;****************************************************************************** ; ; File name : mkItems.stk ; Creation date : Aug-4-1993 ; Last update : Aug-19-1993 ; ;****************************************************************************** ; ; STk adaptation of the Tk widget demo. ; ; mkItems: ; Create a top-level window containing a canvas that displays the various ; item types and allows them to be selected and moved. This demo can be used ; to test out the point-hit and rectangle-hit code for items. ; ;****************************************************************************** (provide "mkItems") (define (mkItems) (let ((font1 "-Adobe-Helvetica-Medium-R-Normal-*-120-*") (font2 "-Adobe-Helvetica-Bold-R-Normal-*-240-*") (blue ()) (red ()) (bisque ()) (green ())) (catch (destroy .top-items)) (toplevel ".top-items") (dpos .top-items) (wm 'title .top-items "Canvas Item Demonstration") (wm 'iconname .top-items "Items") (wm 'minsize .top-items 100 100) (message ".top-items.m" :font "-Adobe-Times-Medium-R-Normal-*-180-*" :width '13c :bd 2 :relief "raised" :text "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.") (frame ".top-items.f2" :relief "raised" :bd 2) (button ".top-items.ok" :text "OK" :command '(destroy .top-items)) (pack .top-items.m :side "top" :fill "x") (pack .top-items.f2 :side "top" :fill "both" :expand "yes") (pack .top-items.ok :side "bottom" :pady 5 :anchor "center") (canvas ".top-items.f2.c" :scrollregion "0c 0c 30c 24c" :width '15c :height '10c :xscroll ".top-items.f2.hsb 'set" :yscroll ".top-items.f2.vsb 'set") (scrollbar ".top-items.f2.vsb" :relief "sunken" :command ".top-items.f2.c 'yview") (scrollbar ".top-items.f2.hsb" :orient "horiz" :relief "sunken" :command ".top-items.f2.c 'xview") (pack .top-items.f2.hsb :side "bottom" :fill "x") (pack .top-items.f2.vsb :side "right" :fill "y") (pack .top-items.f2.c :in .top-items.f2 :expand "yes" :fill "both") ; Display a 3x3 rectangular grid. (.top-items.f2.c 'create 'rectangle '0c '0c '30c '24c :width 2) (.top-items.f2.c 'create 'line '0c '8c '30c '8c :width 2) (.top-items.f2.c 'create 'line '0c '16c '30c '16c :width 2) (.top-items.f2.c 'create 'line '10c '0c '10c '24c :width 2) (.top-items.f2.c 'create 'line '20c '0c '20c '24c :width 2) (if (equal? (tk 'colormodel .top-items.f2.c) "color") (begin (set! blue "DeepSkyBlue3") (set! red "red") (set! bisque "bisque3") (set! green "SeaGreen3")) (begin (set! blue "black") (set! red "black") (set! bisque "black") (set! green "black"))) ; Set up demos within each of the areas of the grid. (.top-items.f2.c 'create 'text '5c '.2c :text "Lines" :anchor "n") (.top-items.f2.c 'create 'line '1c '1c '3c '1c '1c '4c '3c '4c :width "2m" :fill blue :cap "butt" :join "miter" :tags 'item) (.top-items.f2.c 'create 'line '4.67c '1c '4.67c '4c :arrow "last" :tags 'item) (.top-items.f2.c 'create 'line '6.33c '1c '6.33c '4c :arrow "both" :tags 'item) (.top-items.f2.c 'create 'line '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) (.top-items.f2.c 'create 'line '1c '5c '7c '5c '7c '7c '9c '7c :width '.5c :stipple (& STk_bitmaps "/grey.25") :arrow "both" :arrowshape "15 15 7" :tags 'item) (.top-items.f2.c 'create 'line '1c '7c '1.75c '5.8c '2.5c '7c '3.25c '5.8c '4c '7c :width '.5c :cap "round" :join "round" :tags 'item) (.top-items.f2.c 'create 'text '15c '.2c :text "Curves (smoothed lines)" :anchor "n") (.top-items.f2.c 'create 'line '11c '4c '11.5c '1c '13.5c '1c '14c '4c :smooth "on" :fill blue :tags 'item) (.top-items.f2.c 'create 'line '15.5c '1c '19.5c '1.5c '15.5c '4.5c '19.5c '4c :smooth "on" :arrow "both" :width 3 :tags 'item) (.top-items.f2.c 'create 'line '12c '6c '13.5c '4.5c '16.5c '7.5c '18c '6c '16.5c '4.5c '13.5c '7.5c '12c '6c :smooth "on" :width "3m" :cap "round" :stipple (& STk_bitmaps "/grey.25") :fill red :tags 'item) (.top-items.f2.c 'create 'text '25c '.2c :text "Polygons" :anchor "n") (.top-items.f2.c 'create 'polygon '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 :tags 'item) (.top-items.f2.c 'create 'polygon '25c '4c '25c '4c '25c '1c '26c '1c '27c '4c '28c '1c '29c '1c '29c '4c '29c '4c :fill red :smooth "on" :tags 'item) (.top-items.f2.c 'create 'polygon '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 (& STk_bitmaps "/grey.25") :tags 'item) (.top-items.f2.c 'create 'text '5c '8.2c :text "Rectangles" :anchor "n") (.top-items.f2.c 'create 'rectangle '1c '9.5c '4c '12.5c :outline red :width "3m" :tags 'item) (.top-items.f2.c 'create 'rectangle '0.5c '13.5c '4.5c '15.5c :fill green :tags 'item) (.top-items.f2.c 'create 'rectangle '6c '10c '9c '15c :outline "" :stipple (& STk_bitmaps "/grey.25") :fill blue :tags 'item) (.top-items.f2.c 'create 'text '15c '8.2c :text "Ovals" :anchor "n") (.top-items.f2.c 'create 'oval '11c '9.5c '14c '12.5c :outline red :width "3m" :tags 'item) (.top-items.f2.c 'create 'oval '10.5c '13.5c '14.5c '15.5c :fill green :tags 'item) (.top-items.f2.c 'create 'oval '16c '10c '19c '15c :outline "" :stipple (& STk_bitmaps "/grey.25") :fill blue :tags 'item) (.top-items.f2.c 'create 'text '25c '8.2c :text "Text" :anchor "n") (.top-items.f2.c 'create 'rectangle '22.4c '8.9c '22.6c '9.1c) (.top-items.f2.c 'create 'text '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) (.top-items.f2.c 'create 'rectangle '25.4c '10.9c '25.6c '11.1c) (.top-items.f2.c 'create 'text '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) (.top-items.f2.c 'create 'rectangle '24.9c '13.9c '25.1c '14.1c) (.top-items.f2.c 'create 'text '25c '14c :font font2 :anchor "c" :fill red :stipple (& STk_bitmaps "/grey.5") :text "Stippled characters" :tags 'item) (.top-items.f2.c 'create 'text '5c '16.2c :text "Arcs" :anchor "n") (.top-items.f2.c 'create 'arc '0.5c '17c '7c '20c :fill green :outline "black" :start 45 :extent 270 :style "pieslice" :tags 'item) (.top-items.f2.c 'create 'arc '6.5c '17c '9.5c '20c :width "4m" :style "arc" :fill blue :start -135 :extent 270 :stipple (& STk_bitmaps "/grey.25") :tags 'item) (.top-items.f2.c 'create 'arc '0.5c '20c '9.5c '24c :width "4m" :style "pieslice" :fill "" :outline red :start 225 :extent -90 :tags 'item) (.top-items.f2.c 'create 'arc '5.5c '20.5c '9.5c '23.5c :width "4m" :style "chord" :fill blue :outline "" :start 45 :extent 270 :tags 'item) (.top-items.f2.c 'create 'text '15c '16.2c :text "Bitmaps" :anchor "n") (.top-items.f2.c 'create 'bitmap '13c '20c :bitmap (& STk_bitmaps "/face") :tags 'item) (.top-items.f2.c 'create 'bitmap '17c '18.5c :bitmap (& STk_bitmaps "/noletters") :tags 'item) (.top-items.f2.c 'create 'bitmap '17c '21.5c :bitmap (& STk_bitmaps "/letters") :tags 'item) (.top-items.f2.c 'create 'text '25c '16.2c :text "Windows" :anchor "n") (button ".top-items.f2.c.b" :text "Press Me" :command '(butPress .top-items.f2.c 'red)) (.top-items.f2.c 'create 'window '21c '18c :window .top-items.f2.c.b :anchor "nw" :tags 'item) (entry ".top-items.f2.c.e" :width 20 :relief "sunken") (.top-items.f2.c.e 'insert "end" "Edit this text") (.top-items.f2.c 'create 'window '21c '21c :window .top-items.f2.c.e :anchor "nw" :tags 'item) (scale ".top-items.f2.c.s" :from 0 :to 100 :length '6c :sliderlength '.4c :width '.5c :tickinterval 0) (.top-items.f2.c 'create 'window '28.5c '17.5c :window .top-items.f2.c.s :anchor "n" :tags 'item) (.top-items.f2.c 'create 'text '21c '17.9c :text "Button:" :anchor "sw") (.top-items.f2.c 'create 'text '21c '20.9c :text "Entry:" :anchor "sw") (.top-items.f2.c 'create 'text '28.5c '17.4c :text "Scale:" :anchor "s") ; Set up event bindings for canvas: (.top-items.f2.c 'bind 'item "" '(itemEnter .top-items.f2.c)) (.top-items.f2.c 'bind 'item "" '(itemLeave .top-items.f2.c)) (bind .top-items.f2.c "<2>" '(.top-items.f2.c 'scan 'mark %x %y)) (bind .top-items.f2.c "" '(.top-items.f2.c 'scan 'dragto %x %y)) (bind .top-items.f2.c "<3>" '(itemMark .top-items.f2.c %x %y)) (bind .top-items.f2.c "" '(itemStroke .top-items.f2.c %x %y)) (bind .top-items.f2.c "" '(itemsUnderArea .top-items.f2.c)) (.top-items.f2.c 'bind 'item "<1>" '(itemStartDrag .top-items.f2.c %x %y)) (.top-items.f2.c 'bind 'item "" '(itemDrag .top-items.f2.c %x %y)) ; (bind .top-items.f2.c "<1>" '(itemStartDrag .top-items.f2.c %x %y)) ; (bind .top-items.f2.c "" '(itemDrag .top-items.f2.c %x %y)) (bind .top-items "" '(focus .top-items.f2.c)))) ; Utility procedures for highlighting the item under the pointer: (define restoreCmd ()) (define (itemEnter c) (if (not-equal? (tk 'colormodel c) "color") (set! restoreCmd "") (let ((type (c 'type 'current))) (case type ((window) (set! restoreCmd ())) ((bitmap) (let ((bg (tki-get c 'current :background))) (set! restoreCmd `(tki-set ,c 'current :background ,bg)) (tki-set c 'current :background "SteelBlue2"))) (else (let ((fill (tki-get c 'current :fill))) (if (and (member type '(rectangle oval arc)) (equal? fill "")) (let ((outline (tki-get c 'current :outline))) (set! restoreCmd `(tki-set ,c 'current :outline ,outline)) (tki-set c 'current :outline "SteelBlue2")) (begin (set! restoreCmd `(tki-set ,c 'current :fill ,fill)) (tki-set c 'current :fill "SteelBlue2"))))))))) (define (itemLeave c) (eval restoreCmd)) ; Utility procedures for stroking out a rectangle and printing what's ; underneath the rectangle's area. (define (itemMark c x y) (set! areaX1 (c 'canvasx x)) (set! areaY1 (c 'canvasy y)) (c 'delete 'area)) (define (itemStroke c x y) (set! x (c 'canvasx x)) (set! y (c 'canvasy y)) (if (and (not-equal? areaX1 x) (not-equal? areaY1 y)) (begin (c 'delete 'area) (c 'addtag 'area 'withtag (c 'create 'rectangle areaX1 areaY1 x y :outline "black")) (set! areaX2 x) (set! areaY2 y)))) (define (itemsUnderArea c) (set! area (c 'find 'withtag 'area)) (set! items ()) (for-each (lambda (i) (if (member 'item (c 'gettags i)) (set! items (append items (list i))))) (c 'find 'enclosed areaX1 areaY1 areaX2 areaY2)) (display "Items enclosed by area: ") (display items) (newline) (set! items ()) (for-each (lambda (i) (if (member 'item (c 'gettags i)) (set! items (append items (list i))))) (c 'find 'overlapping areaX1 areaY1 areaX2 areaY2)) (display "Items overlapping area: ") (display items) (newline)) (define area '()) (define items '()) (define areaX1 0) (define areaY1 0) (define areaX2 0) (define areaY2 0) ; Utility procedures to support dragging of items. (define lastX 0) (define lastY 0) (define (itemStartDrag c x y) (set! lastX (c 'canvasx x)) (set! lastY (c 'canvasy y))) (define (itemDrag c x y) (set! x (c 'canvasx x)) (set! y (c 'canvasy y)) (c 'move 'current (- x lastX) (- y lastY)) (set! lastX x) (set! lastY y)) ; Procedure that's invoked when the button embedded in the canvas ; is invoked. (define (butPress w color) (let ((i (w 'create 'text '25c '18.1c :text "Ouch!!" :fill color :anchor "n"))) (after 500 `(,(widget-name w) 'delete ,i))))