DataMuseum.dk

top - download

    Length: 4992 (0x1380)
    Types: TextFile
    Names: »EVALUATE.PAS«

└─⟦1b488ebc8⟧ Bits:30003076 SuperCalc 2 for CP/M-80
    └─ ⟦this⟧ »EVALUATE.PAS« 

TextFile

type
  str80=stringÆ80Å;
  
procedure uppercase(var s:str80);
var tegn : integer;
begin
 for tegn:=1 to len(s) do
   if s(.tegn.) in (.'a'..'å'.) then s(.tegn.):=chr(ord(s(.tegn.))-32);
end;

procedure lowercase(var s:str80);
var tegn : integer;
begin
 for tegn:=1 to len(s) do
   if s(.tegn.) in (.'A'..'Å'.) then s(.tegn.):=chr(ord(s(.tegn.))+32);
end;

function potens(a,x:real):real;
(* beregner a'x, idet der tages hensyn til om x er et heltal. *)
var z,u:real;
    e :integer;
begin
  if int(x)=x then
    begin
      e:=round(x);z:=1;u:=a;
      while e>0 do begin
        while not odd(e) do
            begin e:=e div 2;u:=sqr(u);end;
        e:=e-1;z:=u*z;
      end;
    end
  else (* x er ikke et helt tal - bruger derfor logaritme *)
    z:=exp(x*ln(a));
  potens:=z;
end;  

function evaluate(var expr:str80;var errpos:integer;x:real):real;
(************************************************************************
   En funktion, der evaluerer et regneudtryk, der er indeholdt i en string.
   I udtrykket indgår en variabel x, hvis værdi medregnes.
   Der skal benyttes små bogstaver i udtrykket.
   Resultatet afleveres som et reelt tal. Variablen errpos vil indeholde
   tallet 0, hvis der ikke er fejl i udtrykket og ellers vil positionen,
   hvor fejlen er opdaget blive angivet.
   Hvis der er fejl,vil værdien af funktionen være tilfældig!! 
   Beregningshastigheden er ca.halvveret i forhold til en alm. Pascal-sætn.  
 *****************************************************************************)
   
const
  errch='?';
  eofline=@13;
var
  pos :integer;
  ch :char;
  
procedure nextchar;
begin
  repeat
    pos:=pos+1;
    if pos<=len(expr) then
      ch:=exprÆposÅ
    else
      ch:=eofline;
  until ch<>' ';
end;

function expression : real;
var
  e: real;
  opr :char;
  
function simexpr:real;
var
  s :real;
  opr : char;
  
function term:real;
var
  t :real;
  
function signedfactor : real;

function factor : real;
type
  stdf = (fabs,fsqrt,fsin,fcos,farctan,fln,fexp);
  stdflist = arrayÆstdfÅ of stringÆ6Å;
const
  stdfun: stdflist = ('abs','sqrt','sin','cos','arctan','ln','exp');
var
  e,ee,l  :integer;
  decpoint,negexp,found : boolean;
  f: real;
  sf:stdf;
begin
  if ch in Æ'0'..'9'Å then (* det er et tal *)
  begin
    f:=0.0;e:=0;decpoint:=false;
    repeat
      f:=f*10.0+(ord(ch)-48);
      if decpoint then e:=e-1;
      nextchar;
      if (ch='.') and not decpoint then
       begin
         decpoint:=true;nextchar;
       end;
    until not(ch in(.'0'..'9'.));
    if ch='e' then (* eksponentielnotation *)
    begin
      ee:=0;nextchar;
      if ch in Æ'+','-'Å then
      begin
        negexp:=ch='-';nextchar;
      end else
      negexp:=false;
      while ch in(.'0'..'9'.) do
      begin
        ee:=ee*10+ord(ch)-48;
        nextchar;
      end;
      if negexp then e:=e-ee else e:=e+ee;
    end;
    f:=f*pwrten(e); (* nu er tallet dekodet *)
  end else
  if ch='(' then (* hvis der er en parentes *)
  begin
    nextchar;
    f:=expression;
    if ch=')' then nextchar else ch:=errch; (* bliver parentesen sluttet? *)
  end else (* det kan være variablen x *)
  if ch='x' then
  begin
    nextchar;f:=x;
  end else (* et funktionsudtryk *)
  begin
    found:=false;
    for sf:=fabs to fexp do (* find den rigtige funktion *)
    if not found then
    begin
      l:=len(stdfunÆsfÅ);
      if copy(expr,pos,l)=stdfunÆsfÅ then
      begin
        pos:=pos+l-1;nextchar;
        f:=factor;
        case sf of
        fabs : f:=abs(f);
        fsqrt: f:=sqrt(f);
        fsin: f:=sin(f);
        fcos : f:=cos(f);
        farctan : f:=arctan(f);
        fln : f:=ln(f);
        fexp : f:=exp(f);
      end;
      found:=true;
    end;
  end;
  if not found then ch:=errch;
end;
factor:=f;
end; (* factor *)
begin (* signedfactor *)
  if ch='-' then
    begin
      nextchar; signedfactor:=-factor;
    end else
      signedfactor :=factor;
end (* signedfactor *);
begin (*term *)
  t:=signedfactor;
  while ch='''' do (* potens *)
  begin
    nextchar;t:=potens(t,signedfactor);
  end;
  term:=t;
end (* term *);
begin (*simexpr *)
  s:=term;
  while ch in Æ'*','/'Å do
  begin
    opr:=ch;nextchar;
    case opr of
    '*' : s:=s*term;
    '/' : s:=s/term;
    end;
  end;
  simexpr:=s;
end (* simexpr *);
begin (*expression*)
  if ch='-' then begin
    nextchar;e:=-1*simexpr end
  else
    e:=simexpr;
                            
  while ch in Æ'+','-'Å do
  begin
    opr:=ch;nextchar;
    case opr of
    '+' : e:=e+simexpr;
    '-' : e:=e-simexpr;
    end;
  end;
  expression:=e;
end (*expression *);
begin (*evaluate *)
  lowercase(expr);
  pos:=0;nextchar;
  evaluate:=expression;
  if ch=eofline then errpos:=0 else errpos:=pos;
end (*evaluate *);
  
  

«eof»