|
DataMuseum.dkPresents historical artifacts from the history of: CP/M |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about CP/M Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 85376 (0x14d80)
Types: TextFile
Names: »CHESS80.PAS«
└─⟦121d96d60⟧ Bits:30005835 RC Chess 750 source code
└─⟦this⟧ »CHESS80.PAS«
program chess(input,output);
(* chess.p00 *)
label
1,
2,
9;
const
aa = 1; za = 10;
ac = '*'; zc = 'Z';
ad = -21; zd = +21;
aj = 1; zj = 78;
ak = 0; zk = 24;
akm2 = -2; zkp1= 25;
al = 0; zl = 119;
azl = -119; zal= 119;
an = 1; zn = 30; znn = 40;
as = 0; zs = 63;
att = -1; zt = 63;
av = -32767; zv = +32767;
aw = 1; zw = 500;
ax = 0; zx = 63;
ay = 0; zy = 3; zyb = 7;
lpp = 20;
syncf = 1;
syncl = 36;
synmf = 37;
synml = 47;
type
(* simple types *)
ta = aa..za;
tb = boolean;
tc = char;
td = ad..zd;
te = (b1,b2,b3,b4,s1,s2,s3,s4,n1,n2,n3,n4,n5,n6,n7,n8);
tf = (f1,f2,f3,f4,f5,f6,f7,f8);
tg = (pq,pr,pn,pb);
th = (h0,h1,h2,h3,h4,h5,h6,h7);
ti = integer;
tj = aj..zj;
tk = ak..zk;
tl = al..zl;
tm = (lite,dark,none);
tn = an..zn;
tnn = an..znn;
tp = (lp,lr,ln,lb,lq,lk,dp,dr,dn,db,dq,dk,mt);
tq = (ls,ll,ds,dl);
tr = (r1,r2,r3,r4,r5,r6,r7,r8);
ts = as..zs;
tt = att..zt;
tu = (ep,er,en,eb,eq,ek);
tv = av..zv;
tw = aw..zw;
tx = ax..zx;
ty = ay..zy;
tyb = ay..zyb;
tz = real;
byte = 0..255;
(* sets *)
sc = set of ac..zc;
sf = set of tf;
sq = set of tq;
sr = set of tr;
sx = set of tx;
(* records *)
rc = arrayÆtsÅ of tp;
rb = record
rbtm : tm;
rbts : tt;
rbti : ti;
rbsq : sq;
case integer of
0: (rbis: rc);
1: (rbirf: array Ætr,tfÅ of tp);
end;
ra = packed arrayÆtaÅ of tc;
rn = packed array ÆtnÅ of tc;
rnn = packed array ÆtnnÅ of tc;
rj = packed array ÆtjÅ of tc;
rd = packed record
rdpc : tb;
rdsl : tb;
rdkq : tb;
rdnb : tb;
rdrk : tb;
end;
rm = packed record
rmfr : ts;
rmto : ts;
rmcp : tp;
rmca : tb;
rmac : tb;
rmch : tb;
rmmt : tb;
rmil : tb;
rmsu : tb;
case rmpr : tb of
false:(
case rmoo : tb of
false : (rmep : tb);
true : (rmqs : tb);
);
true: (rmpp : tg);
end;
rs = packed record
case integer of
0: (rsss : sx);
1: (rsti : array ÆtyÅ of ti);
2: (rsbt : packed array ÆtybÅ of byte);
end;
rx = array ÆtsÅ of rs;
ry = packed record
ryls : rd;
rych : tc;
ryrs : rd;
end;
re = array ÆtwÅ of tv;
rf = array ÆtwÅ of rm;
var
(* data base *)
board : rb;
nbord : rc;
atkfr : rx;
atkto : rx;
alatk : array ÆtmÅ of rs;
tploc : array ÆtpÅ of rs;
tmloc : array ÆtmÅ of rs;
moves : rf;
valuu : re;
alloc : array ÆtkÅ of rs;
bstmv : array ÆtkÅ of tw;
bstvl : array Æakm2..zkp1Å of tv;
cstat : array ÆtkÅ of rs;
enpas : array ÆtkÅ of rs;
genpn : array ÆtkÅ of rs;
gento : array ÆtkÅ of rs;
genfr : array ÆtkÅ of rs;
mbval : array ÆtkÅ of tv;
mvsel : array ÆtkÅ of ti;
index : array Æak..zkp1Å of tw;
killr : array ÆtkÅ of rm;
lindx : array ÆtkÅ of tw;
srchm : array ÆtkÅ of th;
castle: array ÆtmÅ of tb;
going : ti;
lstmv : rm;
maxps : tv;
mblte : tv;
mbpwn : array ÆtmÅ of ti;
mbtot : tv;
nodes : ti;
jntk : tk;
jmtk : tk;
jntm : tm;
jntw : tw;
jfmv : tb;
(* lets *)
fkpshd: ti;
fksanq: ti;
fmaxmt: ti;
stages: ti;
fpadcr: array ÆtfÅ of ti;
fpblok: ti;
fpconn: ti;
fpflnx: ti;
frdubl: ti;
frk7th: ti;
ftrade: ti;
ftrdsl: ti;
ftrpok: ti;
ftrpwn: ti;
fwking: ti;
fwmajm: ti;
fwminm: ti;
fwpawn: ti;
fwrook: ti;
fcheck: ti;
fwattk: ti;
faking: ti; (* bonus for attack opp. king *)
fcfree: ti; (* bonus for castle free square *)
window: ti;
(* switches *)
swec : tb;
swpa : tb;
swps : tb;
swre : tb;
swsu : tb;
swtr : tb;
swpr : tb;
swbm : tb;
(* command processing data *)
com : ti;
icard : rj;
iline : rj;
jmtj : tj;
jntj : tj;
movms : rnn;
(* translation tables *)
xspb : array ÆtpÅ of tb;
xfpe : array ÆtpÅ of te;
xlld : array Æazl..zalÅ of td;
xlpe : array ÆtpÅ of te;
xrfs : array ÆtfÅ of rs;
xrrs : array ÆtrÅ of rs;
xnfs : array ÆtfÅ of rs;
xnrs : array ÆtrÅ of rs;
xrss : array ÆtsÅ of rs;
xrqm : array ÆtqÅ of rm;
xsqs : array ÆtqÅ of rs;
xssx : array ÆtsÅ of sx;
xtbc : array ÆtbÅ of tc;
xted : array ÆteÅ of td;
xtgc : array ÆtgÅ of tc;
xtgmp : array Ætg,tmÅ of tp;
xtls : array ÆtlÅ of tt;
xtma : array ÆtmÅ of ra;
xtmq : array ÆtmÅ of tq;
xtmv : array ÆtmÅ of tv;
xtpc : array ÆtpÅ of tc;
xtpm : array ÆtpÅ of tm;
xtpu : array ÆtpÅ of tu;
xtpv : array ÆtpÅ of tv;
xtqa : array ÆtqÅ of ra;
xtqs : array ÆtqÅ of ts;
xtrfs : array Ætr,tfÅ of ts;
xtsf : array ÆtsÅ of tf;
xtsl : array ÆtsÅ of tl;
xtsr : array ÆtsÅ of tr;
xtsx : array ÆtsÅ of tx;
xtsy : array ÆtsÅ of ty;
xtuc : array ÆtuÅ of tc;
xtump : array Ætu,tmÅ of tp;
xrqso : array ÆtqÅ of rs;
xrqsa : array ÆtqÅ of rs;
edge : array ÆteÅ of rs;
ct : array Æ0..255Å of ts;
cornr : rs;
nulmv : rm;
other : array ÆtmÅ of tm;
syntx : array Æsyncf..synmlÅ of ry;
(* chess.p01 *)
function max(a,b: ti):ti;
begin if a > b then max:=a else max:=b end;
function min(a,b: ti): ti;
begin if a < b then min:=a else min:=b end;
function sign(a,b: ti): ti;
begin if b <> 0 then sign:=trunc(b/abs(b)) * abs(a) else sign:=a end;
procedure sortit(var a: re; var b: rf; c: tw);
var
intb : tb;
intw : tw;
inti : ti;
intv : tv;
inrm : rm;
begin
for intw:=aw+2 to c do
begin
inti:=intw-1;
intv:=aÆintwÅ;
inrm:=bÆintwÅ;
intb:=true;
while (inti > aw) and intb do
if intv < aÆintiÅ then
begin
aÆinti+1Å:=aÆintiÅ;
bÆinti+1Å:=bÆintiÅ;
inti:=inti-1;
end else intb:=false;
aÆinti+1Å:=intv;
bÆinti+1Å:=inrm;
end;
end;
(* machine independent code *)
procedure andrs(var c: rs; a,b: rs);
begin
c.rsss:=a.rsss * b.rsss;
end;
(*
procedure andrs(var c: rs; var a,b: rs);
var inty : ty;
begin
for inty:=ay to zy do c.rstiÆintyÅ:=a.rstiÆintyÅ and b.rstiÆintyÅ;
end;
*)
(* machine independent code *)
procedure clrrs(var c: rs; a: ts);
begin c.rsss:=c.rsss-xssxÆaÅ end;
(*
procedure clrrs(var c: rs; a: ts);
var i : ts;
begin
i:=ord(xtsrÆaÅ);
c.rsbtÆiÅ:=c.rsbtÆiÅ and not(1 shl ord(xtsfÆaÅ));
end;
*)
(* machine independent code *)
procedure setrs(var c: rs; a: ts);
begin c.rsss:=c.rsss+xssxÆaÅ end;
(*
procedure setrs(var c: rs; a: ts);
var i : ts;
begin
i:=ord(xtsrÆaÅ);
c.rsbtÆiÅ:=c.rsbtÆiÅ or (1 shl ord(xtsfÆaÅ));
end;
*)
(* machine independent code *)
procedure iorrs(var c: rs; a,b: rs);
begin
c.rsss:=a.rsss + b.rsss;
end;
(*
procedure iorrs(var c: rs; var a,b: rs);
var inty : ty;
begin
for inty:=ay to zy do c.rstiÆintyÅ:=a.rstiÆintyÅ or b.rstiÆintyÅ;
end;
*)
procedure newrs(var a: rs);
var inty : ty;
begin
for inty:=ay to zy do a.rstiÆintyÅ:=0;
end;
(* machine independent code *)
procedure notrs(var c: rs; a: rs);
begin
c.rsss:=Æax..zxÅ - a.rsss;
end;
(*
procedure notrs(var c: rs; var a: rs);
var inty : ty;
begin
for inty:=ay to zy do c.rstiÆintyÅ:=not a.rstiÆintyÅ;
end;
*)
(* machine independent code
function nxtts(var a: rs; var b: ts): tb;
label 11;
var
intx : tx;
inty : ty;
begin
for inty:=zy downto ay do
if a.rstiÆintyÅ <> 0 then
begin
for intx:=zx downto ax do
if intx in a.rsss then
begin
b:=intx;
a.rsss:=a.rsss-ÆintxÅ;
nxtts:=true;
goto 11;
end;
end;
nxtts:=false;
11:
end;
*)
function nxtts(var a: rs; var b: ts): tb;
label 11;
var
i,j,p : ti;
intx : tx;
inty : ty;
begin
for i:=zyb downto ay do
if a.rsbtÆiÅ <> 0 then
begin
p:=128;
for j:=ay to zyb do
begin
if a.rsbtÆiÅ - p >= 0 then
begin
b:=j+i * 8;
a.rsbtÆiÅ:=a.rsbtÆiÅ-p;
nxtts:=true;
goto 11;
end;
p:=p div 2;
end;
end;
nxtts:=false;
11:
end;
(* machine independent code *)
function cntrs(var a: rs): ts;
var
i : tyb;
sum : ts;
begin
sum:=0;
for i:=ay to zyb do sum:=sum+ctÆa.rsbtÆiÅÅ;
cntrs:=sum;
end;
(* machine independent code
procedure sftrs(var a: rs; b: rs; c: te);
var
inrs : rs;
ints : ts;
inty : ty;
begin
newrs(a);
while nxtts(b,ints) do
if xtlsÆxtslÆintsÅ+xtedÆcÅÅ > 0 then
setrs(a,xtlsÆxtslÆintsÅ+xtedÆcÅÅ);
end;
*)
procedure sftrs(var a: rs; b: rs; c: te);
var i : integer;
begin
case c of
s1: for i:=ay to zyb do
if b.rsbtÆiÅ < 128 then
a.rsbtÆiÅ:=b.rsbtÆiÅ * 2
else
a.rsbtÆiÅ:=(b.rsbtÆiÅ-128) * 2;
s2: begin
for i:=ay to zyb-1 do a.rsbtÆi+1Å:=b.rsbtÆiÅ;
a.rsbtÆayÅ:=0;
end;
s3: for i:=ay to zyb do a.rsbtÆiÅ:=b.rsbtÆiÅ div 2;
s4: begin
for i:=ay to zyb-1 do a.rsbtÆiÅ:=b.rsbtÆi+1Å;
a.rsbtÆzybÅ:=0;
end;
b1: begin sftrs(a,b,s1); sftrs(a,a,s2) end;
b2: begin sftrs(a,b,s2); sftrs(a,a,s3) end;
b3: begin sftrs(a,b,s3); sftrs(a,a,s4) end;
b4: begin sftrs(a,b,s4); sftrs(a,a,s1) end;
n1: begin sftrs(a,b,b1); sftrs(a,a,s2) end;
n2: begin sftrs(a,b,b2); sftrs(a,a,s2) end;
n3: begin sftrs(a,b,b2); sftrs(a,a,s3) end;
n4: begin sftrs(a,b,b3); sftrs(a,a,s3) end;
n5: begin sftrs(a,b,b3); sftrs(a,a,s4) end;
n6: begin sftrs(a,b,b4); sftrs(a,a,s4) end;
n7: begin sftrs(a,b,b4); sftrs(a,a,s1) end;
n8: begin sftrs(a,b,b1); sftrs(a,a,s1) end;
end;
end;
function inrstb(var a: rs; b: ts): tb;
begin inrstb:=not not (ÆbÅ <= a.rsss) end;
function nulrs(var a: rs): tb;
var
inty : ty;
intb : tb;
begin
intb:=true;
for inty:=ay to zy do
intb:=intb and (a.rstiÆintyÅ = 0);
nulrs:=intb;
end;
function nulmvb(a: rm): tb;
begin
nulmvb:=a.rmac and a.rmpr and (not a.rmca);
end;
procedure pauser;
begin
if swpa then
begin
writeln(' PAUSING ');
readln;
end;
end;
(* chess.p03 *)
procedure mbeval; (* evaluate material balance *)
var inti : ti;
begin
if mblte <> 0 then
if mblte > 0 then inti:=mbpwnÆliteÅ else inti:=mbpwnÆdarkÅ
else inti:=0;
mbvalÆjntkÅ:=sign(
min(
trunc(min(fmaxmt,abs(mblte))
+1.0*ftrade*abs(mblte)*(ftrdsl-mbtot)
*(4*inti+ftrpok) / (4*inti+ftrpwn)
/ 2.62144e5)
,16320)
,mblte);
end;
procedure writexy(sq: ts);
begin
write(chr(sq mod 8 + ord('A')),sq div 8 + 1:0);
end;
procedure inital(var a: rb); (* inittialize for a new game *)
var
intf : tf;
intr : tr;
begin
with a do
begin
rbtm:=lite;
rbts:=-1;
rbti:=0;
rbsq:=Æls,ll,ds,dlÅ;
castleÆliteÅ:=false; castleÆdarkÅ:=false;
for intf:=f1 to f8 do
begin
rbirfÆr2,intfÅ:=lp;
for intr:=r3 to r6 do rbirfÆintr,intfÅ:=mt;
rbirfÆr7,intfÅ:=dp;
end;
rbirfÆr1,f1Å:=lr;
rbirfÆr1,f2Å:=ln;
rbirfÆr1,f3Å:=lb;
rbirfÆr1,f4Å:=lq;
rbirfÆr1,f5Å:=lk;
rbirfÆr1,f6Å:=lb;
rbirfÆr1,f7Å:=ln;
rbirfÆr1,f8Å:=lr;
rbirfÆr8,f1Å:=dr;
rbirfÆr8,f2Å:=dn;
rbirfÆr8,f3Å:=db;
rbirfÆr8,f4Å:=dq;
rbirfÆr8,f5Å:=dk;
rbirfÆr8,f6Å:=db;
rbirfÆr8,f7Å:=dn;
rbirfÆr8,f8Å:=dr;
movms:=' ENTER MOVE CR TYPE GO. ';
writeln(movms);
lstmv:=nulmv;
end;
end;
procedure primov(a: rm);
begin
with a do
begin
write(' ',xtpcÆnbordÆrmfrÅÅ:0,'/');
writexy(rmfr);
if rmca then write('*') else write('-');
writexy(rmto);
if nulmvb(a) then write(', NULL MOVE')
else begin
if rmca then write(', CAPTURE ',xtpcÆrmcpÅ,',')
else write(', SIMPLE,');
if not rmac then write(' NO');
write(' ACS');
if rmch then write(', CHECK');
if rmmt then write(', MATE');
if rmil then write(', ILLEGAL');
if rmsu then write(', SEARCHED');
case rmpr of
false:
case rmoo of
false: if rmep then write(', ENPASSANT');
true :
begin
write(', CASTLE ');
if rmqs then write('LONG') else write('SHORT');
end;
end;
true :
begin
write(', PROMOTE TO ');
case rmpp of
pq: write('QUEEN');
pr: write('ROOK');
pb: write('BISHOP');
pn: write('KNIGHT');
end;
end;
end;
end;
end;
writeln('.');
end;
(* machine independed code *)
procedure printb(a: rc);
var
intr : tr;
intf : tf;
intp : tp;
begin
writeln;
for intr:=r8 downto r1 do
begin
write(' ',ord(intr)+1:1,' ');
for intf:=f1 to f8 do
begin
intp:=aÆxtrfsÆintr,intfÅÅ;
if xtpmÆintpÅ = dark then write('-') else write(' ');
write(xtpcÆintpÅ);
end;
writeln;
end;
writeln; writeln(' A B C D E F G H');
end;
(*
procedure printb(a: rc);
const
invers = @144;
normal = @128;
var
intp : tp;
i,j,k : ti;
figure: tb;
attr : tc;
begin
attr:=invers;
for j:=0 to 23 do
begin
if j mod 3 = 0 then if attr = invers then attr:=normal else attr:=invers;
figure:=false;
if j mod 3 = 1 then
begin
k:=8-j div 3;
write(normal,k,' ')
end else write(normal,' ');
for i:=0 to 55 do
begin
case i mod 7 of
0: begin
if j mod 3 = 1 then figure:=true;
if attr = invers then attr:=normal else attr:=invers;
write(attr,' ');
end;
2: if figure then
begin
intp:=aÆ((k-1)*8 + i div 7)Å;
if intp = mt then
begin
figure:=false;
write(' ');
end else if xtpmÆintpÅ = dark then
write(normal,'-') else write(invers,'-');
end else write(' ');
3: if figure then write(xtpcÆintpÅ) else write(' ');
4: if figure then write('-') else write(' ');
1,5,6: write(attr,' ');
end;
end;
writeln;
end;
write(normal);
end;
*)
procedure prinbb(a: rs); (* print a bit board *)
var
intr : tr;
intf : tf;
begin
writeln;
for intr:=r8 downto r1 do
begin
write(' ',ord(intr)+1:1,' ');
for intf:=f1 to f8 do
write(xtbcÆinrstb(a,xtrfsÆintr,intfÅ)Å);
writeln;
end;
writeln(' ABCDEFGH');
end;
procedure prinam(a: rx); (* print attack map *)
var
intr, jntr : tr;
intf, jntf : tf;
begin
writeln;
for intr:=r8 downto r1 do
begin
for jntr:=r8 downto r1 do
begin
for intf:=f1 to f8 do
begin
write(' ');
for jntf:=f1 to f8 do
write(xtbcÆinrstb(aÆxtrfsÆintr,intfÅÅ,xtrfsÆjntr,jntfÅ)Å);
write(' ');
end;
writeln;
end;
writeln;
if intr in Ær1,r3,r5,r7Å then pauser;
end;
end;
procedure priswi(a: ra; b: tb); (* print a switch *)
begin
write(' ',aÆaaÅ,aÆaa+1Å);
if b then writeln(' ON') else writeln(' OFF');
end;
(* chess.p04 *)
procedure mbcapt(a: tp); (* evaluate material after capture *)
begin
mbtot:=mbtot-abs(xtpvÆaÅ);
if xtpuÆaÅ = ep then mbpwnÆxtpmÆaÅÅ:=mbpwnÆxtpmÆaÅÅ-1;
mblte:=mblte-xtpvÆaÅ;
mbeval;
end;
procedure mbprom(a: tp); (* evaluate matr. bal. change due to pawn
promotion *)
begin
mbtot:=mbtot+abs(xtpvÆaÅ-xtpvÆxtumpÆep,xtpmÆaÅÅÅ);
mbpwnÆxtpmÆaÅÅ:=mbpwnÆxtpmÆaÅÅ-1;
mblte:=mblte+xtpvÆaÅ-xtpvÆxtumpÆep,xtpmÆaÅÅÅ;
mbeval;
end;
procedure mbmorp(a: tp); (* remove pawn promotion from matr.bal. *)
begin
mbtot:=mbtot-abs(xtpvÆaÅ-xtpvÆxtumpÆep,xtpmÆaÅÅÅ);
mbpwnÆxtpmÆaÅÅ:=mbpwnÆxtpmÆaÅÅ+1;
mblte:=mblte-(xtpvÆaÅ-xtpvÆxtumpÆep,xtpmÆaÅÅÅ);
mbeval;
end;
procedure mbtpac(a: tp); (* remove capture form matr. bal. data *)
begin
mbtot:=mbtot+abs(xtpvÆaÅ);
if xtpuÆaÅ = ep then mbpwnÆxtpmÆaÅÅ:=mbpwnÆxtpmÆaÅÅ+1;
mblte:=mblte+xtpvÆaÅ;
mbeval;
end;
procedure addatk(a: ts); (* add attacks of piece to data-base *)
var
intb : tb;
intd : td;
inte : te;
intm : tm;
intp : tp;
intt : tt;
begin
intp:=nbordÆaÅ;
intm:=xtpmÆintpÅ;
for inte:=xfpeÆintpÅ to xlpeÆintpÅ do
begin
intt:=a;
intb:=xspbÆintpÅ;
intd:=xtedÆinteÅ;
repeat
intt:=xtlsÆxtslÆinttÅ+intdÅ;
if intt >= 0 then
begin
setrs(atkfrÆaÅ,intt);
setrs(atktoÆinttÅ,a);
setrs(alatkÆintmÅ,intt);
if nbordÆinttÅ <> mt then intb:=false;
end else intb:=false;
until not intb;
end;
end;
procedure addloc(a: ts; b: tp); (* add piece to data-base *)
begin
clrrs(tplocÆmtÅ,a);
setrs(tplocÆbÅ,a);
setrs(tmlocÆxtpmÆbÅÅ,a);
setrs(allocÆjntkÅ,a);
nbordÆaÅ:=b;
end;
procedure clstat; (* clear position status *)
begin
with board do
begin
rbtm:=lite;
rbts:=-1;
rbsq:=ÆÅ;
end;
castleÆliteÅ:=false; castleÆdarkÅ:=false;
end;
procedure cutatk(a: ts); (* cut attacks trough square *)
var
inrs : rs;
ints : ts;
imrs : rs;
intd : td;
intm : tm;
intl : tl;
intt : tt;
begin
inrs:=atktoÆaÅ;
while nxtts(inrs,ints) do
if xspbÆnbordÆintsÅÅ then
begin
intd:=xlldÆxtslÆaÅ-xtslÆintsÅÅ;
intm:=xtpmÆnbordÆintsÅÅ;
intl:=xtslÆaÅ+intd;
intt:=xtlsÆintlÅ;
while intt > att do
begin
clrrs(atkfrÆintsÅ,intt);
clrrs(atktoÆinttÅ,ints);
andrs(imrs,atktoÆinttÅ,tmlocÆintmÅ);
if nulrs(imrs) then clrrs(alatkÆintmÅ,intt);
if nbordÆinttÅ = mt then
begin
intl:=intl+intd;
intt:=xtlsÆintlÅ;
end else intt:=att;
end;
end;
end;
procedure delatk(a: ts); (* delete attacks from square *)
var
inrs : rs;
imrs : rs;
ints : ts;
intm : tm;
begin
inrs:=atkfrÆaÅ;
newrs(atkfrÆaÅ);
intm:=xtpmÆnbordÆaÅÅ;
while nxtts(inrs,ints) do
begin
clrrs(atktoÆintsÅ,a);
andrs(imrs,atktoÆintsÅ,tmlocÆintmÅ);
if nulrs(imrs) then clrrs(alatkÆintmÅ,ints);
clrrs(tplocÆnbordÆaÅÅ,a);
clrrs(tmlocÆintmÅ,a);
clrrs(allocÆjntkÅ,a);
setrs(tplocÆmtÅ,a);
nbordÆaÅ:=mt;
end;
end;
procedure prpatk(a: ts); (*propagate attacks trough square *)
var
inrs : rs;
ints : ts;
intd : td;
intm : tm;
intl : tl;
intt : tt;
begin
inrs:=atktoÆaÅ;
while nxtts(inrs,ints) do
if xspbÆnbordÆintsÅÅ then
begin
intd:=xlldÆxtslÆaÅ-xtslÆintsÅÅ;
intm:=xtpmÆnbordÆintsÅÅ;
intl:=xtslÆaÅ+intd;
intt:=xtlsÆintlÅ;
while intt >=0 do
begin
setrs(atkfrÆintsÅ,intt);
setrs(atktoÆinttÅ,ints);
setrs(alatkÆintmÅ,intt);
if nbordÆinttÅ = mt then
begin
intl:=intl+intd;
intt:=xtlsÆintlÅ;
end else intt:=-1;
end;
end;
end;
procedure gainit(a: rm); (* unprocess capture move *)
begin
with a do
begin
addloc(rmfr,nbordÆrmtoÅ);
addatk(rmfr);
cutatk(rmfr);
delatk(rmto);
addloc(rmto,rmcp);
addatk(rmto);
mbtpac(nbordÆrmtoÅ);
end;
end;
procedure loseit(a: rm); (* process capture move *)
begin
with a do
begin
mbcapt(nbordÆrmtoÅ);
delatk(rmto);
addloc(rmto,nbordÆrmfrÅ);
delatk(rmfr);
prpatk(rmfr);
addatk(rmto);
end;
end;
procedure moveit(a: rm); (* process ordinary move *)
begin
with a do
begin
addloc(rmto,nbordÆrmfrÅ);
cutatk(rmto);
delatk(rmfr);
prpatk(rmfr);
addatk(rmto);
end;
end;
procedure rtrkit(a: rm); (* unprocess ordinary move *)
begin
with a do
begin
addloc(rmfr,nbordÆrmtoÅ);
cutatk(rmfr);
delatk(rmto);
prpatk(rmto);
addatk(rmfr);
end;
end;
procedure pawnit(a: rm); (* unpromote a pawn *)
begin
with a do
begin
mbmorp(nbordÆrmtoÅ);
nbordÆrmtoÅ:=xtumpÆep,xtpmÆnbordÆrmtoÅÅÅ;
end;
end;
procedure proacs(a: rm);(* process mover affecting castle status *)
procedure proaca(a: ts); (* process castle status changes *)
var
inrs : rs;
imrs : rs;
begin
clrrs(cstatÆjntkÅ,a);
andrs(inrs,cstatÆjntkÅ,xrrsÆxtsrÆaÅÅ);
if not inrstb(inrs,xtrfsÆxtsrÆaÅ,f5Å) then
andrs(cstatÆjntkÅ,cstatÆjntkÅ,xnrsÆxtsrÆaÅÅ);
andrs(imrs,inrs,xrfsÆf8Å);
andrs(inrs,inrs,xrfsÆf1Å);
iorrs(inrs,inrs,imrs);
if nulrs(inrs) then andrs(cstatÆjntkÅ,cstatÆjntkÅ,xnrsÆxtsrÆaÅÅ);
end;
begin
with a do
begin
if inrstb(cstatÆjntkÅ,rmfr) then proaca(rmfr);
if inrstb(cstatÆjntkÅ,rmto) then proaca(rmto);
end;
end;
procedure promot(a: rm); (* process promotion *)
begin
with a do
begin
mbprom(xtgmpÆrmpp,jntmÅ);
nbordÆrmfrÅ:=xtgmpÆrmpp,jntmÅ;
end;
end;
(* chess.p05 *)
procedure genone(a: tt; b: ts); (* stack one generated move *)
var
inrs : rs;
begin
with movesÆjntwÅ do
begin
rmfr:=a;
rmto:=b;
rmcp:=nbordÆbÅ;
rmca:=(nbordÆbÅ <> mt);
iorrs(inrs,xrssÆaÅ,xrssÆbÅ);
andrs(inrs,inrs,cstatÆjntkÅ);
rmac:=not nulrs(inrs);
rmch:=false;
rmmt:=false;
rmil:=false;
rmsu:=false;
rmpr:=false;
rmoo:=false;
rmep:=false;
end;
valuuÆjntwÅ:=0;
if jntw < zw then jntw:=jntw+1;
if jntw = zw then writeln('*** MOVE LIMITS ***');
end;
procedure dndate(a: rm); (* downdate data base to back out a move *)
var
ints : ts;
intr : tr;
intf : tf;
rkfr : ts;
rkto : ts;
begin
with a do
begin
case ord(rmca)*4 + ord(rmac)*2 + ord(rmpr) of
0: rtrkit(a); (* ordinary move *)
1: begin (* pawn move and promote *)
pawnit(a);
rtrkit(a);
end;
2: if rmoo then (* miscellaneous acs *)
begin
if rmqs then intf:=f1 else intf:=f8;
intr:=xtsrÆrmfrÅ;
rkfr:=xtrfsÆintr,intfÅ;
rkto:=(rmfr+rmto) div 2;
castleÆjntmÅ:=false;
addloc(rkfr,nbordÆrktoÅ);
delatk(rkto);
prpatk(rkto);
addatk(rkfr);
rtrkit(a);
end else rtrkit(a);
3: ; (* null move *)
4: if rmep then (* capture enpassant *)
begin
ints:=xtrfsÆxtsrÆrmfrÅ,xtsfÆrmtoÅÅ;
addloc(ints,rmcp);
cutatk(ints);
addatk(ints);
rtrkit(a);
mbtpac(nbordÆintsÅ);
end else gainit(a);
5: begin (* capture and promote *)
pawnit(a);
gainit(a);
end;
6: gainit(a); (* capture acs *)
7: begin (* capture rook acs, promote *)
pawnit(a);
gainit(a);
end;
end;
jntw:=lindxÆjntkÅ;
jntk:=jntk-1;
jntm:=otherÆjntmÅ;
end;
end; (* dndate *)
procedure create; (* create global data base *)
var
inrs : rs;
intm : tm;
intp : tp;
intq : tq;
ints : ts;
begin
with board do
begin
jntw:=aw+1;
jntk:=ak;
jntm:=rbtm;
nodes:=0;
lindxÆjntkÅ:=jntw;
srchmÆjntkÅ:=h0;
for ints:= as to zs do
begin
newrs(atkfrÆintsÅ);
newrs(atktoÆintsÅ);
nbordÆintsÅ:=mt;
end;
newrs(allocÆjntkÅ);
for intp:=lp to mt do newrs(tplocÆintpÅ);
for intm:=lite to none do
begin
newrs(tmlocÆintmÅ);
newrs(alatkÆintmÅ);
end;
mbtot:=0;
mbpwnÆliteÅ:=0;
mbpwnÆdarkÅ:=0;
mblte:=0;
maxps:=0;
for ints:=as to zs do
if rbisÆintsÅ <> mt then
begin
addloc(ints,rbisÆintsÅ);
mbtpac(rbisÆintsÅ);
end else setrs(tplocÆmtÅ,ints);
mbeval;
inrs:=allocÆjntkÅ;
while nxtts(inrs,ints) do addatk(ints);
newrs(cstatÆjntkÅ);
for intq:=ls to dl do
if intq in rbsq then iorrs(cstatÆjntkÅ,cstatÆjntkÅ,xsqsÆintqÅ);
newrs(enpasÆjntkÅ);
if rbts >= 0 then setrs(enpasÆjntkÅ,rbts);
genpnÆjntkÅ:=tplocÆxtumpÆep,jntmÅÅ;
notrs(gentoÆjntkÅ,tmlocÆjntmÅ);
notrs(inrs,genpnÆjntkÅ);
andrs(genfrÆjntkÅ,tmlocÆjntmÅ,inrs);
end;
end; (* create *)
function update(var a: rm):tb; (* update data base for a move *)
var
inrs : rs;
imrs : rs;
ints : ts;
intf : tf;
intr : tr;
rkto : ts;
rkfr : ts;
begin
with a do
begin
jntk:=jntk+1;
if jntk = zk then writeln('*** SEARCH LIMIT ***');
newrs(enpasÆjntkÅ);
cstatÆjntkÅ:=cstatÆjntk-1Å;
allocÆjntkÅ:=allocÆjntk-1Å;
mbvalÆjntkÅ:=mbvalÆjntk-1Å;
lindxÆjntkÅ:=jntw;
case ord(rmca)*4 +ord(rmac)*2 + ord(rmpr) of
0: if rmep then (* ordinary move *)
begin (* pawn move 2 spaces *)
sftrs(inrs,xrssÆrmtoÅ,s1);
sftrs(imrs,xrssÆrmtoÅ,s3);
iorrs(inrs,inrs,imrs);
andrs(inrs,inrs,tplocÆxtumpÆep,otherÆjntmÅÅÅ);
if not nulrs(inrs) then setrs(enpasÆjntkÅ,(rmto+rmfr) div 2);
moveit(a);
end else moveit(a);
1: begin (* move and promote *)
promot(a);
moveit(a);
end;
2: begin (* miscellaneous acs *)
if rmoo then
begin (* castle *)
if rmqs then intf:=f1 else intf:=f8;
intr:=xtsrÆrmfrÅ;
rkfr:=xtrfsÆintr,intfÅ;
rkto:=(rmfr+rmto) div 2;
andrs(cstatÆjntkÅ,cstatÆjntkÅ,xnrsÆintrÅ);
castleÆotherÆjntmÅÅ:=true;
addloc(rkto,nbordÆrkfrÅ);
addatk(rkto);
delatk(rkfr);
moveit(a);
end else
begin
proacs(a);
moveit(a);
end;
end;
3: ; (* null move *)
4: if rmep then (* capture *)
begin
ints:=xtrfsÆxtsrÆrmfrÅ,xtsfÆrmtoÅÅ;
mbcapt(nbordÆintsÅ);
delatk(ints);
prpatk(ints);
moveit(a);
end else loseit(a);
5: begin (* capture and promote *)
promot(a);
loseit(a);
end;
6: begin (* capture acs *)
proacs(a);
loseit(a);
end;
7: begin (* capture rook acs, promote *)
promot(a);
proacs(a);
loseit(a);
end;
end;
(* initialize move generation *)
jntm:=otherÆjntmÅ;
genpnÆjntkÅ:=tplocÆxtumpÆep,jntmÅÅ;
notrs(gentoÆjntkÅ,tmlocÆjntmÅ);
notrs(inrs,genpnÆjntkÅ);
andrs(genfrÆjntkÅ,tmlocÆjntmÅ,inrs);
(* determine if move leaves king in check, or moves king into check *)
andrs(inrs,tplocÆxtumpÆek,jntmÅÅ,alatkÆotherÆjntmÅÅ);
rmch:=not nulrs(inrs);
andrs(inrs,tplocÆxtumpÆek,otherÆjntmÅÅÅ,alatkÆjntmÅ);
rmil:=not nulrs(inrs);
update:= not rmil;
if not rmil then mvselÆjntk-1Å:=mvselÆjntk-1Å+1;
(* initialize move searching *)
srchmÆjntkÅ:=h1;
nodes:=nodes+1;
end;
end; (* update *)
procedure pwnpro; (* generate all promotion moves *)
var
intg : tg;
begin
movesÆjntw-1Å.rmpr:=true;
movesÆjntw-1Å.rmpp:=pq;
for intg:=pr to pb do
begin
movesÆjntwÅ:=movesÆjntw-1Å;
movesÆjntwÅ.rmpp:=intg;
jntw:=jntw+1;
end;
end;
procedure genpwn(a: rs;b: rs); (* generate pawn moves *)
var
inrs : rs;
imrs : rs;
ints : ts;
begin
if jntm = lite then
begin (* white pawn *)
sftrs(inrs,a,s2);
andrs(inrs,tplocÆmtÅ,inrs);
imrs:=inrs;
andrs(inrs,b,inrs);
while nxtts(inrs,ints) do
begin
genone(xtlsÆxtslÆintsÅ-xtedÆs2ÅÅ,ints);
if ints >= xtrfsÆr8,f1Å then pwnpro;
end;
andrs(inrs,imrs,xrrsÆr3Å);
sftrs(inrs,inrs,s2);
andrs(inrs,inrs,tplocÆmtÅ);
andrs(inrs,inrs,b);
while nxtts(inrs,ints) do
begin
genone(xtlsÆxtslÆintsÅ-2*xtedÆs2ÅÅ,ints);
movesÆjntw-1Å.rmep:=true;
end;
sftrs(inrs,a,b1);
iorrs(imrs,tmlocÆotherÆjntmÅÅ,enpasÆjntkÅ);
andrs(imrs,imrs,b);
andrs(inrs,inrs,imrs);
while nxtts(inrs,ints) do
begin
genone(xtlsÆxtslÆintsÅ-xtedÆb1ÅÅ,ints);
movesÆjntw-1Å.rmca:=true;
movesÆjntw-1Å.rmep:=inrstb(enpasÆjntkÅ,ints);
if movesÆjntw-1Å.rmep then movesÆjntw-1Å.rmcp:=dp;
if ints >= xtrfsÆr8,f1Å then pwnpro;
end;
sftrs(inrs,a,b2);
iorrs(imrs,tmlocÆotherÆjntmÅÅ,enpasÆjntkÅ);
andrs(imrs,imrs,b);
andrs(inrs,inrs,imrs);
while nxtts(inrs,ints) do
begin
genone(xtlsÆxtslÆintsÅ-xtedÆb2ÅÅ,ints);
movesÆjntw-1Å.rmca:=true;
movesÆjntw-1Å.rmep:=inrstb(enpasÆjntkÅ,ints);
if movesÆjntw-1Å.rmep then movesÆjntw-1Å.rmcp:=dp;
if ints >= xtrfsÆr8,f1Å then pwnpro;
end;
end else
begin (* black pawns *)
sftrs(inrs,a,s4);
andrs(inrs,tplocÆmtÅ,inrs);
imrs:=inrs;
andrs(inrs,b,inrs);
while nxtts(inrs,ints) do
begin
genone(xtlsÆxtslÆintsÅ-xtedÆs4ÅÅ,ints);
if ints <= xtrfsÆr1,f8Å then pwnpro;
end;
andrs(inrs,imrs,xrrsÆr6Å);
sftrs(inrs,inrs,s4);
andrs(inrs,inrs,tplocÆmtÅ);
andrs(inrs,inrs,b);
while nxtts(inrs,ints) do
begin
genone(xtlsÆxtslÆintsÅ-2*xtedÆs4ÅÅ,ints);
movesÆjntw-1Å.rmep:=true;
end;
sftrs(inrs,a,b3);
iorrs(imrs,tmlocÆotherÆjntmÅÅ,enpasÆjntkÅ);
andrs(imrs,imrs,b);
andrs(inrs,inrs,imrs);
while nxtts(inrs,ints) do
begin
genone(xtlsÆxtslÆintsÅ-xtedÆb3ÅÅ,ints);
movesÆjntw-1Å.rmca:=true;
movesÆjntw-1Å.rmep:=inrstb(enpasÆjntkÅ,ints);
if movesÆjntw-1Å.rmep then movesÆjntw-1Å.rmcp:=lp;
if ints <= xtrfsÆr1,f8Å then pwnpro;
end;
sftrs(inrs,a,b4);
iorrs(imrs,tmlocÆotherÆjntmÅÅ,enpasÆjntkÅ);
andrs(imrs,imrs,b);
andrs(inrs,inrs,imrs);
while nxtts(inrs,ints) do
begin
genone(xtlsÆxtslÆintsÅ-xtedÆb4ÅÅ,ints);
movesÆjntw-1Å.rmca:=true;
movesÆjntw-1Å.rmep:=inrstb(enpasÆjntkÅ,ints);
if movesÆjntw-1Å.rmep then movesÆjntw-1Å.rmcp:=lp;
if ints <= xtrfsÆr1,f8Å then pwnpro;
end;
end;
end; (* genpwn *)
(* chess.p06 *)
procedure genfsl(a: rs);(* generate all moves from a set of squares *)
var (* origin set *)
inrs : rs;
imrs : rs;
iprs : rs;
ints : ts;
imts : ts;
begin
andrs(inrs,a,genfrÆjntkÅ);
notrs(imrs,a);
andrs(genfrÆjntkÅ,genfrÆjntkÅ,imrs);
andrs(iprs,a,genpnÆjntkÅ);
andrs(genpnÆjntkÅ,genpnÆjntkÅ,imrs);
while nxtts(inrs,ints) do
begin
andrs(imrs,atkfrÆintsÅ,gentoÆjntkÅ);
while nxtts(imrs,imts) do genone(ints,imts);
end;
if not nulrs(iprs) then genpwn(iprs,gentoÆjntkÅ);
end;
procedure gentsl(a: rs);(* generate all moves to a set of squares *)
var (* target set *)
inrs : rs;
imrs : rs;
iprs : rs;
ints : ts;
imts : ts;
begin
andrs(inrs,a,gentoÆjntkÅ);
notrs(imrs,a);
andrs(gentoÆjntkÅ,gentoÆjntkÅ,imrs);
iprs:=inrs;
while nxtts(inrs,ints) do
begin
andrs(imrs,atktoÆintsÅ,genfrÆjntkÅ);
while nxtts(imrs,imts) do genone(imts,ints);
end;
if not nulrs(iprs) then genpwn(genpnÆjntkÅ,iprs);
end;
procedure genkillr(from, ito : ts); (* generate killer move *)
var frrs, tors, inrs, iprs : rs;
begin
frrs:=xrssÆfromÅ;
tors:=xrssÆitoÅ;
andrs(iprs,frrs,genpnÆjntkÅ); (* valid pawn from square *)
if not nulrs(iprs) then (* pawn move *)
begin
andrs(inrs,tors,gentoÆjntkÅ); (* only vaild dest.square *)
if not nulrs(inrs) then
begin
clrrs(gentoÆjntkÅ,ito); (* remove dest.square *)
genpwn(iprs,tors);
end;
end
else
begin (* normal move *)
andrs(inrs,frrs,genfrÆjntkÅ); (* only valid from square *)
if not nulrs(inrs) then
begin
andrs(inrs,atkfrÆfromÅ,gentoÆjntkÅ);
andrs(inrs,inrs,tors); (* only valid dest.square *)
if not nulrs(inrs) then
begin
clrrs(gentoÆjntkÅ,ito); (* remove dest.square *)
genone(from,ito);
end;
end;
end;
end;
procedure gencap; (* generate capture moves *)
var inrs : rs;
begin
iorrs(inrs,enpasÆjntkÅ,tmlocÆotherÆjntmÅÅ);
gentsl(inrs);
end;
procedure gencas; (* generate castle moves *)
var
intq : tq;
inrs : rs;
imrs : rs;
begin
for intq:=xtmqÆjntmÅ to succ(xtmqÆjntmÅ) do
if inrstb(cstatÆjntkÅ,xtqsÆintqÅ) then
begin
andrs(inrs,xrqsoÆintqÅ,allocÆjntkÅ);
andrs(imrs,xrqsaÆintqÅ,alatkÆotherÆjntmÅÅ);
if nulrs(inrs) and nulrs(imrs) then
begin
movesÆjntwÅ:=xrqmÆintqÅ;
valuuÆjntwÅ:=0;
jntw:=jntw+1;
end;
end;
end;
procedure genall; (* generate all legal moves *)
begin
genfsl(allocÆjntkÅ); (* generate simple moves *)
gencas; (* generate castle moves *)
end;
procedure lstmov; (* lst legal players moves *)
var intw : tw;
begin
create;
genall;
for intw:=aw+1 to jntw-1 do
begin
if update(movesÆintwÅ) then ;
dndate(movesÆintwÅ);
end;
end;
procedure themov(a: rm); (* make the move for real *)
var
intb : tb;
inrs : rs;
intq : tq;
ints : ts;
begin
lstmv:=a;
intb:=update(a);
with board do
begin
rbtm:=jntm;
inrs:=enpasÆjntkÅ;
if nxtts(inrs,ints) then rbts:=ints else rbts:=att;
if jntm = dark then rbti:=rbti+1;
for intq:=ls to dl do
if inrstb(cstatÆjntkÅ,xtqsÆintqÅ) then rbsq:=rbsq+ÆintqÅ
else rbsq:=rbsq-ÆintqÅ;
for ints:=as to zs do rbisÆintsÅ:=nbordÆintsÅ;
end;
end;
function search: tw; (* search look-ahead tree, return the best move *)
label 11,12,13,14,15,16;
procedure evalu8; (* evaluate current position *)
var
intv : tv;
imtv : tv;
intq : tq;
inrs : rs;
function evatk(a: tm): tv;
var
inrs : rs;
ints : ts;
intv : tv;
begin
intv:=0;
inrs:=tplocÆxtumpÆek,otherÆaÅÅÅ;
if nxtts(inrs,ints) then
begin
andrs(inrs,atkfrÆintsÅ,alatkÆaÅ);
intv:=cntrs(inrs)*faking;
end;
andrs(inrs,alatkÆaÅ,tmlocÆaÅ);
notrs(inrs,inrs);
andrs(inrs,inrs,tmlocÆaÅ);
while nxtts(inrs,ints) do (* piece not cover *)
if xtpuÆnbordÆintsÅÅ <> eq then
intv:=intv - abs(xtpvÆnbordÆintsÅÅ) div fwattk;
evatk:=intv;
if swtr then write(' A',intv:0);
end;
function evking(a, b: rs): tv;
var
ints : ts;
inrs : rs;
intv : tv;
begin
intv:=0;
inrs:=a;
if nxtts(inrs,ints) then
begin
andrs(inrs,atkfrÆintsÅ,b);
intv:=intv+cntrs(inrs)*fkpshd;
end;
evking:=intv;
if swtr then write(' K',intv:0);
end;
function evmobl(a, b: tp): tv;
var
inrs : rs;
ints : ts;
intv : tv;
begin
iorrs(inrs,tplocÆaÅ,tplocÆbÅ);
intv:=0;
while nxtts(inrs,ints) do intv:=intv+cntrs(atkfrÆintsÅ);
evmobl:=intv;
if swtr then write(' M',intv:0);
end;
function evpawn(a: rs; b: te; c: tr; d: tm):tv;
var
i : ti;
inrs : rs;
imrs : rs;
ints : ts;
imts : ts;
intf : tf;
infs : arrayÆtfÅ of ts;
intv : tv;
begin
sftrs(inrs,a,s1);
andrs(inrs,inrs,a);
intv:=cntrs(inrs)*fpflnx;
sftrs(inrs,a,b1);
andrs(inrs,inrs,a);
intv:=intv+cntrs(inrs)*fpconn;
sftrs(inrs,a,b2);
andrs(inrs,inrs,a);
intv:=intv+cntrs(inrs)*fpconn;
sftrs(inrs,a,b);
andrs(inrs,inrs,tmlocÆdÅ);
i:=cntrs(inrs);
if i > 0 then (* blocked by own piece *)
begin
intv:=intv-i*fpblok; (* penalize for blocked *)
andrs(imrs,inrs,a);
intv:=intv-cntrs(imrs)*fpblok; (* double if own pawn *)
andrs(imrs,inrs,tplocÆxtumpÆen,dÅÅ);
intv:=intv+cntrs(imrs)*(fpblok-fpblok div 4); (* 1/4 if N *)
andrs(imrs,inrs,tplocÆxtumpÆeq,dÅÅ);
intv:=intv+cntrs(imrs)*(fpblok-fpblok div 2); (* 1/2 if Q *)
end;
inrs:=a;
for intf:=f1 to f8 do infsÆintfÅ:=as;
while nxtts(inrs,ints) do
begin
intf:=xtsfÆintsÅ;
imts:=xtrfsÆc,f1Å;
if infsÆintfÅ > as then
if c = r2 then imts:=max(infsÆintfÅ,ints)
else imts:=min(infsÆintfÅ,ints);
infsÆintfÅ:=ints;
intv:=intv+(abs(ord(c)-ord(xtsrÆintsÅ))-
abs(ord(c)-ord(xtsrÆimtsÅ)))*fpadcrÆintfÅ;
end;
evpawn:=intv;
if swtr then write(' P',intv:0);
end;
function evrook(a, b: rs): tv;
var
intv : tv;
inti : ti;
ints : ts;
inrs : rs;
begin
intv:=0;
inrs:=a;
if nxtts(inrs,ints) then
begin
andrs(inrs,a,atkfrÆintsÅ);
if not nulrs(inrs) then intv:=intv+frdubl;
end;
andrs(inrs,a,b);
inti:=cntrs(inrs);
intv:=intv+inti*inti*frk7th;
evrook:=intv;
if swtr then write(' R',intv:0);
end;
begin
if swtr then write('MB',mbvalÆjntkÅ:0);
if xtmvÆjntmÅ*mbvalÆjntkÅ+maxps <= bstvlÆjntk-2Å then
intv:=xtmvÆjntmÅ*mbvalÆjntkÅ
else
begin
intv:=
(fwpawn*(evpawn(tplocÆlpÅ,s2,r2,lite)-evpawn(tplocÆdpÅ,s4,r7,dark))
+fwminm*(evmobl(lb,ln) -evmobl(db,dn) )
+fwmajm*(evmobl(lr,lq) -evmobl(dr,dq) )
+fwrook*(evrook(tplocÆlrÅ,xrrsÆr7Å)-evrook(tplocÆdrÅ,xrrsÆr2Å))
+fwking*(evking(tplocÆlkÅ,tplocÆlpÅ)-evking(tplocÆdkÅ,tplocÆdpÅ))
) div 64;
if swtr then write(' v=',intv:0);
imtv:=0;
for intq:=ls to dl do
if inrstb(cstatÆjntkÅ,xtqsÆintqÅ) then (* castle legal *)
begin
andrs(inrs,xrqsoÆintqÅ,tplocÆmtÅ);
case intq of
ls : imtv:=imtv+(cntrs(inrs)+1)*2;
ll : imtv:=imtv+(cntrs(inrs)+1);
ds : imtv:=imtv-(cntrs(inrs)+1)*2;
dl : imtv:=imtv-(cntrs(inrs)+1);
end;
end;
intv:=intv+imtv*fcfree;
if castleÆliteÅ then intv:=intv-(fksanq-(board.rbti+jntk));
if castleÆdarkÅ then intv:=intv+(fksanq-(board.rbti+jntk));
if swtr then write(' vc=',intv:0);
intv:=intv + (evatk(lite) - evatk(dark));
if movesÆindexÆjntkÅÅ.rmch then
intv:=intv-xtmvÆjntmÅ*fcheck; (* bonus *)
maxps:=max(maxps,abs(intv));
intv:=xtmvÆjntmÅ*(mbvalÆjntkÅ+intv);
end;
if swtr then
begin
writeln(' MPS',maxps:0,' TM',xtmvÆjntmÅ:0,' V=',intv:0);
write(' ':jntk*2,' EVALU8 ',jntk:0,' ',jntw:0,' ',indexÆjntkÅ:0,' ',intv:0);
primov(movesÆindexÆjntkÅÅ);
end;
valuuÆindexÆjntkÅÅ:=intv;
end;
procedure newbst(a: tk); (* save best move *)
var
intw : tw;
inrm : rm;
begin
bstmvÆaÅ:=indexÆa+1Å;
if a = ak then
begin
inrm:=movesÆbstmvÆaÅÅ;
if swbm then
begin
write('* NEWBEST * ');
primov(inrm);
write(' ',bstvlÆak+1Å:5,' ');
primov(movesÆbstmvÆak+1ÅÅ);
end;
for intw:=bstmvÆaÅ-1 downto aw+1 do
movesÆintw+1Å:=movesÆintwÅ;
movesÆaw+1Å:=inrm;
bstmvÆakÅ:=aw+1;
end else
if not movesÆbstmvÆaÅÅ.rmca then
killrÆjntkÅ:=movesÆbstmvÆaÅÅ;
end;
function minmax(a: tk): tb;
begin
minmax:=false;
if swtr then
write(' ':jntk*2,' MINMAX ',a:0,' ',-bstvlÆa-1Å:0,
' ',bstvlÆaÅ:0,' ',-bstvlÆa+1Å:0);
if -bstvlÆa+1Å > bstvlÆaÅ then
begin
bstvlÆaÅ:=-bstvlÆa+1Å;
newbst(a);
minmax:=bstvlÆa+1Å <= bstvlÆa-1Å;
if swtr then write(' NEW BEST. PRUNE: ',bstvlÆa+1Å <= bstvlÆa-1Å);
end;
if swtr then writeln;
end;
procedure scorem; (* score mate *)
begin
writeln('*** SCOREM *** ',jntk:0);
movesÆindexÆjntkÅÅ.rmmt:=true;
if movesÆindexÆjntkÅÅ.rmch then valuuÆindexÆjntkÅÅ:=64*jntk-zv
else valuuÆindexÆjntkÅÅ:=0;
if swtr then
writeln(' ':jntk*2,' SCOREM ',jntk:0,' ',jntw:0,' ',indexÆjntkÅ:0,
' ',valuuÆindexÆjntkÅÅ:0);
end;
function select: tb; (* select next move to search *)
var
intb : tb;
intk : tk;
intw : tw;
imtw : tw;
kitw : tw;
intv : tv;
exit : tb;
procedure seldon;
begin
intb:=false;
if swtr then writeln(' ':jntk*2,' SELECT ',jntk:0,' END.');
exit:=true;
end;
procedure selmov(a: tw);
begin
intb:=true;
indexÆjntk+1Å:=a;
movesÆaÅ.rmsu:=true;
if swtr then
begin
if jntk = 0 then writeln;
write(' ':jntk*2,' SELECT ',jntk:0,' ',ord(srchmÆjntkÅ):0,' ',a:0);
primov(movesÆaÅ);
end;
exit:=true;
end;
procedure selnxt(a: th);
begin
indexÆjntk+1Å:=lindxÆjntkÅ-1;
srchmÆjntkÅ:=a;
end;
procedure selany;
label 99;
var intw: tw;
begin
for intw:=indexÆjntk+1Å+1 to jntw-1 do
if not movesÆintwÅ.rmsu then
begin
selmov(intw);
if exit then goto 99;
end;
99: (* exit *)
end;
begin
exit:=false;
repeat (* new search node *)
case srchmÆjntkÅ of
h0: begin (* initialize for new move *)
mvselÆjntkÅ:=0;
intv:=bstvlÆjntk-2Å;
bstvlÆjntk-2Å:=-zv;
maxps:=0;
genall;
for intw:=aw+1 to jntw-1 do
begin
if update(movesÆintwÅ) then
begin
indexÆjntkÅ:=intw;
evalu8;
end;
dndate(movesÆintwÅ);
end;
bstvlÆjntk-2Å:=intv;
sortit(valuu,moves,jntw-1);
for intk:=ak to zk do killrÆintkÅ:=nulmv;
if swtr or swps then
for intw:=aw+1 to jntw-1 do
begin
write(' PRELIM ',intw:0,' ',valuuÆintwÅ:0);
primov(movesÆintwÅ);
if intw/lpp = intw div lpp then pauser;
end;
selnxt(h6);
end;
h1: begin (* initialize at new depth *)
mvselÆjntkÅ:=0;
if jntk > jmtk then
begin
evalu8;
indexÆjntk+1Å:=aw;
bstvlÆjntk+1Å:=-valuuÆindexÆjntkÅÅ;
if movesÆindexÆjntkÅÅ.rmch and (jntk < zk) then
srchmÆjntkÅ:=h3
else
begin
if minmax(jntk) or (jntk = zk) then seldon;
if not exit then srchmÆjntkÅ:=h2;
end;
end else srchmÆjntkÅ:=h3;
if not exit then
begin
gencap;
selnxt(srchmÆjntkÅ);
end;
end;
h2: begin (* capture search *)
intw:=aw;
intv:=av;
for imtw:=lindxÆjntkÅ to jntw-1 do
with movesÆimtwÅ do
if not rmsu then
if abs(xtpvÆrmcpÅ) > intv then
begin
intv:=abs(xtpvÆrmcpÅ);
intw:=imtw;
end;
if intw <> aw then selmov(intw) else seldon;
end;
h3: begin (* full width search - capture *)
intw:=aw;
intv:=av;
for imtw:=lindxÆjntkÅ to jntw-1 do
with movesÆimtwÅ do
if not rmsu then
if abs(xtpvÆrmcpÅ) > intv then
begin
intv:=abs(xtpvÆrmcpÅ);
intw:=imtw;
end;
if intw <> aw then
selmov(intw)
else
if not nulmvb(killrÆjntkÅ) then
begin
imtw:=jntw;
genkillr(killrÆjntkÅ.rmfr,killrÆjntkÅ.rmto);
srchmÆjntkÅ:=h4;
if jntw > imtw then selmov(imtw);
end;
if not exit then selnxt(h4);
end;
h4: begin (* initialize scan of castle & other moves by killer piece *)
gencas;
selnxt(h5);
end;
h5: begin (* full width search *)
selany;
if not exit then
begin
genfsl(allocÆjntkÅ);
selnxt(h6);
end;
end;
h6: begin (* full width search - remainding move *)
selany;
if not exit then
begin
if mvselÆjntkÅ = 0 then scorem;
seldon;
end;
end;
h7: begin (* research first ply *)
jntw:=lindxÆak+1Å;
mvselÆakÅ:=0;
for intw:=aw+1 to jntw-1 do movesÆintwÅ.rmsu:=false;
if jmtk = ak+1 then write('** REDO ')
else write(jmtk:0,'. STAGES ');
write(nodes:0,' ');
primov(movesÆbstmvÆakÅÅ);
if swtr then
writeln(' ':jntk*2,' REDO ',jntk:0,' ',bstvlÆak-2Å:0,' ',bstvlÆak-1Å:0);
selnxt(h6);
end;
end;
until exit; (* select exit *)
select:=intb;
end;
begin (* search *)
bstmvÆakÅ:=aw;
indexÆjntkÅ:=aw;
movesÆawÅ:=lstmv;
bstvlÆak-2Å:=av;
evalu8;
if swsu then
begin
if swec then writeln(' ',board.rbti:0,'. ',-valuuÆawÅ:4);
writeln(' ',board.rbti:0,'. ',-valuuÆawÅ:4);
end else begin writeln; if swec then writeln end;
bstvlÆak-2Å:=valuuÆawÅ-window;
bstvlÆak-1Å:=-valuuÆawÅ-window;
jmtk:=ak+1;
while (jmtk < stages) and (jntk < max(zk div 2,zk-8)) do
begin
11: (* start new ply *)
bstvlÆjntkÅ:=bstvlÆjntk-2Å;
12: (* different first move *)
if not select then
begin
bstvlÆjntkÅ:=valuuÆindexÆjntkÅÅ;
newbst(jntk);
end else
begin
if update(movesÆindexÆjntk+1ÅÅ) then goto 11 else
begin
dndate(movesÆindexÆjntkÅÅ);
goto 12;
end;
13: (* float value back *)
if minmax(jntk) then goto 15;
14: (* find another move at this ply *)
if select then
if update(movesÆindexÆjntk+1ÅÅ) then goto 11 else
begin
dndate(movesÆindexÆjntkÅÅ);
goto 14;
end;
end;
15: (* back up a ply *)
if jntk > ak then
begin
dndate(movesÆindexÆjntkÅÅ);
goto 13;
end;
(* done with iteration *)
if (bstvlÆakÅ <= bstvlÆak-2Å) or (bstvlÆakÅ >= -bstvlÆak-1Å) then
begin (* no move found *)
if mvselÆakÅ = 0 then goto 16; (* no legal moves - give up *)
if stages-1 = jmtk then
begin
bstvlÆak-2Å:=-zv;
bstvlÆak-1Å:=-zv;
srchmÆakÅ:=h7;
jntw:=ak+1;
goto 11;
end;
end;
bstvlÆak-2Å:=bstvlÆakÅ-window;
bstvlÆak-1Å:=-bstvlÆakÅ-window;
jmtk:=jmtk+1;
srchmÆakÅ:=h7;
end;
16: (* exit search *)
search:=bstmvÆakÅ;
end; (* search *)
(* chess.p07 *)
procedure reader; (* read input from user *)
var
inra : ra;
intj : tj;
ok : tb;
procedure rdrerr(a: rn); (* print diagnostic and exit *)
var
intj : tj;
intn : tn;
begin
if not swec then
begin
write(' ');
for intj:=aj to zj-1 do write(ilineÆintjÅ);
writeln;
end;
for intj:=aj to jntj-1 do write(' ');
writeln('`'); (* pointer to error *)
for intn:=an to zn do write(aÆintnÅ);
writeln;
ok:=false;
end;
function rdrgnt(var a: ra): tb; (* get next token from command *)
var intj : tj;
begin
while (jntj < zj) and (ilineÆjntjÅ < 'A') do jntj:=jntj+1;
a:=' ';
intj:=aj;
while (jntj < zj) and (intj < za) and (ilineÆjntjÅ in Æ'A'..'Z'Å) do
begin
aÆintjÅ:=ilineÆjntjÅ;
intj:=intj+1;
jntj:=jntj+1;
end;
rdrgnt:=intj <> aj;
while ilineÆjntjÅ in Æ'A'..'Z'Å do jntj:=jntj+1;
end;
procedure rdrsft; (* skip first token in command line *)
var
inra : ra;
intb : tb;
begin
jntj:=aj;
intb:=rdrgnt(inra);
end;
procedure rdline; (* get next input line from user *)
var intj : tj; intc : tc;
begin
intj:=aj;
readln;
while not eoln(input) and (intj < zj) do
begin
read(intc); icardÆintjÅ:=intc;
intj:=intj+1;
end;
while intj < zj do
begin
icardÆintjÅ:=' ';
intj:=intj+1;
end;
for intj :=aj to zj-1 do
if icardÆintjÅ in Æ'a'..'z'Å then
icardÆintjÅ:=chr(ord(icardÆintjÅ)-ord(' '));
icardÆzjÅ:=';';
jmtj:=aj;
end;
function rdrmov: tb; (* extract next command from input line *)
var imtj : tj;
begin
while (jmtj < zj) and (icardÆjmtjÅ = ' ') do jmtj:=jmtj+1;
imtj:=aj;
while (jmtj < zj) and (icardÆjmtjÅ <> ';') do
begin
ilineÆimtjÅ:=icardÆjmtjÅ;
imtj:=imtj+1;
jmtj:=jmtj+1;
end;
if (icardÆjmtjÅ = ';') and (jmtj < zj) then jmtj:=jmtj+1;
rdrmov:=imtj <> aj;
while imtj < zj do
begin
ilineÆimtjÅ:=' ';
imtj:=imtj+1;
end;
ilineÆzjÅ:=';';
jntj:=aj;
end;
function rdrnum: ti; (* crack number from command line *)
var
intb : tb;
inti : ti;
begin
while (jntj < zj) and (ilineÆjntjÅ = ' ') do jntj:=jntj+1;
if ilineÆjntjÅ = '-' then
begin
intb:=true;
jntj:=jntj+1;
end else
begin
intb:=false;
if ilineÆjntjÅ = '+' then jntj:=jntj+1;
end;
inti:=0;
while ilineÆjntjÅ in Æ'0'..'9'Å do
begin
if inti < maxint div 10 then inti:=10*inti+ord(ilineÆjntjÅ)-ord('0')
else rdrerr(' NUMBER TOO LARGE ');
jntj:=jntj+1;
end;
if ok and (ilineÆjntjÅ in Æ'A'..'Z'Å) then
rdrerr(' DIGIT EXPECTED ');
if intb then inti:=-inti;
rdrnum:=inti;
end;
procedure boacmd; (* command - set up position *)
var
intm : tm;
ints : ts;
procedure boaadv(a: ti);
begin
if ints+a < zs then ints:=ints+a else ints:=zs;
end;
procedure boasto(a: tp);
begin
board.rbisÆintsÅ:=a;
if ints < zs then ints:=ints+1;
end;
begin
clstat;
lstmv:=nulmv;
for ints:=as to zs do board.rbisÆintsÅ:=mt;
intm:=lite;
ints:=0;
repeat
if ilineÆjntjÅ in Æ'P','R','N','B','Q','K','L','D','1'..'8'Å then
case ilineÆjntjÅ of
'P': boasto(xtumpÆep,intmÅ);
'R': boasto(xtumpÆer,intmÅ);
'N': boasto(xtumpÆen,intmÅ);
'B': boasto(xtumpÆeb,intmÅ);
'Q': boasto(xtumpÆeq,intmÅ);
'K': boasto(xtumpÆek,intmÅ);
'L': intm:=lite;
'D': intm:=dark;
'1','2','3','4','5','6','7','8': boaadv(ord(ilineÆjntjÅ)-ord('0'));
end
else
if ilineÆjntjÅ in Æ'A'..'9'Å then
begin
for ints:=as to zs do board.rbisÆintsÅ:=mt;
clstat;
rdrerr(' ILLEGAL BOARD OPTION ');
jntj:=zj-1;
end;
jntj:=jntj+1;
until jntj = zj;
lstmov;
end;
procedure endcmd; (* command - end program *)
begin com:=9 end;
procedure goncmd; (* command - go n moves *)
begin
going:=rdrnum;
if ok then com:=2;
if going <= 0 then going:=1;
end;
procedure inicmd; (* command - initialize for a new game *)
begin com:=1 end;
procedure letcmd; (* command - change variable *)
var inti : ti;
begin
while rdrgnt(inra) do
begin
inti:=rdrnum;
if ok then
begin
(* if inra = 'FKPSHD ' then fkpshd:=inti else
if inra = 'FKSANQ ' then fksanq:=inti else
if inra = 'FMAXMT ' then fmaxmt:=inti else
*) if inra = 'STAGES ' then stages:=inti else
(* if inra = 'FPADQR ' then fpadcrÆf1Å:=inti else
if inra = 'FPADQN ' then fpadcrÆf2Å:=inti else
if inra = 'FPADQB ' then fpadcrÆf3Å:=inti else
if inra = 'FPADQF ' then fpadcrÆf4Å:=inti else
if inra = 'FPADKF ' then fpadcrÆf5Å:=inti else
if inra = 'FPADKB ' then fpadcrÆf6Å:=inti else
if inra = 'FPADKN ' then fpadcrÆf7Å:=inti else
if inra = 'FPADKR ' then fpadcrÆf8Å:=inti else
if inra = 'FPBLOK ' then fpblok:=inti else
if inra = 'FPCONN ' then fpconn:=inti else
if inra = 'FPFLNX ' then fpflnx:=inti else
if inra = 'FRDUBL ' then frdubl:=inti else
if inra = 'FRK7TH ' then frk7th:=inti else
if inra = 'FTRADE ' then ftrade:=inti else
if inra = 'FTRDSL ' then ftrdsl:=inti else
if inra = 'FTRPOK ' then ftrpok:=inti else
if inra = 'FTRPWN ' then ftrpwn:=inti else
*) if inra = 'FWKING ' then fwking:=inti else
if inra = 'FWMAJM ' then fwmajm:=inti else
if inra = 'FWMINM ' then fwminm:=inti else
if inra = 'FWPAWN ' then fwpawn:=inti else
if inra = 'FWROOK ' then fwrook:=inti else
if inra = 'FCHECK ' then fcheck:=inti else
if inra = 'FWATTK ' then fwattk:=inti else
if inra = 'FAKING ' then faking:=inti else
if inra = 'FCFREE ' then fcfree:=inti else
if inra = 'WINDOW ' then window:=inti else
rdrerr(' ILLEGAL LET VARIABLE NAME ');
end;
end;
if ok then writeln('OK');
end;
procedure plecmd; (* command - print variable *)
begin
while rdrgnt(inra) do
begin
(* if inra = 'FKPSHD ' then writeln(inra,'= ', fkpshd) else
if inra = 'FKSANQ ' then writeln(inra,'= ', fksanq) else
if inra = 'FMAXMT ' then writeln(inra,'= ', fmaxmt) else
*) if inra = 'STAGES ' then writeln(inra,'= ', stages) else
(* if inra = 'FPADQR ' then writeln(inra,'= ', fpadcrÆf1Å) else
if inra = 'FPADQN ' then writeln(inra,'= ', fpadcrÆf2Å) else
if inra = 'FPADQB ' then writeln(inra,'= ', fpadcrÆf3Å) else
if inra = 'FPADQF ' then writeln(inra,'= ', fpadcrÆf4Å) else
if inra = 'FPADKF ' then writeln(inra,'= ', fpadcrÆf5Å) else
if inra = 'FPADKB ' then writeln(inra,'= ', fpadcrÆf6Å) else
if inra = 'FPADKN ' then writeln(inra,'= ', fpadcrÆf7Å) else
if inra = 'FPADKR ' then writeln(inra,'= ', fpadcrÆf8Å) else
if inra = 'FPBLOK ' then writeln(inra,'= ', fpblok) else
if inra = 'FPCONN ' then writeln(inra,'= ', fpconn) else
if inra = 'FPFLNX ' then writeln(inra,'= ', fpflnx) else
if inra = 'FRDUBL ' then writeln(inra,'= ', frdubl) else
if inra = 'FRK7TH ' then writeln(inra,'= ', frk7th) else
if inra = 'FTRADE ' then writeln(inra,'= ', ftrade) else
if inra = 'FTRDSL ' then writeln(inra,'= ', ftrdsl) else
if inra = 'FTRPOK ' then writeln(inra,'= ', ftrpok) else
if inra = 'FTRPWN ' then writeln(inra,'= ', ftrpwn) else
*) if inra = 'FWKING ' then writeln(inra,'= ', fwking) else
if inra = 'FWMAJM ' then writeln(inra,'= ', fwmajm) else
if inra = 'FWMINM ' then writeln(inra,'= ', fwminm) else
if inra = 'FWPAWN ' then writeln(inra,'= ', fwpawn) else
if inra = 'FWROOK ' then writeln(inra,'= ', fwrook) else
if inra = 'FCHECK ' then writeln(inra,'= ', fcheck) else
if inra = 'FWATTK ' then writeln(inra,'= ', fwattk) else
if inra = 'FAKING ' then writeln(inra,'= ', faking) else
if inra = 'FCFREE ' then writeln(inra,'= ', fcfree) else
if inra = 'WINDOW ' then writeln(inra,'= ', window) else
rdrerr(' ILLEGAL VARIABLE NAME ');
end;
end;
procedure pricmd; (* command - print board *)
begin
if rdrgnt(inra) then printb(nbord) else printb(board.rbis);
end;
procedure pamcmd; (* command - print attack map *)
begin
while rdrgnt(inra) do
if inraÆaaÅ = 'T' then prinam(atkto)
else
if inraÆaaÅ = 'F' then prinam(atkfr)
else rdrerr(' ATTACK MAP NOT "TO" OR "FROM"');
writeln(' LITE');
prinbb(alatkÆliteÅ);
writeln(' DARK');
prinbb(alatkÆdarkÅ);
end;
procedure popcmd; (* command - print other stuff *)
var intq : tq;
begin
with board do
begin
writeln(xtmaÆrbtmÅ,' TO MOVE.');
writeln(rbts,' ENPASSANT.');
writeln('MOVE NUMBER ',rbti:0);
for intq:=ls to dl do
if intq in rbsq then writeln(xtqaÆintqÅ,' SIDE CASTLE LEGAL.');
end;
end;
procedure pmvcmd; (* command - print move list *)
var intw : tw;
begin
for intw:=aw+1 to jntw-1 do
begin
write(intw:4,' ');
primov(movesÆintwÅ);
if intw/lpp = intw div lpp then pauser;
end;
end;
procedure swicmd; (* command - flip switch *)
procedure swione(var b: tb);
var
a : ra;
imtj : tj;
begin
imtj:=jntj;
a:=inra;
if rdrgnt(inra) then
begin
if inra = 'ON ' then b:=true
else
if inra = 'OFF ' then b:=false
else jntj:=imtj;
priswi(a,b);
end else priswi(a,b);
end;
begin
while rdrgnt(inra) and ok do
begin
if inra = 'EC ' then swione(swec) else
if inra = 'PA ' then swione(swpa) else
if inra = 'PS ' then swione(swps) else
if inra = 'RE ' then swione(swre) else
if inra = 'SU ' then swione(swsu) else
if inra = 'TR ' then swione(swtr) else
if inra = 'PR ' then swione(swpr) else
if inra = 'BM ' then swione(swbm) else
rdrerr(' INVALID SWITCH OPTION ');
end;
end;
procedure whacmd; (* command - print last message *)
begin writeln(movms) end;
procedure stacmd; (* command - status changes *)
var
inra : ra;
intm : tm;
procedure staepf(b: tf); (* process ep file *)
begin
if intm = lite then
board.rbts:=xtrfsÆr6,bÅ
else
board.rbts:=xtrfsÆr3,bÅ;
end;
procedure stacak; (* allow castle king side *)
begin
if intm = lite then
board.rbsq:=board.rbsq + ÆlsÅ
else
board.rbsq:=board.rbsq + ÆdsÅ;
end;
procedure stacaq; (* allow castle queen side *)
begin
if intm = lite then
board.rbsq:=board.rbsq + ÆllÅ
else
board.rbsq:=board.rbsq + ÆdlÅ;
end;
procedure staenp; (* set enpassant file *)
begin
if not rdrgnt(inra) then
begin
clstat;
rdrerr(' ENPASSANT FILE OMITTED ');
end;
if inra = 'QR ' then staepf(f1) else
if inra = 'QN ' then staepf(f2) else
if inra = 'QB ' then staepf(f3) else
if inra = 'Q ' then staepf(f4) else
if inra = 'K ' then staepf(f5) else
if inra = 'KB ' then staepf(f6) else
if inra = 'KN ' then staepf(f7) else
if inra = 'KR ' then staepf(f8) else
begin
clstat;
rdrerr(' ILLEGAL ENPASSANT FILE ');
end;
end;
procedure stagos; (* set side to move *)
begin
board.rbtm:=intm;
jntm:=intm;
end;
begin (* stacmd *)
clstat;
intm:=lite;
while rdrgnt(inra) and ok do
begin
if inra = 'D ' then intm:=dark else
if inra = 'EP ' then staenp else
if inra = 'G ' then stagos else
if inra = 'L ' then intm:=lite else
if inra = 'N ' then board.rbti:=rdrnum else
if inra = 'OO ' then stacak else
if inra = 'OOO ' then stacaq else
begin
clstat;
rdrerr(' INVALID STATUS OPTION ');
end;
end;
lstmov;
end;
begin
com:=0;
repeat
ok:=true;
while not rdrmov do rdline;
if swec then
begin
write(' ');
for intj:=aj to zj-1 do write(ilineÆintjÅ);
writeln;
end;
if ilineÆaj+1Å in Æ'A'..'W','Y'..'Z'Å then
begin
inra:=' ';
inraÆaaÅ:=ilineÆajÅ;
inraÆaa+1Å:=ilineÆaj+1Å;
rdrsft;
if inra = 'BO ' then boacmd else
if inra = 'EN ' then endcmd else
if inra = 'GO ' then goncmd else
if inra = 'IN ' then inicmd else
if inra = 'LE ' then letcmd else
if inra = 'PL ' then plecmd else
if inra = 'PR ' then pricmd else
if inra = 'PA ' then pamcmd else
if inra = 'PO ' then popcmd else
if inra = 'PM ' then pmvcmd else
if inra = 'SW ' then swicmd else
if inra = 'WH ' then whacmd else
if inra = 'ST ' then stacmd else
rdrerr(' INVALID COMMAND ');
end;
until (com > 0) or not(ilineÆaj+1Å in Æ'A'..'W','Y','Z'Å);
end; (* reader *)
(*chess.p02 *)
procedure inicon;
var
intd : td;
inte : te;
intf : tf;
inti : ti;
intl : tl;
intq : tq;
intr : tr;
intt : tt;
intx : tx;
inty : ty;
imti : ti;
x,sum : ti;
inrs : rs;
procedure inisyn(a: ra);
begin
with syntxÆintiÅ do
begin
with ryls do
begin
rdpc:=true;
rdsl:=aÆaa+0Å <> ' ';
rdkq:=aÆaa+1Å <> ' ';
rdnb:=aÆaa+2Å <> ' ';
rdrk:=aÆaa+3Å <> ' ';
end;
rych:=aÆaa+4Å;
with ryrs do
begin
rdpc:=aÆaa+5Å <> ' ';
rdsl:=aÆaa+6Å <> ' ';
rdkq:=aÆaa+7Å <> ' ';
rdnb:=aÆaa+8Å <> ' ';
rdrk:=aÆaa+9Å <> ' ';
end;
end;
inti:=inti+1;
end;
procedure inixtp(a:tp; b:tc; c:tm; d:tu; e:tb; f:te; g:te; h:tv);
begin
xtpcÆaÅ:=b;
xtpmÆaÅ:=c;
xspbÆaÅ:=e;
xfpeÆaÅ:=f;
xlpeÆaÅ:=g;
xtpuÆaÅ:=d;
xtpvÆaÅ:=h;
if a <> mt then xtumpÆd,cÅ:=a;
end;
begin
inixtp(lp,'P',lite,ep,false,b1,b2,1*64);
inixtp(lr,'R',lite,er,true ,s1,s4,5*64);
inixtp(ln,'N',lite,en,false,n1,n8,3*64);
inixtp(lb,'B',lite,eb,true ,b1,b4,3*64);
inixtp(lq,'Q',lite,eq,true ,b1,s4,9*64);
inixtp(lk,'K',lite,ek,false,b1,s4,0);
inixtp(dp,'P',dark,ep,false,b3,b4,-1*64);
inixtp(dr,'R',dark,er,true ,s1,s4,-5*64);
inixtp(dn,'N',dark,en,false,n1,n8,-3*64);
inixtp(db,'B',dark,eb,true ,b1,b4,-3*64);
inixtp(dq,'Q',dark,eq,true ,b1,s4,-9*64);
inixtp(dk,'K',dark,ek,false,b1,s4,0);
inixtp(mt,'.',none,ep,false,b2,b1,0);
xtgmpÆpq,liteÅ:=lq; xtgmpÆpq,darkÅ:=dq; xtgcÆpqÅ:='Q';
xtgmpÆpr,liteÅ:=lr; xtgmpÆpr,darkÅ:=dr; xtgcÆprÅ:='R';
xtgmpÆpn,liteÅ:=ln; xtgmpÆpn,darkÅ:=dn; xtgcÆpnÅ:='N';
xtgmpÆpb,liteÅ:=lb; xtgmpÆpb,darkÅ:=db; xtgcÆpbÅ:='B';
xtucÆekÅ:='K';
xtucÆeqÅ:='Q';
xtucÆerÅ:='R';
xtucÆenÅ:='N';
xtucÆebÅ:='B';
xtucÆepÅ:='P';
(* initialize other constants *)
xtbcÆfalseÅ:='-';
xtbcÆtrue Å:='*';
otherÆliteÅ:=dark; xtmvÆliteÅ:= 1;
otherÆdarkÅ:=lite; xtmvÆdarkÅ:=-1;
otherÆnoneÅ:=none;
xtmaÆliteÅ:=' WHITE ';
xtmaÆdarkÅ:=' BLACK ';
xtmaÆnoneÅ:=' NO ONE ';
xtqaÆlsÅ:='WHITE KING';
xtqaÆllÅ:='WHITE LONG';
xtqaÆdsÅ:='BLACK KING';
xtqaÆdlÅ:='BLACK LONG';
(* initialize 10X12 to 8X8 and 8X8 to 10X12 translation tables *)
for intl:=al to zl do xtlsÆintlÅ:=-1;
intl:=21;
intt:=-1;
for intr:=r1 to r8 do
begin
for intf:=f1 to f8 do
begin
intt:=intt+1;
xtrfsÆintr,intfÅ:=intt;
xtlsÆintlÅ:=intt;
xtslÆinttÅ:=intl;
xtsrÆinttÅ:=intr;
xtsfÆinttÅ:=intf;
intl:=intl+1;
end;
intl:=intl+2;
end;
(* initialize 8X8 to bit board tables *)
intt:=-1;
for inty:=ay to ay do
begin
for intx:=ax to zx do
begin
intt:=intt+1;
xtsxÆinttÅ:=intx;
xtsyÆinttÅ:=inty;
xssxÆinttÅ:=ÆintxÅ;
newrs(xrssÆinttÅ);
xrssÆinttÅ.rsss:=ÆintxÅ;
end;
end;
(* initialize constant bit boards *)
for intr:=r1 to r8 do newrs(xrrsÆintrÅ);
for intf:=f1 to f8 do newrs(xrfsÆintfÅ);
for intr:=r1 to r8 do
for intf:=f1 to f8 do
begin
setrs(xrrsÆintrÅ,xtrfsÆintr,intfÅ);
setrs(xrfsÆintfÅ,xtrfsÆintr,intfÅ);
end;
for intf:=f1 to f8 do notrs(xnfsÆintfÅ,xrfsÆintfÅ);
for intr:=r1 to r8 do notrs(xnrsÆintrÅ,xrrsÆintrÅ);
(* initialize edges *)
edgeÆs1Å:=xrfsÆf1Å;
edgeÆs2Å:=xrrsÆr8Å;
edgeÆs3Å:=xrfsÆf8Å;
edgeÆs4Å:=xrrsÆr1Å;
iorrs(edgeÆb1Å,edgeÆs1Å,edgeÆs2Å);
iorrs(edgeÆb2Å,edgeÆs2Å,edgeÆs3Å);
iorrs(edgeÆb3Å,edgeÆs3Å,edgeÆs4Å);
iorrs(edgeÆb4Å,edgeÆs4Å,edgeÆs1Å);
iorrs(edgeÆn1Å,edgeÆb1Å,xrrsÆr7Å);
iorrs(edgeÆn2Å,edgeÆb2Å,xrrsÆr7Å);
iorrs(edgeÆn3Å,edgeÆb2Å,xrfsÆf7Å);
iorrs(edgeÆn4Å,edgeÆb3Å,xrfsÆf7Å);
iorrs(edgeÆn5Å,edgeÆb3Å,xrrsÆr2Å);
iorrs(edgeÆn6Å,edgeÆb4Å,xrrsÆr2Å);
iorrs(edgeÆn7Å,edgeÆb4Å,xrfsÆf2Å);
iorrs(edgeÆn8Å,edgeÆb1Å,xrfsÆf2Å);
(* initialize corner mask *)
iorrs(inrs,xrrsÆr1Å,xrrsÆr2Å);
iorrs(inrs,inrs,xrrsÆr7Å);
iorrs(inrs,inrs,xrrsÆr8Å);
iorrs(cornr,xrfsÆf1Å,xrfsÆf2Å);
iorrs(cornr,cornr,xrfsÆf7Å);
iorrs(cornr,cornr,xrfsÆf8Å);
andrs(cornr,cornr,inrs);
(* initialize direction table *)
xtedÆn1Å:= 19; xtedÆn2Å:= 21;
xtedÆn8Å:= 8; xtedÆb1Å:= 9;
xtedÆs2Å:= 10; xtedÆb2Å:= 11;
xtedÆn3Å:= 12; xtedÆs1Å:= -1;
xtedÆs3Å:= 1; xtedÆn7Å:=-12;
xtedÆb4Å:=-11; xtedÆs4Å:=-10;
xtedÆb3Å:= -9; xtedÆn4Å:= -8;
xtedÆn6Å:=-21; xtedÆn5Å:=-19;
(* initialize square difference to direction table *)
for inti:=azl to zal do xlldÆintiÅ:=0;
for inte:=b1 to s4 do
begin
intd:=xtedÆinteÅ;
for imti:=1 to 7 do xlldÆimti*intdÅ:=intd;
end;
for inte:=n1 to n8 do xlldÆxtedÆinteÅÅ:=xtedÆinteÅ;
(* initialize castling translation tables *)
iorrs(xsqsÆlsÅ,xrssÆxtrfsÆr1,f8ÅÅ,xrssÆxtrfsÆr1,f5ÅÅ);
iorrs(xsqsÆllÅ,xrssÆxtrfsÆr1,f1ÅÅ,xrssÆxtrfsÆr1,f5ÅÅ);
iorrs(xsqsÆdsÅ,xrssÆxtrfsÆr8,f8ÅÅ,xrssÆxtrfsÆr8,f5ÅÅ);
iorrs(xsqsÆdlÅ,xrssÆxtrfsÆr8,f1ÅÅ,xrssÆxtrfsÆr8,f5ÅÅ);
iorrs(xrqsoÆlsÅ,xrssÆxtrfsÆr1,f6ÅÅ,xrssÆxtrfsÆr1,f7ÅÅ);
iorrs(xrqsoÆllÅ,xrssÆxtrfsÆr1,f4ÅÅ,xrssÆxtrfsÆr1,f3ÅÅ);
iorrs(xrqsaÆlsÅ,xrssÆxtrfsÆr1,f5ÅÅ,xrqsoÆlsÅ);
iorrs(xrqsaÆllÅ,xrssÆxtrfsÆr1,f5ÅÅ,xrqsoÆllÅ);
iorrs(xrqsoÆllÅ,xrssÆxtrfsÆr1,f2ÅÅ,xrqsoÆllÅ);
iorrs(xrqsoÆdsÅ,xrssÆxtrfsÆr8,f6ÅÅ,xrssÆxtrfsÆr8,f7ÅÅ);
iorrs(xrqsoÆdlÅ,xrssÆxtrfsÆr8,f4ÅÅ,xrssÆxtrfsÆr8,f3ÅÅ);
iorrs(xrqsaÆdsÅ,xrssÆxtrfsÆr8,f5ÅÅ,xrqsoÆdsÅ);
iorrs(xrqsaÆdlÅ,xrssÆxtrfsÆr8,f5ÅÅ,xrqsoÆdlÅ);
iorrs(xrqsoÆdlÅ,xrssÆxtrfsÆr8,f2ÅÅ,xrqsoÆdlÅ);
for intq:=ls to dl do
with xrqmÆintqÅ do
begin
rmcp:=mt;
rmca:=false;
rmac:=true;
rmch:=false;
rmmt:=false;
rmil:=false;
rmsu:=false;
rmpr:=false;
rmoo:=true;
end;
xrqmÆlsÅ.rmfr:=xtrfsÆr1,f5Å; xrqmÆlsÅ.rmto:=xtrfsÆr1,f7Å;
xrqmÆllÅ.rmfr:=xtrfsÆr1,f5Å; xrqmÆllÅ.rmto:=xtrfsÆr1,f3Å;
xrqmÆdsÅ.rmfr:=xtrfsÆr8,f5Å; xrqmÆdsÅ.rmto:=xtrfsÆr8,f7Å;
xrqmÆdlÅ.rmfr:=xtrfsÆr8,f5Å; xrqmÆdlÅ.rmto:=xtrfsÆr8,f3Å;
xrqmÆlsÅ.rmqs:=false;
xrqmÆllÅ.rmqs:=true;
xrqmÆdsÅ.rmqs:=false;
xrqmÆdlÅ.rmqs:=true;
xtmqÆliteÅ:=ls;
xtmqÆdarkÅ:=ds;
xtqsÆlsÅ:=xtrfsÆr1,f8Å;
xtqsÆllÅ:=xtrfsÆr1,f1Å;
xtqsÆdsÅ:=xtrfsÆr8,f8Å;
xtqsÆdlÅ:=xtrfsÆr8,f1Å;
(* initialize null move *)
with nulmv do
begin
rmfr:=as;
rmto:=as;
rmcp:=mt;
rmca:=false;
rmac:=true;
rmch:=false;
rmmt:=false;
rmil:=false;
rmsu:=false;
rmpr:=true;
rmpp:=pb;
end;
(* initialize countbit table *)
for inti:=0 to 255 do
begin
sum:=0;
x:=128;
imti:=inti;
while imti > 0 do
begin
if imti-x >= 0 then
begin
sum:=sum+1;
imti:=imti-x;
end;
x:=x div 2;
end;
ctÆintiÅ:=sum;
end;
(* initialize command processing variable *)
jmtj:=zj;
icardÆzjÅ:=';';
ilineÆzjÅ:=';';
(* initialize moves syntax table *)
inti:=syncf;
inisyn(' *P ');
inisyn(' *P/ 1');
inisyn('/ 1*P ');
inisyn(' *P/ R ');
inisyn('/ R *P ');
inisyn(' *P/ R1');
inisyn('/ R1*P ');
inisyn(' *P/ KR');
inisyn('/ KR*P ');
inisyn(' *P/KR1');
inisyn('/KR1*P/ ');
inisyn('/ 1*P/ 1');
inisyn('/ R *P/ R ');
inisyn('/ 1*P/ R ');
inisyn('/ R *P/ 1');
inisyn('/ R1*P/ 1');
inisyn('/ 1*P/ R1');
inisyn('/ R1*P/ R ');
inisyn('/ R *P/ R1');
inisyn('/KR *P/ 1');
inisyn('/ 1*P/KR ');
inisyn('/KR *P/ R ');
inisyn('/ R *P/KR ');
inisyn('/ 1*P/KR1');
inisyn('/KR1*P/ 1');
inisyn('/ R *P/KR1');
inisyn('/KR1*P/ R ');
inisyn('/ R1*P/ R1');
inisyn('/KR *P/ R1');
inisyn('/ R1*P/KR ');
inisyn('/KR *P/KR ');
inisyn('/KR1*P/ R1');
inisyn('/ R1*P/KR1');
inisyn('/KR1*P/KR ');
inisyn('/KR *P/KR1');
inisyn('/KR1*P/KR1');
inisyn(' - R1');
inisyn(' - KR1');
inisyn('/ 1- R1');
inisyn('/ R - R1');
inisyn('/ 1- KR1');
inisyn('/ R - KR1');
inisyn('/ R1- R1');
inisyn('/KR - R1');
inisyn('/ R1- KR1');
inisyn('/KR - KR1');
inisyn('/KR1- KR1');
(* initialize lets *)
fkpshd:=10;
fmaxmt:=2048;
stages:=2;
fpadcrÆf1Å:=1;
fpadcrÆf2Å:=2;
fpadcrÆf3Å:=4;
fpadcrÆf4Å:=6;
fpadcrÆf5Å:=7;
fpadcrÆf6Å:=4;
fpadcrÆf7Å:=2;
fpadcrÆf8Å:=1;
fpblok:=10;
fpconn:=5;
fpflnx:=3;
frdubl:=60;
frk7th:=120;
ftrade:=36;
ftrdsl:=5156;
ftrpok:=2;
ftrpwn:=8;
fwking:=20;
fwmajm:=64;
fwminm:=128;
fwpawn:=64;
fwrook:=2;
fcheck:=32;
fwattk:=16;
fksanq:=64;
fcfree:=4;
faking:=25;
window:=100;
(* initialize switches *)
swec:=false;
swpa:=true;
swps:=false;
swre:=true;
swsu:=true;
swtr:=false;
swpr:=false;
swbm:=false;
going:=0;
end; (* inicon *)
(* chess.p08 *)
procedure mineng(a: rm; b: ra); (* generate minimum english notation *)
var intn : tnn;
procedure addchr(a: tc); (* add character to message *)
begin
movmsÆintnÅ:=a;
if intn < znn then intn:=intn+1;
end;
procedure addsqr(a: ts; b: rd); (* add square to message *)
begin
with b do
begin
if rdpc then addchr(xtucÆxtpuÆnbordÆaÅÅÅ);
if rdsl then addchr('/');
if rdkq then
if xtsfÆaÅ in Æf1..f4Å then addchr('Q') else addchr('K');
if rdnb then
case xtsfÆaÅ of
f1,f8: addchr('R');
f2,f7: addchr('N');
f3,f6: addchr('B');
f4 : addchr('Q');
f5 : addchr('K');
end;
if rdrk then
if jntm = lite then
case xtsrÆaÅ of
r1: addchr('1');
r2: addchr('2');
r3: addchr('3');
r4: addchr('4');
r5: addchr('5');
r6: addchr('6');
r7: addchr('7');
r8: addchr('8');
end
else
case xtsrÆaÅ of
r1: addchr('8');
r2: addchr('7');
r3: addchr('6');
r4: addchr('5');
r5: addchr('4');
r6: addchr('3');
r7: addchr('2');
r8: addchr('1');
end;
end;
end;
procedure addwrd(a:ra; b: ta); (* add word to message *)
var inta : ta;
begin
for inta:=aa to b do addchr(aÆintaÅ);
end;
function differ(a,b: rm): tb; (* compare moves, true if different *)
var intb : tb;
begin
intb:=(a.rmfr <> b.rmfr) or (a.rmto <> b.rmto) or (a.rmcp <> b.rmcp);
if a.rmpr = b.rmpr then
if a.rmpr then differ:=intb or (a.rmpp <> b.rmpp)
else
if a.rmoo = b.rmoo then
if a.rmoo then differ:=intb or (a.rmqs <> b.rmqs)
else differ:=intb
else differ:=true
else differ:=true;
end;
procedure setsqd(a:ts; b:rd; var c:sr; var d:sf); (* define specific *)
begin (* square descriptor *)
c:=Ær1..r8Å;
d:=Æf1..f8Å;
with b do
begin
if rdkq and rdnb then d:=ÆxtsfÆaÅÅ;
if (not rdkq) and rdnb then
case xtsfÆaÅ of
f1,f8: d:=Æf1,f8Å;
f2,f7: d:=Æf2,f7Å;
f3,f6: d:=Æf3,f6Å;
f4 : d:=Æf4Å;
f5 : d:=Æf5Å;
end;
if rdrk then c:=ÆxtsrÆaÅÅ;
end;
end;
procedure mingen(a:rm; b,c:ti); (* produce minimum engl. notation *)
var
intg : tg;
inti : ti;
intw : tw;
inlr : sr;
inrr : sr;
inlf : sf;
inrf : sf;
exit : tb;
found: tb;
begin
exit:=false;
inti:=b;
repeat
with syntxÆintiÅ do
begin
if a.rmpr then intg:=a.rmpp else intg:=pb;
setsqd(a.rmfr,ryls,inlr,inlf);
setsqd(a.rmto,ryrs,inrr,inrf);
found:=true;
intw:=aw+1;
repeat
if differ(movesÆintwÅ,a) then
if (nbordÆa.rmfrÅ = nbordÆmovesÆintwÅ.rmfrÅ) and
(a.rmcp = movesÆintwÅ.rmcp) then
with movesÆintwÅ do
if (xtsrÆrmfrÅ in inlr) and (xtsrÆrmtoÅ in inrr) and
(xtsfÆrmfrÅ in inlf) and (xtsfÆrmtoÅ in inrf) and
((rmpr and (intg = rmpp)) or (not rmpr)) then found:=false;
intw:=intw+1;
until (intw = jntw-1) or not found;
if found then
begin (* no other move looks the same *)
addsqr(a.rmfr,ryls);
addchr(rych);
addsqr(a.rmto,ryrs);
exit:=true;
end;
end;
inti:=inti+1;
until (inti = c) or exit;
end;
begin
movms:=' ';
intn:=aw+1;
addwrd(b,za);
addwrd('- ',2);
with a do
begin
addchr(chr(rmfr mod 8 + ord('A')));
addchr(chr(rmfr div 8 + ord('1')));
if rmca then addchr('*') else addchr('-');
addchr(chr(rmto mod 8 + ord('A')));
addchr(chr(rmto div 8 + ord('1')));
addwrd(' = ',3);
if rmoo then
begin
addwrd('0-0 ',3);
if rmqs then addwrd('-0 ',2);
end else
if rmca then mingen(a,syncf,syncl) else mingen(a,synmf,synml);
if rmpr then
begin
addchr('=');
addchr(xtgcÆrmppÅ);
end;
addwrd('. ',3);
if rmch then
begin
addwrd('CHECK ',5);
if rmmt then addwrd('MATE ',4);
addchr('.');
end else
if rmmt then addwrd('STALEMATE.',10);
end;
end; (* mineng *)
function yrm(var inrm: rm):tb;
label 9,10,11,12,13,14,15,16,18;
var
intb : tb;
intc : tc;
intw : tw;
intp : tp;
incp : tp;
ifca : tb;
ifpr : tb;
ifoo : tb;
ifqs : tb;
intg : tg;
ifmv : tb;
ifld : tb;
iflf : tb;
ifrd : tb;
ifrf : tb;
intf : tf;
intr : tr;
inlf : sf;
inlr : sr;
inrf : sf;
inrr : sr;
exit : tb;
error : tb;
function nchin(a: sc; b: ti):tb; (* determine if next input *)
var intb : tb; (* char is not in a given set *)
begin
intb:=not(intc in a);
if not intb then
begin
case b of
1: ifca:=true; (* yrmcap semantics - capture *)
2: ifoo:=true; (* yrmcas semantics - castle *)
3: case intc of (* yrmcpc semantics - captured piece *)
'P': incp:=xtumpÆep,otherÆjntmÅÅ;
'R': incp:=xtumpÆer,otherÆjntmÅÅ;
'N': incp:=xtumpÆen,otherÆjntmÅÅ;
'B': incp:=xtumpÆeb,otherÆjntmÅÅ;
'Q': incp:=xtumpÆeq,otherÆjntmÅÅ;
end;
4: ifqs:=true; (* yrmcqs semantics - castle long *)
5: begin (* yrmlkq semantics - K or Q on left *)
case intc of
'K': inlf:=Æf5..f8Å*inlf;
'Q': inlf:=Æf1..f4Å*inlf;
end;
iflf:=true;
end;
6: begin (* yrmlrb semantics - R, N or B on left *)
case intc of
'R': inlf:=Æf1,f8Å*inlf;
'N': inlf:=Æf2,f7Å*inlf;
'B': inlf:=Æf3,f6Å*inlf;
end;
ifld:=true;
end;
7: if jntm = lite then (* yrmlrk semantics rank on left *)
case intc of
'1': inlr:=Ær1Å;
'2': inlr:=Ær2Å;
'3': inlr:=Ær3Å;
'4': inlr:=Ær4Å;
'5': inlr:=Ær5Å;
'6': inlr:=Ær6Å;
'7': inlr:=Ær7Å;
'8': inlr:=Ær8Å;
end
else
case intc of
'1': inlr:=Ær8Å;
'2': inlr:=Ær7Å;
'3': inlr:=Ær6Å;
'4': inlr:=Ær5Å;
'5': inlr:=Ær4Å;
'6': inlr:=Ær3Å;
'7': inlr:=Ær2Å;
'8': inlr:=Ær1Å;
end;
8: ; (* yrmnul semantics - null *)
9: case intc of (* yrmpcm semantics - piece moved *)
'P': intp:=xtumpÆep,jntmÅ;
'R': intp:=xtumpÆer,jntmÅ;
'N': intp:=xtumpÆen,jntmÅ;
'B': intp:=xtumpÆeb,jntmÅ;
'Q': intp:=xtumpÆeq,jntmÅ;
'K': intp:=xtumpÆek,jntmÅ;
end;
10: begin (* yrmpro semantics - promotion *)
case intc of
'R': intg:=pr;
'N': intg:=pn;
'B': intg:=pb;
'Q': intg:=pq;
end;
ifpr:=true;
end;
11: begin (* yrmrkq semantics - K or Q on rigth *)
case intc of
'K': inrf:=Æf5..f8Å*inrf;
'Q': inrf:=Æf1..f4Å*inrf;
end;
ifrf:=true;
end;
12: begin (* yrmrrb semantics - R, N or B on rigth *)
case intc of
'R': inrf:=Æf1,f8Å*inrf;
'N': inrf:=Æf2,f7Å*inrf;
'B': inrf:=Æf3,f6Å*inrf;
end;
ifrd:=true;
end;
13: if jntm = lite then (* yrmrrk semantics rank on rigth *)
case intc of
'1': inrr:=Ær1Å;
'2': inrr:=Ær2Å;
'3': inrr:=Ær3Å;
'4': inrr:=Ær4Å;
'5': inrr:=Ær5Å;
'6': inrr:=Ær6Å;
'7': inrr:=Ær7Å;
'8': inrr:=Ær8Å;
end
else
case intc of
'1': inrr:=Ær8Å;
'2': inrr:=Ær7Å;
'3': inrr:=Ær6Å;
'4': inrr:=Ær5Å;
'5': inrr:=Ær4Å;
'6': inrr:=Ær3Å;
'7': inrr:=Ær2Å;
'8': inrr:=Ær1Å;
end;
14: case intc of
'A': intf:=f1;
'B': intf:=f2;
'C': intf:=f3;
'D': intf:=f4;
'E': intf:=f5;
'F': intf:=f6;
'G': intf:=f7;
'H': intf:=f8;
end;
15: begin
case intc of
'1': intr:=r1;
'2': intr:=r2;
'3': intr:=r3;
'4': intr:=r4;
'5': intr:=r5;
'6': intr:=r6;
'7': intr:=r7;
'8': intr:=r8;
end;
intp:=board.rbisÆxtrfsÆintr,intfÅÅ;
inlf:=ÆintfÅ; inlr:=ÆintrÅ;
end;
16: case intc of
'A': intf:=f1;
'B': intf:=f2;
'C': intf:=f3;
'D': intf:=f4;
'E': intf:=f5;
'F': intf:=f6;
'G': intf:=f7;
'H': intf:=f8;
end;
17: begin
case intc of
'1': intr:=r1;
'2': intr:=r2;
'3': intr:=r3;
'4': intr:=r4;
'5': intr:=r5;
'6': intr:=r6;
'7': intr:=r7;
'8': intr:=r8;
end;
incp:=board.rbisÆxtrfsÆintr,intfÅÅ;
inrf:=ÆintfÅ; inrr:=ÆintrÅ;
end;
18: ifca:=true;
end;
jntj:=jntj+1;
while (jntj < zj) and (ilineÆjntjÅ = ' ') do jntj:=jntj+1;
intc:=ilineÆjntjÅ;
if (intc = '.') or (intc = ';') then exit:=true;
end;
nchin:=intb;
end;
procedure yrmhit; (* found a move *)
begin
if ifmv then (* second possible move found *)
begin
error:=true;
writeln(' AMBIGUOUS MOVE.');
end else
begin
ifmv:=true;
inrm:=movesÆintwÅ;
end;
end;
procedure yrmcom; (* compare squares *)
begin
with movesÆintwÅ do
if (xtsrÆrmfrÅ in inlr) and
(xtsfÆrmfrÅ in inlf) and
(xtsrÆrmtoÅ in inrr) and
(xtsfÆrmtoÅ in inrf) and
(not rmil) and (board.rbisÆrmfrÅ = intp) then
if rmca = ifca then
if rmca then
if rmcp = incp then
yrmhit
else
else yrmhit;
end;
begin
intb:=false;
ifca:=false;
ifpr:=false;
ifoo:=false;
ifqs:=false;
ifld:=false;
iflf:=false;
ifrd:=false;
ifrf:=false;
intp:=mt;
incp:=mt;
inlf:=Æf1..f8Å;
inrf:=Æf1..f8Å;
inlr:=Ær1..r8Å;
inrr:=Ær1..r8Å;
exit:=false;
error:=false;
intc:=ilineÆjntjÅ;
if ilineÆjntj+1Å in Æ'1'..'8'Å then
begin
if nchin(Æ'A'..'H'Å ,14) then goto 10;
if nchin(Æ'1'..'8'Å ,15) then goto 16;
if not nchin(Æ'-'Å , 8) then goto 9;
if nchin(Æ'*','X'Å ,18) then goto 16;
9: (* standard syntax from ok *)
if nchin(Æ'A'..'H'Å ,16) then goto 16;
if not nchin(Æ'1'..'8'Å ,17) then goto 15;
end;
10: (* not standard *)
if nchin(Æ'P','R','N','B','Q','K'Å, 9) then goto 14;
if nchin(Æ'/'Å , 8) then goto 11;
if nchin(Æ'K','Q'Å , 5) then ;
if nchin(Æ'R','N','B'Å , 6) then ;
if nchin(Æ'1'..'8'Å , 7) then ;
if exit then goto 15;
11: (* left side done *)
if not nchin(Æ'-'Å , 8) then goto 12;
if nchin(Æ'*','X'Å , 1) then goto 16;
if nchin(Æ'P','R','N','B','Q'Å , 3) then goto 16;
if nchin(Æ'/'Å , 8) then goto 13;
12: (* right side square *)
if nchin(Æ'K','Q'Å ,11) then ;
if nchin(Æ'R','N','B'Å ,12) then ;
if nchin(Æ'1'..'8'Å ,13) then ;
if exit then goto 15;
13: (* promotion *)
if nchin(Æ'='Å , 8) then goto 15;
if nchin(Æ'R','N','B','Q'Å ,10) then goto 16;
if exit then goto 15;
14: (* castling *)
if nchin(Æ'0','O'Å , 8) then goto 16;
if nchin(Æ'-'Å , 8) then goto 16;
if nchin(Æ'0','O'Å , 2) then goto 16;
if nchin(Æ'-'Å , 4) then goto 15;
if nchin(Æ'0','O'Å , 8) then goto 16;
15: (* syntax correct *)
exit:=false;
if ifrf and not ifrd then inrf:=inrf * Æf4,f5Å;
if iflf and not ifld then inlf:=inlf * Æf4,f5Å;
ifmv:=false;
intw:=aw;
while (intw < jntw) and not error do
with movesÆintwÅ do
begin
if rmpr = ifpr then
if rmpr then
if rmpp = intg then
yrmcom
else
else
if rmoo = ifoo then
if rmoo then
if rmqs = ifqs then
yrmhit
else
else
yrmcom;
intw:=intw+1;
end;
if not error then
if ifmv then
begin
intb:=true;
jfmv:=true
end else writeln(' ILLEGAL MOVE.');
goto 18;
16: (* syntax error *)
writeln(' SYNTAX ERROR.');
18: (* exit *)
yrm:=intb;
end;
procedure yrmove;
label 99;
var inrm : rm;
begin
jfmv:=false;
lstmov;
repeat
reader;
if com > 0 then goto 99;
until yrm(inrm);
if jfmv then
begin
mineng(inrm,'YOUR MOVE ');
write(movms);
if swec then write(movms);
themov(inrm);
end;
99:
end;
procedure mymove; (* make machines move *)
var
inti : ti;
inrm : rm;
begin
create; (* initalize data base *)
inrm:=movesÆsearchÅ; (* find the best move *)
if inrm.rmil then
begin (* no move found *)
going:=0;
if lstmv.rmch then writeln(' CONGRATULATIONS.') (* checkmate *)
else writeln(' DRAWN.'); (* stalemate *)
end else
begin
mineng(inrm,' MY MOVE '); (* translate move to english *)
write(movms); (* tell the player *)
for inti:=1 to 7 do write(chr(7));
if swec then write(movms);
themov(inrm); (* make the move *)
if swsu then
begin
if swec then
write(' ',board.rbti:0,'. ',bstvlÆakÅ:4,' ',nodes:0,' nodes. ');
write(' ',board.rbti:0,'. ',bstvlÆakÅ:4,' ',nodes:0,' nodes. ');
end;
writeln;
if swec then writeln;
end;
if swpr then printb(board.rbis);
end;
begin
writeln(' HI. THIS IS CHESS 0.5');
inicon;
1:
inital(board); (* initialize for a new game *)
repeat
repeat
yrmove;
case com of
1: goto 1;
2: goto 2;
9: goto 9;
0: ;
end;
until swre;
2:
repeat (* execute machines move *)
mymove;
if going > 0 then going:=going-1;
until going = 0;
until false;
9:
end.
«eof»