609 lines
12 KiB
Forth
Executable File
609 lines
12 KiB
Forth
Executable File
\ 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
|
|
|
|
: +level
|
|
bp dup c0 + c0 cmove
|
|
c0 bpv +! 1 level +! ;
|
|
|
|
: -level
|
|
-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
|
|
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
|
|
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?
|
|
b@ dup 0= 0= swap 80 and start c@ = and ;
|
|
|
|
variable movits
|
|
|
|
: moveit
|
|
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
|
|
no nw zo zw moveit moveit moveit moveit ;
|
|
|
|
: Rook
|
|
n o z w moveit moveit moveit moveit ;
|
|
|
|
: Queen
|
|
n o z w no nw zo zw 8 0 do moveit loop ;
|
|
|
|
: Knight
|
|
8 0 do
|
|
i cells spring + @
|
|
starting c@ + dup best c!
|
|
dup mine? swap b@ 87 = or 0=
|
|
if tmove then
|
|
loop ;
|
|
|
|
: ?castle
|
|
start c@ 80 = if castlew else castleb then c@ check c@ 0= and ;
|
|
|
|
: ?lcastle
|
|
start c@ 80 = if wlcastle? else blcastle? then c@ check c@ 0= and ;
|
|
|
|
: king
|
|
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
|
|
start c@ if negate then ;
|
|
|
|
: Pawnz
|
|
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
|
|
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
|
|
\ using above jump table for each type of piece - jump table uses , (CELLS)
|
|
piece c@ cells pieces + @ execute ;
|
|
|
|
: ?piecemove
|
|
starting c@ dup mine? if
|
|
b@ 07 and piece c!
|
|
0 pawnmove c! 0 inpassing c! 0 advance c!
|
|
piecemove
|
|
else drop then ;
|
|
|
|
: allmoves
|
|
[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
|
|
best c@ dup mine? 0=
|
|
swap b@ 07 and piece c@ = and
|
|
attack @ or attack ! ;
|
|
|
|
: attacked?
|
|
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
|
|
startingm @ starting c@ =
|
|
bestm @ best c@ = and
|
|
personmove @ advance c@ = and
|
|
if
|
|
+level
|
|
domove
|
|
?check check c@ 0= if
|
|
1 #legal !
|
|
bp bp1 c0 cmove
|
|
then
|
|
-level
|
|
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
|
|
|
|
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
|
|
['] legal is tmove
|
|
0 #legal !
|
|
startingm c@ starting c! ?piecemove
|
|
#legal @
|
|
else
|
|
0
|
|
then
|
|
dup 0= start c@ and if -1 move# +! then
|
|
until
|
|
bp1 bp0 c0 cmove
|
|
changecolor
|
|
|
|
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
|