parser tree

{
	ParsTree - parser tree structure
	---------------------------------------------------------------
	This stucture can learn words ( sequence of any characters )
	together with a code. The codeformat may be choosen before
	compilation, see TYPE CodeTyp.
	If a word is already known, the LEARN returns false.
	At any time a word may be SEARCHed, if found it returns true
	and the returned code is valid.
	---------------------------------------------------------------
	PRPtr --> PRec:
		   Term:BOOLEAN;  true if terminal
		   Ch  :CHAR;	  character
		   Sub:PRPtr;      PRPtr --> PRec
		   Code:CodeTyp;  longint
		   Next:PRPtr;     PRPtr --> PRec
		   Alt:PRPtr;      PRPtr --> PRec
	---------------------------------------------------------------
	Important Note : The whole tree is to be hanged on a to be
	supplied pointer( type PRPtr ), which has to be initialized
	to NIL before use.
	---------------------------------------------------------------
	Changes:
	 6/mar/95 :added size function
	  PEntries: number of strings
	  PText: text bytes found in strings
	  PDelta: suppressed number of text bytes
	  PTotal: includes code, excludes PDelta
		  :added readentry function
	  not yet complete
	---------------------------------------------------------------
	TestProg is PTTEST.PAS
	Upper Unit is PARSERTREE.PAS
	---------------------------------------------------------------
	Created		:8.aug.93
	Last Update	:6/mar/95
	---------------------------------------------------------------
	Is updated version of : -
	---------------------------------------------------------------
}
UNIT ParsTree;

INTERFACE

TYPE
 CodeTyp =WORD;	{ can be BYTE WORD LONGINT }
 PPtr=^PRPtr;
 PRPtr=^PRec;
 PRec=RECORD	{ size is 8byte+CodeTyp }
  Term:BOOLEAN; { true if terminal, false if there is more }
  Ch :CHAR;	{ character }
  Sub:PRPtr;
  Code:CodeTyp;
  Next:PRPtr;
  Alt:PRPtr;
 END;

{ TRUE if successful - else known }
FUNCTION Learn(VAR K:PRPtr;S:STRING;Z:CodeTyp):BOOLEAN;

{ TRUE if successful }
FUNCTION Search(VAR K:PRPtr;S:STRING;VAR Z:CodeTyp):BOOLEAN;

PROCEDURE List(VAR K:PRPtr);
PROCEDURE Kill(VAR K:PRPtr);
PROCEDURE Size(VAR K:PRPtr;VAR PEntries,PText,PDelta,PTotal:LONGINT);
FUNCTION ReadEntry(VAR K:PRPtr;E:LONGINT;VAR S:STRING;VAR Z:CodeTyp):BOOLEAN;

IMPLEMENTATION

{ append rest of string at AT with code Z
 Note AT is a POINTER
}
PROCEDURE AppendH(s:STRING;From:BYTE;At:PPtr;Z:CodeTyp);
VAR T:PRPtr;
 V:PPtr;
 i:BYTE;
BEGIN
 V:=At;
 FOR i:=From TO Length(s) DO
  BEGIN
   T:=New(PRPtr);
   V^:=T;
   T^.Term:=FALSE;
   T^.Code:=0;
   T^.Ch:=s[i];
   T^.Sub:=NIL;
   T^.Next:=NIL;
   T^.Alt:=NIL;
   V:=@T^.next;
  END;
 T^.Code:=Z;
 T^.Term:=TRUE;
END;

FUNCTION FindI(S:STRING;pos:BYTE;p:PPtr;Z:CodeTyp):BOOLEAN;
{ p is truely a ptr to ptr }
VAR t:PRPtr;
    v,l:PPtr;
 found :BOOLEAN;
BEGIN
 IF (p^=NIL) THEN { branch empty - insert there }
  BEGIN
   AppendH(s,1,p,Z); { append at entry ptr }
   FindI:=TRUE;
  END
 ELSE  { there is a nextptr }
  BEGIN
   v:=p;l:=v;
   found:=FALSE;
   REPEAT
    IF (ord(v^^.ch)NIL) THEN
       BEGIN
	L:=V;V:=@V^^.Alt;
       END
      ELSE	{ no altptr - insert after }
       BEGIN
	AppendH(s,pos,@v^^.alt,Z);
	Found:=TRUE;
	FindI:=TRUE;
       END;
     END { pos not reached }
    ELSE
     BEGIN
      IF (ord(v^^.ch)=ord(s[pos])) THEN { pos found }
       BEGIN
	IF (posNIL) THEN
       BEGIN
	L:=V;V:=@V^^.Alt;
       END
      ELSE	{ no altptr - insert after }
       BEGIN
	Found:=TRUE;
	FindS:=FALSE;
       END;
     END { pos not reached }
    ELSE
     BEGIN
      IF (ord(v^^.ch)=ord(s[pos])) THEN { pos found }
       BEGIN
	IF (posNIL) THEN ListI(j^.next,pos+1)
 ELSE BEGIN Write(' ',j^.code); Writeln; END;
 IF (j^.alt<>NIL) THEN
  BEGIN
   FOR i:=1 to pos DO Write(' ');
   ListI(j^.alt,pos);
  END;
END;

PROCEDURE KillI(j:PRPtr;pos:BYTE);
VAR p,t,v:PRPtr;
VAR i :BYTE;
BEGIN
{ Write(j^.ch); debug }
 IF (j^.alt<>NIL) THEN
  BEGIN
   KillI(j^.alt,pos);
  END;
 IF (j^.next<>NIL) THEN KillI(j^.next,pos+1);
 Dispose(J);
END;

PROCEDURE SizeI(j:PRPtr;pos:Byte;VAR PEntries,PText,PDelta,PTotal:LONGINT);
VAR p,t,v:PRPtr;
VAR i :BYTE;
BEGIN
 inc(PText);inc(PTotal);
 IF (j^.next<>NIL) THEN SizeI(j^.next,pos+1,PEntries,PText,PDelta,PTotal)
 ELSE BEGIN inc(PEntries);inc(PTotal,SizeOf(CodeTyp)); END;
 IF (j^.alt<>NIL) THEN
  BEGIN
   FOR i:=1 to pos DO inc(PDelta);
   SizeI(j^.alt,pos,PEntries,PText,PDelta,PTotal);
  END;
END;

{-------------------------------------------------------------}
FUNCTION Search(VAR K:PRPtr;S:STRING;VAR Z:CodeTyp):BOOLEAN;
BEGIN
 Search:=FindS(S,1,@K,Z);
END;

FUNCTION Learn(VAR K:PRPtr;S:STRING;Z:CodeTyp):BOOLEAN;
BEGIN
 Learn:=FindI(S,1,@K,Z);
END;

PROCEDURE List(VAR K:PRPtr);
BEGIN
 IF (K<>NIL) THEN ListI(K,0);
END;

PROCEDURE Kill(VAR K:PRPtr);
BEGIN
 IF (K<>NIL) THEN KillI(K,0);
END;

PROCEDURE Size(VAR K:PRPtr;VAR PEntries,PText,PDelta,PTotal:LONGINT);
BEGIN
 PEntries:=0;PText:=0;PTotal:=0;
 IF (K<>NIL) THEN SizeI(K,0,PEntries,PText,PDelta,PTotal);
END;

FUNCTION ReadEntry(VAR K:PRPtr;E:LONGINT;VAR S:STRING;VAR Z:CodeTyp):BOOLEAN;
VAR p:PRPtr;
BEGIN
 S:='';
 IF (K<>NIL) THEN
  BEGIN
   p:=K;

  END
 ELSE ReadEntry:=FALSE;
END;

{---------------------------------------------------------------}
{BEGIN}	{ autoinit of this unit}
END.	{ unit }

The encapsulation

{
	Parser -

	Created		:
	Last Update	:
	
	Is updated version of :
}
UNIT ParserTree;

INTERFACE

USES ParsTree;

TYPE
 ParserPtr=^ParserType;
 ParserType=OBJECT
  Head:PRPtr;
  CONSTRUCTOR Init;
  DESTRUCTOR Done;
  FUNCTION Learn(S:STRING;Z:CodeTyp):BOOLEAN;
  FUNCTION Search(S:STRING;VAR Z:CodeTyp):BOOLEAN;
  PROCEDURE List;
  PROCEDURE Size(VAR A,B,C,D:LONGINT);
{  PROCEDURE Store(VAR K:PRPtr);}
{  PROCEDURE Load(VAR K:PRPtr);}
 END;

IMPLEMENTATION

CONSTRUCTOR ParserType.Init;
BEGIN
 Head:=NIL;
END;

DESTRUCTOR ParserType.Done;
BEGIN
 ParsTree.Kill(Head);
END;

FUNCTION ParserType.Learn(S:STRING;Z:CodeTyp):BOOLEAN;
BEGIN
 Learn:=ParsTree.Learn(Head,S,Z);
END;

FUNCTION ParserType.Search(S:STRING;VAR Z:CodeTyp):BOOLEAN;
BEGIN
 Search:=ParsTree.Search(Head,S,Z);
END;

PROCEDURE ParserType.List;
BEGIN
 ParsTree.List(Head);
END;

PROCEDURE ParserType.Size(VAR A,B,C,D:LONGINT);
BEGIN
 ParsTree.Size(Head,a,b,c,d);
END;

BEGIN	{ autoinit of this unit}

END.	{ unit }

Sample App

PROGRAM ParserTreeTest;

USES OPCrt,ParsTree;

VAR Q:PRPtr;
    Z:CodeTyp;
    Y:LONGINT;

BEGIN
 clrscr;
 Q:=NIL;
 Y:=MemAvail;

 IF not (Learn(Q,'BAAB',5)) THEN Writeln('!');
 IF not (Learn(Q,'AAAC',3)) THEN Writeln('!');
 IF not (Learn(Q,'BAAC',6)) THEN Writeln('!');
 IF not (Learn(Q,'CAAD',8)) THEN Writeln('!');
 IF not (Learn(Q,'AAAB',2)) THEN Writeln('!');
 IF not (Learn(Q,'AAAA',1)) THEN Writeln('!');
 IF not (Learn(Q,'BAAD',7)) THEN Writeln('!');
 IF not (Learn(Q,'ABAA',4)) THEN Writeln('!');

 IF not (Learn(Q,'XAAB',13)) THEN Writeln('!');
 IF not (Learn(Q,'XAAC',11)) THEN Writeln('!');
 IF not (Learn(Q,'XAAC',14)) THEN Writeln('!');
 IF not (Learn(Q,'XAAD',16)) THEN Writeln('!');
 IF not (Learn(Q,'XAAB',10)) THEN Writeln('!');
 IF not (Learn(Q,'XAAA',9)) THEN Writeln('!');
 IF not (Learn(Q,'XAAD',15)) THEN Writeln('!');
 IF not (Learn(Q,'XBAA',12)) THEN Writeln('!');


 list(Q);

 IF Search(Q,'ABAA',Z) THEN Writeln('Found ',Z);

 Kill(Q);

 Writeln('deltaheap :',Y-MemAvail);
END.

Another sample App

program parsertest;

USES OPCrt,ParsTree,ParserTree;


VAR U:ParserType;
    Z:CodeTyp;
    Y:LONGINT;
    A,B,C,D:LONGINT;

BEGIN
 ClrScr;
 Y:=Memavail;
 U.Init;
 IF Not U.Learn('PROGRAM',1) THEN Writeln('!');
 IF Not U.Learn('PROCEDURE',1) THEN Writeln('!');
 IF Not U.Learn('FUNCTION',1) THEN Writeln('!');
 IF Not U.Learn('BEGIN',1) THEN Writeln('!');
 IF Not U.Learn('END',1) THEN Writeln('!');
 IF Not U.Learn('FOR',1) THEN Writeln('!');
 IF Not U.Learn('WHILE',1) THEN Writeln('!');
 IF Not U.Learn('REPEAT',1) THEN Writeln('!');
 IF Not U.Learn('IF',1) THEN Writeln('!');
 IF Not U.Learn('TYPE',1) THEN Writeln('!');
 IF Not U.Learn('CONST',1) THEN Writeln('!');
 IF Not U.Learn('VAR',1) THEN Writeln('!');
 IF Not U.Learn('UNTIL',1) THEN Writeln('!');


 U.List;
 U.Size(A,B,C,D);

 IF U.Search('ZETA',Z) THEN Writeln('Found ',Z);

 U.Done;

 Writeln('DeltaHeap :',Y-Memavail);

END.