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 add variable g(toPlay) write playerchange
trace add variable g(pred) write playerstatus
trace add variable g(pyellow) write 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