Chess in Forth
A HolonTForth version of Chess in Tcl, a handy chessboard application useful for teaching the basic moves.
Provided both as an example application and for a comparison of Forth and Tcl code.
Note the absence of block markers, statement delimiters and command substitutions.
Model
-----
{} array board
" white" string white
" black" string black
white string toMove
{} list history
: reset ( | setup i x y -- )
cast setup list
{ 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
} setup setlist
0 i set
{ 8 7 6 5 4 3 2 1 } { y } foreach
{ A B C D E F G H } { x } foreach
i setup " $x$y" board put
i incr
repeat
repeat
white toMove set
{} history setlist
: moveMan ( move | to from fromMan -- toMan )
cast move string
" -" move split to set from set
from board fromMan set to board toMan set
toMan " -$toMan" move append
fromMan to board set
" ." from board set
move history append
toMove white = if black else white then toMove set
: color ( c -- color )
c ascii 97 < if white else black then color set
code sameSide? ( a b -- f )
set f [regexp {[a-z][a-z]|[A-Z][A-Z]} $a$b]
white variable side
: valid? ( move | from to fromMan toMan x y x0 y0 x1 y1 dx dy adx ady -- res )
" -" move split to set from set
to {} = if 0 return then
from board fromMan set to board toMan set
fromMan color toMove != if 0 return then
fromMan toMan sameSide? if 0 return then
from coords y0 set x0 set to coords y1 set x1 set
x1 x0 - dup dx set abs adx set y1 y0 - dup dy set abs ady set
fromMan tolower " n" != adx not ady not or adx ady = or and if
x0 x set y0 y set
begin x x1 != y y1 != or while
x x0 != y y0 != or
x y square board " ." != and
if 0 return then \ planned path is blocked
dx sgn x add dy sgn y add
repeat
then
fromMan tolower case
k of adx 2 < ady 2 < and return endof
q of adx 0= ady 0= or adx ady = or return endof
b of adx ady = return endof
n of adx 1 = ady 2 = and adx 2 = ady 1 = and or return endof
r of adx 0= ady 0= or return endof
endcase
fromMan case
P of y0 2 = dy 2 = and dy 1 = or dx 0= toMan " ." = and and
adx 1 = ady 1 = and " p" toMan sameSide? and or return endof
p of y0 7 = dy -2 = and dy -1 = or dx 0= toMan " ." = and and
adx 1 = ady 1 = and " P" toMan sameSide? and or return endof
endcase
0 res set
: validMoves ( from | to move victim -- res )
cast move string
cast res list
{} res setlist
board names { to} foreach
" $from-$to" move set
move valid? if
to board victim set
" -$victim" move append
move res append
then
repeat
res sort
\ Translate square name to numeric coords: C5 -> {3 5}
: coords ( square -- x y )
{} square split y set ascii 64 - x set
\ Translate numeric coords to square name: 3 5 -> C5
: square ( x y -- sq )
x 64 + char x set " $x$y" sq set
\ Full name of man -- use: man Name
{ k king q queen b bishop n knight r rook p pawn } array Name
\ Value of man -- use: man Value
{ k 0 q 9 b 3.2 n 3 r 5 p 1 . 0} array Value
\ Returns the current numeric values of white and black crews.
\ [Locals are set to 0, thus the sums are already initialized. ]
: values ( | square man whitesum blacksum -- res )
board names { square} foreach
square board man set
man tolower Value
man color white = if whitesum add else blacksum add then
repeat
" w:$whitesum b:$blacksum " res set
View
----
" .c" variable w
0 variable X
0 variable Y
{ bisque tan3 } list cColors
: manPolygon ( what -- shape )
what tolower case
b of { -10 8 -5 5 -9 0 -6 -6 0 -10 6 -6 9 0 5 5 10 8
6 10 0 6 -6 10 } endof
k of { -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 } endof
n of { -8 10 -1 -1 -7 0 -10 -4 0 -10 6 -10 10 10 } endof
p of { -8 10 -8 7 -5 7 -2 -1 -4 -5 -2 -10 2 -10 4 -5
2 -1 5 7 8 7 8 10 } endof
r of { -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 } endof
q of { -6 10 -10 -10 -3 0 0 -10 3 0 10 -10 6 10 } endof
endcase shape put
35 variable sqw
\ 'where' is square in board (eg 3E), '@where' is preliminary tag for creating
\ shape (@3E)
: drawMan ( where what | f fill shape x0 y0 x1 y1 -- )
what " ." = if return then
w what manPolygon what uppercase?
if white " black" else black " grey" then " mv @$where" createPoly
sqw 0.035 * f set
w " @$where" 0 0 f f scaleTag
w " $where" tagBox y1 set x1 set y0 set x0 set
w " @$where" x0 x1 + 2 / y0 y1 + 2 / moveTag
code bindBoard ( w -- )
bind $w "push $w; drawBoard "
$w bind mv <1> "push $w; push %x; push %y; click1 "
$w bind mv {
%W move current [expr {%x-$::X}] [expr {%y-$::Y}]
set ::X %x; set ::Y %y
}
$w bind mv "push $w; push %x; push %y; release1 "
: drawBoard ( | x0 x y rows row cols col cIndex tag -- )
cast rows list
cast cols list
w windowExists
if w " all" deleteTags
else w createCanvas
w bindBoard
then
15 x0 put x0 x put 5 y put 0 cIndex put 35 sqw put
{ 8 7 6 5 4 3 2 1 } rows setlist
{ A B C D E F G H } cols setlist
side white != if rows revert cols revert then
rows getlist { row} foreach
w 5 y sqw 2 / + row createText
cols getlist { col} foreach
w x y sqw x add x y sqw + cIndex cColors " square $col$row"
createRect
1 cIndex - cIndex put
repeat
x0 x put sqw y add
1 cIndex - cIndex put
repeat
x0 sqw 2 / - x put
8 y add \ letters go below chess board
cols getlist { col} foreach
sqw x add
w x y col createText
repeat
w drawSetup
0 variable info
\ Tcl string substitution is very welcome in HolonTForth.
: MoveInfo ( | v -- )
" $::toMove to move - [values; pop]" info set
\ Need procedure to accept the three arguments for a trace command. The
\ arguments are not used here. Colonwords can be called from Tcl procs.
proc doMoveInfo {- - -} {
MoveInfo
}
\ Create the board
code theBoard ( -- )
frame .f
label .f.e -width 30 -anchor w -textvar info -relief sunken
button .f.u -text Undo -command {undo; push .c; drawSetup }
button .f.r -text Reset -command {reset; push .c; drawSetup}
button .f.f -text Flip -command {push .c; flipSides}
eval pack [winfo children .f] -side left -fill both
pack .f -fill x -side bottom
pack .c -fill both -expand 1
trace add variable ::toMove write doMoveInfo
bind . ? {console show}
bind . {exit}
set ::info "white to move"
wm title . "Chess in Forth"
: drawChess ( -- )
w destroy
" .f" destroy
reset
drawBoard
theBoard
Control
-------
code getFrom ( w -- from )
$w raise current
regexp {@(..)} [$w gettags current] -> from
\ Stores from between click and release.
0 variable From
: click1 ( w cx cy | fill move victim to fill newfill -- )
cx X set cy Y set
w getFrom From set
From validMoves { move} foreach
{ -} move split victim set to set drop
w to " -fill" ItemGet fill set
fill " green" != fill " red" != and if
victim " ." = if " green" else " red" then newfill set
w to " -fill" newfill ItemPut
" $w itemconfigure $to -fill $fill" 1000 doafter
then
repeat
: release1 ( w cx cy | to i tags victim target x0 y0 x1 y1 xm0 ym0 xm1 ym1 -- )
cast tags list
{} to set
w " overlap $cx $cy $cx $cy" canvasFind { i } foreach
w i getTags tags setlist
" square" tags search 0 >= if tags pop to set break then
repeat
" $::From-$to" valid?
if " $::From-$to" moveMan victim set
victim tolower " k" = if " Checkmate" info set then
w " @$to" deleteTags
w " current" " @$::From" DTags
w " @$to" " withtag" " current" addTag
to target set
else From target set \ go back on invalid move
then
w target tagBox y1 set x1 set y0 set x0 set
w " current" tagBox ym1 set xm1 set ym0 set xm0 set
w " current" x0 x1 + xm0 - xm1 - 2 / y0 y1 + ym0 - ym1 - 2 / moveTag
: drawSetup ( w | x y -- )
w " mv" deleteTags
9 1 do
9 1 do
doI y set
doJ 64 + char x set
" $x$y" dup board drawMan
loop
loop
: undo ( | from to hit -- )
history length 0= if " Nothing to undo" ErrorMsg then
" -" history pop split hit set to set from set
to board from board set
hit {} = if " ." else hit then to board set
toMove white = if black else white then toMove set
: flipSides ( w -- )
w " all" deleteTags
side white = if black else white then side set
w drawBoard
drawChess