;******************************************************************************
;
; File name     : mkArrow.stk
; Creation date : Aug-5-1993
; Last update   : Aug-19-1993
;
;******************************************************************************
;
; STk adaptation of the Tk widget demo.
;
; mkArrow:
; Create a top-level window containing a canvas demonstration that allows
; the user to experiment with arrow shapes.
; This file implements a canvas widget that displays a large line with
; an arrowhead and allows the shape of the arrowhead to be edited
; interactively.  The only procedure that should be invoked from outside
; the file is the first one, which creates the canvas.
;
;******************************************************************************

(provide "mkArrow")

(define v_a 8)
(define v_b 10)
(define v_c 3)
(define v_width 2)
(define v_motionProc 'arrowMoveNull)
(define v_x1 40)
(define v_x2 350)
(define v_y 150)
(define v_smallTips "5 5 2")
(define v_count 0)
(define v_bigLineStyle '())
(define v_boxStyle '())
(define v_activeStyle '())
(define xtip 0)
(define deltaY 0)
(define tmp '())
(define newA 0)


(define demo_arrowInfo ())


(define (mkArrow)
  (let ((c ""))
    (catch (destroy .top-arrow))
    (toplevel ".top-arrow")
    (dpos .top-arrow)
    (wm 'title .top-arrow "Arrowhead Editor Demonstration")
    (wm 'iconname .top-arrow "Arrow")

    (frame ".top-arrow.f1" :relief "raised" :bd 2)
    (canvas ".top-arrow.c" :width 500 :height 350 :relief "raised")
    (set! c .top-arrow.c)
    (button ".top-arrow.ok" :text "OK" :command "destroy .top-arrow")
    (pack .top-arrow.f1 :side "top" :fill "both")
    (pack .top-arrow.ok :side "bottom" :pady 5)
    (pack c :expand "yes" :fill "both")
    (message ".top-arrow.f1.m"
	     :font "-Adobe-Times-Medium-R-Normal-*-180-*" :aspect 300
	     :text "This widget allows you to experiment with different widths and arrowhead shapes for lines in canvases.  To change the line width or the shape of the arrowhead, drag any of the three boxes attached to the oversized arrow.  The arrows on the right give examples at normal scale.  The text at the bottom shows the configuration options as you'd enter them for a line.")
    (pack .top-arrow.f1.m)

    (if (equal? (tk 'colormodel c) "color")
	(begin
	  (set! v_bigLineStyle '(:fill "SkyBlue1"))
	  (set! v_boxStyle '(:fill "" :outline "black" :width 1))
	  (set! v_activeStyle '(:fill "red" :outline "black" :width 1)))
	(begin
	  (set! v_bigLineStyle 
		'(:fill "black" :stipple (& STk_bitmaps "/grey.25")))
	  (set! v_boxStyle '(:fill "" :outline "black" :width 1))
	  (set! v_activeStyle '(:fill "black" :outline "black" :width 1))))

    (arrowSetup c)
    (c 'bind 'box "<Enter>"
       `(,(widget-name c) 'itemconfig 'current ,@v_activeStyle))
    (c 'bind 'box "<Leave>"
       `(,(widget-name c) 'itemconfig 'current ,@v_boxStyle))
    (c 'bind 'box1 "<1>" '(set! demo_arrowInfo arrowMove1))
    (c 'bind 'box2 "<1>" '(set! demo_arrowInfo arrowMove2))
    (c 'bind 'box3 "<1>" '(set! demo_arrowInfo arrowMove3))
    (c 'bind 'box "<B1-Motion>" `(demo_arrowInfo ,(widget-name c) %x %y))
    (bind c "<Any-ButtonRelease-1>" `(arrowSetup ,(widget-name c)))))


; The procedure below completely regenerates all the text and graphics
; in the canvas window.  It's called when the canvas is initially created,
; and also whenever any of the parameters of the arrow head are changed
; interactively.  The argument is the name of the canvas widget to be
; regenerated, and also the name of a global variable containing the
; parameters for the display.

(define (arrowSetup c)
  (c 'delete 'all)
  
  ; Create the arrow and outline.

  (eval `(,c 'create 'line v_x1 v_y v_x2 v_y :width (* 10 v_width)
	     :arrowshape (&& (* 10 v_a) (* 10 v_b) (* 10 v_c))
	     :arrow "last" ,@v_bigLineStyle))
  (set! xtip (- v_x2 (* 10 v_b)))
  (set! deltaY (+ (* 10 v_c) (* 5 v_width)))
  (c 'create 'line v_x2 v_y xtip (+ v_y deltaY)
     (- v_x2 (* 10 v_a)) v_y xtip (- v_y deltaY)
     v_x2 v_y :width 2 :capstyle "round" :joinstyle "round")

  ; Create the boxes for reshaping the line and arrowhead.

  (eval `(,c 'create 'rect (- v_x2 (* 10 v_a) 5) (- v_y 5)
	     (+ (- v_x2 (* 10 v_a)) 5) (+ v_y 5) ,@v_boxStyle
	     :tags "box1 box"))
  (eval `(,c 'create 'rect (- xtip 5) (- v_y deltaY 5)
	     (+ xtip 5) (+ (- v_y deltaY) 5) ,@v_boxStyle
	     :tags "box2 box"))
  (eval `(,c 'create 'rect (- v_x1 5) (- v_y (* 5 v_width) 5)
	     (+ v_x1 5) (+ (- v_y (* 5 v_width)) 5) ,@v_boxStyle
	     :tags "box3 box"))

  ; Create three arrows in actual size with the same parameters

  (c 'create 'line (+ v_x2 50) 0 (+ v_x2 50) 1000 :width 2)
  (set! tmp (+ v_x2 100))
  (c 'create 'line tmp (- v_y 125) tmp (- v_y 75) :width v_width
     :arrow "both" :arrowshape (&& v_a v_b v_c))
  (c 'create 'line (- tmp 25) v_y (+ tmp 25) v_y :width v_width
     :arrow "both" :arrowshape (&& v_a v_b v_c))
  (c 'create 'line (- tmp 25) (+ v_y 75) (+ tmp 25) (+ v_y 125)
     :width v_width :arrow "both" :arrowshape (&& v_a v_b v_c))

  ; Create a bunch of other arrows and text items showing the
  ; current dimensions.

  (set! tmp (+ v_x2 10))
  (c 'create 'line tmp (- v_y (* 5 v_width)) tmp (- v_y deltaY)
	     :arrow "both" :arrowshape v_smallTips)
  (c 'create 'text (+ v_x2 15) (+ (- v_y deltaY) (* 5 v_c))
     :text v_c :anchor "w")
  (set! tmp (- v_x1 10))
  (c 'create 'line tmp (- v_y (* 5 v_width)) tmp (+ v_y (* 5 v_width))
     :arrow "both" :arrowshape v_smallTips)
  (c 'create 'text (- v_x1 15) v_y :text v_width :anchor "e")
  (set! tmp (+ v_y (* 5 v_width) (* 10 v_c) 10))
  (c 'create 'line (- v_x2 (* 10 v_a)) tmp v_x2 tmp 
     :arrow "both" :arrowshape v_smallTips)
  (c 'create 'text (- v_x2 (* 5 v_a)) (+ tmp 5) :text v_a :anchor "n")
  (set! tmp (+ tmp 25))
  (c 'create 'line (- v_x2 (* 10 v_b)) tmp v_x2 tmp
     :arrow "both" :arrowshape v_smallTips)
  (c 'create 'text (- v_x2 (* 5 v_b)) (+ tmp 5) :text v_b :anchor "n")

  (c 'create 'text v_x1 310 :text (& ":width  " v_width)
     :anchor "w" :font "-Adobe-Helvetica-Medium-R-Normal-*-180-*")
  (c 'create 'text v_x1 330
     :text (& ":arrowshape  \"" v_a "  " v_b "  " v_c "\"")
     :anchor "w" :font "-Adobe-Helvetica-Medium-R-Normal-*-180-*")

  (set! v_count (+ 1 v_count)))


; The procedures below are called in response to mouse motion for one
; of the three items used to change the line width and arrowhead shape.
; Each procedure updates one or more of the controlling parameters
; for the line and arrowhead, and recreates the display if that is
; needed.  The arguments are the name of the canvas widget, and the
; x and y positions of the mouse within the widget.

(define (arrowMove1 c x y)
  (set! newA (/ (+ v_x2 (- 5 (c 'canvasx x))) 10))
  (if (< newA 1) (set! newA 1))
  (if (> newA 25) (set! newA 25))
  (if (<> newA v_a)
      (begin
	(c 'move 'box1 (* 10 (- v_a newA)) 0)
	(set! v_a newA))))


(define (arrowMove2 c x y)
  (let ((newB (/ (+ v_x2 (- 5 (c 'canvasx x))) 10))
	(newC (/ (+ v_y (- 5 (c 'canvasy y) (* 5 v_width))) 10)))
    (if (< newB 1) (set! newB 1))
    (if (> newB 25) (set! newB 25))
    (if (< newC 1) (set! newC 1))
    (if (> newC 20) (set! newC 20))
    (if (or (<> newB v_b) (<> newC v_c))
	(begin
	  (c 'move 'box2 (* 10 (- v_b newB)) (* 10 (- v_c newC)))
	  (set! v_b newB)
	  (set! v_c newC)))))


(define (arrowMove3 c x y)
  (let ((newWidth (/ (+ v_y (- 5 (c 'canvasy y))) 5)))
    (if (< newWidth 1) (set! newWidth 1))
    (if (> newWidth 20) (set! newWidth 20))
    (if (<> newWidth v_width)
	(begin
	  (c 'move 'box3 0 (* 5 (- v_width newWidth)))
	  (set! v_width newWidth)))))