Updated 2016-05-09 19:14:37 by pmarin

David 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.

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