134 lines
4.5 KiB
Bash
Executable File
134 lines
4.5 KiB
Bash
Executable File
#!/bin/sh
|
|
:;exec /usr/local/bin/stk -f "$0" "$@"
|
|
;;
|
|
;; A quick demo of the composite widgets
|
|
;; This code is a contribution of Drew.Whitehouse@anu.edu.au
|
|
;;
|
|
;; Multiple-window added by eg on 96/04/14
|
|
|
|
(require "Tk-classes")
|
|
|
|
(define main-frame (make <Frame>))
|
|
(define title (make <Label> :parent main-frame :text "Composite Widgets Demo"))
|
|
(define button-box (make <Frame> :parent main-frame :width 200 :height 100))
|
|
(define quit (make <Button> :parent main-frame
|
|
:text " quit "
|
|
:command (lambda ()
|
|
(destroy *root*))))
|
|
|
|
(define composite-widgets '(Choicebox
|
|
Defbutton
|
|
Filebox
|
|
Lentry
|
|
Paned
|
|
Scrollbox
|
|
Multiwin))
|
|
(for-each (lambda (x)
|
|
(let ((cmd (string-append "(demo-" (symbol->string x) ")")))
|
|
(pack (make <Button> :parent button-box :text x :command cmd)
|
|
:fill 'x :padx 5 )))
|
|
composite-widgets)
|
|
|
|
(pack title button-box :fill 'x :padx 10 :pady 10)
|
|
(pack quit :padx 10 :pady 10 )
|
|
(pack main-frame)
|
|
|
|
(define (demo-choicebox)
|
|
(let* ((tl (make <Toplevel> :title "Choice Box"))
|
|
(cb (make <Choice-box> :value "empty for now!" :parent tl)))
|
|
;; add some entries
|
|
(for-each (lambda (x) (add-choice cb (symbol->string x)))
|
|
composite-widgets)
|
|
(pack cb)))
|
|
|
|
(define (demo-defbutton)
|
|
(pack (make <Default-button>
|
|
:text "button"
|
|
:width 20
|
|
:parent (make <Toplevel> :title "Default Button"))))
|
|
|
|
(define (demo-filebox)
|
|
(let ((f (make-file-box)))
|
|
(if f
|
|
(format #t "You have selected ~S\n" f)
|
|
(format #t "Cancel\n"))))
|
|
|
|
(define (demo-lentry)
|
|
(pack (make <Labeled-entry>
|
|
:title "title"
|
|
:parent (make <Toplevel> :title "Labeled entry"))
|
|
:padx 5 :pady 5))
|
|
|
|
(define (demo-paned)
|
|
(let* ((tl (make <Toplevel> :title "Paned demo"))
|
|
(hp (make <HPaned> :fraction 0.3 :width 300 :height 300 :parent tl))
|
|
(f1 (make <Label> :text "top pane" :parent (top-frame-of hp)))
|
|
(f2 (make <Label> :text "bottom-pane" :parent (bottom-frame-of hp)))
|
|
(vp (make <VPaned> :fraction 0.3 :width 300 :height 300 :parent tl))
|
|
(f3 (make <Label> :text "left pane" :parent (left-frame-of vp)))
|
|
(f4 (make <Label> :text "right-pane" :parent (right-frame-of vp))))
|
|
(pack f1 f2 f3 f4 :expand #t)
|
|
(pack hp vp)))
|
|
|
|
(define (demo-scrollbox)
|
|
(let* ((tl (make <Toplevel> :title "Scroll box"))
|
|
(sb (make <Scroll-listbox> :parent tl :geometry "20x6")))
|
|
;; add some entries into the listbox
|
|
(for-each (lambda (x)
|
|
(insert (listbox-of sb) 0 x))
|
|
(append composite-widgets composite-widgets))
|
|
(pack sb)))
|
|
|
|
|
|
(define (demo-multiwin)
|
|
;;
|
|
;; Make a Menu bar
|
|
;;
|
|
(define tl (make <Toplevel> :title "Multiple and Inner windows demo"))
|
|
(define top (make <Frame> :parent tl))
|
|
(define col '#("violet" "skyblue1" "Misty Rose" "Plum" "grey40"))
|
|
(define menu (make-menubar top
|
|
`(("Menu"
|
|
("Add one" ,(let ((counter 0))
|
|
(lambda ()
|
|
(place (make <Inner-window> :parent f
|
|
:title (format #f "Window #~A" counter)
|
|
:background (vector-ref col (random 5)))
|
|
:x (random 200) :y (random 200))
|
|
(set! counter (1+ counter)))))
|
|
("")
|
|
("Quit" ,(lambda () (destroy tl)))))))
|
|
(pack menu :side "left" :expand #f)
|
|
(pack top :fill "x")
|
|
;;
|
|
;; Make a multiple window
|
|
;;
|
|
(define f (make <Multiple-window> :parent tl :background "cyan4"))
|
|
(pack f :fill "both" :expand #t)
|
|
|
|
;;
|
|
;; First child
|
|
;;
|
|
(define f1 (make <Inner-window> :parent f :title "A Text window"))
|
|
(define t1 (make <Scroll-Text> :highlight-thickness 0 :parent f1 :height 8
|
|
:background "lightblue3" :wrap "word"
|
|
:value "Hi!I'm a text window\n\n\n\n\n\n\n\n\n\n\n\n\n\n\nEnd"))
|
|
(define t2 (make <Scroll-Text> :highlight-thickness 0 :parent f1
|
|
:background "lightblue3" :wrap "word"
|
|
:value "Hi, I'm also embedded in a window.\nUse the mouse in the border of my enclosing window to enlarge or shrink this editor"))
|
|
(pack t1 t2 :fill "both" :expand #t)
|
|
(place f1 :x 100 :y 70)
|
|
|
|
;;
|
|
;; Second child
|
|
;;
|
|
(define f2 (make <Inner-window> :parent f :title "A canvas window"))
|
|
(define c1 (make <Canvas> :parent f2 :background "#c4b6a7"))
|
|
(make <Rectangle> :parent c1 :fill "IndianRed1" :coords '(0 0 50 50))
|
|
(make <Oval> :parent c1 :fill "DarkOliveGreen" :coords '(100 100 150 150))
|
|
(bind-for-dragging c1)
|
|
(pack c1 :fill "both" :expand #t)
|
|
(place f2 :x 10 :y 10))
|
|
|
|
|