Version 2 of Colliding Spheres
Updated 2003-09-12 18:20:41David Easton 12 Sept 2003 - The saga continues: first Bouncing Balls, then Colliding Balls, then Colliding Coins and now Colliding Spheres.
This merges Colliding Coins by Leszek Holenderski (based on Colliding Balls by David Easton) with Spheres from Ulis.
Note: The spheres still have a mass proportional to area because the small spheres were found to travel very fast with mass proportional to volume.
#
# 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]
pack $canvas -fill both -expand true
# 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
update
animate $numOfCoins