Description  edit

See Also  edit

• Exploding Balls
• An Improvement to Colliding Balls, by LH, 3 Apr 2003'', with simpler calculations to find post-collision velocities, and two bug fixes.
• TkPool, a small pool/snooker/billiards agmae by NEM and inspired by this application and a conversation in the chatroom

Changes  edit

Discussion  edit

Code  edit

#! /bin/env tclsh

# Colliding Balls
# Author: David Easton
#   mods by Jeff Hobbs just to brace expr's (improve speed)
#   and clean up some foreach usage
#

package require Tk


#velocity limit
set velocity 8 

#
# Return an entry from the list at random
#
proc randFromList {inputList} {
    return [lindex $inputList [expr {int(rand() * [llength $inputList])}]]
}

#
# 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 } {
    variable velocity
    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() * $velocity) -2}]
    set yvel [expr {(rand() * $velocity) -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]
    set seen [list]
    #if the velocity is higher than the radius of the smallest ball, the
    #[canvas find] command above might cause an endess loop here, so use the
    #extra check for membership in $seen
    while { $id ne $ourId && $id ni $seen} {
       if { [lsearch -glob [$State(canvas) gettags $id] "ball*"] > -1 } {
           set didCollide 1
           lappend overlapList $id
       }
       lappend seen [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) {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) {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) {x2 y2} $State(pos,$tag2) {}
    }

    # Get velocity of each ball

    foreach {ux1 uy1} $State(vel,$tag1) {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]

# Create balls
set State(ballList) [list ball1 ball2 ball3 ball4 ball5 ball6 ball7 ball8]
bind .c <Map> {
    foreach ball $State(ballList) {
        createBall $ball
    }
    moveBalls
}
pack $State(canvas) -fill both -expand true

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References