;******************************************************************************
;
; File name     : mkRuler.stk
; Creation date : Aug-5-1993
; Last update   : Aug-6-1993
;
;******************************************************************************
;
; STk adaptation of the Tk widget demo.
;
; mkRuler:
; Create a canvas demonstration consisting of a ruler.
; This file implements a canvas widget that displays a ruler with tab stops
; that can be set individually.  The only procedure that should be invoked
; from outside the file is the first one, which creates the canvas.
;
;******************************************************************************

(provide "mkRuler")

(define ruler_grid '.25c)
(define v_left ())
(define v_right ())
(define v_top ())
(define v_bottom ())
(define v_size ())
(define v_normalStyle '(:fill "black"))
(define v_activeStyle '())
(define v_deleteStyle '())
(define v_grid 0)
(define v_x    0)
(define v_y    0)



(define (mkRuler)
  (let ((c ()))
    (catch (destroy .top-ruler))
    (toplevel ".top-ruler")
    (dpos .top-ruler)
    (wm 'title .top-ruler "Ruler Demonstration")
    (wm 'iconname .top-ruler "Ruler")

    (message ".top-ruler.m" :font "-Adobe-Times-Medium-R-Normal-*-180-*"
	     :width "13c" :relief "raised" :bd 2 
	     :text "This canvas widget shows a mock-up of a ruler.  You can create tab stops by dragging them out of the well to the right of the ruler.  You can also drag existing tab stops.  If you drag a tab stop far enough up or down so that it turns dim, it will be deleted when you release the mouse button.")
    (canvas ".top-ruler.c" :width '14.8c :height '2.5c :relief "raised")
    (set! c .top-ruler.c)
    (button ".top-ruler.ok" :text "OK" :command '(destroy .top-ruler))
    (pack .top-ruler.m .top-ruler.c :side "top" :fill "x")
    (pack .top-ruler.ok :side "bottom" :pady 5)

    (set! v_left (winfo 'fpixels c '1c))
    (set! v_right (winfo 'fpixels c '13c))
    (set! v_top (winfo 'fpixels c '1c))
    (set! v_bottom (winfo 'fpixels c '1.5c))
    (set! v_size (winfo 'fpixels c '.2c))

    (if (equal? (tk 'colormodel c) "color")
	(begin
	  (set! v_activeStyle '(:fill "red" :stipple ""))
	  (set! v_deleteStyle 
		'(:stipple (& STk_bitmaps "/grey.25") :fill "red")))
	(begin
	  (set! v_activeStyle '(:fill "black" :stipple ""))
	  (set! v_deleteStyle 
		'(:stipple (& STk_bitmaps "/grey.25" :fill "black")))))

    (c 'create 'line '1c '.5c '1c '1c '13c '1c '13c '.5c :width 1)

    (for-each (lambda (i)
		(let ((x (+ i 1)))
		  (c 'create 'line (& x "c") '1c (& x "c") '.6c :width 1)
		  (c 'create 'line (& x ".25c") '1c (& x ".25c") '.8c 
		     :width 1)
		  (c 'create 'line (& x ".5c") '1c (& x ".5c") '.7c :width 1)
		  (c 'create 'line (& x ".75c") '1c (& x ".75c") '.8c
		     :width 1)
		  (c 'create 'text (& x ".15c") '.75c :text i :anchor "sw")))
	      '(0 1 2 3 4 5 6 7 8 9 10 11))

    (c 'addtag 'well 'withtag
       [c 'create 'rect '13.2c '1c '13.8c '.5c :outline "black"
	  :fill (tk-get c :bg)])
    (c 'addtag 'well 'withtag
       [rulerMkTab c (winfo 'pixels c '13.5c) (winfo 'pixels c '.65c)])

    (c 'bind 'well "<1>" `(rulerNewTab ,(widget-name c) %x %y))
    (c 'bind 'tab "<1>" `(demo_selectTab ,(widget-name c) %x %y))
    (bind c "<B1-Motion>" `(rulerMoveTab ,(widget-name c) %x %y))
    (bind c "<Any-ButtonRelease-1>" `(rulerReleaseTab ,(widget-name c)))))


(define (rulerMkTab c x y)
  (c 'create 'polygon x y (+ x v_size) (+ y v_size) (- x v_size) (+ y v_size)))


(define (rulerNewTab c x y)
  (c 'addtag 'active 'withtag (rulerMkTab c x y))
  (c 'addtag 'tab 'withtag 'active)
  (set! v_x x)
  (set! v_y y)
  (rulerMoveTab c x y))


(define (rulerMoveTab c x y)
  (if (not-equal? (c 'find 'withtag 'active) "")
      (let ((cx (c 'canvasx x v_grid)) (cy (c 'canvasy y)))
	(if (< cx v_left) (set! cx v_left))
	(if (> cx v_right) (set! cx v_right))
	(if (and (>= cy v_top) (<= cy v_bottom))
	    (begin
	      (set! cy (+ v_top 2))
	      (eval `(,c 'itemconfig 'active ,@v_activeStyle)))
	    (begin
	      (set! cy (- cy v_size 2))
	      (eval `(,c 'itemconfig 'active ,@v_deleteStyle))))
	(c 'move 'active (- cx v_x) (- cy v_y))
	(set! v_x cx)
	(set! v_y cy))))


(define (demo_selectTab c x y)
  (set! v_x (c 'canvasx x v_grid))
  (set! v_y (+ v_top 2))
  (c 'addtag 'active 'withtag 'current)
  (eval `(,c 'itemconfig 'active ,@v_activeStyle))
  (c 'raise 'active))


(define (rulerReleaseTab c)
  (if (not-equal? (c 'find 'withtag 'active) "")
      (if (<> v_y (+ v_top 2))
	  (c 'delete 'active)
	  (begin
	    (eval `(,c 'itemconfig 'active ,@v_normalStyle))
	    (c 'dtag 'active)))))