|
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: 18048 (0x4680)
Types: TextFile
Names: »REGN4.PAS«
└─⟦fff6648c2⟧ Bits:30004194/disk3.imd Data i Folkeskolen (Comet)
└─⟦this⟧ »REGN4.PAS«
(* REGN4.PAS INCLUDE FILE *)
æ* purpose: read the contents of a cell and UPDATE associated cells *å
PROCEDURE GETLINE(var s: anystring; æ string to edit å
colno,lineno, æ where start line å
max, æ max length å
errpos: integer; æ where to begin å
uppercase:boolean); æ true if auto UPCASE å
var
apos,x: integer;
inserton: boolean;
okchars: set of char;
PROCEDURE GOTOX;
begin
gotoxy(x+colno-2,lineno-1);
end;
begin
okchars:=Æ' '..'å'Å;
inserton:=false;
x:=1; GOTOX;
write(ulnon,s);
if len(s)=1 then x:=2;
if errpos<>0 then x:=errpos;
GOTOX;
repeat
ch:=KEY;
if uppercase then ch:=UPCASE(ch);
case ch of
esc: begin
s:=chr($FF); æ abort editing å
ch:=return;
end;
hoejre: begin æ move cursor right å
x:=x+1;
if (x>len(s)+1) or (x>max) then x:=x-1;
GOTOX;
end;
del: begin æ delete right char å
if x<=len(s) then begin
delete(s,x,1);
write(copy(s,x,len(s)-x+1),ulnoff,' ',ulnon);
GOTOX;
end;
end;
ins: begin æ insert char å
insert(' ',s,x);
if len(s)>max then s:=copy(s,1,max);
write(copy(s,x,len(s)-x+1));
GOTOX;
end;
venstre: begin æ move cursor left å
x:=x-1;
if x<1 then x:=1;
GOTOX;
end;
htab: begin æ move cursor to end of line å
x:=len(s)+1;
GOTOX;
end;
vtab: begin æ move cursor to beginning of line å
x:=1;
GOTOX;
end;
delleft: begin æ delete left char å
x:=x-1;
if (len(s)>0) and (x>0) then begin
delete(s,x,1);
GOTOX;
write(copy(s,x,len(s)-x+1),ulnoff,' ',ulnon);
GOTOX;
if x<1 then x:=1;
end else
x:=1;
end;
^V: inserton:= not inserton;
otherwise
begin
if ch in okchars then begin
if inserton then begin
insert(ch,s,x);
write(copy(s,x,len(s)-x+1),' ');
end else begin
write(ch);
if x>len(s) then
s:=s+ch
else
sÆxÅ:=ch;
end;
x:=x+1;
if (x>len(s)+1) or (x>max) then x:=x-1;
GOTOX;
end;
end;
end;
until ch=return;
write(ulnoff);
end;
PROCEDURE GETCELL(fx: sheetindex;fy: integer);
var
newstat: set of attributes;
errorposition: integer;
i: sheetindex;
result: real;
abort: boolean;
isform: boolean;
æ CLEARCELLS clears the current cell and its associated å
æ cells. an associated cell is a cell overwritten by data from the å
æ current cell. the data can be text in which case the cell has the å
æ attribute "overwritten". if the data is a result from an expressionå
æ and the field with is larger than normwidth then the cell is "locked" å
PROCEDURE CLEARCELLS;
var
renset:boolean;
begin
i:=fx;renset:=false;
while (i<fxmax) and not renset do begin
gotoxy(xposÆiÅ,fy);
write(' ');
i:=succ(i);
if (Æoverwritten,lockedÅ*sheetÆi,fyÅ.cellstatus=ÆÅ) then renset:=true;
end;
æ cell is not overwritten not locked å
end;
PROCEDURE GETFORMULA;
begin
repeat
GETLINE(eline,1,24,maxtegn,errorposition,true);
if eline<>chr($FF) then begin
newstat:=newstat-ÆonscreenÅ;
beregnet:=true;
upfx:=fx;upfy:=fy;
EVALUATE(isform,eline,result,errorposition);
if errorposition<>0 then
FLASH(13,' Fejl ved cursor '+@7,false)
else
FJERNFLASH(13,23);
end;
until (errorposition=0) or (eline=chr($FF));
if isform then newstat:=newstat+ÆformulaÅ;
if beregnet then newstat:=newstat+ÆonscreenÅ;
end;
æ GETTEXT calls the procedure GETLINE with the current å
æ cells x,y position as parameters. this means that text entering å
æ takes place direcly at the cells position on the sheet. å
PROCEDURE GETTEXT;
begin
with sheetÆfx,fyÅ do GETLINE(eline,xposÆfxÅ+1,fy+1,maxtegn+2-xposÆfxÅ,errorposition,false);
end;
æ EDITCELL loads a copy of the current cells contents in å
æ in the variable eline before calling either GETTEXT or GETFORMULA. å
æ In this way no changes are made to the current cell. å
PROCEDURE EDITCELL;
begin
with sheetÆfx,fyÅ do begin
eline:=contents;
if txt in cellstatus then GETTEXT else GETFORMULA;
end;
end;
æ UPDATECELLS is a little more complicated. basically it å
æ makes sure to tag and untag cells which has been overwritten or å
æ cleared from data from another cell. It also UPDATEs the current å
æ width, the new type and the contents which still is in the å
æ temporarly variable "eline". å
PROCEDURE UPDATECELLS;
var
flength: integer;
opdateret:boolean;
begin
sheetÆfx,fyÅ.contents:=eline;
if txt in newstat æsheetÆfx,fyÅ.cellstatuså then begin
i:=fx;
flength:=len(eline);
opdateret:=false;
repeat
if i<fxmax then begin
i:=succ(i);
with sheetÆi,fyÅ do begin
flength:=flength-normwidth;
if (flength>0) then begin
cellstatus:=Æoverwritten,txtÅ;
contents:='';
end else begin
if overwritten in cellstatus then begin
cellstatus:=ÆtxtÅ;
GOTOCELL(i,fy);LEAVECELL(i,fy);
end;
end;
end;
end;
until (i=fxmax) or (sheetÆi,fyÅ.contents<>'');
sheetÆfx,fyÅ.cellstatus:=ÆtxtÅ;
end else begin æ string changed to formula or constant å
æ event number two å
i:=fx;
repeat
with sheetÆi,fyÅ do begin
if overwritten in cellstatus then begin
cellstatus:=ÆtxtÅ;
contents:='';
end;
if i<fxmax then i:=succ(i);
end;
until not (overwritten in sheetÆi,fyÅ.cellstatus) or (i=fxmax);
with sheetÆfx,fyÅ do begin
cellstatus:=ÆconstantÅ;
if isform then cellstatus:=cellstatus+ÆformulaÅ;
value:=result;
end;
end;
end;
æ GETCELL finnaly starts here. this procedure uses all å
æ all the above local procedures. first it initializes the temporaly å
æ variable "eline" with the last read character. it then depending on å
æ this character calls GETFORMULA, GETTEXT, or EDITCELL. å
begin æ GETCELL å
eline:=ch; errorposition:=0; abort:=false;
newstat:=ÆÅ;
if ch in Æ'0'..'9','+','-','.','(',')'Å then begin
if ch ='(' then
SKIFTTYPE(2)
else
SKIFTTYPE(1);
newstat:=ÆconstantÅ;
if not (formula in sheetÆfx,fyÅ.cellstatus) then begin
gotoxy(10,23); write(clreol);
CLEARCELLS;
GETFORMULA;
end else begin
FLASH(13,@7+' Ret i formel J/N? ',true);
repeat
ch:=UPCASE(KEY);
until ch in Æ'J','N'Å;
FJERNFLASH(13,23);
if ch='J' then EDITCELL else abort:=true;
end;
end else begin
if ch=esc then begin
newstat:=(sheetÆfx,fyÅ.cellstatus)*Ætxt,constant,onscreenÅ;
EDITCELL;
end else begin
if formula in sheetÆfx,fyÅ.cellstatus then begin
FLASH(13,@7+' Ret i formel J/N? ',true);
repeat
ch:=UPCASE(KEY);
until ch in Æ'J','N'Å;
FJERNFLASH(13,23);
if ch='J' then EDITCELL else abort:=true;
end else begin
SKIFTTYPE(0);
newstat:=ÆtxtÅ;
CLEARCELLS;
GETTEXT;
end;
end;
end;
if not abort then begin
if eline<>chr($FF) then UPDATECELLS;
if onscreen in newstat then begin
sheetÆfx,fyÅ.cellstatus:=sheetÆfx,fyÅ.cellstatus+ÆonscreenÅ;
end;
GOTOCELL(fx,fy);
if autocalc and (constant in sheetÆfx,fyÅ.cellstatus) then RECALCULATE(true);
if txt in newstat then begin
gotoxy(2,fy);write(clreol);
for i:='A' to fxmax do LEAVECELL(i,fy);
end;
end;
FJERNFLASH(13,23);
GOTOCELL(fx,fy);
end;
PROCEDURE GETINT(xp:byte; var i: integer; max: integer);
var
err: integer;
ch: char;
begin
eline:='';
gotoxy(xp,23);
repeat
repeat
ch:=KEY;
until ch in Æ'0'..'9','-',return,venstreÅ;
if ch<>return then begin
if ch=venstre then begin
if len(eline)>0 then delete(eline,len(eline),1);
gotoxy(xp,23);write(clreol,eline);
end else begin
write(ch); eline:=eline+ch;
val(eline,i,err);
end;
end;
until (ch=return);
if i>max then i:=max;
end;
æ the following procedures up to COMMANDS are suitable for overlays å
æ if you are in need of more free memory å
PROCEDURE FORMAT;
var
j,fw,dec,maxcif,maxbredde,
fromline,toline,
bredde: integer;
lock: boolean;
tal: stringÆ2Å;
icount,slutfelt: sheetindex;
begin
maxcif:=33;dec:=normwidth;fw:=normwidth;fromline:=fy;toline:=fy;
str(normwidth,tal);
write(rvsoff);
MSG(' FORMAT: Angiv antal decimaler (max. '+tal+'): ');
GETINT(43,dec,normwidth);
if maxtegn+2-xposÆfxÅ>maxcif then
maxbredde:=maxcif
else
maxbredde:=maxtegn+2-xposÆfxÅ;
str(maxbredde,tal);
MSG(' Angiv cellebredde. (max. '+tal+'): ');
GETINT(32,fw,maxbredde);
MSG(' Fra søjle '+fx+' linje: ');
GETINT(20,fromline,fymax);
MSG(' Til søjle '+fx+' linje: ');
GETINT(20,toline,fymax);
if fromline>toline then begin
bredde:=fromline;
fromline:=toline;
toline:=bredde;
end;
if fw>normwidth then lock:=true else lock:=false;
bredde:=fw div normwidth;
if (fw mod normwidth>0) then bredde:=bredde+1;
slutfelt:=sheetindex(integer(fx)+bredde-1);
for j:=fromline to toline do begin
sheetÆfx,jÅ.dec:=dec;
sheetÆfx,jÅ.fw:=fw;
if fx<fxmax then begin
if lock then begin
for icount:=succ(fx) to slutfelt do begin
with sheetÆicount,jÅ do begin
cellstatus:=cellstatus+Ælocked,txtÅ;
contents:='';
end;
end;
if slutfelt<fxmax then begin
icount:=succ(slutfelt);
while (icount<=fxmax)
and (sheetÆicount,jÅ.cellstatus*ÆlockedÅ<>ÆÅ) do begin
with sheetÆicount,jÅ do begin
cellstatus:=cellstatus-ÆlockedÅ;
if fw>normwidth then fw:=normwidth;
end;
if icount<fxmax then icount:=succ(icount);
end;
end;
end else begin
icount:=succ(fx);
while (icount<=fxmax)
and (sheetÆicount,jÅ.cellstatus*ÆlockedÅ<>ÆÅ) do begin
with sheetÆicount,jÅ do
cellstatus:=cellstatus-ÆlockedÅ;
if icount<fxmax then icount:=succ(icount);
end;
end;
end;
end;
write(alloff);
UPDATE;
GOTOCELL(fx,fy);
end;
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;
PROCEDURE REPETER;
var
rcount,rtop:integer;
afbrudt,synlig:boolean;
begin
MSG(' REPETER: Hvor mange gange skal arket omregnes? ');
GETINT(48,rtop,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;
PROCEDURE HELP(upd:boolean);
var
helpfilename: str14;
i,j,fejl: integer;
begin
MSG('Et øjeblik ....... Vejledning hentes ...');
if EXIST('REGN.HLP') then begin
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;
end;
LUK(2,fejl);
if upd then UPDATE;
end else begin æ help file did not EXIST å
MSG(@7+'For at få hjælp skal REGN.HLP være på diketten - TAST <RETURN>');
repeat
ch:=KEY;
until ch=return;
end;
end;
PROCEDURE MENU;
var
ud:boolean;
begin
ud:=false;
repeat
write(clrhom);
gotoxy(21,2);
writeln(rvson,' R E G N ',rvsoff);
gotoxy(21,6);
writeln('STOP .............................. 0');
gotoxy(21,9);
writeln('START NYT REGNEARK ................. 1');
gotoxy(21,12);
writeln('HENT GAMMELT REGNEARK .............. 2');
gotoxy(21,15);
writeln('HENT VEJLEDNING .................... 3');
gotoxy(24,19);
write('TAST TALLET UD FOR DET ØNSKEDE ');
repeat
ch:=KEY;
until ch in Æ'0'..'3'Å;
case ch of
'0':begin
slut:=true;
ud:=true;
end;
'1':begin
ud:=true;
GRID;
end;
'2':begin
ud:=true;
write(clrhom);
LOAD;
end;
'3':begin
HELP(false);
end;
end;
until ud;
end;
PROCEDURE KOPIER;
var
fromx,tox:sheetindex;
fromy,toy:integer;
PROCEDURE GETCELLNO(var nux:sheetindex;var nuy:integer);
var
num:stringÆ3Å;
err:integer;
begin
buflen:=3;
CURSOR(true);
read(num);
CURSOR(false);
if ord(numÆ1Å)>96 then numÆ1Å:=chr(ord(numÆ1Å)-32);
if numÆ1Å in Æ'A'..fxmaxÅ then begin
nux:=numÆ1Å;
delete(num,1,1);
val(num,nuy,err);
if (err=0) then begin
if (nuy<1) or (nuy>fymax) then nuy:=0;
end else
nuy:=0;
end else
nuy:=0;
end;
begin
gotoxy(0,23);write(clreol,'KOPIER CELLE? ');
GETCELLNO(fromx,fromy);
if fromy>0 then begin
if not (formula in sheetÆfromx,fromyÅ.cellstatus) then begin
MSG('UMULIGT - INGEN FORMEL I CELLEN - TRYK EN TAST ');
sv:=KEY;
fromy:=0;
end;
if fromy>0 then begin
gotoxy(0,23);write(clreol,'OVER I CELLE? ');
GETCELLNO(tox,toy);
if fromy>0 then begin
sheetÆtox,toyÅ.cellstatus:=ÆformulaÅ;
sheetÆtox,toyÅ.contents:=sheetÆfromx,fromyÅ.contents;
sheetÆtox,toyÅ.value:=sheetÆfromx,fromyÅ.value;
sheetÆtox,toyÅ.dec:=sheetÆfromx,fromyÅ.dec;
sheetÆtox,toyÅ.fw:=sheetÆfromx,fromyÅ.fw;
end;
end;
end;
end;
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;
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,6);
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;
æ The procedures above are suitable for overlayes å
æ if you are in need of more free memory å
æ COMMANDS is activated from the main loop in this program å
æ when the user types a slash (/). å
PROCEDURE COMMANDS;
var
udlin:arrayÆ0..3Å of stringÆ63Å;
hlinnr:byte;
begin
hlinnr:=0;
udlinÆ0Å:='1: Tilbage Omregn Slut Hent Gem Udskrift ? ';
udlinÆ1Å:='2: Tilbage Nyt ark Formatændring Autoregn til/fra ? ';
udlinÆ2Å:='3: Tilbage Linje (slet/indsæt) Repeter omregning ? ';
udlinÆ3Å:='4: Tilbage 0-stil formelresultater Kopier formel ? ';
FLASH(37,' / for flere kommandoer ',false);
repeat
gotoxy(0,23);
write(clreol,'KOMMANDOER ');
HIGHLIGHTMSG(udlinÆhlinnrÅ);
ch:=UPCASE(KEY);
if ch='/' then hlinnr:=(hlinnr+1) mod 4;
until ch<>'/';
FJERNFLASH(37,25);
case ch of
'S': begin
write(rvsoff);
slut:=true;
end;
'F': FORMAT;
'G': SAVE;
'H': LOAD;
'?': HELP(true);
'O': RECALCULATE(true);
'A': AUTO;
'T': UPDATE;
'N': CLEAR;
'U': PRINT;
'0': NULSTIL;
'R': REPETER;
'K': KOPIER;
'L': LINEMOVE;
end;
FLASH(37,' Tast / for kommando ',false);
if not slut then GOTOCELL(fx,fy);
end;
«eof»