|
DataMuseum.dkPresents historical artifacts from the history of: RC4000/8000/9000 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC4000/8000/9000 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 35328 (0x8a00)
Types: TextFile
Names: »s5«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦this⟧ »s5«
begin
integer procedure alphabeta(depth,alpha,beta);
value depth,alpha,beta;
integer depth,alpha,beta;
begin
integer actmover,widthlimit,newalpha,totval1,cr3,cr4,prm,prnx;
boolean array try(1:trywidth);
boolean field ij,mn,next,w;
procedure selecttry(entry,maxtries,crlimit);
value entry,maxtries,crlimit;
integer entry,maxtries,crlimit;
begin
integer r,c,m,prnx;
boolean field next,u,v;
boolean force;
force:= (force1 and depth=3) or (force2 and depth=4);
if selecttest then write(testlog,<:<10>:>,
case actmover of (<:X:>,<:O:>),<: SEL:>,false add 32,
depth+1,<<ddd>,crlimit,<<ddddd>,entry);
if maxtries<100 and depth=threatdepth(mover) then maxtries:= 0;
prnx:= entry;
for prnx:= propose(prnx+1)
while prnx<1676 and w<maxtries and w<trywidth do
begin
next:= prnx shift (-1);
if selecttest then
begin
write(testlog,<: :>);
writefield(testlog,next);
end;
if totval(next) extract 7 >= crlimit then
begin
v:= 0;
u:= (next shift (-1) shift 1) +actmover-1;
for v:= v+1 while v<=w
and try.v extract 10 <> u do ;
if v>w then
begin
if depth>2 and crlimit>0 and -,force then
begin
v:= moveno+depth-1;
for v:= v-2 while v>=moveno and v<1000 do
begin
m:= moves.v extract 10;
r:= abs(u mod 42 - m mod 42)//2;
c:= abs(u//42 - m//42);
if (r=c or r=0 or c=0) and r<5 and c<5 then v:= 1002;
end
end;
if depth<=2 or v=1000 or crlimit=0 or force then
begin
if selecttest then write(testlog,<:+:>);
w:= w+1;
try.w:= false add (u+(if maxtries=100 then 2048 else 0)
+(if crlimit=0 then 1024 else 0));
if maxtries=100 then maxtries:= 1
end
end
end
end;
end selecttry;
actmover:= mover+(-mover+(3-mover))*(1-(depth extract 1));
prm:= 2*actmover;
cr3:= creative(mover,3)+creative(mover,2)*(depth-1);
cr4:= creative(mover,4)+creative(mover,5)*(depth-1);
w:= 0;
i:= 1;
for ij:= 166+prm, 172-prm,
250+prm,256-prm,
418+prm,424-prm do
if propose(ij+1) = 1676 then i:= i+1
else goto casei;
casei:
case i of
begin
begin
comment own5,win;
selecttry(166+prm,100,0)
end;
begin
comment opp5;
selecttry(172-prm,1,0)
end;
begin
comment own-open4.
closed4+open3 => own-open4+own-closed4+opp-open4+opp-closed4,
2*closed4 or open4 => ownopen4,win;
ij:= 250+prm;
for mn:= propose(ij+1)
while mn<1676 and totval(mn shift (-1)) extract 14 < 5*128 do ij:= mn;
if mn=1676 and depth<6 then
begin
selecttry(250+prm,trywidth,0);
selecttry(334+prm,trywidth,cr4);
selecttry(256-prm,trywidth,0);
selecttry(340-prm,trywidth,cr4)
end
else
if mn<1676 then selecttry(ij,100,0)
else
selecttry(250+prm,100,0)
end;
begin
comment opp-open4 => ownclosed4+oppopen4+oppclosed4;
selecttry(256-prm,trywidth,0);
if w<2 then
begin
if depth>5 then
selecttry(334+prm,trywidth,cr4);
selecttry(340-prm,trywidth,cr4);
selecttry(508-prm,trywidth,cr3)
end;
if depth<6 then
selecttry(334+prm,trywidth,1);
end;
begin
comment own-double3.
not opp-closed4 => own-double3,win
else owndouble3+ownclosed4+oppclosed4;
selecttry(340-prm,trywidth,cr4);
if w=0 then selecttry(418+prm,100,0)
else
begin
selecttry(418+prm,trywidth,0);
b:= try(w);
try(w):= try(1);
try(1):= b;
end
end;
begin
comment opp-double3 => ownclosed4+ownsingle3+oppdouble3;
selecttry(334+prm,trywidth,cr4);
selecttry(502+prm,trywidth,cr3);
selecttry(424-prm,trywidth,0);
selecttry(508-prm,trywidth,cr3);
selecttry(340-prm,trywidth,cr4)
end;
begin
comment ingen dobbelttrusler;
comment ownclosed4+ownsingle3+oppclosed4+strategiske træk;
selecttry(334+prm,trywidth,cr4+od(actmover));
selecttry(502+prm,trywidth,cr3+od(actmover));
ij:= 2034+prm;
mn:= 2040-prm;
j:= w;
for prnx:= (if ij >= mn -mnsub(actmover) then ij else mn)
while w<j+width(mover,depth) and (ij>0 or mn>0) do
begin
if propose(prnx+1) < 1676 then
selecttry(prnx,j+width(mover,depth),1);
if ij >= mn -mnsub(actmover) then
begin
for ij:= ij-4 while propose(ij+1) > 1675 do
end
else
for mn:= mn-4 while propose(mn+1) > 1675 do ;
if ij>0 then
begin
if propose(ij+1) = 0 then ij:= 0;
end;
if mn>0 then
begin
if propose(mn+1) = 0 then mn:= 0
end
end next;
selecttry(340-prm,trywidth,cr4+od(3-actmover));
selecttry(508-prm,trywidth,cr3+od(3-actmover));
end;
end case i;
widthlimit:= w;
if depth=1 then
begin
if w=0 then
begin
row:= bestmove//2 mod 21;
col:= bestmove//2//21;
for ij:= 1 step 1 until 19 do
for i:= -ij step 1 until ij do
for j:= -ij step 1 until ij do
if (abs i=ij or abs j=ij) and
row+i>0 and row+i<20 and col+j>0 and col+j<20 then
begin
bestmove:= (row+i+(col+j)*21)*2+mover-1;
pq:= bestmove+3-2*mover;
if totval(bestmove) > 16383
and totval(pq) > 16383 then goto firstbestmove
end
end
else
begin
w:= 1;
bestmove:= try.w extract 10
end
end;
firstbestmove:
for i:= depth step 1 until 13 do
bestseq(depth,i):= 42;
timebase(depth):= timebase(depth-1);
newalpha:= stratval*((depth extract 1 shift 1) -1);
if w=0 and newalpha>alpha then alpha:= newalpha;
w:= 0;
for w:= w+1 while w<=widthlimit and alpha<beta do
begin
next:= try.w extract 10;
ij:= moveno+depth-1;
moves.ij:= false add next;
totval1:= totval(next) extract 14;
nodes:= nodes+1;
node(depth):= node(depth)+1;
steptest:
if alphatest then
begin
if lookaheadstep then
begin
write(out,xymode,1,<:<96><22><30>:>,false add 32,60,<:<13>try=:>);
for mn:= 1 step 1 until widthlimit do
begin
writefield(out,try.mn extract 10);
write(out,<: :>);
end;
write(out,<: commands::>);
setposition(out,0,0);
setposition(in,0,0);
i:= readchar(in,char);
if char>116 or i=7 then
begin
treatcommands;
goto steptest
end;
end;
writemoves(out,ij-mw,ij);
changeboard(ij,true);
writealphatest(actmover,depth,next,
boardvalue(mover),newalpha,alpha,beta,bestmove);
end;
comment boardvalue ses fra Xs synspunkt,
stratval ses fra moverens synspunkt,
alpha og newalpha ses fra actmoverens synspunkt;
if depth=stdepth or moveno+depth>maxmoves
or (widthlimit=1 and depth=1) then
stratval:= boardvalue(mover)*(3-2*mover)
+(totval1 extract 7)*((depth extract 1 shift 1) -1);
if try.w extract 12 >= 2048 then newalpha:= 901-depth
-(if totval1>=11*128 then 0 else
if totval1>=5*128 then 2 else 4)
else
if depth=threatdepth(mover) or moveno+depth>maxmoves
or depth>=moveno+1
or (widthlimit=1 and depth=1) then
newalpha:= stratval*((depth extract 1 shift 1) -1)
else
begin
if depth=1 then force1:= try.w extract 11 >= 1024;
if depth=2 then force2:= try.w extract 11 >= 1024;
move(next,depth);
timeslice(depth):= timeslice(depth-1)*slice(widthlimit,w);
newalpha:= alphabeta(depth+1,-beta,-alpha);
move(next,depth);
timebase(depth):= timebase(depth)+timeslice(depth);
systime(1,movestart,movetime);
if movetime>timebase(depth-1)+timeslice(depth-1)
or (movetime+4 > timeslice(0) and depth = 1) then
w:= widthlimit
end;
if depth=1 and -, alphatest then
begin
writefield(testlog,next);
write(testlog,<<-dd>,newalpha,<: :>);
writefield(out,next);
write(out,<<-dd>,newalpha,<: :>);
setposition(out,0,0)
end;
if newalpha>alpha then
begin
for i:= depth+1 step 1 until 13 do
bestseq(depth,i):= bestseq(depth+1,i);
bestseq(depth,depth):= next;
alpha:= newalpha;
if depth=1 then bestmove:= next
end;
if alphatest then
begin
writemoves(out,moveno+depth-mw-2,moveno+depth-2);
changeboard(moveno+depth-1,false);
writealphatest(actmover,depth,next,
boardvalue(mover),newalpha,alpha,beta,bestmove);
end
end w;
if alphatest and alpha>=beta then
write(testlog,<:<10> CUT-OFF :>,widthlimit,widthlimit-w+1);
alphabeta:= -alpha
end alphabeta;
\f
procedure move(xy,depth);
value xy,depth;
integer xy,depth;
begin
procedure propose_delete;
begin
comment
if movetest then writemovetest(<: DEL:>,gh,depth);
rs:= propose(gh);
tu:= propose(gh+1);
propose(rs+1):= tu;
propose(tu):= rs;
propose(gh+1):= 0
end propose_delete;
procedure propose_insert;
begin
rs:= (totval1 extract 7 shift 2)+(actmover+837)*2;
if threatval > 0 then
rs:= threat(threatval)+actmover*2;
comment
if movetest then writemovetest(<: INS:>,gh,depth);
tu:= propose(rs+1);
propose(rs+1):= gh;
propose(gh):= rs;
propose(gh+1):= tu;
propose(tu):= gh
end propose_insert;
\f
integer actmover,pm1,distance,distsign,ws,dir,wing,ffield,dw,
threatval,totval1,totval2;
boolean field gh,ij,mn,pq,rs,tu;
boolean met1,met2,backwards;
actmover:= (xy extract 1) +1;
pm1:= 1-(xy extract 1 shift 1);
ij:= xy;
gh:= ij shift 1;
comment
if movetest then writemovetest(<: MOV:>,ij,depth);
totval1:= totval(ij);
pq:= ij+pm1;
totval2:= totval(pq) extract 14;
if totval1 > 16383 then
begin
comment feltet er frit, det besættes;
backwards:= false;
totval1:= totval1 extract 14;
totval(ij):= totval1;
boardvalue(mover):= boardvalue(mover) + (totval1 extract 7)*pm1;
distsign:= 0;
if propose(gh+1) > 0 then propose_delete;
gh:= pq shift 1;
if propose(gh+1) > 0 then proposedelete;
end
else
begin
comment feltet er besat, det frigives;
backwards:= true;
totval(ij):= totval1+16384;
boardvalue(mover):= boardvalue(mover)-(totval1 extract 7)*pm1;
distsign:= 8;
threatval:= totval1 shift (-7);
if totval1 extract 7 > proposelow(mover,actmover)
or threatval > 0 then
propose_insert;
threatval:= totval2 shift (-7);
if totval2 extract 7 > proposelow(mover,3-actmover)
or threatval > 0 then
begin
gh:= pq shift 1;
totval1:= totval2;
actmover:= 3-actmover;
propose_insert
end
end;
for dir:= 0,1,2,3 do
for wing:= 0,4 do
begin
comment de 32 omegnsfelter opdateres;
dw:= (dir shift 3) +wing;
ws:= wing+distsign;
met1:= met2 := false;
for ffield:= 1 step 1 until 4 do
begin
ij:= xy+cd(dw+ffield);
comment
if movetest then writemovetest(<: UPD:>,ij,depth);
pq:= ij + pm1;
actmover:= (xy extract 1)+1;
totval1:= totval(ij);
totval2:= totval(pq);
if totval1 > 16383 and totval2 > 16383 then
begin
comment omegnsfeltet er frit, det opdateres;
distance:= dist(ffield+ws);
totval1:= totval1 extract 14;
distupdate:
gh:= ij shift 1;
comment
if movetest then writemovetest(<: FRE:>,ij,depth);
if propose(gh+1) > 0 then
begin
rs:= propose(gh);
tu:= propose(gh+1);
propose(rs+1):= tu;
propose(tu):= rs;
propose(gh+1):= 0
end;
mn:= (ij shift 2) +dir;
rs:= env(mn);
tu:= rs+distance;
env(mn):= tu;
totval1:= totval1+envval.tu extract 12-envval.rs extract 12;
totval(ij):= totval1+16384;
threatval:= totval1 shift (-7);
if (totval1 extract 7 > proposelow(mover,actmover)
and (depth<stdepth or backwards))
or threatval > 0 then
begin
rs:= (totval1 extract 7 shift 2) + 2*(actmover+837);
if threatval > 0 then
rs:= threat(threatval)+2*actmover;
tu:= propose(rs+1);
propose(rs+1):= gh;
propose(gh):= rs;
propose(gh+1):= tu;
propose(tu):= gh
end;
if ij <> pq then
begin
ij:= pq;
totval1:= totval2 extract 14;
actmover:= 3-actmover;
distance:= distance+distance;
goto distupdate
end
end
else
begin
comment omegnsfeltet er besat;
comment
if movetest then writemovetest(<: OCC:>,ij,depth);
if totval1 < 16384 then met1:= true;
if totval2 < 16384 then met2:= true;
if met1 and met2 then ffield:=4
end
end ffield;
end wing;
if envtest then writeenv(testlog,env);
if totvaltest then
begin
i:= 3*mover;
writetotval(testlog,totval,env,envval,
string playername(increase(i)));
end;
if proposetest then writepropose;
end move;
\f
procedure writemovetest(location,ij,depth);
value ij,depth;
integer ij,depth;
string location;
begin
write(testlog,<:<10>:>,case ((ij extract 1)+1) of (<:X:>,<:O:>),
location,false add 32,depth+1);
writefield(testlog,ij);
write(testlog,<: totval=:>);
writefieldval(testlog,ij);
end;
procedure writealphatest(actmover,depth,next,board,
newalpha,alpha,beta,bestmove);
value actmover,depth,next,board,newalpha,alpha,beta,bestmove;
integer actmover,depth,next,board,newalpha,alpha,beta,bestmove;
begin
write(testlog,<:<10>:>,case actmover of (<:X:>,<:O:>),
<: ALF:>,false add 32,depth+1,<:nx=:>);
writefield(testlog,next);
write(testlog,<: tv=:>);
writefieldval(testlog,next);
write(testlog,<: bv=:>,<<-ddd>,board,<<-ddd>,
<: na=:>,newalpha,<: al=:>,alpha,<: be=:>,beta,<: bm=:>);
writefield(testlog,bestmove);
end;
procedure writefield(outzone,ij);
value ij;
zone outzone;
integer ij;
begin
write(outzone,false add (ij//2//21+(if ij>378 then 65 else 64)),
1,<<dd>,ij//2 mod 21);
end;
procedure writefieldval(outzone,ij);
value ij;
zone outzone;
integer ij;
begin
boolean field pq;
pq:= ij;
write(outzone,<<ddd>,totval(pq) extract 14 shift (-7),<:,:>,
<<dd>,totval(pq) extract 7)
end;
\f
procedure writenewboard;
begin
write(out,erase,1,<: A B C D E F G H J K L M N O P Q R S T:>);
for i:= 1 step 1 until 19 do
write(out,down,1,return,1,<<dd>,20-i,
<:. . . . . . . . . . . . . . . . . . .:>,20-i);
write(out,down,1,return,1,<: A B C D E F G H J K L M N O P Q R S T:>);
setposition(out,0,0)
end;
procedure writehead(out);
zone out;
begin
write(out,xymode,1,<:J:>,false,1,<<dd dd dd>,
systime(2,gamestart,clock),<: :>,clock);
for mover:= 1,2 do
begin
i:= 3*mover;
write(out,xymode,1,<:J:>,false add (3*mover-2),1,
case mover of (<:X :>,<:O :>),
string playername(increase(i)));
if playertype(mover)=1 then
begin
write(out,<: thr= :>,<<dd>,threatdepth(mover),
<:; slicefactor= :>,<<d.d>,slicefactor(mover),<:;:>,
<<d>,xymode,1,<:T:>,false add(3*mover-1),1,
<:str= :>,stratdepth(mover),<:; wid=:>);
for i:= 1 step 1 until stratdepth(mover)+1 do
write(out,<<dd>,width(mover,i));
write(out,<:;:>,xymode,1,<:T:>,false add(3*mover),1,
<:cre= :>,creative(mover,4),<:+:>,creative(mover,5),<:,:>,
creative(mover,3),<:+:>,creative(mover,2),<:;:>);
end
end;
write(out,xymode,1,<:J<7>Moveno X O:>);
setposition(out,0,0)
end;
\f
procedure writemoves(out,firstmove,lastmove);
value firstmove,lastmove;
integer firstmove,lastmove;
zone out;
begin
boolean field i;
for i:= firstmove step 1 until lastmove do
begin
write(out,xymode,1,<:J:>,false add(8+i-firstmove),1);
if i>0 then
begin
write(out,<<ddddd>,i,<: :>);
if i mod 2 = 0 then write(out,<: :>);
writefield(out,moves.i extract 10);
if i mod 2 = 1 then write(out,<: :>)
end
else
write(out,<: :>)
end;
setposition(out,0,0)
end;
\f
procedure changeboard(lastmoveno,forward);
value lastmoveno,forward;
integer lastmoveno;
boolean forward;
begin
if forward then
begin
if lastmoveno>1 then changemove(lastmoveno-1,1);
changemove(lastmoveno,2)
end
else
begin
changemove(lastmoveno,0);
changemove(lastmoveno-1,2)
end;
setposition(out,0,0)
end;
procedure changemove(moveno,option);
value moveno,option;
integer moveno,option;
begin
boolean field m;
integer move,row,col,char,mover;
m:= moveno;
mover:= 2 - m mod 2;
move:= moves.m extract 10;
row:= 20-move//2 mod 21;
col:= move//2//21*2;
col:= if col>31 then col+32 else col+96;
char:= case option+1 of
(46,if mover=1 then 120 else 111,
if mover=1 then 88 else 79);
write(out,xymode,1,false add col,1,false add row,1,false add char,1)
end;
procedure writedetails(out);
zone out;
begin
write(out,xymode,1,<:J<15>totval= :>);
writefieldval(out,bestmove);
write(out,<:; boardvalue=:>,<<-ddd>,boardvalue(mover),<: ;:>,
xymode,1,<:J<16>movetime=:>,movetime,
<: s; totaltime= :>,timeused(moveno),<: s;:>);
if playertype(mover)=1 then
begin
write(out,xymode,1,<:J<17>timeslice=:>,<<ddd>,timeslice(0),
<<-ddd>,<: s; alfa= :>,alpha,<: ;:>,
xymode,1,<:J<18>nodes= :>,<<-dddd>,nodes,
<: ; nodetime=:>,(movetime-0.018*blocksread)/nodes*1000,
<: ms; :>,xymode,1,<:J<19>blocksread=:>,<<ddd>,blocksread,
<: ;:>,xymode,1,<:<96><22>:>);
for i:= 1 step 1 until threatdepth(mover) do
write(out,<<dddd>,node(i));
write(out,down,1,return,1);
for i:= 1 step 1 until threatdepth(mover) do
begin
write(out,<: :>);
writefield(out,bestseq(1,i));
end
end;
setposition(out,0,0)
end;
\f
procedure writeboard(out,lastmoveno);
value lastmoveno;
integer lastmoveno;
zone out;
begin
procedure colnameline;
begin
write(out,<:<10> :>);
for col:= collow-margin step 1 until colhigh+margin do
if col>0 and col<20 then
begin
char:= if col>8 then col+65 else col+64;
write(out,false add char,1)
end
end;
boolean array board(1:19,1:19);
integer row,rowlow,rowhigh,col,collow,colhigh;
boolean field i;
for row:= 1 step 1 until 19 do
for col:= 1 step 1 until 19 do board(row,col):= false add 46;
rowlow:= collow:= 19;
rowhigh:= colhigh:= 1;
for i:= 1 step 1 until lastmoveno do
begin
row:= (moves.i extract 12)//2 mod 21;
col:= (moves.i extract 12)//2//21;
board(row,col):= false add (79+9*(i extract 1));
if i<lastmoveno then board(row,col):= board(row,col) add 32;
if row < rowlow then rowlow:= row;
if row > rowhigh then rowhigh:= row;
if col < collow then collow:= col;
if col > colhigh then colhigh:= col;
end i;
colnameline;
for row:= rowhigh+margin step -1 until rowlow-margin do
if row>0 and row<20 then
begin
write(out,<:<10>:>,<<dd>,row);
for col:= collow-margin step 1 until colhigh+margin do
if col>0 and col<20 then write(out,board(row,col),1);
write(out,<<d>,row)
end row;
colnameline;
write(out,<:<10><10>:>);
end;
\f
procedure writepropose;
begin
procedure writechain(totval);
value totval;
integer totval;
begin
boolean field pq;
write(testlog,<:<10>:>,<<ddd>,totval);
pq:= ij;
for pq:= propose(pq+1) while pq>0 and pq<1676 do
begin
write(testlog,<: :>);
writefield(testlog,pq shift (-1));
if totval<7 then writefieldval(testlog,pq shift (-1));
end
end;
boolean field ij;
integer player,prlow,i,j,pl;
for player:= 1,2 do
begin
pl:= 2*player;
i:= mover*3;
write(testlog,<:<12>:>,string playername(increase(i)),
<:-propose for :>,case player of (<:X:>,<:O:>),
<:<10><10>trusler :<10>:>);
for ij:= 166+pl,250+pl,334+pl,418+pl,502+pl do
if propose(ij+1) < 1676 then writechain(7-ij//84);
write(testlog,<:<10><10>ikke-trusler :<10>:>);
prlow:= proposelow(mover,player)*4+1680;
for ij:= 2182+pl step -4 until prlow do
if propose(ij+1) < 1676 then writechain((ij-1676)//4);
comment
goto wpout;
write(testlog,<:<10><10><10> :>);
for i:= 0 step 1 until 20 do
write(testlog,<<ddd>,i);
write(testlog,<:<10>A . :>);
for ij:= 86+pl,ij+4 while ij<2188 do
begin
if ij mod 84 < 4 then
begin
write(testlog,<:<10>:>);
write(testlog,false add (ij//84
+(if ij//84 > 8 then 65 else 64)),1,<: :>);
end;
if propose(ij+1) = 0 then
write(testlog,<: . :>)
else
writefield(testlog,propose(ij+1) shift (-1));
end;
wpout:
write(testlog,<:<10>:>);
end player;
end writepropose;
\f
procedure discio(iotype);
value iotype;
integer iotype;
begin
real plnostring;
plnostring:= real ( case mover of (<:spiller1:>,<:spiller2:>));
disk(envval,-5,6560,string plnostring,0,iotype);
disk(totval,0,1762,string plnostring,13,iotype);
disk(propose,175,4374,string plnostring,17,iotype);
disk(env,351,6702,string plnostring,26,iotype);
end;
procedure proposeclean(actmover);
value actmover;
integer actmover;
begin
integer fieldcount;
fieldcount:= 0;
ij:= 2186+actmover*2;
for ij:= ij-4
while (ij-1676) shift (-2) > proposelow(mover,actmover)
and fieldcount < enoughfields(mover) do
begin
pq:= ij;
for pq:= propose(pq+1) while pq<1676 do
fieldcount:= fieldcount+1;
end;
proposelow(mover,actmover):= (ij-1676) shift (-2);
pq:= ij;
for ij:= propose(ij+1) while ij>0 do
begin
propose(pq+1):= 0;
pq:= ij
end;
if proposetest then writepropose;
end;
\f
procedure gameinit;
begin
moveblock:= 82;
winner:= 0;
moveno:= 0;
for mover:= 1,2 do
begin
timeused(1-mover):= 0;
timeleft(1-mover):= if slicefactor(mover)>5 then 5000 else 650;
boardvalue(mover):= 0;
if playertype(mover) = 1 then
begin
enoughfields(mover):= enoughfactor*width(mover,1);
for i:= 1,2 do proposelow(mover,i):= 0;
disk(env,351,6702,<:env:>,0,0);
i:= 3*mover;
disk(envval,-5,6560,string playername(increase(i)),0,0);
i:= 3*mover;
disk(totval,0,1762,string playername(increase(i)),13,0);
for i:= 88 step 1 until 1679 do propose(i):= 0;
for i:= 2184 step -4 until 1680 do
begin
propose(i):= i+4;
propose(i+1):= i-4;
propose(i+2):= i+6;
propose(i+3):= i-2
end;
for i:= 169,171,253,255,337,339,421,423,505,507 do propose(i):= 1676;
discio(1)
end;
end;
writenewboard;
writehead(out)
end;
\f
procedure treatcommands;
begin
integer gotomoveno;
boolean testvalue;
repeatchar(in);
for i:= readchar(in,char) while char>31 do
if char = 63 and moveno=0 then
begin
comment forklaring til kommandoer;
write(out,<:
træk-syntax = A-T (ikke I) 1-19 (a-t tilladt)
kommandoer defaults
u n = margenbredde n 2
v n = n træk før diktat 150
w n = vinder nr. (0,1,2)
x n = gå tilbage til træk nr. n
y(-)p = enabler/disabler test-switches :
a = alfatest false
b = look ahead, 1 trin ad gangen false
c = movetest false
d = movedetails true
e = totvaltest false
f = proposetest false
g = envtest false
h = selecttest false
z = tom
komma efter kommandoer.
:>);
readchar(in,char);
setposition(out,0,0);
end
else
if char > 116 and char < 123 then
begin
if movedetails then
write(testlog,<:<10>kommando :>,false add char,1);
case char-116 of
begin
begin
comment u;
read(in,margin)
end;
begin
comment v;
read(in,movegen);
if movedetails then write(testlog,movegen);
end;
begin
comment w;
read(in,winner);
winner:= winner+3;
goto game_end
end;
begin
comment x;
read(in,gotomoveno);
if gotomoveno <= moveno then
begin
gameinit;
moveno:= 1
end;
for moveno:= moveno step 1 until gotomoveno-1 do
begin
bestmove:= moves.moveno extract 10;
writemoves(out,moveno-mw,moveno);
changeboard(moveno,true);
for mover:= 1,2 do
if playertype(mover) = 1 then
begin
discio(0);
if moveno<gotomoveno-1 or mover = 2-moveno mod 2 then
begin
move(bestmove,1);
proposeclean(1+moveno mod 2)
end;
moveblock:= moveblock-1;
if moveblock<2 then moveblock:= 21;
discio(1)
end;
end;
moveno:= moveno-1;
goto movenostep
end;
begin
comment y;
readchar(in,char);
if movedetails then write(testlog,false add char,1);
if char <> 45 then testvalue:= true
else
begin
testvalue:= false;
readchar(in,char);
if movedetails then write(testlog,false add char,1);
end;
if char > 96 and char < 105 then
begin
case char-96 of
begin
alphatest:= testvalue;
lookaheadstep:= testvalue;
movetest:= testvalue;
movedetails:= testvalue;
totvaltest:= testvalue;
proposetest:= testvalue;
envtest:= testvalue;
selecttest:= testvalue;
end;
end;
end;
begin
comment z;
end;
end case char;
end;
end;
\f
procedure input_move;
begin
input_start:
if movegen>0 and playertype(mover)=1 then
goto input_end;
writemoves(out,moveno-mw,moveno-1);
write(out,xymode,1,<:J:>,false add(mw+8),1,
<<ddddd>,moveno,false add 32,10,back,8);
if mover = 2 then write(out,<: :>);
write(out,<:?<8>:>);
setposition(out,0,0);
setposition(in,0,0);
i:=readchar(in,char);
if char>116 or i>6 then
begin
treatcommands;
goto input_start
end;
if char>96 then char:= char-32;
col:= if char>73 then char-65 else char-64;
read(in,row);
if row<1 or row>19 or col<1 or col>19 or char=73 then
begin
write(out,xymode,1,<:J:>,false add (mw+9),1,<: ???:>);
goto input_start
end;
bestmove:= (row+col*21)*2+mover-1;
pq:= bestmove+3-2*mover;
if totval(bestmove) < 16384
or totval(pq) < 16384 then
begin
write(out,xymode,1,<:J:>,false add (mw+9),1,<:feltet er besat:>);
goto input_start
end;
input_end:
write(out,xymode,1,<:J:>,false add (mw+9),1,false add 32,15)
end;
\f
procedure write_move(outzone,actmover,ownmove);
value actmover,ownmove;
integer actmover,ownmove;
zone outzone;
begin
write(outzone,<:<10>:>,<<ddd>,moveno-1+ownmove,<: :>);
if actmover=2 then write(outzone,<: :>);
writefield(outzone,bestmove);
if actmover=1 then write(outzone,<: :>);
if movedetails and playertype(mover)=1 then
begin
write(outzone,<: :>);
writefieldval(outzone,bestmove);
write(outzone,<<-ddddd>,boardvalue(mover));
if ownmove=1 then
begin
write(outzone,<<-ddddd>,alpha,blocksread,nodes,
<<-dddd.d>,(movetime-0.018*blocksread)/nodes*1000);
write(outzone,<<-ddd.d>,timeslice(0),<:<10> :>);
for i:= 1 step 1 until threatdepth(mover) do
write(outzone,<<dddd>,node(i));
write(outzone,<:<10> :>);
for i:= 1 step 1 until threatdepth(mover) do
begin
writefield(outzone,bestseq(1,i));
write(outzone,<: :>);
end;
end;
write(outzone,<:<10>:>)
end
end;
\f
integer array totval(0:881),
propose(88:2187),
env(176:3351),
envval(-2:3280),
moves(1:75),
mnsub,od(1:2),
threat(1:63),
node(1:13),
bestseq(1:13,1:13),
enoughfields,boardvalue,
playertype,stratdepth,threatdepth,off,def(1:2),
creative(1:2,2:5),
width(1:2,1:13),
proposelow(1:2,1:2),
cd(1:32),
dist(1:16);
real array slicefactor(1:2),timeleft,timeused(-1:150),playername(3:8),
answer(1:1),timebase,timeslice(0:13),slice(1:15,1:15);
real gamestart,movestart,movetime,clock;
integer i,j,alpha,char,row,col,maxmoves,mover,margin,winner,
mw,moveblock,trywidth,stratval,stdepth,col2,row2,
movegen,nodes,enoughfactor,bottomdivisor;
boolean field ij,mn,pq,bestmove,moveno;
boolean alphatest,lookaheadstep,movetest,movedetails,
totvaltest,proposetest,envtest,selecttest,force1,force2,b,
xymode,back,down,erase,return,forward,up,home;
zone testlog(128,1,stderror);
open(testlog,4,<:testlog:>,0);
begin
integer array ia(1:12);
getshare6(out,ia,1);
ia(4):= logor(ia(4),2);
setshare6(out,ia,1)
end;
for ij:= 0 step 1 until 881 do totval(ij):= 16384;
maxmoves:= 150;
movegen:= maxmoves+1;
alphatest:= lookaheadstep:= movetest:= totvaltest:=
proposetest:= envtest:= selecttest:= false;
movedetails:= true;
margin:= 2;
for i:= 11 step 1 until 63 do threat(i):= 166;
for i:= 10,9,8,7,6,5,4 do threat(i):= 250;
threat(3):= 334;
threat(2):= 418;
threat(1):= 502;
for i:= 1 step 1 until 16 do
dist(i):= case i of (1,9,81,729,3,27,243,2187,
-1,-9,-81,-729,-3,-27,-243,-2187);
for i:= 1 step 1 until 32 do
cd(i):= case i of
(-40,-80,-120,-160,40,80,120,160,
-42,-84,-126,-168,42,84,126,168,
-44,-88,-132,-176,44,88,132,176,
-2,-4,-6,-8,2,4,6,8);
trywidth:= 15;
for i:= 1 step 1 until 15 do
begin
integer s,t;
s:= 1;
for t:= 2 step 1 until i do s:= s+t;
for j:= 1 step 1 until i do slice(i,j):= (i+1-j)/s
end;
col2:= 2;
row2:= 1;
timebase(0):= 0;
totval(0):= 0;
bestmove:= 440;
enoughfactor:= 3;
\f
new_players:
for mover:= 1,2 do
begin
write(out,<:<10><13>:>,case mover of (<:X:>,<:O:>),<: spillernavn= :>);
setposition(out,0,0);
setposition(in,0,0);
readstring(in,playername,mover*3);
mw:= 2;
xymode:= false add 6;
back:= false add 8;
down:= false add 10;
erase:= false add 12;
return:= false add 13;
forward:= false add 24;
up:= false add 26;
home:= false add 29;
threatdepth(mover):= stratdepth(mover):= 0;
if playername(3*mover) = real <:0:> then goto afslut;
if playername(3*mover) = real <:caesa:>add 114 then
begin
threatdepth(mover):= 13;
stratdepth(mover):= 6;
playertype(mover):= 1;
for j:= 1 step 1 until 13 do
width(mover,j):= case j of (6,5,4,3,2,1,0,0,0,0,0,0,0);
for j:= 2,3,4,5 do
creative(mover,j):= case j-1 of (3,33,24,3);
slicefactor(mover):= 2.5;
write(out,<:<10><13>defaults:<10><13>a : threatdepth .. :>, threatdepth(mover),
<:<10><13>b : stratdepth ... :>,stratdepth(mover),
<:<10><13>c : widths ....... :>);
for j:= 1 step 1 until stratdepth(mover)+1 do
write(out,<<ddd>,width(mover,j));
write(out,<:<10><13>d : crlimits ..... :>);
for j:= 4,5,3,2 do write(out,<<ddd>,creative(mover,j));
write(out,<:<10><13>e : slicefactor .. :>,<<d.d>,slicefactor(mover));
if mover=2 then
write(out,<:<10><13>f : move2 ........ :>,<<dd>,col2,row2);
write(out,<:<10><13>indtast eventuelle ændringer:<10><13>:>);
setposition(out,0,0);
setposition(in,0,0);
for i:= readchar(in,char) while char>96 and char<103 do
case char-96 of
begin
begin
read(in,threatdepth(mover))
end;
begin
read(in,stratdepth(mover))
end;
begin
for j:= 1 step 1 until stratdepth(mover)+1 do
read(in,width(mover,j))
end;
begin
for j:= 4,5,3,2 do
read(in,creative(mover,j))
end;
begin
read(in,slicefactor(mover))
end;
begin
read(in,col2,row2)
end;
end;
end
else
playertype(mover):= 2
end mover;
\f
new_game:
moveno:= 0;
write(out,<:<10><13>kommandoer (u,v,w,x,y,z,?) :>);
setposition(out,0,0);
setposition(in,0,0);
readchar(in,char);
treatcommands;
systime(1,0,gamestart);
gameinit;
for mover:= 1,2 do
begin
off(mover):= def(mover):= stratdepth(mover);
if width(mover,stratdepth(mover)+1)<>0 then
begin
if stratdepth(mover) extract 1 = 1 then
def(mover):= def(mover)+1
else
off(mover):= off(mover)+1
end
end;
if movedetails then
begin
write(testlog,<:<12>:>,<<dd dd dd>,
systime(2,gamestart,clock),<: :>,clock);
for mover:= 1,2 do
begin
i:= 3*mover;
write(testlog,case mover of (<:<10>X :>,<:<10>O :>),
string playername(increase(i)));
if playertype(mover) = 1 then
begin
write(testlog,<<ddd>,threatdepth(mover),stratdepth(mover),<:::>);
for i:= 1 step 1 until stratdepth(mover)+1 do
write(testlog,<<dd>,width(mover,i));
write(testlog,<:;:>,<<ddd>,creative(mover,4),
creative(mover,5),creative(mover,3),creative(mover,2));
end;
end;
write(testlog,<:<10>
Træk move total board blocks node time
nr. X O time time totval value alfa read nodes time slice
<10>:>);
end;
movenostep:
for moveno:= moveno+1 while moveno<=maxmoves and winner=0 do
begin
mover:= 2-moveno mod 2;
stdepth:= 6;
systime(1,0,movestart);
blocksread:= 0;
for i:= 1 step 1 until 13 do node(i):= 0;
nodes:= 1;
moveblock:= moveblock-1;
if moveblock<2 then
begin
timeleft(moveno-2):= timeleft(moveno-2)+200;
timeleft(moveno-1):= timeleft(moveno-1)+200;
moveblock:= 21;
end;
alpha:= 0;
\f
case playertype(mover) of
begin
begin
comment 1, intern spiller;
timeslice(0):= timeleft(moveno-2)/moveblock*slicefactor(mover)*2;
if timeslice(0)>timeleft(moveno-2) then
timeslice(0):= timeleft(moveno-2)/moveblock*2;
if playertype(3-mover)=1 then discio(0);
for i:= 1 step 1 until 13 do
for j:= 1 step 1 until 13 do bestseq(i,j):= 42;
if moveno=1 and movegen>0 then bestmove:= (10*21+10)*2
else
begin
if moveno > 1 then
begin
move(bestmove,0);
if movedetails then
write_move(testlog,3-mover,0);
proposeclean(mover);
end;
stratval:= boardvalue(mover)*(3-2*mover);
if -stratval > totval(bestmove) extract 7 shift (-1) then
begin
stdepth:= def(mover);
od(mover):= 3;
od(3-mover):= 0;
mnsub(mover):= 20;
mnsub(3-mover):= 20
end
else
begin
stdepth:= off(mover);
od(mover):= 0;
od(3-mover):= 3;
mnsub(mover):= 20;
mnsub(3-mover):= 20
end;
if stdepth>moveno then stdepth:= moveno+1;
if movegen < 1 then input_move;
if movegen>0 then
begin
if moveno=2 then
begin
col:= bestmove//2//21;
row:= bestmove//2 mod 21;
comment i:= 1+round ((movestart-gamestart)*10) mod 3;
comment j:= case i of (0,1,1);
comment i:= case i of (1,0,1);
col:= col+(if col<10 then col2 else -col2);
row:= row+(if row<10 then row2 else -row2);
bestmove:= col*42+row*2+1;
end
else
begin
write(out,<:<6><96><21>:>,false add 32,80,<:<26>:>);
alpha:= -alphabeta(1,-900,900)
end
end
end;
if alpha<-900 then
begin
winner:= 3-mover;
write(out,<:<6><96><23><10><10>:>,
case mover of (<:X opgiver:>,<:O opgiver:>),<:<10><10>:>);
goto game_end
end;
move(bestmove,1);
systime(1,movestart,movetime);
if movedetails then write_move(testlog,mover,1);
proposeclean(3-mover);
if playertype(3-mover)=1 then discio(1)
end 1;
begin
comment 2, extern spiller;
input_move;
systime(1,movestart,movetime);
if movedetails then write_move(testlog,mover,1);
end 2;
end case playertype;
moves.moveno:= false add bestmove;
writemoves(out,moveno-mw,moveno);
changeboard(moveno,true);
movegen:= movegen-1;
timeleft(moveno):= timeleft(moveno-2)-movetime;
timeused(moveno):= timeused(moveno-2)+movetime;
if movedetails then
begin
writedetails(out);
write(testlog,<:
:>,<<-dddd.d>,movetime,timeused(moveno),<:<10>:>);
writeboard(testlog,moveno);
end;
if totval(bestmove) extract 14 >= 11 shift 7 then winner:= mover
end moveno;
\f
game_end:
write(out,<:<6><96><22><30>:>,false add 32,52,<:<13><26>:>);
moveno:= moveno-1;
if winner >= 0 and winner <= 5 then
begin
write(out,case winner+1 of
(<:remis efter 150 træk:>,
<:X vinder:>,
<:O vinder:>,
<:spillet erklæret remis:>,
<:X erklæret vinder:>,
<:O erklæret vinder:>));
setposition(out,0,0);
if (winner=1 or winner=2) then
begin
if playertype(winner)=2 then
begin
write(out,<: Sejren skal kræves, ellers fortsætter spillet.:>,
<: Kræves den ? (ja/nej):>);
setposition(out,0,0);
setposition(in,0,0);
i:= 1;
readstring(in,answer,i);
if answer(1) = real <:nej:> then
begin
winner:= 0;
goto movenostep;
end
end;
end;
if movedetails then
write(testlog,<:<10><13><10><13>:>,case winner+1 of
(<:remis efter 150 træk:>,
<:X vinder:>,
<:O vinder:>,
<:spillet erklæret remis:>,
<:X erklæret vinder:>,
<:O erklæret vinder:>),<:<10><13>:>);
end
else winner:= 0;
\f
begin
zone gamerec(128,1,stderror);
boolean field bf,bf1;
integer field if1;
real field rf;
integer g,i;
open(gamerec,4,<:gamerecords:>,0);
if1:= 2;
swoprec6(gamerec,2);
g:= gamerec.if1:= gamerec.if1+1;
for i:= 1 step 1 until g do swoprec6(gamerec,222);
for bf:= 1 step 1 until moveno do
gamerec.bf:= moves.bf;
bf:= 151;
gamerec.bf:= false add moveno;
bf:= 152;
gamerec.bf:= false add winner;
rf:= 156;
gamerec.rf:= gamestart;
for rf:= 160 step 4 until 180 do
gamerec.rf:= playername((rf-148)//4);
for mover:= 1,2 do
begin
bf:= 168+18*mover;
gamerec.bf:= false add threatdepth(mover) shift 4 add stratdepth(mover);
for i:= 1 step 1 until threatdepth(mover) do
begin
bf:= 168+18*mover+i;
gamerec.bf:= false add width(mover,i)
end;
for i:= 2,3,4,5 do
begin
bf:= 180+i+18*mover;
gamerec.bf:= false add creative(mover,i)
end
end;
close(gamerec,true)
end;
\f
write(out,
<:<10><13>Flere spil med samme navne og parametre ? (ja/nej) :>);
setposition(out,0,0);
setposition(in,0,0);
i:= 1;
readstring(in,answer,i);
if answer(1) = real <:ja:> then
begin
movegen:= maxmoves+1;
write(out,<:<10><13>Skal der byttes om på X og O ? (ja/nej) :>);
setposition(out,0,0);
setposition(in,0,0);
i:= 1;
readstring(in,answer,i);
if answer(1) = real <:ja:> then
begin
real r;
for i:= 3,4,5 do
begin
r:= playername(i);
playername(i):= playername(i+3);
playername(i+3):= r;
end;
i:= playertype(1);
playertype(1):= playertype(2);
playertype(2):= i;
r:= slicefactor(1);
slicefactor(1):= slicefactor(2);
slicefactor(2):= r;
for j:= 2,3,4,5 do
begin
i:= creative(1,j);
creative(1,j):= creative(2,j);
creative(2,j):= i
end;
i:= stratdepth(1);
stratdepth(1):= stratdepth(2);
stratdepth(2):= i;
i:= threatdepth(1);
threatdepth(1):= threatdepth(2);
threatdepth(2):= i;
for i:= 1 step 1 until 13 do
begin
j:= width(1,i);
width(1,i):= width(2,i);
width(2,i):= j
end;
end;
goto new_game
end;
write(out,<:<10><13>Flere spil med nye spillere ? (ja/nej) :>);
setposition(out,0,0);
setposition(in,0,0);
i:= 1;
readstring(in,answer,i);
if answer(1) = real <:ja:> then goto new_players;
afslut:
begin
integer array ia(1:12);
getshare6(out,ia,1);
ia(4):= exor(ia(4),2);
setshare6(out,ia,1)
end;
write(testlog,<:<25>:>);
close(testlog,true)
end
end
end program
▶EOF◀