Description  edit

Changes  edit

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
        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)}]
         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
        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

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References