Can now output the basic structural DAG of a World in DOT format

6 files changed, 134 insertions, 34 deletions

diff --git a/src/kompsos-collector.adb b/src/kompsos-collector.adb
index 16e2b1f..c95453e 100644
--- a/src/kompsos-collector.adb
+++ b/src/kompsos-collector.adb
@@ -7,9 +7,7 @@
 
 with
 
-    Ada.Unchecked_Deallocation,
-    System.Address_To_Access_Conversions,
-    System.Storage_Elements;
+    Ada.Unchecked_Deallocation;
 
 
 package body Kompsos.Collector is
@@ -56,23 +54,6 @@ package body Kompsos.Collector is
     --  Internal Helpers  --
     ------------------------
 
-    --  Map Keys  --
-
-    package World_Convert is new System.Address_To_Access_Conversions (World_Component);
-
-    function "<"
-           (Left, Right : in World_Component_Access)
-        return Boolean
-    is
-        use System.Storage_Elements;
-    begin
-        return
-            To_Integer (World_Convert.To_Address (World_Convert.Object_Pointer (Left))) <
-            To_Integer (World_Convert.To_Address (World_Convert.Object_Pointer (Right)));
-    end "<";
-
-
-
     --  Unification  --
 
     function Fully_Contains
diff --git a/src/kompsos-collector.ads b/src/kompsos-collector.ads
index 4bca3b4..8743ecc 100644
--- a/src/kompsos-collector.ads
+++ b/src/kompsos-collector.ads
@@ -41,10 +41,6 @@ private
 
     type Constant_World_Access is access constant World;
 
-    function "<"
-           (Left, Right : in World_Component_Access)
-        return Boolean;
-
     type Eval_Kind is
        (Unify_Data,
         Disjunct_Data,
diff --git a/src/kompsos-pretty_print.adb b/src/kompsos-pretty_print.adb
index 834c0ca..8d11f81 100644
--- a/src/kompsos-pretty_print.adb
+++ b/src/kompsos-pretty_print.adb
@@ -87,8 +87,6 @@ package body Kompsos.Pretty_Print is
     end Image;
 
 
-
-
     function Image
            (Item : in State)
         return String
@@ -151,8 +149,6 @@ package body Kompsos.Pretty_Print is
     end Image;
 
 
-
-
     function Image
            (Item : in World)
         return String
@@ -175,6 +171,100 @@ package body Kompsos.Pretty_Print is
     end Image;
 
 
+
+
+    procedure Do_Structure_DOT
+           (This   : in     World;
+            Nodes  : in out DOT_Node_Maps.Map;
+            Next   : in out Long_Natural;
+            Result : in out SU.Unbounded_String) is
+    begin
+        if This.Actual = null or else Nodes.Contains (This.Actual) then
+            return;
+        end if;
+        Nodes.Insert (This.Actual, Next);
+        Next := Next + 1;
+        case This.Actual.Kind is
+        when Static_Node =>
+            SU.Append (Result, Latin.HT &
+                "n" & Image (Nodes.Element (This.Actual)) & " [label=""static""];" & Latin.LF);
+        when Fresh_Node =>
+            SU.Append (Result, Latin.HT &
+                "n" & Image (Nodes.Element (This.Actual)) & " [label=""fresh""];" & Latin.LF);
+            Do_Structure_DOT (This.Actual.Frs_World, Nodes, Next, Result);
+            if Nodes.Contains (This.Actual.Frs_World.Actual) then
+                SU.Append (Result, Latin.HT &
+                    "n" & Image (Nodes.Element (This.Actual)) & " -> " &
+                    "n" & Image (Nodes.Element (This.Actual.Frs_World.Actual)) & ";" & Latin.LF);
+            end if;
+        when Unify_Node =>
+            SU.Append (Result, Latin.HT &
+                "n" & Image (Nodes.Element (This.Actual)) & " [label=""unify""];" & Latin.LF);
+            Do_Structure_DOT (This.Actual.Uni_World, Nodes, Next, Result);
+            if Nodes.Contains (This.Actual.Uni_World.Actual) then
+                SU.Append (Result, Latin.HT &
+                    "n" & Image (Nodes.Element (This.Actual)) & " -> " &
+                    "n" & Image (Nodes.Element (This.Actual.Uni_World.Actual)) & ";" & Latin.LF);
+            end if;
+        when Disjunct_Node =>
+            SU.Append (Result, Latin.HT &
+                "n" & Image (Nodes.Element (This.Actual)) & " [label=""disjunct""];" & Latin.LF);
+            Do_Structure_DOT (This.Actual.Dis_World1, Nodes, Next, Result);
+            Do_Structure_DOT (This.Actual.Dis_World2, Nodes, Next, Result);
+            if Nodes.Contains (This.Actual.Dis_World1.Actual) then
+                SU.Append (Result, Latin.HT &
+                    "n" & Image (Nodes.Element (This.Actual)) & " -> " &
+                    "n" & Image (Nodes.Element (This.Actual.Dis_World1.Actual)) &
+                    " [label=""1""];" & Latin.LF);
+            end if;
+            if Nodes.Contains (This.Actual.Dis_World2.Actual) then
+                SU.Append (Result, Latin.HT &
+                    "n" & Image (Nodes.Element (This.Actual)) & " -> " &
+                    "n" & Image (Nodes.Element (This.Actual.Dis_World2.Actual)) &
+                    " [label=""2""];" & Latin.LF);
+            end if;
+        when Conjunct_Node =>
+            SU.Append (Result, Latin.HT &
+                "n" & Image (Nodes.Element (This.Actual)) & " [label=""conjunct""];" & Latin.LF);
+            Do_Structure_DOT (This.Actual.Con_World, Nodes, Next, Result);
+            if Nodes.Contains (This.Actual.Con_World.Actual) then
+                SU.Append (Result, Latin.HT &
+                    "n" & Image (Nodes.Element (This.Actual)) & " -> " &
+                    "n" & Image (Nodes.Element (This.Actual.Con_World.Actual)) & ";" & Latin.LF);
+            end if;
+        when Recurse_Node =>
+            SU.Append (Result, Latin.HT &
+                "n" & Image (Nodes.Element (This.Actual)) & " [label=""recurse""];" & Latin.LF);
+            Do_Structure_DOT (This.Actual.Rec_World, Nodes, Next, Result);
+            if Nodes.Contains (This.Actual.Rec_World.Actual) then
+                SU.Append (Result, Latin.HT &
+                    "n" & Image (Nodes.Element (This.Actual)) & " -> " &
+                    "n" & Image (Nodes.Element (This.Actual.Rec_World.Actual)) & ";" & Latin.LF);
+            end if;
+        end case;
+    end Do_Structure_DOT;
+
+
+    function Structure_DOT
+           (This : in World;
+            Name : in String := "")
+        return String
+    is
+        Result  : SU.Unbounded_String;
+        Nodes   : DOT_Node_Maps.Map;
+        Next_ID : Long_Natural := 0;
+    begin
+        SU.Append (Result, "digraph ");
+        if Name /= "" then
+            SU.Append (Result, Name & " ");
+        end if;
+        SU.Append (Result, "{" & Latin.LF);
+        Do_Structure_DOT (This, Nodes, Next_ID, Result);
+        SU.Append (Result, "}");
+        return SU.To_String (Result);
+    end Structure_DOT;
+
+
 end Kompsos.Pretty_Print;
 
 
diff --git a/src/kompsos-pretty_print.ads b/src/kompsos-pretty_print.ads
index 1316d5a..19da0af 100644
--- a/src/kompsos-pretty_print.ads
+++ b/src/kompsos-pretty_print.ads
@@ -6,6 +6,11 @@
 --  See license.txt for further details
 
 
+private with
+
+    Ada.Containers.Ordered_Maps;
+
+
 generic
     with function Element_Image
            (Item : in Element_Type)
@@ -17,27 +22,31 @@ package Kompsos.Pretty_Print is
            (Item : in Integer)
         return String;
 
-
     function Image
            (Item : in Term)
         return String;
 
-
     function Image
            (Item : in State)
         return String;
 
-
     function Image
            (Item : in State_Array)
         return String;
 
-
     function Image
            (Item : in World)
         return String;
 
 
+
+
+    function Structure_DOT
+           (This : in World;
+            Name : in String := "")
+        return String;
+
+
 private
 
 
@@ -45,12 +54,16 @@ private
            (Item : in Long_Natural)
         return String;
 
-
     function Image
            (Item : in Variable)
         return String;
 
 
+    package DOT_Node_Maps is new Ada.Containers.Ordered_Maps
+       (Key_Type     => World_Component_Access,
+        Element_Type => Long_Natural);
+
+
 end Kompsos.Pretty_Print;
 
 
diff --git a/src/kompsos.adb b/src/kompsos.adb
index e525f23..1fedb86 100644
--- a/src/kompsos.adb
+++ b/src/kompsos.adb
@@ -9,7 +9,9 @@
 with
 
     Ada.Unchecked_Deallocation,
-    Kompsos.Collector;
+    Kompsos.Collector,
+    System.Address_To_Access_Conversions,
+    System.Storage_Elements;
 
 
 package body Kompsos is
@@ -191,6 +193,20 @@ package body Kompsos is
 
     --  Worlds  --
 
+    package World_Convert is new System.Address_To_Access_Conversions (World_Component);
+
+    function "<"
+           (Left, Right : in World_Component_Access)
+        return Boolean
+    is
+        use System.Storage_Elements;
+    begin
+        return
+            To_Integer (World_Convert.To_Address (World_Convert.Object_Pointer (Left))) <
+            To_Integer (World_Convert.To_Address (World_Convert.Object_Pointer (Right)));
+    end "<";
+
+
     function Static
            (Item : in State)
         return World'Class
diff --git a/src/kompsos.ads b/src/kompsos.ads
index e9bbefd..15f61bb 100644
--- a/src/kompsos.ads
+++ b/src/kompsos.ads
@@ -559,6 +559,10 @@ private
 
     type World_Component_Access is access World_Component;
 
+    function "<"
+           (Left, Right : in World_Component_Access)
+        return Boolean;
+
     type Lazy_Kind is (Zero_Arg, One_Arg, Many_Arg);
 
     type Lazy_Data (Kind : Lazy_Kind) is record