1\ snd-xm.fs -- snd-motif|snd-xm.rb --> snd-xm.fs 2 3\ Author: Michael Scholz <mi-scholz@users.sourceforge.net> 4\ Created: 05/12/26 22:36:46 5\ Changed: 20/11/29 02:58:28 6\ 7\ @(#)snd-xm.fs 1.44 11/29/20 8 9\ Commentary: 10\ 11\ Requires --with-motif 12\ 13\ Tested with Snd 21.x 14\ Fth 1.4.x 15\ Motif 2.3.3 X11R6 16\ 17\ widget? ( w -- f ) 18\ set-sensitive ( w f -- ) 19\ is-managed? ( w -- f ) 20\ change-label ( widget new-label -- ) 21\ for-each-child ( widget prc -- ) 22\ load-font ( name -- fid|#f ) 23\ host-name ( -- host ) 24\ add-main-pane ( name class args -- wid ) 25\ raise-dialog ( dialog -- ) 26\ activate-dialog ( dialog -- ) 27\ show-disk-space ( snd -- ) 28\ 29\ main-dpy ( -- dpy ) 30\ current-screen ( -- scr ) 31\ white-pixel ( -- pix ) 32\ black-pixel ( -- pix ) 33\ screen-depth ( -- n ) 34\ 35\ children->array ( widget -- array ) 36\ find-child ( widget name -- wid ) 37\ widget-exists? ( widget name -- f ) 38\ main-widget-exists? ( name -- f ) 39\ display-widget-tree ( widget -- ) 40\ set-main-color-of-widget ( w -- ) 41\ 42\ add-channel-pane ( snd chn name type args -- wid ) 43\ add-sound-pane ( snd name type args -- wid ) 44\ add-listener-pane ( name type args -- wid ) 45\ 46\ add-mark-pane ( -- ) 47\ 48\ current-label ( widget -- label ) 49 50\ Code: 51 52'snd-nogui provided? [if] skip-file [then] 53 54"X error" create-exception x-error 55 56require extensions 57 58\ 59\ main-widgets 60\ 610 constant top-level-application 621 constant top-level-shell 632 constant main-pane-shell 643 constant main-sound-pane 654 constant listener-pane 665 constant notebook-outer-pane 67 68\ 69\ usage: top-level-shell main-widgets-ref { wid } 70\ 71: main-widgets-ref { idx -- w } 72 main-widgets idx array-ref 73; 74 75\ 76\ menu-widgets 77\ 780 constant top-menu-bar 791 constant file-menu 802 constant edit-menu 813 constant view-menu 824 constant options-menu 835 constant help-menu 84 85: menu-widgets-ref { idx -- w } 86 menu-widgets idx array-ref 87; 88 89\ 90\ sound-widgets 91\ 920 constant sw-main-pane 931 constant sw-name-label 942 constant sw-control-panel 953 constant sw-minibuffer 964 constant sw-play 975 constant sw-filter-graph 986 constant sw-unite 997 constant sw-minibuffer-label 1008 constant sw-name-icon 1019 constant sw-sync 102 103: sound-widgets-ref { snd idx -- w } 104 snd sound-widgets idx array-ref 105; 106 107\ 108\ channel-widgets 109\ 110 0 constant cw-graph 111 1 constant cw-w 112 2 constant cw-f 113 3 constant cw-sx 114 4 constant cw-sy 115 5 constant cw-zx 116 6 constant cw-zy 117 7 constant cw-edhist 118 8 constant cw-gsy 119 9 constant cw-gzy 12010 constant cw-channel-main-pane 121 122: channel-widgets-ref { snd chn idx -- w } 123 snd chn channel-widgets idx array-ref 124; 125 126\ 127\ dialog-widgets 128\ 129 0 constant dw-orientation-dialog 130 1 constant dw-enved-dialog 131 2 constant dw-transform-dialog 132 3 constant dw-file-open-dialog 133 4 constant dw-file-save-as-dialog 134 5 constant dw-view-files-dialog 135 6 constant dw-raw-data-dialog 136 7 constant dw-new-file-dialog 137 8 constant dw-file-mix-dialog 138 9 constant dw-edit-header-dialog 13910 constant dw-find-dialog 14011 constant dw-help-dialog 14112 constant dw-mix-panel-dialog 14213 constant dw-print-dialog 14314 constant dw-region-dialog 14415 constant dw-info-dialog 14516 constant dw-extra-controls-dialog 14617 constant dw-save-selection-dialog 14718 constant dw-insert-file-dialog 14819 constant dw-save-region-dialog 14920 constant dw-preferences-dialog 150 151: dialog-widgets-ref { idx -- w } 152 dialog-widgets idx array-ref 153; 154 155\ 156\ dialog-ok-widget ( dialog -- child ) 157\ dialog-cancel-widget ( dialog -- child ) 158\ dialog-help-widget ( dialog -- child ) 159\ 160\ These words take a dialog widget and return the corresponding button 161\ widgets. 162\ 163'( "ok" "cancel" "help" ) let: ( button -- ) 164 each { name } 165 "\ 166: dialog-%s-widget ( dialog -- child ) 167 FXmDIALOG_%s_BUTTON FXmMessageBoxGetChild 168;" '( name dup string-upcase ) string-format string-eval 169 end-each 170;let 171 172: xm-length ( lst -- lst len/2 ) 173 dup length 2/ 174; 175 176\ 177\ Some Motif convenience functions not found in snd/xm.c but in 178\ include/Xm/*.h 179\ 180\ It creates for example: 181\ 182\ '( "Label" ) let: ... ;let ==> 183\ FXmVaCreateManagedLabel ( parent name args -- w ) 184\ 185'( "ArrowButton" 186 "ArrowButtonGadget" 187 "BulletinBoard" 188 "CascadeButton" 189 "CascadeButtonGadget" 190 "ComboBox" 191 "Command" 192 "Container" 193 "DrawingArea" 194 "DrawnButton" 195 "FileSelectionBox" 196 "Form" 197 "Frame" 198 "Label" 199 "LabelGadget" 200 "List" 201 "MainWindow" 202 "MenuBar" 203 "MessageBox" 204 "Notebook" 205 "PanedWindow" 206 "PushButton" 207 "PushButtonGadget" 208 "RowColumn" 209 "Scale" 210 "ScrollBar" 211 "ScrolledWindow" 212 "ScrolledText" 213 "SelectionBox" 214 "Separator" 215 "SeparatorGadget" 216 "SimpleSpinBox" 217 "SpinBox" 218 "Text" 219 "TextField" 220 "ToggleButton" 221 "ToggleButtonGadget" ) let: ( names -- ) 222 each { name } 223 "\ 224: FXmVaCreateManaged%s ( parent name args -- w ) 225 xm-length FXmCreate%s dup FXtManageChild drop 226;" '( name dup ) string-format <'> string-eval #t nil fth-catch { tag } 227 tag if stack-reset then 228 end-each 229;let 230 231\ ;;; -------- show-disk-space 232\ ;;; 233\ ;;; adds a label to the minibuffer area showing the current free space 234 235hide 236#() value labelled-snds 237 238: kmg { num -- str } 239 num 0<= if 240 "disk full!" 241 else 242 "" { str } 243 num 1024 d> if 244 num 1024 1024 * d> if 245 "space: %6.3fG" #( num 1024.0 1024.0 f* f/ ) 246 else 247 "space: %6.3fM" #( num 1024.0 f/ ) 248 then 249 else 250 "space: %10dK" #( num ) 251 then string-format 252 then 253; 254set-current 255 256#f value showing-disk-space \ for prefs 257\ 258\ after-open-hook <'> show-disk-space add-hook! 259\ 260previous 261 262: widget? ( w -- f) 263 FWidget? 264; 265 266: set-sensitive ( w f -- ) 267 FXtSetSensitive drop 268; 269 270<'> FXtIsManaged alias is-managed? ( wid -- f ) 271 272: change-label ( wid new-label -- ) 273 doc" Change WIDGET's label to be NEW-LABEL." 274 { wid new-label } 275 new-label FXmStringCreateLocalized { str } 276 wid #( FXmNlabelString str ) FXtVaSetValues drop 277 str FXmStringFree drop 278; 279 280: for-each-child { wid prc -- } 281 doc" Apply PRC to WIDGET and each of its children." 282 prc #( wid ) run-proc drop 283 wid FXtIsComposite if 284 wid #( FXmNchildren 0 ) 285 FXtVaGetValues 1 array-ref each ( w ) 286 prc recurse 287 end-each 288 then 289; 290 291: main-dpy ( -- dpy ) 292 top-level-shell main-widgets-ref FXtDisplay 293; 294 295: load-font ( name -- fid|#f ) 296 { name } 297 main-dpy name FXLoadQueryFont { fs } 298 fs FXFontStruct? if 299 fs Ffid 300 else 301 #f 302 then 303; 304 305: current-screen ( -- scr ) 306 doc" Return the current X screen number of the current display." 307 main-dpy FDefaultScreenOfDisplay 308; 309 310: white-pixel ( -- pix ) current-screen FWhitePixelOfScreen ; 311: black-pixel ( -- pix ) current-screen FBlackPixelOfScreen ; 312: screen-depth ( -- n ) current-screen FDefaultDepthOfScreen ; 313 314\ --- apply func to every widget belonging to w --- 315 316hide 317: children->array-cb ( ary -- prc; child self -- ) 318 { ary } 319 1 proc-create ( prc ) 320 ary , 321 does> { child self -- } 322 self @ ( ary ) child array-push drop 323; 324set-current 325 326: children->array ( widget -- array ) 327 #() { ary } 328 ( widget ) ary children->array-cb for-each-child 329 ary 330; 331previous 332 333: find-child ( widget name -- wid ) 334 doc" Return a widget named NAME, if one can be found in the \ 335 widget hierarchy beneath WIDGET." 336 { widget name } 337 #f 338 widget children->array each { w } 339 w FXtName name string= if 340 not 341 w swap 342 leave 343 then 344 end-each unless 345 'no-such-widget 346 #( "%s: %S" get-func-name name ) fth-throw 347 then 348; 349 350: widget-exists? { widget name -- f } 351 #f ( flag ) widget children->array each ( w ) 352 FXtName name string= if 353 ( flag ) not leave 354 then 355 end-each ( flag ) 356; 357 358: main-widget-exists? { name -- f } 359 top-level-shell main-widgets-ref name widget-exists? 360; 361 362hide 363: display-widget <{ widget n -- }> 364 widget FXtName empty? if 365 "<unnamed>" 366 else 367 widget FXtName 368 then 369 n spaces .string cr 370 widget FXtIsComposite if 371 widget #( FXmNchildren 0 ) 372 FXtVaGetValues 1 array-ref each ( w ) 373 n 2 + recurse 374 end-each 375 then 376; 377set-current 378 379: display-widget-tree { widget -- } 380 doc" Display the hierarchy of widgets beneath WIDGET." 381 <'> display-widget #( widget 0 ) run-proc drop 382; 383previous 384 385hide 386: change-color-cb <{ w -- }> 387 w FXtIsWidget if 388 w FXmIsScrollBar if 389 w position-color FXmChangeColor drop 390 else 391 w basic-color FXmChangeColor drop 392 then 393 then 394; 395set-current 396 397: set-main-color-of-widget ( widget -- ) 398 doc" Set the background color of WIDGET." 399 <'> change-color-cb for-each-child 400; 401previous 402 403: host-name ( -- host ) 404 doc" Return name of current machine." 405 top-level-shell main-widgets-ref { wid } 406 wid FXtWindow { win } 407 main-dpy win main-dpy "WM_CLIENT_MACHINE" #f 408 FXInternAtom 0 32 #f FXA_STRING FXGetWindowProperty { host } 409 host if 410 host 5 array-ref 411 else 412 host 413 then 414; 415 416\ --- add our own pane to the channel section --- 417\ 418\ 0 0 "new-pane" FxmDrawingAreaWidgetClass 419\ #( FXmNbackground graph-color FXmNforeground data-color ) 420\ add-channel-pane value draw-widget 421 422: add-channel-pane { snd chn name typ args -- wid } 423 name typ snd chn cw-edhist channel-widgets-ref 424 FXtParent FXtParent args FXtCreateManagedWidget 425; 426 427\ --- add our own pane to the sound section (underneath the controls 428\ in this case) --- 429 430: add-sound-pane { snd name typ args -- wid } 431 name typ snd sw-main-pane sound-widgets-ref args 432 undef FXtCreateManagedWidget 433; 434 435\ --- add our own pane to the overall Snd window (underneath the 436\ listener in this case) --- 437 438: add-main-pane { name class args -- wid } 439 notebook-outer-pane main-widgets-ref dup unless 440 drop main-sound-pane main-widgets-ref 441 then { parent } 442 name class parent args undef FXtCreateManagedWidget 443; 444 445\ --- add a widget at the top of the listener --- 446 447: add-listener-pane { name typ args -- wid } 448 top-level-shell main-widgets-ref 449 "lisp-listener" find-child { listener } 450 listener FXtParent { listener-scroll } 451 listener-scroll FXtParent { listener-form } 452 listener-scroll FXtUnmanageChild drop 453 args 454 #( FXmNleftAttachment FXmATTACH_FORM 455 FXmNrightAttachment FXmATTACH_FORM 456 FXmNtopAttachment FXmATTACH_FORM ) array-append to args 457 name typ listener-form args 458 undef FXtCreateManagedWidget { top-widget } 459 listener-scroll 460 #( FXmNtopAttachment FXmATTACH_WIDGET 461 FXmNtopWidget top-widget ) FXtVaSetValues drop 462 listener-scroll FXtManageChild drop 463 top-widget 464; 465 466\ --- bring possibly-obscured dialog to top --- 467 468: raise-dialog ( dialog -- ) 469 { w } 470 w FWidget? if 471 w FXtIsManaged if 472 w FXtParent { parent } 473 parent FWidget? if 474 parent FxmDialogShellWidgetClass 475 FXtIsSubclass if 476 parent FXtGrabNone 477 FXtPopup drop 478 then 479 then 480 then 481 then 482; 483 484: activate-dialog ( dialog -- ) 485 dup FXtIsManaged if 486 raise-dialog 487 else 488 FXtManageChild drop 489 then 490; 491 492\ --- add-mark-pane --- 493 494#f value including-mark-pane 495 496hide 497#() value mark-list-lengths 498#() value mark-lists 499 500: find-mark-list { snd chn dats -- lst } 501 #f \ flag 502 dats each { dat } 503 snd dat 0 array-ref = 504 chn dat 1 array-ref = && if 505 drop \ drop flag 506 dat 2 array-ref 507 leave 508 then 509 end-each 510; 511 512: mark-list-length ( snd chn -- len ) 513 mark-list-lengths find-mark-list dup unless 514 drop 0 515 then 516; 517 518: set-mark-list-length { snd chn len -- } 519 mark-list-lengths each { dat } 520 snd dat 0 array-ref = 521 chn dat 1 array-ref = && if 522 mark-list-lengths i array-delete! drop 523 leave 524 then 525 end-each 526 mark-list-lengths #( snd chn len ) array-push drop 527; 528 529: mark-list ( snd chn -- lst ) 530 mark-lists find-mark-list dup if 531 2 array-ref 532 else 533 drop #() 534 then 535; 536 537: set-mark-list { snd chn lst -- } 538 mark-lists #( snd chn lst ) array-push drop 539; 540 541: deactivate-channel { snd chn -- } 542 snd chn mark-list-length 0> 543 snd chn mark-list FWidget? && if 544 snd chn mark-list #( FXmNchildren 0 ) 545 FXtVaGetValues 1 array-ref each ( w ) 546 FXtUnmanageChild drop 547 end-each 548 then 549; 550 551: marks-focus-cb <{ w c i -- f }> 552 w #( FXmNbackground white-pixel ) FXtVaSetValues 553; 554 555: marks-losing-focus-cb <{ w c i -- f }> 556 w #( FXmNbackground basic-color ) FXtVaSetValues 557; 558 559: marks-activate-cb <{ w c info -- }> 560 w #( FXmNuserData 0 ) FXtVaGetValues 1 array-ref { id } 561 w #( FXmNvalue 0 ) FXtVaGetValues 1 array-ref { txt } 562 txt string? 563 txt length 0> && if 564 txt string->number 565 else 566 #f 567 then 568 { samp } 569 samp if 570 id samp set-mark-sample 571 else 572 id delete-mark 573 then drop 574 w #( FXmNbackground basic-color ) FXtVaSetValues drop 575; 576 577: marks-enter-cb <{ w c i f -- f }> 578 mouse-enter-text-hook #( w ) run-hook 579; 580 581: marks-leave-cb <{ w c i f -- f }> 582 mouse-leave-text-hook #( w ) run-hook 583; 584 585: make-mark-list { snd chn -- } 586 snd chn mark-list-length { cur-len } 587 snd chn deactivate-channel 588 snd chn mark-list FWidget? unless 589 snd chn "mark-box" FxmFormWidgetClass 590 #( FXmNbackground basic-color 591 FXmNorientation FXmVERTICAL 592 FXmNpaneMinimum 100 593 FXmNbottomAttachment FXmATTACH_FORM ) 594 add-channel-pane { mark-box } 595 mark-box "Marks" 596 #( FXmNbackground highlight-color 597 FXmNleftAttachment FXmATTACH_FORM 598 FXmNrightAttachment FXmATTACH_FORM 599 FXmNalignment FXmALIGNMENT_CENTER 600 FXmNtopAttachment FXmATTACH_FORM ) 601 FXmVaCreateManagedLabel { mark-label } 602 mark-box "mark-scroller" 603 #( FXmNbackground basic-color 604 FXmNscrollingPolicy FXmAUTOMATIC 605 FXmNscrollBarDisplayPolicy FXmSTATIC 606 FXmNleftAttachment FXmATTACH_FORM 607 FXmNrightAttachment FXmATTACH_FORM 608 FXmNtopAttachment FXmATTACH_WIDGET 609 FXmNtopWidget mark-label 610 FXmNbottomAttachment FXmATTACH_FORM ) 611 FXmVaCreateManagedScrolledWindow { mark-scroller } 612 mark-scroller "mark-list" 613 #( FXmNorientation FXmVERTICAL 614 FXmNtopAttachment FXmATTACH_FORM 615 FXmNbottomAttachment FXmATTACH_FORM 616 FXmNspacing 0 ) 617 FXmVaCreateManagedRowColumn { mlist } 618 mark-scroller set-main-color-of-widget 619 mark-box #( FXmNpaneMinimum 1 ) FXtVaSetValues drop 620 snd chn #( snd chn mlist ) set-mark-list 621 then 622 snd chn #f marks { new-marks } 623 new-marks length cur-len > if 624 snd chn mark-list { lst } 625 new-marks length cur-len ?do 626 "field" FxmTextFieldWidgetClass lst 627 #( FXmNbackground basic-color ) 628 undef FXtCreateWidget { tf } 629 tf FXmNfocusCallback 630 <'> marks-focus-cb 631 undef FXtAddCallback drop 632 tf FXmNlosingFocusCallback 633 <'> marks-losing-focus-cb 634 undef FXtAddCallback drop 635 tf FXmNactivateCallback 636 <'> marks-activate-cb 637 undef FXtAddCallback drop 638 tf FEnterWindowMask #f 639 <'> marks-enter-cb 640 undef FXtAddEventHandler drop 641 tf FLeaveWindowMask #f 642 <'> marks-leave-cb 643 undef FXtAddEventHandler drop 644 loop 645 then 646 snd chn new-marks length set-mark-list-length 647 snd chn mark-list #( FXmNchildren 0 ) 648 FXtVaGetValues 1 array-ref each { wid } 649 new-marks empty? ?leave 650 wid FXmIsTextField if 651 wid #( FXmNvalue 652 new-marks car undef mark-sample 653 number->string 654 FXmNuserData 655 new-marks car ) FXtVaSetValues drop 656 wid FXtManageChild drop 657 new-marks array-shift to new-marks 658 then 659 end-each 660 #f 661; 662 663: remark <{ id snd chn reason -- }> 664 snd chn make-mark-list 665; 666 667: unremark <{ snd -- }> 668 snd channels 0 ?do 669 snd i deactivate-channel 670 loop 671; 672 673: marks-edit-cb { snd chn -- prc; self -- } 674 0 proc-create ( prc ) 675 chn , snd , 676 does> { self -- } 677 self @ { chn } 678 self cell+ @ { snd } 679 snd chn mark-list FWidget? if 680 snd chn make-mark-list 681 then 682; 683 684: open-remarks <{ snd -- }> 685 snd channels 0 ?do 686 snd i after-edit-hook snd i marks-edit-cb add-hook! 687 snd i undo-hook snd i marks-edit-cb add-hook! 688 loop 689; 690 691: marks-update-proc <{ snd -- }> 692 snd channels 0 ?do 693 snd i make-mark-list 694 loop 695; 696 697: marks-update-cb <{ snd -- proc }> 698 snd <'> marks-update-proc 699; 700set-current 701 702: add-mark-pane ( -- ) 703 #t to including-mark-pane 704 mark-hook <'> remark add-hook! 705 close-hook <'> unremark add-hook! 706 after-open-hook <'> open-remarks add-hook! 707 update-hook <'> marks-update-cb add-hook! 708; 709previous 710 711\ --- show-disk-space --- 712 713hide 714: show-label <{ data id -- }> 715 data 0 array-ref empty? unless 716 data 0 array-ref { snd } 717 data 1 array-ref { wid } 718 data 2 array-ref { app } 719 snd sound? if 720 wid snd file-name disk-kspace kmg change-label 721 then 722 app 10000 running-word data FXtAppAddTimeOut drop 723 then 724; 725set-current 726 727: show-disk-space <{ snd -- }> 728 doc" Add a label to the minibuffer area showing the current \ 729free space (for use with after-open-hook)." 730 #f ( flag ) 731 labelled-snds each { n } 732 n 0 array-ref snd equal? if 733 ( flag ) drop 734 n 735 leave 736 then 737 end-each { previous-label } 738 previous-label if 739 exit 740 then 741 snd sound? unless 742 "no sound found for disk space label" snd-error drop 743 exit 744 then 745 #t to showing-disk-space 746 top-level-application main-widgets-ref { app } 747 snd sw-minibuffer sound-widgets-ref { minibuffer } 748 snd sw-unite sound-widgets-ref { unite-button } 749 snd sw-sync sound-widgets-ref { sync-button } 750 minibuffer FXtParent { name-form } 751 snd file-name disk-kspace kmg FXmStringCreateLocalized { str } 752 minibuffer FXtUnmanageChild drop 753 minibuffer #( FXmNrightAttachment FXmATTACH_NONE ) 754 FXtVaSetValues drop 755 name-form "space" 756 #( FXmNbackground basic-color 757 FXmNleftAttachment FXmATTACH_NONE 758 FXmNlabelString str 759 FXmNrightAttachment FXmATTACH_WIDGET 760 FXmNrightWidget 761 unite-button FXtIsManaged if 762 unite-button 763 else 764 sync-button 765 then 766 FXmNtopAttachment FXmATTACH_FORM ) 767 FXmVaCreateManagedLabel { new-label } 768 minibuffer 769 #( FXmNrightWidget new-label 770 FXmNrightAttachment FXmATTACH_WIDGET ) 771 FXtVaSetValues drop 772 minibuffer FXtManageChild drop 773 str FXmStringFree drop 774 #( snd new-label app ) to previous-label 775 labelled-snds previous-label array-push drop 776 app 10000 <'> show-label previous-label FXtAppAddTimeOut drop 777; 778previous 779 780: current-label ( widget -- label ) 781 doc" Return WIDGET's label." 782 ( wid ) #( FXmNlabelString 0 ) FXtVaGetValues 783 1 array-ref ( xmstr ) #f FXmCHARSET_TEXT 784 FXmCHARSET_TEXT #f 0 FXmOUTPUT_ALL FXmStringUnparse 785; 786 787\ snd-xm.fs ends here 788