3 # Create a top-level window containing a canvas that displays the
4 # various item types and allows them to be selected and moved. This
5 # demo can be used to test out the point-hit and rectangle-hit code
9 # w - Name to use for new top-level window.
11 proc mkItems
{{w .citems
}} {
16 wm title
$w "Canvas Item Demonstration"
17 wm iconname
$w "Items"
21 frame $w.frame1
-relief raised
-bd 2
22 frame $w.frame2
-relief raised
-bd 2
23 button $w.ok
-text "OK" -command "destroy $w"
24 pack append $w $w.frame1
{top fill
} $w.frame2
{top fill expand
} \
25 $w.ok
{bottom pady
10 frame center
}
26 message $w.frame1.m
-font -Adobe-Times
-Medium
-R
-Normal
-*-180-* -aspect 300 \
27 -text "This window contains a canvas widget with examples of the various kinds of items supported by canvases. The following operations are supported:\n Button-1 drag:\tmoves item under pointer.\n Button-2 drag:\trepositions view.\n Button-3 drag:\tstrokes out area.\n Ctrl+f:\t\tprints items under area."
28 pack append $w.frame1
$w.frame1.m
{frame center
}
30 canvas $c -scrollregion {0c
0c
30c
24c
} -width 15c
-height 10c
31 scrollbar $w.frame2.vscroll
-relief sunken
-command "$c yview"
32 scrollbar $w.frame2.hscroll
-orient horiz
-relief sunken
-command "$c xview"
33 pack append $w.frame2
$w.frame2.hscroll
{bottom fillx
} \
34 $w.frame2.vscroll
{right filly
} $c {expand fill
}
35 $c config
-xscroll "$w.frame2.hscroll set" -yscroll "$w.frame2.vscroll set"
37 # Display a 3x3 rectangular grid.
39 $c create rect
0c
0c
30c
24c
-width 2
40 $c create line
0c
8c
30c
8c
-width 2
41 $c create line
0c
16c
30c
16c
-width 2
42 $c create line
10c
0c
10c
24c
-width 2
43 $c create line
20c
0c
20c
24c
-width 2
45 set font1
-Adobe-Helvetica
-Medium
-R
-Normal
-*-120-*
46 set font2
-Adobe-Helvetica
-Bold
-R
-Normal
-*-240-*
47 if {[winfo screendepth
$c] > 4} {
59 # Set up demos within each of the areas of the grid.
61 $c create
text 5c
.2c
-text Lines
-anchor n
62 $c create line
1c
1c
3c
1c
1c
4c
3c
4c
-width 2m
-fill $blue \
63 -cap butt
-join miter
-tags item
64 $c create line
4.67c
1c
4.67c
4c
-arrow last
-tags item
65 $c create line
6.33c
1c
6.33c
4c
-arrow both
-tags item
66 $c create line
5c
6c
9c
6c
9c
1c
8c
1c
8c
4.8c
8.8c
4.8c
8.8c
1.2c
\
67 8.2c
1.2c
8.2c
4.6c
8.6c
4.6c
8.6c
1.4c
8.4c
1.4c
8.4c
4.4c
\
68 -width 3 -fill $red -tags item
69 $c create line
1c
5c
7c
5c
7c
7c
9c
7c
-width .5c
\
70 -stipple @$tk_library/demos
/bitmaps
/grey
.25 \
71 -arrow both
-arrowshape {15 15 7} -tags item
72 $c create line
1c
7c
1.75c
5.8c
2.5c
7c
3.25c
5.8c
4c
7c
-width .5c
\
73 -cap round
-join round
-tags item
75 $c create
text 15c
.2c
-text "Curves (smoothed lines)" -anchor n
76 $c create line
11c
4c
11.5c
1c
13.5c
1c
14c
4c
-smooth on
\
77 -fill $blue -tags item
78 $c create line
15.5c
1c
19.5c
1.5c
15.5c
4.5c
19.5c
4c
-smooth on
\
79 -arrow both
-width 3 -tags item
80 $c create line
12c
6c
13.5c
4.5c
16.5c
7.5c
18c
6c
\
81 16.5c
4.5c
13.5c
7.5c
12c
6c
-smooth on
-width 3m
-cap round
\
82 -stipple @$tk_library/demos
/bitmaps
/grey
.25 -fill $red -tags item
84 $c create
text 25c
.2c
-text Polygons
-anchor n
85 $c create polygon
21c
1.0c
22.5c
1.75c
24c
1.0c
23.25c
2.5c
\
86 24c
4.0c
22.5c
3.25c
21c
4.0c
21.75c
2.5c
-fill $green -tags item
87 $c create polygon
25c
4c
25c
4c
25c
1c
26c
1c
27c
4c
28c
1c
\
88 29c
1c
29c
4c
29c
4c
-fill $red -smooth on
-tags item
89 $c create polygon
22c
4.5c
25c
4.5c
25c
6.75c
28c
6.75c
\
90 28c
5.25c
24c
5.25c
24c
6.0c
26c
6c
26c
7.5c
22c
7.5c
\
91 -stipple @$tk_library/demos
/bitmaps
/grey
.25 -tags item
93 $c create
text 5c
8.2c
-text Rectangles
-anchor n
94 $c create rectangle
1c
9.5c
4c
12.5c
-outline $red -width 3m
-tags item
95 $c create rectangle
0.5c
13.5c
4.5c
15.5c
-fill $green -tags item
96 $c create rectangle
6c
10c
9c
15c
-outline {} \
97 -stipple @$tk_library/demos
/bitmaps
/grey
.25 -fill $blue -tags item
99 $c create
text 15c
8.2c
-text Ovals
-anchor n
100 $c create oval
11c
9.5c
14c
12.5c
-outline $red -width 3m
-tags item
101 $c create oval
10.5c
13.5c
14.5c
15.5c
-fill $green -tags item
102 $c create oval
16c
10c
19c
15c
-outline {} \
103 -stipple @$tk_library/demos
/bitmaps
/grey
.25 -fill $blue -tags item
105 $c create
text 25c
8.2c
-text Text
-anchor n
106 $c create rectangle
22.4c
8.9c
22.6c
9.1c
107 $c create
text 22.5c
9c
-anchor n
-font $font1 -width 4c
\
108 -text "A short string of text, word-wrapped, justified left, and anchored north (at the top). The rectangles show the anchor points for each piece of text." -tags item
109 $c create rectangle
25.4c
10.9c
25.6c
11.1c
110 $c create
text 25.5c
11c
-anchor w
-font $font1 -fill $blue \
111 -text "Several lines,\n each centered\nindividually,\nand all anchored\nat the left edge." \
112 -justify center
-tags item
113 $c create rectangle
24.9c
13.9c
25.1c
14.1c
114 $c create
text 25c
14c
-font $font2 -anchor c
-fill $red \
115 -stipple @$tk_library/demos
/bitmaps
/grey
.5 \
116 -text "Stippled characters" -tags item
118 $c create
text 5c
16.2c
-text Arcs
-anchor n
119 $c create arc
0.5c
17c
7c
20c
-fill $green -outline black
\
120 -start 45 -extent 270 -style pieslice
-tags item
121 $c create arc
6.5c
17c
9.5c
20c
-width 4m
-style arc
\
122 -fill $blue -start -135 -extent 270 \
123 -stipple @$tk_library/demos
/bitmaps
/grey
.25 -tags item
124 $c create arc
0.5c
20c
9.5c
24c
-width 4m
-style pieslice
\
125 -fill {} -outline $red -start 225 -extent -90 -tags item
126 $c create arc
5.5c
20.5c
9.5c
23.5c
-width 4m
-style chord
\
127 -fill $blue -outline {} -start 45 -extent 270 -tags item
129 $c create
text 15c
16.2c
-text Bitmaps
-anchor n
130 $c create
bitmap 13c
20c
-bitmap @$tk_library/demos
/bitmaps
/face
-tags item
131 $c create
bitmap 17c
18.5c
\
132 -bitmap @$tk_library/demos
/bitmaps
/noletters
-tags item
133 $c create
bitmap 17c
21.5c
\
134 -bitmap @$tk_library/demos
/bitmaps
/letters
-tags item
136 $c create
text 25c
16.2c
-text Windows
-anchor n
137 button $c.
button -text "Press Me" -command "butPress $c $red"
138 $c create window
21c
18c
-window $c.
button -anchor nw
-tags item
139 entry $c.
entry -width 20 -relief sunken
140 $c.
entry insert end
"Edit this text"
141 $c create window
21c
21c
-window $c.
entry -anchor nw
-tags item
142 scale $c.
scale -from 0 -to 100 -length 6c
-sliderlength .4c
\
143 -width .5c
-tickinterval 0
144 $c create window
28.5c
17.5c
-window $c.
scale -anchor n
-tags item
145 $c create
text 21c
17.9c
-text Button
: -anchor sw
146 $c create
text 21c
20.9c
-text Entry
: -anchor sw
147 $c create
text 28.5c
17.4c
-text Scale
: -anchor s
149 # Set up event bindings for canvas:
151 $c bind item
<Any-Enter
> "itemEnter $c"
152 $c bind item
<Any-Leave
> "itemLeave $c"
153 bind $c <2> "$c scan mark %x %y"
154 bind $c <B2-Motion
> "$c scan dragto %x %y"
155 bind $c <3> "itemMark $c %x %y"
156 bind $c <B3-Motion
> "itemStroke $c %x %y"
157 bind $c <Control-f
> "itemsUnderArea $c"
158 bind $c <1> "itemStartDrag $c %x %y"
159 bind $c <B1-Motion
> "itemDrag $c %x %y"
160 bind $w <Any-Enter
> "focus $c"
163 # Utility procedures for highlighting the item under the pointer:
168 if {[winfo screendepth
$c] <= 4} {
172 set type
[$c type current
]
173 if {$type == "window"} {
177 if {$type == "bitmap"} {
178 set bg
[lindex [$c itemconf current
-background] 4]
179 set restoreCmd
[list $c itemconfig current
-background $bg]
180 $c itemconfig current
-background SteelBlue2
183 set fill
[lindex [$c itemconfig current
-fill] 4]
184 if {(($type == "rectangle") ||
($type == "oval") ||
($type == "arc"))
186 set outline
[lindex [$c itemconfig current
-outline] 4]
187 set restoreCmd
"$c itemconfig current -outline $outline"
188 $c itemconfig current
-outline SteelBlue2
190 set restoreCmd
"$c itemconfig current -fill $fill"
191 $c itemconfig current
-fill SteelBlue2
201 # Utility procedures for stroking out a rectangle and printing what's
202 # underneath the rectangle's area.
204 proc itemMark
{c x y
} {
206 set areaX1
[$c canvasx
$x]
207 set areaY1
[$c canvasy
$y]
211 proc itemStroke
{c x y
} {
212 global areaX1 areaY1 areaX2 areaY2
213 set x
[$c canvasx
$x]
214 set y
[$c canvasy
$y]
215 if {($areaX1 != $x) && ($areaY1 != $y)} {
217 $c addtag area withtag
[$c create rect
$areaX1 $areaY1 $x $y \
224 proc itemsUnderArea
{c
} {
225 global areaX1 areaY1 areaX2 areaY2
226 set area
[$c find withtag area
]
228 foreach i
[$c find enclosed
$areaX1 $areaY1 $areaX2 $areaY2] {
229 if {[lsearch [$c gettags
$i] item
] != -1} {
233 puts stdout
"Items enclosed by area: $items"
235 foreach i
[$c find overlapping
$areaX1 $areaY1 $areaX2 $areaY2] {
236 if {[lsearch [$c gettags
$i] item
] != -1} {
240 puts stdout
"Items overlapping area: $items"
248 # Utility procedures to support dragging of items.
250 proc itemStartDrag
{c x y
} {
252 set lastX
[$c canvasx
$x]
253 set lastY
[$c canvasy
$y]
256 proc itemDrag
{c x y
} {
258 set x
[$c canvasx
$x]
259 set y
[$c canvasy
$y]
260 $c move current
[expr $x-$lastX] [expr $y-$lastY]
265 # Procedure that's invoked when the button embedded in the canvas
268 proc butPress
{w color
} {
269 set i
[$w create
text 25c
18.1c
-text "Ouch!!" -fill $color -anchor n
]
270 after 500 "$w delete $i"