package require Tk
set info "iConnect4 (was TkAlign4) v1.1
by Richard Suchenwirth
AI Game Architect
by Jason Tang
Computer Play updates
by Michael Jacobson
Game Play
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.
Computer Opponent
You may play against the computer
or even have it play itself. You
may halt the computer by changing
it back to a human player with
the spin box.
"
frame .f
set g(status) {6 6 6 6 6 6 6}
button .f.0 -text New -command {reset .c}
button .f.1 -text Reset -command {reset .c all}
spinbox .f.2s -textvar g(pred) -width 8 -values {Player1 Computer} -command {opponentchg .f.2s %s}
set g(pred) Player1
label .f.2 -bg red -width 2 -textvar g(red)
spinbox .f.3s -textvar g(pyellow) -width 8 -values {Player2 Computer} -command {opponentchg .f.3s %s}
set g(pyellow) Player2
label .f.3 -bg yellow -width 2 -textvar g(yellow)
button .f.4 -text X -command {exit} ;# mainly for WinCE platform
eval pack [winfo children .f] -side left -fill y
canvas .c
eval pack [winfo children .]
wm geometry . 240x320+0+0
proc reset {c {what ""}} {
global g
$c delete all
if {$what=="all"} {
set g(red) 0
set g(yellow) 0
set g(toPlay) red
} else {
set g(toPlay) $g(toPlay) ;# to trip the trace
}
oval $c 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 [oval $c $x0 $y0 $x1 $y1 -fill black -tag $x,$y]
$c bind $id <1> [list insert $c $x]
}
}
}
proc insert {c x {block 1}} {
if {$block} {
# do not let manual insert if in computer control mode
if {$::g(p$::g(toPlay)) == "Computer" } {return}
}
if {[$c find withtag chip]==""} return
if {[colorof $c $x,1] != "black"} return
$c delete chip
global g
set color $g(toPlay)
$c itemconfig $x,1 -fill $color
set y 1
while 1 {
update
if {[colorof $c $x,[expr $y+1]] != "black"} break
$c itemconfig $x,$y -fill black
$c itemconfig $x,[incr y] -fill $color
after 100
}
set g(status) [lreplace $g(status) $x $x [expr $y-1]]
if ![win $c $x $y] {
set g(toPlay) [expr {$color=="red"? "yellow" : "red"}]
oval $c 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 1 {
if {[colorof $c [incr x0 $dx],[incr y0 $dy]]!=$self} break
lappend row $x0,$y0
}
set x0 $x; set y0 $y
while 1 {
if {[colorof $c [incr x0 $mdx],[incr y0 $mdy]]!=$self} break
lappend row $x0,$y0
}
if {[llength $row] >= 4} {
#puts "We have a winner - Now flash the 4 in a row"
foreach chip $row {$c addtag win withtag $chip}
$c itemconfig win -fill green
set last green
for {set i 1} {$i < 6} {incr i} {
set new [expr {$last=="green"? "$self" : "green"}]
after [expr {500 * $i}] \
$c itemconfig win -fill $new
set last $new
}
# set g(toPlay) [expr {$self=="red"? "yellow" : "red"}]
tk_messageBox -message "$g(p$self) wins"
incr ::g($self)
return 1
}
}
return 0
}
if {$tcl_platform(os)=="Windows CE"} {
proc rp {x0 y0 x1 y1 {n 0} } {
set xm [expr {($x0+$x1)/2.}]
set ym [expr {($y0+$y1)/2.}]
set rx [expr {$xm-$x0}]
set ry [expr {$ym-$y0}]
if {$n==0} {
set n [expr {round(($rx+$ry))}]
}
set step [expr {atan(1)*8/$n}]
set res ""
set th [expr {atan(1)*6}]
for {set i 0} {$i<$n} {incr i} {
lappend res \
[expr {$xm+$rx*cos($th)}]
lappend res \
[expr {$ym+$ry*sin($th)}]
set th [expr {$th+$step}]
}
set res
}
proc oval {w x0 y0 x1 y1 args} {
eval $w create poly [rp $x0 $y0 $x1 $y1] $args
}
} else {
proc oval {w x0 y0 x1 y1 args} {
eval $w create oval $x0 $y0 $x1 $y1 $args
}
}
proc bestMove {color} {
set ans [getMove $color]
if {$::ABORT != 1} {
insert .c $ans 0
} else {
set ::ABORT 0
}
}
# sets the AI's difficulty level
# higher number == tougher AI (but also much slower)
# even numbers tends to favor a more aggressive AI
# odd numbers tends to favor a more defensive AI
if {$tcl_platform(os)=="Windows CE"} {
set DIFFICULTY 1 ;# make it run faster on this platform
} else {
set DIFFICULTY 3
}
set ABORT 0
proc getMove {color} {
global DIFFICULTY
set scores ""
foreach col {0 1 2 3 4 5 6} {
# first make a duplicate of the board
dupBoard board
# next simulate where drop would occur
for {set row 6} {$row >= 1} {incr row -1} {
if {$board($row,$col) == ""} {
set board($row,$col) $color
break
}
}
if {$row <= 0} {
# column is filled; skip to next one
set result -10001
} else {
set result [getMoveAB board $row $col $color $color \
-100001 100001 $DIFFICULTY]
#puts "col $col: $result"
if {$result == 10000} {
return $col
}
}
lappend scores $result
}
# now pick the best score
set bestscore [lindex $scores 0]
set bestcols 0
foreach i {1 2 3 4 5 6} {
set current [lindex $scores $i]
if {$current > $bestscore} {
set bestscore $current
set bestcols $i
} elseif {$current == $bestscore} {
lappend bestcols $i
}
}
return [lindex $bestcols [expr {int (rand () * [llength $bestcols])}]]
}
# performs a somewhat modified alpha-beta search on the board
proc getMoveAB {ob row col me current alpha beta depth} {
update
if {$::ABORT == 1} {return 10000}
upvar $ob origBoard
# this will check to see if search is at a terminal state
set myscore [getScore origBoard $row $col $current]
if {$depth <= 0 || $myscore == 10000} {
if {$me != $current} {
set myscore [expr {-1 * $myscore}]
}
return $myscore
} elseif {$me != $current} {
# examining a max node -- do alpha pruning
incr depth -1
set newCurrent [oppColor $current]
foreach col {0 1 2 3 4 5 6} {
array set board [array get origBoard]
for {set row 6} {$row >= 1} {incr row -1} {
if {$board($row,$col) == ""} {
set board($row,$col) $newCurrent
break
}
}
if {$row <= 0} {
continue
}
set score [getMoveAB board $row $col $me $newCurrent \
$alpha $beta $depth]
if {$score > $alpha} {
set alpha $score
}
if {$alpha >= $beta} {
return $alpha
}
}
return $alpha
} else {
# examining a min node -- do beta pruning
incr depth -1
set newCurrent [oppColor $current]
foreach col {0 1 2 3 4 5 6} {
array set board [array get origBoard]
for {set row 6} {$row >= 1} {incr row -1} {
if {$board($row,$col) == ""} {
set board($row,$col) $newCurrent
break
}
}
if {$row <= 0} {
continue
}
set score [getMoveAB board $row $col $me $newCurrent \
$alpha $beta $depth]
if {$score < $beta} {
set beta $score
}
if {$beta <= $alpha} {
return $beta
}
}
return $beta
}
}
proc dupBoard {dest} {
upvar $dest board
foreach col {0 1 2 3 4 5 6} {
set num 0
foreach row {1 2 3 4 5 6} {
set c [colorof .c $col,$row]
if {$c == "black"} {
set board($row,$col) ""
} else {
set board($row,$col) $c
}
}
}
}
proc oppColor {color} {
if {$color == "red"} {
return yellow
}
return red
}
proc getScore {b row col who} {
upvar $b board
set sum 0
foreach {dx dy ex ey} {-1 0 1 0 0 -1 0 1 1 -1 -1 1 -1 -1 1 1} {
set leftbound 1
set rightbound 1
set score 1
for {set c [expr {$col + $dx}]; set r [expr {$row + $dy}]; set i 0} \
{$i < 3} \
{incr c $dx; incr r $dy; incr i} {
if {![info exists board($r,$c)]} {
set leftbound 0
break
}
if {$board($r,$c) == $who} {
set score [expr {$score << 3}]
} else {
if {$board($r,$c) != ""} {
set leftbound 0
}
break
}
}
for {set c [expr {$col + $ex}]; set r [expr {$row + $ey}]; set i 0} \
{$i < 3} \
{incr c $ex; incr r $ey; incr i} {
if {![info exists board($r,$c)]} {
set rightbound 0
break
}
if {$board($r,$c) == $who} {
set score [expr {$score << 3}]
} else {
if {$board($r,$c) != ""} {
set rightbound 0
}
break
}
}
if {$score >= 256} {
return 10000
}
if {$leftbound == 0 && $rightbound == 0} {
set score 0
} else {
set score [expr {$score + $leftbound * 2 + $rightbound * 2}]
}
incr sum $score
}
return $sum
}
proc opponentchg {c s} {
if {$s == "Computer"} {
if {".f.2s" == $c && $::g(toPlay) == "red"} { playerchange}
if {".f.3s" == $c && $::g(toPlay) == "yellow"} { playerchange}
}
}
trace variable g(toPlay) w playerchange
trace variable g(pred) w playerstatus
trace variable g(pyellow) w playerstatus
proc playerstatus {array var type} {
if {"$::g(p$::g(toPlay))" == $::g($var)} {
if {$::OLD == "Computer" && [string range $::g($var) 0 end-1] == "Player"} {
set ::ABORT 1
}
}
}
set OLD ""
proc playerchange {args} {
set ::OLD $::g(p$::g(toPlay))
if { $::OLD == "Computer" } {
return [after 100 [list bestMove $::g(toPlay)]]
}
}
wm geometry . 240x268+0+1
. config -menu [menu .m]
.m add casc -label File -menu [menu .m.file -tearoff 0]
.m.file add comm -label Exit -comm exit
.m add casc -label Hardness -menu [menu .m.ai -tearoff 0]
.m.ai add radio -label {Stupid} -variable DIFFICULTY -value 0
.m.ai add radio -label {Dumb} -variable DIFFICULTY -value 1
.m.ai add radio -label {Easy} -variable DIFFICULTY -value 2
.m.ai add radio -label {Medium} -variable DIFFICULTY -value 3
.m.ai add radio -label {Hard} -variable DIFFICULTY -value 4
.m.ai add radio -label {Best} -variable DIFFICULTY -value 5
.m add casc -label Help -menu [menu .m.help -tearoff 0]
.m.help add comm -label About -comm {tk_messageBox -message $info}
bind . <F2> {console show}
reset .c allgold added pix, ref older dead link
