1\ popup.fs -- popup.scm|rb --> popup.fs 2 3\ Translator/Author: Michael Scholz <mi-scholz@users.sourceforge.net> 4\ Created: 05/12/23 00:28:28 5\ Changed: 19/12/23 17:58:28 6\ 7\ @(#)popup.fs 1.52 12/23/19 8 9\ selection-popup-menu 10\ graph-popup-menu 11\ fft-popup-menu 12\ edit-history-menu 13\ listener-popup-menu 14\ 15\ add-popups ( -- ) 16\ 17\ edhist-help-edits ( w c i -- ) 18\ change-menu-color ( menu new-color -- ) 19\ change-selection-popup-color ( new-color -- ) 20\ change-graph-popup-color ( new-color -- ) 21\ change-fft-popup-color ( new-color -- ) 22\ change-edhist-popup-color ( new-color -- ) 23\ change-listener-popup-color ( new-color -- ) 24 25'snd-motif provided? [unless] skip-file [then] 26 27require snd-xm 28require extensions 29 30\ for prefs 31: edhist-help-edits <{ w c info -- }> 32 "Edit History Functions" 33 "This popup menu gives access to the edit-list \ 34function handlers in Snd. \ 35At any time you can backup in the edit list, \ 36'save' the current trailing edits, make some \ 37new set of edits, then 'reapply' the saved edits. \ 38The 'apply' choice gives access to all \ 39currently saved edit lists -- any such list can be applied to any channel. \ 40'Clear' deletes all saved edit lists." 41 #( "{edit lists}" "{edit-list->function}" ) 42 #( "extsnd.html#editlists" "extsnd.html#editlist_to_function" ) 43 help-dialog drop 44; 45 461 "PROC is the only argument." create-hook edhist-save-hook 47 48hide 49#() value cascade-popup-cb-list 50 51: widget->name ( w -- s ) 52 FXtName 53; 54 55: popup-post-it { menu info -- } 56 info menu Fset_menuToPost drop 57; 58 59\ --- make-simple-popdown-menu for fft-popup-menu --- 60: popup-cascade-cb { children cb -- prc; w c i self -- } 61 3 proc-create ( prc ) 62 cb , children , 63 does> { w c info self -- } 64 self @ { cb } 65 self cell+ @ { children } 66 cb #( children ) run-proc drop 67; 68 69: make-simple-popdown-menu { label popdown-labels parent cascade-cb -- } 70 parent label #( FXmNbackground highlight-color ) 71 undef FXmCreatePulldownMenu { top } 72 parent label 73 #( FXmNbackground highlight-color FXmNsubMenuId top ) 74 FXmVaCreateManagedCascadeButton { menu } 75 #() { children } 76 nil { c } 77 popdown-labels proc? if 78 \ edhist sends a proc to set TOP to edhist-widgets 79 popdown-labels #( top ) run-proc drop 80 else 81 \ else arrays of #( name proc ) lists 82 popdown-labels each { poplab } 83 top poplab 0 array-ref 84 #( FXmNbackground highlight-color ) 85 FXmVaCreateManagedPushButton to c 86 c FXmNactivateCallback poplab 1 array-ref 87 undef FXtAddCallback drop 88 children c array-push drop 89 end-each 90 then 91 cascade-cb if 92 menu FXmNcascadingCallback 93 children cascade-cb popup-cascade-cb 94 undef FXtAddCallback drop 95 then 96; 97 98\ --- make-popdown-entry for listener-popup-menu --- 99#() value listener-values 100 101: collector-cb { func collector -- prc; w c i self -- val } 102 3 proc-create ( prc ) 103 func , collector , 104 does> { w c info self -- val } 105 self @ { func } 106 self cell+ @ { collector } 107 collector #( sounds ) run-proc ( lst ) 108 0 array-ref 1 >array func swap run-proc 109; 110 111: cas-cb ( func -- prc; w c i self -- val ) 112 { func } 113 3 proc-create ( prc ) 114 func , 115 does> { w c info self -- val } 116 self @ ( func ) #( w current-label 0 find-sound ) run-proc 117; 118 119: popdown-cascade-cb { func coll menu children -- prc; w c i self -- } 120 3 proc-create ( prc ) 121 func , coll , menu , children , 122 does> { w c info self -- } 123 self @ { func } 124 self cell+ @ { collector } 125 self 2 cells + @ { menu } 126 self 3 cells + @ { children } 127 children each ( child ) 128 FXtUnmanageChild drop 129 end-each 130 collector #( sounds ) run-proc { snds } 131 children length { clen } 132 snds length { slen } 133 clen slen < if 134 slen clen ?do 135 menu "" 136 #( FXmNbackground highlight-color ) 137 FXmVaCreateManagedPushButton { c } 138 c FXmNactivateCallback 139 func cas-cb 140 undef FXtAddCallback drop 141 children c array-push drop 142 loop 143 then 144 slen if 145 children each { child } 146 snds i array-ref { snd } 147 child snd short-file-name change-label 148 child FXtManageChild drop 149 end-each 150 then 151; 152 153: make-popdown-entry { label parent func collector with-one -- } 154 #f { widget } 155 #() { children } 156 with-one if 157 parent label 158 #( FXmNbackground highlight-color ) 159 FXmVaCreateManagedPushButton to widget 160 widget FXmNactivateCallback 161 func collector collector-cb 162 undef FXtAddCallback drop 163 then 164 parent label #( FXmNbackground highlight-color ) 165 undef FXmCreatePulldownMenu { menu } 166 parent label 167 #( FXmNbackground highlight-color 168 FXmNsubMenuId menu ) 169 FXmVaCreateManagedCascadeButton { cas-wid } 170 cas-wid FXmNcascadingCallback 171 func collector menu children popdown-cascade-cb 172 undef FXtAddCallback drop 173 listener-values #( widget menu cas-wid collector ) 174 array-push drop 175; 176 177\ --- make-popup-menu for graph-, fft-, and listener-menu --- 178\ 179\ general entries: 180\ entries: #( #( name type cb func ) ... ) 181\ 182\ simple popdown (fft-menu) 183\ entries: #( #( name type labels-array cb ) ... ) 184\ 185\ special popdown (listener) 186\ entries: #( #( name type func collector with-one ) ... ) 187: make-popup-menu ( name parent entries -- menu ) 188 { name parent entries } 189 parent name 190 #( FXmNpopupEnabled FXmPOPUP_AUTOMATIC 191 FXmNbackground highlight-color ) 192 undef FXmCreatePopupMenu { menu } 193 entries each { entry } 194 #f { casc } 195 \ string 196 entry 0 array-ref { label } 197 \ 'label|'separator|'cascade|#f 198 entry 1 array-ref { typ } 199 typ 'label = if 200 FxmLabelWidgetClass 201 else 202 typ 'separator = if 203 FxmSeparatorWidgetClass 204 else 205 FxmPushButtonWidgetClass 206 then 207 then { class } 208 typ 'cascade = if 209 entry length 4 = if \ fft/edhist menu 210 label 211 entry 2 array-ref ( labels ) 212 menu 213 entry 3 array-ref ( prc ) 214 make-simple-popdown-menu 215 else \ listener menu 216 label 217 menu 218 entry 2 array-ref ( func ) 219 entry 3 array-ref ( collector ) 220 entry 4 array-ref ( with-one ) 221 make-popdown-entry 222 then 223 else 224 label class menu 225 #( FXmNbackground highlight-color ) 226 undef FXtCreateManagedWidget { wid } 227 entry 2 array-ref { cb } \ cb: 3 args or #f 228 cb if 229 wid FXmNactivateCallback cb 230 undef FXtAddCallback drop 231 then 232 entry 3 array-ref { prc } \ func: 1 arg or #f 233 prc if 234 prc #( wid ) run-proc drop 235 then 236 then 237 end-each 238 menu 239; 240 241\ --- selection popup --- 242: sel-stop-play-cb { vars -- prc; self -- val } 243 0 proc-create ( prc ) 244 vars , 245 does> { self -- val } 246 self @ { vars } 247 vars :stopping array-assoc-ref if 248 vars :stopping #f array-assoc-set! 249 ( vars ) :stop-widget array-assoc-ref { w } 250 w widget? if 251 w "Play" change-label 252 then 253 then 254 #f 255; 256 257: sel-play-again-cb ( -- val ) 258 selection play 259; 260 261: sel-play-cb { vars -- prc; w c i self -- val } 262 3 proc-create ( prc ) 263 vars , 264 does> { w c info self -- val } 265 self @ { vars } 266 vars :stopping array-assoc-ref if 267 w "Play" change-label 268 vars :stopping #f array-assoc-set! 269 ( vars ) :stopping1 array-assoc-ref if 270 vars :stopping1 #f array-assoc-set! 271 ( vars ) :stop-widget1 array-assoc-ref 272 "Loop play" change-label 273 stop-playing-selection-hook 274 <'> sel-play-again-cb remove-hook! drop 275 then 276 undef stop-playing 277 else 278 w "Stop" change-label 279 vars :stop-widget w array-assoc-set! 280 ( vars ) :stopping #t array-assoc-set! drop 281 selection play 282 then 283; 284 285: sel-loop-cb { vars -- prc; w c i self -- val } 286 3 proc-create ( prc ) 287 vars , 288 does> { w c info self -- val } 289 self @ { vars } 290 vars :stopping1 array-assoc-ref if 291 w "Loop play" change-label 292 vars :stopping1 #f array-assoc-set! 293 ( vars ) :stopping array-assoc-ref if 294 vars :stopping #f array-assoc-set! 295 ( vars ) :stop-widget array-assoc-ref "Play" change-label 296 then 297 stop-playing-selection-hook 298 <'> sel-play-again-cb remove-hook! drop 299 undef stop-playing 300 else 301 w "Stop!" change-label 302 vars :stop-widget1 w array-assoc-set! 303 ( vars ) :stopping1 #t array-assoc-set! drop 304 stop-playing-selection-hook <'> sel-play-again-cb add-hook! 305 selection play 306 then 307; 308 309: as-one-edit-thunk { sel -- prc; self -- val } 310 0 proc-create ( prc ) 311 sel , 312 does> { self -- val } 313 self @ { sel } 314 sel 0 array-ref { snd } 315 sel 1 array-ref { chn } 316 snd chn selection-position { beg } 317 snd chn selection-framples { len } 318 beg 0> if 319 0 beg snd chn delete-samples drop 320 then 321 snd chn #f framples { frms } 322 len frms < if 323 len 1+ frms len - snd chn delete-samples drop 324 then 325 #f 326; 327 328: sel-del <{ w c info -- val }> 329 delete-selection 330; 331 332: sel-zero <{ w c info -- val }> 333 0.0 scale-selection-by 334; 335 336: sel-norm <{ w c info -- val }> 337 1.0 scale-selection-to 338; 339 340: sel-crop <{ w c info -- val }> 341 selection-members each ( sel ) 342 as-one-edit-thunk "" as-one-edit drop 343 end-each 344 #f 345; 346 347: sel-save-as <{ w c info -- val }> 348 #t save-selection-dialog 349; 350 351: sel-copy <{ w c info -- val }> 352 snd-tempnam { new-file-name } 353 new-file-name save-selection drop 354 new-file-name open-sound 355; 356 357: sel-cut <{ w c info -- val }> 358 snd-tempnam { new-file-name } 359 new-file-name save-selection drop 360 delete-selection drop 361 new-file-name open-sound 362; 363 364: sel-marks <{ w c info -- val }> 365 selection-members each { select } 366 select 0 array-ref { snd } 367 select 1 array-ref { chn } 368 snd chn selection-position { pos } 369 snd chn selection-framples 1- { len } 370 pos snd chn #f 0 add-mark drop 371 pos len d+ snd chn #f 0 add-mark drop 372 end-each 373 #f 374; 375 376\ choice 2 == selection 377: sel-appcnt <{ w c info -- val }> 378 \ (apply-controls :optional snd (choice 0) (beg 0) (dur len)) 379 \ choice: 0 snd 380 \ 1 chn 381 \ 2 sel 382 selected-sound 2 undef undef apply-controls 383; 384 385: sel-rescnt <{ w c info -- val }> 386 selected-sound reset-controls 387; 388 389: sel-unsel <{ w c info -- val }> 390 #f #t #f set-selection-member? 391; 392 393: sel-rev <{ w c info -- val }> 394 reverse-selection 395; 396 397: sel-mix <{ w c info -- val }> 398 #f #f #f cursor mix-selection 399; 400 401: sel-invert <{ w c info -- val }> 402 -1.0 scale-selection-by 403; 404 405: sel-info <{ w c info -- val }> 406 selected-sound { snd } 407 snd selected-channel { chn } 408 snd chn selection-position { beg } 409 snd chn selection-framples { len } 410 " start: %d, %.3f\n" #( beg beg #f srate f/ ) string-format ( str ) 411 " end: %d, %.3f\n" #( beg len + dup #f srate f/ ) string-format $+ 412 " duration: %d, %.3f\n" #( len len #f srate f/ ) string-format $+ 413 " chans: %d\n" #( selection-chans ) string-format $+ 414 " maxamp: %.3f\n" #( #f #f selection-maxamp ) string-format $+ { str } 415 "Selection info" str info-dialog 416; 417 418let: ( -- menu ) 419 #a( :stopping #f 420 :stopping1 #f 421 :stop-widget #f 422 :stop-widget1 #f ) { vars } 423 stop-playing-selection-hook vars sel-stop-play-cb add-hook! 424 "selection-popup" main-widgets 2 array-ref 425 #( #( "Selection" 'label #f #f ) 426 #( "sep" 'separator #f #f ) 427 #( "Play" #f vars sel-play-cb #f ) 428 #( "Loop play" #f vars sel-loop-cb #f ) 429 #( "Delete" #f <'> sel-del #f ) 430 #( "-> 0.0" #f <'> sel-zero #f ) 431 #( "-> 1.0" #f <'> sel-norm #f ) 432 #( "Crop" #f <'> sel-crop #f ) 433 #( "Save as" #f <'> sel-save-as #f ) 434 #( "Copy -> new" #f <'> sel-copy #f ) 435 #( "Cut -> new" #f <'> sel-cut #f ) 436 #( "Snap marks" #f <'> sel-marks #f ) 437 #( "Apply controls" #f <'> sel-appcnt #f ) 438 #( "Reset controls" #f <'> sel-rescnt #f ) 439 #( "Unselect" #f <'> sel-unsel #f ) 440 #( "Reverse" #f <'> sel-rev #f ) 441 #( "Mix" #f <'> sel-mix #f ) 442 #( "Invert" #f <'> sel-invert #f ) 443 #( "Info" #f <'> sel-info #f ) 444 ) make-popup-menu 445;let constant selection-popup-menu 446 447\ --- time domain popup --- 448: graph-popup-snd ( -- snd ) #f snd-snd ; 449: graph-popup-chn ( -- chn ) #f snd-chn ; 450 451: stop-playing-cb { vars -- prc; snd self -- val } 452 1 proc-create ( prc ) 453 vars , 454 does> { snd self -- val } 455 self @ { vars } 456 vars :stopping array-assoc-ref if 457 vars :stopping #f array-assoc-set! 458 ( vars ) :stop-widget array-assoc-ref ?dup-if 459 "Play" change-label 460 then 461 then 462 #f 463; 464 465: play-cb { vars -- prc; w c i self -- val } 466 3 proc-create ( prc ) 467 vars , 468 does> { w c info self -- val } 469 self @ { vars } 470 vars :stopping array-assoc-ref if 471 vars :stopping #f array-assoc-set! drop 472 w "Play" change-label 473 undef stop-playing 474 else 475 w "Stop" change-label 476 vars :stopping #t array-assoc-set! drop 477 graph-popup-snd play 478 then 479; 480 481: stop-cb { vars -- prc; widget self -- val } 482 1 proc-create ( prc ) 483 vars , 484 does> { w self -- val } 485 self @ ( vars ) :stop-widget w array-assoc-set! 486; 487 488: pchan-cb { vars -- prc; w c i self -- val } 489 3 proc-create ( prc ) 490 vars , 491 does> { w c info self -- val } 492 self @ ( vars ) :stopping #t array-assoc-set! 493 ( vars ) :stop-widget array-assoc-ref "Stop" change-label 494 graph-popup-snd :channel graph-popup-chn play 495; 496 497: pcur-cb { vars -- prc; w c i self -- val } 498 3 proc-create ( prc ) 499 vars , 500 does> { w c info self -- val } 501 self @ ( vars ) :stopping #t array-assoc-set! 502 ( vars ) :stop-widget array-assoc-ref "Stop" change-label 503 graph-popup-snd 504 :start graph-popup-snd graph-popup-chn #f cursor 505 play 506; 507 508: pprev-cb { vars -- prc; w c i self -- val } 509 3 proc-create ( prc ) 510 vars , 511 does> { w c info self -- val } 512 self @ ( vars ) :stopping #t array-assoc-set! 513 ( vars ) :stop-widget array-assoc-ref "Stop" change-label 514 graph-popup-snd 515 :channel graph-popup-chn 516 :edit-position graph-popup-snd graph-popup-chn edit-position 1- 517 play 518; 519 520: porig-cb { vars -- prc; w c i self -- val } 521 3 proc-create ( prc ) 522 vars , 523 does> { w c info self -- val } 524 self @ ( vars ) :stopping #t array-assoc-set! 525 ( vars ) :stop-widget array-assoc-ref "Stop" change-label 526 graph-popup-snd :channel graph-popup-chn :edit-position 0 play 527; 528 529: pundo-cb <{ w c info -- val }> 530 1 graph-popup-snd graph-popup-chn undo 531; 532 533: predo-cb <{ w c info -- val }> 534 1 graph-popup-snd graph-popup-chn redo 535; 536 537: prev-cb <{ w c info -- val }> 538 graph-popup-snd revert-sound 539; 540 541: popen-cb <{ w c info -- val }> 542 #t open-file-dialog 543; 544 545: psave-cb <{ w c info -- val }> 546 graph-popup-snd save-sound 547; 548 549: psaveas-cb <{ w c info -- val }> 550 graph-popup-snd select-sound drop #t save-sound-dialog 551; 552 553: pupdate-cb <{ w c info -- val }> 554 graph-popup-snd update-sound 555; 556 557: pclose-cb <{ w c info -- val }> 558 graph-popup-snd close-sound-extend 559 #f 560; 561 562: pmixsel-cb <{ w c info -- val }> 563 graph-popup-snd graph-popup-chn #f cursor 564 graph-popup-snd graph-popup-chn mix-selection 565; 566 567: pinssel-cb <{ w c info -- val }> 568 graph-popup-snd graph-popup-chn #f cursor 569 graph-popup-snd graph-popup-chn insert-selection 570; 571 572: prepsel-cb <{ w c info -- val }> 573 graph-popup-snd { snd } 574 graph-popup-chn { chn } 575 snd chn #f cursor { beg } 576 snd chn selection-framples { len } 577 snd chn selection-position { sbeg } 578 snd chn selection-member? not 579 beg len + sbeg < || 580 beg sbeg len + > || if 581 beg len snd chn #f delete-samples drop 582 beg snd chn insert-selection 583 else 584 beg sbeg < if 585 beg sbeg beg - snd chn #f delete-samples 586 else 587 #f 588 then 589 then 590; 591 592: pselall-cb <{ w c info -- val }> 593 graph-popup-snd graph-popup-chn select-all 594; 595 596: punsel-cb <{ w c info -- val }> 597 #f #t #f set-selection-member? 598; 599 600: papcnt-cb <{ w c info -- val }> 601 \ (apply-controls :optional snd (choice 0) (beg 0) (dur len)) 602 \ choice: 0 snd 603 \ 1 chn 604 \ 2 sel 605 graph-popup-snd 0 undef undef apply-controls 606; 607 608: precnt-cb <{ w c info -- val }> 609 graph-popup-snd reset-controls 610; 611 612: print-props { props -- str } 613 object-print-length { old-len } 614 print-length { old-vct-len } 615 3 set-object-print-length 616 3 set-print-length drop 617 "" ( str ) 618 props each { prop } \ ( key . val ) 619 ( str ) 620 " %s: %s\n" 621 #( prop 0 array-ref prop 1 array-ref ) string-format $+ 622 end-each 623 ( str ) 624 old-len set-object-print-length 625 old-vct-len set-print-length drop 626 ( str ) 627; 628 629: paddmrk-cb <{ w c info -- val }> 630 graph-popup-snd graph-popup-chn #f cursor ( samp ) 631 graph-popup-snd graph-popup-chn #f ( name ) 0 ( sync ) add-mark 632; 633 634: pdelmrk-cb <{ w c info -- val }> 635 graph-popup-snd graph-popup-chn #f marks { ms } 636 ms nil? unless 637 ms length 1 = if 638 ms 0 array-ref delete-mark drop 639 else 640 graph-popup-snd graph-popup-chn #f cursor { loc } 641 ms 0 array-ref { id } 642 loc id undef mark-sample - abs { cur-min } 643 ms each { m } 644 loc m undef mark-sample - abs { this-min } 645 this-min cur-min < if 646 this-min to cur-min 647 m to id 648 then 649 end-each 650 id delete-mark 651 then 652 then 653 #f 654; 655 656: pdelamrk-cb <{ w c info -- val }> 657 graph-popup-snd graph-popup-chn delete-marks 658; 659 660: pnextmrk-cb <{ w c info -- val }> 661 [char] j 4 graph-popup-snd graph-popup-chn key \ C-j 662; 663 664: plastmrk-cb <{ w c info -- val }> 665 [char] - 4 graph-popup-snd graph-popup-chn key drop \ C-- 666 [char] j 4 graph-popup-snd graph-popup-chn key \ C-j 667; 668 669: pnorm-cb <{ w c info -- val }> 670 1.0 graph-popup-snd graph-popup-chn scale-to 671; 672 673: pinfo-cb <{ w c info -- val }> 674 graph-popup-snd { snd } 675 graph-popup-chn { chn } 676 snd chn #f framples { frms } 677 snd srate { sr } 678 " chans: %d, srate: %d\n" #( snd channels sr ) string-format ( str ) 679 " format: %s [%s]\n" 680 #( snd sample-type mus-sample-type-name 681 snd header-type mus-header-type-name ) string-format $+ 682 " length: %.3f (%d framples)\n" #( frms sr f/ frms ) string-format $+ 683 snd #t #f maxamp each { mx } 684 "%6s %c: %.3f\n" #( "maxamp" [char] A i + mx ) string-format $+ 685 end-each 686 snd comment empty? unless 687 " comment: %s\n" #( snd comment ) string-format $+ 688 then 689 snd file-name mus-sound-loop-info { loops } 690 loops nil? unless 691 " loop: %s\n" #( loops ) string-format $+ 692 then 693 snd header-type mus-soundfont = if 694 " sounds: %s\n" #( snd soundfont-info ) string-format $+ 695 then 696 snd sound-properties { props } 697 props nil? unless 698 "properties:\n" $+ 699 props print-props $+ 700 then 701 snd channels 0 ?do 702 snd i channel-properties to props 703 props nil? unless 704 "chan %d properties:\n" #( i ) string-format $+ 705 props print-props $+ 706 then 707 loop { str } 708 snd file-name " info" $+ str info-dialog 709; 710 711: exit-cb <{ w c info -- val }> 712 0 snd-exit 713; 714 715let: ( -- menu ) 716 #a( :stopping #f :stop-widget #f ) { vars } 717 stop-playing-hook vars stop-playing-cb add-hook! 718 "graph-popup" main-widgets 2 array-ref 719 #( #( "Snd" 'label #f #f ) 720 #( "sep" 'separator #f #f ) 721 #( "Play" #f vars play-cb vars stop-cb ) 722 #( "Play channel" #f vars pchan-cb #f ) 723 #( "Play from cursor" #f vars pcur-cb #f ) 724 #( "Play previous" #f vars pprev-cb #f ) 725 #( "Play original" #f vars porig-cb #f ) 726 #( "Undo" #f <'> pundo-cb #f ) 727 #( "Redo" #f <'> predo-cb #f ) 728 #( "Revert" #f <'> prev-cb #f ) 729 #( "Open" #f <'> popen-cb #f ) 730 #( "Save" #f <'> psave-cb #f ) 731 #( "Save as" #f <'> psaveas-cb #f ) 732 #( "Update" #f <'> pupdate-cb #f ) 733 #( "Close" #f <'> pclose-cb #f ) 734 #( "Mix selection" #f <'> pmixsel-cb #f ) 735 #( "Insert selection" #f <'> pinssel-cb #f ) 736 #( "Replace with selection" #f <'> prepsel-cb #f ) 737 #( "Select all" #f <'> pselall-cb #f ) 738 #( "Unselect" #f <'> punsel-cb #f ) 739 #( "Apply controls" #f <'> papcnt-cb #f ) 740 #( "Reset controls" #f <'> precnt-cb #f ) 741 #( "Add mark" #f <'> paddmrk-cb #f ) 742 #( "Delete mark" #f <'> pdelmrk-cb #f ) 743 #( "Delete all marks" #f <'> pdelamrk-cb #f ) 744 #( "To next mark" #f <'> pnextmrk-cb #f ) 745 #( "To last mark" #f <'> plastmrk-cb #f ) 746 #( "-> 1.0" #f <'> pnorm-cb #f ) 747 #( "Info" #f <'> pinfo-cb #f ) 748 #( "sep" 'separator #f #f ) 749 #( "Exit" #f <'> exit-cb #f ) 750 ) make-popup-menu 751;let constant graph-popup-menu 752 753: graph-popup-cb { snd chn -- prc; w self -- } 754 1 proc-create ( prc ) 755 chn , snd , 756 does> { w self -- } 757 self @ { chn } 758 self cell+ @ { snd } 759 snd chn edits { eds } 760 w widget->name { name } 761 name "Snd" string= if 762 snd channels 1 > if 763 "%s[%d]" 764 #( snd short-file-name chn ) 765 string-format w swap change-label 766 else 767 w snd short-file-name change-label 768 then 769 #f 770 exit 771 then 772 name "Save" string= 773 name "Undo" string= || 774 name "Revert" string= || 775 name "Play previous" string= || if 776 w eds 0 array-ref 0> if 777 show-widget 778 else 779 hide-widget 780 then 781 exit 782 then 783 name "Play channel" string= if 784 w snd channels 1 > if 785 show-widget 786 else 787 hide-widget 788 then 789 exit 790 then 791 name "Redo" string= if 792 w eds 1 array-ref 0> if 793 show-widget 794 else 795 hide-widget 796 then 797 exit 798 then 799 name "Mix selection" string= 800 name "Insert selection" string= || 801 name "Unselect" string= || 802 name "Replace with selection" string= || if 803 w undef selection? if 804 show-widget 805 else 806 hide-widget 807 then 808 exit 809 then 810 name "Play from cursor" string= if 811 w snd chn #f cursor 0> if 812 show-widget 813 else 814 hide-widget 815 then 816 exit 817 then 818 name "Play original" string= if 819 w eds 0 array-ref 1 > if 820 show-widget 821 else 822 hide-widget 823 then 824 exit 825 then 826 name "Delete mark" string= 827 name "Delete all marks" string= || 828 name "To next mark" string= || 829 name "To last mark" string= || if 830 w snd chn #f marks nil? unless 831 show-widget 832 else 833 hide-widget 834 then 835 else 836 #f 837 then 838; 839 840\ --- fft popup --- 841: choose-chan ( -- chn ) 842 graph-popup-snd channel-style channels-separate = if 843 graph-popup-chn 844 else 845 #t 846 then 847; 848 849: fft-peaks-cb <{ w c info -- val }> 850 graph-popup-snd graph-popup-chn show-transform-peaks not 851 graph-popup-snd choose-chan set-show-transform-peaks 852; 853 854: fft-db-cb <{ w c info -- val }> 855 graph-popup-snd graph-popup-chn fft-log-magnitude not 856 graph-popup-snd choose-chan set-fft-log-magnitude 857; 858 859: fft-frq-cb <{ w c info -- val }> 860 graph-popup-snd graph-popup-chn fft-log-frequency not 861 graph-popup-snd choose-chan set-fft-log-frequency 862; 863 864: fft-norm-cb <{ w c info -- val }> 865 graph-popup-snd graph-popup-chn 866 transform-normalization dont-normalize = if 867 normalize-by-channel graph-popup-snd choose-chan 868 else 869 dont-normalize graph-popup-snd choose-chan 870 then set-transform-normalization 871; 872 873: grp-lst-cb { val -- prc; w c i self -- val } 874 3 proc-create ( prc ) 875 val , 876 does> { w c info self -- val } 877 self @ ( val ) graph-popup-snd choose-chan set-transform-graph-type 878; 879 880: grp-labs ( -- ary ) 881 #( #( "once" graph-once grp-lst-cb ) 882 #( "sonogram" graph-as-sonogram grp-lst-cb ) 883 #( "spectrogram" graph-as-spectrogram grp-lst-cb ) ) 884; 885 886: grp-set <{ lst -- }> 887 graph-popup-snd graph-popup-chn transform-graph-type { tp } 888 lst each ( child ) 889 i tp <> set-sensitive 890 end-each 891; 892 893#( 32 64 128 256 512 1024 2048 4096 8192 16384 65536 262144 1048576 ) 894 constant fft-siz-sizes 895 896: siz-lst-cb { val -- prc; w c i self -- val } 897 3 proc-create ( prc ) 898 val , 899 does> { w c info self -- val } 900 self @ ( val ) graph-popup-snd choose-chan set-transform-size 901; 902 903: siz-labs ( -- ary ) 904 fft-siz-sizes map 905 #( *key* object->string *key* siz-lst-cb ) 906 end-map ( ary ) 907; 908 909: siz-set <{ lst -- }> 910 graph-popup-snd graph-popup-chn transform-size { siz } 911 lst each ( child ) 912 fft-siz-sizes i array-ref siz <> set-sensitive 913 end-each 914; 915 916#( rectangular-window 917 hann-window 918 welch-window 919 parzen-window 920 bartlett-window 921 hamming-window 922 blackman2-window 923 blackman3-window 924 blackman4-window 925 exponential-window 926 riemann-window 927 kaiser-window 928 cauchy-window 929 poisson-window 930 gaussian-window 931 tukey-window 932 dolph-chebyshev-window 933 hann-poisson-window 934 connes-window 935 samaraki-window 936 ultraspherical-window 937 bartlett-hann-window 938 bohman-window 939 flat-top-window 940 blackman5-window 941 blackman6-window 942 blackman7-window 943 blackman8-window 944 blackman9-window 945 blackman10-window 946 rv2-window 947 rv3-window 948 rv4-window 949 mlt-sine-window 950 papoulis-window 951 sinc-window ) constant fft-win-windows 952 953: win-lst-cb { val -- prc; w c i self -- val } 954 3 proc-create ( prc ) 955 val , 956 does> { w c info self -- val } 957 self @ ( val ) graph-popup-snd choose-chan set-fft-window 958; 959 960: win-labs ( -- ary ) 961 #( "Rectangular" 962 "Hann" 963 "Welch" 964 "Parzen" 965 "Bartlett" 966 "Hamming" 967 "Blackman2" 968 "Blackman3" 969 "Blackman4" 970 "Exponential" 971 "Riemann" 972 "Kaiser" 973 "Cauchy" 974 "Poisson" 975 "Gaussian" 976 "Tukey" 977 "Dolph-Chebyshev" 978 "Hann-Poisson" 979 "Connes" 980 "Samaraki" 981 "Ultraspherical" 982 "Bartlett-Hann" 983 "Bohman" 984 "Flat-top" 985 "Blackman5" 986 "Blackman6" 987 "Blackman7" 988 "Blackman8" 989 "Blackman9" 990 "Blackman10" 991 "Rife-Vincent2" 992 "Rife-Vincent3" 993 "Rife-Vincent4" 994 "MLT Sine" 995 "Papoulis" 996 "Sinc" ) map 997 #( *key* fft-win-windows i array-ref win-lst-cb ) 998 end-map 999; 1000 1001: win-set <{ lst -- }> 1002 graph-popup-snd graph-popup-chn fft-window { win } 1003 lst each ( child ) 1004 fft-win-windows i array-ref win <> set-sensitive 1005 end-each 1006; 1007 1008#( fourier-transform 1009 wavelet-transform 1010 walsh-transform 1011 autocorrelation 1012 cepstrum 1013 haar-transform ) value fft-trn-transform 1014 1015: trn-lst-cb { val -- prc; w c i self -- val } 1016 3 proc-create ( prc ) 1017 val , 1018 does> { w c info self -- } 1019 self @ ( val ) graph-popup-snd choose-chan set-transform-type 1020; 1021 1022: trn-labs ( -- ary ) 1023 #( "Fourier" "Wavelet" "Walsh" "Autocorrelate" "Cepstrum" "Haar" ) map 1024 #( *key* fft-trn-transform i array-ref trn-lst-cb ) 1025 end-map ( ary ) 1026; 1027 1028: trn-set <{ lst -- }> 1029 graph-popup-snd graph-popup-chn transform-type { trn } 1030 lst each ( child ) 1031 fft-trn-transform i array-ref trn equal? not set-sensitive 1032 end-each 1033; 1034 1035: typ-lst-cb { val -- prc; w c i self -- val } 1036 3 proc-create ( prc ) 1037 val , 1038 does> { w c info self -- val } 1039 self @ ( val ) graph-popup-snd choose-chan set-wavelet-type 1040; 1041 1042: typ-labs ( -- ary ) 1043 #( "doub4" 1044 "doub6" 1045 "doub8" 1046 "doub10" 1047 "doub12" 1048 "doub14" 1049 "doub16" 1050 "doub18" 1051 "doub20" 1052 "battle-lemarie" 1053 "burt-adelson" 1054 "beylkin" 1055 "coif2" 1056 "coif4" 1057 "coif6" 1058 "sym2" 1059 "sym3" 1060 "sym4" 1061 "sym5" 1062 "sym6" 1063 "doub22" 1064 "doub24" 1065 "doub26" 1066 "doub28" 1067 "doub30" 1068 "doub32" 1069 "doub34" 1070 "doub36" 1071 "doub38" 1072 "doub40" 1073 "doub42" 1074 "doub44" 1075 "doub46" 1076 "doub48" 1077 "doub50" 1078 "doub52" 1079 "doub54" 1080 "doub56" 1081 "doub58" 1082 "doub60" 1083 "doub62" 1084 "doub64" 1085 "doub66" 1086 "doub68" 1087 "doub70" 1088 "doub72" 1089 "doub74" 1090 "doub76" ) map 1091 #( *key* i typ-lst-cb ) 1092 end-map 1093; 1094 1095: typ-set <{ lst -- }> 1096 graph-popup-snd graph-popup-chn wavelet-type { tp } 1097 lst each ( child ) 1098 i tp <> set-sensitive 1099 end-each 1100; 1101 1102: fft-color <{ w c info -- val }> 1103 #t color-orientation-dialog 1104; 1105 1106let: ( -- menu ) 1107 "fft-popup" main-widgets 2 array-ref 1108 #( #( "Transform" 'label #f #f ) 1109 #( "sep" 'separator #f #f ) 1110 #( "Peaks" #f <'> fft-peaks-cb #f ) 1111 #( "dB" #f <'> fft-db-cb #f ) 1112 #( "Log freq" #f <'> fft-frq-cb #f ) 1113 #( "Normalize" #f <'> fft-norm-cb #f ) 1114 #( "Graph type" 'cascade grp-labs <'> grp-set ) 1115 #( "Size" 'cascade siz-labs <'> siz-set ) 1116 #( "Window" 'cascade win-labs <'> win-set ) 1117 #( "Transform type" 'cascade trn-labs <'> trn-set ) 1118 #( "Wavelet type" 'cascade typ-labs <'> typ-set ) 1119 #( "Color/Orientation" #f <'> fft-color #f ) 1120 ) make-popup-menu 1121;let constant fft-popup-menu 1122 1123: fft-popup-cb { snd chn -- prc; w self -- val } 1124 1 proc-create ( prc ) 1125 chn , snd , 1126 does> { w self -- val } 1127 self @ { chn } 1128 self cell+ @ { snd } 1129 w widget->name { name } 1130 name "Peaks" string= if 1131 w snd chn show-transform-peaks if 1132 "No peaks" 1133 else 1134 "Peaks" 1135 then change-label 1136 else 1137 name "dB" string= if 1138 w snd chn fft-log-magnitude if 1139 "Linear" 1140 else 1141 "dB" 1142 then change-label 1143 else 1144 name "Log freq" string= if 1145 w snd chn fft-log-frequency if 1146 "Linear freq" 1147 else 1148 "Log freq" 1149 then change-label 1150 then 1151 then 1152 then 1153 cascade-popup-cb-list each { entry } 1154 entry 0 array-ref #( entry 1 array-ref ) run-proc drop 1155 end-each 1156 #f 1157; 1158 1159: popup-install { snd chn xe ye info -- } 1160 snd chn transform-graph? if 1161 snd chn transform-graph axis-info 1162 else 1163 #f 1164 then { fax } 1165 snd chn lisp-graph? if 1166 snd chn lisp-graph axis-info 1167 else 1168 #f 1169 then { lax } 1170 fax if 1171 xe fax 10 array-ref >= 1172 xe fax 12 array-ref <= && if 1173 \ in fft 1174 fft-popup-menu snd chn fft-popup-cb for-each-child 1175 fft-popup-menu info popup-post-it 1176 #f 1177 else 1178 #t 1179 then 1180 else 1181 #t 1182 then if 1183 lax if 1184 xe lax 10 array-ref >= 1185 xe lax 12 array-ref <= && if 1186 \ in lisp 1187 #f 1188 else 1189 #t 1190 then 1191 else 1192 #t 1193 then if 1194 undef selection? if 1195 snd graph-popup-chn selection-position { pos } 1196 snd srate { sr } 1197 \ BEG and END should be floats 1198 pos sr f/ { beg } 1199 pos snd graph-popup-chn selection-framples f+ 1200 sr f/ { end } 1201 xe beg snd chn undef x->position >= 1202 xe end snd chn undef x->position <= && if 1203 selection-popup-menu info popup-post-it 1204 #f 1205 else 1206 #t 1207 then 1208 else 1209 #t 1210 then if 1211 graph-popup-menu 1212 graph-popup-snd graph-popup-chn 1213 graph-popup-cb for-each-child 1214 graph-popup-menu info popup-post-it 1215 then 1216 then 1217 then 1218; 1219 1220\ --- edit history popup --- 1221#() value edhist-funcs 1222#() value edhist-widgets 1223: edhist-snd ( -- snd ) #f snd-snd ; 1224: edhist-chn ( -- chn ) #f snd-chn ; 1225 1226: edhist-funcs-index { key -- idx|-1 } 1227 -1 ( idx ) 1228 edhist-funcs each 1229 ( val ) car key equal? if 1230 drop \ drop -1 1231 i \ set to current index 1232 leave 1233 then 1234 end-each ( idx ) 1235; 1236 1237: edhist-funcs-ref { key -- val|#f } 1238 key edhist-funcs-index { idx } 1239 idx 0>= if 1240 edhist-funcs idx array-ref cadr \ => proc 1241 else 1242 #f 1243 then 1244; 1245 1246: edhist-funcs-set! { key val -- } 1247 key edhist-funcs-index { idx } 1248 idx 0>= if 1249 edhist-funcs idx #( key val ) array-set! 1250 else 1251 edhist-funcs #( key val ) array-push to edhist-funcs 1252 then 1253; 1254 1255: edhist-clear-edits <{ w c info -- #f }> 1256 #() to edhist-funcs 1257 #f 1258; 1259 1260: edhist-save-edits <{ w c info -- val }> 1261 edhist-snd { snd } 1262 edhist-chn { chn } 1263 #( snd chn ) edhist-funcs-ref { old-prc } 1264 snd chn edits { cur-edits } 1265 0 ( sum ) 1266 cur-edits each ( val ) 1267 + ( sum += val ) 1268 end-each { sum } 1269 snd chn cur-edits car 1+ sum edit-list->function { prc } 1270 edhist-save-hook #( prc ) run-hook drop 1271 #( snd chn ) prc edhist-funcs-set! 1272 #f 1273; 1274 1275: edhist-reapply-edits <{ w c info -- val }> 1276 #( edhist-snd edhist-chn ) edhist-funcs-ref { prc } 1277 prc proc? if 1278 prc #( edhist-snd edhist-chn ) run-proc 1279 else 1280 #f 1281 then 1282; 1283 1284: edhist-set-wid <{ w -- }> 1285 edhist-widgets w array-push to edhist-widgets 1286; 1287 1288: edhist-apply <{ w c info -- val }> 1289 \ context (c) is index (i) from edhist-apply-edits, see below 1290 edhist-funcs c range? if 1291 edhist-funcs c array-ref cadr ( prc ) 1292 #( edhist-snd edhist-chn ) run-proc 1293 else 1294 #f 1295 then 1296; 1297 1298: edhist-apply-edits <{ dummy -- val }> 1299 edhist-widgets car { parent } 1300 edhist-widgets cdr { wids } 1301 edhist-funcs each car { label } 1302 nil { button } 1303 wids nil? if 1304 parent "wid" 1305 #( FXmNbackground highlight-color ) 1306 FXmVaCreateManagedPushButton to button 1307 edhist-widgets button array-push to edhist-widgets 1308 \ index (i) is context (c) in edhist-apply, see above 1309 button FXmNactivateCallback 1310 <'> edhist-apply i FXtAddCallback drop 1311 else 1312 wids car to button 1313 wids cdr to wids 1314 button FXtManageChild drop 1315 then 1316 label array? if \ label: #( snd chn ) 1317 button "%s[%s]" 1318 #( label car short-file-name 1319 label cadr ) string-format 1320 else \ label: "file-name[chn]" 1321 button label 1322 then change-label 1323 end-each 1324 wids each ( w ) 1325 FXtUnmanageChild drop 1326 end-each 1327 #f 1328; 1329 1330: edhist-close-hook-cb <{ snd -- }> 1331 snd short-file-name { name } 1332 snd channels 0 ?do 1333 #( snd i ) edhist-funcs-ref { old-val } 1334 old-val array? if 1335 old-val 0 "%s[%d]" #( name i ) string-format array-set! 1336 then 1337 loop 1338; 1339 1340let: ( -- menu ) 1341 close-hook <'> edhist-close-hook-cb add-hook! 1342 "edhist-popup" main-widgets 2 array-ref 1343 #( #( "Edits" 'label #f #f ) 1344 #( "sep" 'separator #f #f ) 1345 #( "Save" #f <'> edhist-save-edits #f ) 1346 #( "Reapply" #f <'> edhist-reapply-edits #f ) 1347 #( "Apply" 'cascade <'> edhist-set-wid <'> edhist-apply-edits ) 1348 #( "Clear" #f <'> edhist-clear-edits #f ) 1349 #( "sep" 'separator #f #f ) 1350 #( "Help" #f <'> edhist-help-edits #f ) 1351 ) make-popup-menu 1352;let constant edit-history-menu 1353 1354: edhist-popup-cb <{ w -- val }> 1355 edhist-snd { snd } 1356 edhist-chn { chn } 1357 w FXtName { name } 1358 name "Clear" string= 1359 name "Apply" string= || if 1360 w edhist-funcs empty? not set-sensitive 1361 else 1362 name "Save" string= if 1363 snd chn edits { eds } 1364 0 ( sum ) 1365 eds each ( val ) 1366 + ( sum += val ) 1367 end-each { sum } 1368 w sum 0> set-sensitive 1369 else 1370 name "Reapply" string= if 1371 #( snd chn ) edhist-funcs-ref { prc } 1372 w prc word? set-sensitive 1373 then 1374 then 1375 then 1376 #f 1377; 1378 1379: edhist-popup-handler-cb <{ w c info -- val }> 1380 info Fevent { ev } 1381 FButtonPress ev Ftype = if 1382 edit-history-menu <'> edhist-popup-cb for-each-child 1383 edit-history-menu info popup-post-it 1384 then 1385 #f 1386; 1387 1388: popup-handler-cb <{ w c info -- val }> 1389 info Fevent { ev } 1390 ev Fx_root w 0 0 FXtTranslateCoords 0 array-ref - { xe } 1391 ev Fy { ye } 1392 FButtonPress ev Ftype = if 1393 edhist-snd edhist-chn xe ye info popup-install 1394 then 1395 #f 1396; 1397 1398\ --- listener popup --- 1399: identity-cb <{ snds -- lst }> 1400 snds 1401; 1402 1403: edited-cb <{ snds -- lst }> 1404 snds each { snd } 1405 snd channels 0 ?do 1406 snd i edits 0 array-ref 0= if 1407 snds snd array-delete-key drop 1408 then 1409 loop 1410 end-each 1411 snds 1412; 1413 1414: focused-cb <{ snds -- lst }> 1415 snds length 1 > if 1416 snds 1417 else 1418 #() 1419 then 1420; 1421 1422: list-play-cb <{ snd -- val }> 1423 snd play 1424; 1425 1426: list-focus-cb <{ us -- val }> 1427 \ 5 == notebook-outer-pane 1428 main-widgets 5 array-ref FWidget? if 1429 us set-selected-sound 1430 else 1431 us sound-widgets 0 array-ref { pane } 1432 main-widgets 1 array-ref #( FXmNallowShellResize #f ) 1433 FXtVaSetValues drop 1434 sounds each ( them ) 1435 sound-widgets 0 array-ref FXtUnmanageChild drop 1436 end-each 1437 pane FXtManageChild drop 1438 main-widgets 1 array-ref 1439 #( FXmNallowShellResize auto-resize ) 1440 FXtVaSetValues 1441 then 1442; 1443 1444: list-help-cb <{ w c info -- val }> 1445 listener-selection { selected } 1446 selected if 1447 selected undef snd-help { help } 1448 help if 1449 selected help info-dialog 1450 then 1451 then 1452; 1453 1454: list-clear-cb <{ w c info -- val }> 1455 clear-listener 1456; 1457 1458: listener-edit <{ w -- }> 1459 w FXtName "Help" string= if 1460 listener-selection ?dup-if 1461 1 >list w "Help on %S" rot 1462 string-format change-label 1463 w FXtManageChild 1464 else 1465 w FXtUnmanageChild 1466 then drop 1467 then 1468; 1469 1470: listener-popup-cb <{ w c info -- }> 1471 c { menu } 1472 FButtonPress info Fevent Ftype = if 1473 listener-values each { vals } 1474 vals array? if 1475 vals 0 array-ref { top-one } 1476 vals 1 array-ref { top-two } 1477 vals 2 array-ref { top-two-cascade } 1478 vals 3 array-ref #( sounds ) 1479 run-proc length { len } 1480 top-two FXtUnmanageChild drop 1481 top-two-cascade FXtUnmanageChild drop 1482 top-one if 1483 top-one FXtUnmanageChild drop 1484 then 1485 len 1 > if 1486 top-two-cascade FXtManageChild drop 1487 top-two FXtManageChild drop 1488 then 1489 top-one FWidget? 1490 len 1 = && if 1491 top-one FXtManageChild drop 1492 then 1493 then 1494 end-each 1495 menu <'> listener-edit for-each-child 1496 info menu Fset_menuToPost drop 1497 then 1498; 1499 1500let: ( -- menu ) 1501 main-widgets 4 array-ref ?dup-if 1502 ( parent ) 1503 else 1504 #t set-show-listener drop 1505 #f set-show-listener drop 1506 main-widgets 4 array-ref 1507 then { parent } 1508 "listener-popup" parent 1509 #( #( "Listener" 'label #f #f ) 1510 #( "sep" 'separator #f #f ) 1511 #( "Play" 'cascade <'> list-play-cb <'> identity-cb #t ) 1512 #( "Help" #f <'> list-help-cb #f ) 1513 #( "Open" #f <'> popen-cb #f ) 1514 #( "Clear listener" #f <'> list-clear-cb #f ) 1515 #( "Close" 'cascade <'> close-sound-extend <'> identity-cb #t ) 1516 #( "Save" 'cascade <'> save-sound <'> edited-cb #t ) 1517 #( "Revert" 'cascade <'> revert-sound <'> edited-cb #t ) 1518 #( "Focus" 'cascade <'> list-focus-cb <'> focused-cb #f ) 1519 #( "sep" 'separator #f #f ) 1520 #( "Exit" #f <'> exit-cb #f ) 1521 ) make-popup-menu { menu } 1522 parent FXmNpopupHandlerCallback <'> listener-popup-cb menu 1523 FXtAddCallback drop 1524 menu 1525;let constant listener-popup-menu 1526 1527#() constant popups 1528: add-popup <{ snd -- }> 1529 snd channels 0 ?do 1530 popups #( snd i ) array-member? unless 1531 popups #( snd i ) array-push to popups 1532 snd i channel-widgets 7 array-ref ( chn-edhist ) 1533 FXmNpopupHandlerCallback 1534 <'> edhist-popup-handler-cb undef 1535 FXtAddCallback drop 1536 snd i channel-widgets 0 array-ref ( chn-grf ) 1537 FXmNpopupHandlerCallback <'> popup-handler-cb 1538 undef FXtAddCallback drop 1539 then 1540 loop 1541; 1542 1543: change-color-col-cb { col -- prc; w self -- val } 1544 1 proc-create ( prc ) 1545 col , 1546 does> { w self -- val } 1547 w self @ ( col ) FXmChangeColor 1548; 1549set-current 1550 1551: change-menu-color ( menu new-color -- ) 1552 doc" Change the color of MENU to NEW-COLOR. \ 1553NEW-COLOR can be the color name, an xm Pixel, a snd color, \ 1554or a list of rgb values (as in Snd's make-color)." 1555 { menu new-color } 1556 new-color string? if \ assuming X11 color names here 1557 main-widgets 1 array-ref { shell } 1558 shell FXtDisplay { dpy } 1559 dpy FDefaultScreen { scr } 1560 dpy scr FDefaultColormap { cmap } 1561 FXColor { col } 1562 dpy cmap new-color col col FXAllocNamedColor 0= if 1563 "can't allocate %S" 1564 #( new-color ) string-format snd-error 1565 else 1566 col Fpixel 1567 then 1568 else 1569 new-color color? if 1570 new-color 1571 else 1572 new-color each 1573 ( vals-to-stack ) 1574 end-each make-color 1575 then 1576 then ( color-pixel ) menu swap 1577 change-color-col-cb for-each-child 1578; 1579 1580: change-selection-popup-color ( new-color -- ) 1581 doc" Change the selection popup menu's color: \ 1582\"red\" change-selection-popup-color." 1583 selection-popup-menu swap change-menu-color 1584; 1585 1586: change-graph-popup-color ( new-color -- ) 1587 doc" Change the time-domain popup menu's color: \ 1588basic-color change-graph-popup-color." 1589 selection-popup-menu swap change-menu-color 1590; 1591 1592: change-fft-popup-color ( new-color -- ) 1593 doc" Change the fft popup menu's color: \ 1594#(0.5 0.5 0.5) change-fft-popup-color." 1595 fft-popup-menu swap change-menu-color 1596; 1597 1598: change-edhist-popup-color ( new-color -- ) 1599 doc" Change the time-domain popup menu's color: \ 1600basic-color change-graph-popup-color." 1601 edit-history-menu swap change-menu-color 1602; 1603 1604: change-listener-popup-color ( new-color -- ) 1605 doc" Change the listener popup menu's color." 1606 listener-popup-menu swap change-menu-color 1607; 1608 1609: add-popups ( -- ) 1610 after-open-hook <'> add-popup add-hook! 1611 sounds each ( snd ) 1612 add-popup 1613 end-each 1614; 1615previous 1616 1617\ install all popups 1618add-popups 1619 1620\ popup.fs ends here 1621