; $Header: /home/campbell/Languages/Scheme/scm/x-scm/RCS/xmsubs.scm,v 1.5 1992/07/26 21:29:14 campbell Beta $
;
; Generally useful Motif functions.  These are EXTREMELY subject to 
; change.  I intend to try to create more-or-less toolkit-independent
; versions of these, so that I can build compatible versions for
; OpenLook, Microsoft Windows, Macintosh, etc.  So be prepared for
; these interfaces to change...  -lc
;
;  Author: Larry Campbell (campbell@redsox.bsw.com)
; 
;  Copyright 1992 by The Boston Software Works, Inc.
;  Permission to use for any purpose whatsoever granted, as long
;  as this copyright notice remains intact.  Please send bug fixes
;  or enhancements to the above email address.

(require (in-vicinity (library-vicinity) "assert.scm"))

; Call a thunk with a "busy" cursor (watch, hourglass, glacier...)
;
(define (with-busy-cursor widget thunk)
  (if (xt:is-realized widget)
      (let ((xdisplay (xt:display widget))
	    (xwindow (xt:window widget)))
	(x:define-cursor xdisplay xwindow xc:watch)
	(x:flush xdisplay)
	(apply thunk '())
	(x:undefine-cursor xdisplay xwindow))
      (apply thunk '())))

; Create a text widget with a caption to its left.  Returns the
; text widget's ID.
;
(define (make-captioned-text-widget parent label columns . args)
  #.(assert '(string? label))
  #.(assert '(integer? columns))
  (let* ((rc (xt:create-managed-widget
	      "ct" xm:form parent))
	 (caption (xt:create-managed-widget
		   "caption" xm:label-gadget rc
		   xm:n-label-string (xm:string-create label)))
	 (text (xt:create-managed-widget
		"text" xm:text-field rc
		xm:n-columns columns))
	 (offset (+
		  (xt:get-value text xm:n-shadow-thickness xt:integer)
		  (xt:get-value text xm:n-highlight-thickness xt:integer)
		  (xt:get-value text xm:n-margin-height xt:integer))))
    (xt:set-values
     caption
     xm:n-margin-height offset
     xm:n-right-attachment xm:attach-widget
     xm:n-bottom-attachment xm:attach-form
     xm:n-right-widget text)
    (xt:set-values
     text
     xm:n-right-attachment xm:attach-form
     xm:n-bottom-attachment xm:attach-form
     xm:n-right-widget text)
    text))

(define (popup-error parent message)
  #.(assert '(string? message))
  (let* ((dshell (xt:create-popup-shell
		  "Error" xm:dialog-shell parent))
	 (mshell (xt:create-managed-widget
		  "Error" xm:message-box dshell
		  xm:n-dialog-type xm:dialog-error
		  xm:n-message-string (xm:string-create message))))
    (xt:add-callback
     mshell
     xm:n-ok-callback (lambda (w) (xt:destroy-widget dshell)))
    (xt:popup dshell 1)))

(define (popup-information parent message)
  #.(assert '(string? message))
  (let* ((dshell (xt:create-popup-shell
		  "Information" xm:dialog-shell parent))
	 (mshell (xt:create-managed-widget
		  "Information" xm:message-box dshell
		  xm:n-dialog-type xm:dialog-information
		  xm:n-message-string (xm:string-create message))))
    (xt:add-callback
     mshell
     xm:n-ok-callback (lambda (w) (xt:destroy-widget dshell)))
    (xt:popup dshell 1)))


; Create a row of evenly-spaced buttons (typically used for the
; "OK" "Apply" "Cancel" buttons at the bottom of a panel).
; Returns nothing.
; 
; Usage:
;   (make-button-row parent '(("label 1" action1) ("label 2" action2)))
;
(define (make-button-row parent button-specifiers)
  #.(assert '(list? button-specifiers))
  (let ((rc (xt:create-managed-widget
	     "rc" xm:row-column parent
	     xm:n-orientation xm:horizontal
	     xm:n-packing xm:pack-column))
	(parent-width (xt:get-value parent xt:n-width xt:integer)))
    (if (=? 0 parent-width)
	(error "button-row: parent has zero width"))
    (do ((items button-specifiers (cdr items)))
	((null? items) rc)
      (let* ((item (car items))
	     (label (car item))
	     (action (cadr item))
	     (others (cddr item)))
	(apply make-button `(,label ,rc ,action ,@others))))))


(define (make-button label parent action . args)
;;
;; Make a button.  If <action> is a list, the button pops up a pulldown
;; menu, and <action> is the argument list for make-pulldown-menu.
;; If <label> begins with a question mark, the question mark is removed,
;; and the button is a toggle button.
;;
  #.(assert '(or (symbol? label) (string? label)))
  #.(assert
     '(or
       (procedure? action)
       (list? action))
     'action)
  (let ((widget '())
	(widget-callback (if (null? args) args (car args)))
	(args (if (null? args) args (cdr args)))
	(class '())
	(callback xm:n-activate-callback))
    (set! widget
	  (if (list? action)
	      (apply make-pulldown-menu `(,label ,parent ,@action))
	      (begin
		(case label
		  ((xm:arrow-up xm:arrow-down xm:arrow-left xm:arrow-right)
		   (set! widget
			 (xt:create-managed-widget
			  "button" xm:arrow-button-gadget parent
			  xm:n-arrow-direction
			  (case label
			    ((xm:arrow-down) xm:arrow-down)
			    ((xm:arrow-up) xm:arrow-up)
			    ((xm:arrow-left) xm:arrow-left)
			    ((xm:arrow-right) xm:arrow-right))
			  xm:n-traversal-on #f)))

		  (else
		   (let ((class xm:push-button-gadget))
		     (if (char=? (string-ref label 0) #\?)
			 (begin
			   (set! class xm:toggle-button-gadget)
			   (set! callback xm:n-value-changed-callback)
			   (set! label
				 (substring label 1 (string-length label)))))
		     (set! widget
			   (xt:create-managed-widget
			    label class parent
			    xm:n-alignment xm:alignment-center
			    xm:n-shadow-thickness 2)))))
		(xt:add-callback widget callback action)
		(or (null? args)
		    (apply xt:set-values `(,widget ,@args)))
		widget)))
    (if (not (null? widget-callback))
	(widget-callback widget))
    widget))

(define (make-toggle-button label parent action . resources)
  #.(assert '(string? label))
  #.(assert '(procedure? action))
  (let ((widget
	 (apply xt:create-managed-widget
	  `(,label
	    ,xm:toggle-button-gadget
	    ,parent
	    ,@resources))))
    (xt:add-callback widget xm:n-value-changed-callback action)
    widget))

; (make-popup-menu name parent (label1 action1) (label2 action2)...)
;
(define (make-popup-menu name parent . args)
  (let* ((widget (xm:create-popup-menu parent name)))
    (xt:create-managed-widget name xm:label-gadget widget)
    (xt:create-managed-widget name xm:separator-gadget widget)
    (do ((items args (cdr items)))
	((null? items) widget)
        (let* ((item (car items))
       	       (label (car item))
	       (action (cadr item)))
	  (make-button label widget action)))))

; (make-pulldown-menu name parent (label1 action1 wc) (label2 action2 wc)...)
;
; wc is an optional argument -- if present, it must be a procedure
; of one argument which is called with the widget representing the
; button created.
;
(define (make-pulldown-menu name parent . args)
  #.(assert '(string? name) 'name 'args)
  #.(assert '(< 1 (length args)) 'name 'args)
  (let* ((mbutton (xt:create-managed-widget
		   name xm:cascade-button-gadget parent))
	 (menu-pane (xm:create-pulldown-menu parent name)))
    (xt:set-values mbutton xm:n-sub-menu-id menu-pane)
    (do ((items args (cdr items)))
	((null? items) mbutton)
      (let* ((item (car items))
	     (label (car item))
	     (action (cadr item))
	     (widget-callback
	      (if (= 3 (length item))
		  (list-ref item 2)
		  '())))
	(make-button label menu-pane action widget-callback)))))

; (make-menu-bar parent name ((menu1-title ((label action) ...)) ...)
;
(define (make-menu-bar parent name . args)
  #.(assert '(string? name) 'name 'args)
  #.(assert '(< 1 (length args)) 'name 'args)
  (let ((menubar (xt:create-managed-widget
		  name xm:row-column parent
		  xm:n-row-column-type xm:menu-bar)))
    (do ((items args (cdr items)))
	((null? items) menubar)
      (let* ((item (car items))
	     (menu-title (car item))
	     (menu-items (cadr item))
	     (widget ()))
	(set! widget (apply
		      make-pulldown-menu
		      `(,menu-title
			,menubar
			,@menu-items)))
	(if (equal? menu-title "Help")
	    (xt:set-values menubar xm:n-menu-help-widget widget))))))
