if 0 {[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 ;-).

[http://mywebpages.comcast.net/jakeforce/iConnect4.jpg]

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.
}
----
 set info "iConnect4 (was TkAlign4)
    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 ? -command {tk_messageBox -message $info}
 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} {
	#puts $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
 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}
	} else {
		#if {".f.2s" == $c && $::g(toPlay) == "red"} { set ::ABORT 1}
		#if {".f.3s" == $c && $::g(toPlay) == "yellow"} {set ::ABORT 1}
	}
 }

 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 . <F2> {console show}
 reset .c all
----
[Category Games]