Version 15 of Colliding balls

Updated 2003-04-03 21:35:15

David Easton: 17 Mar 2003 Bouncing Balls inspired me to post a little application I wrote to show balls that bounce off each other as well as the edges of the canvas.

Ed Suominen: 25 Mar 2003 This is great! There are some pretty advanced calculations going on here.

David Easton: 26 Mar 2003 Thanks! The calculations used by postColVels come from conservation of energy and momentum. colide resolves velocities parallel and perpendicular to the collision. Thus, this should be a fairly accurate simulation.


NEM - I have been inspired by this, and a conversation in the chatroom, to create the start of a small pool/snooker/billiards game, which I have called TkPool.


 #
 # Colliding Balls
 # Author: David Easton
 #

 package require Tk

 #
 # Return an entry from the list at random
 #
 proc randFromList { inputList } {

     set index [expr int(rand() * [llength $inputList])]
     return [lindex $inputList $index]
 }

 #
 # Given the initial velocities and masses
 # calculates velocities following a collision
 #
 proc postColVels { u1 u2 m1 m2 } {

     # No collision if u2 > u1
     if { $u2 > $u1 } {
         return [list $u1 $u2]
     }

     set u1 [expr 1.0 * $u1]
     set u2 [expr 1.0 * $u2]
     set m1 [expr 1.0 * $m1]
     set m2 [expr 1.0 * $m2]

     set M [expr $m1 / $m2]

     set b [expr ($M * $u1) + $u2]
     set c [expr ($M * $u1 * $u1) + ($u2 * $u2)]

     set q [expr 2 * $M * $b]
     set p [expr 4 * $M * $M * $b * $b]
     set r [expr 4 * ($M + ($M * $M)) * (($b * $b) - $c)]
     set s [expr 2 * ($M + ($M * $M))]

     if { $r > $p } {
         "No solution"
     } else {

         set root [expr sqrt($p -$r)]

 #        set v1(1) [expr ($q + $root) / $s]
         set v1(2) [expr ($q - $root) / $s]

 #        set v2(1) [expr $b - ($M * $v1(1))]
         set v2(2) [expr $b - ($M * $v1(2))]

         # v2 should always be greater than v1
         # which means the answer is always v1(2) and v2(2)

         return [list $v1(2) $v2(2)]
     }
 }

 proc createBall { tag } {

     global State

     set radius [expr int((30 * rand()) + 20)]
     set diam   [expr 2 * $radius]
     # Mass is proportional to area
     set mass   [expr $radius * $radius]

     set canvasHeight [winfo height $State(canvas)]
     set canvasWidth  [winfo width $State(canvas)]

     set xpos [expr $radius + int(($canvasWidth - $diam) * rand())]
     set ypos [expr $radius + int(($canvasHeight - $diam) * rand())]

     set x1 [expr $xpos - $radius]
     set x2 [expr $xpos + $radius]
     set y1 [expr $ypos - $radius]
     set y2 [expr $ypos + $radius]

     # Random colour
     set colList [list red yellow darkgreen green blue lightblue orange pink purple white]
     set colour [randFromList $colList]

     # Now create ball
     set id [$State(canvas) create oval $x1 $y1 $x2 $y2 -outline black -fill $colour -tags [list $tag ball]]

     set State(id2tag,$id) $tag

     set xvel [expr (rand() * 8.0) -2]
     set yvel [expr (rand() * 8.0) -2]

     set State(pos,$tag) [list $xpos $ypos]
     set State(vel,$tag) [list $xvel $yvel]
     set State(rad,$tag) $radius
     set State(mass,$tag) $mass
 }

 #
 # Check if we have collided with another ball
 #
 # Returns: 1 - If there was a collision
 #          0 - If no collision
 #
 proc checkForCollision { tag } {

     global State

     set didCollide 0

     set overlapList {}

     foreach {ourX ourY} $State(pos,$tag) {}

     set ourId [$State(canvas) find withtag $tag]

     set id [$State(canvas) find closest $ourX $ourY $State(rad,$tag) $ourId]

     while { $id != $ourId } {

         if { [lsearch -glob [$State(canvas) gettags $id] "ball*"] > -1 } {

             set didCollide 1
             lappend overlapList $id
         }
         set id [$State(canvas) find closest $ourX $ourY $State(rad,$tag) $id]
     }

     if { [llength $overlapList] > 0 } {

         foreach id $overlapList {

             collide $tag $State(id2tag,$id)
         }
     }

     return $didCollide
 }

 proc moveBalls { } {

     global State

     set canvasHeight [winfo height $State(canvas)]
     set canvasWidth  [winfo width $State(canvas)]

     foreach ball $State(ballList) {

         foreach {xpos ypos} $State(pos,$ball) {}
         foreach {xvel yvel} $State(vel,$ball) {}

         set xpos [expr $xpos + $xvel]
         set ypos [expr $ypos + $yvel]

         $State(canvas) move $ball $xvel $yvel

         # Bounce off the edges

         foreach {x1 y1 x2 y2} [$State(canvas) bbox $ball] {}

         # Left edge
         if { $x1 < 0 && $xvel < 0} {
             set xvel [expr -1.0 * $xvel]
         }
         if { $x2 > $canvasWidth && $xvel > 0} {
             set xvel [expr -1.0 * $xvel]
         }
         if { $y1 < 0 && $yvel < 0} {
             set yvel [expr -1.0 * $yvel]
         }
         if { $y2 > $canvasHeight && $yvel > 0} {
             set yvel [expr -1.0 * $yvel]
         }

         if {[checkForCollision $ball]} {

             # Collided
             set State(pos,$ball) [list $xpos $ypos]

         } else {

             # Update for new position and velocity

             set State(pos,$ball) [list $xpos $ypos]
             set State(vel,$ball) [list $xvel $yvel]
         }
     }

     after 50 moveBalls
 }

 proc collide { tag1 tag2 } {

     global State

     # Get position of each ball

     foreach {x1 y1} $State(pos,$tag1) {}
     foreach {x2 y2} $State(pos,$tag2) {}

     # Always call the ball on the right (2) and the one on the left (1)

     if { $x1 > $x2 } {

         set temp $tag2
         set tag2 $tag1
         set tag1 $temp

         # Get position of each ball

         foreach {x1 y1} $State(pos,$tag1) {}
         foreach {x2 y2} $State(pos,$tag2) {}
     }

     # Get velocity of each ball

     foreach {ux1 uy1} $State(vel,$tag1) {}
     foreach {ux2 uy2} $State(vel,$tag2) {}

     # Work out the angle along the axis of collision

     set diffX [expr 1.0 * ($x2 - $x1)]
     set diffY [expr 1.0 * ($y2 - $y1)]

     set phi [expr atan ($diffY / $diffX)]

     # Now work out the velocity parallel and perpendicular

     set uparr1 [expr ($ux1 * cos($phi)) + ($uy1 * sin($phi))]
     set uperp1 [expr ($ux1 * sin($phi)) - ($uy1 * cos($phi))]

     set uparr2 [expr ($ux2 * cos($phi)) + ($uy2 * sin($phi))]
     set uperp2 [expr ($ux2 * sin($phi)) - ($uy2 * cos($phi))]

     # If they are not going towards each other, then they will not collide
     if { $uparr2 > $uparr1 } {
         return
     }

     set mass1 $State(mass,$tag1)
     set mass2 $State(mass,$tag2)

     foreach {vparr1 vparr2} [postColVels $uparr1 $uparr2 $mass1 $mass2] {}

     # Perpendicular velocites are unchanged

     set vperp1 $uperp1
     set vperp2 $uperp2

     # Now convert back into x and y movements   
     set vx1 [expr ($vparr1 * cos($phi)) + ($vperp1 * sin($phi))]
     set vy1 [expr ($vparr1 * sin($phi)) - ($vperp1 * cos($phi))]

     set vx2 [expr ($vparr2 * cos($phi)) + ($vperp2 * sin($phi))]
     set vy2 [expr ($vparr2 * sin($phi)) - ($vperp2 * cos($phi))]

     # Update for new velocities

     set State(vel,$tag1) [list $vx1 $vy1]
     set State(vel,$tag2) [list $vx2 $vy2]
 }

 # Seed random number generator
 expr srand([clock clicks])

 # Window things
 wm title . "Bouncing balls"

 # Create canvas
 set State(canvas) [canvas .c -width 500 -height 400]
 pack $State(canvas) -fill both -expand true

 update

 # Create balls
 set State(ballList) [list ball1 ball2 ball3 ball4 ball5 ball6 ball7 ball8]

 foreach ball $State(ballList) {

     createBall $ball
 }

 moveBalls

LH (2003/04/03) Some minor improvements:

The calculations in postColVels can be simplified as follows:

 proc postColVels {u1 u2 m1 m2} {
   set u [expr {2*($m1*$u1+$m2*$u2)/($m1+$m2)}]
   list [expr {$u-$u1}] [expr {$u-$u2}]
 }

In collide, one can do without the fragment

     # Always call the ball on the right (2) and the one on the left (1)
     ...

by changing

     # If they are not going towards each other, then they will not collide
     if { $uparr2 > $uparr1 } {
         return
     }

to

     # If they are not going towards each other, then they will not collide
     if { $x1 != $x2 } {
       if { $x1<$x2 && $uparr2>$uparr1 || $x1>$x2 && $uparr2<$uparr1 } return
     } else {
       if { $y1<$y2 && $uparr2>$uparr1 || $y1>$y2 && $uparr2<$uparr1 } return
     }

In collide, the angle of the collision axis is computed by

     set diffX [expr 1.0 * ($x2 - $x1)]
     set diffY [expr 1.0 * ($y2 - $y1)]

     set phi [expr atan ($diffY / $diffX)]

Unfortunately, phi is undefined if diffX is zero. A correct version:

     if { $x1 != $x2 } {
       set phi [expr {atan(double($y2-$y1)/double($x2-$x1))}]
     } else {
       set phi [expr {asin(1)}] ;# 90 degrees
     }

In checkForCollision, an infinite loop is possible. This is quite a subtle bug that manifest rather rarely. Details below.

The following code is used to find other balls that overlap with the given tag ball:

     foreach {ourX ourY} $State(pos,$tag) {}

     set ourId [$State(canvas) find withtag $tag]

     set id [$State(canvas) find closest $ourX $ourY $State(rad,$tag) $ourId]

     while { $id != $ourId } {

         ...
         set id [$State(canvas) find closest $ourX $ourY $State(rad,$tag) $id]
     }

Unfortunately, the loop does not always terminate. This is caused by the line

     foreach {ourX ourY} $State(pos,$tag) {}

that is supposed to compute the center point of the tag ball. The problem is that the tag ball has been moved on canvas by its velocity vector (in moveBalls) without updating the State(pos,$tag), so its real center is somewhere else:

     foreach {x1 y1 x2 y2} [$State(canvas) coords $tag] break
     set ourX' [expr {($x1+$x2)/2.0}]
     set ourY' [expr {($y1+$y2)/2.0}]

In most circumstances the points (ourX,ourY) and (ourX,ourY) are very close and the difference has no visible effects during animation. However, if (ourX,ourY) happens to be outside the tag ball and close to another ball, say B, then find closest statement will constantly return B. As a consequence, the loop's guard will stay true forever (or rather till we kill Colliding Balls :). The following version of checkForCollision seems to be correct:

 proc checkForCollision { tag } {

     global State
     set c $State(canvas)
     set r $State(rad,$tag)

     foreach { x1 y1 x2 y2 } [$c coords $tag] break
     set x [expr {($x1+$x2)/2.0}]
     set y [expr {($y1+$y2)/2.0}]

     set overlapList [list]
     set id [set ourId [$c find withtag $tag]]
     $c raise $tag ;# not sure whether really needed
     while { [set id [$c find closest $x $y $r $id]] != $ourId } {
         lappend overlapList $id
     }

     if { [llength $overlapList] > 0 } {
         foreach id $overlapList {
             collide $tag $State(id2tag,$id)
         }
         return 1
     }

     return 0
 }

Also, it is easy to add some configurable parameters that control the number of balls, their sizes, colours and velocities. For details, have a look at Colliding Coins.


[ Category Graphics

Category Animation ]