MPJ ~ I likes this on the desktop so I decided to try it out on my PocketPC. I changed the maxsize and numbers and scaled the screen to full size. Below is a screen shot of the results and my updates for the PocketPC [1] . (Note: that that some of the sphere images are messed up this is a problem with the current port to the PocketPC)
This is cool. I think it should be part of the tk widget demo to show how interesting animations can be done with the canvas.
#
# Colliding Spheres by David Easton, http://wiki.tcl.tk/9860
# Based on: Colliding Coins by Leszek Holenderski, http://wiki.tcl.tk/8709
# Spheres by Ulis, http://wiki.tcl.tk/9847
#
package require Tk 8.4
# configurable parameters
#
set canvasWidth 600 ;# in pixels
set canvasHeight 500 ;# in pixels
set numOfCoins 20
set minRadius 10 ;# in pixels
set maxRadius 40 ;# in pixels
set maxVelocity 5 ;# in pixels, per one animation step
set delay 20 ;# in milliseconds, per one animation step
set colours [list 1,1,1 1,1,0 1,0,1 0,1,1 1,0,0 0,1,0 0,0,1 0,0.5,0]
set light 1.0
set source 0.0
# Gradient proc from Ulis, http://wiki.tcl.tk/9847
#
proc gradient {image relief light source red green blue} {
set sunken [string match sun* $relief]
set light [expr {$light * 96 + 32}]
set source [expr {0.5 + $source / 2.0}]
set D [image width $image]
set R [expr {$D / 2}]
set R2 [expr {$R * $R}]
for {set y 0} {$y < $D} {incr y} \
{
set Dy2 [expr {($y - $R) * ($y - $R)}]
set dy [expr {($y * $source - $R)}]
set dy2 [expr {$dy * $dy}]
for {set x 0} {$x < $D} {incr x} \
{
set Dx2 [expr {($x - $R) * ($x - $R)}]
set Dxy [expr {$Dx2 + $Dy2}]
if {$Dxy <= $R2} \
{
set dx [expr {($x * $source - $R)}]
set dx2 [expr {$dx * $dx}]
set dxy [expr {$dx2 + $dy2}]
set color [expr {int(127 + $light * (1.0 - ($dxy / $R2 / 1.5)))}]
if {$sunken} { set color [expr {int(127 + $light * 2 - $color)}] }
set color [format "#%02x%02x%02x" [expr {int($color*$red)}] \
[expr {int($color*$green)}] \
[expr {int($color*$blue)}]]
$image put $color -to [expr {$D - $x}] [expr {$D - $y}]
}
}
}
}
# coins are identified by their canvas id, and not special tags
#
proc createCoin {} {
# pick random radius and colour
set r [expr {$::minRadius+int(rand()*($::maxRadius-$::minRadius))}]
set d [expr {2*$r}]
# to simulate Big Bang, all coins are created in the canvas' center
set x [expr {$::canvasWidth/2.0}]
set y [expr {$::canvasHeight/2.0}]
set c [lindex $::colours [expr {int(rand()*[llength $::colours])}]]
foreach {red green blue} [split $c ,] {break}
set image [image create photo -width $d -height $d]
gradient $image raised $::light $::source $red $green $blue
set coin [$::canvas create image $x $y -anchor c -image $image]
# pick random velocity
set u [expr {$::maxVelocity*(2*rand()-1)}]
set v [expr {$::maxVelocity*(2*rand()-1)}]
# store coin's attributes
global State
set State($coin,pos) [list $x $y]
set State($coin,vel) [list $u $v]
set State($coin,mass) [expr {double($r*$r)}] ;# mass ~ area
return [list $coin $r]
}
# collide a given coin with all other coins that overlap with it
#
proc collide {coin radius} {
# find coin's center
foreach {x y} [$::canvas coords $coin] break
# find other coins that overlap with the given coin
set overlap [list]
$::canvas raise $coin ;# not sure if really needed
set next $coin
while {[set next [$::canvas find closest $x $y $radius $next]] != $coin} {
# Check that centres are within collision range (i.e. not just bbox of image)
foreach {x2 y2} [$::canvas coords $next] break
if {[expr {hypot($x2-$x,$y2-$y) - $radius - $::coinToRad($next)}] < 0} {
lappend overlap $next
}
}
# collide the given coin with other coins
foreach other $overlap { collideCoins $coin $other }
}
# recalculate velocities after collision
#
proc collideCoins {coin1 coin2} {
global State
# get positions and velocities of each coin
foreach {x1 y1} $State($coin1,pos) break
foreach {x2 y2} $State($coin2,pos) break
foreach {u1 v1} $State($coin1,vel) break
foreach {u2 v2} $State($coin2,vel) break
# compute the angle of the collision axis
if { $x1 != $x2 } {
set phi [expr {atan(double($y2-$y1)/double($x2-$x1))}]
} else {
set phi [expr {asin(1)}] ;# 90 degrees
}
set sin [expr {sin($phi)}]
set cos [expr {cos($phi)}]
# project velocities on the axis of collision
# (i.e., get the parallel and perpendicular components)
set par1 [expr {$u1*$cos + $v1*$sin}]
set per1 [expr {$u1*$sin - $v1*$cos}]
set par2 [expr {$u2*$cos + $v2*$sin}]
set per2 [expr {$u2*$sin - $v2*$cos}]
# return if the coins are not going towards each other
if { $x1 != $x2 } {
if { $x1<$x2 && $par2>$par1 || $x1>$x2 && $par2<$par1 } return
} else {
if { $y1<$y2 && $par2>$par1 || $y1>$y2 && $par2<$par1 } return
}
# compute parallel velocities after collision
# (note that perpendicular velocities do not change)
set m1 $State($coin1,mass)
set m2 $State($coin2,mass)
set v [expr {2*($m1*$par1+$m2*$par2)/($m1+$m2)}]
set par1 [expr {$v-$par1}]
set par2 [expr {$v-$par2}]
# convert new velocities back to x and y coordinates
set u1 [expr {$par1*$cos + $per1*$sin}]
set v1 [expr {$par1*$sin - $per1*$cos}]
set u2 [expr {$par2*$cos + $per2*$sin}]
set v2 [expr {$par2*$sin - $per2*$cos}]
# update velocities
set State($coin1,vel) [list $u1 $v1]
set State($coin2,vel) [list $u2 $v2]
}
# perform one animation step
# (no collisions during first $BigBang steps)
#
proc animate {BigBang} {
global State
foreach {coin radius} $::coins {
foreach {u v} $State($coin,vel) break
foreach {x y} $State($coin,pos) break
set newPos [list [expr {$x+$u}] [expr {$y+$v}]]
# bounce off the edges
$::canvas move $coin $u $v
foreach {x1 y1 x2 y2} [$::canvas bbox $coin] break
if { $x1<=0 && $u<0 || $x2>=$::canvasWidth && $u>0} {
set u [expr {-$u}]
}
if { $y1<=0 && $v<0 || $y2>=$::canvasHeight && $v>0} {
set v [expr {-$v}]
}
set State($coin,vel) [list $u $v]
# collide with other coins
if {!$BigBang} { collide $coin $radius }
# update position
set State($coin,pos) $newPos
}
if {$BigBang > 0} {
after $::delay "animate [incr BigBang -1]"
} else {
after $::delay "animate 0"
}
}
# create canvas
wm title . "Colliding Spheres"
set canvas [canvas .c -width $canvasWidth -height $canvasHeight]
# get new canvas size whenever canvas is resized
bind $canvas <Configure> {
set canvasWidth [winfo width %W]
set canvasHeight [winfo height %W]
}
# create coins
for {set i 0} {$i < $numOfCoins} {incr i} {
eval lappend coins [createCoin]
}
array set coinToRad $coins
# start animation: first Big Bang then collisions
bind $canvas <Map> {
animate $numOfCoins
}
pack $canvas -fill both -expand true