Garbo/Garbo.cdr/pc/graphics/3df.zoo/parse.pas

Pascal/Delphi Source File | 1991-04-13 | 9KB | 359 lines

Unit Parse;

interface

type
  Token = (AddOp, Comma, EndInput, FunName, Lparen, MulOp,
           PwrOp, Rparen, UnsConst, VarName);

  NodeType = (AbsNd, AtanNd, CosNd, ExpNd, LnNd,
              MaxNd, MinNd, SinNd, SqrtNd,

              PosNd, NegNd,
              PlusNd, MinusNd,
              MulNd, DivNd, PwrNd,
              XNd, YNd, ConstNd);

  Tree = ^TreeRec;
  TreeRec = record
              case typ: NodeType of
                PlusNd: (left, right: Tree);
                ConstNd: (rl: Real);
            end;

function ParseExpr(var inExpr: String): Tree;
function Eval(tr: Tree; x, y: Real): Real;

implementation
  Uses Crt;

const
  funTbl: array[AbsNd..SqrtNd] of String[4] =
          ( 'abs', 'atan', 'cos', 'exp', 'ln', 'max', 'min', 'sin', 'sqrt' );
  tokStr: array[AddOp..VarName] of String[8] =
          ( '+ or -', ',', 'end', 'function', '(', '* or /',
            '^', ')', 'number', 'x or y' );

var
  buf: String;
  p: Integer;
  la: Token;
  laVal: record case Integer of
           0: (rl: Real);
           2: (typ: NodeType);
         end;

  procedure error(msg: String);
  begin
    Writeln('Can''t parse expression: ');
    Writeln(' ', buf);
    Writeln('':p,'\_', msg+'.');
    Halt;
  end;

  procedure lexError(msg: String);
  begin
    inc(p); error(msg);
  end;

  procedure lex;
  var
    tok: String;
    i, code: Integer;
    t: NodeType;
    dot: Boolean;
  begin
    while buf[p] in [^I,' '] do inc(p);
    case buf[p] of
      #0 : la := EndInput;
      '(': begin inc(p); la := LParen; end;
      ')': begin inc(p); la := RParen; end;
      ',': begin inc(p); la := Comma;  end;
      '+': begin inc(p); la := AddOp;   laVal.typ := PlusNd; end;
      '-': begin inc(p); la := AddOp;   laVal.typ := MinusNd; end;
      '*': begin inc(p); la := MulOp;   laVal.typ := MulNd; end;
      '/': begin inc(p); la := MulOp;   laVal.typ := DivNd; end;
      '^': begin inc(p); la := PwrOp;   laVal.typ := PwrNd; end;
      'x': begin inc(p); la := VarName; laVal.typ := XNd;   end;
      'y': begin inc(p); la := VarName; laVal.typ := YNd;   end;
      'a'..'w','z':
           begin
             i := 0;
             repeat
               inc(i); tok[i] := buf[p]; inc(p);
             until not (buf[p] in ['a'..'z', '0'..'9']);
             tok[0] := Char(i);
             t := AbsNd;
             while (t <= SqrtNd) and (funTbl[t] <> tok) do
               inc(t);
             if t > SqrtNd then
               error('Unknown function');
             la := FunName;
             laVal.typ := t;
           end;
      '0'..'9','.':
           begin
             dot := False;
             i := 0;
             repeat
               if buf[p] = '.' then
                 if dot then
                   lexError('Extra decimal point')
                 else
                   dot := True;
               inc(i); tok[i] := buf[p]; inc(p);
             until not (buf[p] in ['.', '0'..'9']);
             tok[0] := Char(i);
             la := UnsConst;
             Val(tok, laVal.rl, code);
             if code <> 0 then
               error('Abort: bad UnsConst');
           end;
      else lexError('Unknown character');
    end;
  end;

  procedure match(t: Token);
  begin
    if la <> t then
      error('Expected '+tokStr[t]);
    lex;
  end;

  function makeNode(t: NodeType; l, r: Tree): Tree;
  var
    tr: Tree;
  begin
    New(tr);
    with tr^ do begin
      typ := t; left := l; right := r;
    end;
    makeNode := tr;
  end;

  function makeConstNode(v: Real): Tree;
  var
    tr: Tree;
  begin
    New(tr);
    with tr^ do begin
      typ := ConstNd; rl := v;
    end;
    makeConstNode := tr;
  end;

  function expr: Tree; forward;

  function factor: Tree;
  var
    tr: Tree;
    op: NodeType;
  begin
    case la of
      FunName:  begin
                 op := laVal.typ;
                 lex;
                 match(Lparen);
                 tr := makeNode(op, expr, nil);
                 if op in [MinNd, MaxNd] then begin
                   match(Comma);
                   tr^.right := expr;
                 end;
                 factor := tr;
                 match(Rparen);
                end;
      VarName:  begin
                 factor := makeNode(laVal.typ, nil, nil);
                 lex;
                end;
      UnsConst: begin
                  factor := makeConstNode(laVal.rl);
                  lex;
                end;
      Lparen:   begin
                  lex;
                  factor := expr;
                  match(Rparen);
                end;
      else      error('Expected a factor');
    end;
  end;

  function power: Tree;
  var
    tr: Tree;
    op: NodeType;
  begin
    tr := factor;
    if la = PwrOp then begin
      op := laVal.typ;
      lex;
      tr := makeNode(op, tr, power);
    end;
    power := tr;
  end;

  function signedFact: Tree;
  var
    sgn: NodeType;
  begin
    sgn := PosNd;
    if la = AddOp then begin
      if laVal.typ = MinusNd then sgn := NegNd;
      lex;
    end;
    if sgn = NegNd then
      signedFact := makeNode(NegNd, power, nil)
    else
      signedFact := power;
  end;

  function term: Tree;
  var
    tr: Tree;
    op: NodeType;
  begin
    tr := signedFact;
    while la = MulOp do begin
      op := laVal.typ;
      lex;
      tr := makeNode(op, tr, signedFact);
    end;
    term := tr
  end;

  function expr: Tree;
  var
    tr: Tree;
    op: NodeType;
  begin
    tr := term;
    while la = AddOp do begin
      op := laVal.typ;
      lex;
      tr := makeNode(op, tr, term);
    end;
    expr := tr;
  end;

  procedure toLowCase(var s: String);
  const
    cnv = Ord('a') - Ord('A');
  var
    i: Integer;
  begin
    for i := 1 to Length(s) do
      if s[i] in ['A'..'Z'] then
        s[i] := Char(Ord(s[i]) + cnv);
  end;

  function parseExpr;
  begin
    buf := inExpr + #0;
    toLowCase(buf);
    p := 1;
    lex;
    parseExpr := expr;
    match(EndInput);
  end;

  function Eval(tr: Tree; x, y: Real): Real;

    function min(a, b: Real): Real;
    begin
      if a < b then min := a else min := b;
    end;

    function max(a, b: Real): Real;
    begin
      if a > b then max := a else max := b;
    end;

    function safeSqrt(x: Real): Real;
    begin
      if x > 0 then
        safeSqrt := Sqrt(x)
      else
        safeSqrt := 0;
    end;

    function safeDiv(a, b: Real): Real;
    begin
      if b = 0 then
        if a < 0 then
          safeDiv := -1e30
        else
          safeDiv := 1e30
      else
        safeDiv := a/b;
    end;

    function safeLn(x: Real): Real;
    begin
      if x = 0 then
        safeLn := -1e30
      else
        safeLn := Ln(Abs(x));
    end;

    function safePwr(x, a: Real): Real;
    var
      tmp: Real;
    begin
      if x = 0 then
        safePwr := 0
      else if Frac(a) = 0 then
        if a < 0 then begin
          tmp := x;
          while a < -1 do begin
            a := a+1;
            tmp := x*tmp;
          end;
          safePwr := 1/tmp;
        end
        else if a > 0 then begin
          tmp := x;
          while a > 1 do begin
            a := a-1;
            tmp := x*tmp;
          end;
          safePwr := tmp;
        end
        else safePwr := 1
      else if x > 0 then
        safePwr := Exp(a*Ln(x))
      else safePwr := 0;
    end;

    function e(tr: Tree): Real;
    begin
      with tr^ do
        case typ of
          AbsNd:   e := Abs(e(left));
          AtanNd:  e := ArcTan(e(left));
          CosNd:   e := Cos(e(left));
          ExpNd:   e := Exp(e(left));
          LnNd:    e := safeLn(e(left));
          MaxNd:   e := max(e(left), e(right));
          MinNd:   e := min(e(left), e(right));
          SinNd:   e := Sin(e(left));
          SqrtNd:  e := safeSqrt(e(left));
          PosNd:   e := e(left);
          NegNd:   e := -e(left);
          PlusNd:  e := e(left) + e(right);
          MinusNd: e := e(left) - e(right);
          MulNd:   e := e(left) * e(right);
          DivNd:   e := safeDiv(e(left), e(right));
          PwrNd:   e := safePwr(e(left), e(right));
          XNd:     e := x;
          YNd:     e := y;
          ConstNd: e := rl;
        end;
    end;

  begin
    Eval := e(tr);
  end;

end.