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