[http://mini.net/files/chess.jpg]
----
[Richard Suchenwirth] 2002-09-14 - In this weekend fun project, I
experimented how to play chess with Tcl. My ambition was not (yet) to code
winning strategies, but just to handle the basics - how to administer
the board data structure, how to validate a move, etc. The first part is
[pure-Tcl], no Tk involved. "Everything is a string", so first I designed a
string format to represent the state of the chess board: one character
per square - "." if empty, else the man's abbreviation (uppercase for White,
lowercase for black):
 R(ook=castle) (k)N(ight) B(ishop) Q(ueen) K(ing) P(awn).
Rows are delimited by newlines, squares by blanks. See the ''chess::reset''
function for the example of the initial setup. Such strings
can be loaded, if you'd like to reproduce chess problems, or the current
state of the board can be returned in the same format.

Internally, the board is implemented as an array in caller's scope, one
element per square. Squares are named conventionally, A1 being bottom left,
H8 top right. Moves are written in the form $from-$to, e.g. A2-A4, and kept
in a history list which can be recalled or undone, one move at a time.
Internally, taken men are recorded as a suffix to the move, e.g. A2-A4-Q,
so they can be reinstated on undo. You can have multiple chess boards in
parallel, if you wish, as the API is "object-oriented":
 chess::new myGame
 myGame move A2-A4
}
 namespace eval chess {set version 0.1}
 proc chess::new board {
    # create a new game (generic dispatcher) with the board name
    proc ::$board {{cmd format} args} \
        "uplevel 1 chess::\$cmd $board \$args"
    uplevel 1 $board reset
 }
 proc chess::reset {boardName {setup ""}} {
    upvar 1 $boardName board
    if {$setup == ""} {set setup \
        "r n b q k b n r
         p p p p p p p p
         . . . . . . . .
         . . . . . . . .
         . . . . . . . .
         . . . . . . . .
         P P P P P P P P
         R N B Q K B N R"
    }
    foreach line [split [string trim $setup] \n] y {8 7 6 5 4 3 2 1} {
        foreach word $line x {A B C D E F G H} {
            set board($x$y) $word
        }
    }
    set board(toMove) white
    set board(history) {} ;# start a new history...
 }
 proc chess::format boardName {
    # render current board into a well-readable string
    upvar 1 $boardName board
    foreach row {8 7 6 5 4 3 2 1} {
        foreach column {A B C D E F G H} {
            set t $board($column$row)
            append res " " $t
        }
        append res \n
    }
    set res
 }
 proc chess::move {boardName move} {
    upvar 1 $boardName board
    foreach {from to} [split $move -] break
    set fromMan $board($from)
    if {$fromMan == "."} {error "no man to move at $from"}
    set toMan   $board($to)
    if ![valid? board $move] {error "invalid move for a [manName $fromMan]"}
    set board($from) .
    set board($to)   $fromMan
    if {$toMan != "."} {append move -$toMan} ;# taken one
    lappend board(history) $move
    set board(toMove) [expr {$board(toMove) == "white"? "black": "white"}]
    set toMan ;# report possible victim
 }
 proc chess::color man {expr {[string is upper $man]? "white" : "black"}}
 
 proc chess::valid? {boardName move} {
    upvar 1 $boardName board
    foreach {from to} [split $move -] break
    if {$to==""} {return 0}
    set fromMan $board($from)
    if {[color $fromMan] != $board(toMove)} {return 0}
    set toMan   $board($to)
    if [sameSide $fromMan $toMan] {return 0}
    foreach {x0 y0} [coords $from] {x1 y1} [coords $to] break
    set dx  [expr {$x1-$x0}]
    set adx [expr {abs($dx)}]
    set dy  [expr {$y1-$y0}]
    set ady [expr {abs($dy)}]
    if {[string tolower $fromMan] != "n" && (!$adx || !$ady || $adx==$ady)} {
        for {set x $x0; set y $y0} {($x!=$x1 || $y!=$y1)} \
          {incr x [sgn $dx]; incr y [sgn $dy]} {
            if {($x!=$x0 || $y!=$y0) && $board([square $x $y])!="."} {
                return 0
            } ;# planned path is blocked
        }
    }
    switch -- $fromMan {
        K - k {expr $adx<2 && $ady<2}
        Q - q {expr $adx==0 || $ady==0 || $adx==$ady}
        B - b {expr $adx==$ady}
        N - n {expr ($adx==1 && $ady==2)||($adx==2 && $ady==1)}
        R - r {expr $adx==0 || $ady==0}
        P {
            expr {(($y0==2 && $dy==2) || $dy==1)
              && (($dx==0 && $toMan==".") ||
                ($adx==1 && $ady==1 && [sameSide p $toMan]))
            }
        }
        p {
            expr {(($y0==7 && $dy==-2) || $dy==-1)
              && (($dx==0 && $toMan==".") ||
                ($adx==1 && $ady==1 && [sameSide P $toMan]))
            }
        }
        default {return 0}
    }
 }
 proc chess::validMoves {boardName from} {
    upvar 1 $boardName board
    set res {}
    foreach to [array names board ??] {
        set move $from-$to
        if [valid? board $move] {
            if {$board($to) != "."} {append move -$board($to)}
            lappend res $move
        }
    }
    lsort $res
 }
 proc chess::coords square {
    # translate square name to numeric coords: C5 -> {3 5}
    foreach {c y} [split $square ""] break
    list [lsearch {- A B C D E F G H} $c] $y
 }
 proc chess::square {x y} {
    # translate numeric coords to square name: {3 5} -> C5
    return [string map {1 A 2 B 3 C 4 D 5 E 6 F 7 G 8 H} $x]$y
 }
 proc chess::undo boardName {
    upvar 1 $boardName board
    if ![llength $board(history)] {error "Nothing to undo"}
    set move [lindex $board(history) end]
    foreach {from to hit} [split $move -]  break
    set board(history) [lrange $board(history) 0 end-1]
    set board($from) $board($to)
    if {$hit==""} {set hit .}
    set board($to) $hit
    set board(toMove) [expr {$board(toMove) == "white"? "black": "white"}]
 }
 proc chess::sameSide {a b} {regexp {[a-z][a-z]|[A-Z][A-Z]} $a$b]}
 
 proc chess::history boardName {uplevel 1 set $boardName\(history)}
 
 proc chess::manName man {
    set table {- k king q queen b bishop n knight r rook p pawn}
    set i [lsearch $table [string tolower $man]]
    lindex $table [incr i]
 }
 proc chess::values boardName {
    # returns the current numeric value of white and black crews
    upvar 1 $boardName board
    set white 0; set black 0
    foreach square [array names board ??] {
        set man $board($square)
        switch -regexp -- $man {
            [A-Z] {set white [expr {$white + [manValue $man]}]}
            [a-z] {set black [expr {$black + [manValue $man]}]}
        }
    }
    list $white $black
 }
 proc chess::manValue man {
    set table {- k 0 q 9 b 3.2 n 3 r 5 p 1}
    set i [lsearch $table [string tolower $man]]
    lindex $table [incr i]
 }
 #----------------------------------------------------------- Tk UI
if 0 {Now we create a "real" chess board on a canvas. The shapes of
men are extremely simple (maybe good for the visually impaired). Clicking on
a man highlights the valid moves in green (possible takes in red) for a
second. Only valid moves are accepted, else the man snaps back to where
he stood. As binidings execute in global scope, the board array has to
be global for the UI.
}
 proc chess::drawBoard {boardName w args} {
    upvar #0 $boardName board
    array set opt {-width 300 -colors {bisque brown} -side white}
    array set opt $args
    if {![winfo exists $w]} {
        canvas $w -width $opt(-width) -height $opt(-width)
    }
    set sqw [expr {($opt(-width) - 20) / 8}]
    set x0 15
    set x $x0; set y 5; set colorIndex 0
    set rows {8 7 6 5 4 3 2 1}
    set cols {A B C D E F G H}
    if {$opt(-side) != "white"} {
        set rows [lrevert $rows]
        set cols [lrevert $cols]
    }
    foreach row $rows {
        $w create text 5 [expr $y+$sqw/2] -text $row
        foreach col $cols {
            $w create rect $x $y [incr x $sqw] [expr $y+$sqw] \
                -fill [lindex $opt(-colors) $colorIndex] \
                -tag [list square $col$row]
            set colorIndex [expr {1-$colorIndex}]
        }
        set x $x0; incr y $sqw
        set colorIndex [expr {1-$colorIndex}]
    }
    set x [expr {$x0 - $sqw/2}]
    incr y 10 ;# letters go below chess board
    foreach col $cols {$w create text [incr x $sqw] $y -text $col}
    set board(canvas) $w
    set board(sqw)    $sqw
    set board(side)   $opt(-side)
    drawSetup $boardName $w
    $w bind mv <1> [list chess::click1 $boardName $w %x %y]
    $w bind mv <B1-Motion> {
        set dx [expr {%x-$chess::x}]
        set dy [expr {%y-$chess::y}]
        %W move current $dx $dy
        set chess::x %x; set chess::y %y
    }
    $w bind mv <ButtonRelease-1> [list chess::release1 $boardName $w %x %y]
    set w
 }
 proc chess::click1 {boardName w cx cy} {
    upvar #0 $boardName board
    variable x $cx y $cy from
    $w raise current
    regexp {@(..)} [$w gettags current] -> from
    foreach move [validMoves board $from] {
        foreach {- to victim} [split $move -] break
        set fill [$w itemcget $to -fill]
        if {$fill != "green" && $fill != "red"} {
            set newfill [expr {$victim==""? "green" : "red"}]
            $w itemconfig $to -fill $newfill
            after 1000 $w itemconfig $to -fill $fill
        }
    }
 }
 proc chess::release1 {boardName w cx cy} {
    upvar #0 $boardName board
    variable from
    set to ""
    foreach i [$w find overlap $cx $cy $cx $cy] {
        set tags [$w gettags $i]
        if {[lsearch $tags square]>=0} {
            set to [lindex $tags end]
            break
        }
    }
    if [valid? board $from-$to] {
        set victim [move board $from-$to]
        if {[string tolower $victim]=="k"} {set ::info Checkmate.}
        $w delete @$to
        set target $to
        $w dtag current @$from
        $w addtag @$to withtag current
    } else {set target $from} ;# go back on invalid move
    foreach {x0 y0 x1 y1}     [$w bbox $target] break
    foreach {xm0 ym0 xm1 ym1} [$w bbox current] break
    set dx [expr {($x0+$x1-$xm0-$xm1)/2}]
    set dy [expr {($y0+$y1-$ym0-$ym1)/2}]
    $w move current $dx $dy
 }
 proc chess::drawSetup {boardName w} {
    upvar #0 $boardName board
    $w delete mv
    foreach square [array names board ??] {
        drawMan $w $square $board($square) $board(sqw)
    }
 }
 proc chess::drawMan {w where what sqw} {
    if {$what=="."} return
    foreach {x0 y0 x1 y1} [$w bbox $where] break
    set fill [expr {[regexp {[A-Z]} $what]? "white": "black"}]
    $w create poly [manPolygon $what] -fill $fill \
            -tag [list mv @$where] -outline gray
    set f [expr {$sqw*0.04}]
    $w scale @$where 0 0 $f $f
    $w move  @$where [expr {($x0+$x1)/2}] [expr {($y0+$y1)/2}]
 }
 proc chess::manPolygon what {
    # very simple shapes of the chess men - feel free to improve!
    switch -- [string tolower $what] {
     b {list -10 8  -5 5  -9 0  -6 -6  0 -10  6 -6  9 0  5 5  10 8\
        6 10  0 6  -6 10}
     k {list -8 10  -10 1  -3 -1  -3 -3  -6 -3  -6 -7  -3 -7  -3 -10\
        3 -10  3 -7  6 -7  6 -3  3 -3  3 -1  10 1  8 10}
     n {list -8 10  -1 -1  -7 0  -10 -4  0 -10  6 -10  10 10}
     p {list -8 10  -3 -1  -6 -5  -2 -10  2 -10  6 -5  3 -1  8 10}
     q {list -6 10  -10 -10  -3 0  0 -10  3 0  10 -10  6 10}
     r {list -10 10  -7 1  -10 0  -10 -10  -5 -10  -5 -6  -3 -6  -3 -10\
          3 -10  3 -6  5 -6  5 -10  10 -10 10 0  7 1  10 10}
    }
 }
 proc chess::flipSides {boardName w} {
    upvar #0 $boardName board
    $w delete all
    set side [expr {$board(side)=="white"? "black": "white"}]
    $boardName drawBoard $w -side $side
 }
 #------------------------------------- some general utilities:
 proc lrevert list {
    set res {}
    set i [llength $list]
    while {$i} {lappend res [lindex $list [incr i -1]]}
    set res
 }
 proc sgn x {expr {$x>0? 1: $x<0? -1: 0}} 
#------------------------------------------------testing demo:
 if {[file tail [info script]]==[file tail $argv0]} {
    chess::new game
    pack [game drawBoard .c]
    frame .f
    label  .f.e -width 30 -anchor w -textvar info -relief sunken
    button .f.u -text Undo  -command {game undo;  game drawSetup .c}
    button .f.r -text Reset -command {game reset; game drawSetup .c}
    button .f.f -text Flip  -command {game flipSides .c}
    eval pack [winfo children .f] -side left -fill both
    pack .f -fill x 
    trace variable game(toMove) w MoveInfo
    proc MoveInfo {- - -} {
        set ::info "$::game(toMove) to move - [chess::values ::game]"
    }
    set info "white to move"
    bind . ?        {console show}
    bind . <Escape> {exec wish $argv0 &; exit}
 }
----
[Tcl/Tk games] - [Arts and crafts of Tcl-Tk programming]