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