[Michael Jacobson] 2003-05-14 - While showing my 6 year old son the game [TkAlign4] he said that it was great but needed a computer to play against (as dad was busy at the time). So with some help from a friend, [Jason Tang], we came up with these enhancements to TkAlign4. I also tried to make sure that it would be playable on the [PocketPc] version of Tcl/Tk. Note that the AI's playing ability is selectable from the menu (Stupid, Dumb, Easy, Medium, Hard, Best) and the default is Easy (which does not seem to easy to me ;-). [gold] inline image [iConnect4 game screenshot png replay] If you want to just download a copy then get it here [http://mywebpages.comcast.net/jakeforce/iConnect4.tcl] or a TclKit version here [http://mywebpages.comcast.net/jakeforce/iConnect4.kit] [Jason Tang]: For the curious, I implemented the game AI as an alpha-beta pruning tree. ====== 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 } } ######################## AI Stuff below ############################## 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 } ######################## AI GUI Stuff below ############################## 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)]] } } ### Code sized to look better on a PocketPC 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 . {console show} reset .c all ====== <> Games