|
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: 10752 (0x2a00)
Types: TextFile
Names: »tretbusnumr «
└─⟦110021343⟧ Bits:30007476 RC8000 Backup tape fra HT's bus-radio system
└─⟦a957ba283⟧
└─⟦this⟧ »tretbusnumr «
;retbusnumre
begin
integer max_antal_busser, max_antal_garager, max_antal_områder;
max_antal_busser:= 2000;
max_antal_garager:= 127;
max_antal_områder:= 11;
begin
integer array bustabel,bustabel1(0:max_antal_busser),
tail(1:10),alfa(0:127);
long array garagenavn(0:max_antal_garager),
områdenavn(1:max_antal_områder),
n(1:2);
integer array field iaf;
real t;
integer sidstebus, b, b1, b2, s, g, o, ch, i, j, i1, i2, akt, nr;
zone z(128,1,stderror);
integer procedure findnavn(navn,tabel);
long navn; long array tabel;
begin
integer i,nr,low,up;
low:= system(3,up,tabel);
i:= 1; nr:= 0;
while i<=up and nr=0 do
begin
if navn=tabel(i) then nr:= i;
i:= i+1;
end;
findnavn:= nr;
end;
boolean procedure indsæt(plads,bus,sig,gar,omr);
value plads,bus,sig,gar,omr;
integer plads,bus,sig,gar,omr;
begin
integer i;
if sidstebus<max_antal_busser then
begin
for i:= sidstebus step -1 until plads do
begin
bustabel (i+1):= bustabel (i);
bustabel1(i+1):= bustabel1(i);
end;
sidstebus:= sidstebus+1;
bustabel (plads):= bus;
bustabel1(plads):= sig shift 16 + gar shift 8 + omr;
indsæt:= true;
end
else
indsæt:= false;
end;
procedure udtag(plads);
value plads;
integer plads;
begin
integer i;
for i:= plads+1 step 1 until sidstebus do
begin
bustabel (i-1):= bustabel(i);
bustabel1(i-1):= bustabel1(i);
end;
i:= sidstebus;
sidstebus:= i-1;
bustabel(i):= bustabel1(i):= 0;
end;
procedure skrivtabel(z,i1,i2,gar,omr,navne);
value i1,i2,gar,omr,navne;
integer i1,i2,gar,omr;
boolean navne;
zone z;
begin
integer a,i,j,s,g,o;
a:= 0;
for i:= i1 step 1 until i2 do
begin
s:= bustabel1(i) shift (-16);
g:= bustabel1(i) shift (-8) extract 8;
o:= bustabel1(i) extract 8;
if (gar=0 or gar=g) and (omr=0 or omr=o) then
begin
j:= write(z,<<dddd>,bustabel(i));
if s>0 then j:= j+write(z,"!",1);
if g>0 then j:= j+(if navne then write(z,"/",1,string garagenavn(g))
else write(z,"/",1,<<d>,g));
if o>0 then j:= j+(if navne then write(z,";",1,string områdenavn(o))
else write(z,";",1,<<d>,o));
a:= a+1;
if a mod 5 = 0 then
write(z,"nl",1)
else
write(z," ",16-j);
end;
end;
if a = 0 or a mod 5 <> 0 then write(z,"nl",1);
end;
integer procedure søgbus(bus,omr,indeks,i1,i2);
value bus,omr;
integer bus,omr,indeks,i1,i2;
begin
integer i,j,nr;
j:= binærsøg(sidstebus, (bustabel(i) - bus), i);
nr:= -1;
if j=0 then
begin
i1:= i2:= i;
while i1>1 and bustabel(i1-1)=bus do i1:= i1 - 1;
while i2<sidstebus and bustabel(i2+1)=bus do i2:= i2 + 1;
if i1<>i2 then
begin
nr:= if omr<>0 then -1 else -2;
for i:= i1 step 1 until i2 do
if bustabel1(i) extract 8 = omr then nr:= i;
if nr > 0 then i:= nr else i:= i1;
end
else
begin
if omr=bustabel1(i) extract 8 then
nr:= i
else
if omr=0 then
nr:= 0
else
nr:= -1;
end;
end
else
begin
if j < 0 then i:= i + 1;
i1:= i; i2:= i-1;
end;
søgbus:= nr;
indeks:= i;
end;
isotable(alfa);
for i:= 'a' step 1 until 'å' do
alfa(i):= 6 shift 12 + (i - 'a' + 'A');
intable(alfa);
for i:= 1 step 1 until max_antal_områder do
områdenavn(i):= long(case i of (
<::>,<::>,<:KBH:>,<:RO:>,<:FS:>,<:HHL:>,<:GLX:>,
<:KJ:>,<:HI:>,<:HG:>,<:BA:>));
garagenavn(0):= long<::>;
open(z,4,<:bplnavne:>,0);
inrec6(z,512);
tofrom(garagenavn,z,508);
close(z,true);
for i:= 1 step 1 until max_antal_garager do
garagenavn(i):= garagenavn(i) shift (-8) shift 8;
if testbit(0) then
begin
write(out,<:GARAGER::>,"nl",1);
for i:= 1 step 1 until max_antal_garager do
if garagenavn(i)<>long<::> then
write(out,<<ddd>,i,<:: :>,string garagenavn(i),"nl",1);
write(out,"nl",1,<:OMRÅDER::>,"nl",1);
for i:= 1 step 1 until max_antal_områder do
if områdenavn(i)<>long<::> then
write(out,<<ddd>,i,<:: :>,string områdenavn(i),"nl",1);
end;
for i:= 0 step 1 until max_antal_busser do
bustabel(i):= bustabel1(i):= 0;
iaf:= 0;
write(out,"+",15,<: rettelse af busnummertabel :>,"+",15,"nl",2,
<:vent på '>':>,"nl",2);
ud(out);
open(z,4,<:busnumre:>,0);
sidstebus:= 0;
while read(z,b) > 0 do
begin
repeatchar(z);
s:= g:= o:= 0;
readchar(z,ch);
if ch='!' then
begin
s:= 1;
readchar(z,ch);
end;
if ch='/' then
begin
readchar(z,ch); repeatchar(z);
if '0'<=ch and ch<='9' then
begin
read(z,g);
if g<1 or g>max_antal_garager then g:= 0;
end
else
begin
readstring(z,n,1);
g:= findnavn(n(1),garagenavn);
end;
repeatchar(z);
readchar(z,ch);
end;
if ch=';' then
begin
readchar(z,ch); repeatchar(z);
if '0'<=ch and ch<='9' then
begin
read(z,o);
if o<1 or o>max_antal_områder then o:= 0;
if o>0 and områdenavn(o)=long<::> then o:= 0;
end
else
begin
readstring(z,n,1);
if n(1)=long<:TCT:> then n(1):=long<:KBH:>;
o:= findnavn(n(1),områdenavn);
end;
repeatchar(z);
readchar(z,ch);
end;
if -, indsæt(sidstebus+1,b,s,g,o) then
begin
close(z,true);
write(out,<:*** for mange busser i tabellen (max. :>,
<<d>,max_antal_busser,<:)<'nl'>:>);
goto finis;
end;
end;
setposition(z,0,0);
næste_kommando:
outchar(out,'>'); ud(out);
readchar(in,akt);
if akt='F' then
begin
skrivtabel(z,1,sidstebus,0,0,false);
outchar(z,'em');
monitorcall(42,z,0,tail,1);
systime(7,0,t);
tail(6):= round(t);
tail(10):= sidstebus;
monitorcall(44,z,0,tail,1);
write(out,<:<'nl'>busnumre ialt::>,sidstebus,"nl",1); ud(out);
close(z,true);
goto finis;
end
else
if akt='Q' then
begin
close(z,true);
write(out,<:<'nl'>busnummertabel ikke rettet, busnumre ialt::>,
sidstebus,"nl",1); ud(out);
goto finis;
end
else
if akt='I' or akt='U' or akt='V' then
begin
b1:= b2:= g:= o:= s:= 0;
for i:= readchar(in,ch) while i<>2 and i<>8 do;
if i<>2 then
begin
write(out,<:*** formatfejl (busnr-1)<'nl'>:>); ud(out);
goto skip;
end;
b1:= 0;
repeat
b1:= b1*10 + ch - '0';
i:= readchar(in,ch);
until i<>2;
while ch=' ' or ch=',' do i:= readchar(in,ch);
if i<>2 then
b2:= b1
else
begin
b2:= 0;
repeat
b2:= b2*10 + ch - '0';
i:= readchar(in,ch);
until i<>2;
end;
if b1>b2 or b1<1 or b1>9999 or b2<1 or b2>9999 then
begin
write(out,<:*** formatfejl (busnr-2)<'nl'>:>); ud(out);
goto skip;
end;
if ch='/' then
begin
i:= readchar(in,ch);
n(1):= n(2):= extend(0); j:= 1;
repeat
if j<=5 then skrivtegn(n.iaf,j,ch);
i:= readchar(in,ch);
until i<>6 and i<>2;
g:= findnavn(n(1),garagenavn);
if g=0 then
begin
write(out,<:*** ukendt garage: :>,string n(1),"nl",1); ud(out);
goto skip;
end;
end;
if ch=';' then
begin
i:= readchar(in,ch);
n(1):= extend(0); j:= 1;
repeat
if j<=5 then skrivtegn(n.iaf,j,ch);
i:= readchar(in,ch);
until i<>6 and i<>2;
o:= findnavn(n(1),områdenavn);
if o=0 then
begin
write(out,<:*** ukendt område: :>,string n(1),"nl",1); ud(out);
goto skip;
end;
end;
if ch='!' then
begin
s:= 1;
while i=7 do i:= readchar(in,ch);
end;
if i<>8 then
begin
write(out,<:*** formatfejl<'nl'>:>); ud(out);
goto skip;
end;
if akt='V' then
begin
j:= søgbus(b1,o,nr,i1,i2);
b1:= i1;
j:= søgbus(b2,o,nr,i1,i2);
b2:= i2;
skrivtabel(out,b1,b2,g,o,true);
end
else
begin
for b:= b1 step 1 until b2 do
begin
j:= søgbus(b,o,nr,i1,i2);
if (j=-2) or (j=0 and akt='I') then
write(out,<:*** bus: :>,<<d>,b,<: findes i andre områder, :>,
<:område skal anføres<'nl'>:>)
else
if j>0 and akt='I' then
begin
write(out,<:*** bus: :>,<<d>,b,<: findes allerede: :>);
skrivtabel(out,nr,nr,0,0,true);
end
else
if j=-1 and akt='U' then
begin
if b1=b2 then
write(out,<:*** bus: :>,<<d>,b,<: findes ikke<'nl'>:>);
end
else
if akt='I' then
begin
if -, indsæt(nr,b,s,g,o) then
begin
write(out,<:*** tabel fuld<'nl'>:>);
goto skip;
end;
end
else
udtag(nr);
end;
end;
end
else
begin
write(out,<:*** ukendt kommando<'nl'>:>);
goto skip;
end;
skip:
repeatchar(in);
for i:= readchar(in,ch) while i<>8 do ;
goto næste_kommando;
finis:
end;
trapmode:= 1 shift 10;
write(out,<:<10>rettelse af busnumre slut.<10>:>);
end
▶EOF◀