[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 {console show} bind .c {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 ---- [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. ---- [Category Graphics] | [Category Application] | [Category Whizzlet]