;******************************************************************************
;
; File name     : mkScroll.stk
; Creation date : Aug-6-1993
; Last update   : Aug-9-1993
;
;******************************************************************************
;
; STk adaptation of the Tk widget demo.
;
; mkScroll:
; Create a top-level window containing a simple canvas that can  be scrolled
; in two dimensions.
;
;******************************************************************************

(provide "mkScroll")

(define (mkScroll)
  (let ((c ()))
    (catch (destroy .top-scroll))
    (toplevel ".top-scroll")
    (dpos .top-scroll)
    (wm 'title .top-scroll "Scrollable Canvas Demonstration")
    (wm 'iconname .top-scroll "Canvas")
    (wm 'minsize .top-scroll 100 100)

    (message ".top-scroll.m"
	     :font "-Adobe-Times-Medium-R-Normal-*-180-*" :aspect 300
	     :relief "raised" :bd 2 
	     :text "This window displays a canvas widget that can be scrolled either using the scrollbars or by dragging with button 2 in the canvas.  If you click button 1 on one of the rectangles, its indices will be printed on stdout.")
    (frame ".top-scroll.f" :relief "raised" :bd 2)
    (button ".top-scroll.ok" :text "OK" :command '(destroy .top-scroll))
    (pack .top-scroll.m :side "top" :fill "x")
    (pack .top-scroll.ok :side "bottom" :pady 5)
    (pack .top-scroll.f :side "top" :expand "yes" :fill "both")

    (canvas ".top-scroll.f.c"
	    :scrollregion "-10c -10c 50c 20c"
	    :xscroll ".top-scroll.f.hsb 'set" :yscroll ".top-scroll.f.vsb 'set")
    (set! c .top-scroll.f.c)
    (scrollbar ".top-scroll.f.vsb" :relief "sunken"
	       :command ".top-scroll.f.c 'yview")
    (scrollbar ".top-scroll.f.hsb" :orient "horiz" :relief "sunken"
	       :command ".top-scroll.f.c 'xview")
    (pack .top-scroll.f.vsb :side "right" :fill "y")
    (pack .top-scroll.f.hsb :side "bottom" :fill "x")
    (pack c :expand "yes" :fill "both")

    (let ((bg (tk-get c :bg)) (fmt (lambda (x) (format #f "~Ac" x))))
      (do ((i 0 (+ i 1)))
	  ((= i 20))
	(let ((x (- (* i 3) 10)))
	  (do ((y -10 (+ y 3)) (j 0 (+ j 1)))
	      ((= j 10))
	    (c 'create 'rect (fmt x) (fmt y) 
	       (fmt (+ x 2)) (fmt (+ y 2))
	       :outline "black" :fill bg :tags 'rect)
	    (c 'create 'text (fmt (+ x 1)) (fmt (+ y 1))
	       :text (format #f "~A,~A" i j) :anchor "center" :tags 'text)))))

    (c 'bind 'all "<Any-Enter>" `(scrollEnter ,(widget-name c)))
    (c 'bind 'all "<Any-Leave>" `(scrollLeave ,(widget-name c)))
    (c 'bind 'all "<1>" `(scrollButton ,(widget-name c)))
    (bind c "<2>" `(,(widget-name c) 'scan 'mark %x %y))
    (bind c "<B2-Motion>" `(,(widget-name c) 'scan 'dragto %x %y))))



(define oldFill ())


(define (scrollEnter canvas)
  (let ((id (car (canvas 'find 'withtag 'current))))
    (if (member 'text (canvas 'gettags 'current))
	(set! id (- id 1)))
    (set! oldFill (tki-get canvas id :fill))
    (if (equal? (tk 'colormodel canvas) "color")
	(tki-set canvas id :fill "SeaGreen1")
	(begin
	  (tki-set canvas id :fill "black")
	  (tki-set canvas (+ id 1) :fill "white")))))


(define (scrollLeave canvas)
  (let ((id (car (canvas 'find 'withtag 'current))))
    (if (member 'text (canvas 'gettags 'current))
	(set! id (- id 1)))
    (tki-set canvas id :fill oldFill)
    (tki-set canvas (+ id 1) :fill "black")))


(define (scrollButton canvas)
  (let ((id (car (canvas 'find 'withtag 'current))))
    (if (not (member 'text (canvas 'gettags 'current)))
	(set! id (+ id 1)))
    (format #t  "You buttoned at ~A~%" (tki-get canvas id :text))))