stk/Demos/stklos-widgets.stklos

#!/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**"))