Version 1 of Chess in Tcl
Updated 2002-09-16 10:45:56
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 UIif 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 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}
}