if 0 {[Richard Suchenwirth] 2003-04-12 - A Ferris Wheel is a large
structure found in entertainment parks, where "cars" are suspended on
axes that connect a pair of very big, slowly rotating wheels. 
Here is another Tcltoy, a study in [canvas] animation simulating a 
Ferris Wheel, vaguely inspired by the famous landmark of Vienna. 
Start resp. stop it with the check button at bottom right 
(which with a little phantasy can be taken as ticket office ;-)
Little blinking lights were added for sheer fun. 
Zoom in/out with left/right mouse button.

[WikiDbImage tkferris.jpg]
----
}
 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 0


----
[HJG] 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.

----
[Category Animation] | [Category Toys] | [Arts and crafts of Tcl-Tk programming]