#! /bin/env tclsh
set info {TkAlign4 - Richard Suchenwirth 2003
Two players, red and yellow.
Click on a column to insert piece.
If you have four pieces in a row
(horizontal, vertical, diagonal), you win.
}
package require Tk
frame .f
button .f.0 -text New -command {reset .c}
button .f.1 -text Reset -command {reset .c all}
entry .f.2e -textvar g(pred) -width 8
set g(pred) Player1
label .f.2 -bg red -width 3 -textvar g(red)
entry .f.32 -textvar g(pyellow) -width 8
set g(pyellow) Player2
label .f.3 -bg yellow -width 3 -textvar g(yellow)
button .f.4 -text ? -command {tk_messageBox -message $info}
eval pack [winfo children .f] -side left -fill y
canvas .c
pack {*}[winfo children .]
wm geometry . 240x320+0+0
proc reset {c {what {}}} {
global g
if {$what eq {all}} {
set g(red) 0
set g(yellow) 0
set g(toPlay) red
}
$c delete all
$c create oval 107 2 133 28 -fill $g(toPlay) -tag chip
$c create rect 0 30 240 240 -fill darkblue
foreach x {0 1 2 3 4 5 6} {
set x0 [expr {$x * 32 + 10}]
set x1 [expr {$x0 + 26}]
foreach y {1 2 3 4 5 6} {
set y0 [expr {$y * 32 + 16}]
set y1 [expr {$y0 + 26}]
set id [$c create oval $x0 $y0 $x1 $y1 -fill black -tag $x,$y]
set script {}
#if [inserting] exists, a move is in progress. Do nothing
append script {if {[namespace which inserting] ne "[
string trimright [namespace current] ::]::inserting"} } [list [
list coroutine inserting insert $c $x]]
$c bind $id <1> [namespace code $script]
}
}
}
proc insert {c x} {
if {[$c find withtag chip] eq {}} return
if {[colorof $c $x,1] ne {black}} return
$c delete chip
global g
set color $g(toPlay)
$c itemconfig $x,1 -fill $color
set y 1
while {[colorof $c $x,[expr {$y + 1}]] eq {black}} {
$c itemconfig $x,$y -fill black
$c itemconfig $x,[incr y] -fill $color
after 100 [list [info coroutine]]
yield
}
if {![win $c $x $y]} {
set g(toPlay) [expr {$color eq {red} ? {yellow} : {red}}]
$c create oval 107 2 133 28 -fill $g(toPlay) -tag chip
}
}
proc colorof {c tag} {$c itemcget $tag -fill}
proc win {c x y} {
global g
set self [colorof $c $x,$y]
foreach {dx dy} {1 0 0 1 1 1 1 -1} {
set mdx [expr {-$dx}]; set mdy [expr {-$dy}]
set row $x,$y
set x0 $x; set y0 $y
while {[colorof $c [incr x0 $dx],[incr y0 $dy]] eq $self} {
lappend row $x0,$y0
}
set x0 $x; set y0 $y
while 1 {
if {[colorof $c [incr x0 $mdx],[incr y0 $mdy]] ne $self} break
lappend row $x0,$y0
}
if {[llength $row] >= 4} {
foreach chip $row {$c addtag win withtag $chip}
$c itemconfig win -fill green
after 1000 $c itemconfig win -fill $self
set g(toPlay) [expr {$self eq {red} ? {yellow} : {red}}]
tk_messageBox -message "$g(p$self) wins"
incr ::g($self)
return 1
}
}
return 0
}
reset .c allMichael Jacobson and Jason Tang have produced an enhanced version that has auto-play facility (5 levels of difficulty) and runs well on a PocketPc. See the iConnect4 page for this version.Velena
is a sophisticated free AI engine which plays connect four perfectly.Theoretical details on how to show that the game is a first player win are presented in A Knowledge-based Approach of Connect-Four, L. Victor Allis, 1989.Detailed explanations of Velena can be found in Searching for Solutions in Games and Artificial Intelligence, Allis, 1994.