{
 * A Child-Sibling Tree.
 *
 * A tree with PLUS at the root and with two children 3 and 4 is
 * structured as:
 *
 *		PLUS
 *		  |
 *		  3 -- 4
 *
 * and can be specified easily in LISP notation as
 *
 * (PLUS 3 4)
 *
 * where every '(' starts a new subtree.
 *
 * These trees are particular useful for translators because of
 * the flexibility of the children lists.  They are also very easy
 * to walk automatically, whereas trees with specific children
 * reference fields can't easily be walked automatically.
 *
 * This class contains the basic support for an AST.
 * Most people will create ASTs that are subclasses of
 * BaseAST or of CommonAST.
 */
}
unit ast;

interface
uses
   Classes,
   Generics.Collections;
//   dpgrtl.Token;


type
   TAST       = class;
   TASTList   = TList<TAST>;

   TAST = class
      protected
         fDown       : TAST;
         fRight      : TAST;

         fAstText    : AnsiString;
         fAstType    : integer;
         fAstLine    : integer;
         fAstColumn  : integer;

      private
         fVerbose    : boolean;  // verbose string conversion
         fTokenNames : TStringList;

      private
         procedure   DoFindAll(  NodeToSearch   : TAST;
                              // v              : Vector;
                                 Target         : TAST;
                                 PartialMatch   : boolean);

      protected
         function    GetNumberofChildren: integer;

         function    GetEquals(              Node  : TAST): boolean;   virtual;
         function    GetEqualsList(          Node  : TAST): boolean;   virtual;
         function    GetEqualsListPartial(   Node  : TAST): boolean;   virtual;
         function    GetEqualsTree(          Node  : TAST): boolean;   virtual;
         function    GetEqualsTreePartial(   Node  : TAST): boolean;   virtual;

         function    GetTokenNames  : TStringList;

         procedure   SetVerbose(             Verbose  : boolean;
                                             Names    : TStringList);

      public
         procedure   Initialize(    AstType  : integer;
                                    AstText  : AnsiString);    overload; virtual; abstract;

         procedure   Initialize(    Node     : TAST);          overload; virtual; abstract;
//         procedure   Initialize(    Token    : TToken);        overload; virtual; abstract;

         procedure   AddChild( node: TAST);
         procedure   RemoveChildren;

      public
         procedure   AfterConstruction; override;
         procedure   BeforeDestruction; override;

      public
         property    NumberOfChildren  : integer      read  GetNumberofChildren;

         property    NextSibling       : TAST         read  fRight      write fRight;
         property    FirstChild        : TAST         read  fDown       write fDown;

         property    AstText           : AnsiString   read  fAstText    write fAstText;
         property    AstType           : integer      read  fAstType    write fAstType;
         property    AstLine           : integer      read  fAstLine    write fAstLine;
         property    AstColumn         : integer      read  fAstColumn  write fAstColumn;

         property    Equals            [n: TAST]: boolean read GetEquals;
         property    EqualsList        [n: TAST]: boolean read GetEqualsList;
         property    EqualsListPartial [n: TAST]: boolean read GetEqualsListPartial;
         property    EqualsTree        [n: TAST]: boolean read GetEqualsTree;
         property    EqualsTreePartial [n: TAST]: boolean read GetEqualsTreepartial;
   end;

   TASTClass  = class of TAST;


implementation

{ TastBase }

procedure TAST.AfterConstruction;
begin
   inherited;
   fTokenNames := TStringList.Create;
end;

procedure TAST.BeforeDestruction;
begin
   fTokenNames.Free;
   inherited;
end;

// ================================================================================================
// DoFindAll
// ================================================================================================
procedure TAST.DoFindAll(NodeToSearch, Target: TAST; PartialMatch: boolean);
var
   sibling  : TAST;
   child    : TAST;

begin
   // start walking sibling lists, looking for matches
   sibling := NodeToSearch;

   while Assigned(sibling) do
   begin
      if (     PartialMatch and sibling.EqualsTreePartial[Target]) or
         ( not PartialMatch and sibling.EqualsTree[Target]) then
         // v.appendelement(sibling)
         ;

      if Assigned( sibling.FirstChild) then
         DoFindAll( sibling.FirstChild, {v,} Target, PartialMatch);

      sibling := sibling.NextSibling
   end;

end;


// ================================================================================================
// Get Number of Children
// ================================================================================================
function TAST.GetNumberofChildren: integer;
var
   t: TAST;
   n: integer;

begin
   t := fDown;
   n := 0;

   if Assigned(t) then
   begin
      INC(n);

      while Assigned(t.fRight) do
      begin
         t := t.fRight;
         INC(n)
      end;
   end;

   result := n
end;

// ================================================================================================
// Get Equals
// ================================================================================================
function TAST.GetEquals(Node: TAST): boolean;
begin
   if Assigned(Node)
      then result := (Node.fAstText = fAstText) and (Node.fAstType = fAstType)
      else result := false
end;

// ================================================================================================
// Get Equals List
// ================================================================================================
function TAST.GetEqualsList(Node: TAST): boolean;
var
   sibling: TAST;

begin
   result := false;

   if Assigned(Node) then
   begin
      sibling := self;

      while Assigned(sibling) and Assigned(Node) do
      begin
         // as a quick optimization, check roots firt
         if not sibling.Equals[Node] then
            break;

         // if roots match, do full list match test on children
         if Assigned( sibling.FirstChild) then
         begin
            if not sibling.FirstChild.EqualsList[Node.FirstChild] then
               break
         end

         // sibling has no kids, make sure Node doesn't either
         else if Assigned(Node.FirstChild) then
            break;

         sibling  := sibling  .NextSibling;
         Node     := Node     .NextSibling;
      end;

      if not Assigned(sibling) and not Assigned(Node) then
         result := true
   end;
end;

// ================================================================================================
// Get Equals List Partial
//
// Is Node a subtree of this list ? The siblings of the root are NOT ignored.
// ================================================================================================
function TAST.GetEqualsListPartial(Node: TAST): boolean;
var
   sibling: TAST;

begin
   result := false;

   if Assigned(Node) then
   begin
      sibling := self;

      while Assigned(sibling) and Assigned(Node) do
      begin
         // as a quick optimization, check roots firt
         if not sibling.Equals[Node] then
            break;

         // if roots match, do partial list match test on children
         if Assigned( sibling.FirstChild) then
            if not sibling.FirstChild.EqualsListPartial[Node.FirstChild] then
               break
      end;

      if not Assigned(sibling) and Assigned(Node)
         then result := false
         else result := true
   end;
end;

// ================================================================================================
// Get Equals Tree
//
// Is the tree rooted at *self* equals to *Node* ?
// The sibling of *self* are ignored.
// ================================================================================================
function TAST.GetEqualsTree(Node: TAST): boolean;
begin
   result := false;

   if Equals[Node] then
   begin
      // if roots match, do full list match test on children
      if Assigned(FirstChild) then
      begin
         if not FirstChild.EqualsList[Node.FirstChild] then
            exit;
      end

      // No kids, make sure *Node* hasn't either
      else if Assigned(Node.FirstChild) then
         exit;
   end;

   result := true
end;

// ================================================================================================
// Get Equals Tree Partial
// ================================================================================================
function TAST.GetEqualsTreePartial(Node: TAST): boolean;
begin
   result := false;

   if Equals[Node] then
      if Assigned(FirstChild) then
         if not FirstChild.EqualsListPartial[Node] then
            exit;

   result := true
end;

// ================================================================================================
// Get Token Names
// ================================================================================================
function TAST.GetTokenNames: TStringList;
begin
   result := TStringList.Create;
   result.AddStrings(fTokenNames);
end;

// ================================================================================================
// Set Verbose
// ================================================================================================
procedure TAST.SetVerbose(Verbose: boolean; Names: TStringList);
begin
   fVerbose := Verbose;
   fTokenNames.Clear;
   ftokenNames.AddStrings(Names);
end;

// ================================================================================================
// AddChild
// ================================================================================================
procedure TAST.AddChild(node: TAST);
var
   n: TAST;

begin
   if Assigned(node) then
   begin
      n := fDown;

      if Assigned(n) then
      begin
         while Assigned(n.fRight) do
            n := n.fRight;

         n.fRight := node
      end

      else
         fDown := node
   end;
end;

// ================================================================================================
// Remove Children
// ================================================================================================
procedure TAST.RemoveChildren;
begin
   fDown := nil
end;


end.