Falling Marbles

Keith Vetter 2003-04-29 : here's fun little animation of marbles cascading down a peg board. The images for the marbles come from gifBalls.

https://www.tcl-lang.org/starkits/marbles.jpg

KPV 2003-04-30 : put up a new version with better resizing behavior, sound and more controls.

KPV 2003-05-02 : added no ramp mode


Jeff Smith 2019-04-28 : Below is an online demo using CloudTk

Please Note : This demo has a run time of 2 minutes.


TV Good visual effect. Makes me wonder about scaling, both the graphics, and the machine horsepower versus update rate or bounce increment. And colliding balls.

KPV Thanks. As to scaling issues, let's first take horsepower. Creating an animated display discusses this issue--basically each frame has an allotted amount of time to complete and, by using the after command, the next frame is not drawn until that time has elapsed. So a slow machine will consume more of each time allotment while fast machines will consume less, but, theoretically, they both should produce the same display.

The way to handle graphic scaling is to use Newtonian physics with gravity acceleration and velocity to compute a ball's path through the pegs. This isn't that hard, but since my ball GIF images don't scale nicely, I just faked it--2 steps up and 5 steps down.


escargo - I was noticing that the "Birth Rate" was not acting the way I was expecting. Looking at the code I noticed the following things in the NewBirth proc.

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

My user expectation is that changing the "Birth Rate" should result in something like linear changes in the birth rate. That's not what I observe. Am I missing something?

KPV - My intent was that birth rate is births per unit time meaning that a larger value results in more balls coming out. That is why the scale value gets inverted. The result should be linear--doubling the value means that twice as many balls coming out--but I do add in a random delay that may skew your perception.

The reason why the val parameter isn't used by NewBirth is partly historical and partly a lost feature (oops). Originally NewBirth took no parameter but then I thought it would be nice if changing the birth rate took effect immediately. So I set the scale's command to be NewBirth but that meant that NewBirth had to take a parameter. That new parameter change got in the final version but somehow the added command to the scale widget got lost (I've now added it in).

escargo Even the new version seems like a very nonlinear frequency change between different "Birth Rate" values. (Pehaps the only way to find out would be to add a field that showed internal values. I don't know if the problem is perceptual (rate really is linear) or procedural (rate really isn't linear).


##+##########################################################################
#
# 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 https://wiki.tcl-lang.org/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

GN 2004-07-30 : wow - Uses 80% + of my dual 2.0G5s cpu in max speed