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
#!/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
# The friction coefficient of the surface
variable fcoefficient 0.01
namespace export ball
}
# Representation of state associated with a ball.
# Using this little encapsulation technique makes some
# parts of the code easier.
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 [expr rand()*8.0] [expr rand()*8.0]]
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
if {$ball eq $::cue} {
puts "Potted the cue ball!"
$ball set pos [list 150 500]
$ball set vel [list 0.0 0.0]
$canvas coords $ball 140 490 160 510
return 2
} else {
puts "[$ball set colour] ball potted!"
$ball delete
}
}
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
}
proc tkpool::move {canvas} {
variable balls
variable fcoefficient
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 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 < 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}]
}
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 8-ball 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
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 {150 - ($radius * 4)}]
for {set i 0} {$i < 5} {incr i} {
# Calculate row offset
if {($i % 2) != 0} {
set offset $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 {$radius * 2}]
}
incr y0 [expr {$radius * 2}]
}
set ::State(state) start
}
proc tkpool::mousedown {} {
variable time
set time [clock clicks -milliseconds]
}
proc tkpool::mouseup {canvas x y} {
global cue
global State
variable time
if {$State(state) eq "start"} {
# Must be behind the line
if {$y < 480} {
puts "Must start from behind the line"
return
}
set cue [tkpool::ball $canvas $x $y 15 white]
set State(state) "game"
} else {
set newtime [clock clicks -milliseconds]
set speed [expr {($newtime - $time) / 30.0}]
# 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 {$speed/$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
set r [expr {$radius + 5}]
set w [winfo width $canvas]
set h [winfo height $canvas]
$canvas create oval [expr {0 - $r}] [expr {0 - $r}] \
$r $r -fill black -tags [list pocket]
$canvas create oval [expr {$w - $r}] [expr {0 - $r}] \
[expr {$w + $r}] $r -fill black -tags [list pocket]
$canvas create oval [expr {0 - $r}] [expr {$h - $r}] \
$r [expr {$h + $r}] -fill black -tags [list pocket]
$canvas create oval [expr {$w - $r}] [expr {$h - $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]
}
# 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)
array set State {
player1,colour ""
player1,score 0
player2,colour ""
player2,score 0
currentplayer "Player 1"
currentp 1
state start
}
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 -side right -fill y
set canvas [canvas .c -bg darkgreen -width 300 -height 600]
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 10 $layout] -width 15
button .info.quit -text "Quit" -command exit -width 15
pack .info.quit -side bottom -padx 5 -pady 5
pack .info.rerack -side bottom -padx 5 -pady 5
wm resizable . 0 0
wm title . "TkPool V0.1"
# Draw the spot and line
$canvas create oval 147 147 153 153 -fill white -outline white
$canvas create line 0 480 300 480 -fill white
update
tkpool::drawpockets $canvas
# Create some balls
tkpool::rack $canvas 10 $layout
bind $canvas <ButtonPress-1> [list tkpool::mousedown]
bind $canvas <ButtonRelease-1> [list tkpool::mouseup $canvas %x %y]
tkpool::move $canvas