diff options
Diffstat (limited to 'snd-motif.scm')
-rw-r--r-- | snd-motif.scm | 301 |
1 files changed, 140 insertions, 161 deletions
diff --git a/snd-motif.scm b/snd-motif.scm index a8e5b52..cba0613 100644 --- a/snd-motif.scm +++ b/snd-motif.scm @@ -78,7 +78,7 @@ (do ((i 0 (+ i 1))) ((= i len) new-str) (let ((c (str i))) - (set! (new-str i) (if (memq c '(#\\ #\/)) #\_ c)))))))) + (set! (new-str i) (if (memv c '(#\\ #\/)) #\_ c)))))))) ;;; -------- apply func to every widget belonging to w (and w) -------- @@ -164,17 +164,15 @@ ;; (XtGetValues dialog (XmNfileSearchProc 0)) to get the default (shell (cadr (main-widgets))) (tags (list "one" "two" "three" "four")) - (colors (list "black" "red" "blue" "orange")) (pixels (let* ((dpy (XtDisplay shell)) - (scr (DefaultScreen dpy)) - (cmap (DefaultColormap dpy scr))) + (cmap (DefaultColormap dpy (DefaultScreen dpy)))) (map (lambda (color) (let ((col (XColor))) (if (= (XAllocNamedColor dpy cmap color col col) 0) (snd-error (format #f "can't allocate ~A" color)) (.pixel col)))) - colors))) + '("black" "red" "blue" "orange")))) (rendertable (XmRenderTableAddRenditions #f (map (lambda (tag pix) @@ -345,10 +343,7 @@ (define add-listener-pane (let ((documentation "(add-listener-pane name type args) adds a widget at the top of the listener")) (lambda (name type args) - (let* ((listener (find-child (cadr (main-widgets)) "lisp-listener")) - ;; this is the listener text widget, hopefully - ;; its parent is the scrolled window, its parent is the form widget filling the listener pane - (listener-scroll (XtParent listener)) + (let* ((listener-scroll (XtParent (find-child (cadr (main-widgets)) "lisp-listener"))) (listener-form (XtParent listener-scroll))) ;; to insert the new widget at the top of the listener pane we need to detach the ;; listener scrolled window etc -- assume here that the "args" list does not @@ -1147,8 +1142,7 @@ ;; this is the procedure to be called when the update is done (do ((i 0 (+ i 1))) ((= i (channels updated-snd))) - (make-mark-list updated-snd i)))))) - ) + (make-mark-list updated-snd i))))))) ;;; -------- select-file -------- @@ -1224,9 +1218,7 @@ (XtSetValues (XtNameToWidget new-dialog "OK") (list XmNarmColor *selection-color*)) new-dialog)))) - (if (not help) - (XtUnmanageChild (XmFileSelectionBoxGetChild dialog XmDIALOG_HELP_BUTTON)) - (XtManageChild (XmFileSelectionBoxGetChild dialog XmDIALOG_HELP_BUTTON))) + ((if (not help) XtUnmanageChild XtManageChild) (XmFileSelectionBoxGetChild dialog XmDIALOG_HELP_BUTTON)) (let ((patstr (XmStringCreateLocalized filter)) (titlestr (XmStringCreateLocalized title))) (let ((dirstr (XmStringCreateLocalized dir))) @@ -1530,10 +1522,8 @@ (documentation "(red-pixel) returns a red pixel")) (lambda () (if (not pix) - (let* ((shell (cadr (main-widgets))) - (dpy (XtDisplay shell)) - (scr (DefaultScreen dpy)) - (cmap (DefaultColormap dpy scr)) + (let* ((dpy (XtDisplay (cadr (main-widgets)))) + (cmap (DefaultColormap dpy (DefaultScreen dpy))) (col (XColor))) (if (= (XAllocNamedColor dpy cmap "red" col col) 0) (snd-error "can't allocate red!") @@ -1720,8 +1710,8 @@ (let ((documentation "(make-channel-drop-site snd) adds a drop site pane to the current channel")) (lambda args (let* ((snd (if (pair? args) (car args) (selected-sound))) - (chn (selected-channel snd)) - (widget (add-channel-pane snd chn "drop here" xmDrawingAreaWidgetClass + (widget (add-channel-pane snd (selected-channel snd) + "drop here" xmDrawingAreaWidgetClass (list XmNbackground (white-pixel) XmNleftAttachment XmATTACH_FORM XmNrightAttachment XmATTACH_FORM @@ -1791,15 +1781,14 @@ (define show-disk-space (let ((labelled-snds ())) (define (kmg num) - (cond ((<= num 0) "disk full!") + (cond ((<= num 0) (copy "disk full!")) ((<= num 1024) (format #f "space: ~10DK" num)) ((> num 1048576) (format #f "space: ~6,3FG" (/ num (* 1024.0 1024.0)))) (else (format #f "space: ~6,3FM" (/ num 1024.0))))) (define (show-label data id) (if (sound? (car data)) - (let* ((space (kmg (disk-kspace (file-name (car data))))) - (str (XmStringCreateLocalized space))) + (let ((str (XmStringCreateLocalized (kmg (disk-kspace (file-name (car data))))))) (XtSetValues (cadr data) (list XmNlabelString str)) (XmStringFree str) (XtAppAddTimeOut (caddr data) 10000 show-label data)))) @@ -1817,8 +1806,7 @@ (unite-button (widgets 6)) (sync-button (widgets 9)) (name-form (XtParent status-area)) ; "snd-name-form" - (space (kmg (disk-kspace (file-name snd)))) - (str (XmStringCreateLocalized space))) + (str (XmStringCreateLocalized (kmg (disk-kspace (file-name snd)))))) (set! showing-disk-space #t) (XtUnmanageChild status-area) (XtVaSetValues status-area (list XmNrightAttachment XmATTACH_NONE)) @@ -1850,9 +1838,9 @@ (let ((documentation "(add-amp-controls) adds amplitude sliders to the control panel for each channel in multi-channel sounds")) (lambda () - (define (label-name chan) (if (= chan 0) "amp-label" (format #f "amp-label-~D" chan))) - (define (number-name chan) (if (= chan 0) "amp-number" (format #f "amp-number-~D" chan))) - (define (scroller-name chan) (if (= chan 0) "amp" (format #f "amp-~D" chan))) + (define (label-name chan) (if (= chan 0) (copy "amp-label") (format #f "amp-label-~D" chan))) + (define (number-name chan) (if (= chan 0) (copy "amp-number") (format #f "amp-number-~D" chan))) + (define (scroller-name chan) (if (= chan 0) (copy "amp") (format #f "amp-~D" chan))) (define (amp-callback w c info) ;; c is (list number-widget snd chan) @@ -1865,16 +1853,13 @@ (let* ((snd (cadr c)) (amp (scroll->amp snd (.value info))) (ampstr (XmStringCreateLocalized (format #f "~,3F " amp))) - (top-chn (- (channels snd) 1)) - (chn (- top-chn (caddr c))) + (chn (- (channels snd) 1 (caddr c))) (ctrl (and (.event info) (not (= (logand (.state (.event info)) ControlMask) 0))))) (XtSetValues (car c) (list XmNlabelString ampstr)) (XmStringFree ampstr) (if ctrl - (let* ((wids (sound-widgets snd)) - (ctrls (wids 2)) - (snd-amp (find-child ctrls "snd-amp")) - (chns (channels snd))) + (let ((snd-amp (find-child ((sound-widgets snd) 2) "snd-amp")) + (chns (channels snd))) (do ((i 0 (+ i 1))) ((= i chns)) (let* ((ampscr (find-child snd-amp (scroller-name i))) @@ -1945,8 +1930,7 @@ (XmStringFree s2) label)) - (let* ((wids (sound-widgets snd)) - (ctrls (wids 2)) + (let* ((ctrls ((sound-widgets snd) 2)) (snd-amp (find-child ctrls "snd-amp")) (chns (channels snd))) @@ -2010,10 +1994,8 @@ (define (amp-controls-clear snd) (if (> (channels snd) 1) - (let* ((wids (sound-widgets snd)) - (ctrls (wids 2)) - (snd-amp (find-child ctrls "snd-amp")) - (top (- (channels snd) 1))) + (let ((snd-amp (find-child ((sound-widgets snd) 2) "snd-amp")) + (top (- (channels snd) 1))) (do ((i 1 (+ i 1))) ((= i (channels snd))) (let ((ampn (find-child snd-amp (number-name i))) @@ -2139,9 +2121,7 @@ (XtAddEventHandler rename-text LeaveWindowMask #f (lambda (w context ev flag) (XtSetValues w (list XmNbackground *basic-color*))))))) - (if (not (XtIsManaged rename-dialog)) - (XtManageChild rename-dialog) - (raise-dialog rename-dialog))) + ((if (not (XtIsManaged rename-dialog)) XtManageChild raise-dialog) rename-dialog)) 8))))) @@ -2174,8 +2154,7 @@ (lambda (color-name) (let* ((col (XColor)) (dpy (XtDisplay (cadr (main-widgets)))) - (scr (DefaultScreen dpy)) - (cmap (DefaultColormap dpy scr))) + (cmap (DefaultColormap dpy (DefaultScreen dpy)))) (if (= (XAllocNamedColor dpy cmap color-name col col) 0) (snd-error (format #f "can't allocate ~A" color-name)) (.pixel col))))) @@ -2233,46 +2212,46 @@ (if (and tooltip-shell (XtIsManaged tooltip-shell)) (XtUnmanageChild tooltip-shell))) - (define start-tooltip - (let ((quittime 3000) ; millisecs to show tip (if pointer not already moved out of widget) - (timeout 500)) ; millisecs after mouse enters widget to tip display - (lambda (ev) - (if (and *with-tooltips* - (not tool-proc)) - (set! tool-proc (XtAppAddTimeOut - (car (main-widgets)) - timeout - (lambda (data id) - (if tooltip-shell - (change-label tooltip-label tip) - (begin - (set! tooltip-shell (XtCreatePopupShell - tip - overrideShellWidgetClass - (cadr (main-widgets)) - (list XmNallowShellResize #t))) - (set! tooltip-label - (XtCreateManagedWidget - tip - xmLabelWidgetClass - tooltip-shell - (list XmNrecomputeSize #t - XmNbackground *highlight-color*))))) - (let ((loc (XtTranslateCoords widget (.x ev) (.y ev)))) - (XtVaSetValues tooltip-shell (list XmNx (car loc) XmNy (cadr loc)))) - (XtManageChild tooltip-shell) - (set! quit-proc (XtAppAddTimeOut - (car (main-widgets)) - quittime - (lambda (data id) - (XtUnmanageChild tooltip-shell) - (set! quit-proc #f))))))))))) - - (XtAddEventHandler widget EnterWindowMask #f - (lambda (w c ev flag) - (if (> (- (cadr (.time ev)) last-time) 50) - (start-tooltip ev)) - (set! last-time (cadr (.time ev))))) + (let ((start-tooltip + (let ((quittime 3000) ; millisecs to show tip (if pointer not already moved out of widget) + (timeout 500)) ; millisecs after mouse enters widget to tip display + (lambda (ev) + (if (and *with-tooltips* + (not tool-proc)) + (set! tool-proc (XtAppAddTimeOut + (car (main-widgets)) + timeout + (lambda (data id) + (if tooltip-shell + (change-label tooltip-label tip) + (begin + (set! tooltip-shell (XtCreatePopupShell + tip + overrideShellWidgetClass + (cadr (main-widgets)) + (list XmNallowShellResize #t))) + (set! tooltip-label + (XtCreateManagedWidget + tip + xmLabelWidgetClass + tooltip-shell + (list XmNrecomputeSize #t + XmNbackground *highlight-color*))))) + (let ((loc (XtTranslateCoords widget (.x ev) (.y ev)))) + (XtVaSetValues tooltip-shell (list XmNx (car loc) XmNy (cadr loc)))) + (XtManageChild tooltip-shell) + (set! quit-proc (XtAppAddTimeOut + (car (main-widgets)) + quittime + (lambda (data id) + (XtUnmanageChild tooltip-shell) + (set! quit-proc #f)))))))))))) + + (XtAddEventHandler widget EnterWindowMask #f + (lambda (w c ev flag) + (if (> (- (cadr (.time ev)) last-time) 50) + (start-tooltip ev)) + (set! last-time (cadr (.time ev)))))) (XtAddEventHandler widget LeaveWindowMask #f (lambda (w c ev flag) (set! last-time (cadr (.time ev))) @@ -2328,83 +2307,83 @@ (listener-text ((main-widgets) 4)) (snd-app (car (main-widgets)))) (lambda () - - (define start-dialog - (let ((shell (cadr (main-widgets))) - (dialog #f) - (find-new #t) - (find-text #f)) - (lambda () - (unless dialog - (let ((xdismiss (XmStringCreate "Go Away" XmFONTLIST_DEFAULT_TAG)) - (xhelp (XmStringCreate "Help" XmFONTLIST_DEFAULT_TAG)) - (xfind (XmStringCreate "Find" XmFONTLIST_DEFAULT_TAG))) - (set! dialog (XmCreateMessageDialog shell - "Find" - (list XmNcancelLabelString xdismiss - XmNokLabelString xfind - XmNhelpLabelString xhelp - XmNautoUnmanage #f - XmNresizePolicy XmRESIZE_GROW - XmNnoResize #f - XmNtransient #f - XmNbackground *basic-color*))) - (for-each - (lambda (button color) - (XtVaSetValues (XmMessageBoxGetChild dialog button) - (list XmNarmColor *selection-color* - XmNbackground color))) - (list XmDIALOG_HELP_BUTTON XmDIALOG_CANCEL_BUTTON XmDIALOG_OK_BUTTON) - (list *highlight-color* *highlight-color* *highlight-color*)) - (XtAddCallback dialog XmNcancelCallback (lambda (w context info) (XtUnmanageChild dialog))) - (XtAddCallback dialog XmNhelpCallback (lambda (w context info) (help-dialog "Find" "no help yet"))) - (XtAddCallback dialog XmNokCallback (lambda (w context info) - (let* ((search-str (XmTextFieldGetString find-text)) - (len (length search-str)) - (pos (XmTextFindString listener-text - (+ (XmTextGetCursorPosition listener-text) - (if find-new 0 (if find-forward 1 -1))) - search-str - (if find-forward XmTEXT_FORWARD XmTEXT_BACKWARD)))) - (if (not pos) - (set! pos (XmTextFindString listener-text - (if find-forward 0 (XmTextGetLastPosition listener-text)) - search-str - (if find-forward XmTEXT_FORWARD XmTEXT_BACKWARD)))) - (if (number? pos) - (begin - (XmTextSetInsertionPosition listener-text pos) - (XmTextSetHighlight listener-text pos (+ pos len) XmHIGHLIGHT_SELECTED) ; flash the string briefly - (XtAppAddTimeOut snd-app 200 - (lambda (context id) - (XmTextSetHighlight listener-text pos (+ pos len) XmHIGHLIGHT_NORMAL))))) - (set! find-new #f)))) - (XmStringFree xhelp) - (XmStringFree xdismiss) - (XmStringFree xfind) - (set! find-text (XtCreateManagedWidget "text" xmTextFieldWidgetClass dialog - (list XmNleftAttachment XmATTACH_FORM - XmNrightAttachment XmATTACH_FORM - XmNtopAttachment XmATTACH_FORM - XmNbottomAttachment XmATTACH_WIDGET - XmNbottomWidget (XmMessageBoxGetChild dialog XmDIALOG_SEPARATOR) - XmNbackground *basic-color*))) - (XtAddCallback find-text XmNfocusCallback - (lambda (w c i) - (XtVaSetValues w (list XmNbackground (WhitePixelOfScreen (DefaultScreenOfDisplay (XtDisplay shell))))))) - (XtAddCallback find-text XmNlosingFocusCallback (lambda (w c i) (XtSetValues w (list XmNbackground *basic-color*)))) - (XtAddCallback find-text XmNvalueChangedCallback (lambda (w c i) (set! find-new #t))))) - (XtManageChild dialog)))) - (XtAppAddActions snd-app - (list (list "search-forward" - (lambda args - (set! find-forward #t) - (start-dialog))) - (list "search-backward" - (lambda args - (set! find-forward #f) - (start-dialog))))) + (let ((start-dialog + (let ((shell (cadr (main-widgets))) + (dialog #f) + (find-new #t) + (find-text #f)) + (lambda () + (unless dialog + (let ((xdismiss (XmStringCreate "Go Away" XmFONTLIST_DEFAULT_TAG)) + (xhelp (XmStringCreate "Help" XmFONTLIST_DEFAULT_TAG)) + (xfind (XmStringCreate "Find" XmFONTLIST_DEFAULT_TAG))) + (set! dialog (XmCreateMessageDialog shell + "Find" + (list XmNcancelLabelString xdismiss + XmNokLabelString xfind + XmNhelpLabelString xhelp + XmNautoUnmanage #f + XmNresizePolicy XmRESIZE_GROW + XmNnoResize #f + XmNtransient #f + XmNbackground *basic-color*))) + (for-each + (lambda (button color) + (XtVaSetValues (XmMessageBoxGetChild dialog button) + (list XmNarmColor *selection-color* + XmNbackground color))) + (list XmDIALOG_HELP_BUTTON XmDIALOG_CANCEL_BUTTON XmDIALOG_OK_BUTTON) + (list *highlight-color* *highlight-color* *highlight-color*)) + (XtAddCallback dialog XmNcancelCallback (lambda (w context info) (XtUnmanageChild dialog))) + (XtAddCallback dialog XmNhelpCallback (lambda (w context info) (help-dialog "Find" "no help yet"))) + (XtAddCallback dialog XmNokCallback (lambda (w context info) + (let* ((search-str (XmTextFieldGetString find-text)) + (len (length search-str)) + (pos (XmTextFindString listener-text + (+ (XmTextGetCursorPosition listener-text) + (if find-new 0 (if find-forward 1 -1))) + search-str + (if find-forward XmTEXT_FORWARD XmTEXT_BACKWARD)))) + (if (not pos) + (set! pos (XmTextFindString listener-text + (if find-forward 0 (XmTextGetLastPosition listener-text)) + search-str + (if find-forward XmTEXT_FORWARD XmTEXT_BACKWARD)))) + (if (number? pos) + (begin + (XmTextSetInsertionPosition listener-text pos) + (XmTextSetHighlight listener-text pos (+ pos len) XmHIGHLIGHT_SELECTED) ; flash the string briefly + (XtAppAddTimeOut snd-app 200 + (lambda (context id) + (XmTextSetHighlight listener-text pos (+ pos len) XmHIGHLIGHT_NORMAL))))) + (set! find-new #f)))) + (XmStringFree xhelp) + (XmStringFree xdismiss) + (XmStringFree xfind) + (set! find-text (XtCreateManagedWidget "text" xmTextFieldWidgetClass dialog + (list XmNleftAttachment XmATTACH_FORM + XmNrightAttachment XmATTACH_FORM + XmNtopAttachment XmATTACH_FORM + XmNbottomAttachment XmATTACH_WIDGET + XmNbottomWidget (XmMessageBoxGetChild dialog XmDIALOG_SEPARATOR) + XmNbackground *basic-color*))) + (XtAddCallback find-text XmNfocusCallback + (lambda (w c i) + (XtVaSetValues w (list XmNbackground (WhitePixelOfScreen (DefaultScreenOfDisplay (XtDisplay shell))))))) + (XtAddCallback find-text XmNlosingFocusCallback (lambda (w c i) (XtSetValues w (list XmNbackground *basic-color*)))) + (XtAddCallback find-text XmNvalueChangedCallback (lambda (w c i) (set! find-new #t))))) + (XtManageChild dialog))))) + + (XtAppAddActions snd-app + (list (list "search-forward" + (lambda args + (set! find-forward #t) + (start-dialog))) + (list "search-backward" + (lambda args + (set! find-forward #f) + (start-dialog)))))) (XtOverrideTranslations listener-text (XtParseTranslationTable "Ctrl <Key>s: search-forward() Ctrl <Key>r: search-backward()"))))) |