{
GPC demo program. A recursive descent parser for mathematical
expressions using real or complex numbers.

The code is Extended Pascal, i.e., it can be compiled with the
`--extended-pascal' option (but also in GPC's default mode).

Copyright (C) 1999-2000 Free Software Foundation, Inc.

Author: Frank Heckenbach <frank@pascal.gnu.de>

This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License as
published by the Free Software Foundation, version 2.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; see the file COPYING. If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.

As a special exception, if you incorporate even large parts of the
code of this demo program into another program with substantially
different functionality, this does not cause the other program to
be covered by the GNU General Public License. This exception does
not however invalidate any other reasons why it might be covered
by the GNU General Public License.
}

program ParserDemo (Input, Output);

{
  This parser understands the following grammar:

  CONSTANT = "e" | "pi" | "i"
  FUNCTION = "abs" | "sqrt" | "sin" | "cos" | "tan" | "arctan" | "exp" | "ln"
  ATOM_NONUM = "(" EXPR ")" | FUNCTION ATOM | CONSTANT
  ATOM = POSITIVE_REAL_NUMBER | "$" POSITIVE_HEXADECIMAL_INTEGER_NUMBER | ATOM_NONUM
  FACTOR_NONUM = ATOM_NONUM | FACTOR_NONUM "^" ATOM
  FACTOR = ATOM | FACTOR "^" ATOM
  EXPR1 = FACTOR | EXPR1 "*" FACTOR | EXPR1 FACTOR_NONUM | EXPR1 "/" FACTOR
  EXPR = EXPR1 | EXPR "+" EXPR1 | EXPR "-" EXPR1 | "-" EXPR1
}

(*@@*)(*$W no-field-name-problem*)

label 99;

{ LoCase (even a version with NLS), Frac and Pi are built into GPC, but
  deactivated when compiling with `--extended-pascal'. }

type
  TString = String (4096);

const
  Pi = 3.1415926535897932384626433832795028841971693993751;

function LoCase (ch : Char) : Char;
begin
  if ch in ['A' .. 'Z']
    then LoCase := Succ (ch, Ord ('a') - Ord ('A'))
    else LoCase := ch
end;

function Frac (x : Real) : Real;
var i : Real;
begin
  i := Round (x);
  if Abs (i) > Abs (x) then
    if i < 0
      then i := i + 1
      else i := i - 1;
  Frac := x - i
end;

procedure Skip;
begin
  while (Input^ = ' ') and not EOLn do Get (Input)
end;

procedure Expect (ch : Char);
begin
  Skip;
  if Input^ <> ch then
    begin
      Writeln ('`', ch, ''' expected');
      goto 99
    end;
  Get (Input)
end;

function Expr : Complex; forward;

function Atom : Complex; forward;

function Atom_NoNum : Complex;
const
  MaxFNames = 11;
var
  FNames : array [1 .. MaxFNames] of String (6) value
    [1 : 'e'; 2 : 'pi'; 3 : 'i'; 4 : 'abs';
     5 : 'sqrt'; 6 : 'sin'; 7 : 'cos'; 8 : 'tan';
     9 : 'arctan'; 10 : 'exp'; 11 : 'ln'];
  f : TString;
  i : Integer;
  z : Complex;
begin
  Skip;
  case LoCase (Input^) of
    '(' : begin
            Expect ('(');
            z := Expr;
            Expect (')')
          end;
    'a' .. 'z' : begin
                   f := '';
                   while LoCase (Input^) in ['a' .. 'z'] do
                     begin
                       f := f + LoCase (Input^);
                       Get (Input)
                     end;
                   i := MaxFNames;
                   while (i > 0) and (f <> FNames [i]) do i := i - 1;
                   if i = 0 then
                     begin
                       Writeln ('Unknown function `', f, '''');
                       goto 99
                     end;
                   case i of
                     1 : z := Exp (1);
                     2 : z := Pi;
                     3 : z := Cmplx (0, 1);
                     otherwise
                       z := Atom;
                       case i of
                          4 : z := Abs (z);
                          5 : z := Sqrt (z);
                          6 : z := Sin (z);
                          7 : z := Cos (z);
                          8 : z := Sin (z) / Cos (z);
                          9 : z := ArcTan (z);
                         10 : z := Exp (z);
                         11 : z := Ln (z);
                       end
                   end
                 end;
    otherwise
      Writeln ('Parse error.');
      goto 99
  end;
  Atom_NoNum := z
end;

function Atom;
var
  r : Real;
  i : Integer;
begin
  Skip;
  if Input^ in ['0' .. '9', '.'] then
    begin
      Read (r);
      Atom := r
    end
  else if Input^ = '$' then
    begin
      Read (i);
      Atom := i
    end
  else
    Atom := Atom_NoNum
end;

function Factor (function AtomFunc : Complex) : Complex;
var
  z, z1 : Complex;
  f : Boolean;
begin
  z := AtomFunc;
  repeat
    Skip;
    f := True;
    case Input^ of
      '^' : begin
              Get (Input);
              z1 := Atom;
              if z <> 0 then
                z := exp (z1 * ln (z))
              else if z1 = 0 then
                z := 1
            end;
      otherwise f := False
    end
  until not f;
  Factor := z
end;

function Expr1 : Complex;
var
  z : Complex;
  f : Boolean;
begin
  z := Factor (Atom);
  repeat
    Skip;
    f := True;
    case LoCase (Input^) of
      '*' : begin
              Get (Input);
              z := z * Factor (Atom)
            end;
      '/' : begin
              Get (Input);
              z := z / Factor (Atom)
            end;
      '(', 'a' .. 'z' : z := z * Factor (Atom_NoNum);
      otherwise f := False
    end
  until not f;
  Expr1 := z
end;

function Expr;
var
  z : Complex;
  s, f : Boolean;
begin
  Skip;
  s := False;
  while Input^ in ['+', '-'] do
    begin
      if Input^ = '-' then s := not s;
      Get (Input);
      Skip
    end;
  z := Expr1;
  if s then z := - z;
  repeat
    Skip;
    f := True;
    case Input^ of
      '+' : begin
              Get (Input);
              z := z + Expr1
            end;
      '-' : begin
              Get (Input);
              z := z - Expr1
            end;
      otherwise f := False
    end
  until not f;
  Expr := z
end;

function Real2String (x : Real) = s : TString;
begin
  if (Abs (x) <= MaxInt) and (Frac (x) = 0)
    then WriteStr (s, Round (x))
    else WriteStr (s, x : 0 : 20)
end;

function Complex2String (z : Complex) = s : TString;
begin
  s := Real2String (Re (z));
  if Im (z) > 0 then s := s + ' +';
  if Im (z) <> 0 then s := s + ' ' + Real2String (Im (z)) + ' * i'
end;

begin
  Writeln ('Enter expressions consisting of');
  Writeln ('- real numbers, using the `e'' notation,');
  Writeln ('- the constants `e'', `pi'', `i'',');
  Writeln ('- the operators `+'', `-'', `*'', `/'', `^'',');
  Writeln ('- the functions `abs'', `sqrt'', `sin'', `cos'', `tan'', `arctan'', `exp'', `ln'',');
  Writeln ('- parentheses.');
  Writeln;
  Writeln ('Note: Due to the `e'' notation, there is a problem with terms like `2e'' which');
  Writeln ('will be interpreted as `2*10^...''. If you mean `2*e'', write so, or `2 e''.');
  Writeln ('Expressions like `3e+4+5'' can be confusing, but are interpreted according to');
  Writeln ('the `e'' notation (i.e., this expression equals 30005).');
  Writeln;
  Writeln ('Enter an empty line when finished.');
  while not EOLn do
    begin
      Writeln (Complex2String (Expr));
      if not EOLn then Writeln ('Superfluous characters after the expression');
      99 : Readln
    end
end.
