;;;;
;;;; STk adaptation of the Tk widget demo.
;;;;
;;;; This demonstration script creates a canvas that displays the
;;;; canvas item types.
;;;;
(define (demo-items)
;;
;; Functions used by this demo
;;
(let* ((w (make-demo-toplevel "items"
"Canvas Item Demonstration"
"This window contains a canvas widget with examples of the various kinds of items supported by canvases. The following operations are supported:\n Button-1 drag:\tmoves item under pointer.\n Button-2 drag:\trepositions view.\n Button-3 drag:\tstrokes out area.\n Ctrl+f:\t\tprints items under area."))
(c (make <Scroll-Canvas>
:parent w
:scroll-region (list 0 0 '30c '24c)
:width "15c"
:height "10c"
:relief "groove"
:border-width 3
:h-scroll-side "bottom"))
(font1 "-Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*")
(font2 "-Adobe-Helvetica-Bold-R-Normal--*-240-*-*-*-*-*-*")
(mono (= (winfo 'depth c) 1))
(blue (if mono "black" "DeepSkyBlue3"))
(red (if mono "black" "red"))
(bisque (if mono "black" "bisque3"))
(green (if mono "black" "SeaGreen3")))
(pack c :expand #t :fill "both")
;; Display a 3x3 rectangular grid.
(make <Rectangle> :parent c :coords '(0c 0c 30c 24c) :width 2)
(make <Line> :parent c :coords '(0c 8c 30c 8c) :width 2)
(make <Line> :parent c :coords '(0c 16c 30c 16c) :width 2)
(make <Line> :parent c :coords '(10c 0c 10c 24c) :width 2)
(make <Line> :parent c :coords '(20c 0c 20c 24c) :width 2)
;;
;; Set up demos within each of the areas of the grid.
;;
;; Lines
(make <Text-item> :parent c :coords '(5c .2c) :text "Lines" :anchor "n")
(make <Line> :parent c :coords '(1c 1c 3c 1c 1c 4c 3c 4c) :width "2m"
:fill blue :cap "butt" :join "miter" :tags "item")
(make <Line> :parent c :coords '(4.67c 1c 4.67c 4c) :arrow "last"
:tags "item")
(make <Line> :parent c :coords '(6.33c 1c 6.33c 4c) :arrow "both"
:tags "item")
(make <Line> :parent c
:coords '(5c 6c 9c 6c 9c 1c 8c 1c 8c 4.8c 8.8c 4.8c 8.8c 1.2c 8.2c 1.2c 8.2c 4.6c 8.6c 4.6c 8.6c 1.4c 8.4c 1.4c 8.4c 4.4c)
:width 3 :fill red :tags "item")
(make <Line> :parent c :coords '(1c 5c 7c 5c 7c 7c 9c 7c) :width '.5c
:stipple (string-append "@" *STk-images* "grey.25")
:arrow "both" :arrow-shape (list 15 15 7) :tags "item")
(make <Line> :parent c
:coords '(1c 7c 1.75c 5.8c 2.5c 7c 3.25c 5.8c 4c 7c) :width '.5c
:cap-style "round" :join-style "round" :tags "item")
;; Smoothed lines
(make <Text-item> :parent c :coords '(15c .2c)
:text "Curves (smoothed lines)" :anchor "n")
(make <Line> :parent c :coords '(11c 4c 11.5c 1c 13.5c 1c 14c 4c)
:smooth #t :fill blue :tags "item")
(make <Line> :parent c :coords '(15.5c 1c 19.5c 1.5c 15.5c 4.5c 19.5c 4c)
:smooth #t :arrow "both" :width 3 :tags "item")
(make <Line> :parent c
:coords '(12c 6c 13.5c 4.5c 16.5c 7.5c 18c 6c 16.5c 4.5c 13.5c 7.5c 12c 6c)
:smooth #t :width '3m :cap-style "round"
:stipple (string-append "@" *STk-images* "grey.25")
:fill red :tags "item")
;; Polygons
(make <Text-item> :parent c :coords '(25c .2c) :text "Polygons"
:anchor "n")
(make <Polygon> :parent c
:coords '(21c 1.0c 22.5c 1.75c 24c 1.0c 23.25c 2.5c 24c 4.0c 22.5c 3.25c 21c 4.0c 21.75c 2.5c)
:fill green :outline "black" :width 4 :tags "item")
(make <Polygon> :parent c
:coords '(25c 4c 25c 4c 25c 1c 26c 1c 27c 4c 28c 1c 29c 1c 29c 4c 29c 4c)
:fill red :smooth #t :tags "item")
(make <Polygon> :parent c
:coords '(22c 4.5c 25c 4.5c 25c 6.75c 28c 6.75c 28c 5.25c 24c 5.25c 24c 6.0c 26c 6c 26c 7.5c 22c 7.5c)
:stipple (string-append "@" *STk-images* "grey.25")
:outline "black" :tags "item")
;; Rectangles
(make <Text-item> :parent c :coords '(5c 8.2c) :text "Rectangles"
:anchor "n")
(make <Rectangle> :parent c :coords '(1c 9.5c 4c 12.5c)
:outline red :width '3m :tags "item")
(make <Rectangle> :parent c :coords '(0.5c 13.5c 4.5c 15.5c)
:fill green :tags "item")
(make <Rectangle> :parent c :coords '(6c 10c 9c 15c)
:stipple (string-append "@" *STk-images* "grey.25")
:outline "" :fill blue :tags "item")
;; Ovals
(make <Text-item> :parent c :coords '(15c 8.2c) :text "Ovals" :anchor "n")
(make <Oval> :parent c :coords '(11c 9.5c 14c 12.5c)
:outline red :width '3m :tags "item")
(make <Oval> :parent c :coords '(10.5c 13.5c 14.5c 15.5c)
:fill green :tags "item")
(make <Oval> :parent c :coords '(16c 10c 19c 15c)
:stipple (string-append "@" *STk-images* "grey.25")
:outline "" :fill blue :tags "item")
;; Texts
(make <Text-item> :parent c :coords '(25c 8.2c) :text "Text" :anchor "n")
(make <Rectangle> :parent c :coords '(22.4c 8.9c 22.6c 9.1c))
(make <Text-item> :parent c :coords '(22.5c 9c) :anchor "n"
:font font1 :width '4c
:text "A short string of text, word-wrapped, justified left, and anchored north (at the top). The rectangles show the anchor points for each piece of text."
:tags "item")
(make <Rectangle> :parent c :coords '(25.4c 10.9c 25.6c 11.1c))
(make <Text-item> :parent c :coords '(25.5c 11c) :anchor "w"
:font font1 :fill blue
:text "Several lines,\n each centered\nindividually,\nand all anchored\nat the left edge."
:justify "center" :tags "item")
(make <Rectangle> :parent c :coords '(24.9c 13.9c 25.1c 14.1c))
(make <Text-item> :parent c :coords '(25c 14c)
:font font2 :anchor "c" :fill red
:stipple (string-append "@" *STk-images* "grey.5")
:text "Stippled characters" :tags "item")
;; Arcs
(make <Text-item> :parent c :coords '(5c 16.2c) :text "Arcs" :anchor "n")
(make <Arc> :parent c :coords '(0.5c 17c 7c 20c) :fill green
:outline "black" :start 45 :extent 270 :style "pieslice" :tags "item")
(make <Arc> :parent c :coords '(6.5c 17c 9.5c 20c) :width '4m :style "arc"
:outline blue :start -135 :extent 270
:outline-stipple (string-append "@" *STk-images* "grey.25")
:tags "item")
(make <Arc> :parent c :coords '(0.5c 20c 9.5c 24c) :width '4m
:style "pieslice" :fill "" :outline red :start 225 :extent -90
:tags "item")
(make <Arc> :parent c :coords '(5.5c 20.5c 9.5c 23.5c) :width '4m
:style "chord" :fill blue :outline "" :start 45 :extent 270
:tags "item")
;; Bitmaps
(make <Text-item> :parent c :coords '(15c 16.2c) :text "Bitmaps" :anchor "n")
(make <Bitmap-item> :parent c :coords '(13c 20c)
:bitmap-name (string-append "@" *STk-images* "face")
:tags "item")
(make <Bitmap-item> :parent c :coords '(17c 18.5c)
:bitmap-name (string-append "@" *STk-images* "noletters")
:tags "item")
(make <Bitmap-item> :parent c :coords '(17c 21.5c)
:bitmap-name (string-append "@" *STk-images* "letters")
:tags "item")
;; Windows
(make <Text-item> :parent c :coords '(25c 16.2c) :text "Windows" :anchor "n")
(make <Canvas-window> :parent c :coords '(21c 18c) :anchor "nw"
:window (make <Button> :text "Press Me" :parent c
:command (lambda ()
(let ((i (make <Text-item> :parent c
:coords '(25c 18.1c)
:anchor "n"
:text "Ouch!!"
:fill "Red")))
(after 500 (lambda ()
(destroy i))))))
:tags "item")
(make <Canvas-window> :parent c :coords '(21c 21c) :anchor "nw"
:window (make <Entry> :parent c :width 20 :relief "sunken"
:value "Edit thid text")
:tags "item")
(make <Canvas-window> :parent c :coords '(28.5c 17.5c) :anchor "n"
:window (make <Scale> :parent c :from 0 :to 100 :length '6c
:slider-length '.4c :width '.5c :tick-interval 0)
:tags "item")
(make <Text-item> :parent c :coords '(21c 17.9c) :text "Button" :anchor "sw")
(make <Text-item> :parent c :coords '(21c 20.9c) :text "Entry" :anchor "sw")
(make <Text-item> :parent c :coords '(28.5c 17.4c) :text "Scale" :anchor "s")
;; Set up event bindings for canvas:
(let ((action #f)
(x0 0) (y0 0)
(x1 0) (y1 0)
(x2 0) (y2 0))
(define (item-enter c)
(let ((item (car (find-items c 'with "current"))))
(cond
((= (winfo 'depth c) 1)
(set! action #f))
((is-a? item <Canvas-window>)
(set! action #f))
((is-a? item <Bitmap-item>)
(let ((bg (slot-ref item 'background)))
(set! action `(slot-set! ,item 'background ,bg))
(slot-set! item 'background "SteelBlue2")))
((and (or (is-a? item <Rectangle>)
(is-a? item <Oval>)
(is-a? item <Arc>))
(equal? (slot-ref item 'fill) ""))
(let ((outline (slot-ref item 'outline)))
(set! action `(slot-set! ,item 'outline ,outline))
(slot-set! item 'outline "SteelBlue2")))
(ELSE (let ((fill (slot-ref item 'fill)))
(set! action `(slot-set! ,item 'fill ,fill))
(slot-set! item 'fill "SteelBlue2"))))))
;; Utility procedures for stroking out a rectangle and printing what's
;; underneath the rectangle's area.
(define (item-mark c x y)
(set! x1 (canvas-x c x))
(set! y1 (canvas-y c y))
(canvas-delete c "area"))
(define (item-stroke c x y)
(let ((x (canvas-x c x))
(y (canvas-y c y)))
(unless (and (= x x1) (= y y1))
(canvas-delete c "area")
(make <Rectangle> :parent c :coords (list x1 y1 x y) :tags "area")
(set! x2 x)
(set! y2 y))))
(define (items-under-area c)
(format #t "Items enclosed by area: ~S\n"
(find-items c 'enclosed x1 y1 x2 y2))
(format #t "Items overlapping area: ~S\n"
(cdr (reverse (find-items c 'overlapping x1 y1 x2 y2)))))
;; Utility procedures to support dragging of items.
(define (item-start-drag c x y)
(set! x0 (canvas-x c x))
(set! y0 (canvas-x c y)))
(define (item-drag c x y)
(let ((x (canvas-x c x))
(y (canvas-x c y)))
(move c "current" (- x x0) (- y y0))
(set! x0 x)
(set! y0 y)))
(bind c "item" "<Any-Enter>" (lambda () (item-enter c)))
(bind c "item" "<Any-Leave>" (lambda () (eval action)))
(bind c "<1>" (lambda (x y) (item-start-drag c x y)))
(bind c "<B1-Motion>" (lambda (x y) (item-drag c x y)))
(bind c "<2>" (lambda (x y) (scan c 'mark x y)))
(bind c "<B2-Motion>" (lambda (x y) (scan c 'dragto x y)))
(bind c "<3>" (lambda (x y) (item-mark c x y)))
(bind c "<B3-Motion>" (lambda (x y) (item-stroke c x y)))
(bind c "<Control-f>" (lambda () (items-under-area c))))
(focus c)
))