[Keith Vetter] : 2006-08-30 : Since writing [Geneva Drive] was so much fun, I thought I'd do an animation of a bunch of inter-meshed gears. [http://mini.net/files/gears.jpg] Three technical challenges: ''First, how do you draw a single gear that can mesh with other different size gears?'' The key here was having a fixed size tooth and gap regardless of the size of the gear. So instead of computing how many teeth can fit on a certain size gear, compute how big a gear must be to have a certain number of teeth. ''Second, how do you add a new gear so that it meshes nicely with an existing gear?'' Here I drew a line between a gear's center and the middle of one of its gap and placed the new gear on that line. The new gear then must be rotated so that a tooth nestles nicely into the gap. I also check to make sure that the new gear is visible and doesn't overlap any other gear. ''Third, how to rotate the gears?'' The actual rotation code is easy using [Canvas Rotation]; the tricky part is computing how much to rotate each gear. Well, I decreed that the first gear always rotates one unit. Working outward from the first gear, you can compute another gear's rotation based on the ratio of the number of teeth on the two abutting gears. ---- ##+########################################################################## # # gears.tcl -- Gear animation # by Keith Vetter, August 30, 2006 # # http://www1.minn.net/~dchristo/Gears/Gears.html package require Tk if {! [catch {package require tile}]} { namespace import -force ::ttk::button if {[package present tile] ne "0.7.2" || ! $tcl_interactive} { namespace import -force ::ttk::scale ;# buggy for me on reload } } set S(title) "Gear Animation" array set GG { base 19 top 10 height 15 spacing 5 gap 2 dir 1 step 1 animate 0 maxSpeed 50} set GG(speed) [expr {$GG(maxSpeed) - 20}] set PI [expr {acos(-1)}] proc DoDisplay {} { global GG wm title . $::S(title) frame .bottom canvas .c -width 500 -height 500 -bd 2 -relief ridge bind .c {ReCenter %W %h %w} bind all {console show} pack .bottom -side bottom -fill x -pady 5 -padx 5 pack .c -side top -fill both -expand 1 button .start -text Start -command StartStop button .reverse -text Reverse -command {set GG(dir) [expr {-$GG(dir)}]} scale .speed -from 1 -to $GG(maxSpeed) -variable GG(speed) -orient hor catch {.speed config -showvalue 0} ;# Older tile allows this catch {.speed config -label Speed} ;# button .add -text "Add Gear" -command AddGear button .reset -text Reset -command Reset image create photo ::img::question -data { R0lGODlhBQAJALMAAAQCBOTe5BcAiAAAfIgACOkAABIApwAAAPgB0HAA+hcAFQAA AACgAHHqABcSAAAAACH5BAAAAAAALAAAAAAFAAkAAwQNMIApQaU0VJ2l/l+XRQA7} button .? -image ::img::question -command About grid x .add x .start x .speed x -in .bottom -pady 2 grid x .reset x .reverse x ^ x -in .bottom -pady 2 grid columnconfigure .bottom {0 2 4 6} -weight 1 place .? -in .bottom -relx 1 -rely 1 -anchor se } proc ReCenter {W h w} { ;# Called by configure event set h2 [expr {$h / 2}] ; set w2 [expr {$w / 2}] $W config -scrollregion [list -$w2 -$h2 $w2 $h2] } ##+########################################################################## # # Teeth2Radius -- returns radius of circle that will fit exactly # N teeth (since tooth size and gap are fixed_ # proc Teeth2Radius {teeth} { global GG set perim [expr {$teeth * ($GG(base) + 2*$GG(spacing))}] set radius [expr {$perim / $::PI / 2}] set radius [expr {1 + int($radius)}] ;# Round up return $radius } proc LightColor {} { # http://wiki.tcl.tk/PastelColors set light [expr {255 * .8}] ;# Value threshold while {1} { set r [expr {int (255 * rand())}] set g [expr {int (255 * rand())}] set b [expr {int (255 * rand())}] if {$r > $light || $g > $light || $b > $light} break } return [format "\#%02x%02x%02x" $r $g $b] } proc Reset {} { if {$::GG(animate)} StartStop ;# Turn off animation .c delete all array unset ::G AddGear } ##+########################################################################## # # AddGear -- adds a new gear # proc AddGear {} { global G GG set cnt [llength [array names G *,teeth]] set who g$cnt if {$cnt == 0} { ;# First gear always in middle set teeth [expr {int(5*rand()) + 13}] ;# Insure it's fairly large MakeGear 0 0 [Teeth2Radius $teeth] $who set G($who,driver) $who set G($who,zero) 0 set G($who,ratio) 1.0 return } for {set i 0} {$i < 30} {incr i} { ;# Redo if overlapped # Pick random gear to be driver, pick random gap on that # gear and pick random new gear size and figure out where # that gear should so it fits into that gap. Next if it doesn't # overlap any existing gears we're done except for rotating # the new gear so that a tooth lines up with the gap on the # driver gear. set driver g[expr {int(rand() * $cnt)}] set gap [expr {int(rand()*$G($driver,teeth))}] set teeth [expr {int(15*rand()) + 5}] set r [Teeth2Radius $teeth] set base [expr {$G($driver,angle) * $::PI / 180}] set angle [expr {$gap * $G($driver,gamma) + $G($driver,gamma)/2 +$base}] set r2 [expr {$r + $GG(height) + $GG(gap) + $G($driver,radius)}] foreach {x0 y0} $G($driver,xy) break set x [expr {$x0 + $r2 * cos($angle)}] set y [expr {$y0 + $r2 * sin($angle)}] if {! [CheckOverlap $x $y $r $driver]} { MakeGear $x $y $r $who RotateGear $who [expr {180 + $angle * 180 / $::PI}] set G($who,driver) $driver set G($who,zero) $G($who,angle) set G($who,ratio) [expr {-$G($driver,ratio) * $G($driver,teeth) / $teeth}] return } } Flash } proc MakeGear {X Y r1 who} { global G GG C set r2 [expr {$r1 + $GG(height)}] ;# Radius to top of tooth set alpha [expr {$GG(base) / double($r1)}] ;# Angle to base of tooth set beta [expr {$GG(top) / double($r2)}] ;# Angle to top of tooth set gamma [expr {($GG(base) + 2*$GG(spacing)) / double($r1)}] set teeth [expr {int(2 * $::PI / $gamma)}] ;# How many teeth can fit set gamma2 [expr {2 * $::PI / $teeth}] ;# Exact angle between teeth set G($who,teeth) $teeth set G($who,radius) $r1 set G($who,gamma) $gamma2 set G($who,xy) [list $X $Y] set G($who,angle) 0 set xy {} for {set i 0} {$i < $teeth} {incr i} { ;# Each gear tooth set angle [expr {$gamma2 * $i}] set x1 [expr {$X + $r1 * cos($angle - $alpha/2)}] set y1 [expr {$Y + $r1 * sin($angle - $alpha/2)}] set x2 [expr {$X + $r2 * cos($angle - $beta/2)}] set y2 [expr {$Y + $r2 * sin($angle - $beta/2)}] set x3 [expr {$X + $r2 * cos($angle + $beta/2)}] set y3 [expr {$Y + $r2 * sin($angle + $beta/2)}] set x4 [expr {$X + $r1 * cos($angle + $alpha/2)}] set y4 [expr {$Y + $r1 * sin($angle + $alpha/2)}] lappend xy $x1 $y1 $x2 $y2 $x3 $y3 $x4 $y4 } set xy [concat $xy [lrange $xy 0 1]] ;# Make coords list closed set clr [LightColor] .c create polygon $xy -tag $who -fill $clr -outline black .c create oval [MakeBox $X $Y $r1] -tag $who -fill $clr -outline black .c create oval [MakeBox $X $Y 3] -tag $who -fill black } proc MakeBox {x y r} { return [list [expr {$x-$r}] [expr {$y-$r}] [expr {$x+$r}] [expr {$y+$r}]] } # From http://wiki.tcl.tk/CanvasRotation proc _RotateItem {w tagOrId Ox Oy angle} { set angle [expr {$angle * atan(1) * 4 / 180.0}] ;# Radians foreach id [$w find withtag $tagOrId] { ;# Do each component separately if {[.c type $id] eq "oval"} continue set xy {} foreach {x y} [$w coords $id] { # rotates vector (Ox,Oy)->(x,y) by angle clockwise set x [expr {$x - $Ox}] ;# Shift to origin set y [expr {$y - $Oy}] set xx [expr {$x * cos($angle) - $y * sin($angle)}] ;# Rotate set yy [expr {$x * sin($angle) + $y * cos($angle)}] set xx [expr {$xx + $Ox}] ;# Shift back set yy [expr {$yy + $Oy}] lappend xy $xx $yy } $w coords $id $xy } } proc RotateGear {who angle} { global G eval _RotateItem .c $who $G($who,xy) $angle set old $G($who,angle) set G($who,angle) [expr {fmod($G($who,angle) + $angle, 360)}] # if $G($who,zero) between old and current then increment G($who,cnt) } proc GoGear {} { global G GG foreach g [array names G *,teeth] { ;# Each gear set who [lindex [split $g ","] 0] set ratio [GetRatio $who] ;# How far to turn per step set angle [expr {$GG(step) * $GG(dir) * $ratio}] RotateGear $who $angle } } ##+########################################################################## # # GetRatio -- returns how much to turn this gear in each step. We must follow # each gear back to the source computing ratio of teeth along the way. # # NB. we now compute this value at creation time so this code isn't needed. # proc GetRatio {who} { global G if {[info exists G($who,ratio)]} { return $G($who,ratio)} set ratio 1.0 set driver $who while {1} { ;# Follow gear chain to source if {$driver eq $G($driver,driver)} break;# At the source??? set last $driver set driver $G($driver,driver) set ratio [expr {-$ratio * $G($driver,teeth) / $G($last,teeth)}] } set G($who,ratio) $ratio ;# Memoize value return $ratio } proc Animate {} { set start [clock click -milliseconds] GoGear set duration [expr {[clock click -milliseconds] - $start}] lappend ::D $duration if {! $::GG(animate)} return set delay [expr {round($::GG(maxSpeed) - $::GG(speed) + 1)}] set delay [expr {$delay > $duration ? $delay - $duration : 1}] after $delay Animate } proc StartStop {} { set ::GG(animate) [expr {! $::GG(animate)}] if {$::GG(animate)} { ;# Now going .start config -text "Stop" Animate } else { .start config -text "Start" } } proc Flash {} { .c config -bg red after 200 {.c config -bg [lindex [.c config -bg] 3]} } proc About {} { set msg "$::S(title)\nby Keith Vetter, August 2006\n" tk_messageBox -message $msg -title "About $::S(title)" } proc CheckOverlap {x y r driver} { global GG G foreach {x0 y0 x1 y1} [.c cget -scrollregion] break if {$x < $x0 || $x > $x1 || $y < $y0 || $y > $y1} { return 1 } foreach g [array names G *,teeth] { set other [lindex [split $g ","] 0] if {$other eq $driver} continue set min [expr {$r + $G($other,radius) + 2*$GG(height) + $GG(gap)}] foreach {x1 y1} $G($other,xy) break set dist [expr {hypot($x1-$x,$y1-$y)}] if {$dist < $min} { return 1 } } return 0 } DoDisplay update AddGear AddGear AddGear return ---- [Category Application] | [Category Animation] | [Category Graphics] | [Category Toys]