# # horoscope pie plotter # loaded on tcl wiki tcl8 # 22may2006, goldshell7 set color 0
proc star {x y color args } { global dx dy
set c5 [lpick {black brown white gray brown3 brown4}]
set c1 [lpick {red yellow blue purple pink green}]
set c2 [lpick {red yellow blue purple pink green}]
.p create rectangle 60 60 10 10 \
-fill $c1 -tags [concat $args mv]
}
proc makeplanet {x y color args} {
global dx dy
set color [lpick {black brown white gray \
brown3 brown4 red yellow blue purple}]
set c1 [lpick {red yellow blue purple \
pink green brown black white gray}]
set c2 [lpick {red yellow blue purple \
pink green brown black white gray}]
.p create oval [expr {$x+2}] [expr {$y+2}] [expr {$x+$dx-3}] [expr {$y+$dy-3}] \
-fill $color -tags [concat $args mv]
}
proc lpick L {lindex $L [expr int(rand()*[llength $L])]}proc horoscope {win radiusradius sectors percentages color} {
canvas $win -width [expr $radiusradius * 2.2] -height [expr $radiusradius * 2.2]
set next 0
set x0 [expr $radiusradius * 1.1]
set y0 [expr $radiusradius * 1.1]
set dim [list [expr $x0 - $radiusradius] [expr $y0 - $radiusradius] \
[expr $x0 + $radiusradius] [expr $y0 + $radiusradius]]
foreach segment $sectors percentage $percentages color $color {
set degrees [expr $percentage * 3.6]
eval $win create arc $dim -start $next -extent $degrees \
-fill $color
set sectors_mid [expr ($next + $degrees / 2) * acos (0) / 90]
$win create text \
[expr $x0 + $radiusradius * cos ($sectors_mid)*6 / 8] \
[expr $y0 - $radiusradius * sin ($sectors_mid)*6 / 8] \
-text $segment
set next [expr $next + $degrees]
}
return $win}
# pack [horoscope .p 220 {ARIES TAURUS CANCER GEMINI LEO VIRGO LIBRA SCORPIO SAGITTARIUS CAPRICORN "AQUARIUS" PISCES } \
{8.3 8.3 8.3 8.3 8.3 8.3 8.3 8.3 8.3 8.3 8.3 8.9 } \
{white yellow white yellow white yellow white yellow white yellow white yellow}]set dx 50
set dy 50
.p bind all <1> {set p(X) [.p canvasx %x]; set p(Y) [.p canvasy %y]}
.p bind mv <B1-Motion> {mv %x %y}
proc mv {x y} {
global p
set x [.p canvasx $x]
set y [.p canvasy $y]
set id [.p find withtag current]
.p move $id [expr {$x-$p(X)}] [expr {$y-$p(Y)}]
.p raise $id
set p(X) $x; set p(Y) $y
}star 20 20 20 args makeplanet 2 2 red makeplanet 2 2 brown makeplanet 2 2 blue makeplanet 2 2 green makeplanet 2 2 black makeplanet 2 2 blue makeplanet 2 2 red makeplanet 2 2 brown makeplanet 2 2 blue makeplanet 2 2 green makeplanet 2 2 black Category Toys