home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
World_Of_Computer_Software-02-385-Vol-1of3.iso
/
x
/
xscm105.zip
/
xscm
/
olsubs.scm
< prev
next >
Wrap
Text File
|
1992-08-29
|
3KB
|
102 lines
; $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)))))