; $Header: /home/campbell/Languages/Scheme/scm/x-scm/RCS/olsubs.scm,v 1.2 1992/07/04 05:02:17 campbell Beta $
;
; Generally useful OpenLook (OLIT) functions
;
;  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"))

; 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* ((caption
	  (xt:create-managed-widget
	   label ol:caption parent
	   xt:n-label label))
	 (text
	  (xt:create-managed-widget
	   "text" ol:text-field caption)))
    text))

(define (make-button label parent action)
  (let ((widget
	 (xt:create-managed-widget
	  label
	  ol:oblong-button
	  parent)))
    (xt:add-callback widget xt:n-select action)
    widget))

; (make-pulldown-menu name parent (label1 action1) (label2 action2)...)

(define (make-pulldown-menu name parent . args)
  (let* ((widget (xt:create-managed-widget
		  name
		  ol:menu-button
		  parent))
	 (menu-widget (xt:get-value widget "menuPane" xt:widget)))
    (do ((items args (cdr items)))
	((null? items) widget)
        (let* ((item (car items))
       	       (label (car item))
	       (action (cadr item)))
	  (make-button label menu-widget action)))))


(define (popup-information parent message)
  #.(assert '(string? message))
  (let ((nshell (xt:create-popup-shell
		  "information" ol:notice-shell parent
		  xt:n-emanate-widget parent)))
    (let ((ca (xt:get-value nshell xt:n-control-area xt:widget))
	  (ta (xt:get-value nshell xt:n-text-area xt:widget)))
      (xt:set-values ta xt:n-string message)
      (make-button "OK" ca (lambda _ (xt:destroy-widget nshell))))
    (xt:popup nshell 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 ((ca (xt:create-managed-widget
	     "ca" ol:control-area parent))
	(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) ca)
      (let* ((item (car items))
	     (label (car item))
	     (action (cadr item))
	     (button '()))
	(case label
	  ((xm:arrow-up xm:arrow-down xm:arrow-left xm:arrow-right)
	   (set! button (xt:create-managed-widget
			 "arrow" xm:arrow-button-gadget ca
			 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
	   (set! button (xt:create-managed-widget
			 label ol:oblong-button-gadget ca))))
	(xt:add-callback button xt:n-select action)))))

