;;;;
;;;; 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)
       
))