[NEM] ''26 Mar 2003'' - Here is a little game I've started putting together to simulate the game of pool. I might also make it so you can play snooker or billiards, or one of the other pool variations. This is just the beginnings, as I try to get it all working. Most of the physics has been taken from [Colliding Balls], with a bit extra (friction, etc) added by me. The physics I've added is not particularly true to nature, but it is reasonably realistic, and easy to calculate.

Any suggestions, bug fixes, etc much appreciated. Please remember, though, that this is still a work in progress.

This is 8-ball pool, using the rules at the English Pool Association: http://www.epa.org.uk/wrules.htm , although I haven't done much to implement those rules yet. I am going to try and create an abstract way to enter the rules, so that it can be adapted for different games easily (you can already specify the initial layout of the balls at start).

Oh, yes - almost forgot to tell you how to play: At the start click anywhere below the white line to place the cue ball. Then click on the table to take a shot - the cue ball will move towards where you clicked. The longer you hold down the mouse the more force behind the shot. If you pot the cue ball click below the line again to replace it on the table.

'''Known Issues'''

   * Copying and pasting this into a tclsh from this page gave weird results, with the collision detection not working at all. If this happens to you, save the text into a file and then run that. Not sure what has caused this.
   * The score boxes to the right never change! Not implemented yet.
   * Sometimes (particularly if you hit really hard) the cue ball passes straight through the other balls. This is because of the collision detection algorithm used. I'm gonna say this is a feature, as [DKF] said in the chatroom that I'd be done when you could get the cue ball to jump balls for a trick shot ;) Also, if any of the balls are moving fast enough they can pass through the cushions!


----
 #!/bin/sh
 # Next line restarts with Tcl \
 exec tclsh "$0" ${1+"$@"}
 
 # TkPool --
 #
 #   A "simple" simulation of the game of Pool using Tcl/Tk. Based on the ideas
 #   and code from Colliding Balls: http://wiki.tcl.tk/8573 by David Easton.
 
 package require Tcl 8.4
 package require Tk 8.4
 
 namespace eval tkpool {
     # List of created balls
     variable balls {}
     # Unique id for creating balls
     variable uniqueid 0
     # Mapping from id to name
     variable id2name
 
     variable radius 10 
     variable mass   10
     # The friction coefficient of the surface
     variable fcoefficient 0.01
 
     # The dimensions of the main window - reduce this number to reduce size of
     # the table and balls
     variable scale 1.0
 
     set radius [expr {$radius * $scale}]
 
     namespace export ball
 }
 
 
 # Representation of state associated with a ball
 proc tkpool::ball {canvas xpos ypos mass colour} {
     variable balls
     variable uniqueid
     variable radius
     variable id2name
 
     # Create a unique name for this ball
     set name "ball[incr uniqueid]"
     lappend balls $name
     # And a command to access it from
     interp alias {} ::$name {} ::tkpool::ball_cmd $name
 
     # Create the state of this ball
     variable $name
     upvar 0 $name state
     set state(pos) [list $xpos $ypos]
     set state(vel) [list 0.0 0.0]
     set state(mass) $mass
     set state(colour) $colour
 
     set x1 [expr {$xpos - $radius}]
     set x2 [expr {$xpos + $radius}]
     set y1 [expr {$ypos - $radius}]
     set y2 [expr {$ypos + $radius}]
 
     set state(id) [$canvas create oval $x1 $y1 $x2 $y2 \
         -outline black -fill $colour -tags [list $name ball]]
 
     set id $state(id)
     set id2name($id) $name
 }
 
 proc tkpool::ball_cmd {name cmd args} {
     variable balls
     variable $name
     upvar 0 $name state
 
     switch $cmd {
         set    {
             if {[llength $args] == 1} {
                 return $state([lindex $args 0])
             } elseif {[llength $args] == 2} {
                 set state([lindex $args 0]) [lindex $args 1]
             } else {
                 return -code error "wrong # args"
             }
         }
         unset   {
             unset state([lindex $args 0])
         }
         delete {
             set idx [lsearch $balls $name]
             catch {
                 set balls [lreplace $balls $idx $idx]
             }
             .c delete $state(id)
             unset state
         }
         default {
             return -code error "unknown command \"$cmd\""
         }
     }
 }
  
 #
 # Given the initial velocities and masses calculates the velocities following
 # a collision.
 proc tkpool::postColVels {u1 u2 m1 m2} {
     # No collision if velocity of ball2 > velocity of ball1
     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} {
         return -code error "no solution"
     } else {
         set root [expr {sqrt($p-$r)}]
 
         set v1 [expr {($q - $root) / $s}]
         set v2 [expr {$b - ($M * $v1)}]
 
         return [list $v1 $v2]
     }
 }
 
 proc tkpool::checkForCollisions {canvas ball} {
     variable radius
     variable id2name
     global State
 
     set didCollide 0
     set overlapList [list]
 
     foreach {ourX ourY} [$ball set pos] {break}
 
     set searched [list [$ball set id]]
     set id [$canvas find closest $ourX $ourY $radius [$ball set id]]
 
     while {[lsearch $searched $id] == -1} {
         if {[lsearch -glob [$canvas gettags $id] "ball*"] > -1} {
             set didCollide 1
             lappend overlapList $id
         } elseif {[lsearch [$canvas gettags $id] "pocket"] > -1} {
             # Ball has been potted
             pot $canvas $ball
             break
         }
         lappend searched $id
         set id [$canvas find closest $ourX $ourY $radius $id]
     }
 
     if {[llength $overlapList] > 0} {
         foreach id $overlapList {
             collide $ball $id2name($id)
         }
     }
 
     return $didCollide
 }
  
 # Called when a ball is potted.
 proc tkpool::pot {canvas ball} {
     global State
     # See which ball has been potted.
     set colour [$ball set colour]
     set player "player$State(currentp)"
     set other "player[expr {3 - $State(currentp)}]"
 
     if {$ball eq $::cue} {
         puts "Potted the cue ball!"
         set State(state) start
     } else {
         puts "$colour ball potted!"
     }
     $ball delete
 }
 
 proc tkpool::move {canvas} {
     variable balls
     variable fcoefficient
     variable scale
 
     set canvasHeight [winfo height $canvas]
     set canvasWidth  [winfo width $canvas]
 
     foreach ball $balls {
 
         foreach {xpos ypos} [$ball set pos] {break}
         foreach {xvel yvel} [$ball set vel] {break}
 
         # Take friction into account
         set mass [$ball set mass]
         set decel [expr {$fcoefficient * $mass}]
 
         if {$xvel != 0.0} {
             set phi [expr {atan(abs($yvel / $xvel))}]
 
             set vel [expr {sqrt(pow($xvel,2) + pow($yvel,2))}]
             set vel [expr {$vel - $decel}]
 
             if {$vel < 0.0} {
                 set vel 0.0
             }
 
             if {$xvel < 0.0} {
                 set xvel [expr {-1.0 * $vel * cos($phi)}]
             } else {
                 set xvel [expr {$vel * cos($phi)}]
             }
             if {$yvel < 0.0} {
                 set yvel [expr {-1.0 * $vel * sin($phi)}]
             } else {
                 set yvel [expr {$vel * sin($phi)}]
             }
         }
 
         set xpos [expr {$xpos + $xvel}]
         set ypos [expr {$ypos + $yvel}]
 
         $canvas move $ball $xvel $yvel
 
         # Bounce off edges
         foreach {x1 y1 x2 y2} [$canvas bbox $ball] {break}
 
         # Left edge
         if {$x1 < (10 * $scale) && $xvel < 0} {
             set xvel [expr {-1.0 * $xvel}]
         } 
         if {$x2 > ($canvasWidth - (10 * $scale)) && $xvel > 0} {
             set xvel [expr {-1.0 * $xvel}]
         }
         if {$y1 < (10 * $scale) && $yvel < 0} {
             set yvel [expr {-1.0 * $yvel}]
         } 
         if {$y2 > ($canvasHeight - (10 * $scale)) && $yvel > 0} {
             set yvel [expr {-1.0 * $yvel}]
         }
 
 
         set ret [checkForCollisions $canvas $ball]
         if {$ret == 2} {
             # Potted the cue ball
         } elseif {$ret == 1} {
             # Collided
             $ball set pos [list $xpos $ypos]
         } else {
             $ball set pos [list $xpos $ypos]
             $ball set vel [list $xvel $yvel]
         }
 
     }
 
     after 50 [list ::tkpool::move $canvas]
 }

 proc tkpool::collide {ball1 ball2} {
 
     foreach {x1 y1} [$ball1 set pos] {break}
     foreach {x2 y2} [$ball2 set pos] {break}
 
     # Always call ball on right (2) and one on left (1)
     if {$x1 > $x2} {
         set temp $ball2
         set ball2 $ball1
         set ball1 $temp
 
         foreach {x1 y1} [$ball1 set pos] {break}
         foreach {x2 y2} [$ball2 set pos] {break}
     }
 
     # Get velocity of each ball
     foreach {ux1 uy1} [$ball1 set vel] {break}
     foreach {ux2 uy2} [$ball2 set vel] {break}
 
     # Work out angle of collision
     set diffX [expr {1.0 * ($x2 - $x1)}]
     set diffY [expr {1.0 * ($y2 - $y1)}]
 
     if {$diffX == 0.0} {
         set diffX 0.0000001
     } 
     set phi [expr {atan($diffY / $diffX)}]
 
     # Work out 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 [$ball1 set mass]
     set mass2 [$ball2 set mass]
 
     foreach {vparr1 vparr2} [postColVels $uparr1 $uparr2 $mass1 $mass2] \
         {break}
 
     # Perpendicular velocities are unchanged
     set vperp1 $uperp1
     set vperp2 $uperp2
 
     # 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 new velocities
     $ball1 set vel [list $vx1 $vy1]
     $ball2 set vel [list $vx2 $vy2]
 }
 
 #
 # Racks the balls on the table, using the positions indicated. The positions
 # argument should be a list of lists, where each element is a letter or x
 # (meaning no ball in this position). The rows go from the back to the front.
 # Here is English pool setup:
 # {
 #  {y r y y r}
 #  { r y r y }
 #  {x y b r x}
 #  { x r y x }
 #  {x x r x x}
 # }
 proc tkpool::rack {canvas mass positions} {
     variable radius
     variable balls
     variable numred
     variable numyellow
     global cue
 
     foreach ball $balls {
         $ball delete
     }
 
     set w [winfo width $canvas]
     set h [winfo height $canvas]
 
     set x0 [expr {($w /2.0) - (4 * $radius)}]
     set y0 [expr {int(($h / 4) - ($radius * 4))}]
 
     for {set i 0} {$i < 5} {incr i} {
         # Calculate row offset
         if {($i % 2) != 0} {
             set offset [expr {int($radius)}]
         } else {
             set offset 0
         }
         foreach item [lindex $positions $i] {
             switch $item {
                 x   { }
                 y   { ball $canvas [expr {$x0 + $offset}] \
                                    $y0 $mass yellow
                 }
                 r   { ball $canvas [expr {$x0 + $offset}] \
                                     $y0 $mass red
                 }
                 b   { ball $canvas [expr {$x0 + $offset}] \
                                     $y0 $mass black
                 }
                 default { return -code error "unknown identifier \"$item\""}
             }
             incr offset [expr {int($radius * 2.0)}]
         }
         incr y0 [expr {int($radius * 2.0)}]
     }
     set ::State(state) start
     set ::State(red) 7
     set ::State(yellow) 7
 }
 
  #
 # If taking a shot, start a timer to determine the power of the shot
 proc tkpool::mousedown {} {
     variable timer
     variable power 0
 
     global State
     if {$State(state) ne "start"} {
         set timer [after 20 [list tkpool::powerup]]
     }
 }
 
 proc tkpool::powerup {} {
     # Show a visual display of the power
     variable power
     variable timer
 
     incr power
     if {$power > 30} { set power 0 }
 
     set ::powerup [string repeat \u258a $power]
 
     set timer [after 20 [list tkpool::powerup]]
 }
 
 proc tkpool::mouseup {canvas x y} {
     global cue
     global State
     variable timer
     variable power
     variable scale
     variable mass
 
     if {$State(state) eq "start"} {
         # Must be behind the line
         if {$y < (480 * $scale)} {
             puts "Must start from behind the line"
             return
         }
         set cue [tkpool::ball $canvas $x $y [expr {$mass * 1.5}] white]
         set State(state) "game"
     } else {
         after cancel $timer
         set ::powerup ""
 
         # Work out component velocities.
         foreach {oldx oldy} [$cue set pos] {break}
         set diffX [expr {1.0 * ($x - $oldx)}]
         set diffY [expr {1.0 * ($y - $oldy)}]
 
         set vel [expr {sqrt(pow($diffX,2) + pow($diffY,2))}]
         set ratio [expr {$power/$vel}]
 
         set xvel [expr {$ratio * $diffX}]
         set yvel [expr {$ratio * $diffY}]
 
         $cue set vel [list $xvel $yvel]
     }
 }
 
 # Draw some pockets onto the canvas
 proc tkpool::drawpockets {canvas} {
     variable radius
     variable scale
 
     set r [expr {$radius + 5}]
 
     set w [winfo width $canvas]
     set h [winfo height $canvas]
 
     set inset [expr {10 * $scale}]
     $canvas create rectangle 0 0 $inset $h -fill SeaGreen
     $canvas create rectangle 0 0 $w $inset -fill SeaGreen
     $canvas create rectangle [expr {$w - $inset}] 0 $w $h -fill SeaGreen
     $canvas create rectangle 0 [expr {$h - $inset}] $w $h -fill SeaGreen
 
     $canvas create oval [expr {0 - $r}] [expr {0 - $r}] \
         [expr {1.5 * $r}] [expr {1.5 * $r}] -fill black -tags [list pocket]
     $canvas create oval [expr {$w - 1.5 * $r}] [expr {0 - $r}] \
         [expr {$w + $r}] [expr {1.5 * $r}] -fill black -tags [list pocket]
     $canvas create oval [expr {0 - $r}] [expr {$h - 1.5 * $r}] \
         [expr {1.5 * $r}] [expr {$h + $r}] -fill black -tags [list pocket]
     $canvas create oval [expr {$w - 1.5 * $r}] [expr {$h - 1.5 * $r}] \
         [expr {$w + $r}] [expr {$h + $r}] -fill black -tags [list pocket]
 
     set mid [expr {$h / 2}]
     $canvas create oval [expr {0 - $r}] [expr {$mid - $r}] \
         $r [expr {$mid + $r}] -fill black -tags [list pocket]
     $canvas create oval [expr {$w - $r}] [expr {$mid - $r}] \
         [expr {$w + $r}] [expr {$mid + $r}] -fill black -tags [list pocket]
 }
  proc tkpool::about {} {
     # Popup an about box
     tk_messageBox -title "About TkPool V0.2" -icon info \
         -message "A simple Tcl/Tk pool game\nBy Neil Madden\nhttp://wiki.tcl.tk/TkPool\nPublic Domain"
 }
 
 # Create a frame to show the players' scores
 frame .info
 
 labelframe .info.p1 -text "Player 1"
 label .info.p1.colour -text "Colour:"
 label .info.p1.col -textvariable State(player1,colour)
 label .info.p1.score -text "Score:"
 label .info.p1.scr -textvariable State(player1,score)
 
 labelframe .info.p2 -text "Player 2"
 label .info.p2.colour -text "Colour:"
 label .info.p2.col -textvariable State(player2,colour)
 label .info.p2.score -text "Score:"
 label .info.p2.scr -textvariable State(player2,score)
 
 labelframe .info.turn -text "Turn"
 label .info.turn.t -textvariable State(currentplayer)
 
 labelframe .info.power -text "Power"
 label .info.power.p -textvariable ::powerup -fg navy -anchor w -width 25
 
 array set State {
     player1,colour      ""
     player1,score       0
     player2,colour      ""
     player2,score       0
     currentplayer       "Player 1"
     currentp            1
     state               start
     red                 7
     yellow              7
 }
 
 pack .info.p1.colour .info.p1.col -anchor w
 pack .info.p1.score .info.p1.scr -anchor w
 pack .info.p2.colour .info.p2.col -anchor w
 pack .info.p2.score .info.p2.scr -anchor w
 
 pack .info.p1 -anchor n -fill x
 pack .info.p2 -anchor n -fill x
 
 pack .info.turn.t -fill both
 pack .info.turn -anchor n -fill x
 
 pack .info.power.p -fill both
 pack .info.power -anchor n -fill x
 
 
 pack .info -side right -fill y
 
 set scale $tkpool::scale
 set canvas [canvas .c -bg darkgreen -width [expr {300 * $scale}] \
     -height [expr {600 * $scale}]]
 pack $canvas
 
 set layout {
       {y r y y r}
       { r y r y }
       {x y b r x}
       { x r y x }
       {x x r x x}
 }
 
 button .info.rerack -text "Re-Rack" -command \
     [list tkpool::rack $canvas $tkpool::mass $layout] -width 15
 
 button .info.quit -text "Quit" -command exit -width 15
 button .info.about -text "About" -command tkpool::about -width 15
 
 pack .info.quit -side bottom -padx 5 -pady 5
 pack .info.rerack -side bottom -padx 5 -pady 5
 pack .info.about -side bottom -padx 5 -pady 5
 
 
 wm resizable . 0 0
 wm title . "TkPool V0.2"
 
 update
 
 # Draw the spot and line
 set p [expr {[winfo width $canvas]/2.0}]
 $canvas create oval [expr $p-3] [expr $p-3] [expr $p+3] [expr $p+3]\
     -fill white -outline white
 
 set p [expr {[winfo height $canvas] * 0.8}]
 $canvas create line 0 $p [winfo width $canvas] $p -fill white 
 
 tkpool::drawpockets $canvas
 
 # Create some balls
 tkpool::rack $canvas $tkpool::mass $layout
 
 # Create the cue ball - with a slightly larger mass
 bind $canvas <ButtonPress-1> [list tkpool::mousedown]
 bind $canvas <ButtonRelease-1> [list tkpool::mouseup $canvas %x %y]
 
 tkpool::move $canvas
 

----
[Category Games]