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
/
oltest.scm
< prev
next >
Wrap
Text File
|
1992-08-29
|
4KB
|
146 lines
(require 'format)
(load "x11")
(load "xt")
(load "ol")
(load "olsubs")
(load "xevent")
(define (say x) (display x) (newline) (force-output))
(define (go)
(xt:realize-widget top-level)
(xt:main-loop))
(define top-level (ol:initialize "Test" "test"))
(define control-pane
(xt:create-managed-widget
"control pane" ol:control-area top-level
xt:n-h-space 20))
(define (event-demo)
(let ((stub-widget
(xt:create-managed-widget
"stub" ol:stub control-pane
xt:n-height 100
xt:n-width 200))
(msg-widget
(xt:create-managed-widget
"text" ol:static-text control-pane)))
(xt:add-event-handler
stub-widget x:leave-window-mask 0
(lambda args
(display "leaveWindow: ")
(display args)
(newline)))
(xt:add-event-handler
stub-widget x:pointer-motion-mask 0
(lambda args
(display "pointerMotion: ")
(display args)
(newline)))))
(define (rubbertile-demo)
(let ((base
(xt:create-managed-widget
"base"
ol:rubber-tile
control-pane)))
(do ((i 0 (1+ i)))
((= i 3))
(let* ((rt (xt:create-managed-widget
(format #f "Tile ~A" i)
ol:rubber-tile base
xt:n-orientation ol:horizontal)))
(do ((j 0 (1+ j)))
((= j 3))
(xt:create-managed-widget
(format #f "Button ~A" (+ j (* i 3)))
ol:rect-button rt))))
#t))
(define (menu-demo)
(let* ((st (xt:create-managed-widget
"st" ol:static-text control-pane
xt:n-string "Press MENU here"))
(menu (xt:create-popup-shell
"popup" ol:menu-shell st
"pushpin" ol:out))
(menu-pane (xt:get-value menu xt:n-menu-pane xt:widget)))
(make-button "New" menu-pane (lambda (w) (say "New")))
(make-button "Open" menu-pane (lambda (w) (say "Open")))
(make-button "Save" menu-pane (lambda (w) (say "Save")))
(make-button "Print" menu-pane (lambda (w) (say "Print")))))
(define (textfield-demo)
(for-each
(lambda (x)
(let* ((name (car x))
(text (cadr x))
(label (xt:create-managed-widget
name ol:static-text control-pane
xt:n-string name
xt:n-width 70
xt:n-gravity "east"))
(field (xt:create-managed-widget
name ol:text-field control-pane
xt:n-string text)))
(xt:add-callback
field "verification"
(lambda (w) (say "Yokes!")))))
'(("MAKE:" "Acme") ("MODEL:" "Deluxe") ("SERIAL NO." "")))
(xt:set-values control-pane
xt:n-layout-type ol:fixedcols
"measure" 2
"charsVisible" 10))
(define (footerpanel-demo)
(let* ((footer-panel
(xt:create-managed-widget
"footerpanel" ol:footer-panel control-pane))
(control-area
(xt:create-managed-widget
"control" ol:control-area footer-panel))
(form
(xt:create-managed-widget
"form" ol:form footer-panel))
(status
(xt:create-managed-widget
"status" ol:oblong-button control-area))
(mode
(xt:create-managed-widget
"mode" ol:oblong-button control-area))
(st
(xt:create-managed-widget
"st" ol:static-text form
xt:n-x-vary-offset #t
xt:n-y-vary-offset #t))
(mo
(xt:create-managed-widget
"mo" ol:static-text form
xt:n-x-vary-offset #t
xt:n-y-vary-offset #t
xt:n-x-attach-right #t)))
(xt:add-callback
status xt:n-select
(let* ((msglist '("Status 1" "Status 2" "Status 3"))
(msg msglist))
(lambda (w)
(if (null? msg)
(set! msg msglist))
(xt:set-values st xt:n-string (car msg))
(set! msg (cdr msg)))))
(xt:add-callback
mode xt:n-select
(let* ((msglist '("Mode 1" "Mode 2" "Mode 3"))
(msg msglist))
(lambda (w)
(if (null? msg)
(set! msg msglist))
(xt:set-values mo xt:n-string (car msg))
(set! msg (cdr msg)))))))
;(xt:realize-widget top-level)
;(xt:main-loop)