spinix-hive/pfth/chess.fth

642 lines
12 KiB
Forth

\ This program was written by Lennart Benschop and converted to ANS Forth by
\ by Jeff Fox. It was further modified by Dave Hein to run under pfth. The
\ orignal source is available at http://www.ultatechnology.com/chess.html.
HEX
: scroll cr ;
: cls page ;
: key? 1 ;
: off false swap ! ;
: >defer 2 + w@ 4 - ;
3 constant maxlevel
create bp0
maxlevel 1 + c0 * allot
variable bpv
: bp bpv @ ;
: b@ bpv @ + c@ ;
: b! bpv @ + c! ;
: boardvar create ,
does> c@ bpv @ + ;
0c boardvar start
0d boardvar castlew
0e boardvar castleb
0f boardvar ep
1c boardvar starting
1d boardvar piece
1e boardvar best
1f boardvar farther?
2c boardvar wlcastle?
2d boardvar blcastle?
2e boardvar check
2f boardvar pawnmove
3c boardvar kingw
3d boardvar kingb
3e boardvar inpassing
3f boardvar advance
4c boardvar valuew
5c boardvar alfa
6c boardvar beta
7c boardvar (eval)
8c boardvar highest
9c boardvar cutoff
ac boardvar valueb
bc boardvar played
variable level
variable lastcnt
: timeit cnt@ dup lastcnt @ - 80 / space . lastcnt ! ;
: +level
\ ." +LEVEL" timeit cr
bp dup c0 + c0 cmove
c0 bpv +! 1 level +! ;
: -level
\ ." -LEVEL" timeit cr
-c0 bpv +! -1 level +! ;
create symbols
CHAR . , CHAR p , CHAR k , CHAR b ,
CHAR r , CHAR q , CHAR K ,
create values
0 , 40 , c0 , c0 , 140 , 240 , 3000 ,
: .board
\ ." .BOARD" timeit cr
cls
0 0 at-xy 20 spaces
cr 2 spaces
[CHAR] H 1 + [CHAR] A do i emit 2 spaces loop
bp 20 + 8 0 do
cr 20 spaces
cr [CHAR] 8 i - emit
0a 2 do space
dup i + c@ dup
07 and cells symbols + 1 type
dup 80 and if ." W" drop else
if ." B" else ." ." then
then
loop
10 +
loop cr drop ;
: .pos
\ ." .POS" timeit cr
10 /mod
swap 2 - [CHAR] A + emit
[CHAR] 8 2 + swap - emit ;
\ constants that indicate the directions on the board
-11 constant nw -0f constant no
0f constant zw 11 constant zo
-10 constant n 10 constant z
-1 constant w 1 constant o
create spring
-12 , -21 , -1f , -0e , 12 , 21 , 1f , 0e ,
defer tmove
defer attacktest
: mine?
\ ." MINE? " depth . timeit cr
b@ dup 0= 0= swap 80 and start c@ = and ;
variable movits
: moveit
\ ." MOVEIT" timeit cr
starting c@ best c! 1 farther? c!
begin
best c@ over + dup best c!
dup mine? over b@ 87 = or 0=
farther? c@ and while
tmove
b@ 0= farther? c!
repeat
drop drop
1 movits +! ;
: Bishop
\ ." BISHOP" timeit cr
no nw zo zw moveit moveit moveit moveit ;
: Rook
\ ." ROOK" timeit cr
n o z w moveit moveit moveit moveit ;
: Queen
\ ." QUEEN" timeit cr
n o z w no nw zo zw 8 0 do moveit loop ;
: Knight
\ ." KNIGHT" timeit cr
8 0 do
i cells spring + @
starting c@ + dup best c!
dup mine? swap b@ 87 = or 0=
if tmove then
loop ;
: ?castle
\ ." ?CASTLE" timeit cr
start c@ 80 = if castlew else castleb then c@ check c@ 0= and ;
: ?lcastle
\ ." ?LCASTLE" timeit cr
start c@ 80 = if wlcastle? else blcastle? then c@ check c@ 0= and ;
: king
\ ." KING" timeit cr
n o z w no nw zo zw 8 0 do
starting c@ + dup best c!
dup mine? swap b@ 87 = or 0=
if tmove then
loop
?castle if 28 start c@ if 70 + then
dup bp + 1- @ 0=
if
dup 1- attacktest 0=
if
best c! tmove
else drop then
else drop then
then
?lcastle if 24 start c@ if 70 + then
dup bp + @ over bp + 1- @ or 0=
if
dup 1 + attacktest 0=
if
best c! tmove
else drop then
else drop then
then ;
: Pawnrow
\ ." PAWNROW" timeit cr
start c@ if negate then ;
: Pawnz
\ ." PAWNZ" timeit cr
dup best c!
f0 and start c@ if 20 else 90 then =
if 6 2 do i advance c! tmove loop
else tmove then
0 pawnmove c! 0 inpassing c! 0 advance c! ;
: Pawn
\ ." PAWN" timeit cr
starting c@ z Pawnrow +
dup b@ if
drop
else
dup Pawnz
z Pawnrow + dup b@ if
drop
else
starting c@ f0 and
start c@ if 80 else 30 then =
if starting c@ 0f and pawnmove c!
Pawnz
else drop
then
then
then
zw zo 2 0 do
Pawnrow starting c@ +
dup f0 and start c@ if 40 else 70 then =
over 0f and ep c@ = and
if 1 inpassing c!
dup Pawnz
then
dup b@ dup 0= 2 pick mine? or
swap 87 = or
if drop else Pawnz then
loop ;
create pieces
' noop , ' Pawn , ' Knight , ' Bishop , ' Rook , ' Queen , ' king ,
: piecemove
\ ." PIECEMOVE" timeit cr
\ using above jump table for each type of piece - jump table uses , (CELLS)
piece c@ cells pieces + @ execute ;
: ?piecemove
\ ." ?PIECEMOVE" timeit cr
starting c@ dup mine? if
b@ 07 and piece c!
0 pawnmove c! 0 inpassing c! 0 advance c!
piecemove
else drop then ;
: allmoves
\ ." ALLMOVES" timeit cr
[char] . emit
start c@ 0= if
22 starting c!
8 0 do
8 0 do
?piecemove starting c@ 1 + starting c!
loop
starting c@ 8 + starting c!
loop
else
92 starting c!
8 0 do
8 0 do
?piecemove starting c@ 1 + starting c!
loop
starting c@ 18 - starting c!
loop
then ;
variable attack
: ?attack
\ ." ?ATTACK" timeit cr
best c@ dup mine? 0=
swap b@ 07 and piece c@ = and
attack @ or attack ! ;
: attacked?
\ ." ATTACKED?" timeit cr
attack off 0 7 1 do
i piece c!
piecemove
attack @ if drop 1 leave then
loop ;
variable starting'
variable best'
variable start'
variable tmove'
: settest
starting c@ starting' c!
best c@ best' c!
start c@ start' c!
['] tmove >defer tmove' !
['] ?attack is tmove ;
: po@
starting' c@ starting c!
best' c@ best c!
start' c@ start c!
tmove' @ is tmove ;
: changecolor
start c@ 80 xor start c! ;
variable endf
variable playlevel
variable #legal
variable selected
variable compcolor
variable move#
create bp1 c0 allot
: endgame?
start c@ if valueb else valuew then @ c1 < ;
: evalboard
valueb @ valuew @ - start c@ if negate then
55 mine? 1 and + 56 mine? 1 and + 65 mine? 1 and + 66 mine? 1 and +
changecolor 55 mine? + 56 mine? + 65 mine? + 66 mine? + changecolor
endgame? if
start c@ if kingb else kingw then c@
dup f0 and dup 20 = swap 90 = or 7 and
swap 0f and dup 2 = swap 9 = or 7 and + +
then ;
: ?check
settest
start c@ if kingw else kingb then c@
starting c! attacked? check c!
po@ ;
: (attacktest)
['] tmove >defer ['] ?attack <> if
settest
starting c!
attacked?
po@
else drop true
then ;
' (attacktest) is attacktest
variable seed
: rnd
seed @ 743 * 43 + dup seed ! ;
\ 1 ;
: domove
best c@ b@ 7 and cells values + @ negate start c@
if valueb else valuew then +!
starting c@ b@ best c@ b!
0 starting c@ b!
advance c@ if
advance c@ dup cells values + @ 40 - start c@
if valueb else valueb then +!
start c@ or best c@ b!
then
piece c@ 4 = if
starting c@ 0f and 2 =
if
0 start c@ if wlcastle? else blcastle? then c!
then
starting c@ 0f and 9 =
if
0 start c@ if castlew else castleb then c!
then
then
piece c@ 6 = if
0 0 start c@ if castlew else castleb then dup >r c!
r> 1f + c!
best c@ starting c@ - 2 =
if
4 start c@ or best c@ 1- b!
0 best c@ 1 + b!
then
best c@ starting c@ - -2 =
if
4 start c@ or best c@ 1 + b!
0 best c@ 2 - b!
then
best c@ start c@ if kingw else kingb then c!
then
inpassing c@ if
0 best c@ n Pawnrow + b!
-40 start c@ if valueb else valuew then +!
then
pawnmove c@ ep c! ;
: deeper
cutoff @
invert if
+level
domove
?check check c@ if -level exit then
-1 played c0 - !
level @ playlevel @ = if
evalboard
(eval) c0 - !
else
alfa @ highest !
alfa @ negate beta @ negate alfa ! beta !
changecolor
0 played !
allmoves
played @ 0= if
?check check c@ if -2000 highest ! else 0 highest ! then
then
highest @ negate
(eval) c0 - !
then
-level
(eval) @ highest @ max
highest !
highest @ beta @ > if TRUE cutoff ! then
then ;
: analyse
+level
domove
?check check c@ 0= if
1 #legal +!
changecolor
['] tmove >defer
['] deeper is tmove
0 played !
allmoves
is tmove
played @ 0= if
?check check c@ if -2000 highest ! else 0 highest ! then
then
highest @ beta c0 - @ = if
rnd 2000 > if #legal @ selected ! then
then
highest @ beta c0 - @ < if
#legal @ selected !
highest @ beta c0 - !
then
then
-level ;
: select
+level
domove
?check check c@ 0= if
1 #legal +!
#legal @ selected @ = if
bp bp1 c0 cmove
starting c@ .pos ." -" best c@ .pos space
then
then
-level ;
: against
+level
domove
?check check c@ 0= if
1 #legal +!
then
-level ;
: compmove
.board
['] analyse is tmove
0 #legal !
-4000 alfa ! 4000 beta !
\ 0 18 at-xy cr
scroll
\ 28 spaces
start c@ if 1 move# +! move# @ 3 .r space else 4 spaces then
?check check c@ if ." Check" then
1 selected !
allmoves
#legal @ 0= if
check c@ if
." mate"
else
." Pat"
then
TRUE endf !
else
['] select is tmove
0 #legal !
allmoves
bp1 bp0 c0 cmove
changecolor
['] against is tmove
0 #legal !
allmoves
?check check c@ if ." Check" then
#legal @ 0= if
check c@ if
." mate"
else
." Pat"
then
TRUE endf !
then
then
.board ;
variable startingm
variable bestm
variable personmove
: legal
\ ." LEGAL" timeit cr
startingm @ starting c@ =
bestm @ best c@ = and
personmove @ advance c@ = and
if
\ ." LEGAL 1" timeit cr
+level
domove
?check check c@ 0= if
\ ." LEGAL 2" timeit cr
1 #legal !
bp bp1 c0 cmove
then
-level
\ ." LEGAL 3" timeit cr
then ;
create inputbuf 6 allot
: inpos
dup inputbuf + c@ [CHAR] A -
dup 8 u<
rot inputbuf + 1 + c@ [CHAR] 1 -
dup 8 u< rot and
swap 7 swap - 10 * rot + 22 + ;
: promote
0 6 2 do over symbols i cells + c@ = if drop i then loop ;
: person
begin
.board
\ 0 18 at-xy timeit cr
scroll
\ 28 spaces
start c@ if 1 move# +! move# @ 3 .r else 3 spaces then
inputbuf 5 expect cr
\ [char] X emit inputbuf 5 type [char] X emit
inputbuf c@ [CHAR] Q = if quit then
0 inpos startingm !
2 inputbuf + c@ [CHAR] - = and
3 inpos bestm !
and
bestm @ f0 and start c@ if 20 else 90 then =
startingm b@ 07 and 1 = and
if
." What piece? " 0 0 begin drop drop key promote dup until
personmove ! emit
else
0 personmove !
then
if
\ ." Trace 1" timeit cr
['] legal is tmove
0 #legal !
startingm c@ starting c! ?piecemove
#legal @
else
\ ." Trace 2" timeit cr
0
then
\ ." Trace 3" timeit cr
dup 0= start c@ and if -1 move# +! then
until
\ ." Trace 4" timeit cr
bp1 bp0 c0 cmove
changecolor
cr
\ ." Trace 5" timeit cr
.board ;
: setmove
compcolor @ 0< start c@ 80 = = if compmove else person then ;
variable manVsMachine
: askcolor
manVSmachine @
if ." Do you want White Y/N"
key dup [CHAR] Y = swap [CHAR] y = or
if 1 else -1 then compcolor !
then ;
: asklevel
cr ." Level? 2-"
maxlevel . key [CHAR] 0 - 2 max maxlevel min playlevel !
cls ;
: init
0 level ! bp0 bpv !
bp c0 87 fill
4 2 3 6 5 3 2 4 8 0 do bp 22 + i + c! loop
bp 32 + 8 01 fill
bp 42 + 8 00 fill bp 52 + 8 00 fill
bp 62 + 8 00 fill bp 72 + 8 00 fill
bp 82 + 8 81 fill
84 82 83 86 85 83 82 84 8 0 do bp 92 + i + c! loop
1 castlew c! 1 castleb c! 0 ep c! 1 wlcastle? c! 1 blcastle? c! 0 advance c!
80 start c! 96 kingw c! 26 kingb c!
askcolor cr asklevel
0 move# ! 0 endf !
0 check c! 9c0 valuew ! 9c0 valueb ! ;
: play
begin setmove endf @ until ;
: games
begin init play again ;
: autoplay
begin setmove compcolor @ negate compcolor ! key? if quit then endf @ until ;
: auto
init -1 compcolor ! autoplay ;
: chess
cls
." ANS Forth Chess" cr
." Do you want to play against the computer? Y/N" cr
begin rnd drop key? until key
dup [CHAR] Y = swap [CHAR] y = or dup manVsMachine !
if games else auto then ;
decimal