1(provide 'snd-marks-menu.scm) 2 3(if (provided? 'xm) 4 (begin 5 (require snd-effects-utils.scm) 6 (if (not (defined? 'mark-sync-color)) 7 (load "snd-motif.scm")))) 8 9(when (provided? 'snd-motif) 10 (define mark-sync-color (*motif* 'mark-sync-color))) 11 12(if (not (defined? 'mark-loops)) (load "examp.scm")) 13(if (not (defined? 'play-between-marks)) (load "marks.scm")) 14(if (not (defined? 'loop-between-marks)) (load "play.scm")) 15 16(define *e* *motif*) 17(define update-label (*e* 'update-label)) 18(define change-label (*e* 'change-label)) 19(define make-effect-dialog (*e* 'make-effect-dialog)) 20(define add-sliders (*e* 'add-sliders)) 21(define activate-dialog (*e* 'activate-dialog)) 22(define select-file (*e* 'select-file)) 23 24(define marks-list ()) ; menu labels are updated to show current default settings 25 26(define marks-menu (add-to-main-menu "Marks" (lambda () 27 (update-label marks-list)))) 28(define find-two-marks 29 (let ((+documentation+ "(find-two-marks) looks for the marks for the marks-menu functions to use")) 30 (lambda () 31 (let ((ms (marks (selected-sound) (selected-channel)))) 32 (if (> (length ms) 1) 33 (map mark->integer (list (car ms) (cadr ms))) 34 ()))))) 35 36 37;;; -------- Play between by marks 38 39(define play-between-marks-m1 0) 40(define play-between-marks-m2 1) 41(define play-between-marks-label "Play between marks") 42(define play-between-marks-dialog #f) 43(define play-between-marks-menu-label #f) 44 45(define cp-play-between-marks 46 (let ((+documentation+ "(cp-play-between-marks) plays between 2 marks (marks-menu)")) 47 (lambda () 48 (play-between-marks (integer->mark play-between-marks-m1) (integer->mark play-between-marks-m2))))) 49 50(if (not (or (provided? 'xm) 51 (provided? 'xg))) 52 (set! play-between-marks-menu-label (add-to-menu marks-menu play-between-marks-label cp-play-between-marks)) 53 (begin 54 55 (define (set-syncs) 56 (for-each 57 (lambda (snd-marks) 58 (for-each 59 (lambda (chan-marks) 60 (for-each 61 (lambda (m) 62 (set! (sync m) (if (or (= (mark->integer m) play-between-marks-m1) 63 (= (mark->integer m) play-between-marks-m2)) 64 1 0))) 65 chan-marks)) 66 snd-marks)) 67 (marks)) 68 (update-time-graph)) 69 70 (define (max-mark) ; "id" here 71 (apply max (map mark->integer (marks (selected-sound) (selected-channel))))) 72 73 (define (min-mark) 74 (apply min (map mark->integer (marks (selected-sound) (selected-channel))))) 75 76 (define (post-play-between-marks-dialog) 77 (unless play-between-marks-dialog 78 (let ((inits (find-two-marks)) 79 (max-mark-id (max-mark)) 80 (sliders ())) 81 82 (if (null? inits) 83 (snd-display ";no marks") 84 85 (begin 86 (set! play-between-marks-m1 (car inits)) 87 (set! play-between-marks-m2 (cadr inits)) 88 (set-syncs) 89 (mark-sync-color "yellow") 90 91 (set! play-between-marks-dialog 92 (make-effect-dialog play-between-marks-label 93 (values (lambda (w context info) 94 (cp-play-between-marks)) 95 (lambda (w context info) 96 (help-dialog "Define selection by marks Help" 97 "Plays area between specified marks. Use the sliders to select the boundary marks.")) 98 (lambda (w c i) 99 ((*motif* 'XtSetValues) (sliders 0) (list (*motif* 'XmNvalue) play-between-marks-m1)) 100 ((*motif* 'XtSetValues) (sliders 1) (list (*motif* 'XmNvalue) play-between-marks-m2)))))) 101 (set! sliders 102 (add-sliders 103 play-between-marks-dialog 104 (list (let ((plyf1 (lambda (w context info) 105 (set! play-between-marks-m1 ((*motif* '.value) info)) 106 (set-syncs)))) 107 (list "mark one" 0 play-between-marks-m1 max-mark-id plyf1 1)) 108 (let ((plyf2 (lambda (w context info) 109 (set! play-between-marks-m2 ((*motif* '.value) info)) 110 (set-syncs)))) 111 (list "mark two" 0 play-between-marks-m2 max-mark-id plyf2 1))))) 112 113 (if (provided? 'snd-motif) 114 (with-let (sublet *motif*) 115 (hook-push select-channel-hook (lambda (hook) 116 (let ((max-ms (max-mark)) 117 (min-ms (min-mark)) 118 (current-ms (find-two-marks))) 119 (if (null? current-ms) 120 (set! current-ms (list min-ms max-ms))) 121 (if max-ms 122 (for-each 123 (lambda (slider) 124 (XtVaSetValues slider 125 (list XmNmaximum max-ms 126 XmNminimum min-ms 127 XmNvalue (car current-ms))) 128 (set! current-ms (cdr current-ms))) 129 sliders))))) 130 (hook-push mark-hook (lambda (hook) 131 (if (and (= (hook 'snd) (selected-sound)) 132 (= (hook 'chn) (selected-channel)) 133 (= (hook 'reason) 0)) ; add-mark 134 (for-each 135 (lambda (slider) 136 (XtVaSetValues slider (list XmNmaximum (max-mark)))) 137 sliders)))))))) 138 (if play-between-marks-dialog 139 (activate-dialog play-between-marks-dialog))))) 140 141 (set! play-between-marks-menu-label (add-to-menu marks-menu "Play between marks" post-play-between-marks-dialog)))) 142 143 144 145(set! marks-list (cons (lambda () 146 (let ((new-label (format #f "Play between marks (~D ~D)" play-between-marks-m1 play-between-marks-m2))) 147 (if play-between-marks-menu-label (change-label play-between-marks-menu-label new-label)) 148 (set! play-between-marks-label new-label))) 149 marks-list)) 150 151 152;;; -------- Loop play between marks 153 154(when (provided? 'xm) 155 (with-let (sublet *motif*) 156 157 (define loop-between-marks-m1 0) 158 (define loop-between-marks-m2 1) 159 (define loop-between-marks-buffer-size 512) 160 (define loop-between-marks-label "Loop play between marks") 161 (define loop-between-marks-dialog #f) 162 (define loop-between-marks-menu-label #f) 163 164 (define use-combo-box-for-buffer-size #f) ; radio-buttons or combo-box choice 165 166 (define (cp-loop-between-marks) 167 ;; cp-loop-between-marks) loops between two marks, playing (marks-menu) 168 (loop-between-marks (integer->mark loop-between-marks-m1) (integer->mark loop-between-marks-m2) loop-between-marks-buffer-size)) 169 170 (define (overall-max-mark-id default-max) 171 (let ((maxid default-max)) 172 (for-each 173 (lambda (snd-marks) 174 (for-each 175 (lambda (chan-marks) 176 (for-each 177 (lambda (m) 178 (set! maxid (max maxid (mark->integer m)))) 179 chan-marks)) 180 snd-marks)) 181 (marks)) 182 maxid)) 183 184 (define (post-loop-between-marks-dialog) 185 (unless loop-between-marks-dialog 186 ;; if loop-between-marks-dialog doesn't exist, create it 187 (let ((initial-loop-between-marks-m1 0) 188 (initial-loop-between-marks-m2 1) 189 (sliders ()) 190 (max-mark-id (overall-max-mark-id 25))) 191 (set! loop-between-marks-dialog 192 (make-effect-dialog 193 loop-between-marks-label 194 (lambda (w context info) 195 (cp-loop-between-marks)) 196 (lambda (w context info) 197 (help-dialog "Loop play between marks" 198 "Move the sliders to set the mark numbers. Check a radio button to set the buffer size.")) 199 (lambda (w c i) 200 (stop-playing)))) 201 (set! sliders 202 (add-sliders 203 loop-between-marks-dialog 204 (list (list "mark one" 0 initial-loop-between-marks-m1 max-mark-id 205 (lambda (w context info) 206 (set! loop-between-marks-m1 (.value info))) 207 1) 208 (list "mark two" 0 initial-loop-between-marks-m2 max-mark-id 209 (lambda (w context info) 210 (set! loop-between-marks-m2 (.value info))) 211 1)))) 212 213 ;; now add either a radio-button box or a combo-box for the buffer size 214 ;; need to use XtParent here since "mainform" isn't returned by add-sliders 215 216 (if use-combo-box-for-buffer-size 217 ;; this block creates a "combo box" to handle the buffer size 218 (let* ((s1 (XmStringCreateLocalized "Buffer size")) 219 (frm (let ((frame (XtCreateManagedWidget "frame" xmFrameWidgetClass (XtParent (car sliders)) 220 (list XmNborderWidth 1 221 XmNshadowType XmSHADOW_ETCHED_IN 222 XmNpositionIndex 2)))) 223 (XtCreateManagedWidget "frm" xmFormWidgetClass frame 224 (list XmNleftAttachment XmATTACH_FORM 225 XmNrightAttachment XmATTACH_FORM 226 XmNtopAttachment XmATTACH_FORM 227 XmNbottomAttachment XmATTACH_FORM 228 XmNbackground *basic-color*)))) 229 (lab (XtCreateManagedWidget "Buffer size" xmLabelWidgetClass frm 230 (list XmNleftAttachment XmATTACH_FORM 231 XmNrightAttachment XmATTACH_NONE 232 XmNtopAttachment XmATTACH_FORM 233 XmNbottomAttachment XmATTACH_FORM 234 XmNlabelString s1 235 XmNbackground *basic-color*))) 236 (buffer-labels (map XmStringCreateLocalized '("64" "128" "256" "512" "1024" "2048" "4096"))) 237 (combo (XtCreateManagedWidget "buffersize" xmComboBoxWidgetClass frm 238 (list XmNleftAttachment XmATTACH_WIDGET 239 XmNleftWidget lab 240 XmNrightAttachment XmATTACH_FORM 241 XmNtopAttachment XmATTACH_FORM 242 XmNbottomAttachment XmATTACH_FORM 243 XmNitems buffer-labels 244 XmNitemCount (length buffer-labels) 245 XmNcomboBoxType XmDROP_DOWN_COMBO_BOX 246 XmNbackground *basic-color*)))) 247 (for-each XmStringFree buffer-labels) 248 (XmStringFree s1) 249 (XtSetValues combo (list XmNselectedPosition 1)) 250 (XtAddCallback combo XmNselectionCallback 251 (lambda (w c i) 252 (set! loop-between-marks-buffer-size 253 (string->number (XmStringUnparse (.item_or_text i) #f XmCHARSET_TEXT XmCHARSET_TEXT #f 0 XmOUTPUT_ALL)))))) 254 255 ;; this block creates a "radio button box" 256 (let* ((s1 (XmStringCreateLocalized "Buffer size")) 257 (frm (let ((frame (XtCreateManagedWidget "frame" xmFrameWidgetClass (XtParent (car sliders)) 258 (list XmNborderWidth 1 259 XmNshadowType XmSHADOW_ETCHED_IN 260 XmNpositionIndex 2)))) 261 (XtCreateManagedWidget "frm" xmFormWidgetClass frame 262 (list XmNleftAttachment XmATTACH_FORM 263 XmNrightAttachment XmATTACH_FORM 264 XmNtopAttachment XmATTACH_FORM 265 XmNbottomAttachment XmATTACH_FORM 266 XmNbackground *basic-color*)))) 267 (rc (XtCreateManagedWidget "rc" xmRowColumnWidgetClass frm 268 (list XmNorientation XmHORIZONTAL 269 XmNradioBehavior #t 270 XmNradioAlwaysOne #t 271 XmNentryClass xmToggleButtonWidgetClass 272 XmNisHomogeneous #t 273 XmNleftAttachment XmATTACH_FORM 274 XmNrightAttachment XmATTACH_FORM 275 XmNtopAttachment XmATTACH_FORM 276 XmNbottomAttachment XmATTACH_NONE 277 XmNbackground *basic-color*)))) 278 (XtCreateManagedWidget "Buffer size" xmLabelWidgetClass frm 279 (list XmNleftAttachment XmATTACH_FORM 280 XmNrightAttachment XmATTACH_FORM 281 XmNtopAttachment XmATTACH_WIDGET 282 XmNtopWidget rc 283 XmNbottomAttachment XmATTACH_FORM 284 XmNlabelString s1 285 XmNalignment XmALIGNMENT_BEGINNING 286 XmNbackground *basic-color*)) 287 (for-each 288 289 (lambda (size) 290 (XtCreateManagedWidget (format #f "~D" size) xmToggleButtonWidgetClass rc 291 (list XmNbackground *basic-color* 292 XmNvalueChangedCallback (list (lambda (w c i) (if (.set i) (set! loop-between-marks-buffer-size c))) size) 293 XmNset (= size loop-between-marks-buffer-size)))) 294 '(64 128 256 512 1024 2048 4096)) 295 (XmStringFree s1))))) 296 (activate-dialog loop-between-marks-dialog)) 297 298 (set! loop-between-marks-menu-label (add-to-menu marks-menu "Loop play between marks" post-loop-between-marks-dialog)) 299 300 (set! marks-list (cons (lambda () 301 (let ((new-label (format #f "Loop play between marks (~D ~D ~D)" 302 loop-between-marks-m1 loop-between-marks-m2 loop-between-marks-buffer-size))) 303 (if loop-between-marks-menu-label (change-label loop-between-marks-menu-label new-label)) 304 (set! loop-between-marks-label new-label))) 305 marks-list)))) 306 307(add-to-menu marks-menu #f #f) 308 309 310;;; -------- trim from and back (goes by first or last mark) 311 312(define trim-front 313 (let ((+documentation+ "trim-front finds the first mark in each of the syncd channels and removes all samples before it") 314 (trim-front-one-channel 315 (lambda (snd chn) 316 (if (null? (marks snd chn)) 317 (status-report "trim-front needs a mark" snd) 318 (delete-samples 0 (mark-sample (car (marks snd chn))) snd chn))))) 319 (lambda () 320 (let ((snc (sync))) 321 (if (> snc 0) 322 (apply map 323 (lambda (snd chn) 324 (if (= (sync snd) snc) 325 (trim-front-one-channel snd chn))) 326 (all-chans)) 327 (trim-front-one-channel (selected-sound) (selected-channel))))))) 328 329(add-to-menu marks-menu "Trim before mark" trim-front) 330 331(define trim-back 332 (let ((+documentation+ "trim-back finds the last mark in each of the syncd channels and removes all samples after it") 333 (trim-back-one-channel 334 (lambda (snd chn) 335 (if (null? (marks snd chn)) 336 (status-report "trim-back needs a mark" snd) 337 (let ((endpt (let ((ms (marks snd chn))) 338 (mark-sample (list-ref ms (- (length ms) 1)))))) 339 (delete-samples (+ endpt 1) (- (framples snd chn) endpt))))))) 340 (lambda () 341 (let ((snc (sync))) 342 (if (> snc 0) 343 (apply map 344 (lambda (snd chn) 345 (if (= (sync snd) snc) 346 (trim-back-one-channel snd chn))) 347 (all-chans)) 348 (trim-back-one-channel (selected-sound) (selected-channel))))))) 349 350(add-to-menu marks-menu "Trim behind mark" trim-back) 351 352 353;;; -------- crop (trims front and back) 354 355(define crop 356 (let ((+documentation+ "crop finds the first and last marks in each of the syncd channels and removes all samples outside them") 357 (crop-one-channel 358 (lambda (snd chn) 359 (if (< (length (marks snd chn)) 2) 360 (status-report "crop needs start and end marks" snd) 361 (as-one-edit 362 (lambda () 363 (delete-samples 0 (mark-sample (car (marks snd chn))) snd chn) 364 (let ((endpt (let ((ms (marks snd chn))) 365 (mark-sample (list-ref ms (- (length ms) 1)))))) 366 (delete-samples (+ endpt 1) (- (framples snd chn) endpt)))) 367 "crop"))))) 368 (lambda () 369 (let ((snc (sync))) 370 (if (> snc 0) 371 (apply map 372 (lambda (snd chn) 373 (if (= (sync snd) snc) 374 (crop-one-channel snd chn))) 375 (all-chans)) 376 (crop-one-channel (selected-sound) (selected-channel))))))) 377 378(add-to-menu marks-menu "Crop around marks" crop) 379 380(add-to-menu marks-menu #f #f) 381 382 383;;; -------- Fit selection to marks 384 385(define fit-to-mark-one 0) 386(define fit-to-mark-two 1) 387(define fit-to-mark-label "Fit selection to marks") 388(define fit-to-mark-dialog #f) 389(define fit-to-mark-menu-label #f) 390 391(define cp-fit-to-marks 392 (let ((+documentation+ "(cp-fit-to-marks) fits the selection between two marks (marks-menu)")) 393 (lambda () 394 ((if (selection?) fit-selection-between-marks define-selection-via-marks) 395 (integer->mark fit-to-mark-one) 396 (integer->mark fit-to-mark-two))))) 397 398(if (not (or (provided? 'xm) 399 (provided? 'xg))) 400 (set! fit-to-mark-menu-label (add-to-menu marks-menu fit-to-mark-label cp-fit-to-marks)) 401 (begin 402 403 (define (post-fit-to-mark-dialog) 404 (unless fit-to-mark-dialog 405 (let ((initial-fit-to-mark-one 0) 406 (initial-fit-to-mark-two 1) 407 (sliders ())) 408 409 (set! fit-to-mark-dialog 410 (make-effect-dialog fit-to-mark-label 411 (values (lambda (w context info) 412 (cp-fit-to-marks)) 413 (lambda (w context info) 414 (help-dialog "Fit selection to marks Help" 415 "Fit-selection-between-marks tries to squeeze the current selection \ 416between two marks,using the granulate generator to fix up the selection duration (this still is not perfect). Move the sliders to set the mark numbers.")) 417 (lambda (w c i) 418 (set! fit-to-mark-one initial-fit-to-mark-one) 419 ((*motif* 'XtSetValues) (sliders 0) (list (*motif* 'XmNvalue) fit-to-mark-one)) 420 (set! fit-to-mark-two initial-fit-to-mark-two) 421 ((*motif* 'XtSetValues) (sliders 1) (list (*motif* 'XmNvalue) fit-to-mark-two)))))) 422 (set! sliders 423 (add-sliders 424 fit-to-mark-dialog 425 (list (let ((fitf1 (lambda (w context info) (set! fit-to-mark-one ((*motif* '.value) info))))) 426 (list "mark one" 0 initial-fit-to-mark-one 20 fitf1 1)) 427 (let ((fitf2 (lambda (w context info) (set! fit-to-mark-two (.value info))))) 428 (list "mark two" 0 initial-fit-to-mark-two 20 fitf2 1))))))) 429 430 (activate-dialog fit-to-mark-dialog)) 431 432 (set! fit-to-mark-menu-label (add-to-menu marks-menu "Fit selection to marks" post-fit-to-mark-dialog)))) 433 434 435(set! marks-list (cons (lambda () 436 (let ((new-label (format #f "Fit selection to marks (~D ~D)" fit-to-mark-one fit-to-mark-two))) 437 (if fit-to-mark-menu-label (change-label fit-to-mark-menu-label new-label)) 438 (set! fit-to-mark-label new-label))) 439 marks-list)) 440 441 442;;; -------- Define selection by marks 443 444(define define-by-mark-one 0) 445(define define-by-mark-two 1) 446(define define-by-mark-label "Define selection by marks") 447(define define-by-mark-dialog #f) 448(define define-by-mark-menu-label #f) 449 450(define define-selection-via-marks 451 (let ((+documentation+ "(define-selection-via-marks m1 m2) defines the selection via marks (marks-menu)")) 452 (lambda (m1 m2) 453 (let ((m1sc (mark-home m1)) 454 (m2sc (mark-home m2))) 455 (if (not (equal? m1sc m2sc)) 456 (snd-error "define-selection-via-marks assumes the marks are in the same channel") 457 (let ((beg (min (mark-sample m1) (mark-sample m2))) 458 (end (max (mark-sample m1) (mark-sample m2))) 459 (snd (car m1sc)) 460 (chn (cadr m1sc))) 461 (set! (selection-member? snd chn) #t) 462 (set! (selection-position snd chn) beg) 463 (set! (selection-framples snd chn) (- (+ end 1) beg)))))))) 464 465(define (cp-define-by-marks) 466 (define-selection-via-marks (integer->mark define-by-mark-one) (integer->mark define-by-mark-two))) 467 468(if (not (or (provided? 'xm) 469 (provided? 'xg))) 470 (set! define-by-mark-menu-label (add-to-menu marks-menu define-by-mark-label cp-define-by-marks)) 471 (begin 472 473 (define (post-define-by-mark-dialog) 474 (unless define-by-mark-dialog 475 (let ((initial-define-by-mark-one 0) 476 (initial-define-by-mark-two 1) 477 (sliders ())) 478 479 (set! define-by-mark-dialog 480 (make-effect-dialog define-by-mark-label 481 (values (lambda (w context info) 482 (cp-define-by-marks)) 483 (lambda (w context info) 484 (help-dialog "Define selection by marks Help" 485 "Selects and highlights area between marks. Use the sliders to choose the boundary marks.")) 486 (lambda (w c i) 487 (set! define-by-mark-one initial-define-by-mark-one) 488 ((*motif* 'XtSetValues) (sliders 0) (list (*motif* 'XmNvalue) define-by-mark-one)) 489 (set! define-by-mark-two initial-define-by-mark-two) 490 ((*motif* 'XtSetValues) (sliders 1) (list (*motif* 'XmNvalue) define-by-mark-two)))))) 491 (set! sliders 492 (add-sliders 493 define-by-mark-dialog 494 (list (let ((def1 (lambda (w context info) (set! define-by-mark-one ((*motif* '.value) info))))) 495 (list "mark one" 0 initial-define-by-mark-one 25 def1 1)) 496 (let ((def2 (lambda (w context info) (set! define-by-mark-two ((*motif* '.value) info))))) 497 (list "mark two" 0 initial-define-by-mark-two 25 def2 1))))))) 498 499 (activate-dialog define-by-mark-dialog)) 500 501 (set! define-by-mark-menu-label (add-to-menu marks-menu "Define selection by marks" post-define-by-mark-dialog)))) 502 503 504(set! marks-list (cons (lambda () 505 (let ((new-label (format #f "Define selection by marks (~D ~D)" define-by-mark-one define-by-mark-two))) 506 (if define-by-mark-menu-label (change-label define-by-mark-menu-label new-label)) 507 (set! define-by-mark-label new-label))) 508 marks-list)) 509 510(add-to-menu marks-menu #f #f) 511 512 513;;; ------- Start/stop mark sync 514 515(define mark-sync-menu-label #f) 516 517(define mark-sync-number 0) 518 519(define start-sync 520 (let ((+documentation+ "(start-sync) starts mark syncing (marks-menu)")) 521 (lambda () 522 (set! mark-sync-number (+ (mark-sync-max) 1))))) 523 524(define stop-sync 525 (let ((+documentation+ "(stop-sync) stops mark-syncing (marks-menu)")) 526 (lambda () 527 (set! mark-sync-number 0)))) 528 529(define click-to-sync 530 (let ((+documentation+ "(click-to-sync id) sets a mark's sync field when it is clicked (marks-menu)")) 531 (lambda (id) 532 (set! (sync id) mark-sync-number) 533 #f))) 534 535(hook-push mark-click-hook (lambda (hook) (click-to-sync (hook 'id)))) 536 537 538(define m-sync #f) 539(define m-sync-label "Mark sync (On)") 540(define no-m-sync-label "Mark sync (Off)") 541 542(define msync! 543 (let ((+documentation+ "(msync!) starts mark syncing (marks-menu)")) 544 (lambda () 545 (set! m-sync #t) 546 (if mark-sync-menu-label (change-label mark-sync-menu-label m-sync-label)) 547 (start-sync) 548 (mark-sync-color "yellow")))) 549 550(define unmsync! 551 (let ((+documentation+ "(unmsync!) stops mark syncing (marks-menu)")) 552 (lambda () 553 (set! m-sync #f) 554 (if mark-sync-menu-label (change-label mark-sync-menu-label no-m-sync-label)) 555 (stop-sync)))) 556 557(set! mark-sync-menu-label 558 (add-to-menu marks-menu no-m-sync-label 559 (lambda () 560 (if m-sync 561 (unmsync!) 562 (msync!))))) 563 564(add-to-menu marks-menu #f #f) 565 566 567;;; -------- Places marks at loop points specified in the file header 568 569(add-to-menu marks-menu "Mark sample loop points" mark-loops) 570 571 572 573;;; -------- mark loop dialog (this refers to sound header mark points, not Snd mark objects!) 574 575(when (provided? 'xm) 576 (with-let (sublet *motif*) 577 578 ;; Here is a first stab at the loop dialog (I guessed a lot as to what these buttons 579 ;; are supposed to do -- have never used these loop points). 580 581 (define loop-dialog #f) 582 (define loop-data '(0 0 0 0 0 0 1 1)) 583 584 (define (update-labels start range end sus-rel range-in-secs) 585 (let ((sr2 (* sus-rel 2))) 586 (if range-in-secs 587 (begin 588 (change-label start (format #f "~,3F" (/ (loop-data sr2) (srate)))) 589 (change-label range (format #f "~,3F" (/ (- (loop-data (+ 1 sr2)) (loop-data sr2)) (srate)))) 590 (change-label end (format #f "~,3F" (/ (loop-data (+ 1 sr2)) (srate))))) 591 (begin 592 (change-label start (format #f "~D" (loop-data sr2))) 593 (change-label range (format #f "~D" (- (loop-data (+ 1 sr2)) (loop-data sr2)))) 594 (change-label end (format #f "~D" (loop-data (+ 1 sr2)))))))) 595 596 (define (create-loop-dialog) 597 (unless (Widget? loop-dialog) 598 (let ((xdismiss (XmStringCreate "Go Away" XmFONTLIST_DEFAULT_TAG)) 599 (xsave (XmStringCreate "Save" XmFONTLIST_DEFAULT_TAG)) 600 (xhelp (XmStringCreate "Help" XmFONTLIST_DEFAULT_TAG)) 601 (titlestr (XmStringCreate "Loop Points" XmFONTLIST_DEFAULT_TAG))) 602 (set! loop-dialog 603 (XmCreateTemplateDialog (cadr (main-widgets)) "loop-points" 604 (list XmNcancelLabelString xdismiss 605 XmNhelpLabelString xhelp 606 XmNokLabelString xsave 607 XmNautoUnmanage #f 608 XmNdialogTitle titlestr 609 XmNresizePolicy XmRESIZE_GROW 610 XmNnoResize #f 611 XmNbackground *basic-color* 612 XmNtransient #f))) 613 (XtAddCallback loop-dialog 614 XmNcancelCallback (lambda (w context info) 615 (XtUnmanageChild loop-dialog))) 616 (XtAddCallback loop-dialog 617 XmNhelpCallback (lambda (w context info) 618 (snd-print "set loop points"))) 619 (XtAddCallback loop-dialog 620 XmNokCallback (lambda (w context info) 621 (set! (sound-loop-info) loop-data))) 622 (for-each XmStringFree (vector xhelp xdismiss titlestr xsave)) 623 (let* ((mainform 624 (XtCreateManagedWidget "form" xmFormWidgetClass loop-dialog 625 (list XmNleftAttachment XmATTACH_FORM 626 XmNrightAttachment XmATTACH_FORM 627 XmNtopAttachment XmATTACH_FORM 628 XmNbottomAttachment XmATTACH_WIDGET 629 XmNbottomWidget (XmMessageBoxGetChild loop-dialog XmDIALOG_SEPARATOR) 630 XmNbackground *basic-color*))) 631 (leftform 632 (XtCreateManagedWidget "lform" xmFormWidgetClass mainform 633 (list XmNleftAttachment XmATTACH_FORM 634 XmNrightAttachment XmATTACH_POSITION 635 XmNrightPosition 50 636 XmNtopAttachment XmATTACH_FORM 637 XmNbottomAttachment XmATTACH_FORM 638 XmNbackground *basic-color*))) 639 (rightform 640 (XtCreateManagedWidget "rform" xmFormWidgetClass mainform 641 (list XmNleftAttachment XmATTACH_WIDGET 642 XmNleftWidget leftform 643 XmNrightAttachment XmATTACH_FORM 644 XmNtopAttachment XmATTACH_FORM 645 XmNbottomAttachment XmATTACH_FORM 646 XmNbackground *basic-color*)))) 647 (for-each 648 (lambda (parent top-label offset) 649 (let* ((frame-form 650 (let ((main-frame 651 (let ((main-label (XtCreateManagedWidget top-label xmLabelWidgetClass parent 652 (list XmNleftAttachment XmATTACH_FORM 653 XmNrightAttachment XmATTACH_FORM 654 XmNtopAttachment XmATTACH_FORM 655 XmNbottomAttachment XmATTACH_NONE)))) 656 (XtCreateManagedWidget "fr" xmFrameWidgetClass parent 657 (list XmNleftAttachment XmATTACH_FORM 658 XmNrightAttachment XmATTACH_FORM 659 XmNtopAttachment XmATTACH_WIDGET 660 XmNtopWidget main-label 661 XmNbottomAttachment XmATTACH_FORM 662 XmNshadowThickness 6 663 XmNshadowType XmSHADOW_ETCHED_OUT))))) 664 (XtCreateManagedWidget "fform" xmFormWidgetClass main-frame ()))) 665 (top-frame (XtCreateManagedWidget "topf" xmFrameWidgetClass frame-form 666 (list XmNleftAttachment XmATTACH_FORM 667 XmNrightAttachment XmATTACH_FORM 668 XmNtopAttachment XmATTACH_FORM 669 XmNbottomAttachment XmATTACH_NONE))) 670 (top-form (XtCreateManagedWidget "tform" xmFormWidgetClass top-frame ())) 671 (left-column (XtCreateManagedWidget "lcol" xmRowColumnWidgetClass top-form 672 (list XmNorientation XmVERTICAL 673 XmNbackground *position-color* 674 XmNleftAttachment XmATTACH_FORM 675 XmNrightAttachment XmATTACH_POSITION 676 XmNrightPosition 40 677 XmNtopAttachment XmATTACH_FORM 678 XmNbottomAttachment XmATTACH_FORM))) 679 (mid-column (XtCreateManagedWidget "lcol" xmFormWidgetClass top-form 680 (list XmNleftAttachment XmATTACH_WIDGET 681 XmNleftWidget left-column 682 XmNrightAttachment XmATTACH_POSITION 683 XmNrightPosition 60 684 XmNtopAttachment XmATTACH_FORM 685 XmNbottomAttachment XmATTACH_FORM))) 686 (right-column (XtCreateManagedWidget "lcol" xmRowColumnWidgetClass top-form 687 (list XmNorientation XmVERTICAL 688 XmNbackground *position-color* 689 XmNleftAttachment XmATTACH_WIDGET 690 XmNleftWidget mid-column 691 XmNrightAttachment XmATTACH_FORM 692 XmNtopAttachment XmATTACH_FORM 693 XmNbottomAttachment XmATTACH_FORM))) 694 (rowlefttop (XtCreateManagedWidget "r1" xmRowColumnWidgetClass left-column 695 (list XmNorientation XmHORIZONTAL 696 XmNbackground *position-color* 697 XmNspacing 0))) 698 (leftrange (XtCreateManagedWidget "range" xmPushButtonWidgetClass left-column ())) 699 (rowleftbottom (XtCreateManagedWidget "r1" xmRowColumnWidgetClass left-column 700 (list XmNorientation XmHORIZONTAL 701 XmNbackground *position-color* 702 XmNspacing 0))) 703 (rowrighttop (XtCreateManagedWidget "r1" xmRowColumnWidgetClass right-column 704 (list XmNorientation XmHORIZONTAL 705 XmNbackground *position-color* 706 XmNspacing 0))) 707 (rowrightbottom (XtCreateManagedWidget "r1" xmRowColumnWidgetClass right-column 708 (list XmNorientation XmHORIZONTAL 709 XmNbackground *position-color* 710 XmNspacing 0))) 711 (midlab1 (XtCreateManagedWidget "0.000" xmLabelWidgetClass mid-column 712 (list XmNleftAttachment XmATTACH_FORM 713 XmNrightAttachment XmATTACH_FORM 714 XmNtopAttachment XmATTACH_POSITION 715 XmNtopPosition 10 716 XmNbottomAttachment XmATTACH_NONE))) 717 (midlab2 (XtCreateManagedWidget "0.000" xmLabelWidgetClass mid-column 718 (list XmNleftAttachment XmATTACH_FORM 719 XmNrightAttachment XmATTACH_FORM 720 XmNtopAttachment XmATTACH_POSITION 721 XmNtopPosition 40 722 XmNbottomAttachment XmATTACH_NONE))) 723 (midlab3 (XtCreateManagedWidget "0.000" xmLabelWidgetClass mid-column 724 (list XmNleftAttachment XmATTACH_FORM 725 XmNrightAttachment XmATTACH_FORM 726 XmNtopAttachment XmATTACH_NONE 727 XmNbottomAttachment XmATTACH_POSITION 728 XmNbottomPosition 90))) 729 (bottom-left (let ((bottom-form (XtCreateManagedWidget "bform" xmFormWidgetClass frame-form 730 (list XmNleftAttachment XmATTACH_FORM 731 XmNrightAttachment XmATTACH_FORM 732 XmNtopAttachment XmATTACH_WIDGET 733 XmNtopWidget top-frame 734 XmNbottomAttachment XmATTACH_FORM)))) 735 (XtCreateManagedWidget "bleft" xmFormWidgetClass bottom-form 736 (list XmNleftAttachment XmATTACH_FORM 737 XmNrightAttachment XmATTACH_NONE 738 XmNtopAttachment XmATTACH_FORM 739 XmNbottomAttachment XmATTACH_FORM)))) 740 (bottom-left-label (XtCreateManagedWidget "Loop Mode" xmLabelWidgetClass bottom-left 741 (list XmNleftAttachment XmATTACH_FORM 742 XmNrightAttachment XmATTACH_FORM 743 XmNtopAttachment XmATTACH_FORM 744 XmNbottomAttachment XmATTACH_NONE))) 745 (bottom-left-button (XtCreateManagedWidget "forwards" xmPushButtonWidgetClass bottom-left 746 (list XmNleftAttachment XmATTACH_FORM 747 XmNrightAttachment XmATTACH_FORM 748 XmNtopAttachment XmATTACH_WIDGET 749 XmNtopWidget bottom-left-label 750 XmNbottomAttachment XmATTACH_FORM))) 751 (range-in-secs #t)) 752 (let ((mode 1)) 753 (XtAddCallback bottom-left-button 754 XmNactivateCallback 755 (lambda (w context info) 756 (set! mode (if (= mode 1) 2 1)) 757 (set! (loop-data (+ offset 6)) mode) 758 (change-label w (if (= mode 1) "forward" "forw/back"))))) 759 (XtAddCallback leftrange XmNactivateCallback 760 (lambda (w c i) 761 (set! range-in-secs (not range-in-secs)) 762 (update-labels midlab1 midlab2 midlab3 offset range-in-secs))) 763 (for-each 764 (lambda (rparent loc) 765 (let ((farleft (XtCreateManagedWidget "<<" xmPushButtonWidgetClass rparent ()))) 766 (XtAddCallback farleft XmNactivateCallback 767 (lambda (w c i) 768 (let ((ml (if (= loc 0) 0 (loop-data sus-rel-start)))) 769 (set! (loop-data (+ loc (* offset 2))) ml) 770 (update-labels midlab1 midlab2 midlab3 offset range-in-secs))))) 771 (let ((stopleft (XtCreateManagedWidget " O " xmPushButtonWidgetClass rparent ()))) 772 (XtAddCallback stopleft XmNactivateCallback 773 (lambda (w c i) 774 (let ((ml (if (= loc 0) 0 (loop-data sus-rel-start)))) 775 (set! (loop-data (+ loc (* offset 2))) ml) 776 (update-labels midlab1 midlab2 midlab3 offset range-in-secs))))) 777 (let ((lotsleft (XtCreateManagedWidget "<< " xmPushButtonWidgetClass rparent ()))) 778 (XtAddCallback lotsleft XmNactivateCallback 779 (lambda (w c i) 780 (let ((ml (if (= loc 0) 0 (loop-data sus-rel-start)))) 781 (set! (loop-data (+ loc (* offset 2))) (max ml (- (loop-data (+ loc (* offset 2))) 10))) 782 (update-labels midlab1 midlab2 midlab3 offset range-in-secs))))) 783 (let ((someleft (XtCreateManagedWidget " < " xmPushButtonWidgetClass rparent ())) 784 (sus-rel-start (* offset 2))) 785 (XtAddCallback someleft XmNactivateCallback 786 (lambda (w c i) 787 (let ((ml (if (= loc 0) 0 (loop-data sus-rel-start)))) 788 (set! (loop-data (+ loc (* offset 2))) (max ml (- (loop-data (+ loc (* offset 2))) 1))) 789 (update-labels midlab1 midlab2 midlab3 offset range-in-secs)))))) 790 (list rowlefttop rowleftbottom) 791 '(0 1)) 792 793 (for-each 794 (lambda (rparent loc) 795 (let ((sus-rel-start (+ (* offset 2) 1))) 796 (let ((someright (XtCreateManagedWidget " > " xmPushButtonWidgetClass rparent ()))) 797 (XtAddCallback someright XmNactivateCallback 798 (lambda (w c i) 799 (let ((ml (if (= loc 0) (loop-data sus-rel-start) (framples)))) 800 (set! (loop-data (+ loc (* offset 2))) (min ml (+ (loop-data (+ loc (* offset 2))) 1))) 801 (update-labels midlab1 midlab2 midlab3 offset range-in-secs))))) 802 (let ((lotsright (XtCreateManagedWidget " >>" xmPushButtonWidgetClass rparent ()))) 803 (XtAddCallback lotsright XmNactivateCallback 804 (lambda (w c i) 805 (let ((ml (if (= loc 0) (loop-data sus-rel-start) (framples)))) 806 (set! (loop-data (+ loc (* offset 2))) (min ml (+ (loop-data (+ loc (* offset 2))) 10))) 807 (update-labels midlab1 midlab2 midlab3 offset range-in-secs))))) 808 (let ((stopright (XtCreateManagedWidget " O " xmPushButtonWidgetClass rparent ()))) 809 (XtAddCallback stopright XmNactivateCallback 810 (lambda (w c i) 811 (let ((ml (if (= loc 0) (loop-data sus-rel-start) (framples)))) 812 (set! (loop-data (+ loc (* offset 2))) ml) 813 (update-labels midlab1 midlab2 midlab3 offset range-in-secs))))) 814 (let ((farright (XtCreateManagedWidget ">>" xmPushButtonWidgetClass rparent ()))) 815 (XtAddCallback farright XmNactivateCallback 816 (lambda (w c i) 817 (let ((ml (if (= loc 0) (loop-data sus-rel-start) (framples)))) 818 (set! (loop-data (+ loc (* offset 2))) ml) 819 (update-labels midlab1 midlab2 midlab3 offset range-in-secs))))))) 820 (list rowrighttop rowrightbottom) 821 '(0 1)))) 822 823 (list leftform rightform) 824 '("Sustain" "Release") 825 '(0 1))) 826 (for-each-child 827 loop-dialog 828 (lambda (n) 829 (if (and (XtIsWidget n) 830 (not (XmIsRowColumn n)) 831 (not (XmIsSeparator n))) 832 (begin 833 (XmChangeColor n *basic-color*) 834 (if (XmIsToggleButton n) 835 (XtVaSetValues n (list XmNselectColor 836 (let* ((col (XColor)) 837 (dpy (XtDisplay (cadr (main-widgets)))) 838 (cmap (DefaultColormap dpy (DefaultScreen dpy)))) 839 (XAllocNamedColor dpy cmap "yellow" col col) 840 (.pixel col))))))))) 841 )) 842 (XtManageChild loop-dialog)) 843 844 (add-to-menu marks-menu "Show loop editor" create-loop-dialog) 845 )) 846 847 848(add-to-menu marks-menu #f #f) 849 850 851;;; -------- Delete all marks 852 853(add-to-menu marks-menu "Delete all marks" delete-marks) 854 855(add-to-menu marks-menu #f #f) 856 857 858;;; -------- Explode all marks to separate files 859 860(define mark-explode 861 (let ((+documentation+ "(mark-explode) produces separate files as delineated by successive marks (marks-menu)")) 862 (lambda () 863 (let ((start 0)) 864 (for-each 865 (lambda (mark) 866 (let ((len (- (mark-sample mark) start)) 867 (filename (snd-tempnam))) 868 (array->file filename 869 (channel->float-vector start len) 870 len (srate) 1) 871 (set! start (mark-sample mark)))) 872 (caar (marks))))))) 873 874(add-to-menu marks-menu "Explode marks to files" mark-explode) 875