[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].
[http://www.tcl.tk/starkits/marbles.jpg]
[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://wiki.tcl.tk/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)]
upbindat .c <Configure> {
DrawPegs
DrawSums
DrawRamps
DoSounds
bind .c <Configure> { ReCenter %W %h %w
Go
}
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
Clear
$W config -scrollregion [list [expr {-$w/2}] 0 [expr {$w/2}] $h]
DrawRamps
DrawSums
}
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
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] {
set id [lindex [split $ball ","] 0]
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
}
DoDisplayGo
======
----
[GN] 2004-07-30 : wow - Uses 80% + of my dual 2.0G5s cpu in max speed
<<categories>> Graphics | Application | Whizzlet | Animation