From c29b11ef640b61331bf85ed489f14b155fc7a040 Mon Sep 17 00:00:00 2001 From: Vincent Jicquel Date: Thu, 4 Apr 2024 12:53:12 +0200 Subject: [PATCH] Implement a directed graph and its iterator MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This implementation comes initially from the one in gpr2 (GPR2.View_Ids.DAGs) and from e3-core (src/e3/collection/dag.py). Each node in the graph is identified by a node ID and can have other nodes as predecessors. Acyclic graphs can be iterated with an iterator that can be external or internal to the graph. Each graph node supports three different states during an iteration: non-visited, visiting and visited: * Non_Visited : The node has not been iterated. * Visiting : The node has been iterated but it has not been processed by the graph iterator caller. Use the "Complete" procedure to go from the "Visiting" to the "Visited" state. * Visited : The node has been iterated and processed. However, it is also possible to only keep the non-visited and visited states to simplify the process. Nodes can be added or their predecessors updated during an iteration. Notice that a node can not be removed, for simplicity and efficiency. Co-authored-by: Nicolas Roche --- src/gnatcoll-directed_graph.adb | 697 +++++++++++++++++++++++ src/gnatcoll-directed_graph.ads | 304 ++++++++++ testsuite/tests/directed_graph/test.adb | 427 ++++++++++++++ testsuite/tests/directed_graph/test.yaml | 2 + 4 files changed, 1430 insertions(+) create mode 100644 src/gnatcoll-directed_graph.adb create mode 100644 src/gnatcoll-directed_graph.ads create mode 100644 testsuite/tests/directed_graph/test.adb create mode 100644 testsuite/tests/directed_graph/test.yaml diff --git a/src/gnatcoll-directed_graph.adb b/src/gnatcoll-directed_graph.adb new file mode 100644 index 00000000..0c2d827b --- /dev/null +++ b/src/gnatcoll-directed_graph.adb @@ -0,0 +1,697 @@ +-- +-- Copyright (C) 2024, AdaCore +-- +-- SPDX-License-Identifier: Apache-2.0 WITH LLVM-Exception +-- + +with Ada.Containers.Ordered_Maps; + +package body GNATCOLL.Directed_Graph is + + use type Ada.Containers.Count_Type; + + package Node_Int_Maps is new Ada.Containers.Ordered_Maps (Node_Id, Natural); + subtype Node_Int_Map is Node_Int_Maps.Map; + + function Allocate_Node (Self : in out Directed_Graph) return Node_Id; + -- Allocate a new node and return its ID + + function Min (List : Node_Sets.Set; Map : Node_Int_Map) return Node_Id; + -- Return the key that corresponds to the minimum value in the map + + procedure Update_Cached_Data (Self : in out Directed_Graph); + -- Compute the topological sort, store it in a cache and detect cycles. + -- If cycles are detected, then the topological sort is aborted. + + procedure Internal_Add_Predecessor + (Self : in out Directed_Graph; Node : Node_Id; Predecessor : Node_Id) + with Inline => True; + -- Add a predecessor to a given node. Note that this is the responsability + -- of the caller to check node validity. + + function Contains (Self : Directed_Graph; Nodes : Node_Set) + return Boolean + with Inline => True; + + procedure Increment (N : in out Natural) + with Inline_Always => True; + + -------------- + -- Add_Node -- + -------------- + + function Add_Node + (Self : in out Directed_Graph; + Predecessors : Node_Set := Empty_Node_Set) + return Node_Id + is + begin + -- Perform all checks before inclusion + + if not Self.Contains (Predecessors) then + raise DG_Error with "Invalid predecessors"; + end if; + + -- Prerequisites are met, node can be created safely + + declare + Node : constant Node_Id := Self.Allocate_Node; + begin + for Predecessor of Predecessors loop + Self.Internal_Add_Predecessor (Node, Predecessor); + end loop; + + return Node; + end; + end Add_Node; + + function Add_Node + (Self : in out Directed_Graph; + Predecessors : Node_Array) return Node_Id + is + begin + -- Perform all checks before inclusion + + for Pred of Predecessors loop + if not Self.Contains (Pred) then + raise DG_Error with "Invalid predecessors"; + end if; + end loop; + + -- Prerequisites are met, node can be created safely + + declare + Node : constant Node_Id := Self.Allocate_Node; + begin + -- Add them + + for Pred of Predecessors loop + Self.Internal_Add_Predecessor (Node, Pred); + end loop; + + return Node; + end; + end Add_Node; + + --------------------- + -- Add_Predecessor -- + --------------------- + + procedure Add_Predecessor + (Self : in out Directed_Graph; + Node : Node_Id; + Predecessor : Node_Id) + is + begin + if not Self.Contains (Node) then + raise DG_Error with "Non existing node"; + end if; + + if not Self.Contains (Predecessor) then + raise DG_Error with "Invalid predecessor"; + end if; + + if Predecessor = Node then + raise DG_Error with "Predecessor cannot be the node itself"; + end if; + + Self.Internal_Add_Predecessor (Node, Predecessor); + Self.Is_Cache_Valid := False; + end Add_Predecessor; + + ---------------------- + -- Add_Predecessors -- + ---------------------- + + procedure Add_Predecessors + (Self : in out Directed_Graph; + Node : Node_Id; + Predecessors : Node_Set := Empty_Node_Set) + is + begin + if not Self.Contains (Node) then + raise DG_Error with "Non existing node"; + end if; + + if not Self.Contains (Predecessors) then + raise DG_Error with "Invalid predecessors"; + end if; + + if Predecessors.Contains (Node) then + raise DG_Error with "Predecessor cannot be the node itself"; + end if; + + for Pred of Predecessors loop + Self.Internal_Add_Predecessor (Node, Pred); + end loop; + + Self.Is_Cache_Valid := False; + end Add_Predecessors; + + -------------------- + -- Allocate_Node -- + -------------------- + + function Allocate_Node + (Self : in out Directed_Graph) return Node_Id + is + Node : Node_Id; + begin + if Self.Next_Free_Node = No_Node then + raise DG_Error + with "Graph cannot contain more than 2 ^ 32 - 1 element"; + end if; + + Node := Self.Next_Free_Node; + + if Self.Next_Free_Node < Node_Id'Last then + Self.Next_Free_Node := Self.Next_Free_Node + 1; + else + -- The maximum number of nodes has been reached + + Self.Next_Free_Node := No_Node; + end if; + + -- As no deletion is allowed doing an append to Predecessors and + -- Successors works. + + Self.Predecessors.Append (Empty_Node_Set); + Self.Successors.Append (Empty_Node_Set); + + Self.Is_Cache_Valid := False; + + return Node; + end Allocate_Node; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Self : in out Directed_Graph) is + begin + Self.Next_Free_Node := First_Free_Node; + Self.Predecessors.Clear; + Self.Successors.Clear; + Self.Sort_Cache.Clear; + Self.Is_Cache_Valid := True; + Self.Iterator.Started := False; + end Clear; + + -------------------- + -- Complete_Visit -- + -------------------- + + procedure Complete_Visit + (Self : in out DAG_Iterator'Class; + Graph : Directed_Graph'Class; + Node : Node_Id) + is + begin + + -- Note that if the node is not in either Non_Visited or Visiting then + -- it means the node has been visited. + + if Self.Non_Visited.Contains (Node) then + raise DG_Error + with "node" & Node'Img & "cannot be marked visited"; + elsif Self.Visiting.Contains (Node) then + Self.Visiting.Delete (Node); + + for Successor of Graph.Successors (Positive (Node)) loop + Increment (Self.Visited_Predecessors (Integer (Successor))); + end loop; + end if; + end Complete_Visit; + + procedure Complete_Visit + (Self : in out Directed_Graph'Class; Node : Node_Id) + is + begin + Complete_Visit (Self.Iterator, Self, Node); + end Complete_Visit; + + -------------- + -- Contains -- + -------------- + + function Contains (Self : Directed_Graph; Nodes : Node_Set) + return Boolean + is + begin + + -- As the graph structure does not support deletion of elements checking + -- the first and last element of an ordered set is enough to check set + -- validity. + + return Nodes.Length = 0 or else + (Self.Contains (Nodes.Last_Element) and then + Self.Contains (Nodes.First_Element)); + end Contains; + + function Contains (Self : Directed_Graph; Node : Node_Id) return Boolean + is + begin + return Node > 0 and then Node < Self.Next_Free_Node; + end Contains; + + --------------- + -- Has_Cycle -- + --------------- + + function Has_Cycle (Self : in out Directed_Graph) return Boolean + is + begin + if not Self.Is_Cache_Valid then + Self.Update_Cached_Data; + end if; + + return Self.Has_Cycle; + end Has_Cycle; + + --------------- + -- Increment -- + --------------- + + procedure Increment (N : in out Natural) is + begin + N := N + 1; + end Increment; + + ------------------------------ + -- Internal_Add_Predecessor -- + ------------------------------ + + procedure Internal_Add_Predecessor + (Self : in out Directed_Graph; Node : Node_Id; Predecessor : Node_Id) + is + begin + Self.Predecessors (Integer (Node)).Include (Predecessor); + Self.Successors (Integer (Predecessor)).Include (Node); + end Internal_Add_Predecessor; + + ---------------------- + -- Iterator_Started -- + ---------------------- + + function Iterator_Started (Self : DAG_Iterator'Class) return Boolean + is + begin + return Self.Started; + end Iterator_Started; + + function Iterator_Started (Self : Directed_Graph) return Boolean + is + begin + return Self.Iterator.Started; + end Iterator_Started; + + ------------ + -- Length -- + ------------ + + function Length (Self : Directed_Graph'Class) return Natural + is + begin + return Natural (Self.Next_Free_Node - 1); + end Length; + + --------- + -- Min -- + --------- + + function Min (List : Node_Sets.Set; Map : Node_Int_Map) return Node_Id + is + Result : Node_Id; + Value : Integer := Integer'Last; + begin + for Key of List loop + if Value > Map.Element (Key) then + Value := Map.Element (Key); + Result := Key; + end if; + end loop; + + return Result; + end Min; + + ---------- + -- Next -- + ---------- + + function Next + (Self : in out DAG_Iterator'Class; + Graph : Directed_Graph'Class; + Node : out Node_Id) + return Boolean + is + begin + Node := No_Node; + + -- Check if new nodes were added + + if Self.Graph_Next_Free_Node < Graph.Next_Free_Node then + for N in Self.Graph_Next_Free_Node .. Graph.Next_Free_Node - 1 loop + Self.Non_Visited.Include (N); + declare + Visited_Pred : Integer := 0; + begin + -- Update the number of visited predecessors for the new nodes + + for Pred of Graph.Predecessors (Integer (N)) loop + if not Self.Non_Visited.Contains (Pred) and then + not Self.Visiting.Contains (Pred) + then + Visited_Pred := Visited_Pred + 1; + end if; + end loop; + + Self.Visited_Predecessors.Append (Visited_Pred); + end; + end loop; + + Self.Graph_Next_Free_Node := Graph.Next_Free_Node; + end if; + + -- If all nodes have been visited it means that we have reached the + -- end of the iteration. + + if Node_Sets.Length (Self.Non_Visited) = 0 then + Node := No_Node; + + return False; + end if; + + -- Otherwise try to find a node for which all predecessors have been + -- visited. + + for N of Self.Non_Visited loop + if Integer (Graph.Predecessors (Integer (N)).Length) + - Self.Visited_Predecessors (Integer (N)) = 0 + then + Node := N; + exit; + end if; + end loop; + + if Node = No_Node then + if not Self.Enable_Visiting_State then + + -- This means there is a cycle in the graph + + raise DG_Error with "cycle detected"; + else + return True; + end if; + end if; + + Self.Non_Visited.Delete (Node); + + if Self.Enable_Visiting_State then + Self.Visiting.Include (Node); + else + + -- Found vertex is not blocking anymore their successors + + for Successor_Node of Graph.Successors (Integer (Node)) loop + Increment (Self.Visited_Predecessors (Integer (Successor_Node))); + end loop; + end if; + + return True; + end Next; + + function Next + (Self : in out DAG_Iterator'Class; + Graph : Directed_Graph'Class) + return Node_Id + is + Status : Boolean; + pragma Unreferenced (Status); + + Result : Node_Id; + begin + Status := Next (Self, Graph => Graph, Node => Result); + + return Result; + end Next; + + function Next (Self : in out Directed_Graph'Class) return Node_Id is + begin + return Next (Self.Iterator, Self); + end Next; + + function Next + (Self : in out Directed_Graph'Class; Node : out Node_Id) return Boolean + is + begin + return Next (Self.Iterator, Self, Node); + end Next; + + --------------------- + -- Shortest_Cycle -- + --------------------- + + function Shortest_Cycle (Self : in out Directed_Graph) return Node_Vector + is + Result : Node_Vector; + begin + + if not Self.Is_Cache_Valid then + Self.Update_Cached_Data; + end if; + + if not Self.Has_Cycle then + return Empty_Node_Vector; + end if; + + for Node in 1 .. Self.Next_Free_Node - 1 loop + Result := Shortest_Path (Self, Node, Node); + if not Result.Is_Empty then + return Result; + end if; + end loop; + + raise DG_Error with "Has_Cycle set but no cycle found"; + end Shortest_Cycle; + + ------------------- + -- Shortest_Path -- + ------------------- + + function Shortest_Path + (Self : Directed_Graph; + Source, Target : Node_Id) return Node_Vectors.Vector + is + + package Node_Node_Maps is new Ada.Containers.Ordered_Maps + (Node_Id, Node_Id); + + Infinite : constant Natural := Natural (Self.Next_Free_Node); + -- Maximum distance between two vertices is the number of nodes in the + -- graph - 1, unless Source and Target are equal in which case the + -- maximum possible distance is the number of nodes. So infinity is + -- Length (Nodes) + 1. + + Dist : Node_Int_Map; + -- This map will keep track of minimal distance between vertices and the + -- source. + + Prev : Node_Node_Maps.Map; + -- This keeps track of the minimum distance + + Non_Visited : Node_Sets.Set; + -- Non visited nodes + + T_Node : Node_Id renames Target; + S_Node : Node_Id := Source; + + U, V : Node_Id; + Alt : Natural; + Result : Node_Vectors.Vector; + + begin + -- We use the Dijkstra algorithm to compute the shortest path. + -- Note that this is a slight variation so that the algorithm + -- can be used to compute shortest cycle on a given node. + + -- Initialize Dist: + + for Node in 1 .. Self.Next_Free_Node - 1 loop + if Node = T_Node then + -- Only known distance at startup + Dist.Insert (Node, 0); + else + Dist.Insert (Node, Infinite); + end if; + end loop; + + -- Initialize Prev: + + for Node in 1 .. Self.Next_Free_Node - 1 loop + Prev.Insert (Node, No_Node); + end loop; + + for Node in 1 .. Self.Next_Free_Node - 1 loop + Non_Visited.Insert (Node); + end loop; + + if S_Node = T_Node then + + -- If Source is equal to target, default Dijkstra algorithm does + -- not work. Add a fake node and use it as target. When iterating + -- on predecessors, replace all occurrences of sources to that node. + -- If we find a path between that node and the source, it means we + -- have our shortest cycle. + + Dist.Insert (No_Node, Infinite); + Prev.Insert (No_Node, No_Node); + Non_Visited.Insert (No_Node); + S_Node := No_Node; + end if; + + while not Non_Visited.Is_Empty loop + U := Min (Non_Visited, Dist); + Non_Visited.Delete (U); + + if U = S_Node then + + -- We found the shortest path + + exit; + + elsif U /= No_Node then + for U_Pred of Self.Predecessors (Integer (U)) loop + if S_Node = No_Node and then U_Pred = T_Node then + -- Handle cycle detection case + + V := No_Node; + else + V := U_Pred; + end if; + + Alt := Dist.Element (U) + 1; + + if Alt < Dist.Element (V) then + Dist.Replace (V, Alt); + Prev.Replace (V, U); + end if; + end loop; + end if; + end loop; + + if Dist.Element (S_Node) = Infinite then + + -- No path between source and target + + return Node_Vectors.Empty_Vector; + end if; + + U := S_Node; + Result.Append (Source); + + while Prev.Element (U) /= No_Node loop + U := Prev.Element (U); + Result.Append (U); + end loop; + + return Result; + end Shortest_Path; + + -------------------- + -- Start_Iterator -- + -------------------- + + procedure Start_Iterator + (Self : in out DAG_Iterator'Class; + Graph : Directed_Graph'Class; + Enable_Visiting_State : Boolean := False) + is + Non_Visited_Nodes : Node_Sets.Set := Node_Sets.Empty_Set; + Visited_Predecessors : Pred_Num_Vector := Empty_Pred_Num_Vector; + use Node_Sets; + begin + for Node_Id in 1 .. Graph.Next_Free_Node - 1 loop + Non_Visited_Nodes.Include (Node_Id); + end loop; + + -- ??? improve + + for Idx in 1 .. Graph.Next_Free_Node - 1 loop + Visited_Predecessors.Append (0); + end loop; + + Self.Non_Visited := Non_Visited_Nodes; + Self.Visiting := Empty_Node_Set; + Self.Visited_Predecessors := Visited_Predecessors; + Self.Graph_Next_Free_Node := Graph.Next_Free_Node; + Self.Enable_Visiting_State := Enable_Visiting_State; + Self.Started := True; + end Start_Iterator; + + procedure Start_Iterator + (Self : in out Directed_Graph; + Enable_Visiting_State : Boolean := False) + is + begin + Start_Iterator (Self.Iterator, Self, Enable_Visiting_State); + end Start_Iterator; + + ---------------------- + -- Topological_Sort -- + ---------------------- + + function Topological_Sort (Self : in out Directed_Graph) return Node_Vector + is + begin + if not Self.Is_Cache_Valid then + Self.Update_Cached_Data; + end if; + + return Self.Sort_Cache; + end Topological_Sort; + + ------------------------ + -- Update_Cached_Data -- + ------------------------ + + procedure Update_Cached_Data (Self : in out Directed_Graph) + is + Iterator : DAG_Iterator; + Node : Node_Id; + begin + Iterator.Start_Iterator + (Graph => Self, + Enable_Visiting_State => False); + Self.Sort_Cache.Clear; + + begin + while Next (Iterator, Self, Node) loop + Self.Sort_Cache.Append (Node); + end loop; + + Self.Has_Cycle := False; + exception + when DG_Error => + Self.Has_Cycle := True; + end; + + Self.Is_Cache_Valid := True; + end Update_Cached_Data; + + -------------------- + -- Visiting_Nodes -- + -------------------- + + function Visiting_Nodes (Self : DAG_Iterator'Class) return Node_Sets.Set + is + begin + return Self.Visiting.Copy; + end Visiting_Nodes; + + function Visiting_Nodes (Self : Directed_Graph) return Node_Sets.Set + is + begin + return Visiting_Nodes (Self.Iterator); + end Visiting_Nodes; + +end GNATCOLL.Directed_Graph; diff --git a/src/gnatcoll-directed_graph.ads b/src/gnatcoll-directed_graph.ads new file mode 100644 index 00000000..79158754 --- /dev/null +++ b/src/gnatcoll-directed_graph.ads @@ -0,0 +1,304 @@ +-- +-- Copyright (C) 2024, AdaCore +-- +-- SPDX-License-Identifier: Apache-2.0 WITH LLVM-Exception +-- + +with Ada.Containers.Vectors; +with Ada.Containers.Ordered_Sets; + +package GNATCOLL.Directed_Graph is + + DG_Error : exception; + + type Directed_Graph is tagged limited private; + -- An object representing a Direct Graph + + type DAG_Iterator is tagged limited private; + -- An iterator on a directed acyclic graph. Note that each graph contains + -- also its own iterator for convenience. + + type Node_Id is mod 2 ** 32 with Default_Value => 0; + -- A node identifier in a graph structure. Limiting to 2^32 - 1 nodes is + -- enough for all realistic case. + + No_Node : constant Node_Id := 0; + -- Special node id value used to represents the absence of node id + + package Node_Vectors is new Ada.Containers.Vectors (Positive, Node_Id); + subtype Node_Vector is Node_Vectors.Vector; + Empty_Node_Vector : constant Node_Vector := Node_Vectors.Empty_Vector; + + package Node_Sets is new Ada.Containers.Ordered_Sets (Node_Id); + subtype Node_Set is Node_Sets.Set; + Empty_Node_Set : constant Node_Set := Node_Sets.Empty_Set; + + type Node_Array is array (Natural range <>) of Node_Id; + + function Length (Self : Directed_Graph'Class) return Natural + with Inline => True; + -- Return the size of the graph (i.e the number of nodes) + + function Add_Node + (Self : in out Directed_Graph; + Predecessors : Node_Set := Empty_Node_Set) + return Node_Id; + -- Add a node to the graph and set its precedecessors. If the graph already + -- contains 2 ^ 32 - 1 elements raise DG_Error. Otherwise return the + -- Node_Id of the new node. + -- Predecessors should contain only node ids of existing nodes. + + function Add_Node + (Self : in out Directed_Graph; + Predecessors : Node_Array) + return Node_Id; + -- Same as previous function except that Predecessors are passed in an + -- array. Note that duplicate Node_Ids in Predecessors are ignored. + + procedure Add_Predecessors + (Self : in out Directed_Graph; + Node : Node_Id; + Predecessors : Node_Set := Empty_Node_Set); + -- Add predecessors to an existing node. All node ids should refer to + -- existing nodes. + + procedure Add_Predecessor + (Self : in out Directed_Graph; + Node : Node_Id; + Predecessor : Node_Id); + -- Add a predecessor to a node. Both nodes must belong to the graph + + function Contains (Self : Directed_Graph; Node : Node_Id) return Boolean + with Inline => True; + -- Return True if Self contains a node whose id is Node, False otherwise. + + function Has_Cycle (Self : in out Directed_Graph) return Boolean; + -- Return True if the graph contains at least one cycle. + + function Shortest_Cycle (Self : in out Directed_Graph) return Node_Vector; + -- Return the smallest circle, if any, or the empty vector + + function Topological_Sort (Self : in out Directed_Graph) return Node_Vector; + -- Return the list of nodes in a topological order + + function Shortest_Path + (Self : Directed_Graph; + Source, Target : Node_Id) + return Node_Vector; + -- Compute the shortest path between two vertices of the graph. + -- If target equals to Source then the algorithm tries to find the + -- shortest cycle including Source. + -- If there is no path between the two vertices, then the return value is + -- an empty vector. + + procedure Clear (Self : in out Directed_Graph); + -- Reset the graph by removing all the nodes and stop its iterator if + -- needed. + + -------------- + -- Iterator -- + -------------- + + procedure Start_Iterator + (Self : in out DAG_Iterator'Class; + Graph : Directed_Graph'Class; + Enable_Visiting_State : Boolean := False); + -- Initialize an iterator for the specified graph. If + -- Enable_Visiting_State is set, then nodes states go through an + -- intermediate state "Visiting" after the "Non_Visited" one. Nodes with + -- the "Visiting" state are still blocking their predecessors but are not + -- returned anymore by the Next function. + -- The function "Complete" must be called to go from "Visiting" to + -- "Visited" state. This mechanism can be useful for parallel tasking, as + -- we do not want one task to keep going forward before one of its + -- predecessor has not completed. + -- If the iterator is already started, then it is restarted from scratch. + + function Next + (Self : in out DAG_Iterator'Class; + Graph : Directed_Graph'Class; + Node : out Node_Id) + return Boolean; + -- Update the iterator to the next state. + -- + -- The output is one of the following: + -- + -- 1- The function returns False. This means that the end of the iteration + -- has been reached. In that case Node is always set to No_Node. + -- 2- The function returns True and Node is different from No_Node. In that + -- case the node state is set to "visiting" or "visited" depending on + -- how the iterator was initialized. + -- 3- The function returns True and Node is set to No_Node. This case only + -- occurs when Enable_Visiting_State is set to True. This means that + -- some nodes are in the visiting state and prevent the visiting of new + -- nodes. The function will return No_Node until the some of the + -- "visiting" nodes are marked as visited using Compilte_Visit method + + function Next + (Self : in out DAG_Iterator'Class; + Graph : Directed_Graph'Class) + return Node_Id; + -- Update the iterator to the next state. + -- + -- Return the next available node and set its state as visited or visiting + -- (see Enable_Visiting_State parameter of Start_Iterator). + -- + -- If Enable_Visiting_State was set to False the function will return + -- No_Node on end of iteration + -- If Enable_Visiting_State was set to True, then the function return + -- No_Node on end of iteration or when some nodes in visiting state are + -- blocking the visit of newer node. To do the distinction between the two + -- state, calling Visiting_Nodes should be done. If the return set of + -- visiting nodes is empty then it means that end of iteration was reached. + + procedure Complete_Visit + (Self : in out DAG_Iterator'Class; + Graph : Directed_Graph'Class; + Node : Node_Id); + -- Mark the current vertex as "Visited". Has no effect if the vertex + -- state was not "Visiting". + + function Visiting_Nodes (Self : DAG_Iterator'Class) return Node_Set; + -- Return the list of the Visiting nodes + + function Iterator_Started (Self : DAG_Iterator'Class) return Boolean + with Inline => True; + -- Return True if the iterator has been started + + ----------------------- + -- Internal Iterator -- + ----------------------- + + -- Same iterator interface except that the graph's internal iterator + -- is used. + + procedure Start_Iterator + (Self : in out Directed_Graph; + Enable_Visiting_State : Boolean := False); + -- Initialize the iterator embedded with the graph. If + -- Enable_Visiting_State is set, then nodes states go through an + -- intermediate state "Visiting" after the "Non_Visited" one. Nodes with + -- the "Visiting" state are still blocking their predecessors but are not + -- returned anymore by the Next function. + -- The function "Complete" must be called to go from "Visiting" to + -- "Visited" state. This mechanism can be useful for parallel tasking, as + -- we do not want one task to keep going forward before one of its + -- predecessor has not completed. + -- If the iterator is already started, then it is restarted from scratch. + + function Next + (Self : in out Directed_Graph'Class; Node : out Node_Id) return Boolean; + -- Update the internal iterator to the next state. + -- + -- The output is one of the following: + -- + -- 1- The function returns False. This means that the end of the iteration + -- has been reached. In that case Node is always set to No_Node. + -- 2- The function returns True and Node is different from No_Node. In that + -- case the node state is set to "visiting" or "visited" depending on + -- how the iterator was initialized. + -- 3- The function returns True and Node is set to No_Node. This case only + -- occurs when Enable_Visiting_State is set to True. This means that + -- some nodes are in the visiting state and prevent the visiting of new + -- nodes. The function will return No_Node until the some of the + -- "visiting" nodes are marked as visited using Compilte_Visit method + + function Next (Self : in out Directed_Graph'Class) return Node_Id; + -- Update the internal iterator to the next state. + -- + -- Return the next available node and set its state as visited or visiting + -- (see Enable_Visiting_State parameter of Start_Iterator). + -- + -- If Enable_Visiting_State was set to False the function will return + -- No_Node on end of iteration + -- If Enable_Visiting_State was set to True, then the function return + -- No_Node on end of iteration or when some nodes in visiting state are + -- blocking the visit of newer node. To do the distinction between the two + -- state, calling Visiting_Nodes should be done. If the return set of + -- visiting nodes is empty then it means that end of iteration was reached. + + procedure Complete_Visit + (Self : in out Directed_Graph'Class; Node : Node_Id); + -- Mark the current vertex as "Visited" within the internal iterator. + -- Has no effect if the vertex state was not "Visiting". + + function Visiting_Nodes (Self : Directed_Graph) return Node_Set; + -- Return the list of the Visiting nodes for the internal iterator + + function Iterator_Started (Self : Directed_Graph) return Boolean; + -- Return True if the internal iterator has been started + +private + + package Node_Set_Vectors is new Ada.Containers.Vectors + (Positive, Node_Set, "=" => Node_Sets."="); + subtype Node_Set_Vector is Node_Set_Vectors.Vector; + Empty_Node_Set_Vector : constant Node_Set_Vector := + Node_Set_Vectors.Empty_Vector; + + package Pred_Num_Vectors is new Ada.Containers.Vectors (Positive, Natural); + subtype Pred_Num_Vector is Pred_Num_Vectors.Vector; + Empty_Pred_Num_Vector : constant Pred_Num_Vector := + Pred_Num_Vectors.Empty_Vector; + + First_Free_Node : constant := 1; + + type State is (Non_Visited, Visiting, Visited); + -- Non_Visited : The vertex has not been iterated. + -- Visiting : Only used when Enable_Visiting_State is set. The vertex + -- has been iterated but it has not been processed by the + -- graph iterator caller. Use the "Complete" procedure to go + -- from the "Visiting" to the "Visited" state. + -- Visited : The vertex has been iterated and processed. + + type DAG_Iterator is tagged limited record + + Non_Visited : Node_Set := Empty_Node_Set; + -- Nodes that have not been visited yet + + Visiting : Node_Set := Empty_Node_Set; + -- Nodes that are currently in visiting state + + Visited_Predecessors : Pred_Num_Vector := Empty_Pred_Num_Vector; + -- For each node of the graph, the number of predecessors that have been + -- visited. + + Graph_Next_Free_Node : Node_Id := No_Node; + -- Used to detect addition of new nodes in the Graph linked to the + -- iterator. + + Enable_Visiting_State : Boolean := False; + -- Indicate if there is an intermediate state "Visiting" between the + -- "Non_Visited" and "Visited" ones. + + Started : Boolean := False; + + end record; + + type Directed_Graph is tagged limited record + Predecessors : Node_Set_Vector; + -- Set of predecessors for each node + + Successors : Node_Set_Vector; + -- Set of successors for each node + + Next_Free_Node : Node_Id := First_Free_Node; + -- Next available Node_Id. As no deletion is permitted + -- Next_Free_Node - 1 represents also the number of nodes in the graph. + + -- The following two attributes are cached on first computation + Sort_Cache : Node_Vectors.Vector; + -- One topological sort of the graph's nodes + + Has_Cycle : Boolean := False; + -- Whether the graph contains a cycle + + Is_Cache_Valid : Boolean := True; + -- Whether the Sort_Cache is valid. True by default with everything + -- empty. + + Iterator : DAG_Iterator; + -- Internal iterator + end record; + +end GNATCOLL.Directed_Graph; diff --git a/testsuite/tests/directed_graph/test.adb b/testsuite/tests/directed_graph/test.adb new file mode 100644 index 00000000..e5009a0b --- /dev/null +++ b/testsuite/tests/directed_graph/test.adb @@ -0,0 +1,427 @@ +with GNATCOLL.Directed_Graph; use GNATCOLL.Directed_Graph; +with Ada.Exceptions; use Ada.Exceptions; +with Ada.Assertions; use Ada.Assertions; +with Test_Assert; + +function Test return Integer is + + package A renames Test_Assert; + use Node_Vectors; + use Node_Sets; + + G : Directed_Graph; + N1, N2, N3, N4, N5 : Node_Id; + N : Node_Id; + S : Node_Set; +begin + -- Test Add_node method + N1 := G.Add_Node; + A.Assert (G.Contains (N1)); + + -- Check that we cannot add a node with predecessor including itself + -- This test makes assumption about how Node_Id are allocated + begin + N2 := G.Add_Node (Predecessors => (1 => 2)); + A.Assert (False, "Exception not raised"); + exception + when DG_Error => + A.Assert (True); + when others => + A.Assert (False, "Unknown exception"); + end; + + begin + S.Clear; + S.Include (2); + N2 := G.Add_Node (Predecessors => S); + A.Assert (False, "Exception not raised"); + exception + when DG_Error => + A.Assert (True); + when others => + A.Assert (False, "Unknown exception"); + end; + + -- Check that we cannot add non existing nodes as predecessors + begin + N2 := G.Add_Node (Predecessors => (5, 6)); + A.Assert (False, "Exception not raised"); + exception + when DG_Error => + A.Assert (True); + when others => + A.Assert (False, "Unknown exception"); + end; + + begin + S.Clear; + S.Include (5); + S.Include (6); + N2 := G.Add_Node (Predecessors => S); + A.Assert (False, "Exception not raised"); + exception + when DG_Error => + A.Assert (True); + when others => + A.Assert (False, "Unknown exception"); + end; + + -- At this all node additions have failed except the first one. A failure + -- on this test probably means that the pre-condition checks are done after + -- allocating a new node. + A.Assert (G.Length, 1); + + -- Add nodes with valid dependencies with both array and sets + N2 := G.Add_Node (Predecessors => (1 => N1)); + N3 := G.Add_Node (Predecessors => (1 => N2)); + + S.Clear; + S.Include (N3); + N4 := G.Add_Node (Predecessors => S); + A.Assert (G.Contains (N4)); + + -- Test Add_Predecessor(s) functions + N5 := G.Add_Node; + + -- Cannot add a node in its own predecessors + begin + S.Clear; + S.Include (N5); + G.Add_Predecessors (N5, S); + A.Assert (False, "Exception not raised"); + exception + when DG_Error => + A.Assert (True); + when others => + A.Assert (False, "Unknown exception"); + end; + + begin + G.Add_Predecessor (N5, N5); + A.Assert (False, "Exception not raised"); + exception + when DG_Error => + A.Assert (True); + when others => + A.Assert (False, "Unknown exception"); + end; + + -- Cannot add No_Node as predecessors + begin + S.Clear; + S.Include (No_Node); + S.Include (N4); + G.Add_Predecessors (N5, S); + A.Assert (False, "Exception not raised"); + exception + when E : DG_Error => + A.Assert (True, Exception_Message (E)); + when others => + A.Assert (False, "Unknown exception"); + end; + + -- All nodes should exist + begin + G.Add_Predecessor (N5, 10); + A.Assert (False, "Exception not raised"); + exception + when DG_Error | Assertion_Error => + A.Assert (True); + when E : others => + A.Assert (False, "Unknown exception: " & + Exception_Name (E) & " " & Exception_Message (E)); + end; + + begin + G.Add_Predecessor (10, N5); + A.Assert (False, "Exception not raised"); + exception + when DG_Error | Assertion_Error => + A.Assert (True); + when E : others => + A.Assert (False, "Unknown exception: " & Exception_Message (E)); + end; + + -- All nodes should exist + declare + Predecessors : Node_Set := Empty_Node_Set; + begin + Predecessors.Include (10); + G.Add_Predecessors (N5, Predecessors); + A.Assert (False, "Exception not raised"); + exception + when DG_Error | Assertion_Error => + A.Assert (True); + when E : others => + A.Assert (False, "Unknown exception: " & + Exception_Name (E) & " " & Exception_Message (E)); + end; + + declare + Predecessors : Node_Set := Empty_Node_Set; + begin + Predecessors.Include (N5); + G.Add_Predecessors (10, Predecessors); + A.Assert (False, "Exception not raised"); + exception + when DG_Error | Assertion_Error => + A.Assert (True); + when E : others => + A.Assert (False, "Unknown exception: " & Exception_Message (E)); + end; + + declare + Predecessors : Node_Set := Empty_Node_Set; + begin + Predecessors.Include (N4); + G.Add_Predecessors (N5, Predecessors); + end; + + -- N1 -> N2 -> N3 -> N4 -> N5 + A.Assert (not G.Has_Cycle); + A.Assert (G.Shortest_Cycle = Empty_Node_Vector); + + declare + Expected : constant Node_Vector := N1 & N2 & N3 & N4 & N5; + begin + -- Topological view + + A.Assert (Expected = G.Topological_Sort); + end; + + G.Start_Iterator (False); + A.Assert (G.Next (N) and then N = N1); + A.Assert (G.Next (N) and then N = N2); + A.Assert (G.Next (N) and then N = N3); + A.Assert (G.Next (N) and then N = N4); + A.Assert (G.Next (N) and then N = N5); + A.Assert (not G.Next (N) and then N = No_Node); + + G.Start_Iterator (False); + A.Assert (G.Next = N1); + A.Assert (G.Next = N2); + A.Assert (G.Next = N3); + A.Assert (G.Next = N4); + A.Assert (G.Next = N5); + A.Assert (G.Next = No_Node); + + declare + Iter : DAG_Iterator; + begin + Iter.Start_Iterator (G, False); + G.Start_Iterator (False); + A.Assert (Iter.Next (G) = N1); + A.Assert (Iter.Next (G) = N2); + A.Assert (Iter.Next (G) = N3); + A.Assert (Iter.Next (G) = N4); + A.Assert (Iter.Next (G) = N5); + A.Assert (Iter.Next (G) = No_Node); + end; + + -- Create a loop in the graph + -- N1 -> N2 -> N3 -> N4 -> N1 + -- -> N5 + + declare + Cycle : Node_Vector; + S : Node_Set; + Expected_Short_Cycle : Node_Set; + begin + Expected_Short_Cycle.Include (N1); + Expected_Short_Cycle.Include (N2); + Expected_Short_Cycle.Include (N3); + Expected_Short_Cycle.Include (N4); + + G.Add_Predecessor (N1, N4); + + A.Assert (G.Has_Cycle); + A.Assert (G.Topological_Sort = Node_Vectors.Empty_Vector); + Cycle := G.Shortest_Cycle; + for N of Cycle loop + S.Include (N); + end loop; + A.Assert (S = Expected_Short_Cycle); + end; + + -- When Enable_Visiting_State is not set, cycles are also detected during + -- the graph iteration. + + begin + declare + Node : Node_Id; + Status : Boolean; + begin + + G.Start_Iterator (False); + Status := G.Next (Node); + + -- Exception shall have been raised during the previous Next + + A.Assert (False, "Next returned " & Status'Img & "Node=" & Node'Img); + end; + exception + when others => + A.Assert (True); + + end; + + -- Reset the graph + G.Clear; + + -- ->N2-- + -- / \ + -- N1 N4 + -- \ / + -- ->N3-- + + N1 := G.Add_Node; + N2 := G.Add_Node (Predecessors => (1 => N1)); + N3 := G.Add_Node (Predecessors => (1 => N1)); + N4 := G.Add_Node (Predecessors => (N3, N2)); + + -- Visiting state disabled + + declare + Node : Node_Id; + Status : Boolean; + begin + A.Assert (not G.Iterator_Started); + G.Start_Iterator (False); + A.Assert (G.Iterator_Started); + + A.Assert (G.Next (Node) and then Node = N1); + A.Assert (G.Visiting_Nodes = Node_Sets.Empty_Set); + + for Unused in 1 .. 2 loop + Status := G.Next (Node); + A.Assert (Status and then (Node = N2 or else Node = N3)); + end loop; + + A.Assert (G.Next (Node) and then Node = N4); + A.Assert (not G.Next (Node) and then Node = No_Node); + end; + + -- Visiting state enabled + + declare + Save_1, Save_2, Node : Node_Id; + Status : Boolean; + begin + + G.Start_Iterator (True); + + A.Assert (G.Next (Node) and then Node = N1); + + A.Assert (G.Next (Node) and Node = No_Node); + G.Complete_Visit (N1); + + -- Check that we can not complete a non-visited node + + begin + G.Complete_Visit (N4); + A.Assert (False, "Exception not raised"); + exception + when DG_Error | Assertion_Error => + A.Assert (True); + when E : others => + A.Assert (False, "Unknown exception: " & Exception_Message (E)); + end; + + Status := G.Next (Save_1); + A.Assert (Status and then (Save_1 = N2 or else Save_1 = N3)); + Status := G.Next (Save_2); + A.Assert (Status and then (Save_2 = N2 or else Save_2 = N3)); + + for Visiting_Node of G.Visiting_Nodes loop + A.Assert (Visiting_Node = N2 or else Visiting_Node = N3); + end loop; + + -- Visiting nodes need to be left + + A.Assert (G.Next (Node) and then Node = No_Node); + G.Complete_Visit (Save_1); + A.Assert (G.Next (Node) and then Node = No_Node); + A.Assert (G.Visiting_Nodes.First_Element = Save_2); + + G.Complete_Visit (Save_2); + A.Assert (G.Visiting_Nodes = Node_Sets.Empty_Set); + + -- Check that completing an already visited node has no effect + + G.Complete_Visit (Save_2); + + -- Last job is now available + + A.Assert (G.Next (Node) and then Node = N4); + A.Assert (not G.Next (Node) and then Node = No_Node); + end; + + -- Test node addition during an iteration + + declare + Node : Node_Id; + begin + G.Clear; + + -- N1 --> N2 --> N3 + -- \ + -- ---> N4 + + N1 := G.Add_Node; + N2 := G.Add_Node (Predecessors => (1 => N1)); + N3 := G.Add_Node (Predecessors => (1 => N2)); + N4 := G.Add_Node (Predecessors => (1 => N1)); + + G.Start_Iterator (True); + + A.Assert (G.Next (Node) and then Node = N1); + G.Complete_Visit (N1); + A.Assert (G.Next (Node) and then Node = N2); + G.Complete_Visit (N2); + + -- N1 --> N2 -------> N3 + -- |\--> N4 ------/ + -- | \ / + -- \-----> N5 -/ + + N5 := G.Add_Node (Predecessors => (N1, N4)); + G.Add_Predecessor (N3, N5); + + A.Assert (G.Next (Node) and then Node = N4); + A.Assert (G.Next (Node) and then Node = No_Node); + G.Complete_Visit (N4); + + A.Assert (G.Next (Node) and then Node = N5); + A.Assert (G.Next (Node) and then Node = No_Node); + G.Complete_Visit (N5); + + A.Assert (G.Next (Node) and then Node = N3); + G.Complete_Visit (N3); + + A.Assert (not G.Next (Node) and then Node = No_Node); + end; + + -- Test shortest path + + G.Clear; + + -- N1 ----------> N2 --> N3 + -- \ / + -- ---> N4 -> N5 + + N1 := G.Add_Node; + N4 := G.Add_Node (Predecessors => (1 => N1)); + N5 := G.Add_Node (Predecessors => (1 => N4)); + N2 := G.Add_Node (Predecessors => (N1, N5)); + N3 := G.Add_Node (Predecessors => (1 => N2)); + + declare + Expected : constant Node_Vector := N1 & N2 & N3; + begin + A.Assert (Expected = G.Shortest_Path (N1, N3)); + end; + + A.Assert (G.Shortest_Path (N3, N1) = Empty_Node_Vector); + + return A.Report; +end Test; diff --git a/testsuite/tests/directed_graph/test.yaml b/testsuite/tests/directed_graph/test.yaml new file mode 100644 index 00000000..a49f3f03 --- /dev/null +++ b/testsuite/tests/directed_graph/test.yaml @@ -0,0 +1,2 @@ +title: GNATCOLL.Directed_Graph +description: Test directed graphs and their iterators \ No newline at end of file