Version 1 of TkAlign4

Updated 2003-04-22 07:23:48

if 0 {Richard Suchenwirth 2003-04-21 - Here is another little Tk game, "Align Four", where you drop chips of your color (red or yellow) into slots of a receptacle, until one player has managed to get four chips in a row.

}

 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.
 "
 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
 eval pack [winfo children .]
 wm geometry . 240x320+0+0

 proc reset {c {what ""}} {
    global g
    if {$what=="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]
            $c bind $id <1> [list insert $c $x]
        }
    }
 }
 proc insert {c x} {
    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
    }
    if ![win $c $x $y] {
        set g(toPlay) [expr {$color=="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 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} {
            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=="red"? "yellow" : "red"}]
            tk_messageBox -message "$g(p$self) wins" 
            incr ::g($self)
            return 1
        } 
    }
    return 0
 }
 reset .c all

 bind . <Escape> {exec wish $argv0 &; exit}
 bind . <F1> {console show}