Version 3 of Falling Marbles

Updated 2003-04-30 04:19:41

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


 ##+##########################################################################
 #
 # Falling Marbles
 # by Keith Vetter, April 2003

 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}

 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 top -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}
    bind .c <Configure> {ReCenter %W %h %w}

    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
    DrawChannels
 }
 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 .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 20 -font [.go cget -font] \
        -variable S(new) -bd 2 -relief ridge -showvalue 1 -label "Birth Rate"
    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 rowconfigure .ctrl 10 -minsize 20
    grid .speed -in .ctrl -sticky ew -row 11
    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} {1} {incr row} {
        set y [expr {$top + $row * $S(yspacing)}]
        if {$y > $bottom} break

        for {set col 0} {$col < 200} {incr col} {
            set x [expr {$col * $S(xspacing)}]
            set PEG($col,$row) [list $x $y]
            set PEG(-$col,$row) [list -$x $y]
            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

    for {set col 0} {$col < 200} {incr col} {
        if {($row & 1) && !($col & 1)} continue ;# Odd row, even column
        if {!($row & 1) && ($col & 1)} continue ;# Even row, odd column

        set x [expr {$col * $S(xspacing)}]
        .c create text $x $y -tag e$col -font {{Times Roman} 8 bold}
        .c create text -$x $y -tag e-$col -font {{Times Roman} 8 bold}
        set SUMS($col) [set SUMS(-$col) ""]
    }
    trace variable SUMS w TraceSums
 }
 proc DrawChannels {} {
    global S

    .c delete channel 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 channel
    .c create poly -$x0 $y0 -$x1 $y1 -$x2 $y2 -$x3 $y3 -$x4 $y4 -$x5 $y5 \
        -tag channel

    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 -$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]
    DrawChannels
 }
 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
            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
            }
            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)} return
    CreateBall
    set delay [expr {(110 - 10*$S(speed)) * $S(new) + round(200 * rand())}]
    after $delay Birth
 }
 DoDisplay
 Go

Category Graphics | Category Application | Category Whizzlet