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

----
[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'' affects.

----
 ##+##########################################################################
 #
 # 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}
    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 .bottom -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 {} {
    # 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 {} {
    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 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 {[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
        pack $GG(barW) -fill both -expand 1
        update
    }
    TallyHo 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 -- http://wiki.tcl.tk/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
 update
 Reset
 AddGear
 AddGear
 
 return

----
[Category Application] | [Category Animation] | [Category Graphics] | [Category Toys]