|
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 - download
Length: 15360 (0x3c00)
Types: TextFile
Names: »REGN5.PAS«
└─⟦5c8344fa1⟧ Bits:30004223 REGN version 2.1 til ICL Comet
└─ ⟦this⟧ »REGN5.PAS«
(* INCLUDE FILE REGN5.PAS *)
(* The first function is only for COMET. It tests the pressence of
file REGN.000 on the ramdrive *)
FUNCTION RAMDREVTEST:boolean; (* Only for COMET *)
var
ovnavn:stringÆ11Å;
fcb:arrayÆ1..36Å of byte;
dma:stringÆ128Å;
a:byte;
begin
ovnavn:='REGN 000';
dma:='';
for a:=1 to 128 do dma:=dma+' ';
bdos(26,addr(dma)+1); (* SET DMA-ADRESS *)
for a:=1 to 36 do fcbÆaÅ:=0;
fcbÆ1Å:=4; (* Search on drive D: *)
for a:=2 to 12 do fcbÆaÅ:=ord(ovnavnÆa-1Å);
a:=bdosb(17,addr(fcb)); (* SEARCH FIRST *)
RAMDREVTEST:=(a<>255);
end;
æ the following procedures up to COMMANDS are suitable for overlays å
OVERLAY PROCEDURE FORMAT;
var
j,k,nyfw,nydec,maxcif,maxdec,maxbredde,fromline,toline,naboer:integer;
renset:boolean;
tal:stringÆ2Å;
icount:sheetindex;
begin
maxcif:=33;nydec:=2;nyfw:=normwidth;fromline:=fy;toline:=fy;
if maxtegn+2-xposÆfxÅ>maxcif then
maxbredde:=maxcif
else
maxbredde:=maxtegn+2-xposÆfxÅ;
maxdec:=maxbredde-3;
if maxdec>11 then maxdec:=11;
str(maxdec,tal);
MSG(' FORMAT: Angiv antal decimaler (max. '+tal+'): ');
GETINT(43,nydec,-1,maxdec);
str(maxbredde,tal);
MSG(' Angiv cellebredde. (max. '+tal+'): ');
GETINT(32,nyfw,1,maxbredde);
MSG(' Fra søjle '+fx+' linje: ');
GETINT(20,fromline,1,fymax);
MSG(' Til søjle '+fx+' linje: ');
GETINT(20,toline,1,fymax);
if fromline>toline then begin
naboer:=fromline;
fromline:=toline;
toline:=naboer;
end;
if nyfw>11 then
if nyfw>22 then
naboer:=2
else
naboer:=1
else
naboer:=0;
for j:=fromline to toline do begin
sheetÆfx,jÅ.dec:=nydec;
sheetÆfx,jÅ.fw:=nyfw;
icount:=fx;
if sheetÆicount,jÅ.cellstatus*Æoverwritten,lockedÅ=ÆÅ then begin
for k:=1 to naboer do begin
icount:=succ(icount);
with sheetÆicount,jÅ do begin
cellstatus:=Ælocked,txtÅ;
contents:='';
end;
end;
renset:=false;
while (icount<fxmax) and not renset do begin
icount:=succ(icount);
with sheetÆicount,jÅ do
if cellstatus*Ælocked,overwrittenÅ<>ÆÅ then
RYDCELLE(icount,j,true)
else
renset:=true;
end;
end;
end;
UPDATE;
GOTOCELL(fx,fy);
end;
OVERLAY PROCEDURE NULSTIL;
var
a:sheetindex;
b:byte;
begin
for b:=1 to fymax do
for a:='A' to fxmax do
with sheetÆa,bÅ do
if formula in cellstatus then begin
value:=0;
cellstatus:=cellstatus-ÆonscreenÅ;
LEAVECELL(a,b);
end;
end;
OVERLAY PROCEDURE REPETER;
var
rcount,rtop:integer;
afbrudt,synlig:boolean;
begin
MSG(' REPETER: Hvor mange gange skal arket omregnes? ');
GETINT(48,rtop,1,30000);
MSG(' REPETER: Synlig opdatering? J/N ');
repeat
ch:=UPCASE(KEY);
until ch in Æ'J','N'Å;
synlig:=(ch='J');
gotoxy(27,23);
if synlig then
write(': JA ')
else
write(': NEJ ');
rcount:=0;afbrudt:=false;
FLASH(13,' Repeter: af ',false);
gotoxy(31,22);write(rvson,rtop,rvsoff);
FLASH(37,' Afbryd repetition = ESC ',false);
repeteret:=true; æ To make shure, that the cells get updated å
while (rcount<rtop-1) and not afbrudt do begin
rcount:=rcount+1;
gotoxy(22,22);write(rvson,rcount:5,rvsoff);
RECALCULATE(synlig);
if keypress then if KEY=esc then afbrudt:=true;
end;
RECALCULATE(true);
repeteret:=false;
FJERNFLASH(13,23);
end;
OVERLAY PROCEDURE HELP(upd:boolean);
var
i,j,fejl: integer;
escaped:boolean;
begin
MSG('Et øjeblik ....... Vejledning hentes ...');
if EXIST('REGN.HLP') then begin
escaped:=false;
assign(tekstfil,'REGN.HLP');
reset(tekstfil);
while not eof(tekstfil) do begin
write(clrhom); i:=1; write(rvsoff);
readln(tekstfil,eline);
repeat
writeln(eline);
i:=i+1;
readln(tekstfil,eline);
until eof(tekstfil) or (i>23) or (copy(eline,1,3)='.PA');
gotoxy(24,23); write(rvson);
write(' <<<< TRYK PÅ EN TAST >>>> ');
write(rvsoff);
ch:=KEY;
escaped:=(ch=esc);
end;
(*$I-*)
close(tekstfil);
fejl:=iores;
(*$I+*)
if upd then UPDATE;
end else begin æ help file did not EXIST å
MSG(bell+'For at få hjælp skal REGN.HLP være på diketten - TAST <RETURN>');
repeat
ch:=KEY;
until ch=return;
end;
end;
OVERLAY PROCEDURE KOPIER;
var
maxbredde,j,naboer:byte;
renset:boolean;
icount:sheetindex;
nucell,num:stringÆ3Å;
begin
gotoxy(0,23);write(clreol,'KOPIER CELLE: ',kopierfra,' FRA eller TIL? F/T ');
repeat
ch:=UPCASE(KEY);
until ch in Æ'F','T'Å;
if ch='F' then begin
str(fy,num);
kopierfra:=fx+num;
formelbuffer:=sheetÆfx,fyÅ;
end else begin
if kopierfra='' then begin
MSG(bell+'UMULIGT - INGEN CELLE AT KOPIERE - TRYK EN TAST ');
sv:=KEY;
end else begin
maxbredde:=maxtegn+2-xposÆfxÅ;
if (formelbuffer.fw>maxbredde) or
((formelbuffer.cellstatus=ÆtxtÅ) and (len(formelbuffer.contents)>maxbredde)) then begin
MSG(bell+'UMULIGT - IKKE PLADS!! - TRYK EN TAST ');
sv:=KEY;
end else begin
sheetÆfx,fyÅ:=formelbuffer;
gotoxy(xposÆfxÅ,fy);
write(' ');
if formelbuffer.fw>11 then
if formelbuffer.fw>22 then
naboer:=2
else
naboer:=1
else
naboer:=0;
icount:=fx;
for j:=1 to naboer do begin
icount:=succ(icount);
with sheetÆicount,fyÅ do begin
gotoxy(xposÆicountÅ,fy);
write(' ');
cellstatus:=Ælocked,txtÅ;
contents:='';
end;
end;
renset:=false;
while (icount<fxmax) and not renset do begin
icount:=succ(icount);
nucell:=icount;
with sheetÆicount,fyÅ do
if cellstatus*Ælocked,overwrittenÅ<>ÆÅ then begin
gotoxy(xposÆicountÅ,fy);
write(' ');
RYDCELLE(icount,fy,true);
end else
renset:=true;
end;
if ((formelbuffer.cellstatus=ÆtxtÅ) and (len(formelbuffer.contents)>11)) then begin
naboer:=((len(formelbuffer.contents)-1) div 11);
icount:=fx;
for j:=1 to naboer do begin
icount:=succ(icount);
with sheetÆicount,fyÅ do begin
gotoxy(xposÆicountÅ,fy);
write(' ');
cellstatus:=Ætxt,overwrittenÅ;
contents:='';
end;
end;
end;
for icount:=fx to fxmax do LEAVECELL(icount,fy);
end;
end;
end;
end;
OVERLAY PROCEDURE LINEMOVE;
var
ccount:sheetindex;
lcount:integer;
begin
FORTRYDTEKST;
MSG('Indsæt linje - Slet linje I/S ');
repeat
ch:=UPCASE(KEY);
until ch in Æ'I','S',escÅ;
if ch<>esc then begin
if ch='I' then begin
for lcount:=fymax downto fy do
if lcount>1 then
for ccount:='A' to fxmax do
sheetÆccount,lcountÅ:=sheetÆccount,lcount-1Å;
for ccount:='A' to fxmax do
with sheetÆccount,fyÅ do begin
cellstatus:=ÆtxtÅ;contents:='';value:=0;dec:=2;fw:=normwidth;
end;
end else begin
for lcount:=fy to fymax-1 do
for ccount:='A' to fxmax do
sheetÆccount,lcountÅ:=sheetÆccount,lcount+1Å;
for ccount:='A' to fxmax do
with sheetÆccount,fymaxÅ do begin
cellstatus:=ÆtxtÅ;contents:='';value:=0;dec:=2;fw:=normwidth;
end;
end;
UPDATE;
MSG('Evt. formler kan refere forkerte celler nu! - Tryk en tast ');
ch:=KEY;
end;
FJERNFLASH(37,25);
end;
OVERLAY PROCEDURE WELLCOME;
PROCEDURE CENTRER(s: anystring;rvs:boolean);
var
i:byte;
begin
for i:=1 to (79-len(s)+2) div 2 do write(' ');
if rvs then write(rvson);
writeln(' ',s,' ');
if rvs then write(rvsoff);
end;
begin æ WELLCOME å
write(clrhom);
CENTRER('Et PRO''85 program',false);
gotoxy(0,2);
CENTRER(' REGN ',true);
CENTRER('Et simpelt regneark',true);
gotoxy(0,5);
CENTRER('Den officielle version',false);
CENTRER('Fremstillet for Landscentralen for Undervisningsmidler',false);
writeln;
CENTRER('af',false);
writeln;
CENTRER('Jørgen H. Christiansen',false);
CENTRER('Hans Jørgen Jensen',false);
CENTRER('Leif Kragh',false);
CENTRER('Bent Lerche',false);
CENTRER('Arne Mogensen',false);
æ
CENTRER('Ændret af:',false);
å
gotoxy(0,17);
CENTRER('Vers. nr. '+vers,false);
writeln;
writeln;
writeln;
CENTRER(' Tryk en tast ',true);
gotoxy(40,23);
ch:=KEY;
end;
OVERLAY PROCEDURE SAVE;
var
udisk:char;
i: sheetindex;
j,fejl: integer;
overskriv:boolean;
begin
udisk:=DISKVALG;
if udisk<>esc then begin
DISKDIR(udisk,'????????ARK',false,'GEMTE ARK');
repeat
filename:='';
MSG(' GEM: Angiv arknavn: ');
GETFILENAME(23,filename,'ARK');
if (filename<>'') then begin
RESETDISK;
ro:=false;
overskriv:=EXIST(udisk+':'+filename);
if ro then begin
MSG(bell+'ARKET: '+filename+' Disk eller fil skrivebeskyttet - Tryk en tast ');
ch:=KEY;
filename:='';
end else begin
if overskriv then begin
MSG(bell+'ARKET: '+filename+' findes allerede! - Skal det overskrives? J/N ');
repeat
ch:=UPCASE(KEY);
until ch in Æ'J','N'Å;
write(ch);
if ch='N' then
filename:=''
else begin
assign(mcfile,udisk+':'+filename);
erase(mcfile);
end;
end else
overskriv:=true;
end;
end;
until (filename='') or overskriv;
if filename<>'' then begin
MSG(' Et øjeblik... - Ark: '+filename+' gemmes ');
assign(mcfile,udisk+':'+filename);
(*$I-*)
rewrite(mcfile);
fejl:=iores;
if fejl=0 then
for i:='A' to fxmax do begin
j:=1;
while (j<=fymax) and (fejl=0) do begin
write(mcfile,sheetÆi,jÅ);
fejl:=iores;
j:=j+1;
end;
end;
if fejl=0 then begin
close(mcfile);
fejl:=iores;
end;
(*$I+*)
if fejl>0 then begin
MSG(bell+' FEJL VED SKRIVNING: '+errmessageÆfejlÅ+' - TRYK EN TAST ');
ch:=KEY;
end;
end;
UPDATE;
end else
GOTOCELL(fx,fy);
end;
OVERLAY PROCEDURE LOAD;
var
udisk:char;
fejl:integer;
begin
udisk:=DISKVALG;
if udisk<>esc then begin
DISKDIR(udisk,'????????ARK',false,'GEMTE ARK');
MSG(' HENT: Angiv arknavn: ');
GETFILENAME(24,filename,'ARK');
if (filename<>'') then begin
ro:=false;
if (not EXIST(udisk+':'+filename)) then
repeat
MSG(bell+' Intet ark: '+filename+'! - Skriv et andet arknavn: ');
filename:='';
GETFILENAME(52,filename,'ARK');
ro:=false;
until EXIST(udisk+':'+filename) or (filename='');
end;
if filename<>'' then
if ro then begin
MSG(bell+'Filen er beskyttet - kan ikke læses - Tryk en tast ');
ch:=KEY;
filename:='';
end;
if filename<>'' then begin
MSG(' Et øjeblik... - Ark: '+filename+' hentes ');
(*$I-*)
assign(mcfile,udisk+':'+filename);
reset(mcfile);
fejl:=iores;
if fejl=0 then begin
for fx:='A' to fxmax do begin
fy:=1;
while (fy<=fymax) and (fejl=0) do begin
read(mcfile,sheetÆfx,fyÅ);
fejl:=iores;
fy:=fy+1;
end;
end;
end;
close(mcfile);
fejl:=iores;
(*$I+*)
if fejl>0 then begin
MSG(bell+' FEJL VED LÆSNING: '+errmessageÆfejlÅ+' - TRYK EN TAST ');
ch:=KEY;
end else
kopierfra:='OLD';
fx:='A'; fy:=1;
end;
UPDATE;
end else begin
UPDATE;
GOTOCELL(fx,fy);
end;
end;
OVERLAY PROCEDURE PRINT;
var
udisk:char;
spoolok,printer,overskriv:boolean;
i:sheetindex;
j,count,fejl,
leftmargin: integer;
spoolname:stringÆ20Å;
p:stringÆ33Å;
begin
FORTRYDTEKST;
MSG(' UDSKRIFT: På Printer eller Diskette? P/D ');
repeat
ch:=UPCASE(KEY);
until ch in Æ'P','D',escÅ;
if ch=esc then
udisk:=esc
else
write(ch);
printer:=(ch<>'D');
if not printer then udisk:=DISKVALG;
if udisk<>esc then begin
leftmargin:=1;
if not printer then begin
DISKDIR(udisk,'????????LST',false,'SKREVNE ARK');
repeat
filename:='';
MSG(' UDSKRIFT: Angiv arknavn: ');
GETFILENAME(27,filename,'LST');
if (filename<>'') then begin
RESETDISK;
ro:=false;
overskriv:=EXIST(udisk+':'+filename);
if ro then begin
MSG(bell+'ARKET: '+filename+' Disk eller fil skrivebeskyttet - Tryk en tast ');
ch:=KEY;
filename:='';
end else begin
if overskriv then begin
MSG(bell+'ARKET: '+filename+' findes allerede! - Skal det overskrives? J/N ');
repeat
ch:=UPCASE(KEY);
until ch in Æ'J','N'Å;
write(ch);
if ch='N' then
filename:=''
else begin
assign(tekstfil,udisk+':'+filename);
erase(tekstfil);
end;
end else
overskriv:=true;
end;
end;
until (filename='') or overskriv;
end;
if (filename<>'') or printer then begin
if printer then begin
if multi then begin
FJERNFLASH(37,25);
repeat
spoolok:=false;
MSG('ANGIV SPOOL-DEVICE: (Return for: B:PRN1) ');
read(spoolname);
buflen:=6;
if len(spoolname)=6 then
if (spoolnameÆ2Å=':') then spoolok:=true;
until (spoolname='') or spoolok;
if spoolname='' then spoolname:='B:PRN1';
spoolname:=spoolname+'.'+chr(65+random(25))+chr(65+random(25))+chr(65+random(25));
end else
filename:='LST:';
end else
filename:=udisk+':'+filename;
if printer and multi then begin
MSG(' Udskrift på : ' + spoolname + '....');
assign(tekstfil,spoolname);
end else begin
MSG(' Udskrift på : ' + filename + '....');
assign(tekstfil,filename);
end;
(*$I-*)
rewrite(tekstfil);
fejl:=iores;
if fejl=0 then begin
if printer then begin
count:=1;
while (count<=5) and (fejl=0) do begin
count:=count+1;
writeln(tekstfil);
fejl:=iores;
end;
end;
j:=1;
while (j<=fymax) and (fejl=0) do begin
eline:='';
i:='A';
for i:='A' to fxmax do begin
with sheetÆi,jÅ do begin
while (len(eline)-leftmargin<xposÆiÅ-3) do eline:=eline+' ';
if (constant in cellstatus) or (formula in cellstatus) then begin
if not (locked in cellstatus) then begin
if dec>=0 then str(value:fw:dec,p) else str(value:fw,p);
if (onscreen in cellstatus) or not (formula in cellstatus) then
eline:=eline+p
else
eline:=eline+copy(tom,1,fw);
end;
end else
eline:=eline+contents;
end; æ width å
end; æ one line å
for count:=1 to leftmargin do write(tekstfil,' ');
writeln(tekstfil,eline);
fejl:=iores;
j:=j+1;
end; æ end column å
if fejl=0 then
if printer then begin
write(tekstfil,@12);
close(tekstfil);
end else begin
close(tekstfil);
fejl:=iores;
end;
end;
(*$I+*)
if fejl>0 then begin
MSG(bell+' FEJL VED SKRIVNING: '+errmessageÆfejlÅ+' - TRYK EN TAST ');
ch:=KEY;
end;
end;
UPDATE;
end else
GOTOCELL(fx,fy);
end;
æ The procedures above are suitable for overlayes å
«eof»