1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
|
(when (provided? 'snd-motif)
(with-let (sublet *motif*)
;; set up our user-interface
(let* ((shell (let* ((xdismiss (XmStringCreate "Go away" XmFONTLIST_DEFAULT_TAG))
(xhelp (XmStringCreate "Help" XmFONTLIST_DEFAULT_TAG))
(titlestr (XmStringCreate "FM Forever!" XmFONTLIST_DEFAULT_TAG))
(dialog (XmCreateTemplateDialog (cadr (main-widgets)) "FM Forever!"
(list XmNcancelLabelString xdismiss
XmNhelpLabelString xhelp
XmNautoUnmanage #f
XmNdialogTitle titlestr
XmNwidth 600
XmNresizePolicy XmRESIZE_GROW
XmNnoResize #f
XmNtransient #f))))
(XtAddCallback dialog
XmNhelpCallback (lambda (w context info)
(snd-print "This dialog lets you experiment with simple FM")))
(XmStringFree xhelp)
(XmStringFree xdismiss)
(XmStringFree titlestr)
dialog))
(screen (DefaultScreenOfDisplay (XtDisplay shell)))
(black (BlackPixelOfScreen screen))
(white (WhitePixelOfScreen screen))
(form (XtCreateManagedWidget "form" xmFormWidgetClass shell
(list XmNbackground white
XmNforeground black
XmNresizePolicy XmRESIZE_GROW)))
;; toggle named "play"
(play-button (XtCreateManagedWidget "play" xmToggleButtonWidgetClass form
(list XmNleftAttachment XmATTACH_FORM
XmNbottomAttachment XmATTACH_NONE
XmNtopAttachment XmATTACH_FORM
XmNrightAttachment XmATTACH_NONE
XmNbackground white)))
;; carrier freq
(carrier (XtCreateManagedWidget "carrier freq:" xmLabelWidgetClass form
(list XmNleftAttachment XmATTACH_FORM
XmNbottomAttachment XmATTACH_NONE
XmNtopAttachment XmATTACH_WIDGET
XmNtopWidget play-button
XmNrightAttachment XmATTACH_NONE
XmNrecomputeSize #f
XmNbackground white)))
(freq-label (XtCreateManagedWidget "label" xmLabelWidgetClass form
(list XmNleftAttachment XmATTACH_WIDGET
XmNleftWidget carrier
XmNbottomAttachment XmATTACH_NONE
XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
XmNtopWidget carrier
XmNrightAttachment XmATTACH_NONE
XmNbackground white)))
(freq-scale (XtCreateManagedWidget "carrier freq" xmScaleWidgetClass form
(list XmNleftAttachment XmATTACH_WIDGET
XmNleftWidget freq-label
XmNbottomAttachment XmATTACH_NONE
XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
XmNtopWidget freq-label
XmNrightAttachment XmATTACH_FORM
XmNshowValue #f
XmNorientation XmHORIZONTAL
XmNbackground *position-color*)))
;; amp
(amp-label (XtCreateManagedWidget "label" xmLabelWidgetClass form
(let ((amp (XtCreateManagedWidget "amp:" xmLabelWidgetClass form
(list XmNleftAttachment XmATTACH_FORM
XmNbottomAttachment XmATTACH_NONE
XmNtopAttachment XmATTACH_WIDGET
XmNtopWidget carrier
XmNrightAttachment XmATTACH_NONE
XmNrecomputeSize #f
XmNbackground white))))
(list XmNleftAttachment XmATTACH_WIDGET
XmNleftWidget amp
XmNbottomAttachment XmATTACH_NONE
XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
XmNtopWidget amp
XmNrightAttachment XmATTACH_NONE
XmNbackground white))))
(amp-scale (XtCreateManagedWidget "amp" xmScaleWidgetClass form
(list XmNleftAttachment XmATTACH_WIDGET
XmNleftWidget amp-label
XmNbottomAttachment XmATTACH_NONE
XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
XmNtopWidget amp-label
XmNrightAttachment XmATTACH_FORM
XmNshowValue #f
XmNorientation XmHORIZONTAL
XmNbackground *position-color*)))
;; fm index
(fm-label (XtCreateManagedWidget "label" xmLabelWidgetClass form
(let ((fm-index (XtCreateManagedWidget "fm index:" xmLabelWidgetClass form
(list XmNleftAttachment XmATTACH_FORM
XmNbottomAttachment XmATTACH_NONE
XmNtopAttachment XmATTACH_WIDGET
XmNtopWidget amp-scale
XmNrightAttachment XmATTACH_NONE
XmNrecomputeSize #f
XmNbackground white))))
(list XmNleftAttachment XmATTACH_WIDGET
XmNleftWidget fm-index
XmNbottomAttachment XmATTACH_NONE
XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
XmNtopWidget fm-index
XmNrightAttachment XmATTACH_NONE
XmNbackground white))))
(fm-scale (XtCreateManagedWidget "fm index" xmScaleWidgetClass form
(list XmNleftAttachment XmATTACH_WIDGET
XmNleftWidget fm-label
XmNbottomAttachment XmATTACH_NONE
XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
XmNtopWidget fm-label
XmNrightAttachment XmATTACH_FORM
XmNshowValue #f
XmNorientation XmHORIZONTAL
XmNbackground *position-color*)))
;; c/m ratio
(cm-label (XtCreateManagedWidget "label" xmLabelWidgetClass form
(let ((cm-ratio (XtCreateManagedWidget "c/m ratio:" xmLabelWidgetClass form
(list XmNleftAttachment XmATTACH_FORM
XmNbottomAttachment XmATTACH_NONE
XmNtopAttachment XmATTACH_WIDGET
XmNtopWidget fm-scale
XmNrightAttachment XmATTACH_NONE
XmNrecomputeSize #f
XmNbackground white))))
(list XmNleftAttachment XmATTACH_WIDGET
XmNleftWidget cm-ratio
XmNbottomAttachment XmATTACH_NONE
XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
XmNtopWidget cm-ratio
XmNrightAttachment XmATTACH_NONE
XmNbackground white))))
(cm-scale (XtCreateManagedWidget "cm ratio" xmScaleWidgetClass form
(list XmNleftAttachment XmATTACH_WIDGET
XmNleftWidget cm-label
XmNbottomAttachment XmATTACH_NONE
XmNtopAttachment XmATTACH_OPPOSITE_WIDGET
XmNtopWidget cm-label
XmNrightAttachment XmATTACH_FORM
XmNshowValue #f
XmNorientation XmHORIZONTAL
XmNbackground *position-color*))))
(let ((frequency 220.0)
(low-frequency 40.0)
(high-frequency 2000.0)
(amplitude 0.25)
(index 1.0)
(high-index 3.0)
(ratio 1)
(high-ratio 10)
(playing 0.0)
(set-flabel
(lambda (label value)
(let ((s1 (XmStringCreate (format #f "~,3F" value) XmFONTLIST_DEFAULT_TAG)))
(XtVaSetValues label (list XmNlabelString s1))
(XmStringFree s1))))
(set-ilabel
(lambda (label value)
(let ((s1 (XmStringCreate (format #f "~D" value) XmFONTLIST_DEFAULT_TAG)))
(XtVaSetValues label (list XmNlabelString s1))
(XmStringFree s1)))))
(define (freq-callback w c i)
(set! frequency (+ low-frequency (* (.value i) (/ (- high-frequency low-frequency) 100.0))))
(set-flabel freq-label frequency))
(define (amp-callback w c i)
(set! amplitude (/ (.value i) 100.0))
(set-flabel amp-label amplitude))
(define (fm-callback w c i)
(set! index (* (.value i) (/ high-index 100.0)))
(set-flabel fm-label index))
(define (ratio-callback w c i)
(set! ratio (floor (* (.value i) (/ high-ratio 100.0))))
(set-ilabel cm-label ratio))
(define fm
(let ((carosc (make-oscil 0.0))
(modosc (make-oscil 0.0)))
(lambda ()
(* amplitude playing
(oscil carosc
(+ (hz->radians frequency)
(* index
(oscil modosc
(hz->radians (* ratio frequency))))))))))
;; --------------------------------
;; go-away button
(XtAddCallback shell XmNcancelCallback (lambda (w c i) (stop-playing) (XtUnmanageChild w)))
;; add scale-change (drag and value-changed) callbacks
(XtAddCallback freq-scale XmNdragCallback freq-callback)
(XtAddCallback freq-scale XmNvalueChangedCallback freq-callback)
(XtAddCallback amp-scale XmNdragCallback amp-callback)
(XtAddCallback amp-scale XmNvalueChangedCallback amp-callback)
(XtAddCallback fm-scale XmNdragCallback fm-callback)
(XtAddCallback fm-scale XmNvalueChangedCallback fm-callback)
(XtAddCallback cm-scale XmNdragCallback ratio-callback)
(XtAddCallback cm-scale XmNvalueChangedCallback ratio-callback)
(XtAddCallback play-button XmNvalueChangedCallback (lambda (w c i) (set! playing (if (.set i) 1.0 0.0))))
(XmAddWMProtocolCallback (XtParent shell) (XmInternAtom (XtDisplay (cadr (main-widgets))) "WM_DELETE_WINDOW" #f) (lambda (w c i) (stop-playing)) #f)
;; set initial values
(set-flabel freq-label frequency)
(set-flabel amp-label amplitude)
(set-flabel fm-label index)
(set-ilabel cm-label ratio)
(XmScaleSetValue freq-scale (floor (* 100 (/ (- frequency low-frequency) (- high-frequency low-frequency)))))
(XmScaleSetValue amp-scale (floor (* 100 amplitude)))
(XmScaleSetValue fm-scale (floor (* 100 (/ index high-index))))
(XmScaleSetValue cm-scale (floor (* ratio (/ 100 high-ratio))))
(XtManageChild shell)
(XtRealizeWidget shell)
(play fm)))))
|
