blob: 43153616293eacd0e6fd8c2ad6beb6d7dcea1458 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
|
# This file creates a visual test for arcs. It is part of the Tk
# visual test suite, which is invoked via the "visual" script.
#
# RCS: @(#) $Id: arc.tcl,v 1.3 1999/04/16 01:51:33 stanton Exp $
catch {destroy .t}
toplevel .t
wm title .t "Visual Tests for Canvas Arcs"
wm iconname .t "Arcs"
wm geom .t +0+0
wm minsize .t 1 1
canvas .t.c -width 650 -height 600 -relief raised
pack .t.c -expand yes -fill both
button .t.quit -text Quit -command {destroy .t}
pack .t.quit -side bottom -pady 3 -ipadx 4 -ipady 2
puts "depth is [winfo depth .t]"
if {[winfo depth .t] > 1} {
set fill1 aquamarine3
set fill2 aquamarine3
set fill3 IndianRed1
set outline2 IndianRed3
} else {
set fill1 black
set fill2 white
set fill3 Black
set outline2 white
}
set outline black
.t.c create arc 20 20 220 120 -start 30 -extent 270 -outline $fill1 -width 14 \
-style arc
.t.c create arc 260 20 460 120 -start 30 -extent 270 -fill $fill2 -width 14 \
-style chord -outline $outline
.t.c create arc 500 20 620 160 -start 30 -extent 270 -fill {} -width 14 \
-style chord -outline $outline -outlinestipple gray50
.t.c create arc 20 260 140 460 -start 45 -extent 90 -fill $fill2 -width 14 \
-style pieslice -outline $outline
.t.c create arc 180 260 300 460 -start 45 -extent 90 -fill {} -width 14 \
-style pieslice -outline $outline
.t.c create arc 340 260 460 460 -start 30 -extent 150 -fill $fill2 -width 14 \
-style chord -outline $outline -stipple gray50 -outlinestipple gray25
.t.c create arc 500 260 620 460 -start 30 -extent 150 -fill {} -width 14 \
-style chord -outline $outline
.t.c create arc 20 450 140 570 -start 135 -extent 270 -fill $fill1 -width 14 \
-style pieslice -outline {}
.t.c create arc 180 450 300 570 -start 30 -extent -90 -fill $fill1 -width 14 \
-style pieslice -outline {}
.t.c create arc 340 450 460 570 -start 320 -extent 270 -fill $fill1 -width 14 \
-style chord -outline {}
.t.c create arc 500 450 620 570 -start 350 -extent -110 -fill $fill1 -width 14 \
-style chord -outline {}
.t.c addtag arc withtag all
.t.c addtag circle withtag [.t.c create oval 320 200 340 220 -fill MistyRose3]
.t.c bind arc <Any-Enter> {
set prevFill [lindex [.t.c itemconf current -fill] 4]
set prevOutline [lindex [.t.c itemconf current -outline] 4]
if {($prevFill != "") || ($prevOutline == "")} {
.t.c itemconf current -fill $fill3
}
if {$prevOutline != ""} {
.t.c itemconf current -outline $outline2
}
}
.t.c bind arc <Any-Leave> {.t.c itemconf current -fill $prevFill -outline $prevOutline}
bind .t.c <1> {markarea %x %y}
bind .t.c <B1-Motion> {strokearea %x %y}
proc markarea {x y} {
global areaX1 areaY1
set areaX1 $x
set areaY1 $y
}
proc strokearea {x y} {
global areaX1 areaY1 areaX2 areaY2
if {($areaX1 != $x) && ($areaY1 != $y)} {
.t.c delete area
.t.c addtag area withtag [.t.c create rect $areaX1 $areaY1 $x $y \
-outline black]
set areaX2 $x
set areaY2 $y
}
}
bind .t.c <Control-f> {
puts stdout "Enclosed: [.t.c find enclosed $areaX1 $areaY1 $areaX2 $areaY2]"
puts stdout "Overlapping: [.t.c find overl $areaX1 $areaY1 $areaX2 $areaY2]"
}
bind .t.c <3> {puts stdout "%x %y"}
# The code below allows the circle to be move by shift-dragging.
bind .t.c <Shift-1> {
set curx %x
set cury %y
}
bind .t.c <Shift-B1-Motion> {
.t.c move circle [expr %x-$curx] [expr %y-$cury]
set curx %x
set cury %y
}
# The binding below flashes the closest item to the mouse.
bind .t.c <Control-c> {
set closest [.t.c find closest %x %y]
set oldfill [lindex [.t.c itemconf $closest -fill] 4]
.t.c itemconf $closest -fill IndianRed1
after 200 [list .t.c itemconfig $closest -fill $oldfill]
}
proc c {option value} {.t.c itemconf 2 $option $value}
bind .t.c a {
set go 1
set i 1
while {$go} {
if {$i >= 50} {
set delta -5
}
if {$i <= 5} {
set delta 5
}
incr i $delta
c -start $i
c -extent [expr 360-2*$i]
after 20
update
}
}
bind .t.c b {set go 0}
bind .t.c <Control-x> {.t.c delete current}
|
