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


<<categories>> Games