util/src/TclTk/tk8.6.12/library/demos/arrow.tcl

   1 # arrow.tcl --
   2 #
   3 # This demonstration script creates a canvas widget that displays a
   4 # large line with an arrowhead whose shape can be edited interactively.
   5
   6 if {![info exists widgetDemo]} {
   7     error "This script should be run from the \"widget\" demo."
   8 }
   9
  10 package require Tk
  11
  12 # arrowSetup --
  13 # This procedure regenerates all the text and graphics in the canvas
  14 # window.  It's called when the canvas is initially created, and also
  15 # whenever any of the parameters of the arrow head are changed
  16 # interactively.
  17 #
  18 # Arguments:
  19 # c -           Name of the canvas widget.
  20
  21 proc arrowSetup c {
  22     upvar #0 demo_arrowInfo v
  23
  24     # Remember the current box, if there is one.
  25
  26     set tags [$c gettags current]
  27     if {$tags != ""} {
  28         set cur [lindex $tags [lsearch -glob $tags box?]]
  29     } else {
  30         set cur ""
  31     }
  32
  33     # Create the arrow and outline.
  34
  35     $c delete all
  36     eval {$c create line $v(x1) $v(y) $v(x2) $v(y)  -arrow last \
  37             -width [expr {10*$v(width)}] -arrowshape [list \
  38             [expr {10*$v(a)}] [expr {10*$v(b)}] [expr {10*$v(c)}]]} \
  39             $v(bigLineStyle)
  40     set xtip [expr {$v(x2)-10*$v(b)}]
  41     set deltaY [expr {10*$v(c)+5*$v(width)}]
  42     $c create line $v(x2) $v(y) $xtip [expr {$v(y)+$deltaY}] \
  43             [expr {$v(x2)-10*$v(a)}] $v(y) $xtip [expr {$v(y)-$deltaY}] \
  44             $v(x2) $v(y) -width 2 -capstyle round -joinstyle round
  45
  46     # Create the boxes for reshaping the line and arrowhead.
  47
  48     eval {$c create rect [expr {$v(x2)-10*$v(a)-5}] [expr {$v(y)-5}] \
  49             [expr {$v(x2)-10*$v(a)+5}] [expr {$v(y)+5}] \
  50             -tags {box1 box}} $v(boxStyle)
  51     eval {$c create rect [expr {$xtip-5}] [expr {$v(y)-$deltaY-5}] \
  52             [expr {$xtip+5}] [expr {$v(y)-$deltaY+5}] \
  53             -tags {box2 box}} $v(boxStyle)
  54     eval {$c create rect [expr {$v(x1)-5}] [expr {$v(y)-5*$v(width)-5}] \
  55             [expr {$v(x1)+5}] [expr {$v(y)-5*$v(width)+5}] \
  56             -tags {box3 box}} $v(boxStyle)
  57     if {$cur != ""} {
  58         eval $c itemconfigure $cur $v(activeStyle)
  59     }
  60
  61     # Create three arrows in actual size with the same parameters
  62
  63     $c create line [expr {$v(x2)+50}] 0 [expr {$v(x2)+50}] 1000 \
  64             -width 2
  65     set tmp [expr {$v(x2)+100}]
  66     $c create line $tmp [expr {$v(y)-125}] $tmp [expr {$v(y)-75}] \
  67             -width $v(width) \
  68             -arrow both -arrowshape "$v(a) $v(b) $v(c)"
  69     $c create line [expr {$tmp-25}] $v(y) [expr {$tmp+25}] $v(y) \
  70             -width $v(width) \
  71             -arrow both -arrowshape "$v(a) $v(b) $v(c)"
  72     $c create line [expr {$tmp-25}] [expr {$v(y)+75}] [expr {$tmp+25}] \
  73             [expr {$v(y)+125}] -width $v(width) \
  74             -arrow both -arrowshape "$v(a) $v(b) $v(c)"
  75
  76     # Create a bunch of other arrows and text items showing the
  77     # current dimensions.
  78
  79     set tmp [expr {$v(x2)+10}]
  80     $c create line $tmp [expr {$v(y)-5*$v(width)}] \
  81             $tmp [expr {$v(y)-$deltaY}] \
  82             -arrow both -arrowshape $v(smallTips)
  83     $c create text [expr {$v(x2)+15}] [expr {$v(y)-$deltaY+5*$v(c)}] \
  84             -text $v(c) -anchor w
  85     set tmp [expr {$v(x1)-10}]
  86     $c create line $tmp [expr {$v(y)-5*$v(width)}] \
  87             $tmp [expr {$v(y)+5*$v(width)}] \
  88             -arrow both -arrowshape $v(smallTips)
  89     $c create text [expr {$v(x1)-15}] $v(y) -text $v(width) -anchor e
  90     set tmp [expr {$v(y)+5*$v(width)+10*$v(c)+10}]
  91     $c create line [expr {$v(x2)-10*$v(a)}] $tmp $v(x2) $tmp \
  92             -arrow both -arrowshape $v(smallTips)
  93     $c create text [expr {$v(x2)-5*$v(a)}] [expr {$tmp+5}] \
  94             -text $v(a) -anchor n
  95     set tmp [expr {$tmp+25}]
  96     $c create line [expr {$v(x2)-10*$v(b)}] $tmp $v(x2) $tmp \
  97             -arrow both -arrowshape $v(smallTips)
  98     $c create text [expr {$v(x2)-5*$v(b)}] [expr {$tmp+5}] \
  99             -text $v(b) -anchor n
 100
 101     $c create text $v(x1) 310 -text "-width  $v(width)" \
 102             -anchor w -font {Helvetica 18}
 103     $c create text $v(x1) 330 -text "-arrowshape  {$v(a)  $v(b)  $v(c)}" \
 104             -anchor w -font {Helvetica 18}
 105
 106     incr v(count)
 107 }
 108
 109 set w .arrow
 110 catch {destroy $w}
 111 toplevel $w
 112 wm title $w "Arrowhead Editor Demonstration"
 113 wm iconname $w "arrow"
 114 positionWindow $w
 115 set c $w.c
 116
 117 label $w.msg -font $font -wraplength 5i -justify left -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 canvas line item."
 118 pack $w.msg -side top
 119
 120 ## See Code / Dismiss buttons
 121 set btns [addSeeDismiss $w.buttons $w]
 122 pack $btns -side bottom -fill x
 123
 124 canvas $c -width 500 -height 350 -relief sunken -borderwidth 2
 125 pack $c -expand yes -fill both
 126
 127 set demo_arrowInfo(a) 8
 128 set demo_arrowInfo(b) 10
 129 set demo_arrowInfo(c) 3
 130 set demo_arrowInfo(width) 2
 131 set demo_arrowInfo(motionProc) arrowMoveNull
 132 set demo_arrowInfo(x1) 40
 133 set demo_arrowInfo(x2) 350
 134 set demo_arrowInfo(y) 150
 135 set demo_arrowInfo(smallTips) {5 5 2}
 136 set demo_arrowInfo(count) 0
 137 if {[winfo depth $c] > 1} {
 138     if {[tk windowingsystem] eq "aqua"} {
 139         set demo_arrowInfo(bigLineStyle) "-fill systemSelectedTextBackgroundColor"
 140     } else {
 141         set demo_arrowInfo(bigLineStyle) "-fill LightSeaGreen"
 142     }
 143     set demo_arrowInfo(boxStyle) "-fill {} -width 1"
 144     set demo_arrowInfo(activeStyle) "-fill red -width 1"
 145 } else {
 146     # Main widget program sets variable tk_demoDirectory
 147     set demo_arrowInfo(bigLineStyle) "-fill black \
 148         -stipple @[file join $tk_demoDirectory images grey.25]"
 149     set demo_arrowInfo(boxStyle) "-fill {} -outline black -width 1"
 150     set demo_arrowInfo(activeStyle) "-fill black -outline black -width 1"
 151 }
 152 arrowSetup $c
 153 $c bind box <Enter> "$c itemconfigure current $demo_arrowInfo(activeStyle)"
 154 $c bind box <Leave> "$c itemconfigure current $demo_arrowInfo(boxStyle)"
 155 $c bind box <B1-Enter> " "
 156 $c bind box <B1-Leave> " "
 157 $c bind box1 <Button-1> {set demo_arrowInfo(motionProc) arrowMove1}
 158 $c bind box2 <Button-1> {set demo_arrowInfo(motionProc) arrowMove2}
 159 $c bind box3 <Button-1> {set demo_arrowInfo(motionProc) arrowMove3}
 160 $c bind box <B1-Motion> "\$demo_arrowInfo(motionProc) $c %x %y"
 161 bind $c <ButtonRelease-1> "arrowSetup $c"
 162
 163 # arrowMove1 --
 164 # This procedure is called for each mouse motion event on box1 (the
 165 # one at the vertex of the arrow).  It updates the controlling parameters
 166 # for the line and arrowhead.
 167 #
 168 # Arguments:
 169 # c -           The name of the canvas window.
 170 # x, y -        The coordinates of the mouse.
 171
 172 proc arrowMove1 {c x y} {
 173     upvar #0 demo_arrowInfo v
 174     set newA [expr {($v(x2)+5-round([$c canvasx $x]))/10}]
 175     if {$newA < 0} {
 176         set newA 0
 177     }
 178     if {$newA > 25} {
 179         set newA 25
 180     }
 181     if {$newA != $v(a)} {
 182         $c move box1 [expr {10*($v(a)-$newA)}] 0
 183         set v(a) $newA
 184     }
 185 }
 186
 187 # arrowMove2 --
 188 # This procedure is called for each mouse motion event on box2 (the
 189 # one at the trailing tip of the arrowhead).  It updates the controlling
 190 # parameters for the line and arrowhead.
 191 #
 192 # Arguments:
 193 # c -           The name of the canvas window.
 194 # x, y -        The coordinates of the mouse.
 195
 196 proc arrowMove2 {c x y} {
 197     upvar #0 demo_arrowInfo v
 198     set newB [expr {($v(x2)+5-round([$c canvasx $x]))/10}]
 199     if {$newB < 0} {
 200         set newB 0
 201     }
 202     if {$newB > 25} {
 203         set newB 25
 204     }
 205     set newC [expr {($v(y)+5-round([$c canvasy $y])-5*$v(width))/10}]
 206     if {$newC < 0} {
 207         set newC 0
 208     }
 209     if {$newC > 20} {
 210         set newC 20
 211     }
 212     if {($newB != $v(b)) || ($newC != $v(c))} {
 213         $c move box2 [expr {10*($v(b)-$newB)}] [expr {10*($v(c)-$newC)}]
 214         set v(b) $newB
 215         set v(c) $newC
 216     }
 217 }
 218
 219 # arrowMove3 --
 220 # This procedure is called for each mouse motion event on box3 (the
 221 # one that controls the thickness of the line).  It updates the
 222 # controlling parameters for the line and arrowhead.
 223 #
 224 # Arguments:
 225 # c -           The name of the canvas window.
 226 # x, y -        The coordinates of the mouse.
 227
 228 proc arrowMove3 {c x y} {
 229     upvar #0 demo_arrowInfo v
 230     set newWidth [expr {($v(y)+2-round([$c canvasy $y]))/5}]
 231     if {$newWidth < 0} {
 232         set newWidth 0
 233     }
 234     if {$newWidth > 20} {
 235         set newWidth 20
 236     }
 237     if {$newWidth != $v(width)} {
 238         $c move box3 0 [expr {5*($v(width)-$newWidth)}]
 239         set v(width) $newWidth
 240     }
 241 }