1(provide 'snd-effects-utils.scm) 2(require snd-motif) 3 4(with-let *motif* 5 6 (define raise-dialog 7 (let ((+documentation+ "(raise-dialog w) tries to put 'w' on top of any widgets that are obscuring it")) 8 (lambda (w) 9 (if (and (Widget? w) 10 (XtIsManaged w)) 11 (let ((parent (XtParent w))) 12 (if (and (Widget? parent) 13 (XtIsSubclass parent xmDialogShellWidgetClass)) 14 (XtPopup parent XtGrabNone))))))) 15 16 (define activate-dialog 17 (let ((+documentation+ "(activate-dialog dialog) makes 'dialog' active and brings it to the top of the currently displayed widgets")) 18 (lambda (dialog) 19 ((if (not (XtIsManaged dialog)) XtManageChild raise-dialog) dialog)))) 20 21 (define for-each-child 22 (let ((+documentation+ "(for-each-child w func) applies 'func' to 'w' and to its descendents")) 23 (lambda (w func) 24 (func w) 25 (if (XtIsComposite w) 26 (for-each 27 (lambda (n) 28 (for-each-child n func)) 29 (cadr (XtGetValues w (list XmNchildren 0) 1))))))) 30 31 (define use-combo-box-for-fft-size #f) ; cross-synthesis fft size: radio-buttons or combo-box choice 32 33 (define current-screen 34 (let ((+documentation+ "(current-screen) returns the current X screen number of the current display")) 35 (lambda () 36 (DefaultScreenOfDisplay 37 (XtDisplay (cadr (main-widgets))))))) 38 39 (define all-chans ; for later use in new-effects.scm? 40 (let ((+documentation+ "(all-chans) returns a list of all current sound objects and channel numbers")) 41 (lambda () 42 (let ((sndlist ()) 43 (chnlist ())) 44 (for-each (lambda (snd) 45 (do ((i (- (channels snd) 1) (- i 1))) 46 ((< i 0)) 47 (set! sndlist (cons snd sndlist)) 48 (set! chnlist (cons i chnlist)))) 49 (sounds)) 50 (list sndlist chnlist))))) 51 52 (define update-label 53 (let ((+documentation+ "(update-label effects) evaluates the elements of the list 'effects'")) 54 (lambda (effects) 55 (for-each (lambda (effect) (effect)) effects)))) 56 57 (define effect-target-ok 58 (let ((+documentation+ "(effect-target-ok target) returns #t if the current effect's chosen target is ready")) 59 (lambda (target) 60 (case target 61 ((sound) (pair? (sounds))) 62 ((selection) (selection?)) 63 (else (and (selected-sound) 64 (>= (length (marks (selected-sound) (selected-channel))) 2))))))) 65 66 (define make-effect-dialog 67 (let ((+documentation+ "(make-effect-dialog label ok-callback help-callback reset-callback target-ok-callback) makes a standard effects dialog")) 68 (lambda* (label ok-callback help-callback reset-callback target-ok-callback) 69 ;; make a standard dialog 70 (let* ((xdismiss (XmStringCreate "Go Away" XmFONTLIST_DEFAULT_TAG)) 71 (xhelp (XmStringCreate "Help" XmFONTLIST_DEFAULT_TAG)) 72 (xok (XmStringCreate "DoIt" XmFONTLIST_DEFAULT_TAG)) 73 (titlestr (XmStringCreate label XmFONTLIST_DEFAULT_TAG)) 74 (new-dialog (XmCreateTemplateDialog 75 (cadr (main-widgets)) label 76 (list XmNcancelLabelString xdismiss 77 XmNhelpLabelString xhelp 78 XmNokLabelString xok 79 XmNautoUnmanage #f 80 XmNdialogTitle titlestr 81 XmNresizePolicy XmRESIZE_GROW 82 XmNnoResize #f 83 XmNbackground *basic-color* 84 XmNtransient #f)))) 85 (for-each 86 (lambda (button color) 87 (XtVaSetValues 88 (XmMessageBoxGetChild new-dialog button) 89 (list XmNarmColor *selection-color* 90 XmNbackground color))) 91 (list XmDIALOG_HELP_BUTTON XmDIALOG_CANCEL_BUTTON XmDIALOG_OK_BUTTON) 92 (list *highlight-color* *highlight-color* *highlight-color*)) 93 94 (XtAddCallback new-dialog XmNcancelCallback (lambda (w c i) (XtUnmanageChild new-dialog))) 95 (XtAddCallback new-dialog XmNhelpCallback help-callback) ; "Help" 96 (XtAddCallback new-dialog XmNokCallback ok-callback) ; "DoIt" 97 98 (if reset-callback 99 ;; add a Reset button 100 (let ((reset-button (XtCreateManagedWidget "Reset" xmPushButtonWidgetClass new-dialog 101 (list XmNbackground *highlight-color* 102 XmNforeground (BlackPixelOfScreen (current-screen)) 103 XmNarmColor *selection-color*)))) 104 (XtAddCallback reset-button XmNactivateCallback reset-callback))) 105 (for-each XmStringFree (vector xhelp xok xdismiss titlestr)) 106 107 (if target-ok-callback 108 (begin 109 (XtSetSensitive (XmMessageBoxGetChild new-dialog XmDIALOG_OK_BUTTON) (target-ok-callback)) 110 (hook-push effects-hook 111 (lambda (hook) 112 (XtSetSensitive (XmMessageBoxGetChild new-dialog XmDIALOG_OK_BUTTON) (target-ok-callback))))) 113 (begin 114 (XtSetSensitive (XmMessageBoxGetChild new-dialog XmDIALOG_OK_BUTTON) (pair? (sounds))) 115 (hook-push effects-hook 116 (lambda (hook) 117 (XtSetSensitive (XmMessageBoxGetChild new-dialog XmDIALOG_OK_BUTTON) (pair? (sounds))))))) 118 119 new-dialog)))) 120 121 122;;; replacement for change-menu-label 123 (define change-label 124 (let ((+documentation+ "(change-label widget new-label) changes the label of 'widget' to be 'new-label'")) 125 (lambda (widget new-label) 126 (let ((str (XmStringCreateLocalized new-label))) 127 (XtSetValues widget (list XmNlabelString str)) 128 (XmStringFree str))))) 129 130 131;;; -------- log scaler widget 132 133 (define log-scale-ticks 500) ; sets precision (to some extent) of slider 134 135 (define scale-log->linear 136 (let ((+documentation+ "(scale-log->linear lo val hi) given user-relative low..val..hi returns val as scale-relative (0..log-scale-ticks)")) 137 (lambda (lo val hi) 138 (let ((log-lo (log (max lo 1.0) 2)) 139 (log-hi (log hi 2)) 140 (log-val (log val 2))) 141 (floor (* log-scale-ticks (/ (- log-val log-lo) (- log-hi log-lo)))))))) 142 143 (define scale-linear->log 144 (let ((+documentation+ "(scale-linear->log lo val hi) given user-relative lo..hi and scale-relative val, returns the user-relative val")) 145 (lambda (lo val hi) 146 ;; since log-scale widget assumes 0..log-scale-ticks, val can be used as ratio (log-wise) between lo and hi 147 (let ((log-lo (log (max lo 1.0) 2)) 148 (log-hi (log hi 2))) 149 (expt 2.0 (+ log-lo (* (/ val log-scale-ticks) (- log-hi log-lo)))))))) 150 151 (define scale-log-label 152 (let ((+documentation+ "(scale-log-label lo val hi) makes a log scale label")) 153 (lambda (lo val hi) 154 (format #f "~,2F" (scale-linear->log lo val hi))))) 155 156 (define create-log-scale-widget 157 (let ((+documentation+ "(create-log-scale-widget parent title low initial high) returns a log scale widget")) 158 (lambda (parent title low initial high) 159 (let ((label (XtCreateManagedWidget (format #f "~,2F" initial) xmLabelWidgetClass parent 160 (list XmNbackground *basic-color*))) 161 (scale (XtCreateManagedWidget "scale" xmScaleWidgetClass parent 162 (list XmNorientation XmHORIZONTAL 163 XmNshowValue #f 164 XmNminimum 0 165 XmNmaximum log-scale-ticks 166 XmNvalue (floor (scale-log->linear low initial high)) 167 XmNdecimalPoints 0 168 XmNtitleString title 169 XmNbackground *basic-color*)))) 170 (XtAddCallback scale XmNvalueChangedCallback 171 (lambda (widget context info) 172 (change-label label (scale-log-label low (.value info) high)))) 173 (XtAddCallback scale XmNdragCallback 174 (lambda (widget context info) 175 (change-label label (scale-log-label low (.value info) high)))) 176 scale)))) 177 178 179;;; -------- semitone scaler widget 180;;; 181;;; set up like log scale (use 'semi in place of 'log), 182;;; to get the ratio from the semitones, use (expt 2.0 (/ value 12.0)) -- semitones->ratio below 183 184 (define semi-range 24) ; 2 octaves either way 185 186 (define semi-scale-label 187 (let ((+documentation+ "(semi-scale-label val) makes a semitone label")) 188 (lambda (val) 189 (format #f "semitones: ~D" (- val semi-range))))) 190 191 (define semitones->ratio 192 (let ((+documentation+ "(semitones->ratio val) takes a semitone number 'val' and returns the corresponding float ratio")) 193 (lambda (val) 194 (expt 2.0 (/ val 12.0))))) 195 196 (define ratio->semitones 197 (let ((+documentation+ "(ratio->semitones ratio) takes a float ratio and returns the corresponding number of semitones")) 198 (lambda (ratio) 199 (round (* 12 (log ratio 2)))))) 200 201 (define create-semi-scale-widget 202 (let ((+documentation+ "(create-semi-scale-widget parent title initial) returns a semitone scale widget")) 203 (lambda (parent title initial) 204 (let ((label (XtCreateManagedWidget (format #f "semitones: ~D" (ratio->semitones initial)) xmLabelWidgetClass parent 205 (list XmNbackground *basic-color*))) 206 (scale (XtCreateManagedWidget "scale" xmScaleWidgetClass parent 207 (list XmNorientation XmHORIZONTAL 208 XmNshowValue #f 209 XmNminimum 0 210 XmNmaximum (* 2 semi-range) 211 XmNvalue (+ semi-range (ratio->semitones initial)) 212 XmNdecimalPoints 0 213 XmNtitleString title 214 XmNbackground *basic-color*)))) 215 (XtAddCallback scale XmNvalueChangedCallback 216 (lambda (widget context info) 217 (change-label label (semi-scale-label (.value info))))) 218 (XtAddCallback scale XmNdragCallback 219 (lambda (widget context info) 220 (change-label label (semi-scale-label (.value info))))) 221 scale)))) 222 223 (define add-sliders 224 (let ((+documentation+ "(add-sliders dialog sliders) takes 'sliders', a list of lists, each inner list being (title low initial high callback scale ['log]) \ 225and returns a list of widgets (for reset callbacks)")) 226 (lambda* (dialog sliders) 227 (let ((mainform (let ((mainfrm (XtCreateManagedWidget "formd" xmFormWidgetClass dialog 228 (list XmNleftAttachment XmATTACH_FORM 229 XmNrightAttachment XmATTACH_FORM 230 XmNtopAttachment XmATTACH_FORM 231 XmNbottomAttachment XmATTACH_WIDGET 232 XmNbottomWidget (XmMessageBoxGetChild dialog XmDIALOG_SEPARATOR) 233 XmNbackground *highlight-color*)))) 234 (XtCreateManagedWidget "formd" xmRowColumnWidgetClass mainfrm 235 (list XmNleftAttachment XmATTACH_FORM 236 XmNrightAttachment XmATTACH_FORM 237 XmNbackground *highlight-color* 238 XmNorientation XmVERTICAL))))) 239 (map 240 (lambda (slider-data) 241 (let* ((title (XmStringCreate (slider-data 0) XmFONTLIST_DEFAULT_TAG)) 242 (low (slider-data 1)) 243 (initial (slider-data 2)) 244 (high (slider-data 3)) 245 (func (slider-data 4)) 246 (new-slider (if (= (length slider-data) 7) 247 (if (eq? (slider-data 6) 'log) 248 (create-log-scale-widget mainform title low initial high) 249 (create-semi-scale-widget mainform title initial)) 250 (let ((scale (slider-data 5))) 251 (XtCreateManagedWidget (car slider-data) xmScaleWidgetClass mainform 252 (list XmNorientation XmHORIZONTAL 253 XmNshowValue #t 254 XmNminimum (floor (* low scale)) 255 XmNmaximum (floor (* high scale)) 256 XmNvalue (floor (* initial scale)) 257 XmNdecimalPoints (case scale ((10000) 4) ((1000) 3) ((100) 2) ((10) 1) (else 0)) 258 XmNtitleString title 259 XmNleftAttachment XmATTACH_FORM 260 XmNrightAttachment XmATTACH_FORM 261 XmNbackground *basic-color*)))))) 262 (XmStringFree title) 263 (XtAddCallback new-slider XmNvalueChangedCallback func) 264 new-slider)) 265 sliders))))) 266 267 ) 268