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