}
package require Tk
proc FerrisWheel {w xm ym r {cars 12}} {
$w create oval [expr $xm-$r] [expr $ym-$r] [expr $xm+$r] [expr $ym+$r]\
-width 4 -fill {} -tag wheel
$w create oval [expr $xm-8] [expr $ym-8] [expr $xm+8] [expr $ym+8]\
-fill black
for {set d 0} {$d<360} {set d [expr {$d+360./$cars}]} {
set rad [deg2rad $d]
set x [expr {$xm+cos($rad)*$r}]
set y [expr {$ym+sin($rad)*$r}]
$w create line $xm $ym $x $y -tag "wheel spoke sx$d"
set color [lpick {white yellow orange green purple}]
$w create oval [expr $x-2] [expr $y-2] [expr $x+2] [expr $y+2] \
-fill $color -tags "wheel x$d lamp"
car $w $x $y x$d
}
$w raise wheel
set ybot [expr {$ym+$r*1.5}]
$w create line [expr $xm-$r] $ybot $xm $ym [expr $xm+$r] $ybot \
-fill grey30 -width 8 -tag frame
incr r -12; set yy [expr {$ym+$r*1.5}]
foreach xx {25 35 45} {
$w create rect [expr $xm-$xx] [expr $yy-3] [expr $xm+$xx] [expr $yy+3] \
-fill grey50 -tag stairs
set yy [expr {$yy + 5.0}]
}
after 100 animate $w
}
proc car {w x y tag} {
#set color red
set color [lpick {red pink yellow orange green cyan blue purple}]
$w create rect [expr {$x-10}] $y [expr {$x+10}] [expr {$y+20}] \
-fill $color -tag $tag
$w create rect [expr {$x-8}] [expr {$y+3}] [expr {$x+8}] [expr {$y+10}] \
-fill [$w cget -bg] -tag $tag
$w create rect [expr {$x-3}] [expr {$y+3}] [expr {$x+3}] [expr {$y+18}] \
-fill {} -width 2 -tag $tag
}
proc deg2rad deg {expr {$deg * atan(1)*8/360}}
proc lpick list {lindex $list [expr {int(rand()*[llength $list])}]}
proc animate {w} {
if $::go {
foreach {x0 - xm ym} [$w coords [$w find withtag frame]] break
set r [expr {$xm-$x0}]
foreach spoke [$w find withtag spoke] {
foreach {x0 y0 x y} [$w coords $spoke] break
set th [expr {($x? atan2($y-$ym,$x-$xm) : 0.0)+0.0075}]
set x1 [expr {$xm + cos($th) * $r}]
set y1 [expr {$ym + sin($th) * $r}]
$w coords $spoke $x0 $y0 $x1 $y1
regexp {s([x[0-9.]+)} [$w gettags $spoke] -> id
$w move $id [expr {$x1-$x}] [expr {$y1-$y}]
}
}
set id [lpick [$w find withtag lamp]]
set color [$w itemcget $id -fill]
if {$color ne "black"} {
$w itemconfigure $id -fill black
after 250 [list $w itemconfigure $id -fill $color]
}
after 50 [list animate $w]
}
pack [canvas .c -width 200 -height 220 -bg lightblue] -fill both -expand 1
FerrisWheel .c 100 100 85 15
checkbutton .c.go -variable go -text ""
set go 1
.c create window 180 212 -window .c.go
bind .c <1> {
.c configure -height [expr [.c cget -height] * 2]
.c configure -width [expr [.c cget -width] * 2]
.c scale all 0 0 2 2
}
bind .c <3> {
.c configure -height [expr [.c cget -height] / 2]
.c configure -width [expr [.c cget -width] / 2]
.c scale all 0 0 0.5 0.5
}
bind . <KeyPress-q> {destroy .}
wm resizable . 0 0HJG 2005-06-29 Added random colors for the cars, and little stairs at the bottom of the wheel.
Steven A 2006-01-08 The whole widget now scales up/down with the wheel.
