[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. [KPV] 2003-05-02 : added no ramp mode ---- [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 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 {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 {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] 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 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 } } .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 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"} { foreach {id _} [split $a ","] break array unset B $id,* .c delete $id } } if {! $S(ramp)} return 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 {x y} $PEG($B($id,peg)) break ;# 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 foreach {x y} $PEG($B($id,peg)) break ;# Where we land return [list $x $S(bh)] return [list $x $S(drop,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}] ;# 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 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]