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