#!/bin/sh
:;exec /usr/local/bin/stk -f "$0" "$@"
;;
;; A quick demo of the STklos widgets
;; This code is a contribution of Drew.Whitehouse@anu.edu.au
;;
;; Multiple-window added by eg on 96/04/14
;; Gauges and help balloon added by eg on 96/10/23
(require "Tk-classes")
(define main-frame (make <Frame>))
(define title (make <Label> :parent main-frame :text "STklos 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 '(Choice-box
Color-Box
Default-button
File-box
Font-chooser
Gauge
Help-Balloon
Hierarchy-Tree
Labeled-Entry
Labeled-Frame
Multiple-Window
Notepad
Paned
Scroll-Canvas
Scroll-Listbox
Scroll-text
Toolbar
Valued-Gauge))
(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-choice-box)
(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-color-box)
(let ((f (make <Color-Box> :value "gray75" :title "Color Box Demo")))
(colorbox-wait-result f)))
;=============================================================================
(define (demo-default-button)
(pack (make <Default-button>
:text "button"
:width 20
:parent (make <Toplevel> :title "Default Button"))))
;=============================================================================
(define (demo-file-box)
(let ((f (make-file-box)))
(if f
(format #t "You have selected ~S\n" f)
(format #t "Cancel\n"))))
;=============================================================================
(define (demo-gauge)
(let* ((top (make <Toplevel> :title "Gauge widget"))
(g (make <Gauge> :parent top :width 400 :height 15
:foreground "IndianRed4")))
(pack g :expand #t :fill "both")
(dotimes (i 101)
(slot-set! g 'value i)
(after 5)
(update))))
;=============================================================================
(define (demo-help-balloon)
(let* ((top (make <Toplevel> :title "Balloon Help"))
(f (make <Frame> :parent top))
(txt (make <Label> :parent top
:text "Place the mouse on a button\n and wait a while"))
(h (make <Help-Balloon> :background "#ffffb9")))
(for-each (lambda (x)
(let ((b (make <Button> :parent f :text x :side "left")))
(add-balloon h b (format #f "This is the help\nof\n~S" x))
(pack b :side "left")))
'("Button1" "Button2" "Button3" "Button4" "Button5" "Button6"))
(pack (make <Button> :text "Balloons" :parent f :width 10
:command activate-balloons))
(pack (make <Button> :text "No Balloons" :parent f :width 10
:command deactivate-balloons))
(pack f)
(pack txt :expand #t :fill "both")))
;=============================================================================
(define (demo-labeled-entry)
(pack (make <Labeled-entry>
:title "Enter your name"
:parent (make <Toplevel> :title "Labeled entry"))
:padx 5 :pady 5))
;=============================================================================
(define (demo-labeled-frame)
(define top (make <Toplevel> :title "Labeld Frames"))
(define lf (make <Labeled-Frame> :title "Font" :parent top))
(pack lf :fill "both" :expand #t :side "left")
(for-each (lambda (x)
(pack (make <Radio-button> :anchor "w" :parent lf :variable 'font
:text x :string-value #f :width 8 :font "fixed" :value x)
:fill "x" :expand #f :anchor "w" :side "top"))
'("10pt" "12pt" "14pt" "18pt"))
(define lf2 (make <Labeled-Frame> :title "Type" :parent top))
(pack lf2 :fill "both" :expand #t :side "left")
(for-each (lambda (x)
(pack (make <Radio-button> :anchor "w" :parent lf2 :variable 'type
:text x :string-value #f :width 15 :font "fixed" :value x)
:fill "x" :expand #f :anchor "w" :side "top"))
'("Bold" "Italic" "Normal")))
;=============================================================================
(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-scroll-canvas . parent)
(let* ((top (if (null? parent)
(make <Toplevel> :title "Scroll Canvas")
(car parent)))
(c (make <Scroll-Canvas> :parent top :background "#c4b6a7"
:h-scroll-side "bottom" :scroll-region '(0 0 1000 1000))))
(make <Rectangle> :parent c :fill "IndianRed1" :coords '(0 0 50 50))
(make <Oval> :parent c :fill "DarkOliveGreen" :coords '(100 100 150 150))
(bind-for-dragging c)
(pack c :fill "both" :expand #t)))
;=============================================================================
(define (demo-scroll-listbox)
(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-scroll-text . parent)
(let* ((top (if (null? parent)
(make <Toplevel> :title "Scroll Canvas")
(car parent)))
(t1 (make <Scroll-Text> :highlight-thickness 0 :parent top :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"))
(t2 (make <Scroll-Text> :highlight-thickness 0 :parent top
:background "lightblue3" :wrap "word" :height 4
: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)))
;=============================================================================
(define (demo-multiple-window)
;;
;; Make a Menu bar
;;
(define tl (make <Toplevel> :title "Multiple and Inner windows demo"))
(define col '#("violet" "skyblue1" "Misty Rose" "Plum" "grey40"))
(define menu (make-toolbar tl
`(("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 "top" :expand #f :fill 'x)
;;
;; Make a multiple window
;;
(define f (make <Multiple-window> :parent tl :background "cyan4"))
(pack f :fill "both" :expand #t)
;; Attach the floting toolbar to the f widget
(slot-set! menu 'release-command (default-release-toolbar f))
(define f1 (make <Inner-window> :parent f :title "A Text window"))
(define f2 (make <Inner-window> :parent f :title "A canvas window"))
(demo-scroll-text f1)
(demo-scroll-canvas f2)
(place f1 :x 100 :y 70)
(place f2 :x 10 :y 10))
;=============================================================================
(define (demo-valued-gauge)
(let* ((top (make <Toplevel> :title "Valued Gauge widget"))
(g (make <Valued-Gauge> :parent top :width 400 :height 15)))
(pack g :expand #t :fill "both")
(dotimes (i 101)
(slot-set! g 'value i)
(after 5)
(update))))
;=============================================================================
(define (demo-hierarchy-tree)
(let* ((top (make <Toplevel> :title "Hierarchy Tree Demo"))
(T (make <Hierarchy-tree> :parent top :width 400 :height 300)))
(pack T :expand #t :fill "both")
(define d1 (add-node T #f "dir1"))
(define d2 (add-node T #f "dir2"))
(define d3 (add-node T d1 "dir3"))
(add-leave T d1 "file2")
(add-leave T d1 "file1")
(add-leave T d3 "file3")
(add-leave T d2 "file4")))
;=============================================================================
(define (demo-notepad)
;;
;; Fist define the actions associated to the tab
;;
(define (Host parent tab)
(unless (page tab) ; First call. Create the interface
(let* ((f (make <Frame> :parent parent :border-width 3
:background "darkgray" :relief "groove"))
(b1 (make <Labeled-Entry> :parent f :title "Host: "))
(b2 (make <Labeled-Entry> :parent f :title "Port: ")))
(pack b1 b2 :fill 'x :padx 10 :pady 10)
(set! (page tab) f)))
(pack (page tab) :padx 10 :pady 10 :fill "both" :expand #t))
(define (Mess parent tab)
(unless (page tab) ; First call. Create the interface
(let ((m (make <Message> :parent parent :border-width 3
:relief "groove" :background "darkgray" :aspect 300
:justify "center" :font "10x20"
:text "This is a simple demonstration.")))
(pack m :expand #t :fill "both")
(set! (page tab) m)))
(pack (page tab) :padx 10 :pady 10 :fill "both" :expand #t))
(let* ((top (make <Toplevel> :title "Note Pad Widget Demo"))
(f (make <NotePad> :parent top :width 450 :height 150)))
(pack f :expand #t :fill "both" :padx 2 :pady 2)
(make <Notepad-Tab> :parent f :text "host1" :action Host)
(make <Notepad-Tab> :parent f :text "host2" :action Host)
(make <Notepad-Tab> :parent f :text "Multi-line\nlabel" :action Mess)
(make <Notepad-Tab> :parent f :bitmap "questhead" :width 30 :action Host)))
;==============================================================================
(define (demo-toolbar)
(define-macro (P x) ; A macro for printing traces (for this demo)
`(lambda () (display ,x) (newline)))
(define top (make <toplevel> :title "Toolbar Demo"))
(define st (make <Scroll-Text> :parent top :font '(Helvetica 18 bold)
:width 48 :height 12
:value (& "\n\n\n"
"\tTo re-attach a detached toolbar, drag it on\n"
"\tone of the 4 sides of this text editor")))
(define action (default-release-toolbar st))
(define f1
(make-toolbar *top-root*
`(("File"
("---") ;; we want a tear-off
("Open" ,(P "Open"))
("Close" ,(P "Close"))
("") ;; insert a separator
("Exit" ,(lambda() (exit 0))))
("Edit"
("Cut" ,(P "Cut"))
("Copy" ,(P "Copy"))
("Paste" ,(P "Paste"))
("Submenu" ;; a submenu without tear-off
("sub1" ,(P "sub1"))
("sub2" ,(P "sub2")))
;; a completely managed item
(radiobutton :label "Foo" :foreground "blue3")
(radiobutton :label "Bar" :foreground "blue3"))
0
("Help"
("About" ,(P "About"))))
:parent top :background "Bisque3" :release-command action))
(define f2
(make-toolbar *top-root*
`(("tb_console.gif" "Open New Console" ,(P 1))
("tb_edit.gif" "Open New Editor" ,(P 2))
("tb_customize.gif" "Customize Environment" ,(P 3))
20 ; insert a 20 pixels wide space
("tb_fileopen.gif" "Load File" ,(P 4)))
:parent top :background "Bisque4" :release-command action))
(define f3
(make-toolbar *top-root*
`(("tb_copy.gif" "Copy" ,(P 5))
("tb_paste.gif" "Paste" ,(P 6))
("tb_cut.gif" "Cut" ,(P 7))
20
("tb_info.gif" "Help on Console" , (P 8)))
:parent top :background "Wheat2" :release-command action
:orientation "vertical"))
(pack f1 f2 :side "top" :fill 'x)
(pack f3 :side "left" :fill 'y)
(pack st :fill 'both :expand #t :side "bottom"))
;=============================================================================
(define (demo-font-chooser)
(require "font-chooser")
(let ((font (make-font-chooser)))
(if font
(format #t "You have choosed the font ~S\n" font)))
(format #t "**Cancel**"))