3 # This demonstration script creates a canvas widget that displays a
4 # large line with an arrowhead whose shape can be edited interactively.
6 # RCS: @(#) $Id: arrow.tcl,v 1.3 2001/06/14 10:56:58 dkf Exp $
8 if {![info exists widgetDemo
]} {
9 error "This script should be run from the \"widget\" demo."
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
19 # c - Name of the canvas widget.
22 upvar #0 demo_arrowInfo v
24 # Remember the current box, if there is one.
26 set tags
[$c gettags current
]
28 set cur
[lindex $tags [lsearch -glob $tags box?
]]
33 # Create the arrow and outline.
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
)}]]} \
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
46 # Create the boxes for reshaping the line and arrowhead.
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
)
58 eval $c itemconfigure
$cur $v(activeStyle
)
61 # Create three arrows in actual size with the same parameters
63 $c create line
[expr {$v(x2
)+50}] 0 [expr {$v(x2
)+50}] 1000 \
65 set tmp
[expr {$v(x2
)+100}]
66 $c create line
$tmp [expr {$v(y
)-125}] $tmp [expr {$v(y
)-75}] \
68 -arrow both
-arrowshape "$v(a) $v(b) $v(c)"
69 $c create line
[expr {$tmp-25}] $v(y
) [expr {$tmp+25}] $v(y
) \
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)"
76 # Create a bunch of other arrows and text items showing the
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
)}] \
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}] \
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}] \
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}
113 wm title
$w "Arrowhead Editor Demonstration"
114 wm iconname
$w "arrow"
118 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."
119 pack $w.msg
-side top
122 pack $w.buttons
-side bottom
-fill x
-pady 2m
123 button $w.buttons.dismiss
-text Dismiss
-command "destroy $w"
124 button $w.buttons.code
-text "See Code" -command "showCode $w"
125 pack $w.buttons.dismiss
$w.buttons.code
-side left
-expand 1
127 canvas $c -width 500 -height 350 -relief sunken
-borderwidth 2
128 pack $c -expand yes
-fill both
130 set demo_arrowInfo
(a
) 8
131 set demo_arrowInfo
(b
) 10
132 set demo_arrowInfo
(c
) 3
133 set demo_arrowInfo
(width
) 2
134 set demo_arrowInfo
(motionProc
) arrowMoveNull
135 set demo_arrowInfo
(x1
) 40
136 set demo_arrowInfo
(x2
) 350
137 set demo_arrowInfo
(y
) 150
138 set demo_arrowInfo
(smallTips
) {5 5 2}
139 set demo_arrowInfo
(count
) 0
140 if {[winfo depth
$c] > 1} {
141 set demo_arrowInfo
(bigLineStyle
) "-fill SkyBlue1"
142 set demo_arrowInfo
(boxStyle
) "-fill {} -outline black -width 1"
143 set demo_arrowInfo
(activeStyle
) "-fill red -outline black -width 1"
145 set demo_arrowInfo
(bigLineStyle
) "-fill black \
146 -stipple @[file join $tk_library demos images grey.25]"
147 set demo_arrowInfo
(boxStyle
) "-fill {} -outline black -width 1"
148 set demo_arrowInfo
(activeStyle
) "-fill black -outline black -width 1"
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"
159 bind $c <Any-ButtonRelease-1
> "arrowSetup $c"
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.
167 # c - The name of the canvas window.
168 # x, y - The coordinates of the mouse.
170 proc arrowMove1
{c x y
} {
171 upvar #0 demo_arrowInfo v
172 set newA
[expr {($v(x2
)+5-round
([$c canvasx
$x]))/10}]
179 if {$newA != $v(a
)} {
180 $c move box1
[expr {10*($v(a
)-$newA)}] 0
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.
191 # c - The name of the canvas window.
192 # x, y - The coordinates of the mouse.
194 proc arrowMove2
{c x y
} {
195 upvar #0 demo_arrowInfo v
196 set newB
[expr {($v(x2
)+5-round
([$c canvasx
$x]))/10}]
203 set newC
[expr {($v(y
)+5-round
([$c canvasy
$y])-5*$v(width
))/10}]
210 if {($newB != $v(b
)) ||
($newC != $v(c
))} {
211 $c move box2
[expr {10*($v(b
)-$newB)}] [expr {10*($v(c
)-$newC)}]
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.
223 # c - The name of the canvas window.
224 # x, y - The coordinates of the mouse.
226 proc arrowMove3
{c x y
} {
227 upvar #0 demo_arrowInfo v
228 set newWidth
[expr {($v(y
)+2-round
([$c canvasy
$y]))/5}]
232 if {$newWidth > 20} {
235 if {$newWidth != $v(width
)} {
236 $c move box3
0 [expr {5*($v(width
)-$newWidth)}]
237 set v
(width
) $newWidth