Version 9 of Falling Marbles

Updated 2003-05-02 19:14:21

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 (or was it from gifBalls?).

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


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 - added better resizing behavior, sound, more controls
 #

 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}

 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(new) $S(psteps)                           ;# How often new balls come in

 proc DoDisplay {} {
    global S

    # see http://mini.net/tcl/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}
    pack .c -in .screen -side left -fill both -expand 1

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

    update
    DrawPegs
    DrawSums
    DrawRamps
    DoSounds
    bind .c <Configure> {ReCenter %W %h %w}
 }
 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]

    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 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
    foreach {X0 Y0 X1 Y1} [.c cget -scrollregion] break

    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
        }
    }
    set S(rows) $row

    .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

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

    for {set row 0} {1} {incr row} {
        foreach {x y} $PEG(0,$row) break
        if {$y > $bottom} break
    }
    set S(rows) $row                            ;# Number of visible rows
    .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

    .c delete ramp door
    foreach {X0 Y0 X1 Y1} [.c cget -scrollregion] break
    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} {
    foreach {x0 y0} $::B($id,xy) break          ;# Where it is now
    foreach {x y} $xy break                     ;# 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"} {
        foreach {x y} $S(entry,$B($id,peg)) break
        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"} {
        foreach {x1 y1} $PEG(0,0) break
        set dx [expr {$step * ($x1 - $S(drop,x)) / $S(dsteps)}]
        set dy [expr {$step * ($y1 - $S(drop,y)) / $S(dsteps)}]
        set x [expr {$S(drop,x) + $dx}]
        set y [expr {$S(drop,y) + $dy}]
        return [list $x $y]
    }
    foreach {x y} $PEG($B($id,peg)) break       ;# 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 -$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}]
    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]
    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"
        }
    } 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"
            set B($id,peg) "0,0"                ;# Peg we're at
        }
    } elseif {$B($id,where) == "peg"} {
        if {$B($id,step) >= $S(psteps)} {       ;# Hit the next peg
            foreach {col row} [split $B($id,peg) ","] break
            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] {
            foreach {id _} [split $ball ","] break
            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
 Go

Category Graphics | Category Application | Category Whizzlet

Category Animation