Updated 2015-06-21 12:38:02 by HJG

## Description  edit

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

## Changes  edit

PYK 2012-12-03: removed update

## Code  edit

```##+##########################################################################
#
# 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
}
bind all <F2> {console show}
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 .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]
}
##+##########################################################################
#
# N teeth (since tooth size and gap are fixed_
#
global GG

set perim [expr {\$teeth * (\$GG(base) + 2*\$GG(spacing))}]
set radius [expr {\$perim / \$::PI / 2}]
}
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
}
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}]
}
}
##+##########################################################################
#
#
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 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,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]}
}

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 -- 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```