• The val parameter is not used.
• The rate variable is inverted relative to the scale widget value (which means at the very least that it has the wrong name).
• The greater the speed setting, the lower the delay (which is good).

##+##########################################################################
#
# Falling Marbles
# by Keith Vetter, April 2003
# KPV Apr 30, 2003 - better resizing behavior, sound, more controls
# KPV May  2, 2003 - added no ramp mode
#

package require Tk

array set S {title "Falling Marbles" top 70 bottom 20 xspacing 20 yspacing 30
    pegsize 3 bnum 0 stop 1 bias 0 speed 5 sound 0 auto 1 birth 96 ramp 1}

set S(psteps) 7                                        ;# Steps falling between pegs
set S(rsteps) 15                                ;# Steps rolling down ramp
set S(dsteps) 3                                        ;# Steps dropping to first peg
set S(hsteps) 10                                ;# Steps holding still

proc DoDisplay {} {
    global S

    # see http://wiki.tcl.tk/gifBalls
    set ball(red) {R0lGODlhFAAPAPMPAAAAADgFD00CEGoDGHMTJ21ZXZISK6USL7MoRJ1aZ
        9IzUvRUdNVAXscbPv9ylKqcniH5BAEAAAAALAAAAAAUAA8AAARwEMgpX7qPavrQ+YdBZ
        Nv0HIDCKE04kNvZMEvNeIMAU8mhLI7gQuEqlAwHWtCxYLgIMeRvOTwQBoHS4ICg2RCGX
        HZDQCIUaPBVMNYkBgZkSCQ2lgSDAWGfZwd2HAJ4fX6AGg9sggGLhiUPBZCNJZMaEQA7}
    set ball(yellow) {R0lGODlhFAAPAPMPAAAAADExBD09Kk5OAmtrDFNTKmxsWImJFLCwM5
        mZJaCgUsXFONPTUvb2ceXlWKennCH5BAEAAAAALAAAAAAUAA8AAARqEMgpX1Lq0U3t+Q
        dBaNz0HAmyIEk4kNyZLI7DMC3xlsqBOI0gA+EylAgpoJCoK8QIPkbQxhwEjqjFbZgQWY
        /QFILlClw5hoEI5LUaSwO1SBc3wzaPgCC+NwfuMX5+AoAlAA8GBQaFho0UEQA7}
    set ball(green) {R0lGODlhFAAPAPQAAAAAAAA4BwBNCgBqEgBzE0ZtTACSEwClFgqzJj+d
        TADHIQ/SKRzVOyv0RUf/bH+qgwAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
        AAAAAAAAAAAAAAAAAAAACH5BAEAABAALAAAAAAUAA8AAAV2ICSO4pOcD6mSD3K8h0Gk6/
        gc0MIsSjzQq5uC0SgyXAMBkJQ4LBqOaGPhK9QMB2LU0WD4CEHsczs9EAaB2uCAIBoRhmR
        6RcAiFnj4WTBXJQYGWDEyclY1AgMDBIuJfAFLLAKIjY6QKg98kgGbljUPBaCdNaMqIQA7}

    wm title . $S(title)
    pack [frame .ctrl -relief ridge -bd 2 -padx 5 -pady 5] \
        -side right -fill both -ipady 5
    pack [frame .screen -bd 2 -relief raised] -side left -fill both -expand 1

    canvas .c -borderwidth 0 -height 500 -width 600 \
        -highlightthickness 0 -scrollregion {-300 0 300 500}

    bind all <Alt-c> {console show}

    DoCtrlFrame
    foreach b {red yellow green} num {0 1 2} {
        image create photo ::img::ball($num) -data $ball($b)
    }

    set S(bw) [image width ::img::ball(0)]
    set S(bh) [image height ::img::ball(0)]

    bind .c <Configure> {
        DrawPegs
        DrawSums
        DrawRamps
        DoSounds
        ReCenter %W %h %w
        Go
    }
    pack .c -in .screen -side left -fill both -expand 1
}
proc DoCtrlFrame {} {
    button .go -text "Go" -command Go -bd 4
    .go configure -font "[font actual [.go cget -font]] -weight bold"
    button .clear -text "Clear" -command Clear -bd 4 -font [.go cget -font]
    button .new -text "New Ball" -command CreateBall -bd 4 -font [.go cget -font]
    checkbutton .sound -text "Sound" -relief raised -bd 4 -state disabled \
        -variable S(sound) -padx 10 -anchor w -font [.go cget -font]
    checkbutton .auto -text "Auto Ball" -relief raised -bd 4 -command Birth \
        -variable S(auto) -padx 10 -anchor w -font [.go cget -font]
    checkbutton .ramp -text "Ramp" -relief raised -bd 4 -command DrawRamps \
        -variable S(ramp) -padx 10 -anchor w -font [.go cget -font]

    button .about -text "About" -font [.go cget -font] -command \
        [list tk_messageBox -message "$::S(title)\nby Keith Vetter, April 2003"]
    scale .speed -orient h -from 1 -to 10 -font [.go cget -font] \
        -variable S(speed) -bd 2 -relief ridge -showvalue 1 -label Speed
    scale .birth -orient h -from 3 -to 100 -font [.go cget -font] \
        -variable S(birth) -bd 2 -relief ridge -showvalue 1 -label "Birth Rate" \
        -command NewBirth
    scale .bias -orient h -from -10 -to 10 -font [.go cget -font] \
        -variable S(bias) -bd 2 -relief ridge -showvalue 1 -label "Bias"

    grid .go -in .ctrl -sticky ew -row 0
    grid .clear -in .ctrl -sticky ew
    grid .new -in .ctrl -sticky ew
    grid rowconfigure .ctrl 10 -minsize 10
    grid .sound -in .ctrl -sticky ew -row 11
    grid .auto -in .ctrl -sticky ew
    grid .ramp -in .ctrl -sticky ew
    grid rowconfigure .ctrl 30 -minsize 20
    grid .speed -in .ctrl -sticky ew -row 31
    grid .birth -in .ctrl -sticky ew
    grid .bias -in .ctrl -sticky ew
    grid rowconfigure .ctrl 50 -weight 1
    grid .about -in .ctrl -sticky ew -row 100
}
proc DrawPegs {} {
    global S PEG SUMS

    .c delete peg
    lassign [.c cget -scrollregion] X0 Y0 X1 Y1

    set top [expr {$Y0 + $S(top)}]
    set bottom [expr {$Y1 - $S(bottom)}]
    for {set row 0} {$row < 50} {incr row} {
        set y [expr {$top + $row * $S(yspacing)}]
        #if {$y > $bottom} break

        for {set col 0} {$col < 50} {incr col} {
            set x [expr {$col * $S(xspacing)}]
            set PEG($col,$row) [list $x $y]
            set PEG(-$col,$row) [list -$x $y]
            #if {$x > $X1} continue
            if {($row & 1) && !($col & 1)} continue ;# Odd row, even column
            if {!($row & 1) && ($col & 1)} continue ;# Even row, odd column

            .c create oval [bbox $x $y $S(pegsize)] -tag peg -fill black
            .c create oval [bbox -$x $y $S(pegsize)] -tag peg -fill black
        }
    }

    .c create rect 0 0 0 0 -tag sum -fill [.c cget -bg] -outline {}
    # Sums text
    set y [expr {$Y1 - 2}]
    set font {{Times Roman} 8 bold}
    for {set col 0} {$col < 50} {incr col} {
        set x [expr {$col * $S(xspacing)}]
        .c create text $x $y -tag e$col -font $font -anchor s
        .c create text -$x $y -tag e-$col -font $font -anchor s
        set SUMS($col) [set SUMS(-$col) ""]
    }
    trace variable SUMS w TraceSums
}
proc DrawSums {} {
    global S PEG

    lassign [.c cget -scrollregion] X0 Y0 X1 Y1
    set bottom [expr {$Y1 - $S(bottom)}]

    for {set row 0} {1} {incr row} {
        lassign $PEG(0,$row) x y
        if {$y > $bottom} break
    }
    set S(rows) $row                                ;# Number of visible rows
    set S(cols) [expr {int(double($X1) / $S(xspacing)) | 1}]
    .c coords sum -999 [expr {$y - $S(pegsize)}] 999 $Y1 ;# Blank out bottom

    # Reposition counters
    set y [expr {$Y1 - 2}]
    for {set col 0} {$col < 50} {incr col} {
        set x [expr {$col * $S(xspacing)}]
        .c coords e$col $x $y
        .c coords e-$col -$x $y
    }
}
proc DrawRamps {} {
    global S B

    .c delete ramp door
    foreach a [array names B *,where] {
        if {$B($a) == "ramp" || $B($a) == "hold"} {
            set id [lindex [split $a ","] 0]
            array unset B $id,*
            .c delete $id
        }
    }
    if {! $S(ramp)} return

    lassign [.c cget -scrollregion] X0 Y0 X1 Y1
    set x0 $X1                       ; set y0 [expr {$Y0 + $S(bh)}]
    set x1 [expr {$S(bw) / 2}] ; set y1 [expr {$Y0 + $S(top) - 3*$S(bh)}]
    set x2 $x1                       ; set y2 [expr {$y1 + $S(bh)}]
    set x3 $x0                       ; set y3 $y2
    set x4 5000                       ; set y4 $y3
    set x5 $x4                       ; set y5 $y0
    .c create poly $x0 $y0 $x1 $y1 $x2 $y2 $x3 $y3 $x4 $y4 $x5 $y5 -tag ramp
    .c create poly -$x0 $y0 -$x1 $y1 -$x2 $y2 -$x3 $y3 -$x4 $y4 -$x5 $y5 \
        -tag ramp

    set S(rsteps) [expr {$X1 < 20 ? 1 : $X1 / 20}]
    set S(entry,0) [list [expr {$X0 + $S(bw) / 2.0}] [expr {$Y0 + $S(bh) + 2}]]
    set S(entry,1) [list [expr {$X1 - $S(bw) / 2.0}] [expr {$Y0 + $S(bh) + 2}]]
    set S(drop,x) 0
    set S(drop,y) [expr {$y1 + 3}]

    set x [expr {$X1 - $S(bw)}] ; set y [expr {$Y0 + $S(bh)}]
    .c create oval $x $Y0 $X1 $y -tag door -fill red
    .c create oval [expr {-1*$x}] $Y0 $X0 $y -tag door -fill red
}
proc TraceSums {var1 var2 op} {
    .c itemconfig e$var2 -text $::SUMS($var2)
}
proc bbox {x y r} {
    return [list [expr {$x-$r}] [expr {$y-$r}] [expr {$x+$r}] [expr {$y+$r}]]
}
proc ReCenter {W h w} {                   ;# Called by configure event
    Clear
    $W config -scrollregion [list [expr {-$w/2}] 0 [expr {$w/2}] $h]
    DrawRamps
    DrawSums
}
proc MoveAbs {id xy} {
    lassign $::B($id,xy) x0 y0                ;# Where it is now
    lassign $xy x y                        ;# Where to put it
    .c move $id [expr {$x - $x0}] [expr {$y - $y0}]
    set ::B($id,xy) $xy
}
proc Ball2Canvas {id} {
    global PEG B S

    set step $B($id,step)
    if {$B($id,where) == "ramp"} {
        lassign $S(entry,$B($id,peg)) x y
        set dx [expr {$step * ($S(drop,x) - $x) / $S(rsteps)}]
        set dy [expr {$step * ($S(drop,y) - $y) / $S(rsteps)}]
        set x [expr {$x + $dx}]
        set y [expr {$y + $dy}]
        return [list $x $y]
    }
    if {$B($id,where) == "drop"} {
        lassign $PEG($B($id,peg)) x y        ;# Where we land
        set dy [expr {$step * ($y - $S(drop,y)) / $S(dsteps)}]
        set y [expr {$S(drop,y) + $dy}]
        return [list $x $y]
    }
    if {$B($id,where) == "hold"} {        ;# Hold still
        lassign $PEG($B($id,peg)) x y        ;# Where we land
        return [list $x $S(bh)]
        return [list $x $S(drop,y)]
    }
    lassign $PEG($B($id,peg)) x y        ;# Last peg hit
    set dx [expr {$step * $S(xspacing) / double($S(psteps))}]
    set xx [expr {$x + $B($id,dir) * $dx}]

    set upsteps 2                        ;# How many steps going up
    set updist -10                        ;# How far up to go

    if {$step == 0} {
        set dy 0
    } elseif {$step <= $upsteps} {                ;# Bounce up a bit
        set dy [expr {$step * $updist / double($upsteps)}]
    } elseif {$step > $upsteps} {                ;# Going down now
        set dist [expr {$S(yspacing) - $updist}];# How far to go
        set tsteps [expr {$S(psteps) - $upsteps}] ;# How many steps to do it in
        incr step [expr {-$upsteps}]
        set dy [expr {$updist + $step * $dist / double($tsteps)}]
    }
    set yy [expr {$y + $dy}]

    return [list $xx $yy]
}
proc CreateBall {} {
    global B S

    set id "B[incr S(bnum)]"
    set B($id,where) ramp
    set B($id,peg) [expr {rand() > .5 ? 0 : 1}] ;# Which side to launch from
    set B($id,step) -1
    set B($id,dir) [expr {rand() < ($S(bias) + 10)/20.0 ? 1 : -1}]
    set B($id,xy) {-9999 -9999}
    set num [expr {int(rand() * 3)}]
    .c create image $B($id,xy) -anchor s \
        -image ::img::ball($num) -tag [list ball $id]

    if {! $S(ramp)} {                                ;# No ramp mode
        set col [expr {2*int($S(cols) * (rand() - .5))}]
        set B($id,peg) "$col,0"
        set B($id,where) "hold"
    }

    MoveOneBall $id
    return $id
}
proc MoveBall {id} {
    global B S SUMS

    incr B($id,step)
    if {$B($id,where) == "ramp"} {
        if {$B($id,step) >= $S(rsteps)} {        ;# Done with the ramp
            set B($id,step) 0
            set B($id,where) "drop"
            set B($id,peg) "0,0"                ;# Peg to drop to
        }
    } elseif {$B($id,where) == "drop"} {        ;# Dropping through the hole
        if {$B($id,step) >= $S(dsteps)} {        ;# Done with the drop
            if {$S(sound)} {snd_click play}
            set B($id,step) 0
            set B($id,where) "peg"
        }
    } elseif {$B($id,where) == "hold"} {
        if {$B($id,step) >= $S(hsteps)} {        ;# Done holding, let her drop
            set B($id,step) 0
            set B($id,where) "drop"
        }
    } elseif {$B($id,where) == "peg"} {
        if {$B($id,step) >= $S(psteps)} {        ;# Hit the next peg
            lassign [split $B($id,peg) ","] col row
            incr col $B($id,dir)
            incr row
            if {$row >= $S(rows)} {                ;# Off the bottom
                if {$SUMS($col) == ""} {set SUMS($col) 0}
                incr SUMS($col)
                array unset B $id,*
                .c delete $id
                return
            }
            if {$S(sound)} {snd_click play}
            set B($id,peg) "$col,$row"
            set B($id,dir) [expr {rand() < ($S(bias) + 10)/20.0 ? 1 : -1}]
            set B($id,step) 0
        }
    }
    set xy [Ball2Canvas $id]
    MoveAbs $id $xy
}
proc MoveOneBall {id {single 0}} {
    global B S

    set ttime [clock clicks -milliseconds]
    if {! [info exists B($id,peg)]} return
    if {$S(stop) && ! $single} return
    MoveBall $id
    if {$single} return
    set ttime [expr {[clock clicks -milliseconds] - $ttime}]
    set delay [expr {110 - 10*$S(speed)}]
    set delay [expr {$ttime > $delay ? 0 : $delay - $ttime}]
    after $delay [list MoveOneBall $id]
}
proc Go {} {
    global B S

    if {$S(stop)} {                                ;# We're stopped
        .go config -text "Stop"
        set S(stop) 0
        foreach ball [array names B *,xy] {
            set id [lindex [split $ball ","] 0]
            after [expr {110 - 10*$S(speed)}] [list MoveOneBall $id]
        }
        Birth
    } else {
        foreach a [after info] {after cancel $a}
        .go config -text "Go"
        set S(stop) 1
    }
}
proc Clear {} {
    set stop $::S(stop)
    if {! $stop} Go                                ;# Stop everything
    foreach a [array names ::SUMS] { set ::SUMS($a) "" }
    foreach a [array names ::B] { unset ::B($a) }
    .c delete ball
    if {! $stop} Go
}
proc Birth {} {
    global S

    if {$S(stop) || ! $S(auto)} return
    CreateBall                                        ;# Called for a new birth
    NewBirth $S(birth)
}
proc NewBirth {val} {
    global S

    after cancel Birth
    set rate [expr {103 - $S(birth)}]
    set delay [expr {110 - 10*$S(speed)}]
    set delay [expr {$delay * $rate + round(200 * rand())}]
    after $delay Birth
}
proc DoSounds {} {
    proc snd_click {play} {}                        ;# Stub
    if {[catch {package require base64}]} return
    if {[catch {package require snack}]} return
    set sdata {UklGRkACAABXQVZFZm10IBAAAAABAAEAESsAABErAAABAAgAZGF0YRwCAACAgId0Z
        HZbU5aMj7/MsIZ6UX6nWIiITWiIRUGUlZesvrGCiKiKTl96Fit3YF5emrGHqcqhlJuAdWxgW
        01EbWSHubW1uJ2MkqGPYFVSamtvgHmEh5ybraWLkHp5Xm5oWGRvb3WSlYqMi4+JhY6Ac25xd
        Xp5jYR/hoODdIN8e356goCHgoqGgIV/g35/d3N2eHZ6gIOIgouHioaNioGAfHpycHp2dH2Hi
        ouNiYiKhIF9enZzd3l+dX2BgYKIjoaJhIJ/fX6AfHl8fICAgICEgISFhYF/gH+AfIJ/gH6Af
        X6AfICAfYB+gn2DfoGAgIOAgYB8e3x9gIKChYCDgIN/g32Afn+BgIF+gH+BgIOAgX2CfYGAg
        IB/gH9/fIB/gICBgH+Df4KAgIB9gHuBfYKAgoCAhICDgIN+gH+Af4CAgIGAg4CFgIOAgICAg
        H9/f32AfoF/gn+BgICAf4B/gICAgICAgIKAgYCAgH+AfYB8f4CAgoGBgIKBgHt0cnqEi4yIh
        oKHioOBeoF+gHRvbW10eYSHhoyMmI+PhIF5dm9tbW92fICJjpKRkY6JhHx5b2xlbnWAhYeOj
        pSQkIiAe3R1cnNzdnx/gomLj4yJhICAfHp3d3d6fYKDhoKGgIeAhX1/eXt9foCAg4GCg4CDf
        YF6gHmAfYCBgIR/h4CEf4B9fn98gHuEfYV/g4CAgn6Fe4R6gn1/gHuDe4V+g4CAgn8=}
    regsub -all {\s} $sdata {} sdata                ;# Bug in base64 package
    sound snd_click
    snd_click data [::base64::decode $sdata]
    .sound config -state normal
}

DoDisplay

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