Vous ne pouvez pas sélectionner plus de 25 sujets Les noms de sujets doivent commencer par une lettre ou un nombre, peuvent contenir des tirets ('-') et peuvent comporter jusqu'à 35 caractères.

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534
  1. ;;; bess1.scm -- some examples from clm-2/rt.lisp and clm-2/bess5.cl
  2. ;; Author: Michael Scholz <scholz-micha@gmx.de>
  3. ;; Created: Thu May 29 04:14:35 CEST 2003
  4. ;; Last: Sun Jun 15 03:50:21 CEST 2003
  5. ;; changed slightly 14-Jun-06 Bill to match bess.scm, fix pitch problem in make-oscil.
  6. ;; then again 18-Dec-09 to use s7 rather than Guile
  7. ;; changed float-vector-map! to use a loop instead (Bill 4-July-12)
  8. (if (not (provided? 'snd-motif)) (error "bess1.scm needs motif"))
  9. ;;; Commentary:
  10. ;; This file provides simple mono real time output to DAC. Tempo,
  11. ;; frequency, amplitude, and FM index can be controlled via sliders.
  12. ;; The music algorithms are taken from clm-2/rt.lisp and
  13. ;; clm-2/bess5.cl.
  14. ;; (main) calls (rt-motif) which starts a Motif widget with two DAC
  15. ;; tests.
  16. ;;
  17. ;; (rt-motif :srate *clm-srate* ;; 22050
  18. ;; :bufsize *clm-rt-bufsize* ;; 128
  19. ;; :sample-type *clm-sample-type*) ;; mus-lshort
  20. ;;; Code:
  21. (with-let *motif*
  22. (set! *clm-srate* 22050)
  23. (define *clm-sample-type* mus-lfloat)
  24. (define *clm-rt-bufsize* 1024)
  25. (define *output* #f) ;holds fd from (mus-audio-open-output)
  26. (define ctempo 0.25)
  27. (define camp 1.0)
  28. (define cfreq 1.0)
  29. (define cindex 1.0)
  30. (define cplay #f)
  31. (define sliderback "lightsteelblue")
  32. (define background "lightsteelblue1")
  33. ;(define (seconds->samples secs) (round (* secs *clm-srate*)))
  34. ;; called by XtAppAddWorkProc
  35. (define (rt-send->dac func)
  36. (if cplay
  37. (let ((data (make-float-vector *clm-rt-bufsize*)))
  38. (do ((i 0 (+ i 1)))
  39. ((= i *clm-rt-bufsize*))
  40. (set! (data i) (func)))
  41. (mus-audio-write *output* (copy data (make-float-vector (list 1 *clm-rt-bufsize*))) *clm-rt-bufsize*)
  42. #f)
  43. (begin
  44. (mus-audio-close *output*)
  45. #t)))
  46. (define make-rt-violin
  47. (let ((documentation "(make-rt-violin dur freq amp (fm-index 1.0) (amp-env '(0 0 25 1 75 1 100 0))) real time simple violin (see fm.html)"))
  48. (lambda* (dur freq amp (fm-index 1.0) (amp-env '(0 0 25 1 75 1 100 0)))
  49. (let* ((frq-scl (hz->radians freq))
  50. (maxdev (* frq-scl fm-index)))
  51. (let ((carrier (make-oscil :frequency freq))
  52. (fmosc1 (make-oscil :frequency freq))
  53. (fmosc2 (make-oscil :frequency (* 3 freq)))
  54. (fmosc3 (make-oscil :frequency (* 4 freq)))
  55. (ampf (make-env :envelope amp-env :scaler amp :duration dur))
  56. (indf1 (make-env :envelope '(0 1 25 0.4 75 0.6000000000000001 100 0)
  57. :scaler (* maxdev (/ 5.0 (log freq)))
  58. :duration dur))
  59. (indf2 (make-env :envelope '(0 1 25 0.4 75 0.6000000000000001 100 0)
  60. :scaler (/ (* maxdev 3.0 (- 8.5 (log freq))) (+ 3.0 (/ freq 1000)))
  61. :duration dur))
  62. (indf3 (make-env :envelope '(0 1 25 0.4 75 0.6000000000000001 100 0)
  63. :scaler (* maxdev (/ 4.0 (sqrt freq)))
  64. :duration dur))
  65. (pervib (make-triangle-wave :frequency 5 :amplitude (* 0.0025 frq-scl)))
  66. (ranvib (make-rand-interp :frequency 16 :amplitude (* 0.005 frq-scl))))
  67. (lambda ()
  68. (let ((vib (+ (triangle-wave pervib) (rand-interp ranvib))))
  69. (* (env ampf)
  70. (oscil carrier
  71. (+ vib
  72. (* (env indf1) (oscil fmosc1 vib))
  73. (* (env indf2) (oscil fmosc2 (* 3.0 vib)))
  74. (* (env indf3) (oscil fmosc3 (* 4.0 vib)))))))))))))
  75. (define lim 256)
  76. ;; from clm-2/rt.lisp
  77. (define* (make-float-vector-test (srate *clm-srate*)
  78. (bufsize *clm-rt-bufsize*)
  79. (sample-type *clm-sample-type*))
  80. (let ((vpits (make-vector (+ 1 lim) 0))
  81. (vbegs (make-vector (+ 1 lim) 0)))
  82. (do ((i 0 (+ 1 i)))
  83. ((= i lim))
  84. (set! (vpits i) (random 12))
  85. (set! (vbegs i) (+ 1 (random 3))))
  86. (set! *clm-srate* srate)
  87. (set! *clm-rt-bufsize* bufsize)
  88. (set! *output* (mus-audio-open-output mus-audio-default srate 1 sample-type (* bufsize 2)))
  89. (let ((cellbeg 0)
  90. (cellsiz 6)
  91. (cellctr 0)
  92. (func #f)
  93. (len 0)
  94. (dur 0.0)
  95. (vmode (vector 0 12 2 4 14 4 5 5 0 7 7 11 11)))
  96. (lambda ()
  97. (if (> len 1)
  98. (set! len (- len 1))
  99. (begin
  100. (set! dur (* ctempo (vbegs (+ cellctr 1))))
  101. (set! cellctr (+ cellctr 1))
  102. (if (> cellctr (+ cellsiz cellbeg))
  103. (begin
  104. (if (> (random 1.0) 0.5) (set! cellbeg (+ 1 cellbeg)))
  105. (if (> (random 1.0) 0.5) (set! cellsiz (+ 1 cellsiz)))
  106. (set! cellctr cellbeg)))
  107. (let ((freq (* cfreq 16.351 16
  108. (expt 2 (/ (vmode (vpits cellctr)) 12.0)))))
  109. (format () "dur: ~A, freq: ~A, amp: ~A, index: ~A~%"
  110. dur
  111. (if (< (* 8 freq) *clm-srate*)
  112. freq
  113. (/ freq 4))
  114. (* camp 0.3)
  115. cindex)
  116. (set! func (make-rt-violin dur
  117. (if (< (* 8 freq) *clm-srate*)
  118. freq
  119. (/ freq 4))
  120. (* camp 0.3) :fm-index cindex)))
  121. (set! len (ceiling (/ (seconds->samples dur) bufsize)))))
  122. func))))
  123. ;; from clm-2/bess5.cl and clm-2/clm-example.lisp
  124. (define time 60)
  125. (define mode (vector 0 0 2 4 11 11 5 6 7 9 2 0 0))
  126. (define rats (vector 1.0 256/243 9/8 32/27 81/64 4/3 1024/729 3/2 128/81 27/16 16/9 243/128 2.0))
  127. (define bell '(0 0 10 0.25 90 1.0 100 1.0))
  128. (define pits (make-vector (+ 1 lim) 0))
  129. (define octs (make-vector (+ 1 lim) 0))
  130. (define rhys (make-vector (+ 1 lim) 0))
  131. (define begs (make-vector (+ 1 lim) 0))
  132. (define amps (make-vector (+ 1 lim) 0))
  133. (define (tune x)
  134. (* (rats (modulo x 12))
  135. (expt 2 (floor (/ x 12)))))
  136. (define (rbell x)
  137. (envelope-interp (* x 100) bell))
  138. (define* (make-agn (srate *clm-srate*)
  139. (bufsize *clm-rt-bufsize*)
  140. (sample-type *clm-sample-type*))
  141. (do ((i 0 (+ i 1)))
  142. ((= i lim))
  143. (set! (octs i) (floor (+ 4 (* 2 (rbell (random 1.0))))))
  144. (set! (pits i) (mode (random 12)))
  145. (set! (rhys i) (+ 4 (random 6)))
  146. (set! (begs i) (if (< (random 1.0) 0.9)
  147. (+ 4 (random 2))
  148. (random 24)))
  149. (set! (amps i) (floor (+ 1 (* 8 (rbell (random 1.0)))))))
  150. (set! *clm-srate* srate)
  151. (set! *clm-rt-bufsize* bufsize)
  152. (set! *output* (mus-audio-open-output mus-audio-default srate 1 sample-type (* bufsize 2)))
  153. (let ((wins (vector '(0 0 40 0.1 60 0.2 75 0.4 82 1 90 1 100 0)
  154. '(0 0 60 0.1 80 0.2 90 0.4 95 1 100 0)
  155. '(0 0 10 1 16 0 32 0.1 50 1 56 0 60 0 90 0.3 100 0)
  156. '(0 0 30 1 56 0 60 0 90 0.3 100 0)
  157. '(0 0 50 1 80 0.3 100 0)
  158. '(0 0 40 0.1 60 0.2 75 0.4 82 1 90 1 100 0)
  159. '(0 0 40 0.1 60 0.2 75 0.4 82 1 90 1 100 0)
  160. '(0 0 10 1 32 0.1 50 1 90 0.3 100 0)
  161. '(0 0 60 0.1 80 0.3 95 1 100 0)
  162. '(0 0 80 0.1 90 1 100 0)))
  163. (nextbeg 0.0)
  164. (beg 0.0)
  165. (dur 0.0)
  166. (freq 0.0)
  167. (ampl 0.0)
  168. (ind 0.0)
  169. (cellctr 0)
  170. (cellsiz 4)
  171. (cellbeg 0)
  172. (whichway 1)
  173. (func #f)
  174. (len 0))
  175. (lambda ()
  176. (if (> len 1)
  177. (set! len (- len 1))
  178. (begin
  179. (set! beg (+ beg nextbeg))
  180. (set! nextbeg (+ nextbeg (max 0.025 (* ctempo (+ 0.95 (random 0.1)) (begs cellctr)))))
  181. (set! dur (max 0.025 (* ctempo (+ 0.85 (random 0.1)) (rhys cellctr))))
  182. (set! freq (* cfreq 16.351 (tune (pits cellctr)) (expt 2 (octs cellctr))))
  183. (set! ampl (* camp 10 (max 0.003 (* (amps cellctr) 0.01))))
  184. (set! ind (* cindex (random 3.0)))
  185. (set! cellctr (+ cellctr 1))
  186. (if (> cellctr (+ cellsiz cellbeg))
  187. (begin
  188. (set! cellbeg (+ 1 cellbeg))
  189. (if (> (random 1.0) 0.5) (set! cellsiz (+ cellsiz whichway)))
  190. (cond ((and (> cellsiz 10)
  191. (> (random 1.0) 0.99))
  192. (set! whichway -2))
  193. ((and (> cellsiz 6)
  194. (> (random 1.0) 0.999))
  195. (set! whichway -1))
  196. ((< cellsiz 4)
  197. (set! whichway 1)))
  198. (set! nextbeg (+ nextbeg (random 1.0)))
  199. (set! cellctr cellbeg)))
  200. (set! func (make-rt-violin dur freq ampl
  201. :fm-index ind
  202. :amp-env (wins (floor (* 10 (- beg (floor beg)))))))
  203. (set! len (ceiling (/ (seconds->samples dur) bufsize)))))
  204. func)))
  205. #|
  206. ;; from env.scm
  207. (define* (envelope-interp :rest args)
  208. (let ((x (car args))
  209. (env (cadr args))
  210. (base (if (null? (cddr args)) #f (caddr args))))
  211. (cond ((null? env) 0.0)
  212. ((or (<= x (car env))
  213. (null? (cddr env)))
  214. (cadr env))
  215. ((> (caddr env) x)
  216. (if (or (= (cadr env) (cadddr env))
  217. (and base (= base 0.0)))
  218. (cadr env)
  219. (if (or (not base) (= base 1.0))
  220. (+ (cadr env)
  221. (* (- x (car env))
  222. (/ (- (cadddr env) (cadr env))
  223. (- (caddr env) (car env)))))
  224. (+ (cadr env)
  225. (* (/ (- (cadddr env) (cadr env))
  226. (- base 1.0))
  227. (- (expt base (/ (- x (car env))
  228. (- (caddr env) (car env))))
  229. 1.0))))))
  230. (else (envelope-interp x (cddr env))))))
  231. |#
  232. (define* (rt-motif :rest args)
  233. (let* ((shell-app (XtVaOpenApplication
  234. "FM" 0 () applicationShellWidgetClass
  235. (list XmNallowShellResize #t)))
  236. (app (cadr shell-app))
  237. (shell (car shell-app))
  238. (dpy (XtDisplay shell))
  239. (black (BlackPixelOfScreen (DefaultScreenOfDisplay dpy))))
  240. (define (get-color color)
  241. (let ((col (XColor))
  242. (cmap (DefaultColormap dpy (DefaultScreen dpy))))
  243. (if (= (XAllocNamedColor dpy cmap color col col) 0)
  244. (error (format #f "can't allocate ~A" color))
  245. (.pixel col))))
  246. (define (set-flabel label value)
  247. (let ((s1 (XmStringCreate (format #f "~5,3F" value) XmFONTLIST_DEFAULT_TAG)))
  248. (XtVaSetValues label (list XmNlabelString s1))
  249. (XmStringFree s1)))
  250. (XtSetValues shell (list XmNtitle "FM Forever!"))
  251. (let* ((light-blue (get-color sliderback))
  252. (form (XtCreateManagedWidget "form" xmFormWidgetClass shell
  253. (list XmNbackground (get-color background)
  254. XmNforeground black
  255. XmNresizePolicy XmRESIZE_GROW)))
  256. ;; play
  257. (play-button (XtCreateManagedWidget "play" xmToggleButtonWidgetClass form
  258. (list XmNleftAttachment XmATTACH_FORM
  259. XmNbottomAttachment XmATTACH_NONE
  260. XmNtopAttachment XmATTACH_FORM
  261. XmNrightAttachment XmATTACH_NONE
  262. XmNbackground (get-color background))))
  263. ;; radio
  264. (radio (XmCreateRadioBox form "radio"
  265. (list XmNorientation XmHORIZONTAL
  266. XmNleftAttachment XmATTACH_WIDGET
  267. XmNleftWidget play-button
  268. XmNbottomAttachment XmATTACH_NONE
  269. XmNtopAttachment XmATTACH_FORM
  270. XmNrightAttachment XmATTACH_NONE
  271. XmNbackground (get-color background))))
  272. ;; play agn
  273. (agn-button (XtCreateManagedWidget "agn" xmToggleButtonWidgetClass radio
  274. (list XmNleftAttachment XmATTACH_FORM
  275. XmNbottomAttachment XmATTACH_NONE
  276. XmNtopAttachment XmATTACH_FORM
  277. XmNrightAttachment XmATTACH_NONE
  278. XmNbackground (get-color background))))
  279. ;; play test
  280. (test-button (XtCreateManagedWidget "test" xmToggleButtonWidgetClass radio
  281. (list XmNleftAttachment XmATTACH_WIDGET
  282. XmNleftWidget agn-button
  283. XmNbottomAttachment XmATTACH_NONE
  284. XmNtopAttachment XmATTACH_FORM
  285. XmNrightAttachment XmATTACH_NONE
  286. XmNbackground (get-color background))))
  287. ;; quit
  288. (quit-button (XtCreateManagedWidget " quit " xmPushButtonWidgetClass form
  289. (list XmNleftAttachment XmATTACH_WIDGET
  290. XmNleftWidget radio
  291. XmNbottomAttachment XmATTACH_NONE
  292. XmNtopAttachment XmATTACH_FORM
  293. XmNrightAttachment XmATTACH_FORM
  294. XmNbackground (get-color background))))
  295. (tempo (let ((sep (XtCreateManagedWidget "sep" xmSeparatorWidgetClass form
  296. (list XmNleftAttachment XmATTACH_FORM
  297. XmNbottomAttachment XmATTACH_NONE
  298. XmNtopAttachment XmATTACH_WIDGET
  299. XmNtopWidget radio
  300. XmNrightAttachment XmATTACH_FORM
  301. XmNheight 4
  302. XmNorientation XmHORIZONTAL))))
  303. (XtCreateManagedWidget " tempo:" xmLabelWidgetClass form
  304. (list XmNleftAttachment XmATTACH_FORM
  305. XmNbottomAttachment XmATTACH_NONE
  306. XmNtopAttachment XmATTACH_WIDGET
  307. XmNtopWidget sep
  308. XmNrightAttachment XmATTACH_NONE
  309. XmNrecomputeSize #f
  310. XmNbackground (get-color background)))))
  311. (tempo-label (XtCreateManagedWidget "label" xmLabelWidgetClass form
  312. (list XmNleftAttachment XmATTACH_WIDGET
  313. XmNleftWidget tempo
  314. XmNbottomAttachment XmATTACH_NONE
  315. XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
  316. XmNtopWidget tempo
  317. XmNrightAttachment XmATTACH_NONE
  318. XmNbackground (get-color background))))
  319. (tempo-scale (XtCreateManagedWidget "tempo" xmScaleWidgetClass form
  320. (list XmNleftAttachment XmATTACH_WIDGET
  321. XmNleftWidget tempo-label
  322. XmNbottomAttachment XmATTACH_NONE
  323. XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
  324. XmNtopWidget tempo-label
  325. XmNrightAttachment XmATTACH_FORM
  326. XmNshowValue #f
  327. XmNorientation XmHORIZONTAL
  328. XmNheight 20
  329. XmNbackground light-blue)))
  330. ;; freq
  331. (freq (XtCreateManagedWidget " freq:" xmLabelWidgetClass form
  332. (list XmNleftAttachment XmATTACH_FORM
  333. XmNbottomAttachment XmATTACH_NONE
  334. XmNtopAttachment XmATTACH_WIDGET
  335. XmNtopWidget tempo
  336. XmNrightAttachment XmATTACH_NONE
  337. XmNrecomputeSize #f
  338. XmNbackground (get-color background))))
  339. (freq-label (XtCreateManagedWidget "label" xmLabelWidgetClass form
  340. (list XmNleftAttachment XmATTACH_WIDGET
  341. XmNleftWidget freq
  342. XmNbottomAttachment XmATTACH_NONE
  343. XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
  344. XmNtopWidget freq
  345. XmNrightAttachment XmATTACH_NONE
  346. XmNbackground (get-color background))))
  347. (freq-scale (XtCreateManagedWidget "freq" xmScaleWidgetClass form
  348. (list XmNleftAttachment XmATTACH_WIDGET
  349. XmNleftWidget freq-label
  350. XmNbottomAttachment XmATTACH_NONE
  351. XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
  352. XmNtopWidget freq-label
  353. XmNrightAttachment XmATTACH_FORM
  354. XmNshowValue #f
  355. XmNorientation XmHORIZONTAL
  356. XmNheight 20
  357. XmNbackground light-blue)))
  358. ;; amp
  359. (amp (XtCreateManagedWidget " amp:" xmLabelWidgetClass form
  360. (list XmNleftAttachment XmATTACH_FORM
  361. XmNbottomAttachment XmATTACH_NONE
  362. XmNtopAttachment XmATTACH_WIDGET
  363. XmNtopWidget freq
  364. XmNrightAttachment XmATTACH_NONE
  365. XmNrecomputeSize #f
  366. XmNbackground (get-color background))))
  367. (amp-label (XtCreateManagedWidget "label" xmLabelWidgetClass form
  368. (list XmNleftAttachment XmATTACH_WIDGET
  369. XmNleftWidget amp
  370. XmNbottomAttachment XmATTACH_NONE
  371. XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
  372. XmNtopWidget amp
  373. XmNrightAttachment XmATTACH_NONE
  374. XmNbackground (get-color background))))
  375. (amp-scale (XtCreateManagedWidget "amp" xmScaleWidgetClass form
  376. (list XmNleftAttachment XmATTACH_WIDGET
  377. XmNleftWidget amp-label
  378. XmNbottomAttachment XmATTACH_NONE
  379. XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
  380. XmNtopWidget amp-label
  381. XmNrightAttachment XmATTACH_FORM
  382. XmNshowValue #f
  383. XmNorientation XmHORIZONTAL
  384. XmNheight 20
  385. XmNbackground light-blue)))
  386. (index-label (let ((index (XtCreateManagedWidget " index:" xmLabelWidgetClass form
  387. (list XmNleftAttachment XmATTACH_FORM
  388. XmNbottomAttachment XmATTACH_NONE
  389. XmNtopAttachment XmATTACH_WIDGET
  390. XmNtopWidget amp
  391. XmNrightAttachment XmATTACH_NONE
  392. XmNrecomputeSize #f
  393. XmNbackground (get-color background)))))
  394. (XtCreateManagedWidget "label" xmLabelWidgetClass form
  395. (list XmNleftAttachment XmATTACH_WIDGET
  396. XmNleftWidget index
  397. XmNbottomAttachment XmATTACH_NONE
  398. XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
  399. XmNtopWidget index
  400. XmNrightAttachment XmATTACH_NONE
  401. XmNbackground (get-color background)))))
  402. (index-scale (XtCreateManagedWidget "index" xmScaleWidgetClass form
  403. (list XmNleftAttachment XmATTACH_WIDGET
  404. XmNleftWidget index-label
  405. XmNbottomAttachment XmATTACH_NONE
  406. XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
  407. XmNtopWidget index-label
  408. XmNrightAttachment XmATTACH_FORM
  409. XmNshowValue #f
  410. XmNorientation XmHORIZONTAL
  411. XmNheight 20
  412. XmNbackground light-blue))))
  413. (let ((low-tempo 0.05)
  414. (high-tempo 0.5)
  415. (low-freq 0.1)
  416. (high-freq 4.0)
  417. (high-index 2.0)
  418. (which-play 0)
  419. (proc #f)
  420. (func #f))
  421. (define (tempo-callback w c i)
  422. (set! ctempo (+ low-tempo (* (.value i) (/ (- high-tempo low-tempo) 100.0))))
  423. (set-flabel tempo-label ctempo))
  424. (define (amp-callback w c i)
  425. (let ((high-amp 1.0))
  426. (set! camp (* (.value i) (/ high-amp 100.0))))
  427. (set-flabel amp-label camp))
  428. (define (freq-callback w c i)
  429. (set! cfreq (+ low-freq (* (.value i) (/ (- high-freq low-freq) 100.0))))
  430. (set-flabel freq-label cfreq))
  431. (define (index-callback w c i)
  432. (set! cindex (* (.value i) (/ high-index 100.0)))
  433. (set-flabel index-label cindex))
  434. (define (set-defaults)
  435. (set! ctempo 0.25)
  436. (set! camp 1.0)
  437. (set! cfreq 1.0)
  438. (set! cindex 1.0)
  439. (set-flabel tempo-label ctempo)
  440. (set-flabel amp-label camp)
  441. (set-flabel freq-label cfreq)
  442. (set-flabel index-label cindex)
  443. (XmScaleSetValue tempo-scale (floor (* 100 (/ (- ctempo low-tempo) (- high-tempo low-tempo)))))
  444. (XmScaleSetValue freq-scale (floor (* 100 (/ (- cfreq low-freq) (- high-freq low-freq)))))
  445. (XmScaleSetValue amp-scale (floor (* 100 camp)))
  446. (XmScaleSetValue index-scale (floor (* 100 (/ cindex high-index)))))
  447. (XtManageChild radio)
  448. ;; add scale-change (drag and value-changed) callbacks
  449. (XtAddCallback tempo-scale XmNdragCallback tempo-callback)
  450. (XtAddCallback tempo-scale XmNvalueChangedCallback tempo-callback)
  451. (XtAddCallback amp-scale XmNdragCallback amp-callback)
  452. (XtAddCallback amp-scale XmNvalueChangedCallback amp-callback)
  453. (XtAddCallback freq-scale XmNdragCallback freq-callback)
  454. (XtAddCallback freq-scale XmNvalueChangedCallback freq-callback)
  455. (XtAddCallback index-scale XmNdragCallback index-callback)
  456. (XtAddCallback index-scale XmNvalueChangedCallback index-callback)
  457. (XtAddCallback agn-button XmNvalueChangedCallback
  458. (lambda (w c i)
  459. (if (.set i)
  460. (set! which-play 0))
  461. (set! cplay #f)
  462. (XmToggleButtonSetState play-button cplay #f)))
  463. (XmToggleButtonSetState agn-button #t #f)
  464. (XtAddCallback test-button XmNvalueChangedCallback
  465. (lambda (w c i)
  466. (if (.set i)
  467. (set! which-play 1))
  468. (set! cplay #f)
  469. (XmToggleButtonSetState play-button cplay #f)))
  470. (XtAddCallback quit-button XmNactivateCallback
  471. (lambda (w c i)
  472. (set! cplay #f)
  473. (if proc (XtRemoveWorkProc proc))
  474. (exit 0)))
  475. (XtAddCallback play-button XmNvalueChangedCallback
  476. (lambda (w c i)
  477. (set! cplay (.set i))
  478. (if cplay
  479. (begin
  480. (set-defaults)
  481. (set! func (apply (if (= which-play 0) make-agn make-float-vector-test) (or args ())))
  482. (set! proc (XtAppAddWorkProc app (lambda (c) (rt-send->dac func)))))
  483. (if proc (XtRemoveWorkProc proc)))))
  484. (XmToggleButtonSetState play-button cplay #f)
  485. (set-defaults)
  486. (XtRealizeWidget shell))
  487. (XtAppMainLoop app))))
  488. (rt-motif)
  489. )
  490. ;; bess1.scm ends here