[Back to OOP SWAG index] [Back to Main SWAG index] [Original]

    UNIT PARSER;

    {  recursive descent expression Parser.

       Based on the parser by Herbert Shildt as shown in
       Advanced C
       Osborn McGraw-Hill

       Ported to Pascal by

       (C) M.Fiel 1993 Vienna - Austria
       CompuServe ID : 100041,2007

       for further infos refer to this book.

       Use freely if you find it useful.

    }
    {$R+}

    INTERFACE

      USES
        Objects,ParTools;

      CONST
        MaxParserVars = 100; { Max Count of Variables fo PVarParser }

      TYPE

    { PMathParser evaluates expressions like (-(10*5)/27) * 128  no variables }

        PMathParser = ^TMathParser;
        TMathParser = object(TObject)

          ToParse   : PString;    { the string to parse }
          ExprPos   : Integer;    { aktuall position in the string }
          TokenType : Integer;    { Variable delimiter...}
          Token     : String;     { the aktuell token }

          Result    : Real;       { the result of the expression }

          constructor Init;
          destructor  Done; virtual;

          function    Evaluate(Expression:String) : Real;
          { expression is the string which is to be evaluated
          calls function Parse}

          function    GetNextToken : Boolean; virtual;
          function    GetPart : String; virtual;
          function    isDelimiter : Boolean; virtual;

          function    AddSub : Boolean; virtual;
          { checks for Addition or Substr and calls MulDiv }
          function    MulDiv : Boolean; virtual;
          { checks for Multiplikation or Div. and calls Unary }
          function    Unary  : Boolean; virtual;
          { checks for Unary (+/-) and calls Parant }
          function    Parant : Boolean; virtual;
          { checks for paratheses and if necessary calls Parse --> go recursive }

          function    Primitive : Boolean; virtual;
          { evaluates constatn value }

          function    Parse : Boolean; virtual;
          { parse not necessary in this version (call addsub instead) but is
            needed in descents }

        end;

    { VarParser can Handle Variables and epressions like
      A=10.78
      B=20.45
      A*(B-10)+5
      .
      .
      .
    }
        PVarParser = ^TVarParser;
        TVarParser = object(TMathParser)

          Vars : PParserVarColl;{Container of Variables defined in Unit ParTools}

          constructor Init;
          destructor  Done; virtual;

          function    Primitive : Boolean; virtual;
          function    Parse : Boolean; virtual;
          { Calls Checckassign }

          function    CheckAssign : Boolean; virtual;
          { checks assignments : ex. A=12 }
          procedure   ClearVars; virtual;
          { clears all variables }

        end;

    IMPLEMENTATION

      CONST                { defines wich type a token is }
        tError     = 0;
        tVariable  = 1;
        tDelimiter = 2;
        tNumber    = 3;
        tConstValue = 4;

      constructor TMathParser.Init;
        begin
          if not inherited Init then FAIL;
          ExprPos:=0;
          Token:='';
        end;

      destructor TMathParser.Done;
        begin
          if (ToParse<>NIL) then DisposeStr(ToParse);
          inherited Done;
        end;

      function TMathParser.Evaluate(Expression:String) : Real;

        begin

          if (ToParse<>NIL) then DisposeStr(ToParse);
          ToParse:=NewStr(Expression);

          result:=0.00;
          ExprPos:=1;

          if GetNextToken then Parse;

          Evaluate:=result;

        end;

      function TMathParser.Parse : Boolean;
        begin
          Parse:=AddSub;
        end;

      function TMathParser.GetNextToken : Boolean;
        begin

          GetNextToken:=True;

          while ToParse^[ExprPos] = ' ' do inc(ExprPos);

          if (isDelimiter) then begin

            TokenType := tDelimiter;
            Token:=ToParse^[ExprPos];
            inc(ExprPos);

          end else begin

            case ToParse^[ExprPos] of

              '0'..'9':begin
                TokenType := tNumber;
                Token :=GetPart;
              end;

              'A'..'Z','a'..'z' : begin
                TokenType := tVariable;
                Token:=GetPart;
              end;

              else begin
                TokenType := tError;
                GetNextToken:=False;
              end;

            end;

          end;

        end;

      function TMathParser.GetPart : String;
        var
          RetVal : String;
        begin

          RetVal:='';

          while not(isDelimiter) do begin

            RetVal:=RetVal+ToParse^[ExprPos];

            if ExprPos<length(ToParse^) then
              inc(ExprPos)
            else begin
              RetVal:=Trim(RetVal);
              GetPart:=RetVal;
              Exit;
            end;

          end;

          RetVal:=Trim(RetVal);

          GetPart:=RetVal;

        end;

      function TMathParser.isDelimiter : Boolean;
        begin
          isDelimiter:=(Pos(ToParse^[ExprPos],'+-*/()=%')<>0);
        end;

      function TMathParser.AddSub : Boolean;
        var
          Hold : Real;
          OldToken : String;
        begin

          AddSub:=True;

          if (MulDiv) then begin

            while (Pos(Token,'+-') > 0) do begin

              OldToken:=Token;
              GetNextToken;

              Hold:=Result;

              if (MulDiv) then begin
                if OldToken='+' then Result:=(Hold+Result) else Result:=(Hold-Result);
              end else
                AddSub:=False;

            end;

          end else
            AddSub:=False;

        end;

      function TMathParser.MulDiv : Boolean;
        var
          Hold : Real;
          PerHelp : Real;
          OldToken : String;
        begin

          MulDiv:=True;

          if (Unary) then begin

            while (Pos(Token,'*/%') > 0) do begin

              OldToken:=Token;
              GetNextToken;
              Hold:=Result;

              if (Unary) then begin

                case OldToken[1] of
                  '*':Result:=Hold*Result;

                  '/':begin
                    if (Result<> 0) then
                      Result:=Hold/Result
                    else begin
                      OwnError('Division by zero');
                      MulDiv:=False;
                    end;
                  end;

                  '%':begin
                    PerHelp:=Hold/Result;
                    Result:=Hold-(PerHelp*Result);
                  end;

                end;

              end else
                MulDiv:=False;

            end;

          end else
            MulDiv:=False;

        end;

      function TMathParser.Unary : Boolean;
        var
          UnaryHelp:Boolean;
          OldToken : String;
        begin

          Unary:=True;

          UnaryHelp:=False;

          if (Pos(Token,'-+') >0) then begin
            OldToken:=Token;
            UnaryHelp:=True;
            GetNextToken;
          end;

          if (Parant) then begin
            if (UnaryHelp and (OldToken = '-')) then Result:=-(Result);
          end else
            Unary:=False;

        end;

      function TMathParser.Parant : Boolean;
        begin

          Parant:=True;

          if ((TokenType = tDelimiter) and (Token = '(')) then begin

            GetNextToken;

            if (Parse) then begin

              if (Token <> ')') then begin
                OwnError('unbalanced parantheses');
                Parant:=False;
              end;

            end else
              Parant:=False;

            GetNextToken;

          end else

            Parant:=Primitive;

        end;

      function TMathParser.Primitive : Boolean;
        var
          e:Integer;
        begin

          Primitive:=True;

          if (TokenType = tNumber) then begin

            val(Token,Result,e);

            if (e<>0) then begin
              OwnError('syntax error');
              Primitive:=False;
            end;

            GetNextToken;

          end;

        end;

    {****************************************************************************}
    {                          TVARPARSER                                        }
    {****************************************************************************}

      constructor TVarParser.Init;
        begin
          if not inherited Init then FAIL;
          Vars:=New(PParserVarColl,Init(MaxParserVars,0));
        end;

      destructor TVarParser.Done;
        begin
          Dispose(Vars,Done);
          inherited Done;
        end;

      function TVarParser.Primitive : Boolean;
        begin

          Primitive:=True;

          if (inherited Primitive) then begin

            if (TokenType = tVariable) then begin
              result:=Vars^.GetVar(Token);
              GetNextToken;
            end;

          end else
            Primitive:=False;

        end;

     function TVarParser.Parse : Boolean;
       begin
         Parse:=CheckAssign;
       end;

     function TVarParser.CheckAssign : Boolean;
       var
         OldToken : String;
         OldType  : Integer;
       begin

         if (TokenType = tVariable) then begin

           OldToken :=Token;
           OldType := TokenType;

           GetNextToken;

           if (Token = '=') then begin

             GetNextToken;

             CheckAssign:=AddSub;
             Vars^.SetValue(OLdToken,result);

             Exit;

           end else begin

             dec(ExprPos,length(Token));
             Token:=OldToken;
             TokenType:=OldType;

           end;

         end;

         CheckAssign := AddSub;

       end;

     procedure TVarParser.ClearVars;
       begin
         Vars^.FreeAll;
       end;

    END.

    { -------------------------------- CUT HERE -----------------------}

    UNIT PARTOOLS;

    {
       (C) M.Fiel 1993 Vienna - Austria
       CompuServe ID : 100041,2007

       Use freely if you find it useful.
    }

    INTERFACE

      USES
        Objects;

      TYPE

        {Object to hold variable data for the TVarParser defined in Unit Parser}

        PParserVar = ^TParserVar;
        TParserVar = object(TObject)

          Name : PString;
          Value : Real;

          constructor Init(aName:String;aValue:Real);
          destructor  Done; virtual;

          function    GetName : String; virtual;
          function    GetValue : Real; virtual;
          procedure   SetValue(NewValue : Real); virtual;

        end;

        {Container to hold TParserVar objects }

        PParserVarColl = ^TParserVarColl;
        TParserVarColl = object(TCollection)

          procedure FreeItem(Item:Pointer); virtual;
          function  GetVarIndex(Name:String) : Integer; virtual;
          function  GetVar(Name:String) : Real; virtual;
          procedure SetValue(Name:String;NewValue:Real); virtual;

        end;

       PStrColl = ^TStrColl;  { Container for Strings }
       TStrColl = object(TCollection)
         procedure  FreeItem(Item: Pointer); virtual;
       end;

      procedure OwnError(S:String); { Shows a MsgBox with S }
      function Trim(Line:String) : String; { Pads a String from End }
      function MkStr(Len,Val:Byte): String;
      { makes a String of length len and fills it with val }

    IMPLEMENTATION

      USES
        MsgBox;

      constructor TParserVar.Init(aName:String;aValue:Real);
        begin
          inherited Init;
          Name:=NewStr(aName);
          Value:=aValue;
        end;

      destructor TParserVar.Done;
        begin
          DisposeStr(Name);
          inherited Done;
        end;

      function TParserVar.GetName : String;
        begin
          if Name<>NIL then GetName:=Name^ else GetName:='';
        end;

      function TParserVar.GetValue : Real;
        begin
          GetValue:=Value;
        end;

      procedure TParserVar.SetValue(NewValue : Real);
        begin
          Value:=NewValue;
        end;

      procedure TParserVarColl.FreeItem(Item:Pointer);
        begin
          if (Item <> NIL) then Dispose(PParserVar(Item),Done);
        end;

      function TParserVarColl.GetVar(Name:String) : Real;
        var
          Index:Integer;
        begin
          Index:=GetVarIndex(Name);

          if (Index<>-1) then
            GetVar:=PParserVar(At(Index))^.GetValue
          else begin
            OwnError('invalid variable');
            GetVar:=0;
          end;

        end;

      function TParserVarColl.GetVarIndex(Name:String) : Integer;

        function isName(P:PParserVar):Boolean;
          begin
            isName:=(P^.GetName = Name);
          end;

        begin
          GetVarIndex:=IndexOf(FirstThat(@isName));
        end;

      procedure TParserVarColl.SetValue(Name:String;NewValue:Real);
        var
          Index : Integer;

        begin

          Index:=GetVarIndex(Name);

          if (Index <> -1) then
            PParserVar(At(Index))^.SetValue(NewValue)
          else
            Insert(New(PParserVar,Init(Name,NewValue)));

        end;

      procedure OwnError(S:String);
        begin
           MessageBox(S,nil,mfError + mfOkButton);
        end;

      function Trim(Line:String) : String;
        var
          Len: BYTE ABSOLUTE Line;
        begin
          while (Len > 0) AND (Line[Len] = ' ') DO Dec(Len);
          Trim := Line;
        end ;

      function MkStr (Len,Val:Byte): String;
        var
          S:String;
        begin
           S[0]:=chr(Len);
           fillchar (S[1],Len,Val);
           MkStr:=s;
        end;

     procedure TStrColl.FreeItem(Item: Pointer);
       begin
         if Item<>Nil then DisposeStr(Item);
       end;

    END.

    { -------------------------------- DEMO PROGRAM -----------------------}

    PROGRAM PARDEMO;

    {
       (C) M.Fiel 1993 Vienna - Austria
       CompuServe ID : 100041,2007

       Use freely if you find it useful.

       Demonstration of a Recursive descent Parser and a new Screensaver
       object.

       Infos watch the units and the parser.txt file

       if problems or comments leave me a message or mail me.

    }

    USES
      Objects,Drivers,Menus,Views,App,Dialogs,ScrSaver,TVParser;

      { NOTE  -  SCRSAVER UNIT CAN BE FOUND IN SWAG DISTRIBUTION ALSO !!}
      {          AND WILL BE NEED BY THIS MODULE                        }

    CONST
      cmParser = 1001;
      cmScreenSave = 1002;

    TYPE

       PApp = ^Tapp;
       TApp = object(TApplication)

          ScreenSaver : PScreenSaver; { defined in unit ScrSav }
          {add the screensaver object to the application}

          constructor Init;

          procedure   HandleEvent (var event:Tevent); virtual;
          procedure   InitMenuBar; virtual;
          procedure   InitStatusLine; virtual;
          procedure   ShowParser;
          procedure   GetEvent(var Event: TEvent); virtual;

       end;

      VAR
        XApplic: TApp;

       constructor TApp.Init;
         begin
           if not inherited Init then FAIL;

           ScreenSaver:=New(PScreenSaver,Init('I''m the Screensaver',180));
           Insert(ScreenSaver);

         end;

      procedure TApp.GetEvent(var Event: TEvent);
        begin
          inherited GetEvent(Event);
          ScreenSaver^.GetEvent(Event);  { don't forget this line }
        end;

       procedure Tapp.InitStatusLine;

         var
           R: TRect;
         begin

           GetExtent(r);
           R.A.Y := R.B.Y - 1;

           StatusLine:=New(PStatusLine, Init(R,

              NewStatusDef (0, 1000,
                 newstatuskey ('~F10~-Menu',kbF10,cmmenu,
                 newstatuskey ('~Alt-X~ Exit', kbaltx, cmQuit,
              NIL)),

           NIL)));

         end;

       procedure Tapp.InitMenuBar;

         var
           R : TRect;
         begin

            GetExtent(R);
            R.B.Y := R.A.Y + 1;

            MenuBar:=New(PMenuBar,Init(R,NewMenu(

               NewSubMenu('~ð~ ',hcNoContext,NewMenu(
                 NewItem('~Alt-X~ Exit','',kbAltX,cmQuit,hcNoContext,
               NIL)),

               NewItem('~P~arser','',0,cmParser,hcNoContext,
               NewItem('~S~creensave','',0,cmScreenSave,hcNoContext,

            Nil))))));
        end;

      procedure TApp.ShowParser;
        var
          Parser:PVisionParser;
        begin
          Parser:=New(PVisionParser,Init);
          if Parser<>NIL then begin
            DeskTop^.ExecView(Parser);
            Dispose(Parser,Done);
          end;
        end;

      procedure Tapp.HandleEvent (var Event:TEvent);
        begin

          case Event.What of

            evCommand : begin

              case (Event.Command) of

                cmParser : ShowParser;
                cmScreenSave : begin
                  DoneVideo;
                  ScreenSaver^.Activ:=True;
                end;
                else inherited HandleEvent (Event);

              end;

            end;

            else inherited HandleEvent (Event);

          end;

        end;

    begin

       XApplic.Init;
       XApplic.Run;
       XApplic.Done;

    end.

[Back to OOP SWAG index] [Back to Main SWAG index] [Original]