From 853a5a484f3e556a526473f23a60e3394b133abe Mon Sep 17 00:00:00 2001
From: Jed Barber <jjbarber@y7mail.com>
Date: Fri, 22 May 2020 22:23:22 +1000
Subject: Parse_Graphs complete but untested

---
 src/packrat-parse_graphs.adb | 249 +++++++++++++++++++
 src/packrat-parse_graphs.ads | 556 +++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 805 insertions(+)
 create mode 100644 src/packrat-parse_graphs.adb
 create mode 100644 src/packrat-parse_graphs.ads

(limited to 'src')

diff --git a/src/packrat-parse_graphs.adb b/src/packrat-parse_graphs.adb
new file mode 100644
index 0000000..16b74dc
--- /dev/null
+++ b/src/packrat-parse_graphs.adb
@@ -0,0 +1,249 @@
+
+
+package body Packrat.Parse_Graphs is
+
+
+    function "<"
+           (Left, Right : in Edge_Label_Type)
+        return Boolean is
+    begin
+        if Left.Finish = Right.Finish then
+            return Left.Order < Right.Order;
+        else
+            return Left.Finish < Right.Finish;
+        end if;
+    end "<";
+
+
+
+
+
+    function "="
+           (Left, Right : in Parse_Graph)
+        return Boolean
+    is
+        use type Base.Graph;
+    begin
+        return Base.Graph (Left) = Base.Graph (Right) and
+            Left.Root_Node = Right.Root_Node;
+    end "=";
+
+
+
+
+
+    function To_Graph
+           (Nodes : in Node_Array;
+            Edges : in Edge_Array)
+        return Parse_Graph is
+    begin
+        return G : Parse_Graph :=
+            (Base.To_Graph (Nodes, Edges) with Root_Node => No_Node);
+    end To_Graph;
+
+
+    function To_Graph
+           (Nodes : in Node_Array;
+            Edges : in Edge_Array;
+            Root  : in Extended_Node_ID_Type)
+        return Parse_Graph
+    is
+        Valid : Boolean := False;
+    begin
+        if Root /= No_Node then
+            for N of Nodes loop
+                if Root = N then
+                    Valid := True;
+                    exit;
+                end if;
+            end loop;
+            if not Valid then
+                raise Constraint_Error with "Root node not in graph";
+            end if;
+        end if;
+        return G : Parse_Graph :=
+            (Base.To_Graph (Nodes, Edges) with Root_Node => Root);
+    end To_Graph;
+
+
+
+
+
+    procedure Assign
+           (Target : in out Parse_Graph;
+            Source : in     Parse_Graph) is
+    begin
+        Base.Assign (Base.Graph (Target), Base.Graph (Source));
+        Target.Root_Node := Source.Root_Node;
+    end Assign;
+
+
+    function Copy
+           (Source : in Parse_Graph)
+        return Parse_Graph is
+    begin
+        return G : Parse_Graph :=
+            (Base.Copy (Base.Graph (Source)) with Root_Node => Source.Root_Node);
+    end Copy;
+
+
+    procedure Move
+           (Target, Source : in out Parse_Graph) is
+    begin
+        Base.Move (Base.Graph (Target), Base.Graph (Source));
+        Target.Root_Node := Source.Root_Node;
+        Source.Root_Node := No_Node;
+    end Move;
+
+
+
+
+
+    function Root
+           (Container : in Parse_Graph)
+        return Cursor is
+    begin
+        if not Container.Contains (Container.Root_Node) then
+            return No_Element;
+        else
+            return Container.To_Cursor (Container.Root_Node);
+        end if;
+    end Root;
+
+
+    procedure Set_Root
+           (Container : in out Parse_Graph;
+            Node      : in     Extended_Node_ID_Type) is
+    begin
+        Container.Root_Node := Node;
+    end Set_Root;
+
+
+
+
+
+    function Finish_List
+           (Container : in Parse_Graph;
+            Node      : in Node_ID_Type)
+        return Finish_Array is
+    begin
+        return Finish_List (Container.To_Cursor (Node));
+    end Finish_List;
+
+
+    function Finish_List
+           (Position : in Cursor)
+        return Finish_Array
+    is
+        function V2A is new Vector_To_Array (Finish_Type, Finish_Array, Finish_Vectors);
+        Fins : Finish_Vectors.Vector;
+        Current : Edge_Label_Type;
+    begin
+        for E of Outbound (Position) loop
+            if Has_Label (Position, E) then
+                Current := Label (Position, E);
+                if not Fins.Contains (Current.Finish) then
+                    Fins.Append (Current.Finish);
+                end if;
+            end if;
+        end loop;
+        Finsort.Sort (Fins);
+        return V2A (Fins);
+    end Finish_List;
+
+
+    function Sub_Nodes
+           (Container : in Parse_Graph;
+            Node      : in Node_ID_Type;
+            Finish_At : in Finish_Type)
+        return Node_Array is
+    begin
+        return Sub_Nodes (Container.To_Cursor (Node), Finish_At);
+    end Sub_Nodes;
+
+
+    function Sub_Nodes
+           (Position  : in Cursor;
+            Finish_At : in Finish_Type)
+        return Node_Array
+    is
+        function V2A is new Vector_To_Array (Node_ID_Type, Node_Array, Node_Vectors);
+        Nodes : Node_Vectors.Vector;
+        Current_Label : Edge_Label_Type;
+    begin
+        for E of Outbound (Position) loop
+            if Has_Label (Position, E) then
+                Current_Label := Label (Position, E);
+                if Current_Label.Finish = Finish_At then
+                    Nodes.Reference (Current_Label.Order) := E.To;
+                end if;
+            end if;
+        end loop;
+        return V2A (Nodes);
+    end Sub_Nodes;
+
+
+
+
+
+    procedure Prune
+           (Container : in out Parse_Graph;
+            Node      : in     Node_ID_Type)
+    is
+        My_Cursor : Cursor := Container.To_Cursor (Node);
+    begin
+        Prune (My_Cursor);
+    end Prune;
+
+
+    procedure Prune
+           (Position : in out Cursor)
+    is
+        use type Ada.Containers.Count_Type;
+        Active : Cursor_Vectors.Vector;
+        Current : Cursor;
+    begin
+        if not Has_Element (Position) then
+            return;
+        end if;
+        for N of Children (Position) loop
+            if N /= Element (Position) then
+                Active.Append (Cursor_To (Position, N));
+            end if;
+        end loop;
+        Delete (Position);
+        while not Active.Is_Empty loop
+            for Index in reverse 1 .. Active.Last_Index loop
+                Current := Active (Index);
+                if Indegree (Current) = 0 then
+                    for N of Children (Current) loop
+                        if not Active.Contains (Cursor_To (Current, N)) then
+                            Active.Append (Cursor_To (Current, N));
+                        end if;
+                    end loop;
+                    Delete (Current);
+                end if;
+                Active.Delete (Index);
+            end loop;
+        end loop;
+    end Prune;
+
+
+
+
+
+    function Vector_To_Array
+           (Input : in Type_Vectors.Vector)
+        return Array_Type is
+    begin
+        return Result : Array_Type (1 .. Input.Last_Index) do
+            for I in Result'Range loop
+                Result (I) := Input (I);
+            end loop;
+        end return;
+    end Vector_To_Array;
+
+
+end Packrat.Parse_Graphs;
+
+
diff --git a/src/packrat-parse_graphs.ads b/src/packrat-parse_graphs.ads
new file mode 100644
index 0000000..0a3660e
--- /dev/null
+++ b/src/packrat-parse_graphs.ads
@@ -0,0 +1,556 @@
+
+
+with
+
+    Ada.Containers,
+    Directed_Graphs;
+
+private with
+
+    Ada.Containers.Vectors;
+
+
+generic
+
+    type Label_Enum is (<>);
+    type Element_Type is private;
+    type Element_Array is array (Positive range <>) of Element_Type;
+
+    with package Gen_Tokens is new Tokens (Label_Enum, Element_Type, Element_Array);
+
+package Packrat.Parse_Graphs is
+
+
+    type Node_ID_Type is new Positive;
+    type Edge_ID_Type is new Positive;
+
+    subtype Node_Label_Type is Gen_Tokens.Token;
+
+    subtype Finish_Type is Positive;
+    subtype Order_Type is Positive;
+    type Edge_Label_Type is record
+        Finish : Finish_Type;
+        Order  : Order_Type;
+    end record;
+
+    function "<"
+           (Left, Right : in Edge_Label_Type)
+        return Boolean;
+
+    type Finish_Array is array (Positive range <>) of Finish_Type;
+
+
+
+
+    --  This is to avoid some... ambiguities... with "="
+    --  functions when instantiating the Base package.
+    use type Gen_Tokens.Token;
+
+    package Base is new Directed_Graphs
+       (Node_ID_Type    => Node_ID_Type,
+        Edge_ID_Type    => Edge_ID_Type,
+        Node_Label_Type => Node_Label_Type,
+        Edge_Label_Type => Edge_Label_Type);
+
+    subtype Extended_Node_ID_Type is Base.Extended_Node_ID_Type;
+    subtype Node_Array is Base.Node_Array;
+    subtype Path is Base.Path;
+
+    subtype Edge_Type is Base.Edge_Type;
+    subtype Edge_Array is Base.Edge_Array;
+
+    function "<"
+           (Left, Right : in Edge_Type)
+        return Boolean
+    renames Base."<";
+
+
+
+
+    subtype Node_Label_Constant_Reference is Base.Node_Label_Constant_Reference;
+    subtype Node_Label_Reference is Base.Node_Label_Reference;
+    subtype Edge_Label_Constant_Reference is Base.Edge_Label_Constant_Reference;
+    subtype Edge_Label_Reference is Base.Edge_Label_Reference;
+
+
+
+
+    type Parse_Graph is new Base.Graph with private;
+    subtype Cursor is Base.Cursor;
+
+    function "="
+           (Left, Right : in Cursor)
+        return Boolean
+    renames Base."=";
+
+    function "="
+           (Left, Right : in Parse_Graph)
+        return Boolean;
+
+
+
+
+    No_Node     : constant Extended_Node_ID_Type := Base.No_Node;
+    No_Element  : constant Cursor := Base.No_Element;
+    Empty_Graph : constant Parse_Graph;
+
+
+
+
+    function To_Graph
+           (Nodes : in Node_Array;
+            Edges : in Edge_Array)
+        return Parse_Graph;
+
+    function To_Graph
+           (Nodes : in Node_Array;
+            Edges : in Edge_Array;
+            Root  : in Extended_Node_ID_Type)
+        return Parse_Graph;
+
+
+
+
+    procedure Assign
+           (Target : in out Parse_Graph;
+            Source : in     Parse_Graph);
+
+    function Copy
+           (Source : in Parse_Graph)
+        return Parse_Graph;
+
+    procedure Move
+           (Target, Source : in out Parse_Graph);
+
+
+
+
+    --  Usually you would get a Parse_Graph by way of parsing something
+    --  with the parser, which would then have a root node already set,
+    --  being the only node in the graph that has no parents.
+    function Root
+           (Container : in Parse_Graph)
+        return Cursor;
+
+    --  Not really advisable under most circumstances unless you're
+    --  making a Parse_Graph manually for some reason.
+    procedure Set_Root
+           (Container : in out Parse_Graph;
+            Node      : in     Extended_Node_ID_Type);
+
+
+
+
+    --  Returns an array of the all possible finish positions resulting
+    --  from current node's parsing, sorted from shortest to longest.
+    function Finish_List
+           (Container : in Parse_Graph;
+            Node      : in Node_ID_Type)
+        return Finish_Array;
+
+    function Finish_List
+           (Position : in Cursor)
+        return Finish_Array;
+
+    --  Returns an array of children of a node made by a parse that ended
+    --  at a specified finish position, sorted according to parsing order.
+    function Sub_Nodes
+           (Container : in Parse_Graph;
+            Node      : in Node_ID_Type;
+            Finish_At : in Finish_Type)
+        return Node_Array;
+
+    function Sub_Nodes
+           (Position  : in Cursor;
+            Finish_At : in Finish_Type)
+        return Node_Array;
+
+
+
+
+    --  Deletes a node from the graph then removes any other nodes that
+    --  were made unreachable from the root by that deletion.
+    procedure Prune
+           (Container : in out Parse_Graph;
+            Node      : in     Node_ID_Type);
+
+    procedure Prune
+           (Position : in out Cursor);
+
+
+
+
+    --  Since this package sets the Nodes, Edges, and Labels of the Graphs
+    --  to be specific types, it cannot be a child package of Directed_Graphs.
+    --  Yet, it still is an extension of that package. To make it all work
+    --  conveniently we re-export all the Cursor functions and procedures here.
+    --  The Graph functions and procedures can be called with dot extension
+    --  notation regardless so aren't a concern.
+
+    function Has_Element
+           (Position : in Cursor)
+        return Boolean
+    renames Base.Has_Element;
+
+    function Element
+           (Position : in Cursor)
+        return Extended_Node_ID_Type
+    renames Base.Element;
+
+    function Node_Count
+           (Container : in Cursor)
+        return Ada.Containers.Count_Type
+    renames Base.Node_Count;
+
+    function Node_Count_In_Subgraph
+           (Position : in Cursor)
+        return Ada.Containers.Count_Type
+    renames Base.Node_Count_In_Subgraph;
+
+    function Edge_Count
+           (Container : in Cursor)
+        return Ada.Containers.Count_Type
+    renames Base.Edge_Count;
+
+    function Edge_Count_In_Subgraph
+           (Position : in Cursor)
+        return Ada.Containers.Count_Type
+    renames Base.Edge_Count_In_Subgraph;
+
+    function Nodes
+           (Container : in Cursor)
+        return Node_Array
+    renames Base.Nodes;
+
+    function Nodes_In_Subgraph
+           (Position : in Cursor)
+        return Node_Array
+    renames Base.Nodes_In_Subgraph;
+
+    function Edges
+           (Container : in Cursor)
+        return Edge_Array
+    renames Base.Edges;
+
+    function Edges_In_Subgraph
+           (Position : in Cursor)
+        return Edge_Array
+    renames Base.Edges_In_Subgraph;
+
+    function Unused
+           (Container : in Cursor)
+        return Node_ID_Type
+    renames Base.Unused;
+
+    function Unused
+           (Container : in Cursor)
+        return Edge_ID_Type
+    renames Base.Unused;
+
+    procedure Insert
+           (Container : in Cursor;
+            Node      : in Node_ID_Type)
+    renames Base.Insert;
+
+    procedure Insert
+           (Container : in Cursor;
+            Node      : in Node_ID_Type;
+            Label     : in Node_Label_Type)
+    renames Base.Insert;
+
+    procedure Insert
+           (Container : in Cursor;
+            Edge      : in Edge_Type)
+    renames Base.Insert;
+
+    procedure Insert
+           (Container : in Cursor;
+            Edge      : in Edge_Type;
+            Label     : in Edge_Label_Type)
+    renames Base.Insert;
+
+    procedure Delete
+           (Position : in out Cursor)
+    renames Base.Delete;
+
+    procedure Delete
+           (Container : in Cursor;
+            Edge      : in Edge_Type)
+    renames Base.Delete;
+
+    procedure Append_Label
+           (Position : in Cursor;
+            Label    : in Node_Label_Type)
+    renames Base.Append_Label;
+
+    procedure Append_Label
+           (Container : in Cursor;
+            Edge      : in Edge_Type;
+            Label     : in Edge_Label_Type)
+    renames Base.Append_Label;
+
+    procedure Replace_Label
+           (Position : in Cursor;
+            Label    : in Node_Label_Type)
+    renames Base.Replace_Label;
+
+    procedure Replace_Label
+           (Container : in Cursor;
+            Edge      : in Edge_Type;
+            Label     : in Edge_Label_Type)
+    renames Base.Replace_Label;
+
+    procedure Delete_Label
+           (Position : in Cursor)
+    renames Base.Delete_Label;
+
+    procedure Delete_Label
+           (Container : in Cursor;
+            Edge      : in Edge_Type)
+    renames Base.Delete_Label;
+
+    procedure Delete_Subgraph
+           (Position : in out Cursor)
+    renames Base.Delete_Subgraph;
+
+    procedure Swap
+           (Left, Right : in out Cursor)
+    renames Base.Swap;
+
+    function Constant_Label_Reference
+           (Position : in Cursor)
+        return Node_Label_Constant_Reference
+    renames Base.Constant_Label_Reference;
+
+    function Label_Reference
+           (Position : in Cursor)
+        return Node_Label_Reference
+    renames Base.Label_Reference;
+
+    function Constant_Label_Reference
+           (Container : in Cursor;
+            Edge      : in Edge_Type)
+        return Edge_Label_Constant_Reference
+    renames Base.Constant_Label_Reference;
+
+    function Label_Reference
+           (Container : in Cursor;
+            Edge      : in Edge_Type)
+        return Edge_Label_Reference
+    renames Base.Label_Reference;
+
+    function Has_Label
+           (Position : in Cursor)
+        return Boolean
+    renames Base.Has_Label;
+
+    function Has_Label
+           (Container : in Cursor;
+            Edge      : in Edge_Type)
+        return Boolean
+    renames Base.Has_Label;
+
+    function Label
+           (Position : in Cursor)
+        return Node_Label_Type
+    renames Base.Label;
+
+    function Label
+           (Container : in Cursor;
+            Edge      : in Edge_Type)
+        return Edge_Label_Type
+    renames Base.Label;
+
+    function Neighbors
+           (Position : in Cursor)
+        return Node_Array
+    renames Base.Neighbors;
+
+    function Parents
+           (Position : in Cursor)
+        return Node_Array
+    renames Base.Parents;
+
+    function Children
+           (Position : in Cursor)
+        return Node_Array
+    renames Base.Children;
+
+    function Outbound
+           (Position : in Cursor)
+        return Edge_Array
+    renames Base.Outbound;
+
+    function Inbound
+           (Position : in Cursor)
+        return Edge_Array
+    renames Base.Inbound;
+
+    function Between
+           (Parent, Child : in Cursor)
+        return Edge_Array
+    renames Base.Between;
+
+    function Outdegree
+           (Position : in Cursor)
+        return Ada.Containers.Count_Type
+    renames Base.Outdegree;
+
+    function Indegree
+           (Position : in Cursor)
+        return Ada.Containers.Count_Type
+    renames Base.Indegree;
+
+    function Degree
+           (Position : in Cursor)
+        return Ada.Containers.Count_Type
+    renames Base.Degree;
+
+    function Has_Edge
+           (Parent, Child : in Cursor)
+        return Boolean
+    renames Base.Has_Edge;
+
+    function Has_Labeled_Edge
+           (Parent, Child : in Cursor)
+        return Boolean
+    renames Base.Has_Labeled_Edge;
+
+    function Has_Neighbor
+           (Left, Right : in Cursor)
+        return Boolean
+    renames Base.Has_Neighbor;
+
+    function Find_In_Subgraph
+           (Position : in Cursor;
+            Label    : in Node_Label_Type)
+        return Node_Array
+    renames Base.Find_In_Subgraph;
+
+    function Find_In_Subgraph
+           (Position : in Cursor;
+            Label    : in Edge_Label_Type)
+        return Edge_Array
+    renames Base.Find_In_Subgraph;
+
+    function Contains_In_Subgraph
+           (Position : in Cursor;
+            Node     : in Extended_Node_ID_Type)
+        return Boolean
+    renames Base.Contains_In_Subgraph;
+
+    function Contains_In_Subgraph
+           (Position : in Cursor;
+            Node     : in Extended_Node_ID_Type;
+            Label    : in Node_Label_Type)
+        return Boolean
+    renames Base.Contains_In_Subgraph;
+
+    function Contains_In_Subgraph
+           (Position : in Cursor;
+            Edge_ID  : in Edge_ID_Type)
+        return Boolean
+    renames Base.Contains_In_Subgraph;
+
+    function Contains_In_Subgraph
+           (Position : in Cursor;
+            Edge     : in Edge_Type)
+        return Boolean
+    renames Base.Contains_In_Subgraph;
+
+    function Contains_In_Subgraph
+           (Position : in Cursor;
+            Edge     : in Edge_Type;
+            Label    : in Edge_Label_Type)
+        return Boolean
+    renames Base.Contains_In_Subgraph;
+
+    function Contains_Label_In_Subgraph
+           (Position : in Cursor;
+            Label    : in Node_Label_Type)
+        return Boolean
+    renames Base.Contains_Label_In_Subgraph;
+
+    function Contains_Label_In_Subgraph
+           (Position : in Cursor;
+            Label    : in Edge_Label_Type)
+        return Boolean
+    renames Base.Contains_Label_In_Subgraph;
+
+    function Next
+           (Position : in Cursor)
+        return Cursor
+    renames Base.Next;
+
+    procedure Next
+           (Position : in out Cursor)
+    renames Base.Next;
+
+    function Previous
+           (Position : in Cursor)
+        return Cursor
+    renames Base.Previous;
+
+    procedure Previous
+           (Position : in out Cursor)
+    renames Base.Previous;
+
+    function Follow
+           (Position : in Cursor;
+            Edge     : in Edge_Type)
+        return Cursor
+    renames Base.Follow;
+
+    function Cursor_To
+           (Position : in Cursor;
+            Node     : in Node_ID_Type)
+        return Cursor
+    renames Base.Cursor_To;
+
+
+
+
+private
+
+
+    type Parse_Graph is new Base.Graph with record
+        Root_Node : Extended_Node_ID_Type := No_Node;
+    end record;
+
+    Empty_Graph : constant Parse_Graph :=
+        (Base.Empty_Graph with Root_Node => No_Node);
+
+
+
+
+    package Node_Vectors is new Ada.Containers.Vectors
+       (Index_Type   => Positive,
+        Element_Type => Node_ID_Type);
+
+    package Cursor_Vectors is new Ada.Containers.Vectors
+       (Index_Type   => Positive,
+        Element_Type => Cursor);
+
+    package Finish_Vectors is new Ada.Containers.Vectors
+       (Index_Type   => Positive,
+        Element_Type => Finish_Type);
+
+    package Finsort is new Finish_Vectors.Generic_Sorting;
+
+
+
+
+    generic
+        type Base_Type is private;
+        type Array_Type is array (Positive range <>) of Base_Type;
+        with package Type_Vectors is new Ada.Containers.Vectors
+           (Index_Type   => Positive,
+            Element_Type => Base_Type);
+    function Vector_To_Array
+           (Input : in Type_Vectors.Vector)
+        return Array_Type;
+
+
+end Packrat.Parse_Graphs;
+
+
-- 
cgit