DataMuseum.dk

top - download

    Length: 4224 (0x1080)
    Types: TextFile
    Names: »CALC.PAS«

└─⟦74e5ee6fb⟧ Bits:30002683 PolyPascal-86 v. 3.11 - Piccoline
└─⟦74e5ee6fb⟧ Bits:30003934 SW1402 PolyPascal v3.11 (dk) til Piccoline
    └─ ⟦this⟧ »CALC.PAS« 

TextFile

PROGRAM calculator; æ$K-,R-å

æ This program acts like a calculator - You type an expression	å
æ and the program calculates its value. Each time the calcula-	å
æ tor is ready to accept an input line, it prints an asterisk.	å
æ You must then type the expression and end it by pressing the	å
æ RETURN key, and shortly after, the result is displayed. If	å
æ the calculator finds an error, it displays a pointer, which	å
æ points at the error. There are five different operators (^,	å
æ *, /, +, and -), and seven standard functions (ABS, SQRT,	å
æ SIN, COS, ARCTAN, LN, and EXP). Parentheses within expres-	å
æ sions are allowed. A special variable, called X, always	å
æ holds the value of the last computation. To end the program,	å
æ type QUIT when the calculator prompts for an input line.	å

CONST
  strlen = 48;
TYPE
  str = STRINGÆstrlenÅ;
VAR
  e: integer;
  r: real;
  s: str;

PROCEDURE upcase(VAR s: str);
VAR
  i: integer;
BEGIN
  FOR i:=1 TO len(s) DO
  IF (sÆiÅ>='a') AND (sÆiÅ<='z') THEN sÆiÅ:=chr(ord(sÆiÅ)-32);
END;

PROCEDURE evaluate(VAR expr: str; VAR value: real; VAR errpos: integer);
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
  p,e,sl: integer;
  found: boolean;
  f: real;
  sf: stdf;
BEGIN
  IF ch IN Æ'0'..'9'Å THEN
  BEGIN
    p:=pos;
    REPEAT nextchar UNTIL NOT(ch IN Æ'0'..'9','.'Å);
    IF ch IN Æ'E','e'Å THEN
    BEGIN
      nextchar;
      IF ch IN Æ'+','-'Å THEN nextchar;
      WHILE ch IN Æ'0'..'9'Å DO nextchar;
    END;
    val(copy(expr,p,pos-p),f,e);
    IF e<>0 THEN
    BEGIN
      pos:=p+e-1; ch:=errch;
    END;
  END ELSE
  IF ch='(' THEN
  BEGIN
    nextchar;
    f:=expression;
    IF ch=')' THEN nextchar ELSE ch:=errch;
  END ELSE
  IF ch='X' THEN
  BEGIN
    nextchar; f:=value;
  END ELSE
  BEGIN
    found:=false;
    FOR sf:=fabs TO fexp DO
    IF NOT found THEN
    BEGIN
      sl:=len(stdfunÆsfÅ);
      IF copy(expr,pos,sl)=stdfunÆsfÅ THEN
      BEGIN
        pos:=pos+sl-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
  BEGIN
    nextchar; t:=exp(ln(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å
  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å
  pos:=0; nextchar;
  value:=expression;
  IF ch=eofline THEN errpos:=0 ELSE errpos:=pos;
END æevaluateå;

BEGIN æcalculatorå
  REPEAT
    write('* '); buflen:=strlen; read(s); upcase(s);
    IF (s<>'') AND (s<>'QUIT') THEN
    BEGIN
      evaluate(s,r,e);
      IF e=0 THEN write(' =',r) ELSE
      BEGIN
        writeln;
        write('^ ERROR':e+8);
      END;
    END;
    writeln;
  UNTIL s='QUIT';
END æcalculatorå.