3 # This demonstration script creates a canvas that displays the
6 if {![info exists widgetDemo
]} {
7 error "This script should be run from the \"widget\" demo."
15 wm title
$w "Canvas Item Demonstration"
16 wm iconname
$w "Items"
20 label $w.msg
-font $font -wraplength 5i
-justify left
-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."
23 ## See Code / Dismiss buttons
24 set btns
[addSeeDismiss
$w.buttons
$w]
25 pack $btns -side bottom
-fill x
28 pack $w.
frame -side top
-fill both
-expand yes
30 canvas $c -scrollregion {0c
0c
30c
24c
} -width 15c
-height 10c
\
31 -relief sunken
-borderwidth 2 \
32 -xscrollcommand "$w.frame.hscroll set" \
33 -yscrollcommand "$w.frame.vscroll set"
34 scrollbar $w.
frame.vscroll
-command "$c yview"
35 scrollbar $w.
frame.hscroll
-orient horiz
-command "$c xview"
37 grid $c -in $w.
frame \
38 -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news
39 grid $w.
frame.vscroll
\
40 -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news
41 grid $w.
frame.hscroll
\
42 -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news
43 grid rowconfig
$w.
frame 0 -weight 1 -minsize 0
44 grid columnconfig
$w.
frame 0 -weight 1 -minsize 0
46 # Display a 3x3 rectangular grid.
48 $c create rect
0c
0c
30c
24c
-width 2
49 $c create line
0c
8c
30c
8c
-width 2
50 $c create line
0c
16c
30c
16c
-width 2
51 $c create line
10c
0c
10c
24c
-width 2
52 $c create line
20c
0c
20c
24c
-width 2
54 set font1
{Helvetica
12}
55 set font2
{Helvetica
24 bold
}
56 if {[winfo depth
$c] > 1} {
68 # Set up demos within each of the areas of the grid.
70 $c create
text 5c
.2c
-text Lines
-anchor n
71 $c create line
1c
1c
3c
1c
1c
4c
3c
4c
-width 2m
-fill $blue \
72 -cap butt
-join miter
-tags item
73 $c create line
4.67c
1c
4.67c
4c
-arrow last
-tags item
74 $c create line
6.33c
1c
6.33c
4c
-arrow both
-tags item
75 $c create line
5c
6c
9c
6c
9c
1c
8c
1c
8c
4.8c
8.8c
4.8c
8.8c
1.2c
\
76 8.2c
1.2c
8.2c
4.6c
8.6c
4.6c
8.6c
1.4c
8.4c
1.4c
8.4c
4.4c
\
77 -width 3 -fill $red -tags item
78 # Main widget program sets variable tk_demoDirectory
79 $c create line
1c
5c
7c
5c
7c
7c
9c
7c
-width .5c
\
80 -stipple @[file join $tk_demoDirectory images gray25.xbm
] \
81 -arrow both
-arrowshape {15 15 7} -tags item
82 $c create line
1c
7c
1.75c
5.8c
2.5c
7c
3.25c
5.8c
4c
7c
-width .5c
\
83 -cap round
-join round
-tags item
85 $c create
text 15c
.2c
-text "Curves (smoothed lines)" -anchor n
86 $c create line
11c
4c
11.5c
1c
13.5c
1c
14c
4c
-smooth on
\
87 -fill $blue -tags item
88 $c create line
15.5c
1c
19.5c
1.5c
15.5c
4.5c
19.5c
4c
-smooth on
\
89 -arrow both
-width 3 -tags item
90 $c create line
12c
6c
13.5c
4.5c
16.5c
7.5c
18c
6c
\
91 16.5c
4.5c
13.5c
7.5c
12c
6c
-smooth on
-width 3m
-cap round
\
92 -stipple @[file join $tk_demoDirectory images gray25.xbm
] \
95 $c create
text 25c
.2c
-text Polygons
-anchor n
96 $c create polygon
21c
1.0c
22.5c
1.75c
24c
1.0c
23.25c
2.5c
\
97 24c
4.0c
22.5c
3.25c
21c
4.0c
21.75c
2.5c
-fill $green \
98 -outline black
-width 4 -tags item
99 $c create polygon
25c
4c
25c
4c
25c
1c
26c
1c
27c
4c
28c
1c
\
100 29c
1c
29c
4c
29c
4c
-fill $red -smooth on
-tags item
101 $c create polygon
22c
4.5c
25c
4.5c
25c
6.75c
28c
6.75c
\
102 28c
5.25c
24c
5.25c
24c
6.0c
26c
6c
26c
7.5c
22c
7.5c
\
103 -stipple @[file join $tk_demoDirectory images gray25.xbm
] \
104 -outline black
-tags item
106 $c create
text 5c
8.2c
-text Rectangles
-anchor n
107 $c create rectangle
1c
9.5c
4c
12.5c
-outline $red -width 3m
-tags item
108 $c create rectangle
0.5c
13.5c
4.5c
15.5c
-fill $green -tags item
109 $c create rectangle
6c
10c
9c
15c
-outline {} \
110 -stipple @[file join $tk_demoDirectory images gray25.xbm
] \
111 -fill $blue -tags item
113 $c create
text 15c
8.2c
-text Ovals
-anchor n
114 $c create oval
11c
9.5c
14c
12.5c
-outline $red -width 3m
-tags item
115 $c create oval
10.5c
13.5c
14.5c
15.5c
-fill $green -tags item
116 $c create oval
16c
10c
19c
15c
-outline {} \
117 -stipple @[file join $tk_demoDirectory images gray25.xbm
] \
118 -fill $blue -tags item
120 $c create
text 25c
8.2c
-text Text
-anchor n
121 $c create rectangle
22.4c
8.9c
22.6c
9.1c
122 $c create
text 22.5c
9c
-anchor n
-font $font1 -width 4c
\
123 -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
124 $c create rectangle
25.4c
10.9c
25.6c
11.1c
125 $c create
text 25.5c
11c
-anchor w
-font $font1 -fill $blue \
126 -text "Several lines,\n each centered\nindividually,\nand all anchored\nat the left edge." \
127 -justify center
-tags item
128 $c create rectangle
24.9c
13.9c
25.1c
14.1c
129 $c create
text 25c
14c
-font $font2 -anchor c
-fill $red -stipple gray50
\
130 -text "Stippled characters" -tags item
132 $c create
text 5c
16.2c
-text Arcs
-anchor n
133 $c create arc
0.5c
17c
7c
20c
-fill $green -outline black
\
134 -start 45 -extent 270 -style pieslice
-tags item
135 $c create arc
6.5c
17c
9.5c
20c
-width 4m
-style arc
\
136 -outline $blue -start -135 -extent 270 -tags item
\
137 -outlinestipple @[file join $tk_demoDirectory images gray25.xbm
]
138 $c create arc
0.5c
20c
9.5c
24c
-width 4m
-style pieslice
\
139 -fill {} -outline $red -start 225 -extent -90 -tags item
140 $c create arc
5.5c
20.5c
9.5c
23.5c
-width 4m
-style chord
\
141 -fill $blue -outline {} -start 45 -extent 270 -tags item
143 $c create
text 15c
16.2c
-text Bitmaps
-anchor n
144 $c create
bitmap 13c
20c
-tags item
\
145 -bitmap @[file join $tk_demoDirectory images face.xbm
]
146 $c create
bitmap 17c
18.5c
-tags item
\
147 -bitmap @[file join $tk_demoDirectory images noletter.xbm
]
148 $c create
bitmap 17c
21.5c
-tags item
\
149 -bitmap @[file join $tk_demoDirectory images letters.xbm
]
151 $c create
text 25c
16.2c
-text Windows
-anchor n
152 button $c.
button -text "Press Me" -command "butPress $c $red"
153 $c create window
21c
18c
-window $c.
button -anchor nw
-tags item
154 entry $c.
entry -width 20 -relief sunken
155 $c.
entry insert end
"Edit this text"
156 $c create window
21c
21c
-window $c.
entry -anchor nw
-tags item
157 scale $c.
scale -from 0 -to 100 -length 6c
-sliderlength .4c
\
158 -width .5c
-tickinterval 0
159 $c create window
28.5c
17.5c
-window $c.
scale -anchor n
-tags item
160 $c create
text 21c
17.9c
-text Button
: -anchor sw
161 $c create
text 21c
20.9c
-text Entry
: -anchor sw
162 $c create
text 28.5c
17.4c
-text Scale
: -anchor s
164 # Set up event bindings for canvas:
166 $c bind item
<Any-Enter
> "itemEnter $c"
167 $c bind item
<Any-Leave
> "itemLeave $c"
168 bind $c <2> "$c scan mark %x %y"
169 bind $c <B2-Motion
> "$c scan dragto %x %y"
170 bind $c <3> "itemMark $c %x %y"
171 bind $c <B3-Motion
> "itemStroke $c %x %y"
172 bind $c <Control-f
> "itemsUnderArea $c"
173 bind $c <1> "itemStartDrag $c %x %y"
174 bind $c <B1-Motion
> "itemDrag $c %x %y"
176 # Utility procedures for highlighting the item under the pointer:
181 if {[winfo depth
$c] == 1} {
185 set type
[$c type current
]
186 if {$type == "window"} {
190 if {$type == "bitmap"} {
191 set bg
[lindex [$c itemconf current
-background] 4]
192 set restoreCmd
[list $c itemconfig current
-background $bg]
193 $c itemconfig current
-background SteelBlue2
196 set fill
[lindex [$c itemconfig current
-fill] 4]
197 if {(($type == "rectangle") ||
($type == "oval") ||
($type == "arc"))
199 set outline
[lindex [$c itemconfig current
-outline] 4]
200 set restoreCmd
"$c itemconfig current -outline $outline"
201 $c itemconfig current
-outline SteelBlue2
203 set restoreCmd
"$c itemconfig current -fill $fill"
204 $c itemconfig current
-fill SteelBlue2
214 # Utility procedures for stroking out a rectangle and printing what's
215 # underneath the rectangle's area.
217 proc itemMark
{c x y
} {
219 set areaX1
[$c canvasx
$x]
220 set areaY1
[$c canvasy
$y]
224 proc itemStroke
{c x y
} {
225 global areaX1 areaY1 areaX2 areaY2
226 set x
[$c canvasx
$x]
227 set y
[$c canvasy
$y]
228 if {($areaX1 != $x) && ($areaY1 != $y)} {
230 $c addtag area withtag
[$c create rect
$areaX1 $areaY1 $x $y \
237 proc itemsUnderArea
{c
} {
238 global areaX1 areaY1 areaX2 areaY2
239 set area
[$c find withtag area
]
241 foreach i
[$c find enclosed
$areaX1 $areaY1 $areaX2 $areaY2] {
242 if {[lsearch [$c gettags
$i] item
] != -1} {
246 puts stdout
"Items enclosed by area: $items"
248 foreach i
[$c find overlapping
$areaX1 $areaY1 $areaX2 $areaY2] {
249 if {[lsearch [$c gettags
$i] item
] != -1} {
253 puts stdout
"Items overlapping area: $items"
261 # Utility procedures to support dragging of items.
263 proc itemStartDrag
{c x y
} {
265 set lastX
[$c canvasx
$x]
266 set lastY
[$c canvasy
$y]
269 proc itemDrag
{c x y
} {
271 set x
[$c canvasx
$x]
272 set y
[$c canvasy
$y]
273 $c move current
[expr {$x-$lastX}] [expr {$y-$lastY}]
278 # Procedure that's invoked when the button embedded in the canvas
281 proc butPress
{w color
} {
282 set i
[$w create
text 25c
18.1c
-text "Ouch!!" -fill $color -anchor n
]
283 after 500 "$w delete $i"