----
[WikiDbImage chess.jpg] [WikiDbImage chessfont.jpg]
----
''This version 0.2 supports dynamic resizing.''
----

[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 piece'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.
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.2 ;# resize on <Configure>}
 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} {
            append res " " $board($column$row)
        }
        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 sq uare 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"? "bl ack": "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 [l search $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 b oard ??] {
        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 {
    array set a {k 0 q 9 b 3.2 n 3 r 5 p 1}
    set a([string tolower $man])
 }
 #----------------------------------------------------------- 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 bindings 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 tan3} -side white -usefont 0}
    array set opt $args
    if {![winfo exists $w]} {
        canvas $w -width $opt(-width) -height $opt(-width)
        bind $w <Configure> "chess::drawBoard $boardName $w $args"
        set board(usefont) $opt(-usefont)
        $w bind mv <1> [list chess::click1 $boardName $w %x %y]
        $w bind mv <B1-Motion> {
            %W move current [expr {%x-$chess::x}] [expr {%y-$chess::y}]
            set chess::x %x; set chess::y %y
        }
        $w bind mv <ButtonRelease-1> "chess::release1 $boardName $w %x %y"
    } else {
        $w delete all
    }
    set board(side)   $opt(-side)
    set dim [min [winfo height $w] [winfo width $w]]
    if {$dim<2} {set dim $opt(-width)}
    set board(sqw) [set sqw [expr {($dim - 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 {$board(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 8 ;# letters go below chess board
    foreach col $cols {$w create text [incr x $sqw] $y -text $col}
    drawSetup $boardName $w
    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 $boardName $w $square $board($square)
    }
 }
 proc chess::drawMan {boardName w where what} {
    if {$what=="."} return
    upvar #0 $boardName board
    set fill [expr {[regexp {[A-Z]} $what]? "white": "black"}]
    if $board(usefont) {
        set unicode [string map {
            k \u265a q \u265b r \u265c b \u265d n \u265e p \u265f
          k K q Q r R b B n N p P
        } [string tolower $what]]
        set font [list Helvetica [expr {$board(sqw)/2}] bold]
        $w create text 0 0 -text $unicode -font $font \
            -tag [list mv @$where] -fill $fill
    } else {
        $w create poly [manPolygon $what] -fill $fill \
            -tag [list mv @$where] -outline gray
        set f [expr {$board(sqw)*0.035}]
        $w scale @$where 0 0 $f $f
    }
    foreach {x0 y0 x1 y1} [$w bbox $where] break
    $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  -8 7  -5 7  -2 -1  -4 -5  -2 -10  2 -10  4 -5 \
          2 -1  5 7  8 7  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 min args {lindex [lsort -real $args] 0}
 proc sgn x {expr {$x>0? 1: $x<0? -1: 0}} 
#------------------------------------------------testing demo:
 if {[file tail [info script]]==[file tail $argv0]} {
    chess::new game
    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 -side bottom
    pack [game drawBoard .c] -fill both -expand 1    
    trace variable game(toMove) w MoveInfo
    proc MoveInfo {- - -} {
        set ::info "$::game(toMove) to move - [chess::values ::game]"
    }
    set info "white to move"
    bind . <3> {
        set game(usefont) [expr 1-$game(usefont)]
        event generate .c <Configure>
    }
    bind . ?        {console show}
    bind . <Escape> {exec wish $argv0 &; exit}
 }
----
[KBK] - I love it, except for the shapes of the chessmen. Are you aware that the chessmen have Unicode symbols (\u2654-\u265f)?
[RS]: No, I wasn't - thanks for the hint! I made this configurable (maybe not everybody has a font that supplies these... - Arial Unicode MS, as from Office 2000, seems to have them). Use the ''-usefont 1'' switch on the ''drawBoard'' command to get an appearance like on the second screenshot. (The Unicodes I chose use only glyphs of black men, but repaint the white ones - the originals were transparent internally and didn't come out well). You can toggle the two representations with right mouseclick.

[MDD]: Cool.  You could use [Tequila] to make a simple two-player net version.  If you did that, it would be pretty straightforward to add a persistent game DB too.

[Lars H]: Very nice (IMO even with the crude chessmen). A few of the basic moves are however still missing:
   * '''En passant''' (a pawn that moved two squares in the previous move is taken by a pawn from the other side, as if the taken pawn had just moved one square). ''Implementation catch:'' When undoing, the pawn is not put back on the square to which the taking pawn moved.
   * '''Check''' Currently, no notice is taken of whether there is currently a check. This is important, since it limits the number of allowed moves; a player may not make a move that puts his own king in check, and a player whose king is in check must make a move that gets the king out of check. If the program took this into account when determining valid moves, I would definitely label it as child-safe.
   * '''Castling''' (king moves two squares towards a rook, the rook is placed on the square that the king passed). This is a serious restriction, since experienced chess-players usually seek to make this move. The king may not end up in check, or pass through an intermediate position where it would be in check. ''Implementation catch:'' Requires that the history list is redesigned, since two men move in the same move.

Also, if there was an option to have a visible history list (perhaps as text widget in a separate toplevel window), with a more "chessy" notation (like Ke1-e2 instead of E1-E2, Qd1xg4 instead of D1-G4-p, etc.) then it would look a lot more professional.
----
[JeeBee, June 2007]: I used this code as a starting point for chess in my games plugin for aMSN. The source can be found here: http://amsn.svn.sourceforge.net/viewvc/amsn/trunk/amsn-extras/plugins/games/Chess.tcl?revision=8761&view=markup.
----
[MNO]: Are you aware of Scid?  A free chess database program written in Tcl/Tk extended in C++ http://scid.sourceforge.net/

----
[MPJ] has tweaked the above code so it fits well on a [PocketPC].  I also figured out how to add online play using [TclSOAP] and a Web Service listed on http://www.xmethods.net.  Check it out at [Play Chess With a WebService].
----
[MNO] I've recently been working on an internet chess server client, [PocketICS], for PocketPC to connect to chessclub.com or freechess.org.  It's nearly finished (still have some niggly things to fix such as queening of pawns!) but corrently stuck owing to the problems described on the [PocketPC socket/fileevent strangeness] page.
----
[Michael Schlenker]: Dumping the history as LaTeX file using chess.sty would be nice. Or similar functionality.
----
[MDD]:  I just noticed that it doesn't support queening of pawns.  I should also add that my 5-year-old daughter, who is in the process of learning chess, really likes this app since it highlights both possible moves and potential captures for her.
----
Can someone update this page so that it is [wish-reaper] ready?
''[escargo] 24 Nov 2003'' - I changed the formatting of the abbreviations and corrected
an added space; I used [wish-reaper] on it and ran it on my [Windows] XP laptop.  I
find that the white pieces don't show up all that well on my laptop screen, but other
than that it seems to work.
----
[Tcl/Tk games] - [Arts and crafts of Tcl-Tk programming] - [Category Games]
- [Category Application]