** 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]
----
[Jeff Smith] 2020-05-05 : Below is an online demo using [CloudTk]. This demo runs Gear Animation in an Alpine Linux Docker Container. It is a 27.4MB image which is made up of Alpine Linux + tclkit + Gear-Animation.kit + libx11 + libxft + fontconfig + ttf-linux-libertine. It is run under a user account in the Container. The Container is restrictive with permissions for "Other" removed for "execute" and "read" for certain directories.
'''Please Note''' : This demo has a run time of 2 minutes.
<<inlinehtml>>
<iframe height="600" width="600" src="https://cloudtk-app.tcl-lang.org/cloudtk/VNC?session=new&Tk=Gear-Animation" allowfullscreen></iframe>
<<inlinehtml>>
----
** 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 {} {
# 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)}] forelachssign {x0 y0} $G($driver,xy) breakx0 y0
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
forelachssign {x0 y0 x1 y1} [.c cget -scrollregion] breakx0 y0 x1 y1
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)}] forelachssign {x1 y1} $G($other,xy) breakx1 y1
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 forelach {sumsign data} [GetTally] bresum dakta
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]
} forelassign $choords {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]
} forelachssign {bot top} [::Bars::MinMax $vals] breakot top
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 { forelachssign {$bar txt val col} $bar break
set y [expr {round($y1-($val*$f))}]
set y1a $y1 if {$y>$y1a} {forelachssign {y y1a} [list $y1a $y] breaky y1a}
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
======
<<categories>> Application | Animation | Graphics | Toys