[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.
'''Screenshot'''
[https://web.archive.org/web/20110617113213/www.cs.nott.ac.uk/~nem/TkPool.gif]
0.4 PocketPC: [WikiDbImage TkPool_ce.jpg]
----[Jeff Smith] 2019-05-13 : Below is an online demo using [CloudTk]
<<inlinehtml>>
<iframe height="650" width="600" src="https://cloudtk-app.tcl-lang.org/cloudtk/VNC?session=new&Tk=TkPool" allowfullscreen></iframe>
<<inlinehtml>>
----
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. ''Should be fixed in V0.2''.
* 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! ''This is a bit better in the soon to be release V0.3 - I increased the frame rate, so the distance moved each frame is smaller''
* Rounded ends of cushions behave just like the straight parts of the cushions for calculating rebound angles.
'''Change Log'''
* '''0.1''' ''26 Mar 2003'' - Initial release. Buggy, but general physics done.
* '''0.2''' ''27 Mar 2003'' - Some bug fixes. Added cushions, About box, and power meter. Added a "scale" variable to allow the GUI to be scaled to fit on smaller/larger displays. All sizes (table, balls etc) are scaled by this factor. '''Note''' Currently, the power of shots is not scaled by this factor, so users on small screens will have to be careful about hitting things too hard.
* '''0.3''' ''27 Mar 2003'' - A few more tweaks here and there. Scale can now be specified on the command line. Tidied up a few bits of the code. Adjusted the friction and power levels to try and make the game more realistic. Needs more work.
* '''0.4''' ''28 Mar 2003'' - Made the code more efficient by making it only draw balls which are actually moving. This also allows the code to know when all the balls have finished moving, so that in future I can prevent taking a new shot before that last has finished. Added "hot-spots" to the pockets, so that it is harder to pot. Changed default radius to 9 from 10 - better proportion.
* '''0.5''' ''28 Mar 2003'' - Rewrote the power meter. More bug fixes. Added a dump-state binding (press 'd').
* '''0.6''' ''28 Mar 2003'' - Fixed another bug. Thanks to escargo for the bug report. Added more information to the dump for debugging.
* '''0.7''' ''29 Mar 2003'' - Major overhaul of how the cushions are drawn and how collisions are detected with the cushions. Before, it was possible to bounce off the actual pocket in some situations. This shouldn't happen now. Currently, the rounded ends of the cushions are taken to be flat for the purposes of calculating the collision reactions. It's quite tricky to work out the angle of the surface with the current collision detection algorithm. You can now only take a shot, or reposition the cue ball (after potting it), when all the balls have stopped moving.
* '''0.7.1''' ''29 Mar 2003'' - New versioning scheme. Added a binding to allow easier lining up of shots (use the right mouse button). Improved the look and action of the power meter.
''[escargo] 28 Mar 2003'' - I used [wish-reaper] to download TkPool. When I tried it, one ball
moved off of the table all by itself. It did not stop at the top of the table; it just kept
going. I don't know how much work it might be, but you might want to add a ''data dump'' button
where a user can save the state of the game for analysis. That way I could have done a snapshot
of the data as the ball moved autonomously off the table; that might simplify the process of
finding out why. Just a thought.
''[NEM] 28 Mar 2003'' - Good idea. I've seen this bug a couple of times, but I thought I'd fixed it. If you see it again, press 'd' and the game will dump the state of all balls to standard output (it'll open the console window on Windows, if needed).
''[escargo] - Where should I e-mail the log and dump files? And how about binding 1 to 9 to power?''
''[NEM]'' - Email them to me. Hmm, I could add key bindings for the power stuff. I'm not sure what advantage this gives over using the mouse (admittedly, it's quite hard to accurately control the power at the moment, I'm working on that).
''[escargo] 29 Mar 2003'' - What you say about a mode where there is a line drawn from the cue
ball to where the cursor is; it would help setting up shots to be more accurate. (I'd really like to go further than that, with lines tangent and normal to the ball that cursor is over, but that
might be helping out a bit too much.)
''[NEM] 29 Mar 2003'' - Done. If you hold down the right mouse button (button 3) a line will be drawn from the cursor to the cue ball position, so you can line up shots a bit easier. Drawing the tangent and normal lines to predict the collision is a bit harder, and I think it does make things a bit ''too'' easy! I've changed the version numbering now, as I was advancing up the version numbers a bit quickly. It will now stay 0.7.x while fixing bugs. 0.8 will happen when the scores etc work.
''[DKF]: 31 Mar 2003 -'' 0.7.1 seems more inclined than 0.4 (the last version I tried) to have balls ending up overlapping (or even leaving) the table. This is annoying if it is the cueball, but virtually impossible if any other ball...
''[NEM]: 31 Mar 2003'' - Hmm.. That is disturbing. It mostly works fine on my computer. There are still a few areas where this happens. It shouldn't have got any ''worse'' since 0.4. I need to come up with a better collision detection strategy, or limit the movement per frame to allow collisions to be more accurately detected. The latter solution would probably result in an unacceptable slow-down, so a new collision detection method is needed (can't use the canvas ''find closest'' method anymore). Well, I'm going to be away from the Internet for most of the next 3 weeks, so if someone wants to contribute something in that time...
''[TV]: 31 Mar 2003'' Nice app, I at times think I'd like to hit the balls like 5 times harder, I didn't get into the cose, which is not so short to cut and paste..
''[DKF]: 31 Mar 2003 -'' I've only ever seen the problem at very high speeds. Perhaps a second test should be made to see if a ball has gone outside the displayed screen; that's always an error case.
As a separate point, it'd be nice if you can only fire a shot if you click within a certain distance of the cue-ball. Right now, it's easier to do a shot right across the table than doing a shot towards something that's close to you. Real pool's the opposite in my experience. Mind you, perhaps that should be a feature that people can turn on for a game if they want...
''[escargo]'' - I have also found that you can click ''within the cue ball itself'' and make the
cue ball move. That hardly seems like rational behavior. I think I have also seen cases where
momentum is not conserved; the cue ball will hit a ball and they both go off in the same direction.
Physically that has to be wrong (until we start being able to put ''spin'' on the balls).
''[RS]'' - Version 0.4 has been adapted to run fine on [Windows/CE] [PocketPC] - available from [http://wiki.tcl.tk/_repo/wiki_images/TkPool.zip] (7KB, 24 KB unwrapped)
''[DKF]'' (10/4/03) - You can get the balls moving the same direction after a collision if the masses are not equal (and the heavier ball moves into the lighter), which I believe is the case here.
''[DKF]'' (22/4/03) - I have a greatly enhanced (well, greatly tinkered with) version here[http://www.man.ac.uk/~zzcgudf/tcl/bitsandpieces/tkpool.tcl] that adds better bouncing off cushions and some knowledge of the actual rules of pool.
''[NEM]'' (22/4/03) - Nice work, Donal! I'm glad someone had time to tinker with this while I'm bogged down with exams/dissertation/graduating and all those other unnecessary inconveniences ;) Almost at 1.0 level now (a few minor tweaks to UI would do it). Then, networked multi-player capabilities for 2.0?
----
======
#!/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
# bgerror handler
proc bgerror {args} {
global errorInfo
puts "=== ERROR ==="
puts "$args"
catch { puts $errorInfo }
tkpool::dump
}
namespace eval tkpool {
# VERSION
variable version "0.7.1"
# List of created balls
variable balls {}
# Unique id for creating balls
variable uniqueid 0
# Mapping from id to name
variable id2name
variable radius 9
variable mass 10
# The friction coefficient of the surface
variable fcoefficient 0.015
# Flag to say if any balls are in motion - if not, then don't bother
# updating them.
variable inMotion 0
# 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\""
}
}
}
proc tkpool::dump {} {
variable balls
variable version
variable radius
variable mass
variable scale
catch {console show}
puts "=== BEGIN DUMP ==="
puts "Version: $version"
puts "Radius: $radius"
puts "Mass: $mass"
puts "Scale: $scale"
puts ""
foreach ball $balls {
puts "Ball $ball"
upvar 0 ::tkpool::$ball state
parray state
puts ""
}
puts "=== END DUMP ==="
}
#
# 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 potted 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
set potted 1
break
}
lappend searched $id
set id [$canvas find closest $ourX $ourY $radius $id]
}
if {$potted} {
pot $canvas $ball
} elseif {[llength $overlapList] > 0} {
foreach id $overlapList {
collide $ball $id2name($id)
}
}
return $didCollide
}
proc tkpool::checkForCushionCollisions {canvas ball} {
variable radius
set didCollide 0
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 [$canvas gettags $id] "cushion"] > -1} {
set didCollide 1
break
}
lappend searched $id
set id [$canvas find closest $ourX $ourY $radius $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
variable inMotion
set canvasHeight [winfo height $canvas]
set canvasWidth [winfo width $canvas]
if {$inMotion} {
set moving 0
foreach ball $balls {
foreach {xpos ypos} [$ball set pos] {break}
foreach {xvel yvel} [$ball set vel] {break}
if {$xvel == 0.0 && $yvel == 0.0} {
# Not moving
continue
} else {
incr moving
}
# Take friction into account
set mass [$ball set mass]
set decel [expr {$fcoefficient * $mass * $scale}]
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)}]
}
} else {
# No horizontal component
if {$yvel > 0.0} {
set yvel [expr {$yvel - $decel}]
if {$yvel < 0.0} {
set yvel 0.0
}
} elseif {$yvel < 0.0} {
set yvel [expr {$yvel + $decel}]
if {$yvel > 0.0} {
set yvel 0.0
}
}
}
set xpos [expr {$xpos + ($xvel / 2.0)}]
set ypos [expr {$ypos + ($yvel / 2.0)}]
$canvas move $ball [expr {$xvel/2.0}] [expr {$yvel/2.0}]
# Bounce off edges
foreach {x1 y1 x2 y2} [$canvas bbox $ball] {break}
# Work out if the ball is overlapping a cushion
if {[checkForCushionCollisions $canvas $ball]} {
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]
}
}
if {$moving == 0} {
# No balls were moving this round
set inMotion 0
}
}
after 25 [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 phi 1.57079632579
} else {
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
variable inMotion
if {$inMotion} {return}
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
variable segments
incr power
# Update power display
set p [expr {$power / 2}]
set colour green
if {$p > 12} {
set colour red
} elseif {$p > 7} {
set colour yellow
}
if {($power % 2) == 1} {
.info.power.p itemconfigure [lindex $segments [expr {$power/2}]] \
-fill $colour
}
if {$power >= 30} {
set timer [after 20 [list tkpool::powerdown]]
} else {
set timer [after 20 [list tkpool::powerup]]
}
}
proc tkpool::powerdown {} {
variable power
variable timer
variable segments
incr power -1
set p [expr {$power/2}]
set colour green
if {$p > 12} {
set colour red
} elseif {$p > 7} {
set colour yellow
}
if {($power % 2) == 1} {
.info.power.p itemconfigure [lindex $segments [expr {$power/2}]] \
-fill #404040
}
if {$power <= 0} {
set timer [after 20 [list tkpool::powerup]]
} else {
set timer [after 20 [list tkpool::powerdown]]
}
}
proc tkpool::mouseup {canvas x y} {
global cue
global State
variable timer
variable power
variable scale
variable mass
variable inMotion
variable segments
if {$inMotion} {return}
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.2}] white]
set State(state) "game"
} else {
after cancel $timer
foreach segment $segments {
.info.power.p itemconfigure $segment -fill #404040
}
$canvas delete cueline
# 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 power [expr {$power * 1.5 * $scale}]
if {$diffX != 0.0} {
set phi [expr {atan(abs($diffY / $diffX))}]
if {$diffX < 0.0} {
set xvel [expr {-1.0 * $power * cos($phi)}]
} else {
set xvel [expr {$power * cos($phi)}]
}
if {$diffY < 0.0} {
set yvel [expr {-1.0 * $power * sin($phi)}]
} else {
set yvel [expr {$power * sin($phi)}]
}
} else {
# No horizontal component
if {$diffY > 0.0} {
set yvel $power
} elseif {$yvel < 0.0} {
set yvel [expr {-1.0 * $power}]
}
}
$cue set vel [list $xvel $yvel]
set inMotion 1
}
}
# 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
foreach size {1.0 0.7} tags {{} {pocket}} color {saddlebrown black} {
$canvas create oval [expr {0 - 1.5 * $size * $r}] [expr {0 - 1.5 * $size * $r}] \
[expr {1.5 * $size * $r}] [expr {1.5 * $size * $r}] -fill $color \
-tags $tags
$canvas create oval [expr {$w - 1.5 * $size * $r}] \
[expr {0 - 1.5 * $size * $r}] \
[expr {$w + 1.5 * $size * $r}] [expr {1.5 * $size * $r}] -fill $color \
-tags $tags
$canvas create oval [expr {0 - 1.5 * $size * $r}] \
[expr {$h - 1.5 * $size * $r}] \
[expr {1.5 * $size * $r}] [expr {$h + 1.5 * $size * $r}] -fill $color \
-tags $tags
$canvas create oval [expr {$w - 1.5 * $size * $r}] \
[expr {$h - 1.5 * $size * $r}] \
[expr {$w + 1.5 * $size * $r}] [expr {$h + 1.5 * $size * $r}] -fill $color \
-tags $tags
set mid [expr {$h / 2}]
$canvas create oval [expr {0 - $size * $r}] [expr {$mid - $size * $r}] \
[expr {$size * $r}] [expr {$mid + $size * $r}] \
-fill $color -tags $tags
$canvas create oval [expr {$w - $size * $r}] \
[expr {$mid - $size * $r}] \
[expr {$w + $size * $r}] [expr {$mid + $size * $r}] -fill $color \
-tags $tags
}
# Draw the cushions
$canvas create rectangle 0 [expr {1.5 * $r + $inset}] $inset \
[expr {$h/2 - $r - $inset}] \
-fill SeaGreen -tags cushion -outline SeaGreen
$canvas create rectangle 0 [expr {$h/2 + $r + $inset}] $inset \
[expr {$h - 1.5 * $r - $inset}] \
-fill SeaGreen -tags cushion -outline SeaGreen
$canvas create rectangle [expr {1.5 * $r + $inset}] 0 \
[expr {$w - 1.5 * $r - $inset}] $inset \
-fill SeaGreen -tags cushion -outline SeaGreen
$canvas create rectangle [expr {$w - $inset}] [expr {1.5 * $r + $inset}] $w \
[expr {$h/2 - $r - $inset}] -fill SeaGreen -tags cushion -outline SeaGreen
$canvas create rectangle [expr {$w - $inset}] [expr {$h/2 + $r + $inset}] $w \
[expr {$h - 1.5 * $r - $inset}] -fill SeaGreen -tags cushion -outline SeaGreen
$canvas create rectangle [expr {1.5 * $r + $inset}] [expr {$h - $inset}] \
[expr {$w - 1.5 * $r - $inset}] $h -fill SeaGreen -tags cushion -outline SeaGreen
# Draw the rounded edges of the cushions
foreach x [list 0 $w] {
set i [expr {$x - $inset}]
set j [expr {$x + $inset}]
$canvas create oval $i [expr {1.5 * $r}] \
$j [expr {1.5 * $r + 2 * $inset}] -fill SeaGreen -tags cushion \
-outline SeaGreen
$canvas create oval $i [expr {$h/2 - $r}] \
$j [expr {$h/2 -$r - 2* $inset}] -fill SeaGreen -tags cushion \
-outline SeaGreen
$canvas create oval $i [expr {$h/2 + $r}] \
$j [expr {$h/2 + $r + 2 * $inset}] -fill SeaGreen -tags cushion \
-outline SeaGreen
$canvas create oval $i [expr {$h - 1.5 * $r}] $j\
[expr {$h - 1.5 * $r - 2 * $inset}] -fill SeaGreen -tags cushion \
-outline SeaGreen
}
foreach y [list 0 $h] {
set i [expr {$y - $inset}]
set j [expr {$y + $inset}]
$canvas create oval [expr {1.5 * $r}] $i \
[expr {1.5 * $r + 2 * $inset}] $j -fill SeaGreen -tags cushion \
-outline SeaGreen
$canvas create oval [expr {$w - 1.5 * $r}] $i \
[expr {$w - 1.5 * $r - 2 * $inset}] $j \
-fill SeaGreen -tags cushion -outline SeaGreen
}
}
proc tkpool::drawline {canvas x y} {
global cue
if {[catch {$cue set pos} pos]} {
# No cue ball
return
}
foreach {x1 y1} $pos {break}
$canvas delete cueline
$canvas create line $x $y $x1 $y1 -tags cueline -fill white
bind $canvas <Motion> [list tkpool::drawline $canvas %x %y]
}
proc tkpool::endline {canvas} {
$canvas delete cueline
bind $canvas <Motion> {}
}
proc tkpool::about {} {
variable version
# Popup an about box
tk_messageBox -title "About TkPool V$version" -icon info \
-message "A simple Tcl/Tk pool game\nBy Neil Madden\nhttp://wiki.tcl.tk/TkPool\nPublic Domain"
}
proc tkpool::main {argv} {
variable scale
variable radius
variable version
variable segments
global State cue
if {[llength $argv] > 0} {
if {[llength $argv] > 1 || ![string is double [lindex $argv 0]]} {
puts "Usage: $::argv0 ?scale?"
exit 1
} else {
set scale [lindex $argv 0]
set radius [expr {$radius * $scale}]
}
}
# 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"
canvas .info.power.p -bg black -width 100 -height 10
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 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 V$version"
update
# Create the segments in the power display
set r [expr {[winfo width .info.power.p] / 15.0}]
for {set i 0} {$i < 15} {incr i} {
lappend segments [.info.power.p create rect [expr {$i * $r}] 0 \
[expr {$i * $r + $r -1}] 10 -fill #404040]
}
# 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
$canvas configure -cursor tcross
drawpockets $canvas
# Create some balls
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]
bind $canvas <ButtonPress-3> [list tkpool::drawline $canvas %x %y]
bind $canvas <ButtonRelease-3> [list tkpool::endline $canvas]
bind . <d> tkpool::dump
move $canvas
}
tkpool::main $argv
======
----
[Jacob Levy] 04/22/2003 I'm wondering if it'd be very hard to write a TkPinball with all the cool bells and whistles that usually accompany these games. Make it networked so that you can have a tournament, one person playing with others watching...
----
2017-09-15: Online demo at [http://172.104.5.86:5443/cloudtk/VNC?session=new&Tk=TkPool] 2017-09-23: Update - Tk window size now adjusts to fit browser window. Nice feature click on Control Bar Tab at the left of screen and select Fullscreen. Also should work on tablets! Smartphones however Tk window controls do not adjust properly to screen size. May be Tk application specific?
<<categories>> Games