[NEM] ''26 Mar 2003'' - Here is a little game I've started putting together to simulate the game of pool. I might also make it so you can play snooker or billiards, or one of the other pool variations. This is just the beginnings, as I try to get it all working. Most of the physics has been taken from [Colliding Balls], with a bit extra (friction, etc) added by me. The physics I've added is not particularly true to nature, but it is reasonably realistic, and easy to calculate.

Any suggestions, bug fixes, etc much appreciated. Please remember, though, that this is still a work in progress.

This is 8-ball pool, using the rules at the English Pool Association: http://www.epa.org.uk/wrules.htm , although I haven't done much to implement those rules yet. I am going to try and create an abstract way to enter the rules, so that it can be adapted for different games easily (you can already specify the initial layout of the balls at start).

Oh, yes - almost forgot to tell you how to play: At the start click anywhere below the white line to place the cue ball. Then click on the table to take a shot - the cue ball will move towards where you clicked. The longer you hold down the mouse the more force behind the shot. If you pot the cue ball click below the line again to replace it on the table.

'''Known Issues'''

   * 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.
   * 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!


----
 #!/bin/sh
 # Next line restarts with Tcl \
 exec tclsh "$0" ${1+"$@"}
 # TkPool --
 #
 #   A "simple" simulation of the game of Pool using Tcl/Tk. Based on the ideas
 #   and code from Colliding Balls: http://wiki.tcl.tk/8573 by David Easton.
 package require Tcl 8.4
 package require Tk 8.4
 
 namespace eval tkpool {
    # List of created balls
    variable balls {}
    # Unique id for creating balls
    variable uniqueid 0
    # Mapping from id to name
    variable id2name
 
    variable radius 10 
    # The friction coefficient of the surface
    variable fcoefficient 0.01
 
    namespace export ball
 }
    
    
 # Representation of state associated with a ball.
 # Using this little encapsulation technique makes some
 # parts of the code easier.
 proc tkpool::ball {canvas xpos ypos mass colour} {
    variable balls
    variable uniqueid
    variable radius
    variable id2name
 
    # Create a unique name for this ball
    set name "ball[incr uniqueid]"
    lappend balls $name
    # And a command to access it from
    interp alias {} ::$name {} ::tkpool::ball_cmd $name
    
    # Create the state of this ball
    variable $name 
    upvar 0 $name state
    set state(pos) [list $xpos $ypos]
    #set state(vel) [list [expr rand()*8.0] [expr rand()*8.0]]
    set state(vel) [list 0.0 0.0]
    set state(mass) $mass
    set state(colour) $colour
 
    set x1 [expr {$xpos - $radius}]
    set x2 [expr {$xpos + $radius}]
    set y1 [expr {$ypos - $radius}]
    set y2 [expr {$ypos + $radius}]
 
    set state(id) [$canvas create oval $x1 $y1 $x2 $y2 \
        -outline black -fill $colour -tags [list $name ball]]
 
    set id $state(id)
    set id2name($id) $name
 }

 proc tkpool::ball_cmd {name cmd args} {
    variable balls
    variable $name
    upvar 0 $name state
 
    switch $cmd {
        set    {
            if {[llength $args] == 1} {
                return $state([lindex $args 0])
            } elseif {[llength $args] == 2} {
                set state([lindex $args 0]) [lindex $args 1]
            } else {
                return -code error "wrong # args"
            }
        }
        unset   {
            unset state([lindex $args 0])
        }
        delete {
            set idx [lsearch $balls $name]
            catch {
                set balls [lreplace $balls $idx $idx]
            }
            .c delete $state(id)
 
            unset state
        }
        default {
            return -code error "unknown command \"$cmd\""
        }
    }
 }   
    
 #   
 # Given the initial velocities and masses calculates the velocities following
 # a collision.
 proc tkpool::postColVels {u1 u2 m1 m2} {
    # No collision if velocity of ball2 > velocity of ball1
    if {$u2 > $u1} {
        return [list $u1 $u2]
    }
 
    set u1 [expr {1.0 * $u1}]
    set u2 [expr {1.0 * $u2}]
    set m1 [expr {1.0 * $m1}]
    set m2 [expr {1.0 * $m2}]
    
    set M [expr {$m1 / $m2}]
    
    set b [expr {($M * $u1) + $u2}]
    set c [expr {($M * $u1 * $u1) + ($u2 * $u2)}]
                
    set q [expr {2 * $M * $b}] 
    set p [expr {4 * $M * $M * $b * $b}]
    set r [expr {4 * ($M + ($M * $M)) * (($b * $b) - $c)}]
    set s [expr {2 * ($M + ($M * $M))}]
            
    if {$r > $p} {
        return -code error "no solution"
    } else {
        set root [expr {sqrt($p-$r)}]
        
        set v1 [expr {($q - $root) / $s}]
        set v2 [expr {$b - ($M * $v1)}]
                
        return [list $v1 $v2]
    }       
 }
 
 proc tkpool::checkForCollisions {canvas ball} {
    variable radius
    variable id2name
    global State
 
    set didCollide 0
    set overlapList [list]
 
    foreach {ourX ourY} [$ball set pos] {break}
 
    set searched [list [$ball set id]]
    set id [$canvas find closest $ourX $ourY $radius [$ball set id]]
 
    while {[lsearch $searched $id] == -1} {
        if {[lsearch -glob [$canvas gettags $id] "ball*"] > -1} {
            set didCollide 1
            lappend overlapList $id
        } elseif {[lsearch [$canvas gettags $id] "pocket"] > -1} {
            # Ball has been potted
            if {$ball eq $::cue} {
                puts "Potted the cue ball!"
                $ball set pos [list 150 500]
                $ball set vel [list 0.0 0.0]
                $canvas coords $ball 140 490 160 510
                return 2
            } else {
                puts "[$ball set colour] ball potted!"
                $ball delete
            }
        }
        lappend searched $id
        set id [$canvas find closest $ourX $ourY $radius $id]
    }
 
    if {[llength $overlapList] > 0} {
        foreach id $overlapList {
            collide $ball $id2name($id)
        }
    }
    
    return $didCollide
 }
 
 proc tkpool::move {canvas} {
    variable balls
    variable fcoefficient
 
    set canvasHeight [winfo height $canvas]
    set canvasWidth  [winfo width $canvas]
 
    foreach ball $balls {
 
        foreach {xpos ypos} [$ball set pos] {break}
        foreach {xvel yvel} [$ball set vel] {break}
 
        # Take friction into account
        set mass [$ball set mass]
        set decel [expr {$fcoefficient * $mass}]
            
        if {$xvel != 0.0} {
            set phi [expr {atan(abs($yvel / $xvel))}]
            
            set vel [expr {sqrt(pow($xvel,2) + pow($yvel,2))}]
            set vel [expr {$vel - $decel}]
                
            if {$vel < 0.0} {
                set vel 0.0
            } 
                
            if {$xvel < 0.0} {
                set xvel [expr {-1.0 * $vel * cos($phi)}]
            } else {
                set xvel [expr {$vel * cos($phi)}]
            }
            if {$yvel < 0.0} {
                set yvel [expr {-1.0 * $vel * sin($phi)}]
            } else {
                set yvel [expr {$vel * sin($phi)}]
            }
        }
    
        set xpos [expr {$xpos + $xvel}]
        set xpos [expr {$xpos + $xvel}]
        set ypos [expr {$ypos + $yvel}]
 
        $canvas move $ball $xvel $yvel
 
        # Bounce off edges
        foreach {x1 y1 x2 y2} [$canvas bbox $ball] {break}
 
        # Left edge
        if {$x1 < 0 && $xvel < 0} {
            set xvel [expr {-1.0 * $xvel}]
        }
        if {$x2 > $canvasWidth && $xvel > 0} {
            set xvel [expr {-1.0 * $xvel}]
        }
        if {$y1 < 0 && $yvel < 0} {
            set yvel [expr {-1.0 * $yvel}]
        }
        if {$y2 > $canvasHeight && $yvel > 0} {
            set yvel [expr {-1.0 * $yvel}]
        }
        set ret [checkForCollisions $canvas $ball]
        if {$ret == 2} {
            # Potted the cue ball
        } elseif {$ret == 1} {
            # Collided
            $ball set pos [list $xpos $ypos]
        } else {
            $ball set pos [list $xpos $ypos]
            $ball set vel [list $xvel $yvel]
        }
 
    }
 
    after 50 [list ::tkpool::move $canvas]
 }
 
 proc tkpool::collide {ball1 ball2} {
 
    foreach {x1 y1} [$ball1 set pos] {break}
    foreach {x2 y2} [$ball2 set pos] {break}
        
    # Always call ball on right (2) and one on left (1)
    if {$x1 > $x2} { 
        set temp $ball2
        set ball2 $ball1
        set ball1 $temp
 
        foreach {x1 y1} [$ball1 set pos] {break}
        foreach {x2 y2} [$ball2 set pos] {break}
    }       
        
    # Get velocity of each ball
    foreach {ux1 uy1} [$ball1 set vel] {break}
    foreach {ux2 uy2} [$ball2 set vel] {break}
        
    # Work out angle of collision
    set diffX [expr {1.0 * ($x2 - $x1)}]
    set diffY [expr {1.0 * ($y2 - $y1)}] 
            
    if {$diffX == 0.0} {
        set diffX 0.0000001
    }
    set phi [expr {atan($diffY / $diffX)}]
        
    # Work out velocity parallel and perpendicular
    set uparr1 [expr {($ux1 * cos($phi)) + ($uy1 * sin($phi))}]
    set uperp1 [expr {($ux1 * sin($phi)) - ($uy1 * cos($phi))}]
            
    set uparr2 [expr {($ux2 * cos($phi)) + ($uy2 * sin($phi))}]
    set uperp2 [expr {($ux2 * sin($phi)) - ($uy2 * cos($phi))}]
            
    # If they are not going towards each other, then they will not collide
    if {$uparr2 > $uparr1} {
        return
    }
    
    set mass1 [$ball1 set mass]
    set mass2 [$ball2 set mass]
 
    foreach {vparr1 vparr2} [postColVels $uparr1 $uparr2 $mass1 $mass2] \
        {break} 
        # Perpendicular velocities are unchanged
    set vperp1 $uperp1
    set vperp2 $uperp2
 
    # Convert back into x and y movements
    set vx1 [expr {($vparr1 * cos($phi)) + ($vperp1 * sin($phi))}]
    set vy1 [expr {($vparr1 * sin($phi)) - ($vperp1 * cos($phi))}]
 
    set vx2 [expr {($vparr2 * cos($phi)) + ($vperp2 * sin($phi))}]
    set vy2 [expr {($vparr2 * sin($phi)) - ($vperp2 * cos($phi))}]
 
    # Update new velocities
    $ball1 set vel [list $vx1 $vy1]
    $ball2 set vel [list $vx2 $vy2]
 }
 
 #
 # Racks the balls on the table, using the positions indicated. The positions
 # argument should be a list of lists, where each element is a letter or x
 # (meaning no ball in this position). The rows go from the back to the front.
 # Here is 8-ball pool setup:
 # {
 #  {y r y y r}
 #  { r y r y }
 #  {x y b r x}
 #  { x r y x }
 #  {x x r x x}
 # }
 proc tkpool::rack {canvas mass positions} {
    variable radius
    variable balls
    global cue
 
    foreach ball $balls {
        $ball delete
    }
 
    set w [winfo width $canvas]
    set h [winfo height $canvas]
 
    set x0 [expr {($w /2.0) - (4 * $radius)}]
    set y0 [expr {150 - ($radius * 4)}]
 
    for {set i 0} {$i < 5} {incr i} {
        # Calculate row offset
        if {($i % 2) != 0} {
            set offset $radius
        } else {
            set offset 0
        }
        foreach item [lindex $positions $i] {
            switch $item {
                x   { }
                y   { ball $canvas [expr {$x0 + $offset}] \
                                   $y0 $mass yellow
                }
                r   { ball $canvas [expr {$x0 + $offset}] \
                                    $y0 $mass red
                }
                b   { ball $canvas [expr {$x0 + $offset}] \
                                    $y0 $mass black
                }
                default { return -code error "unknown identifier \"$item\""}
            }
            incr offset [expr {$radius * 2}]
        }
        incr y0 [expr {$radius * 2}]
    }
    set ::State(state) start
 }
 
 proc tkpool::mousedown {} {
    variable time
    set time [clock clicks -milliseconds]
 }
    
 proc tkpool::mouseup {canvas x y} {
    global cue
    global State
    variable time
    
    if {$State(state) eq "start"} {
        # Must be behind the line
        if {$y < 480} { 
            puts "Must start from behind the line"
            return
        }
        set cue [tkpool::ball $canvas $x $y 15 white]
        set State(state) "game"
    } else {
        set newtime [clock clicks -milliseconds]
        set speed [expr {($newtime - $time) / 30.0}]
 
        # Work out component velocities.
        foreach {oldx oldy} [$cue set pos] {break}
        set diffX [expr {1.0 * ($x - $oldx)}]
        set diffY [expr {1.0 * ($y - $oldy)}]
 
        set vel [expr {sqrt(pow($diffX,2) + pow($diffY,2))}]
        set ratio [expr {$speed/$vel}]
 
        set xvel [expr {$ratio * $diffX}]
        set yvel [expr {$ratio * $diffY}]
 
        $cue set vel [list $xvel $yvel]
    }
 }
 
 # Draw some pockets onto the canvas
 proc tkpool::drawpockets {canvas} {
    variable radius
 
    set r [expr {$radius + 5}]
 
    set w [winfo width $canvas]
    set h [winfo height $canvas]
 
    $canvas create oval [expr {0 - $r}] [expr {0 - $r}] \
        $r $r -fill black -tags [list pocket]
    $canvas create oval [expr {$w - $r}] [expr {0 - $r}] \
        [expr {$w + $r}] $r -fill black -tags [list pocket]
    $canvas create oval [expr {0 - $r}] [expr {$h - $r}] \
        $r [expr {$h + $r}] -fill black -tags [list pocket]
    $canvas create oval [expr {$w - $r}] [expr {$h - $r}] \
        [expr {$w + $r}] [expr {$h + $r}] -fill black -tags [list pocket]
 
    set mid [expr {$h / 2}]
    $canvas create oval [expr {0 - $r}] [expr {$mid - $r}] \
        $r [expr {$mid + $r}] -fill black -tags [list pocket]
    $canvas create oval [expr {$w - $r}] [expr {$mid - $r}] \
        [expr {$w + $r}] [expr {$mid + $r}] -fill black -tags [list pocket]
 }   
         
 # Create a frame to show the players' scores
 frame .info
 
 labelframe .info.p1 -text "Player 1"
 label .info.p1.colour -text "Colour:"
 label .info.p1.col -textvariable State(player1,colour)
 label .info.p1.score -text "Score:"
 label .info.p1.scr -textvariable State(player1,score)
         
 labelframe .info.p2 -text "Player 2"
 label .info.p2.colour -text "Colour:"
 label .info.p2.col -textvariable State(player2,colour)
 label .info.p2.score -text "Score:"
 label .info.p2.scr -textvariable State(player2,score)
    
 labelframe .info.turn -text "Turn"
 label .info.turn.t -textvariable State(currentplayer)
 
 array set State {
    player1,colour      ""
    player1,score       0
    player2,colour      "" 
    player2,score       0
    currentplayer       "Player 1"
    currentp            1
    state               start
 }   
         
 pack .info.p1.colour .info.p1.col -anchor w
 pack .info.p1.score .info.p1.scr -anchor w
 pack .info.p2.colour .info.p2.col -anchor w
 pack .info.p2.score .info.p2.scr -anchor w
     
 pack .info.p1 -anchor n -fill x
 pack .info.p2 -anchor n -fill x
 pack .info.turn.t -fill both
 pack .info.turn -anchor n -fill x
 pack .info -side right -fill y
 
 set canvas [canvas .c -bg darkgreen -width 300 -height 600]
 pack $canvas
 
 set layout {
      {y r y y r}
      { r y r y }
      {x y b r x}
      { x r y x }
      {x x r x x}
 }
 
 button .info.rerack -text "Re-Rack" -command \
    [list tkpool::rack $canvas 10 $layout] -width 15
 
 button .info.quit -text "Quit" -command exit -width 15
 
 pack .info.quit -side bottom -padx 5 -pady 5
 pack .info.rerack -side bottom -padx 5 -pady 5
 
 wm resizable . 0 0
 wm title . "TkPool V0.1"
 
 # Draw the spot and line
 $canvas create oval 147 147 153 153 -fill white -outline white
 $canvas create line 0 480 300 480 -fill white
 
 update
 tkpool::drawpockets $canvas
 
 # Create some balls
 tkpool::rack $canvas 10 $layout
 
 bind $canvas <ButtonPress-1> [list tkpool::mousedown]
 bind $canvas <ButtonRelease-1> [list tkpool::mouseup $canvas %x %y]
 
 tkpool::move $canvas

----
[Category Game]