1# 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$ 5 6catch {destroy .t} 7toplevel .t 8wm title .t "Visual Tests for Canvas Arcs" 9wm iconname .t "Arcs" 10wm geom .t +0+0 11wm minsize .t 1 1 12 13canvas .t.c -width 650 -height 600 -relief raised 14pack .t.c -expand yes -fill both 15button .t.quit -text Quit -command {destroy .t} 16pack .t.quit -side bottom -pady 3 -ipadx 4 -ipady 2 17 18puts "depth is [winfo depth .t]" 19if {[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} 30set 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 69bind .t.c <1> {markarea %x %y} 70bind .t.c <B1-Motion> {strokearea %x %y} 71 72proc markarea {x y} { 73 global areaX1 areaY1 74 set areaX1 $x 75 set areaY1 $y 76} 77 78proc 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 89bind .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 94bind .t.c <3> {puts stdout "%x %y"} 95 96# The code below allows the circle to be move by shift-dragging. 97 98bind .t.c <Shift-1> { 99 set curx %x 100 set cury %y 101} 102 103bind .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 111bind .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 118proc c {option value} {.t.c itemconf 2 $option $value} 119 120bind .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 138bind .t.c b {set go 0} 139 140bind .t.c <Control-x> {.t.c delete current} 141 142 143 144 145 146 147 148 149 150 151 152 153 154