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