]> git.zerfleddert.de Git - micropolis/blob - src/tk/library/demos/mkArrow.tcl
add simple Makefile in top directory
[micropolis] / src / tk / library / demos / mkArrow.tcl
1 # mkArrow w
2 #
3 # Create a top-level window containing a canvas demonstration that
4 # allows the user to experiment with arrow shapes.
5 #
6 # Arguments:
7 # w - Name to use for new top-level window.
8
9 # This file implements a canvas widget that displays a large line with
10 # an arrowhead and allows the shape of the arrowhead to be edited
11 # interactively. The only procedure that should be invoked from outside
12 # the file is the first one, which creates the canvas.
13
14 proc mkArrow {{w .arrow}} {
15 global tk_library
16 upvar #0 demo_arrowInfo v
17 catch {destroy $w}
18 toplevel $w
19 dpos $w
20 wm title $w "Arrowhead Editor Demonstration"
21 wm iconname $w "Arrow"
22 set c $w.c
23
24 frame $w.frame1 -relief raised -bd 2
25 canvas $c -width 500 -height 350 -relief raised
26 button $w.ok -text "OK" -command "destroy $w"
27 pack append $w $w.frame1 {top fill} $w.ok {bottom pady 10 frame center} \
28 $c {expand fill}
29 message $w.frame1.m -font -Adobe-Times-Medium-R-Normal-*-180-* -aspect 300 \
30 -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 line."
31 pack append $w.frame1 $w.frame1.m {frame center}
32
33
34 set v(a) 8
35 set v(b) 10
36 set v(c) 3
37 set v(width) 2
38 set v(motionProc) arrowMoveNull
39 set v(x1) 40
40 set v(x2) 350
41 set v(y) 150
42 set v(smallTips) {5 5 2}
43 set v(count) 0
44 if {[winfo screendepth $c] > 4} {
45 set v(bigLineStyle) "-fill SkyBlue1"
46 set v(boxStyle) "-fill {} -outline black -width 1"
47 set v(activeStyle) "-fill red -outline black -width 1"
48 } else {
49 set v(bigLineStyle) "-fill black -stipple @$tk_library/demos/bitmaps/grey.25"
50 set v(boxStyle) "-fill {} -outline black -width 1"
51 set v(activeStyle) "-fill black -outline black -width 1"
52 }
53 arrowSetup $c
54 $c bind box <Enter> "$c itemconfigure current $v(activeStyle)"
55 $c bind box <Leave> "$c itemconfigure current $v(boxStyle)"
56 $c bind box1 <1> {set demo_arrowInfo(motionProc) arrowMove1}
57 $c bind box2 <1> {set demo_arrowInfo(motionProc) arrowMove2}
58 $c bind box3 <1> {set demo_arrowInfo(motionProc) arrowMove3}
59 $c bind box <B1-Motion> "\$demo_arrowInfo(motionProc) $c %x %y"
60 bind $c <Any-ButtonRelease-1> "arrowSetup $c"
61 }
62
63 # The procedure below completely regenerates all the text and graphics
64 # in the canvas window. It's called when the canvas is initially created,
65 # and also whenever any of the parameters of the arrow head are changed
66 # interactively. The argument is the name of the canvas widget to be
67 # regenerated, and also the name of a global variable containing the
68 # parameters for the display.
69
70 proc arrowSetup c {
71 upvar #0 demo_arrowInfo v
72 $c delete all
73
74 # Create the arrow and outline.
75
76 eval "$c create line $v(x1) $v(y) $v(x2) $v(y) -width [expr 10*$v(width)] \
77 -arrowshape {[expr 10*$v(a)] [expr 10*$v(b)] [expr 10*$v(c)]} \
78 -arrow last $v(bigLineStyle)"
79 set xtip [expr $v(x2)-10*$v(b)]
80 set deltaY [expr 10*$v(c)+5*$v(width)]
81 $c create line $v(x2) $v(y) $xtip [expr $v(y)+$deltaY] \
82 [expr $v(x2)-10*$v(a)] $v(y) $xtip [expr $v(y)-$deltaY] \
83 $v(x2) $v(y) -width 2 -capstyle round -joinstyle round
84
85 # Create the boxes for reshaping the line and arrowhead.
86
87 eval "$c create rect [expr $v(x2)-10*$v(a)-5] [expr $v(y)-5] \
88 [expr $v(x2)-10*$v(a)+5] [expr $v(y)+5] $v(boxStyle) \
89 -tags {box1 box}"
90 eval "$c create rect [expr $xtip-5] [expr $v(y)-$deltaY-5] \
91 [expr $xtip+5] [expr $v(y)-$deltaY+5] $v(boxStyle) \
92 -tags {box2 box}"
93 eval "$c create rect [expr $v(x1)-5] [expr $v(y)-5*$v(width)-5] \
94 [expr $v(x1)+5] [expr $v(y)-5*$v(width)+5] $v(boxStyle) \
95 -tags {box3 box}"
96
97 # Create three arrows in actual size with the same parameters
98
99 $c create line [expr $v(x2)+50] 0 [expr $v(x2)+50] 1000 \
100 -width 2
101 set tmp [expr $v(x2)+100]
102 $c create line $tmp [expr $v(y)-125] $tmp [expr $v(y)-75] \
103 -width $v(width) \
104 -arrow both -arrowshape "$v(a) $v(b) $v(c)"
105 $c create line [expr $tmp-25] $v(y) [expr $tmp+25] $v(y) \
106 -width $v(width) \
107 -arrow both -arrowshape "$v(a) $v(b) $v(c)"
108 $c create line [expr $tmp-25] [expr $v(y)+75] [expr $tmp+25] \
109 [expr $v(y)+125] -width $v(width) \
110 -arrow both -arrowshape "$v(a) $v(b) $v(c)"
111
112 # Create a bunch of other arrows and text items showing the
113 # current dimensions.
114
115 set tmp [expr $v(x2)+10]
116 $c create line $tmp [expr $v(y)-5*$v(width)] \
117 $tmp [expr $v(y)-$deltaY] \
118 -arrow both -arrowshape $v(smallTips)
119 $c create text [expr $v(x2)+15] [expr $v(y)-$deltaY+5*$v(c)] \
120 -text $v(c) -anchor w
121 set tmp [expr $v(x1)-10]
122 $c create line $tmp [expr $v(y)-5*$v(width)] \
123 $tmp [expr $v(y)+5*$v(width)] \
124 -arrow both -arrowshape $v(smallTips)
125 $c create text [expr $v(x1)-15] $v(y) -text $v(width) -anchor e
126 set tmp [expr $v(y)+5*$v(width)+10*$v(c)+10]
127 $c create line [expr $v(x2)-10*$v(a)] $tmp $v(x2) $tmp \
128 -arrow both -arrowshape $v(smallTips)
129 $c create text [expr $v(x2)-5*$v(a)] [expr $tmp+5] \
130 -text $v(a) -anchor n
131 set tmp [expr $tmp+25]
132 $c create line [expr $v(x2)-10*$v(b)] $tmp $v(x2) $tmp \
133 -arrow both -arrowshape $v(smallTips)
134 $c create text [expr $v(x2)-5*$v(b)] [expr $tmp+5] \
135 -text $v(b) -anchor n
136
137 $c create text $v(x1) 310 -text "-width $v(width)" \
138 -anchor w -font -Adobe-Helvetica-Medium-R-Normal-*-180-*
139 $c create text $v(x1) 330 -text "-arrowshape {$v(a) $v(b) $v(c)}" \
140 -anchor w -font -Adobe-Helvetica-Medium-R-Normal-*-180-*
141
142 incr v(count)
143 }
144
145 # The procedures below are called in response to mouse motion for one
146 # of the three items used to change the line width and arrowhead shape.
147 # Each procedure updates one or more of the controlling parameters
148 # for the line and arrowhead, and recreates the display if that is
149 # needed. The arguments are the name of the canvas widget, and the
150 # x and y positions of the mouse within the widget.
151
152 proc arrowMove1 {c x y} {
153 upvar #0 demo_arrowInfo v
154 set newA [expr ($v(x2)+5-[$c canvasx $x])/10]
155 if {$newA < 1} {
156 set newA 1
157 }
158 if {$newA > 25} {
159 set newA 25
160 }
161 if {$newA != $v(a)} {
162 $c move box1 [expr 10*($v(a)-$newA)] 0
163 set v(a) $newA
164 }
165 }
166
167 proc arrowMove2 {c x y} {
168 upvar #0 demo_arrowInfo v
169 set newB [expr ($v(x2)+5-[$c canvasx $x])/10]
170 if {$newB < 1} {
171 set newB 1
172 }
173 if {$newB > 25} {
174 set newB 25
175 }
176 set newC [expr ($v(y)+5-[$c canvasy $y]-5*$v(width))/10]
177 if {$newC < 1} {
178 set newC 1
179 }
180 if {$newC > 20} {
181 set newC 20
182 }
183 if {($newB != $v(b)) || ($newC != $v(c))} {
184 $c move box2 [expr 10*($v(b)-$newB)] [expr 10*($v(c)-$newC)]
185 set v(b) $newB
186 set v(c) $newC
187 }
188 }
189
190 proc arrowMove3 {c x y} {
191 upvar #0 demo_arrowInfo v
192 set newWidth [expr ($v(y)+5-[$c canvasy $y])/5]
193 if {$newWidth < 1} {
194 set newWidth 1
195 }
196 if {$newWidth > 20} {
197 set newWidth 20
198 }
199 if {$newWidth != $v(width)} {
200 $c move box3 0 [expr 5*($v(width)-$newWidth)]
201 set v(width) $newWidth
202 }
203 }
Impressum, Datenschutz