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.


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(yellow) {R0lGODlhFAAPAPMPAAAAADExBD09Kk5OAmtrDFNTKmxsWImJFLCwM5
    set ball(green) {R0lGODlhFAAPAPQAAAAAAAA4BwBNCgBqEgBzE0ZtTACSEwClFgqzJj+d

    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}

    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> {
        ReCenter %W %h %w
    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
    $W config -scrollregion [list [expr {-$w/2}] 0 [expr {$w/2}] $h]
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
            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]
    } 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
    regsub -all {\s} $sdata {} sdata                ;# Bug in base64 package
    sound snd_click
    snd_click data [::base64::decode $sdata]
    .sound config -state normal


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