#! /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 all