home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / GRAPHICS / PLOT / 3DF.ZIP / PARSE.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-04-13  |  8.4 KB  |  359 lines
  1. Unit Parse;
  2.  
  3. interface
  4.  
  5. type
  6.   Token = (AddOp, Comma, EndInput, FunName, Lparen, MulOp,
  7.            PwrOp, Rparen, UnsConst, VarName);
  8.  
  9.   NodeType = (AbsNd, AtanNd, CosNd, ExpNd, LnNd,
  10.               MaxNd, MinNd, SinNd, SqrtNd,
  11.  
  12.               PosNd, NegNd,
  13.               PlusNd, MinusNd,
  14.               MulNd, DivNd, PwrNd,
  15.               XNd, YNd, ConstNd);
  16.  
  17.   Tree = ^TreeRec;
  18.   TreeRec = record
  19.               case typ: NodeType of
  20.                 PlusNd: (left, right: Tree);
  21.                 ConstNd: (rl: Real);
  22.             end;
  23.  
  24. function ParseExpr(var inExpr: String): Tree;
  25. function Eval(tr: Tree; x, y: Real): Real;
  26.  
  27. implementation
  28.   Uses Crt;
  29.  
  30. const
  31.   funTbl: array[AbsNd..SqrtNd] of String[4] =
  32.           ( 'abs', 'atan', 'cos', 'exp', 'ln', 'max', 'min', 'sin', 'sqrt' );
  33.   tokStr: array[AddOp..VarName] of String[8] =
  34.           ( '+ or -', ',', 'end', 'function', '(', '* or /',
  35.             '^', ')', 'number', 'x or y' );
  36.  
  37. var
  38.   buf: String;
  39.   p: Integer;
  40.   la: Token;
  41.   laVal: record case Integer of
  42.            0: (rl: Real);
  43.            2: (typ: NodeType);
  44.          end;
  45.  
  46.   procedure error(msg: String);
  47.   begin
  48.     Writeln('Can''t parse expression: ');
  49.     Writeln(' ', buf);
  50.     Writeln('':p,'\_', msg+'.');
  51.     Halt;
  52.   end;
  53.  
  54.   procedure lexError(msg: String);
  55.   begin
  56.     inc(p); error(msg);
  57.   end;
  58.  
  59.   procedure lex;
  60.   var
  61.     tok: String;
  62.     i, code: Integer;
  63.     t: NodeType;
  64.     dot: Boolean;
  65.   begin
  66.     while buf[p] in [^I,' '] do inc(p);
  67.     case buf[p] of
  68.       #0 : la := EndInput;
  69.       '(': begin inc(p); la := LParen; end;
  70.       ')': begin inc(p); la := RParen; end;
  71.       ',': begin inc(p); la := Comma;  end;
  72.       '+': begin inc(p); la := AddOp;   laVal.typ := PlusNd; end;
  73.       '-': begin inc(p); la := AddOp;   laVal.typ := MinusNd; end;
  74.       '*': begin inc(p); la := MulOp;   laVal.typ := MulNd; end;
  75.       '/': begin inc(p); la := MulOp;   laVal.typ := DivNd; end;
  76.       '^': begin inc(p); la := PwrOp;   laVal.typ := PwrNd; end;
  77.       'x': begin inc(p); la := VarName; laVal.typ := XNd;   end;
  78.       'y': begin inc(p); la := VarName; laVal.typ := YNd;   end;
  79.       'a'..'w','z':
  80.            begin
  81.              i := 0;
  82.              repeat
  83.                inc(i); tok[i] := buf[p]; inc(p);
  84.              until not (buf[p] in ['a'..'z', '0'..'9']);
  85.              tok[0] := Char(i);
  86.              t := AbsNd;
  87.              while (t <= SqrtNd) and (funTbl[t] <> tok) do
  88.                inc(t);
  89.              if t > SqrtNd then
  90.                error('Unknown function');
  91.              la := FunName;
  92.              laVal.typ := t;
  93.            end;
  94.       '0'..'9','.':
  95.            begin
  96.              dot := False;
  97.              i := 0;
  98.              repeat
  99.                if buf[p] = '.' then
  100.                  if dot then
  101.                    lexError('Extra decimal point')
  102.                  else
  103.                    dot := True;
  104.                inc(i); tok[i] := buf[p]; inc(p);
  105.              until not (buf[p] in ['.', '0'..'9']);
  106.              tok[0] := Char(i);
  107.              la := UnsConst;
  108.              Val(tok, laVal.rl, code);
  109.              if code <> 0 then
  110.                error('Abort: bad UnsConst');
  111.            end;
  112.       else lexError('Unknown character');
  113.     end;
  114.   end;
  115.  
  116.   procedure match(t: Token);
  117.   begin
  118.     if la <> t then
  119.       error('Expected '+tokStr[t]);
  120.     lex;
  121.   end;
  122.  
  123.   function makeNode(t: NodeType; l, r: Tree): Tree;
  124.   var
  125.     tr: Tree;
  126.   begin
  127.     New(tr);
  128.     with tr^ do begin
  129.       typ := t; left := l; right := r;
  130.     end;
  131.     makeNode := tr;
  132.   end;
  133.  
  134.   function makeConstNode(v: Real): Tree;
  135.   var
  136.     tr: Tree;
  137.   begin
  138.     New(tr);
  139.     with tr^ do begin
  140.       typ := ConstNd; rl := v;
  141.     end;
  142.     makeConstNode := tr;
  143.   end;
  144.  
  145.   function expr: Tree; forward;
  146.  
  147.   function factor: Tree;
  148.   var
  149.     tr: Tree;
  150.     op: NodeType;
  151.   begin
  152.     case la of
  153.       FunName:  begin
  154.                  op := laVal.typ;
  155.                  lex;
  156.                  match(Lparen);
  157.                  tr := makeNode(op, expr, nil);
  158.                  if op in [MinNd, MaxNd] then begin
  159.                    match(Comma);
  160.                    tr^.right := expr;
  161.                  end;
  162.                  factor := tr;
  163.                  match(Rparen);
  164.                 end;
  165.       VarName:  begin
  166.                  factor := makeNode(laVal.typ, nil, nil);
  167.                  lex;
  168.                 end;
  169.       UnsConst: begin
  170.                   factor := makeConstNode(laVal.rl);
  171.                   lex;
  172.                 end;
  173.       Lparen:   begin
  174.                   lex;
  175.                   factor := expr;
  176.                   match(Rparen);
  177.                 end;
  178.       else      error('Expected a factor');
  179.     end;
  180.   end;
  181.  
  182.   function power: Tree;
  183.   var
  184.     tr: Tree;
  185.     op: NodeType;
  186.   begin
  187.     tr := factor;
  188.     if la = PwrOp then begin
  189.       op := laVal.typ;
  190.       lex;
  191.       tr := makeNode(op, tr, power);
  192.     end;
  193.     power := tr;
  194.   end;
  195.  
  196.   function signedFact: Tree;
  197.   var
  198.     sgn: NodeType;
  199.   begin
  200.     sgn := PosNd;
  201.     if la = AddOp then begin
  202.       if laVal.typ = MinusNd then sgn := NegNd;
  203.       lex;
  204.     end;
  205.     if sgn = NegNd then
  206.       signedFact := makeNode(NegNd, power, nil)
  207.     else
  208.       signedFact := power;
  209.   end;
  210.  
  211.   function term: Tree;
  212.   var
  213.     tr: Tree;
  214.     op: NodeType;
  215.   begin
  216.     tr := signedFact;
  217.     while la = MulOp do begin
  218.       op := laVal.typ;
  219.       lex;
  220.       tr := makeNode(op, tr, signedFact);
  221.     end;
  222.     term := tr
  223.   end;
  224.  
  225.   function expr: Tree;
  226.   var
  227.     tr: Tree;
  228.     op: NodeType;
  229.   begin
  230.     tr := term;
  231.     while la = AddOp do begin
  232.       op := laVal.typ;
  233.       lex;
  234.       tr := makeNode(op, tr, term);
  235.     end;
  236.     expr := tr;
  237.   end;
  238.  
  239.   procedure toLowCase(var s: String);
  240.   const
  241.     cnv = Ord('a') - Ord('A');
  242.   var
  243.     i: Integer;
  244.   begin
  245.     for i := 1 to Length(s) do
  246.       if s[i] in ['A'..'Z'] then
  247.         s[i] := Char(Ord(s[i]) + cnv);
  248.   end;
  249.  
  250.   function parseExpr;
  251.   begin
  252.     buf := inExpr + #0;
  253.     toLowCase(buf);
  254.     p := 1;
  255.     lex;
  256.     parseExpr := expr;
  257.     match(EndInput);
  258.   end;
  259.  
  260.   function Eval(tr: Tree; x, y: Real): Real;
  261.  
  262.     function min(a, b: Real): Real;
  263.     begin
  264.       if a < b then min := a else min := b;
  265.     end;
  266.  
  267.     function max(a, b: Real): Real;
  268.     begin
  269.       if a > b then max := a else max := b;
  270.     end;
  271.  
  272.     function safeSqrt(x: Real): Real;
  273.     begin
  274.       if x > 0 then
  275.         safeSqrt := Sqrt(x)
  276.       else
  277.         safeSqrt := 0;
  278.     end;
  279.  
  280.     function safeDiv(a, b: Real): Real;
  281.     begin
  282.       if b = 0 then
  283.         if a < 0 then
  284.           safeDiv := -1e30
  285.         else
  286.           safeDiv := 1e30
  287.       else
  288.         safeDiv := a/b;
  289.     end;
  290.  
  291.     function safeLn(x: Real): Real;
  292.     begin
  293.       if x = 0 then
  294.         safeLn := -1e30
  295.       else
  296.         safeLn := Ln(Abs(x));
  297.     end;
  298.  
  299.     function safePwr(x, a: Real): Real;
  300.     var
  301.       tmp: Real;
  302.     begin
  303.       if x = 0 then
  304.         safePwr := 0
  305.       else if Frac(a) = 0 then
  306.         if a < 0 then begin
  307.           tmp := x;
  308.           while a < -1 do begin
  309.             a := a+1;
  310.             tmp := x*tmp;
  311.           end;
  312.           safePwr := 1/tmp;
  313.         end
  314.         else if a > 0 then begin
  315.           tmp := x;
  316.           while a > 1 do begin
  317.             a := a-1;
  318.             tmp := x*tmp;
  319.           end;
  320.           safePwr := tmp;
  321.         end
  322.         else safePwr := 1
  323.       else if x > 0 then
  324.         safePwr := Exp(a*Ln(x))
  325.       else safePwr := 0;
  326.     end;
  327.  
  328.     function e(tr: Tree): Real;
  329.     begin
  330.       with tr^ do
  331.         case typ of
  332.           AbsNd:   e := Abs(e(left));
  333.           AtanNd:  e := ArcTan(e(left));
  334.           CosNd:   e := Cos(e(left));
  335.           ExpNd:   e := Exp(e(left));
  336.           LnNd:    e := safeLn(e(left));
  337.           MaxNd:   e := max(e(left), e(right));
  338.           MinNd:   e := min(e(left), e(right));
  339.           SinNd:   e := Sin(e(left));
  340.           SqrtNd:  e := safeSqrt(e(left));
  341.           PosNd:   e := e(left);
  342.           NegNd:   e := -e(left);
  343.           PlusNd:  e := e(left) + e(right);
  344.           MinusNd: e := e(left) - e(right);
  345.           MulNd:   e := e(left) * e(right);
  346.           DivNd:   e := safeDiv(e(left), e(right));
  347.           PwrNd:   e := safePwr(e(left), e(right));
  348.           XNd:     e := x;
  349.           YNd:     e := y;
  350.           ConstNd: e := rl;
  351.         end;
  352.     end;
  353.  
  354.   begin
  355.     Eval := e(tr);
  356.   end;
  357.  
  358. end.
  359.