258 lines
11 KiB
Plaintext
258 lines
11 KiB
Plaintext
;;;;
|
|
;;;; 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)
|
|
|
|
))
|