DataMuseum.dk

top - metrics - download

    Length: 25344 (0x6300)
    Types: TextFile
    Names: »savemb«

└─⟦a41ae585a⟧ Bits:30001842 SW-save af projekt 1000, Alarm-system
    └─⟦72244f0ef⟧ 
        └─⟦this⟧ »savemb« 

TextFile

job jg 8 200 time 2 0
p=set 80 disc1
o xx
p=algol list.yes xref.yes
program desp
begin
<* globale variable *>
 
boolean
retabler,       <* retabler spilsituation *>
start,          <* skal rc_8000 starte spillet *>
modif,          <* skal der modificeres i spilparametre *>
flk,            <* desp i fase forklar *>
slut,           <* er spillet slut *>
batch,          <* skal programmet køre batch *>
sim,            <* skal programmet simulere spilleren *>
a,b,c;          <* arbejdsvariabel *>
  
integer
spilnr,         <* nummer på valgte spil *>
char,klasse,    <* var til læseprocedurerne *>
time,tal,       <* arbejdsvariable *>
i,j,k,          <* arbejdsvariable *>
testniv,        <* nummer på niveau for testudskrift *>
antal_spil,     <* antallet af forskellige demospil *>
sværhed,        <* aktuelle sværhedsgrad *>
maxsvær,        <* største sværhedsgrad i aktuelle spil *>
result,         <* resultat af spillet *>
træknr,         <* aktuelle træknummer *>
tiltræk,        <* træknr til og med i batchkørsel *>
xtal;           <* tilfældig integer *>
     
integer field
inf;
 
long
version;        <* versionstext *>
 
real
r;              <* arbejdsvariabel *>
  
integer array
to(1:8 ,0:3),   <* testout array *>
ia(1:20),       <* arbejdsarray *>
stat(0:9);      <* spil statistik *>
    
zone
log(2*128,2,stderror);
  
\f


<* globale for spil1 *>
boolean
ens;            <* må der være ens cifre i løsningen *>
integer
ant_forsøg,     <* antal tilladte forsøg *>
ant_pos,        <* antal positioner i løsningen *>
ant_var;        <* antal variationer i ant_pos *>
  
<* globale for spil2 *>
integer
ant_felter,     <* antal felter i spillet *>
dim,            <* størrelse på feltet *>
apr,            <* antal på række der vinder *>
rx,ry;
  
<* globale for spil3 *>
boolean
sidst;          <* den der tager sidste pind vinder *>
integer
ant_bunker;     <* antal bunker i spillet *>
integer array
base_bunker(1:10); <* rummer startindholdet i bunkerne *>
\f


  
procedure readcr;
begin <* læser frem til nl i inzonen *>
repeatchar(in);
for klasse:= readchar(in,char) while char<> 'nl' do <*skip*>;
end;
  
integer procedure udtræk(vari);
integer vari;
begin
random(xtal);
udtræk:= xtal mod vari + 1;
end;
   
procedure setpos(z);
zone z;
begin
integer kind;
getzone6(z,ia);  kind:= ia(1) extract 12;
if kind=0 or kind=8 or kind=12 or kind=14 then
setposition(z,0,0);
end;
  
  
\f


boolean procedure læs_jn(no);
integer no;
begin
integer i;
igen:
if no>0 then
begin
readcr;
i:= write(out,<:<6><1><22><14>:>,"sp",2,case no of
<* 1*> (<:vil du begynde:>
<* 2*> ,<:må der være ens cifre i løsningen:>
<* 3*> ,<:ønskes der en forklaring på spillet:>
<* 4*> ,<:vil du prøve igen:>
<* 5*> ,<:gælder det om at tage den sidste:>
<* 6*> ,<:skal vi slutte:>
<* 7*> ,<:forklaring ønskes til spil nr: :>
<* 8*> ,<:størrelse på spillet:>
<* 9*> ,<:antal på række der vinder:>
<*10*> ,<:vil du fortsætte:>
<*11*> ,<:modif slut:>
<*12*> ,<:næste:>
<*13*> ,<:ok:>
       ),<:<63> :>);
write(out,"sp",44-i,false add 8,44-i);
setpos(out);
end;
 
for klasse:= readchar(in,char) while char='sp' do <*skip*>;
if char<>'j' and char<>'n' then
begin
if char='?' and -, flk then forklar;
goto igen;
end;
læs_jn:= char='j';
end;
  
\f


integer procedure læs_tal(nr,num,max,min);
integer nr,num,max,min;
begin
integer i;
igen:
if nr>0 then
begin
if nr>1 then readcr;
i:= write(out,<:<6><1><22><14>:>,"sp",2,case nr of
<* 1*> (<:vælg spilnr:>
<* 2*> ,<:sværhedsgrad:>
<* 3*> ,<:antal cifre i tallet:>
<* 4*> ,<:største ciffer i tallet:>
<* 5*> ,<:antal forsøg:>
<* 6*> ,<:gæt nr:>
<* 7*> ,<:forklaring ønskes til spilnr:>
<* 8*> ,<:størrelse på spillet:>
<* 9*> ,<:antal på række der vinder:>
<*10*> ,<:tast et felt:>
<*11*> ,<:antal bunker:>
<*12*> ,<:antal i bunke :>
<*13*> ,<:vælg bunkenummer og antal:>
<*14*> ,<:var nr:>
<*15*> ,<:tegn:>
<*16*> ,<:index:>
<*17*> ,<:felt nr:>
       ));
if num>-1 then i:=i+write(out,<<ddd>,num);
i:=i+write(out,<: = :>);
write(out,"sp",44-i,false add 8,44-i);
setpos(out);
end;
læs_nu_tal:
for klasse:= readchar(in,char) while char='sp' do <*skip*>;
if klasse=2 then
begin
repeatchar(in);
read(in,tal);
if tal<min or tal>max then
begin
if nr=0 then tal:= -1 else goto igen;
end;
læs_tal:= tal;
end
else
begin
if char='m' and nr=1 then
begin
modif:= true;
goto læs_nu_tal;
end else
if char='b' and nr=1 then
begin
batch:= true;
readchar(in,char);
repeatchar(in);
if char<>'nl' then
read(in,tiltræk);
end
else if char='a' then goto exit
else if char='n' then goto start_nyt_spil
else if char='f' and spilnr<>0 then goto start_spil
else if char='r' then retabler:= true
else if char='s' then sværhed:= læs_tal(2,-1,maxsvær,1)
else if char='t' then testniv:= læs_tal(-1,-1,1023,0)
else if char='u' then sim:= true
else if char='?' and -, flk and nr>0 then forklar;
goto igen;
end;
end;
  
\f


procedure forklar;
begin
integer visnr;
flk:= true;
visnr:= spilnr+1;
vis:
case visnr of
begin
begin
visnr:= læs_tal(7,-1,antal_spil,1) + 1;
goto vis;
end;
write(out,"ff",1,
"cr",1,
<:der skal gættes et tal bestående af :>,<<dd>,ant_pos,<: cifre,:>,"nl",1,
"cr",1,
<:hvert ciffer kan antage værdierne fra 0 til:>,ant_var-1,"nl",1,
"cr",1,
<:der kan:>,if ens then <: :> else <: ikke :>,
<:være ens cifre i løsningen.:>,"nl",1,
"cr",1,
<:der gives:>,<<ddd>,ant_forsøg,<: forsøg på at finde løsningen:>,"nl",1,
"cr",1,
<:tast blank mellem cifrene:>,"nl",1,"cr",1);
;
;
;
end;
while -, læs_jn(13) do;
flk:= false;
retabler:= true;
setpos(out);
end;
    
\f


<*initier globale*>
version:= long <:version 0.5  :>;
inf:= 2;
flk:= false;
retabler:= false;
antal_spil:= 2;
for i:=0 step 1 until 9 do stat(i):= 0;
systime(1,time,r);
xtal:= r;
testniv:= 0;
<* initier faste spilparametre *>
<* spil 1 *>
ant_forsøg:= 8;
ens       := true;
ant_pos   := 4;
ant_var   := 10;
<* spil 2 *>
dim       := 15;
apr       := 5;
ant_felter:= dim*dim;
<* spil 3 *>
sidst     := false;
ant_bunker:= 5;
for i:= 1 step 1 until ant_bunker do
base_bunker(i):= 2*i - 1;
open(log,4,<:logfil:>,0);
\f


start_nyt_spil:
modif:= false;
spilnr:= 0;
write(out,"ff",1,string version,"nl",2,"cr",1,
"sp",30,<:D E M O S P I L:>,"nl",2,"cr",1);
j:= 0;
for i:=1 step 1 until antal_spil,4,5,6,7 do
begin
j:= j+1;
write(out,case i of(
 _<:master mind ----------------------- ( 1 ):>
,<:kryds og bolle -------------------- ( 2 ):>
,<:nim ------------------------------- ( 3 ):>
,<:forklaring til spillet ------------ ( ? ):>
,<:nyt spil ønskes ------------------- ( n ):>
,<:samme spil forfra ----------------- ( f ):>
,<:afslut demospil ------------------- ( a ):>),"nl",1,"cr",1);
end;
setpos(in);
setpos(out);
batch:= false;
sim  := false;
tiltræk:= 0;
spilnr:= læs_tal(1,-1,antal_spil,1);
\f


<* initier spilparametre *>
   
start   := case spilnr of (false,true,false,false,false);
maxsvær := case spilnr of ( 0, 5, 0, 0, 0 );
sværhed := case spilnr of ( 1, 3, 1, 0, 0 );
for i:=1 step 1 until 8 do to(i,0):= 0;
\f


<* modificer parametre *>
  
if modif then
begin
if maxsvær>0 then sværhed:= læs_tal(2,-1,maxsvær,1);
b:= case spilnr of (false,true,false,false,false);
if b then start:= -, læs_jn(1);
  
case spilnr of
begin
begin <* spil 1 *>
ens:= læs_jn(2);
ant_pos:= læs_tal(3,-1,10,1);
for ant_var:= 1+læs_tal(4,-1,9,0) while
( -, ens and ant_var<ant_pos ) do;
ant_forsøg:= læs_tal(5,-1,100,1);
end;
begin <* spil 2 *>
dim:= læs_tal(8,-1,20,3);
apr:= læs_tal(9,-1,5,3);
ant_felter:= dim*dim;
end;
end case;
end modif;
\f


start_spil:
  
slut    := false;
result  := 0;
træknr  := 0;
  
case spilnr of
begin
begin <* master mind *>
integer
cifok,         <* antal rigtige positioner *>
ciferder,      <* antal rigtige cifre *>
plus,minus,
i,j,a,b,c;     <* arbejdsvariable *>
integer array
løsning (1:ant_pos),
liste   (1:ant_forsøg),
gæt     (1:ant_pos,1:ant_forsøg);
   
<* lav løsning *>
for i:=1 step 1 until ant_pos do
begin
løsning(i):= udtræk(ant_var)-1;
if -, ens then
for j:=1 step 1 until i do
if løsning(i)=løsning(j) and i<>j then i:= i-1;
end;
  
<* start spil *>
result:= -1;
write(out,"nl",1);
while -, slut and træknr<ant_forsøg do
begin
træknr:= træknr + 1;
læs_ny:
for i:=1 step 1 until ant_pos do
begin
gæt(i,træknr):= if i=1 then læs_tal(6,træknr,ant_var-1,0) else
læs_tal(0,-1,ant_var-1,0);
if gæt(i,træknr)=-1 then goto læs_ny;
end;
cifok:= ciferder:= 0;
for j:= 0 step 1 until ant_var-1 do
begin
plus:= minus:= 0;
for i:=1 step 1 until ant_pos do
begin
a:= if løsning(i)=j then 1 else 0;
b:= if gæt(i,træknr)=j then 1 else 0;
c:= a-b;
case c+2 of
begin
minus:= minus+1;
;
plus := plus+1;
end;
end;
cifok:= cifok+minus;
ciferder:= ciferder + (if plus>minus then minus else plus);
end;
cifok:= ant_pos-cifok;
write(out,false add 24,30,false add 26,1);
for j:= 1 step 1 until ant_pos do
write(out,<<dd>,gæt(j,træknr));
write(out,<:  =>  :>,"+",cifok,"sp",ant_pos-cifok,"-",ciferder,"nl",2);
liste(træknr):= cifok shift 12 + ciferder;
if cifok=ant_pos then
begin
slut:= true;
result:= 1;
end;
end træknr;
for i:= 1 step 1 until ant_pos do ia(i):= løsning(i);
end master mind;
\f


begin <* kryds og bolle *>
integer
base0,base1,base2,basex,
i,j,k,kryds,bolle,ialt,
trx,try;    <* fundne modtræk *>
integer array
stilling (1:dim,1:dim),
træk     (1:ant_felter),
liste    (-apr:apr),
adr      (-apr:apr),
række    (-apr:apr),
felt     (-apr:apr),
<*var 1*> styrke   (1:2),      <* max styrke i felt *>
<*var 2*> gemfelt  (1:4,0:8*apr),
<*var 3*> modtræk  (0:dim*dim),  <* resterende tomme felter *>
<*var 4*> kandidat (1:2,0:dim*dim),
<*var 5*> chance   (1:2,1:dim,1:dim),
<*var 6*> tryk     (1:2,1:dim,1:dim),
<*var 7*> ktryk    (1:2,1:dim,1:dim),
<*var 8*> kombi    (1:2,1:dim,1:dim);
\f


procedure update_spil2(x,y,tegn);
integer x,y,tegn;
begin
integer i, char;
if retabler then vis_spil2(stilling);
stilling(x,y):= tegn;
træk(træknr):= x shift 6 + y;
for char:=6, x, dim-y do
outchar( out, char);
for i:=1 step 1 until 1+2*x do  outchar(out,24);
write( out, case tegn+1 of (
<:-:>, <:x:>, <:o:>));
if træknr=2 then
write(out,<:<6><1><21><14>:>,"sp",11);
write(out,<:<6><1><21><14>:>,
if tegn=kryds == start then <:kryds:> else <:bolle:>,
<<ddd>,x,<: -:>,y);
setpos(out);
i:= 0;
for i:=i+1 while modtræk(i)<>træk(træknr) do;
modtræk(i):= modtræk(modtræk(0));
modtræk(0):= modtræk(0)-1;
write(log,"nl",1,<:træk:>,<<ddd>,træknr,
if tegn=kryds then <: rc8000 :> else <: player :>,x,y);
end;


\f


procedure udskr2(vent);
boolean vent;
begin
integer i,j,k,a,b,c;
if testniv extract 1=1 then
begin <* modif testout *>
modom:
a:= læs_tal(17,-1,8,1);
i:= to(a,0):= læs_tal(14,-1,8,0);
if i<>0 then
begin
b:= case i of (2,4,dim*dim,2,2,2,2,2);
to(a,1):= læs_tal(16,1,b,if i=3 then 0 else 1);
b:= case i of (
0, 8*apr, 0, dim*dim, dim, dim, dim, dim);
c:= case i of (
0, 0, 0, 0, 1, 1, 1, 1);
if b>0 then to(a,2):= læs_tal(16,2,b,c);
b:= case i of (
0, 0, 0, 0, dim, dim, dim, dim);
c:= case i of (
0, 0, 0, 0, 1, 1, 1, 1);
if b>0 then to(a,3):= læs_tal(16,3,b,c);
end;
if -, læs_jn(11) then goto modom else
testniv:= testniv shift (-1) shift 1;
end modif;
  
write(out,<:<6><1><23><14>:>);
for i:=1 step 1 until 8 do
begin
k:= to(i,0);
if k=0 then write(out,"sp",10)
else
begin
a:= to(i,1);
b:= to(i,2);
c:= to(i,3);
write(out,<<dddddddddd>,case k of (
styrke(a),
(case a of (
(gemfelt(1,b) shift (-6))*100+gemfelt(1,b) extract 6,
0,0,0)),
(modtræk(a) shift (-6))*100 + modtræk(a) extract 6,
(kandidat(a,b) shift (-6))*100+kandidat(a,b) extract 6,
chance(a,b,c),
tryk(a,b,c),
ktryk(a,b,c),
extend kombi(a,b,c) shift (-16)*100000 +
kombi(a,b,c) shift (-8) extract 8 * 100 +
kombi(a,b,c) extract 8
));
end;
end for i;
if vent then
begin
if læs_jn(12) then goto modom;
end;
end udskr2;
\f


procedure vis_spil2(st);
integer array st;
begin
integer k,l;
write(out,"ff",1);
for k:= dim step -1 until 1 do
begin
write(out,<<dd>,k);
for l:=1 step 1 until dim do
write(out,case st(l,k)+1 of (
<: -:>,<: x:>,<: o:>));
write(out,"nl",1,"cr",1);
end;
for k:=0 step 1 until dim do
write(out,<<dd>,k mod 10);
if træknr=0 then
write(out,<:<6><1><21><14>sværhed =:>,<<dd>,sværhed);
setpos(out);
retabler:= false;
end;
  
boolean procedure nyt_felt(x,y,retning);
<* x,y er koordinaterne til feltet hvorfra der beregnes
nytfelts x,y i aktuelle retning,nyt_felt=true hvis felt findes *>
integer x,y,retning;
begin
integer ax,ay;
ax:= x + (case retning of ( 0, 1, 1, 1, 0,-1,-1,-1));
ay:= y + (case retning of ( 1, 1, 0,-1,-1,-1, 0, 1));
if ax<=dim and ax>0 and
   ay<=dim and ay>0 then
begin
nyt_felt:= true;
x:= ax;
y:= ay;
end else
nyt_felt:= false;
end;
\f


procedure check_række(st,x,y,retning,tegn);
integer array st;
integer x,y,retning,tegn;
begin
integer k;
for k:= -apr step 1 until apr do
begin
liste(k):= adr(k):= 0;
felt (k):= række(k):= 0;
end;
for k:= retning, retning+4 do
check_retning(st,x,y,k,tegn);
liste(0):= liste(0)-1;
end;
\f


procedure check_retning(st,x,y,retning,tegn);
integer array st;
integer x,y,retning,tegn;
begin
integer ax,ay,antal,akt_tegn,fase,sign;
boolean færdig , nyt_tegn;
  
sign:= if retning<5 then 1 else -1;
færdig:= false;
nyt_tegn:= false;
ax:= x;  ay:= y;  antal:= -1;  fase:= 0;
akt_tegn:= st(x,y);
for antal:=antal+1 while
antal<=apr-1 and -, færdig do
begin
række(antal*sign):= st(ax,ay);
felt (antal*sign):= ax shift 6 + ay;
if st(ax,ay)<>akt_tegn then
begin <* nyt tegn *>
akt_tegn:= st(ax,ay);
fase:= fase + sign;
adr(fase):= ax shift 6 + ay;
end;
if -, nyt_tegn then
begin
nyt_tegn:= akt_tegn=3-tegn;
if nyt_tegn then række(sign*apr):= antal;
end;
liste(fase):= liste(fase) + 1;
færdig:= -, nyt_felt(ax,ay,retning);
end;
felt(sign*apr):= antal-1;
if -, nyt_tegn then række(sign*apr):= antal;
end;
\f


procedure fmt(tegn,trx,try,sv);
integer tegn,trx,try,sv;
begin
integer a,b,i,j,k,kt,m,nykombi,kryds,bolle,type;
integer array tot(1:2,base2:basex);
kryds:= tegn;
bolle:= 3-tegn;
case sv of
begin
begin <* sv 1 *>
k:= udtræk(modtræk(0));
trx:= modtræk(k) shift (-6);
try:= modtræk(k) extract 6;
end <* sv 1 *>;
begin <* sv 2 *>
m:= k:= 0;
styrke(kryds):= 0;
for b:=1 step 1 until modtræk(0) do
begin
i:= modtræk(b) shift (-6);
j:= modtræk(b) extract 6;
a:= chance(kryds,i,j) + chance(bolle,i,j);
if a>0 then
begin
m:= m+1;
if a>styrke(kryds) then
begin
styrke(kryds):= a;
k:= 1;
kandidat(kryds,k):= i shift 6 + j;
end
else
if a=styrke(kryds) then
begin
k:= k+1;
kandidat(kryds,k):= i shift 6 + j;
end;
end;
end;
   
if k>0 then
begin
b:= udtræk(k);
trx:= kandidat(kryds,b) shift (-6) extract 6;
try:= kandidat(kryds,b) extract 6;
end;
if m<2 then
begin
if læs_jn(6) then
begin
slut:= true;
result:= 1;
end;
end;
end <* sv 2 *>;
begin <* sv 3 *>
m:= 0;
for b:= base2,base1,base1+1,base0,basex do
tot(1,b):= tot(2,b):= 0;
styrke(kryds):= styrke(bolle):= 0;
kandidat(kryds,0):= kandidat(bolle,0):= 0;
for a:= 1 step 1 until modtræk(0) do
begin
i:= modtræk(a) shift (-6) extract 6;
j:= modtræk(a) extract 6;
for b:= kryds,bolle do
begin
k:= tryk(b,i,j);
kt:= ktryk(b,i,j);
nykombi:= k shift 8 add kt  shift 8 add chance(b,i,j);
if nykombi>0 then
begin
m:= m+1;
if k<base2 then
begin
if styrke(b)<base2 then
begin
if k>styrke(b) then styrke(b):= k;
if kt>0 then
begin
kandidat(b,0):= kandidat(b,0) + 1;
kandidat(b,kandidat(b,0)):= modtræk(a);
end;
end;
end else
begin
if k>styrke(b) then
begin
if styrke(b)<base2 then
kandidat(b,0):= 0;
styrke(b):= k;
end;
kandidat(b,0):= kandidat(b,0) + 1;
kandidat(b,kandidat(b,0)):= modtræk(a);
tot(b,k):= tot(b,k) + 1;
end;
end;
if nykombi<>kombi(b,i,j) and k>=base2-1 then
begin
write(log,"nl",1,<:x-y-t:>,<<ddd>,i,j,
if b=kryds then <: kryds:> else <: bolle:>,
nykombi shift (-16),
nykombi shift (-8) extract 8,
nykombi extract 8);
end;
kombi(b,i,j):= nykombi;
end;
end;
i:= styrke(kryds);
j:= styrke(bolle);
  
<* vælg tegn og strategi *>
if sværhed=3 then
type:=
if i>=j then kryds+28 else bolle+28
else
type:=
if træknr<=apr*2 then
(
bolle+4
) else
if i=basex then kryds+4 else
if j=basex then bolle+4 else
if i=base0 then kryds+4 else
if j=base0 then
(
if tot(bolle,base0)>2 and tot(kryds,base1)>0 then kryds+28 else
if i<base2 then bolle+4 else bolle+28
) else
if i=base1+1 then
(
if j=base1+1 then kryds+28 else kryds+4
) else
if j=base1+1 then
(
if i=base1 then kryds+28 else
if i=base2 then bolle+28 else bolle+4
) else
if i=base1 then
(
if j=base1 then kryds+20 else if j=base2 then kryds+8 else kryds+4
) else
if j=base1 then
(
if tot(bolle,base1)>1 then bolle+20 else kryds+8
) else
if i=base2 then
(
if j=base2 then kryds+16 else kryds+8
) else
if j=base2 then
(if tot(bolle,base2)<2 then kryds+4 else bolle+20) else
if i>1 shift 8 then kryds+20 else
bolle+20;
 
k:= type extract 2;
type:= type shift (-2);
if styrke(k)>0 then
begin
kandidat(3-k,0):= 0;
styrke(3-k):= 0;
for a:=1 step 1 until kandidat(k,0) do
begin
i:= kandidat(k,a) shift (-6);
j:= kandidat(k,a) extract 6;
  
b:=
case type of (
kombi(k,i,j),
kombi(k,i,j) extract 16,
kombi(k,i,j) extract 8,
kombi(k,i,j) + kombi(3-k,i,j),
kombi(k,i,j) extract 16 +
kombi(3-k,i,j) extract 16,
kombi(k,i,j) extract 8 + kombi(3-k,i,j) extract 8,
kombi(k,i,j) + kombi(3-k,i,j) extract 16,
kombi(k,i,j) + kombi(3-k,i,j) extract 8);
 
if b>styrke(3-k) then
begin
styrke(3-k):= b;
kandidat(3-k,0):= 1;
kandidat(3-k,1):= kandidat(k,a);
end
else
if b=styrke(3-k) then
begin
kandidat(3-k,0):= kandidat(3-k,0) + 1;
kandidat(3-k,kandidat(3-k,0)):= kandidat(k,a);
end;
end;
b:= udtræk(kandidat(3-k,0));
trx:= kandidat(3-k,b) shift (-6) extract 6;
try:= kandidat(3-k,b) extract 6;
end;
if m<2 then
begin
if læs_jn(6) then
begin
slut:= true;
result:= 1;
end;
end;
end <* sv 3 *>;
end case;
end;
\f


integer procedure dan_chance(st,x,y,tegn);
integer array st;
integer x,y,tegn;
begin
integer j,k,antal;
antal:= 0;
for k:= 1 step 1 until 4 do
begin
check_række(st,x,y,k,tegn);
j:= række(-apr)+række(apr)-1;
if j>=apr then
antal:= antal + j - apr + 1;
end;
dan_chance:= antal;
end;
   
\f


  
procedure check_stilling(st,x,y,tegn);
integer array st;
integer x,y,tegn;
begin
integer i,j,k,m,ant,p,t;
gemfelt(1,0):= i:= 0;
for k:= 1,k+1 while -, slut and k<=4 do
begin
check_række(st,x,y,k,tegn);
if testniv shift (-4) extract 1=1 then udskr2(true);
if liste(0)>=apr then
begin <* spillet er slut *>
slut:= true;
result:= if start then 4-tegn else tegn+1;
end else
begin <* analyser *>
<* find relevante tomme felter *>
if sværhed>1 then
begin <* find felter til y chanceberegning *>
for j:= -felt(-apr) step 1 until felt(apr) do
if felt(j)<>0 and række(j)=0 then
begin
i:= i+1;
gemfelt(1,i):= felt(j);
end;
end;
   
end;
end for k;
gemfelt(1,0):= i;
<* opdater tabeller *>
if sværhed>1 then
begin
if testniv shift (-2) extract 1=1 then udskr2(true);
chance(tegn,x,y):= chance(3-tegn,x,y):= 0;
if gemfelt(1,0)>0 then
for k:=1 step 1 until gemfelt(1,0) do
begin
i:= gemfelt(1,k) shift (-6) extract 6;
j:= gemfelt(1,k) extract 6;
ktryk(kryds,i,j):=
ktryk(bolle,i,j):=
tryk(kryds,i,j):=
tryk(bolle,i,j):= 0;
chance(3-tegn,i,j):= 0;
if sværhed>2 then chance(tegn,i,j):= 0;
for m:= 1 step 1 until 4 do
begin
if sværhed=2 then
begin
check_række(st,i,j,m,3-tegn);
ant:= række(-apr) + række(apr) -1;
if ant>=apr then
chance(3-tegn,i,j):=
chance(3-tegn,i,j) + ant - apr + 1;
end;
if sværhed>2 then
begin
check_række(st,i,j,m,0);
for p:= kryds,bolle do
begin
t:= check_tryk(p,i,j);
if tryk(p,i,j)=base2 and t=base2 then
tryk(p,i,j):= base1+1 else
if (tryk(p,i,j)=base1 or tryk(p,i,j)=base2)
and (t=base1 or t=base2) then tryk(p,i,j):= base0 else
if tryk(p,i,j)<t then tryk(p,i,j):= t;
end;
end;
end;
end;
if testniv shift (-3) extract 1=1 then udskr2(true);
end;
end;
\f


integer procedure check_tryk(tegn,x,y);
integer tegn,x,y;
begin
integer tryk,antblank,fase,j,k,m,anttegn,antrække,lgdrk;
boolean slut,blank,t,tslut;
integer array kt(-1:1);
tryk:= 0;
antrække:= 0; <* antal tegn umiddelbart op til det blanke felt *>
antblank:= 1;
anttegn := 0;
lgdrk   := 1;
for fase:= -1,1 do
begin
t:= true;
tslut:= false;
slut:= false;
blank:= false;
k:= felt(fase*apr);
kt(fase):= 0;
j:= 0;
for j:=j+1 while -, slut and j<=k do
begin
m:= j*fase;
if række(m)=3-tegn then
slut:= true else
if række(m)=tegn then
begin
if -, tslut then
begin
tryk:= tryk + (if blank then 2 else 4);
lgdrk:= lgdrk + 1;
end;
blank:= false;
if t then antrække:= antrække + 1;
anttegn:= anttegn + 1;
kt(fase):= kt(fase) + apr - j;
end else
begin
if blank or tslut then
tslut:= true else
begin
tryk:= tryk + 2;
lgdrk:= lgdrk + 1;
blank:= true;
t    := false;
end;
antblank:= antblank + 1;
end;
end for j;
end for fase;
k:= antblank + anttegn;
if k>=apr then
begin
chance(tegn,x,y):= chance(tegn,x,y) + k - apr + 1;
ktryk(tegn,x,y):= ktryk(tegn,x,y) + kt(-1) + kt(1);
end;
if tryk>base0 then tryk:= base0;
if antrække>=apr-1 then tryk:= basex else
if tryk>base1 and antrække<apr-2 then tryk:= base1 else
if tryk=base2 and antrække=0 and anttegn=apr-2 then tryk:= base1 else
if tryk=base2 and lgdrk=apr and anttegn=apr-2 then tryk:= base1 else
if tryk<base1 and k=apr then tryk:= tryk-2;
check_tryk:= if k>=apr and anttegn>0 then tryk else 0;
end procedure;
\f


procedure start_batch;
begin
integer tr,i;
boolean slut;
slut:= false;
tr:= 0;
setposition(log,0,49);
inrec6(log,2);
tr:= log.inf;
i:= 0;
while -, slut do
begin
i:= i+1;
inrec6(log,2);
træk(i):= log.inf;
if i=tiltræk or i=tr then slut:= true;
end;
tiltræk:= i;
end;
\f


<***** her startet kryds og bolle *****>
  
kryds:= if start then 1 else 2;
bolle:= if start then 2 else 1;
if batch then start_batch else
for i:=1 step 1 until ant_felter do træk(i):= 0;
  
base0:= 4*(apr-1);
base1:= base0-2;
base2:= base1-2;
basex:= 2*base0;
styrke(kryds):= styrke(bolle):= 0;
kandidat(kryds,0):= kandidat(bolle,0):= 0;
for i:=1 step 1 until dim do
for j:=1 step 1 until dim do
begin
modtræk( (i-1)*dim + j ):= i shift 6 + j;
stilling(i,j):= 0;
tryk(kryds,i,j):=
tryk(bolle,i,j):=
ktryk(kryds,i,j):=
ktryk(bolle,i,j):=
kombi(kryds,i,j):=
kombi(bolle,i,j):= 0;
end;
modtræk(0):= dim*dim;
for i:= 1 step 1 until dim do
for j:= 1 step 1 until dim do
chance(kryds,i,j):=
chance(bolle,i,j):=
dan_chance(stilling,i,j,0);
if testniv extract 1=1 then udskr2(true);
vis_spil2(stilling);
setposition(log,0,0);
write(log,"nl",1,string version,<<ddd>,<:dim:>,dim,<:  apr:>,apr);
   
repeat
træknr:= træknr + 1;
if (træknr mod 2 = 1) == start then
\f


begin <* rc8000 *>
if batch and træknr<=tiltræk then
begin
trx:= træk(træknr) shift (-6) extract 6;
try:= træk(træknr) extract 6;
end else
begin
if sim then sværhed:= 3;
trx:= 0;
if trx=0 and sværhed>2 then fmt(kryds,trx,try,3);
if trx=0 and sværhed>1 then fmt(kryds,trx,try,2);
if trx=0 then fmt(kryds,trx,try,1);
end;
 
  
update_spil2(trx,try,kryds);
check_stilling(stilling,trx,try,kryds);
end <* rc8000 *>
else
begin <* spiller *>
nyt_træk:
if testniv extract 2<>0 then udskr2(false);
if batch and træknr<=tiltræk then
begin
trx:= træk(træknr) shift (-6) extract 6;
try:= træk(træknr) extract 6;
end else
if sim then
begin
sværhed:= 4;
trx:= 0;
if trx=0 and sværhed>2 then fmt(bolle,trx,try,3);
if trx=0 and sværhed>1 then fmt(bolle,trx,try,2);
if trx=0 then fmt(bolle,trx,try,1);
end else
begin
trx:= læs_tal(10,-1,dim,1);
try:= læs_tal( 0,-1,dim,1);
if try=-1 then goto nyt_træk;
if stilling(trx,try)<>0 then goto nyt_træk;
end;
update_spil2(trx,try,bolle);
check_stilling(stilling,trx,try,bolle);
end spiller;
until slut or træknr=ant_felter;
  
write(log,<:<25><25><25>:>);
getposition(log,0,i);
setposition(log,0,49);
outrec6(log,2);
log.inf:= træknr;
for j:=1 step 1 until træknr do
begin
outrec6(log,2);
log.inf:= træk(j);
end;
setposition(log,0,i+1);
 
end kryds og bolle;
end case spilnr;
\f


<* spil slut *>
case spilnr of
begin
begin <* spil 1 *>
stat(5):= stat(5) + result;
write(out,"nl",1,"cr",1);
if slut then
write(out,<:du vandt i:>,<<ddd>,træknr,<: forsøg !!!:>,"nl",1)
else
begin
write(out,<:du tabte , løsningen er :>);
for i:= 1 step 1 until ant_pos do
write(out,<<dd>,ia(i));
end;
end spil 1;
begin <* spil 2 *>
if sim and result>1 then result:= 4;
write(out,<:<6><1><21><14>:>,case result+1 of (
<:det blev uafgjort , tak for spillet:>,
<:det blev uafgjort:>,
<:du vandt , tillykke:>,
<:du tabte !!!     :>,
<:jeg vandt , hurra:>));
stat(result):= stat(result) + 1;
end spil 2;
end case;
<* afslut aktuelle spil *>
  
setpos(out);
if læs_jn(4) then goto start_spil
else goto start_nyt_spil;
  
exit:
write(out,"nl",1);
write(log,<:<25><25><25><25>:>);
close(log,true);
end;
o c
scope login p
scope login xx
finis

▶EOF◀