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