Gear Animation

Description

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.

WikiDbImage 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.


KPV Got a little frivolous: I took the code from A little bar chart and added a histogram bar chart of the number of revolutions per gear.

I also changed the speed code to not only adjust the time between interations but also the increment size. This allows for much faster (but less smooth) animation. It also can result in some cool wagon wheel effects.

HJG see also: Geneva Drive and Scotch Yoke

Changes

PYK 2012-12-03: removed update

Code

##+##########################################################################
#
# 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 delay 20
    barW .bar.c barTop .bar
}
set GG(speed) 30
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 <Configure> {
        ReCenter %W %h %w
        Reset
        AddGear
        AddGear
    }
    bind all <F2> {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 100 -variable GG(speed) -orient hor \
         -command SetSpeed
    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 -width 6 -data {
         R0lGODlhBQAJALMAAAQCBOTe5BcAiAAAfIgACOkAABIApwAAAPgB0HAA+hcAFQAA
         AACgAHHqABcSAAAAACH5BAAAAAAALAAAAAAFAAkAAwQNMIApQaU0VJ2l/l+XRQA7}
    image create photo ::img::arrows -data {
         R0lGODlhBgAJAIAAAAAAAP///yH5BAAAAAAALAAAAAAGAAkAAAINjA+WygH5HIRsrYNzAQA7}
    button .? -image ::img::question -command About
    button .> -image ::img::arrows -command GoBarchart

    grid x .add   x .start   x .speed x -in .bottom -pady 2 -sticky ew
    grid x .reset x .reverse x ^      x -in .bottom -pady 2 -sticky ew
    grid columnconfigure .bottom {0 2 4 6} -weight 1
    frame .bottom.b2
    pack .? .> -in .bottom.b2 -side bottom
    place .bottom.b2 -in .bottom -relx 1 -rely 1 -anchor se
    #place .? -in .top -relx 1 -rely 1 -anchor se
    #place .> -in .bottom -relx 1 -rely 0 -anchor ne
}
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 {} {
    # https://wiki.tcl-lang.org/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 {} {
    after cancel [after info]
    if {$::GG(animate)} StartStop               ;# Turn off animation
    .c delete all
    array unset ::G
    set ::G(sum) -1
    AddGear
}
proc SetSpeed {args} {
    global GG

    if {$GG(speed) < 50} {
         set GG(step) 1
         set GG(delay) [expr {50 - $GG(speed)}]
    } else {
         set GG(delay) 1
         set GG(step) [expr {3 - 2 * (100 - $GG(speed))/50.0}]
    }
}
##+##########################################################################
#
# 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

              set G($who,driver) $driver
              set G($who,zero) $G($who,angle)
              set G($who,ratio) [expr {-$G($driver,ratio) * $G($driver,teeth) / $teeth}]
              RotateGear $who [expr {180 + $angle * 180 / $::PI}]
              set G($who,zero) $G($who,angle)
              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 G($who,tally) 0
    set G($who,clr) [LightColor]

    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 $G($who,clr)
    .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
    #.c create line $X $Y [expr {$X + $r1}] $Y -tag $who
}
proc MakeBox {x y r} {
    return [list [expr {$x-$r}] [expr {$y-$r}] [expr {$x+$r}] [expr {$y+$r}]]
}

# From https://wiki.tcl-lang.org/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 {[BetweenAngle $old $G($who,angle) $G($who,zero)]} {
         incr G($who,tally)
    }
}
proc AngleDiff {a b} {
    set d [expr {fmod(720 + $a - $b, 360)}]
    if {$d > 180} { set d [expr {360 - $d}] }
    return $d
}
proc BetweenAngle {a b x} {
    set ab [AngleDiff $a $b]
    set ax [AngleDiff $a $x]
    set bx [AngleDiff $b $x]
    if {$ax > $ab || $bx > $ab || $ax == 0} { return 0 }
    return 1
}

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
    }
    TallyHo
}
##+##########################################################################
#
# 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}]
    if {! $::GG(animate)} return

    set delay [expr {$::GG(delay) > $duration ? $::GG(delay) - $duration : 1}]
    set delay [expr {round($delay)}]
    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
}
proc GoBarchart {} {
    global GG

    if {! [winfo exist $GG(barW)]} {
        toplevel $GG(barTop)
        wm title $GG(barTop) "Revolution Count"
        wm transient $GG(barTop) .
        set x [expr {[winfo x .] + [winfo width .] + 20}]
        set y [expr {[winfo y .]}]
        wm geom $GG(barTop) "+$x+$y"

        canvas $GG(barW) -width 240 -height 280
        bind $GG(barW) <Configure> {
            TallyHo 1
        }
        pack $GG(barW) -fill both -expand 1
    }
}
proc TallyHo {{force 0}} {
    global G GG

    if {! [winfo exists $GG(barW)]} return
    foreach {sum data} [GetTally] break
    if {!$force && $sum == $G(sum)} return
    set G(sum) $sum
    ::Bars::Go $GG(barW) $data
}
proc GetTally {} {
    global G

    set sum 0
    set cnt [llength [array names G *,teeth]]
    set data {}
    for {set i 0} {$i < $cnt} {incr i} {
         set who g$i
         lappend data [list "" $G($who,tally) $G($who,clr)]
         incr sum $G($who,tally)
    }
    return [list $sum $data]
}

################################################################
# Barchart code -- https://wiki.tcl-lang.org/ALittleBarChart
#
namespace eval Bars {}

proc ::Bars::3DRect {w args} {
    if [string is int -strict [lindex $args 1]] {
         set coords [lrange $args 0 3]
    } else {
         set coords [lindex $args 0]
    }
    foreach {x0 y0 x1 y1} $coords break
    set d [expr {($x1-$x0)/3}]
    set x2 [expr {$x0+$d+1}]
    set x3 [expr {$x1+$d}]
    set y2 [expr {$y0-$d+1}]
    set y3 [expr {$y1-$d-1}]
    set id [eval [list $w create rect] $args]
    set fill [$w itemcget $id -fill]
    set tag [$w gettags $id]
    set clr2 [::tk::Darken $fill 80]
    set clr3 [::tk::Darken $fill 60]
    $w create poly $x0 $y0 $x2 $y2 $x3 $y2 $x1 $y0 -fill $clr2 -outline black
    $w create poly $x1 $y1 $x3 $y3 $x3 $y2 $x1 $y0 -fill $clr3 -outline black -tag $tag
}

# Draw a simple scale for the y axis, and return the scaling factor:}

proc ::Bars::YScale {w x0 y0 y1 min max} {
    set dy [expr {$y1-$y0}]
    regexp {([1-9]+)} $max -> prefix
    set stepy [expr {1.*$dy/$prefix}]
    set step [expr {$max/$prefix}]
    set y $y0
    set label $max
    while {$label>=$min} {
         $w create text $x0 $y -text $label -anchor w
         set y [expr {$y+$stepy}]
         set label [expr {$label-$step}]
    }
    expr {$dy/double($max)}
}

# An interesting sub-challenge was to round numbers very roughly,
# to 1 or maximally 2 significant digits - by default rounding up,
# add "-" to round down:}
proc ::Bars::Roughly {n {sgn +}} {
    regexp {(.+)e([+-])0*(.+)} [format %e $n] -> mant sign exp
    set exp [expr $sign$exp]
    if {abs($mant)<1.5} {
         set mant [expr {$mant*10}]
         incr exp -1
    }
    set t [expr round($mant $sgn 0.49)*pow(10,$exp)]
    expr {$exp>=0? int($t): $t}
}

# So here is my little bar chart generator.
# Given a canvas pathname, a bounding rectangle, and the data to display
# a list of {name value color} triples), it figures out the geometry.
proc ::Bars::Bars {w x0 y0 x1 y1 data} {
    set vals 0
    foreach bar $data {
         lappend vals [lindex $bar 1]
    }
    foreach {bot top} [::Bars::MinMax $vals] break
    set top [::Bars::Roughly $top]
    if {$top < 5} {set top 5}
    set bot [::Bars::Roughly $bot -]

    set f [::Bars::YScale $w $x0 $y0 $y1 $bot $top]
    set x [expr {$x0+30}]
    set dx [expr {($x1-$x0-$x)/[llength $data]}]
    set y3 [expr {$y1-20}]
    set y4 [expr {$y1+10}]
    $w create poly $x0 $y4 [expr {$x0+30}] $y3  $x1 $y3 [expr {$x1-20}] $y4 \
         -fill gray65
    set dxw [expr {$dx*6/10}]
    foreach bar $data {
         foreach {txt val col} $bar break
         set y [expr {round($y1-($val*$f))}]
         set y1a $y1
         if {$y>$y1a} {foreach {y y1a} [list $y1a $y] break }
         set tag [expr {$val<0? "d": ""}]
         ::Bars::3DRect $w $x $y [expr {$x+$dxw}] $y1a -fill $col -tag $tag
         #$w create text [expr {$x+12}] [expr {$y-12}] -text $val
         #$w create text [expr {$x+12}] [expr {$y1a+2}] -text $txt -anchor n
         incr x $dx
    }
    $w lower d
}
proc ::Bars::MinMax {vals} {
    set min [set max [lindex $vals 0]]
    foreach v [lrange $vals 1 end] {
         if {$v > $max} {
              set max $v
         } elseif {$v < $min} {
              set min $v
         }
    }
    return [list $min $max]
}
proc ::Bars::Go {W data} {
    $W delete all
    set w [winfo width $W]
    set h [winfo height $W]
    ::Bars::Bars $W 10 20 [incr w -20] [incr h -30] $data
}

DoDisplay