# arrow.tcl -- Stollen from tk8.0/demo directory.
# Probably due to Ousterhout (?)
# but certainly not my creation.
# I only changed the text frame and canceled th line-width box, so the user
# is not allowed to change the line width through this tool.
#
# This demonstration script creates a canvas widget that displays a
# large line with an arrowhead whose shape can be edited interactively.
#
# SCCS: @(#) arrow.tcl 1.8 97/03/02 16:18:20

# arrowSetup --
# This procedure 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.
#
# Arguments:
# c -		Name of the canvas widget.

proc arrowSetup c {
    upvar #0 demo_arrowInfo v

    # Remember the current box, if there is one.

    set tags [$c gettags current]
    if {$tags != ""} {
	set cur [lindex $tags [lsearch -glob $tags box?]]
    } else {
	set cur ""
    }

    # Create the arrow and outline.

    $c delete all
    eval "$c create line $v(x1) $v(y) $v(x2) $v(y) -width [expr 10*$v(width)] \
	    -arrowshape {[expr 10*$v(a)] [expr 10*$v(b)] [expr 10*$v(c)]} \
	    -arrow last $v(bigLineStyle)"
    set xtip [expr $v(x2)-10*$v(b)]
    set deltaY [expr 10*$v(c)+5*$v(width)]
    $c create line $v(x2) $v(y) $xtip [expr $v(y)+$deltaY] \
	    [expr $v(x2)-10*$v(a)] $v(y) $xtip [expr $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 [expr $v(x2)-10*$v(a)-5] [expr $v(y)-5] \
	    [expr $v(x2)-10*$v(a)+5] [expr $v(y)+5] $v(boxStyle) \
	    -tags {box1 box}"
    eval "$c create rect [expr $xtip-5] [expr $v(y)-$deltaY-5] \
	    [expr $xtip+5] [expr $v(y)-$deltaY+5] $v(boxStyle) \
	    -tags {box2 box}"
    if {$cur != ""} {
	eval $c itemconfigure $cur $v(activeStyle)
    }

    # Create three arrows in actual size with the same parameters

    $c create line [expr $v(x2)+50] 0 [expr $v(x2)+50] 1000 \
	    -width 2
    set tmp [expr $v(x2)+100]
    $c create line $tmp [expr $v(y)-125] $tmp [expr $v(y)-75] \
	    -width $v(width) \
	    -arrow both -arrowshape "$v(a) $v(b) $v(c)"
    $c create line [expr $tmp-25] $v(y) [expr $tmp+25] $v(y) \
	    -width $v(width) \
	    -arrow both -arrowshape "$v(a) $v(b) $v(c)"
    $c create line [expr $tmp-25] [expr $v(y)+75] [expr $tmp+25] \
	    [expr $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 [expr $v(x2)+10]
    $c create line $tmp [expr $v(y)-5*$v(width)] \
	    $tmp [expr $v(y)-$deltaY] \
	    -arrow both -arrowshape $v(smallTips)
    $c create text [expr $v(x2)+15] [expr $v(y)-$deltaY+5*$v(c)] \
	    -text $v(c) -anchor w
    set tmp [expr $v(x1)-10]
    $c create line $tmp [expr $v(y)-5*$v(width)] \
	    $tmp [expr $v(y)+5*$v(width)] \
	    -arrow both -arrowshape $v(smallTips)
    $c create text [expr $v(x1)-15] $v(y) -text $v(width) -anchor e
    set tmp [expr $v(y)+5*$v(width)+10*$v(c)+10]
    $c create line [expr $v(x2)-10*$v(a)] $tmp $v(x2) $tmp \
	    -arrow both -arrowshape $v(smallTips)
    $c create text [expr $v(x2)-5*$v(a)] [expr $tmp+5] \
	    -text $v(a) -anchor n
    set tmp [expr $tmp+25]
    $c create line [expr $v(x2)-10*$v(b)] $tmp $v(x2) $tmp \
	    -arrow both -arrowshape $v(smallTips)
    $c create text [expr $v(x2)-5*$v(b)] [expr $tmp+5] \
	    -text $v(b) -anchor n

    $c create text $v(x1) 310 -text "-width  $v(width)" \
	    -anchor w -font {Helvetica 14}
    $c create text $v(x1) 330 -text "-arrowshape  {$v(a)  $v(b)  $v(c)}" \
	    -anchor w -font {Helvetica 14}

    incr v(count)
}

proc arrowShapeTool {} {
  global demo_arrowInfo Graphics tk_library

  set butfont {Helvetica 12 bold}

  set w .arrowshape
  catch {destroy $w}
  toplevel $w
  wm title $w "Arrowhead Editor"
  wm iconname $w "arrow"
  #positionWindow $w
  #bind $w <FocusOut> "raise $w; focus -force $w"
  grab set $w
  raise $w
  focus $w

  set c $w.c
  
  label $w.msg -font {Helvetica 14 bold} -wraplength 5i -justify left \
               -text "Design your favourite arrow shape."
  pack $w.msg -side top
  
  frame $w.buttons
  pack $w.buttons -side bottom -fill x -pady 2m
  button $w.buttons.cancel -text Cancel \
         -font $butfont \
         -command "grab release $w ; destroy $w"
  button $w.buttons.apply -text "Apply" \
         -command "applyArrowShape" -font $butfont
  pack $w.buttons.cancel $w.buttons.apply -side left -expand 1
  
  canvas $c -width 500 -height 350 -relief sunken -borderwidth 2
  pack $c -expand yes -fill both
  
  set demo_arrowInfo(a) [lindex $Graphics(arrowshape) 0]
  set demo_arrowInfo(b) [lindex $Graphics(arrowshape) 1]
  set demo_arrowInfo(c) [lindex $Graphics(arrowshape) 2]
  set demo_arrowInfo(width) $Graphics(line,width)
  set demo_arrowInfo(motionProc) arrowMoveNull
  set demo_arrowInfo(x1) 40
  set demo_arrowInfo(x2) 350
  set demo_arrowInfo(y) 150
  set demo_arrowInfo(smallTips) {5 5 2}
  set demo_arrowInfo(count) 0
  if {[winfo depth $c] > 1} {
      set demo_arrowInfo(bigLineStyle) "-fill SkyBlue1"
      set demo_arrowInfo(boxStyle) "-fill {} -outline black -width 1"
      set demo_arrowInfo(activeStyle) "-fill red -outline black -width 1"
  } else {
      set demo_arrowInfo(bigLineStyle) "-fill black \
  	-stipple @[file join $tk_library demos images grey.25]"
      set demo_arrowInfo(boxStyle) "-fill {} -outline black -width 1"
      set demo_arrowInfo(activeStyle) "-fill black -outline black -width 1"
  }
  arrowSetup $c
  $c bind box <Enter> "$c itemconfigure current $demo_arrowInfo(activeStyle)"
  $c bind box <Leave> "$c itemconfigure current $demo_arrowInfo(boxStyle)"
  $c bind box <B1-Enter> " "
  $c bind box <B1-Leave> " "
  $c bind box1 <1> {set demo_arrowInfo(motionProc) arrowMove1}
  $c bind box2 <1> {set demo_arrowInfo(motionProc) arrowMove2}
  $c bind box <B1-Motion> "\$demo_arrowInfo(motionProc) $c %x %y"
  bind $c <Any-ButtonRelease-1> "arrowSetup $c"
}

# arrowMove1 --
# This procedure is called for each mouse motion event on box1 (the
# one at the vertex of the arrow).  It updates the controlling parameters
# for the line and arrowhead.
#
# Arguments:
# c -		The name of the canvas window.
# x, y -	The coordinates of the mouse.

proc arrowMove1 {c x y} {
    upvar #0 demo_arrowInfo v
    set newA [expr ($v(x2)+5-round([$c canvasx $x]))/10]
    if {$newA < 0} {
	set newA 0
    }
    if {$newA > 25} {
	set newA 25
    }
    if {$newA != $v(a)} {
	$c move box1 [expr 10*($v(a)-$newA)] 0
	set v(a) $newA
    }
}

# arrowMove2 --
# This procedure is called for each mouse motion event on box2 (the
# one at the trailing tip of the arrowhead).  It updates the controlling
# parameters for the line and arrowhead.
#
# Arguments:
# c -		The name of the canvas window.
# x, y -	The coordinates of the mouse.

proc arrowMove2 {c x y} {
    upvar #0 demo_arrowInfo v
    set newB [expr ($v(x2)+5-round([$c canvasx $x]))/10]
    if {$newB < 0} {
	set newB 0
    }
    if {$newB > 25} {
	set newB 25
    }
    set newC [expr ($v(y)+5-round([$c canvasy $y])-5*$v(width))/10]
    if {$newC < 0} {
	set newC 0
    }
    if {$newC > 20} {
	set newC 20
    }
    if {($newB != $v(b)) || ($newC != $v(c))} {
	$c move box2 [expr 10*($v(b)-$newB)] [expr 10*($v(c)-$newC)]
	set v(b) $newB
	set v(c) $newC
    }
}

proc applyArrowShape {} {
  global Graphics demo_arrowInfo
  set Graphics(arrowshape) \
      [list $demo_arrowInfo(a) $demo_arrowInfo(b) $demo_arrowInfo(c)]
  grab release .arrowshape
  destroy .arrowshape
  Message "I hope you like your new arrow shape?"
}