|
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: 13056 (0x3300)
Types: TextFile
Names: »REGN3.PAS«
└─⟦5c8344fa1⟧ Bits:30004223 REGN version 2.1 til ICL Comet
└─ ⟦this⟧ »REGN3.PAS«
(* REGN3.PAS INCLUDE FILE *)
var
dobbeltrelation,form: boolean;
sv,second:char;
(*$A-*)
PROCEDURE EVALUATE(var isformula: boolean; æ true if formula å
var formel: anystring; æ formula to evaluate å
var value: real; æ result of formula å
var errpos: integer); æ position of error å
const
numbers: set of char = Æ'0'..'9'Å;
eofline=return;
var
cpos: integer; æ current position in formula å
ch: char; æ current character being scanned å
exy: stringÆ3Å; æ intermidiate string for conversion å
æ NEXTCH returns the next character in the formula å
æ the variable cpos contains the position and ch the character å
PROCEDURE NEXTCH;
begin
repeat
cpos:=cpos+1;
if cpos<=len(formel) then
ch:=formelÆcposÅ
else
ch:=eofline;
until ch<>' ';
end æ NEXTCH å;
FUNCTION EXPRESSION: real;
var
e: real;
opr: char;
FUNCTION SIMPLEEXPRESSION: real;
var
s: real;
opr: char;
FUNCTION TERM: real;
var
t: real;
FUNCTION SIGNEDFACTOR: real;
FUNCTION FACTOR: real;
type
standardfunction=(FABS,FSQRT,FSQR,FSIN,FCOS,FRND,FARCTAN,FTAN,
FPI,FLN,FLOG,FEXP,FFACT,FROUND,FINT,FFRAC);
standardfunctionlist=arrayÆstandardfunctionÅ of stringÆ6Å;
const
standardfunctionnames:
standardfunctionlist=('ABS','SQRT','SQR','SIN','COS','RND','ARCTAN','TAN',
'PI','LN','LOG','EXP','FACT','ROUND','INT','FRAC');
var
e,ee,l: integer; æ intermidiate variables å
found:boolean;
f: real;
sf:standardfunction;
oldefy, æ current cell å
efy,
sumfy,
start:integer;
oldefx,
efx,
sumfx:sheetindex;
cellsum: real;
FUNCTION FACT(i: integer): real;
begin
if i > 0 then begin
FACT:=i*FACT(i-1);
end else
FACT:=1;
end;
begin æ function FACTOR å
if ch in numbers then begin
start:=cpos;
repeat NEXTCH until not (ch in numbers);
if ch='.' then repeat NEXTCH until not (ch in numbers);
if ch='E' then begin
NEXTCH;
repeat NEXTCH until not (ch in numbers);
end;
val(copy(formel,start,cpos-start),f,errpos);
end else
if ch='(' then begin
NEXTCH;
f:=EXPRESSION;
if ch=')' then
NEXTCH
else
errpos:=cpos;
end else (* Test for cell reference *)
if (ch in Æ'A'..fxmaxÅ) and
not (formelÆcpos+1Å in Æ'A'..'å'Å) then begin
efx:=ch;
NEXTCH;
if ch in numbers then begin
f:=0;
exy:=ch;
NEXTCH;
if ch in numbers then begin
exy:=exy+ch;
NEXTCH;
end;
val(exy,efy,errpos);
isformula:=true;
(* Can the formula be calculated? *)
(* or rather can then result be written on the screen? *)
if (txt in sheetÆefx,efyÅ.cellstatus) then begin
beregnet:=false;
end;
if not (((fx=efx) and (fy=efy)) or ((efx=upfx) and (efy=upfy))) then
if (formula in sheetÆefx,efyÅ.cellstatus) and
not (onscreen in sheetÆefx,efyÅ.cellstatus) then beregnet:=false;
if (constant in sheetÆefx,efyÅ.cellstatus) and
not (calculated in sheetÆefx,efyÅ.cellstatus) then begin
EVALUATE(form,sheetÆefx,efyÅ.contents,f,errpos);
sheetÆefx,efyÅ.cellstatus:=sheetÆefx,efyÅ.cellstatus+ÆcalculatedÅ;
end else
if not (txt in sheetÆefx,efyÅ.cellstatus) then begin
f:=sheetÆefx,efyÅ.value;
end else begin
beregnet:=false;
end;
if ch='&' then begin (* Sum of block *)
oldefx:=efx; oldefy:=efy;
NEXTCH;
efx:=ch;
NEXTCH;
if ch in numbers then begin
exy:=ch;
NEXTCH;
if ch in numbers then begin
exy:=exy+ch;
NEXTCH;
end;
val(exy,efy,errpos);
cellsum:=0;
for sumfy:=oldefy to efy do begin
for sumfx:=oldefx to efx do begin
f:=0;
if txt in sheetÆsumfx,sumfyÅ.cellstatus then begin
beregnet:=false;
end;
if not (((fx=sumfx) and (fy=sumfy)) or ((sumfx=upfx) and (sumfy=upfy))) then
if (formula in sheetÆsumfx,sumfyÅ.cellstatus) and
not (onscreen in sheetÆsumfx,sumfyÅ.cellstatus) then beregnet:=false;
if (constant in sheetÆsumfx,sumfyÅ.cellstatus) and
not (calculated in sheetÆsumfx,sumfyÅ.cellstatus) then begin
EVALUATE(form,sheetÆsumfx,sumfyÅ.contents,f,errpos);
sheetÆsumfx,sumfyÅ.cellstatus:=sheetÆsumfx,sumfyÅ.cellstatus+ÆcalculatedÅ;
end else
if not (txt in sheetÆsumfx,sumfyÅ.cellstatus) then begin
f:=sheetÆsumfx,sumfyÅ.value;
end else begin
beregnet:=false;
end;
cellsum:=cellsum+f;
f:=cellsum;
end;
end;
end;
end;
end;
end else begin
found:=false;
for sf:=fabs to ffrac do
if not found then begin
l:=len(standardfunctionnamesÆsfÅ);
if copy(formel,cpos,l)=standardfunctionnamesÆsfÅ then begin
cpos:=cpos+l-1;
NEXTCH;
f:=FACTOR;
case sf of
FABS: f:=abs(f);
FSQRT:begin
if f<0 then begin
f:=f;
beregnet:=false;
end else
f:=sqrt(f);
end;
FSQR: f:=sqr(f);
FSIN: f:=sin(f);
FCOS: f:=cos(f);
FARCTAN: f:=arctan(f);
FTAN:begin
if cos(f)=0 then begin
f:=f;
beregnet:=false;
end else
f:=sin(f)/cos(f);
end;
FPI: f:=pi;
FLN:begin
if f<0 then begin
f:=f;
beregnet:=false;
end else
f:=ln(f);
end;
FLOG:begin
if f<=0 then begin
f:=f;
beregnet:=false;
end else
f:=ln(f)/ln(10);
end;
FEXP: begin
if f>88 then begin
f:=f;
beregnet:=false;
end else
f:=exp(f);
end;
FFACT:begin
if f<0 then begin
f:=f;
beregnet:=false;
end else
f:=fact(trunc(f));
end;
FRND:begin
if f>maxint then begin
f:=f;
beregnet:=false;
end else
f:=random(round(abs(f)));
end;
FROUND:begin
if f>maxint then begin
f:=f;
beregnet:=false;
end else
f:=round(f);
end;
FINT:begin
if f>maxint then begin
f:=f;
beregnet:=false;
end else
f:=int(f);
end;
FFRAC: f:=frac(f);
end;
found:=true;
end;
end;
if not found then errpos:=cpos;
end;
FACTOR:=f;
end æ function FACTORå;
begin æ SIGNEDFACTOR å
if ch='-' then begin
NEXTCH;
SIGNEDFACTOR:=-FACTOR;
end else begin
if ch in Æ'>','='Å then begin
dobbeltrelation:=true;
second:=ch;
NEXTCH;
end else
dobbeltrelation:=false;
SIGNEDFACTOR:=FACTOR;
end;
end;
begin æ TERM å
t:=SIGNEDFACTOR;
while ch='^' do begin
NEXTCH;
if t<=0 then begin
t:=t;
beregnet:=false;
end else
t:=exp(ln(t)*SIGNEDFACTOR);
end;
TERM:=t;
end;
var
tmp:real;
begin æ SIMPLEEXPRESSION å
s:=TERM;
while ch in Æ'*','/',':','<','=','>'Å do begin
opr:=ch;
NEXTCH;
tmp:=TERM;
case opr of
'*': s:=s*tmp;
':','/': begin
if tmp<>0 then
s:=s/tmp
else begin
s:=s;
beregnet:=false;
end;
end;
'<':begin
if dobbeltrelation then begin
if second='>' then
if s<>tmp then s:=1 else s:=0;
if second='=' then
if s<=tmp then s:=1 else s:=0;
end else
if s<tmp then s:=1 else s:=0;
end;
'>':begin
if dobbeltrelation then begin
if second='=' then
if s>=tmp then s:=1 else s:=0;
end else
if s>tmp then s:=1 else s:=0;
end;
'=':begin
if s=tmp then s:=1 else s:=0;
end;
end;
end;
SIMPLEEXPRESSION:=s;
end;
begin æ EXPRESSION å
e:=SIMPLEEXPRESSION;
while ch in Æ'+','-'Å do begin
opr:=ch;
NEXTCH;
case opr of
'+': e:=e+SIMPLEEXPRESSION;
'-': e:=e-SIMPLEEXPRESSION;
end;
end;
EXPRESSION:=e;
end;
begin æ EVALUATE å
isformula:=false;
cpos:=0;
NEXTCH;
value:=EXPRESSION;
if ch=eofline then errpos:=0 else errpos:=cpos;
end æ EVALUATE å;
(*$A+*)
PROCEDURE RECALCULATE(visible:boolean);
var
rfx: sheetindex;
rfy:integer;
oldvalue: real;
err: integer;
shown:boolean;
begin
if visible then begin
write(rvsoff);
gotoxy(0,23); write(clreol);
write(' Beregning.. ');
end;
for rfy:=1 to fymax do begin
for rfx:='A' to fxmax do begin
upfx:=rfx;upfy:=rfy;
with sheetÆrfx,rfyÅ do begin
if (formula in cellstatus) then begin
shown:=((onscreen in cellstatus) and not repeteret);
cellstatus:=cellstatus-ÆonscreenÅ;
oldvalue:=value;
beregnet:=true;
cellstatus:=cellstatus+ÆcalculatedÅ;
EVALUATE(form,contents,value,err);
if beregnet then begin
cellstatus:=cellstatus+ÆonscreenÅ;
if ((oldvalue<>value) or not shown) and visible then begin
gotoxy(xposÆrfxÅ,rfy);
TALUD(rfx,rfy);
end;
end else begin
gotoxy(xposÆrfxÅ,rfy);
write(copy(points,1,fw));
end;
end;
end;
end;
end;
if visible then GOTOCELL(fx,fy);
end;
FUNCTION SYNTAX(var formel:anystring):byte;
var
pil:byte;
formelok,operator,double1,double2:boolean;
simpleoperators:set of char;
rel:stringÆ2Å;
begin
simpleoperators:=Æ'+','-','^','*','/',':','<','=','>'Å;
while (pos(',',formel)>0) do formelÆpos(',',formel)Å:='.';
if formelÆ1Å='.' then formel:='0'+formel;
if (formelÆ1Å='+') then delete(formel,1,1);
while pos('..',formel)>0 do delete(formel,pos('..',formel),1);
operator:=(formelÆ1Å<>'-');
double1:=true;double2:=true;
formelok:=(len(formel)>0);
if formelok then pil:=0 else pil:=1;
while (pil<len(formel)) and formelok do begin
pil:=pil+1;
if formelÆpilÅ in simpleoperators then begin
if formelÆpilÅ in Æ'<','=','>'Å then begin
if operator then begin
if double2 then
formelok:=false
else
if double1 then begin
rel:=copy(formel,pil-1,2);
if (rel='<>') or (rel='>=') or (rel='<=') then
double2:=true
else
formelok:=false;
end else
formelok:=false;
end else begin
operator:=true;
double1:=true;
end;
end else begin
if operator then
formelok:=false
else
operator:=true;
end;
end else begin
operator:=false;double1:=false;double2:=false;
end;
end;
if operator then formelok:=false;
if formelok then
SYNTAX:=0
else
SYNTAX:=pil;
end;
«eof»