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