#!/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: https://wiki.tcl-lang.org/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\nhttps://wiki.tcl-lang.org/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

#!/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: https://wiki.tcl-lang.org/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 = {$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 = {$xpos - $radius}
    set x2 = {$xpos + $radius}
    set y1 = {$ypos - $radius}
    set y2 = {$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 = {1.0 * $u1}
    set u2 = {1.0 * $u2}
    set m1 = {1.0 * $m1}
    set m2 = {1.0 * $m2}

    set M = {$m1 / $m2}

    set b = {($M * $u1) + $u2}
    set c = {($M * $u1 * $u1) + ($u2 * $u2)}

    set q = {2 * $M * $b}
    set p = {4 * $M * $M * $b * $b}
    set r = {4 * ($M + ($M * $M)) * (($b * $b) - $c)}
    set s = {2 * ($M + ($M * $M))}

    if {$r > $p} {
        return -code error "no solution"
    } else {
        set root = {sqrt($p-$r)}

        set v1 = {($q - $root) / $s}
        set v2 = {$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 = {$fcoefficient * $mass * $scale}

            if {$xvel != 0.0} {
                set phi = {atan(abs($yvel / $xvel))}

                set vel = {sqrt(pow($xvel,2) + pow($yvel,2))}
                set vel = {$vel - $decel}

                if {$vel < 0.0} {
                    set vel 0.0
                }

                if {$xvel < 0.0} {
                    set xvel = {-1.0 * $vel * cos($phi)}
                } else {
                    set xvel = {$vel * cos($phi)}
                }
                if {$yvel < 0.0} {
                    set yvel = {-1.0 * $vel * sin($phi)}
                } else {
                    set yvel = {$vel * sin($phi)}
                }
            } else {
                # No horizontal component
                if {$yvel > 0.0} {
                    set yvel = {$yvel - $decel}
                    if {$yvel < 0.0} {
                        set yvel 0.0
                    }
                } elseif {$yvel < 0.0} {
                    set yvel = {$yvel + $decel}
                    if {$yvel > 0.0} {
                        set yvel 0.0
                    }
                }
            }

            set xpos = {$xpos + ($xvel / 2.0)}
            set ypos = {$ypos + ($yvel / 2.0)}

            $canvas move $ball {=}{$xvel/2.0},$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 = {-1.0 * $xvel}
                } 
                if {$x2 > ($canvasWidth - (10 * $scale)) && $xvel > 0} {
                    set xvel = {-1.0 * $xvel}
                }
                if {$y1 < (10 * $scale) && $yvel < 0} {
                    set yvel = {-1.0 * $yvel}
                } 
                if {$y2 > ($canvasHeight - (10 * $scale)) && $yvel > 0} {
                    set yvel = {-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 = {1.0 * ($x2 - $x1)}
    set diffY = {1.0 * ($y2 - $y1)}

    if {$diffX == 0.0} {
        set phi 1.57079632579
    } else {
        set phi = {atan($diffY / $diffX)}
    }

    # Work out velocity parallel and perpendicular
    set uparr1 = {($ux1 * cos($phi)) + ($uy1 * sin($phi))}
    set uperp1 = {($ux1 * sin($phi)) - ($uy1 * cos($phi))}

    set uparr2 = {($ux2 * cos($phi)) + ($uy2 * sin($phi))}
    set uperp2 = {($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 = {($vparr1 * cos($phi)) + ($vperp1 * sin($phi))}
    set vy1 = {($vparr1 * sin($phi)) - ($vperp1 * cos($phi))}
    
    set vx2 = {($vparr2 * cos($phi)) + ($vperp2 * sin($phi))}
    set vy2 = {($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 = {($w /2.0) - (4 * $radius)}
    set y0 = {int(($h / 4) - ($radius * 4))}

    for {set i 0} {$i < 5} {incr i} {
        # Calculate row offset
        if {($i % 2) != 0} {
            set offset = {int($radius)}
        } else {
            set offset 0
        }
        foreach item [lindex $positions $i] {
            switch $item {
                x   { }
                y   { ball $canvas {=}{$x0 + $offset} $y0 $mass yellow
                }
                r   { ball $canvas {=}{$x0 + $offset} $y0 $mass red
                }
                b   { ball $canvas {=}{$x0 + $offset} $y0 $mass black
                }
                default { return -code error "unknown identifier \"$item\""}
            }
            incr offset {=}{int($radius * 2.0)}
        }
        incr y0 {=}{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 = {$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 {=}{$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 = {$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 {=}{$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 {=}{$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 = {1.0 * ($x - $oldx)}
        set diffY = {1.0 * ($y - $oldy)}

        set power = {$power * 1.5 * $scale}

        if {$diffX != 0.0} {
            set phi = {atan(abs($diffY / $diffX))}

            if {$diffX < 0.0} {
                set xvel = {-1.0 * $power * cos($phi)}
            } else {
                set xvel = {$power * cos($phi)}
            }
            if {$diffY < 0.0} {
                set yvel = {-1.0 * $power * sin($phi)}
            } else {
                set yvel = {$power * sin($phi)}
            }
        } else {
            # No horizontal component
            if {$diffY > 0.0} {
                set yvel $power
            } elseif {$yvel < 0.0} {
                set yvel = {-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 = {$radius + 5}

    set w [winfo width $canvas]
    set h [winfo height $canvas]

    set inset = {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 {=}{0 - 1.5 * $size * $r, 0 - 1.5 * $size * $r, 
            1.5 * $size * $r, 1.5 * $size * $r} \
            -fill $color -tags $tags
        $canvas create oval {=}{$w - 1.5 * $size * $r, 0 - 1.5 * $size * $r, 
            $w + 1.5 * $size * $r, 1.5 * $size * $r} \
            -fill $color -tags $tags
        $canvas create oval {=}{0 - 1.5 * $size * $r, $h - 1.5 * $size * $r, 
            1.5 * $size * $r, $h + 1.5 * $size * $r} \
            -fill $color -tags $tags
        $canvas create oval {=}{$w - 1.5 * $size * $r, $h - 1.5 * $size * $r, 
            $w + 1.5 * $size * $r, $h + 1.5 * $size * $r} \
            -fill $color -tags $tags

        set mid = {$h / 2}
        $canvas create oval {=}{0 - $size * $r, $mid - $size * $r, 
            $size * $r, $mid + $size * $r} \
            -fill $color -tags $tags
        $canvas create oval {=}{$w - $size * $r, $mid - $size * $r, 
            $w + $size * $r, $mid + $size * $r} \
            -fill $color -tags $tags
    }
    # Draw the cushions
    $canvas create rectangle {=}{0, 1.5 * $r + $inset, $inset, 
        $h/2 - $r - $inset} -fill SeaGreen -tags cushion -outline SeaGreen

    $canvas create rectangle {=}{0, $h/2 + $r + $inset, $inset, 
        $h - 1.5 * $r - $inset} -fill SeaGreen -tags cushion -outline SeaGreen

    $canvas create rectangle {=}{1.5 * $r + $inset, 0, $w - 1.5 * $r - $inset,
        $inset} -fill SeaGreen -tags cushion -outline SeaGreen

    $canvas create rectangle {=}{$w - $inset, 1.5 * $r + $inset, $w, 
        $h/2 - $r - $inset} -fill SeaGreen -tags cushion -outline SeaGreen

    $canvas create rectangle {=}{$w - $inset, $h/2 + $r + $inset, $w, 
        $h - 1.5 * $r - $inset} -fill SeaGreen -tags cushion -outline SeaGreen

    $canvas create rectangle {=}{1.5 * $r + $inset, $h - $inset, 
        $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 = {$x - $inset}
        set j = {$x + $inset}
        $canvas create oval {=}{$i, 1.5 * $r, $j, 1.5 * $r + 2 * $inset} \
            -fill SeaGreen -tags cushion -outline SeaGreen
        $canvas create oval {=}{$i, $h/2 - $r, $j, $h/2 -$r - 2* $inset} \
            -fill SeaGreen -tags cushion -outline SeaGreen
        $canvas create oval {=}{$i, $h/2 + $r, $j, $h/2 + $r + 2 * $inset} \
            -fill SeaGreen -tags cushion -outline SeaGreen
        $canvas create oval {=}{$i, $h - 1.5 * $r, $j, 
            $h - 1.5 * $r - 2 * $inset} -fill SeaGreen -tags cushion \
            -outline SeaGreen
    }

    foreach y [list 0 $h] {
        set i = {$y - $inset}
        set j = {$y + $inset}
        $canvas create oval {=}{1.5 * $r, $i, 1.5 * $r + 2 * $inset, $j} \
           -fill SeaGreen -tags cushion -outline SeaGreen
        $canvas create oval {=}{$w - 1.5 * $r, $i, $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\nhttps://wiki.tcl-lang.org/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 = {$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 {=}{300 * $scale} \
        -height {=}{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 = {[winfo width .info.power.p] / 15.0}
    for {set i 0} {$i < 15} {incr i} {
        lappend segments [.info.power.p create rect {=}{$i * $r, 0, 
           $i * $r + $r -1, 10} -fill #404040]
    }

    # Draw the spot and line
    set p = {[winfo width $canvas]/2.0}
    $canvas create oval {=}{$p-3, $p-3, $p+3, $p+3} \
        -fill white -outline white

    set p = {[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