dom
/
tonalisa
Watch 1
Star 0
Fork 0
Code Issues 0 Pull Requests 0 Releases 0 Wiki Activity
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
1 Commit
1 Branch
Tree: e37c040080
Branches Tags
${ item.name }
Create branch ${ searchTerm }
from 'e37c040080'
${ noResults }
tonalisa/lib/sndlib/bess.scm

250 lines
10KB
Raw Blame History 

  1. ;;; this is obsolete -- it needs some replacement for the mus-audio* functions

  2. 

  3. (when (provided? 'snd-motif)

  4.   (with-let (sublet *motif*)

  5.     ;; set up our user-interface

  6.     (let* ((app (car (main-widgets)))

  7. 	   

  8. 	   (shell (let* ((xdismiss (XmStringCreate "Go away" XmFONTLIST_DEFAULT_TAG))

  9. 			 (xhelp (XmStringCreate "Help" XmFONTLIST_DEFAULT_TAG))

  10. 			 (titlestr (XmStringCreate "FM Forever!" XmFONTLIST_DEFAULT_TAG))

  11. 			 (dialog (XmCreateTemplateDialog (cadr (main-widgets)) "FM Forever!"

  12. 							 (list XmNcancelLabelString   xdismiss

  13. 							       XmNhelpLabelString     xhelp

  14. 							       XmNautoUnmanage        #f

  15. 							       XmNdialogTitle         titlestr

  16. 							       XmNresizePolicy        XmRESIZE_GROW

  17. 							       XmNnoResize            #f

  18. 							       XmNtransient           #f))))

  19. 		    (XtAddCallback dialog 

  20. 				   XmNhelpCallback (lambda (w context info)

  21. 						     (snd-print "This dialog lets you experiment with simple FM")))

  22. 		    (XmStringFree xhelp)

  23. 		    (XmStringFree xdismiss)

  24. 		    (XmStringFree titlestr)

  25. 		    dialog))

  26. 	   

  27. 	   (dpy (XtDisplay shell))

  28. 	   (screen (DefaultScreenOfDisplay dpy))

  29. 	   ;; (cmap (DefaultColormap dpy (DefaultScreen dpy)))

  30. 	   (black (BlackPixelOfScreen screen))

  31. 	   (white (WhitePixelOfScreen screen)))

  32.       

  33.       (define (set-flabel label value)

  34. 	(let ((s1 (XmStringCreate (format #f "~,3F" value) XmFONTLIST_DEFAULT_TAG)))

  35. 	  (XtVaSetValues label (list XmNlabelString s1))

  36. 	  (XmStringFree s1)))

  37.       

  38.       (define (set-ilabel label value)

  39. 	(let ((s1 (XmStringCreate (format #f "~D" value) XmFONTLIST_DEFAULT_TAG)))

  40. 	  (XtVaSetValues label (list XmNlabelString s1))

  41. 	  (XmStringFree s1)))

  42.       

  43.       (let* ((form (XtCreateManagedWidget "form" xmFormWidgetClass shell 

  44. 					  (list XmNbackground white

  45. 						XmNforeground black

  46. 						XmNresizePolicy XmRESIZE_GROW)))

  47. 	     ;; toggle named "play"

  48. 	     (play-button (XtCreateManagedWidget "play" xmToggleButtonWidgetClass form

  49. 						 (list XmNleftAttachment   XmATTACH_FORM

  50. 						       XmNbottomAttachment XmATTACH_NONE

  51. 						       XmNtopAttachment    XmATTACH_FORM

  52. 						       XmNrightAttachment  XmATTACH_NONE

  53. 						       XmNbackground       white)))

  54. 	     ;; carrier freq

  55. 	     (carrier (XtCreateManagedWidget "carrier freq:" xmLabelWidgetClass form

  56. 					     (list XmNleftAttachment   XmATTACH_FORM

  57. 						   XmNbottomAttachment XmATTACH_NONE

  58. 						   XmNtopAttachment    XmATTACH_WIDGET

  59. 						   XmNtopWidget        play-button

  60. 						   XmNrightAttachment  XmATTACH_NONE

  61. 						   XmNrecomputeSize    #f

  62. 						   XmNbackground       white)))

  63. 	     (freq-label (XtCreateManagedWidget "label" xmLabelWidgetClass form

  64. 						(list XmNleftAttachment   XmATTACH_WIDGET

  65. 						      XmNleftWidget       carrier

  66. 						      XmNbottomAttachment XmATTACH_NONE

  67. 						      XmNtopAttachment    XmATTACH_OPPOSITE_WIDGET

  68. 						      XmNtopWidget        carrier

  69. 						      XmNrightAttachment  XmATTACH_NONE

  70. 						      XmNbackground       white)))

  71. 	     (freq-scale (XtCreateManagedWidget "carrier freq" xmScaleWidgetClass form

  72. 						(list XmNleftAttachment   XmATTACH_WIDGET

  73. 						      XmNleftWidget       freq-label

  74. 						      XmNbottomAttachment XmATTACH_NONE

  75. 						      XmNtopAttachment    XmATTACH_OPPOSITE_WIDGET

  76. 						      XmNtopWidget        freq-label

  77. 						      XmNrightAttachment  XmATTACH_FORM

  78. 						      XmNshowValue        #f

  79. 						      XmNorientation      XmHORIZONTAL

  80. 						      XmNbackground       *position-color*)))

  81. 	     ;; amp

  82. 	     (amp-label (XtCreateManagedWidget "label" xmLabelWidgetClass form

  83. 					       (let ((amp (XtCreateManagedWidget "amp:" xmLabelWidgetClass form

  84. 										 (list XmNleftAttachment   XmATTACH_FORM

  85. 										       XmNbottomAttachment XmATTACH_NONE

  86. 										       XmNtopAttachment    XmATTACH_WIDGET

  87. 										       XmNtopWidget        carrier

  88. 										       XmNrightAttachment  XmATTACH_NONE

  89. 										       XmNrecomputeSize    #f

  90. 										       XmNbackground       white))))

  91. 						 (list XmNleftAttachment   XmATTACH_WIDGET

  92. 						       XmNleftWidget       amp

  93. 						       XmNbottomAttachment XmATTACH_NONE

  94. 						       XmNtopAttachment    XmATTACH_OPPOSITE_WIDGET

  95. 						       XmNtopWidget        amp

  96. 						       XmNrightAttachment  XmATTACH_NONE

  97. 						       XmNbackground       white))))

  98. 	     (amp-scale (XtCreateManagedWidget "amp" xmScaleWidgetClass form

  99. 					       (list XmNleftAttachment   XmATTACH_WIDGET

  100. 						     XmNleftWidget       amp-label

  101. 						     XmNbottomAttachment XmATTACH_NONE

  102. 						     XmNtopAttachment    XmATTACH_OPPOSITE_WIDGET

  103. 						     XmNtopWidget        amp-label

  104. 						     XmNrightAttachment  XmATTACH_FORM

  105. 						     XmNshowValue        #f

  106. 						     XmNorientation      XmHORIZONTAL

  107. 						     XmNbackground       *position-color*)))

  108. 	     ;; fm index

  109. 	     (fm-label (XtCreateManagedWidget "label" xmLabelWidgetClass form

  110. 					      (let ((fm-index (XtCreateManagedWidget "fm index:" xmLabelWidgetClass form

  111. 										     (list XmNleftAttachment   XmATTACH_FORM

  112. 											   XmNbottomAttachment XmATTACH_NONE

  113. 											   XmNtopAttachment    XmATTACH_WIDGET

  114. 											   XmNtopWidget        amp-scale

  115. 											   XmNrightAttachment  XmATTACH_NONE

  116. 											   XmNrecomputeSize    #f

  117. 											   XmNbackground       white))))

  118. 						(list XmNleftAttachment   XmATTACH_WIDGET

  119. 						      XmNleftWidget       fm-index

  120. 						      XmNbottomAttachment XmATTACH_NONE

  121. 						      XmNtopAttachment    XmATTACH_OPPOSITE_WIDGET

  122. 						      XmNtopWidget        fm-index

  123. 						      XmNrightAttachment  XmATTACH_NONE

  124. 						      XmNbackground       white))))

  125. 	     (fm-scale (XtCreateManagedWidget "fm index" xmScaleWidgetClass form

  126. 					      (list XmNleftAttachment   XmATTACH_WIDGET

  127. 						    XmNleftWidget       fm-label

  128. 						    XmNbottomAttachment XmATTACH_NONE

  129. 						    XmNtopAttachment    XmATTACH_OPPOSITE_WIDGET

  130. 						    XmNtopWidget        fm-label

  131. 						    XmNrightAttachment  XmATTACH_FORM

  132. 						    XmNshowValue        #f

  133. 						    XmNorientation      XmHORIZONTAL

  134. 						    XmNbackground       *position-color*)))

  135. 	     ;; c/m ratio

  136. 	     (cm-label (XtCreateManagedWidget "label" xmLabelWidgetClass form

  137. 					      (let ((cm-ratio (XtCreateManagedWidget "c/m ratio:" xmLabelWidgetClass form

  138. 										     (list XmNleftAttachment   XmATTACH_FORM

  139. 											   XmNbottomAttachment XmATTACH_NONE

  140. 											   XmNtopAttachment    XmATTACH_WIDGET

  141. 											   XmNtopWidget        fm-scale

  142. 											   XmNrightAttachment  XmATTACH_NONE

  143. 											   XmNrecomputeSize    #f

  144. 											   XmNbackground       white))))

  145. 						(list XmNleftAttachment   XmATTACH_WIDGET

  146. 						      XmNleftWidget       cm-ratio

  147. 						      XmNbottomAttachment XmATTACH_NONE

  148. 						      XmNtopAttachment    XmATTACH_OPPOSITE_WIDGET

  149. 						      XmNtopWidget        cm-ratio

  150. 						      XmNrightAttachment  XmATTACH_NONE

  151. 						      XmNbackground       white))))

  152. 	     (cm-scale (XtCreateManagedWidget "cm ratio" xmScaleWidgetClass form

  153. 					      (list XmNleftAttachment   XmATTACH_WIDGET

  154. 						    XmNleftWidget       cm-label

  155. 						    XmNbottomAttachment XmATTACH_NONE

  156. 						    XmNtopAttachment    XmATTACH_OPPOSITE_WIDGET

  157. 						    XmNtopWidget        cm-label

  158. 						    XmNrightAttachment  XmATTACH_FORM

  159. 						    XmNshowValue        #f

  160. 						    XmNorientation      XmHORIZONTAL

  161. 						    XmNbackground       *position-color*))))

  162. 	(let ((frequency 220.0)

  163. 	      (low-frequency 40.0)

  164. 	      (high-frequency 2000.0)

  165. 	      (amplitude 0.5)

  166. 	      (index 1.0)

  167. 	      (high-index 3.0)

  168. 	      (ratio 1)

  169. 	      (high-ratio 10)

  170. 	      (playing 0.0)

  171. 	      (carosc (make-oscil 0.0))

  172. 	      (modosc (make-oscil 0.0)))

  173. 	  

  174. 	  (define (freq-callback w c i)

  175. 	    (set! frequency (+ low-frequency (* (.value i) (/ (- high-frequency low-frequency) 100.0))))

  176. 	    (set-flabel freq-label frequency))

  177. 	  

  178. 	  (define (amp-callback w c i)

  179. 	    (set! amplitude (/ (.value i) 100.0))

  180. 	    (set-flabel amp-label amplitude))

  181. 	  

  182. 	  (define (fm-callback w c i)

  183. 	    (set! index (* (.value i) (/ high-index 100.0)))

  184. 	    (set-flabel fm-label index))

  185. 	  

  186. 	  (define (ratio-callback w c i)

  187. 	    (set! ratio (floor (* (.value i) (/ high-ratio 100.0))))

  188. 	    (set-ilabel cm-label ratio))

  189. 	  

  190. 	  ;; add scale-change (drag and value-changed) callbacks

  191. 	  (XtAddCallback freq-scale XmNdragCallback freq-callback)

  192. 	  (XtAddCallback freq-scale XmNvalueChangedCallback freq-callback)

  193. 	  

  194. 	  (XtAddCallback amp-scale XmNdragCallback amp-callback)

  195. 	  (XtAddCallback amp-scale XmNvalueChangedCallback amp-callback)

  196. 	  

  197. 	  (XtAddCallback fm-scale XmNdragCallback fm-callback)

  198. 	  (XtAddCallback fm-scale XmNvalueChangedCallback fm-callback)

  199. 	  

  200. 	  (XtAddCallback cm-scale XmNdragCallback ratio-callback)

  201. 	  (XtAddCallback cm-scale XmNvalueChangedCallback ratio-callback)

  202. 	  

  203. 	  (XtAddCallback play-button XmNvalueChangedCallback (lambda (w c i) (set! playing (if (.set i) 1.0 0.0))))

  204. 	  

  205. 	  ;; set initial values

  206. 	  (set-flabel freq-label frequency)

  207. 	  (set-flabel amp-label amplitude)

  208. 	  (set-flabel fm-label index)

  209. 	  (set-ilabel cm-label ratio)

  210. 	  

  211. 	  (XmScaleSetValue freq-scale (floor (* 100 (/ (- frequency low-frequency) (- high-frequency low-frequency)))))

  212. 	  (XmScaleSetValue amp-scale (floor (* 100 amplitude)))

  213. 	  (XmScaleSetValue fm-scale (floor (* 100 (/ index high-index))))

  214. 	  (XmScaleSetValue cm-scale (floor (* ratio (/ 100 high-ratio))))

  215. 	  

  216. 	  (XtManageChild shell)

  217. 	  (XtRealizeWidget shell)

  218. 	  

  219. 	  ;; send fm data to dac

  220. 	  (let* ((bufsize 256)

  221. 		 (work-proc #f)

  222. 		 (port (mus-audio-open-output mus-audio-default 22050 1 mus-lshort (* bufsize 2))))

  223. 	    (if (< port 0) 

  224. 		(format () "can't open DAC!"))

  225. 	    

  226. 	    (XmAddWMProtocolCallback (cadr (main-widgets)) ; shell

  227. 				     (XmInternAtom dpy "WM_DELETE_WINDOW" #f)

  228. 				     (lambda (w c i)

  229. 				       (XtRemoveWorkProc work-proc) ; odd that there's no XtAppRemoveWorkProc

  230. 				       (mus-audio-close port))

  231. 				     #f)

  232. 	    (XtAddCallback shell

  233. 			   XmNcancelCallback (lambda (w context info)

  234. 					       (XtRemoveWorkProc work-proc)

  235. 					       (mus-audio-close port)

  236. 					       (XtUnmanageChild shell)))

  237. 	    (set! work-proc (XtAppAddWorkProc app 

  238. 					      (lambda (ignored-arg)

  239. 						(let ((data (make-float-vector bufsize)))

  240. 						  (do ((i 0 (+ 1 i)))

  241. 						      ((= i bufsize))

  242. 						    (float-vector-set! data i (* amplitude playing

  243. 										 (oscil carosc 

  244. 											(+ (hz->radians frequency)

  245. 											   (* index 

  246. 											      (oscil modosc 

  247. 												     (hz->radians (* ratio frequency)))))))))

  248. 						  (mus-audio-write port data bufsize)

  249. 						  #f))))))))))