Version 28 of Chess in Tcl
Updated 2003-09-16 13:58:20
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 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 imple mented 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.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 b oard(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 -$t oMan} ;# 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} {
u pvar 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
}
}
ls ort $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 UIif 0 {Now we create a "real" chess board on a canvas. The shapes of men are ex tremely si mple (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 boa rd 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 {boardN ame 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 [linde x $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 cur rent @$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 tog gle 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 w ith the crude chessmen). A few of the basic moves are however still missing:
- 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 expe rienced chess-players usually seek to make this move. Implementation catch: Requires that the history list is redesigned, since two men moves in the same move.
- En passant (a pawn that moved two squares in the previous move is taken by a paw n 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.
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.
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.
Tcl/Tk games - Arts and crafts of Tcl-Tk programming - Category Games - [Category Application]