-- with Ada.Text_IO; with WL.Heaps; package body WL.Graphs is ------------ -- Append -- ------------ procedure Append (Container : in out Graph; Vertex : Vertex_Type) is begin Container.Vertices.Append (Vertex_Info' (Vertex => Vertex, Index => Container.Vertices.Last_Index + 1, Edges => Edge_Lists.Empty_List)); Container.Vs.Append (Vertex); end Append; ------------ -- Append -- ------------ procedure Append (Sub : in out Sub_Graph; Index : Index_Type) is begin Sub.Vertex_List.Append (Index); Sub.Vertex_Flags.Replace_Element (Index, True); end Append; ------------ -- Append -- ------------ procedure Append (Collection : in out Sub_Graph_Collection; Sub : Sub_Graph) is begin Collection.Vector.Append (Sub); end Append; ------------------------ -- Breadth_First_Scan -- ------------------------ procedure Breadth_First_Scan (Container : Graph; Start : Index_Type; Process : not null access procedure (Path_To : Path)) is package Frontier_Queues is new WL.Heaps (Key_Type => Cost_Type, Element_Type => Index_Type, "<" => ">"); Sentinel : constant Extended_Index := Extended_Index'First; type Visited_Info is record Visited : Boolean := False; Came_From : Extended_Index := Sentinel; Cost_So_Far : Cost_Type := 0.0; end record; Visited : array (1 .. Container.Vertices.Last_Index) of Visited_Info; Frontier : Frontier_Queues.Heap; begin Frontier.Insert (0.0, Start); Visited (Start).Visited := True; while not Frontier.Is_Empty loop declare Current : constant Index_Type := Frontier.First_Element; Current_Cost : constant Cost_Type := Visited (Current).Cost_So_Far; begin Frontier.Delete_First; if Current /= Start then declare P : Path; It : Extended_Index := Current; begin while Visited (It).Came_From /= Sentinel loop if P.List.Is_Empty then P.List.Append (It); else P.List.Insert (P.List.First, It); end if; It := Visited (It).Came_From; end loop; P.Cost := Current_Cost; Process (P); end; end if; for Edge of Container.Vertices.Element (Current).Edges loop declare New_Cost : constant Cost_Type := Current_Cost + Edge.Cost; Info : Visited_Info renames Visited (Edge.To); begin if not Info.Visited then Frontier.Insert (New_Cost, Edge.To); Info.Visited := True; Info.Cost_So_Far := New_Cost; Info.Came_From := Current; end if; end; end loop; end; end loop; end Breadth_First_Scan; -------------------------- -- Breadth_First_Search -- -------------------------- function Breadth_First_Search (Container : Graph; Start : Vertex_Type; Test : not null access function (Vertex : Vertex_Type) return Boolean) return Vertex_Type is package Queue_Of_Partials is new Ada.Containers.Doubly_Linked_Lists (Index_Type); Queue : Queue_Of_Partials.List; Tested : Queue_Of_Partials.List; begin Queue.Append (Index_Of (Start)); while not Queue.Is_Empty loop declare Ix : constant Index_Type := Queue.First_Element; begin Queue.Delete_First; if Test (Container.Vs (Ix)) then return Container.Vs (Ix); elsif not Tested.Contains (Ix) then Tested.Append (Ix); for Edge of Container.Vertices.Element (Ix).Edges loop Queue.Append (Edge.To); end loop; end if; end; end loop; return Start; end Breadth_First_Search; -------------------------- -- Breadth_First_Search -- -------------------------- procedure Breadth_First_Search (Container : Graph; Start : Index_Type; Max_Steps : Count_Type; Result : out Sub_Graph) is type Partial is record Index : Index_Type; Steps : Count_Type; end record; package Queue_Of_Partials is new Ada.Containers.Doubly_Linked_Lists (Partial); Queue : Queue_Of_Partials.List; begin Container.Create (Result); Queue.Append ((Start, 0)); while not Queue.Is_Empty loop declare use type Ada.Containers.Count_Type; P : constant Partial := Queue.First_Element; Ix : constant Index_Type := P.Index; Steps : constant Count_Type := P.Steps; begin Queue.Delete_First; if not Contains (Result, Ix) then Append (Result, Ix); if Steps < Max_Steps then for Edge of Container.Vertices.Element (Ix).Edges loop Queue.Append ((Edge.To, Steps + 1)); end loop; end if; end if; end; end loop; end Breadth_First_Search; -------------------------- -- Breadth_First_Search -- -------------------------- procedure Breadth_First_Search (Container : Graph; Start : Index_Type; Max : Cost_Type; Result : out Sub_Graph) is type Partial is record Index : Index_Type; Cost : Cost_Type; end record; package Queue_Of_Partials is new Ada.Containers.Doubly_Linked_Lists (Partial); Queue : Queue_Of_Partials.List; begin Container.Create (Result); Queue.Append ((Start, 0.0)); while not Queue.Is_Empty loop declare P : constant Partial := Queue.First_Element; Ix : constant Index_Type := P.Index; Cost : constant Cost_Type := P.Cost; begin Queue.Delete_First; if not Contains (Result, Ix) then Append (Result, Ix); for Edge of Container.Vertices.Element (Ix).Edges loop declare New_Cost : constant Cost_Type := Cost + Edge.Cost; begin if New_Cost <= Max then Queue.Append ((Edge.To, New_Cost)); end if; end; end loop; end if; end; end loop; end Breadth_First_Search; -------------------------- -- Breadth_First_Search -- -------------------------- procedure Breadth_First_Search (Container : Graph; Start : Index_Type; Test : not null access function (Vertex : Vertex_Type) return Boolean; Result : out Sub_Graph) is package Queue_Of_Indices is new Ada.Containers.Doubly_Linked_Lists (Index_Type); Queue : Queue_Of_Indices.List; begin Container.Create (Result); if not Test (Container.Vertex (Start)) then return; end if; Queue.Append (Start); while not Queue.Is_Empty loop declare Ix : constant Index_Type := Queue.First_Element; begin Queue.Delete_First; if not Contains (Result, Ix) then Append (Result, Ix); for Edge of Container.Vertices.Element (Ix).Edges loop if Test (Container.Vertex (Edge.To)) then Queue.Append (Edge.To); end if; end loop; end if; end; end loop; end Breadth_First_Search; ------------- -- Connect -- ------------- procedure Connect (Container : in out Graph'Class; From, To : Index_Type; Cost : Cost_Type := Default_Cost) is begin Container.Vertices (From).Edges.Append ((To, Cost)); end Connect; --------------- -- Connected -- --------------- function Connected (Container : Graph; From, To : Index_Type) return Boolean is begin for Edge of Container.Vertices.Element (From).Edges loop if Edge.To = To then return True; end if; end loop; return False; end Connected; ------------------------- -- Connected_Sub_Graph -- ------------------------- procedure Connected_Sub_Graph (Container : Graph; Start : Vertex_Type; Is_Member : not null access function (Vertex : Vertex_Type) return Boolean; Result : out Sub_Graph) is package Queue_Of_Partials is new Ada.Containers.Doubly_Linked_Lists (Index_Type); Queue : Queue_Of_Partials.List; begin Container.Create (Result); Queue.Append (Index_Of (Start)); while not Queue.Is_Empty loop declare Ix : constant Index_Type := Queue.First_Element; begin Queue.Delete_First; if Is_Member (Container.Vs (Ix)) and then not Contains (Result, Ix) then Append (Result, Ix); for Edge of Container.Vertices.Element (Ix).Edges loop Queue.Append (Edge.To); end loop; end if; end; end loop; end Connected_Sub_Graph; -------------- -- Contains -- -------------- function Contains (Container : Graph; Vertex : Vertex_Type) return Boolean is begin return Container.Index_Of (Vertex) in Index_Type'Range; end Contains; -------------- -- Contains -- -------------- function Contains (Sub : Sub_Graph; Index : Index_Type) return Boolean is begin return Sub.Vertex_Flags.Element (Index); end Contains; -------------- -- Contains -- -------------- function Contains (Collection : Sub_Graph_Collection; Index : Index_Type) return Boolean is begin for Sub of Collection.Vector loop if Contains (Sub, Index) then return True; end if; end loop; return False; end Contains; ---------- -- Cost -- ---------- function Cost (P : Path) return Cost_Type is begin return P.Cost; end Cost; ------------ -- Create -- ------------ procedure Create (Container : Graph'Class; Sub : out Sub_Graph) is begin Sub.Main_Graph := Container'Unchecked_Access; Sub.Vertex_List.Clear; Sub.Vertex_Flags.Clear; for I in 1 .. Container.Last_Vertex_Index loop Sub.Vertex_Flags.Append (False); end loop; end Create; ------------------------ -- Depth_First_Search -- ------------------------ procedure Depth_First_Search (Container : Graph; Start : Index_Type; Max : Cost_Type; Result : out Sub_Graph) is pragma Unreferenced (Max); Stack : Index_Lists.List; begin Container.Create (Result); Stack.Append (Start); while not Stack.Is_Empty loop declare Ix : constant Index_Type := Stack.First_Element; begin Stack.Delete_First; if not Contains (Result, Ix) then Append (Result, Ix); for Edge of Container.Vertices.Element (Ix).Edges loop Stack.Insert (Stack.First, Edge.To); end loop; end if; end; end loop; end Depth_First_Search; ---------- -- Edge -- ---------- function Edge (Container : Graph; From : Vertex_Type; Index : Count_Type) return Vertex_Type is Edges : Edge_Lists.List renames Container.Vertices.Element (Index_Of (From)).Edges; Position : Edge_Lists.Cursor := Edges.First; begin for I in 2 .. Index loop Edge_Lists.Next (Position); end loop; return Container.Vs (Edge_Lists.Element (Position).To); end Edge; --------------- -- Edge_Cost -- --------------- function Edge_Cost (Container : Graph; From, To : Index_Type) return Cost_Type is begin for Edge of Container.Vertices.Element (From).Edges loop if Edge.To = To then return Edge.Cost; end if; end loop; -- can't happen because of precondition raise Program_Error with "invalid call to edge_cost"; end Edge_Cost; ------------------------------ -- Get_Connected_Components -- ------------------------------ procedure Get_Connected_Components (Container : Graph'Class; Result : out Sub_Graph_Collection) is begin Result.Vector.Clear; for Index in 1 .. Container.Vertices.Last_Index loop if not Contains (Result, Index) then declare Sub : Sub_Graph; begin Container.Depth_First_Search (Index, Cost_Type'Last, Sub); Append (Result, Sub); end; end if; end loop; end Get_Connected_Components; ------------------- -- Get_Sub_Graph -- ------------------- function Get_Sub_Graph (Collection : Sub_Graph_Collection; Index : Positive) return Sub_Graph is begin return Collection.Vector (Index); end Get_Sub_Graph; -------------- -- Index_Of -- -------------- function Index_Of (Container : Graph; Vertex : Vertex_Type) return Extended_Index is begin for I in Index_Type'First .. Container.Vertices.Last_Index loop if Container.Vertices.Element (I).Vertex = Vertex then return I; end if; end loop; return Extended_Index'First; end Index_Of; ------------ -- Insert -- ------------ procedure Insert (Collection : in out Sub_Graph_Collection; Sub : Sub_Graph) is begin Collection.Vector.Append (Sub); end Insert; ------------- -- Iterate -- ------------- procedure Iterate (Container : Graph; Process : not null access procedure (Position : Cursor)) is procedure Local_Process (Position : Vertex_Info_Vectors.Cursor); ------------------- -- Local_Process -- ------------------- procedure Local_Process (Position : Vertex_Info_Vectors.Cursor) is begin Process (Cursor (Position)); end Local_Process; begin Container.Vertices.Iterate (Local_Process'Access); end Iterate; ------------- -- Iterate -- ------------- procedure Iterate (Sub : Sub_Graph; Process : not null access procedure (Vertex : Vertex_Type)) is begin for Index of Sub.Vertex_List loop Process (Sub.Main_Graph.Vs (Index)); end loop; end Iterate; ------------------- -- Iterate_Edges -- ------------------- procedure Iterate_Edges (Container : Graph; From : Index_Type; Process : not null access procedure (To : Index_Type; Cost : Cost_Type)) is begin for Edge of Container.Vertices.Element (From).Edges loop Process (Edge.To, Edge.Cost); end loop; end Iterate_Edges; ------------------- -- Iterate_Edges -- ------------------- procedure Iterate_Edges (Container : Graph; From : Vertex_Type; Process : not null access procedure (To : Vertex_Type; Cost : Cost_Type)) is procedure Internal (To : Index_Type; Cost : Cost_Type); -------------- -- Internal -- -------------- procedure Internal (To : Index_Type; Cost : Cost_Type) is begin Process (Container.Vertices.Element (To).Vertex, Cost); end Internal; begin Graph'Class (Container).Iterate_Edges (Index_Of (From), Internal'Access); end Iterate_Edges; ----------------------- -- Last_Vertex_Index -- ----------------------- function Last_Vertex_Index (Container : Graph) return Extended_Index is begin return Container.Vertices.Last_Index; end Last_Vertex_Index; ---------- -- Next -- ---------- function Next (Container : Graph; P : Path) return Vertex_Type is begin return Container.Vs.Element (Index_Lists.Element (Index_Lists.Next (P.List.First))); end Next; ------------------- -- Path_Vertices -- ------------------- function Path_Vertices (Container : Graph; P : Path) return Array_Of_Vertices is pragma Unreferenced (Container); Count : Positive := 1; begin return Result : Array_Of_Vertices (1 .. Natural (P.List.Length)) do for Index of P.List loop Result (Count) := Index; Count := Count + 1; end loop; end return; end Path_Vertices; -------------------- -- Same_Sub_Graph -- -------------------- function Same_Sub_Graph (Collection : Sub_Graph_Collection; V1, V2 : Index_Type) return Boolean is begin for Sub_Graph of Collection.Vector loop if Contains (Sub_Graph, V1) then return Contains (Sub_Graph, V2); elsif Contains (Sub_Graph, V2) then return False; end if; end loop; return False; end Same_Sub_Graph; ------------------- -- Shortest_Path -- ------------------- function Shortest_Path (Container : Graph'Class; From, To : Index_Type) return Path is function Cost (From, To : Vertex_Type) return Cost_Type is (Container.Edge_Cost (Index_Of (From), Index_Of (To))); begin return Container.Shortest_Path (From, To, Cost'Access); end Shortest_Path; ------------------- -- Shortest_Path -- ------------------- function Shortest_Path (Container : Graph'Class; From, To : Index_Type; Test_Vertex : not null access function (Vertex : Vertex_Type) return Boolean) return Path is pragma Warnings (Off); function Passable (From, To : Vertex_Type) return Boolean is (Test_Vertex (To)); function Cost (From, To : Vertex_Type) return Cost_Type is (1.0); function Estimate (From, To : Vertex_Type) return Cost_Type is (0.0); begin return Container.Shortest_Path (From, To, Passable'Access, Cost'Access, Estimate'Access); end Shortest_Path; ------------------- -- Shortest_Path -- ------------------- function Shortest_Path (Container : Graph'Class; Start, Finish : Index_Type; Passable : not null access function (From, To : Vertex_Type) return Boolean; Cost : not null access function (From, To : Vertex_Type) return Cost_Type; Estimate : not null access function (From, To : Vertex_Type) return Cost_Type) return Path is package Frontier_Queues is new WL.Heaps (Key_Type => Cost_Type, Element_Type => Index_Type, "<" => ">"); Sentinel : constant Extended_Index := Extended_Index'First; type Visited_Info is record Visited : Boolean := False; Came_From : Extended_Index := Sentinel; Cost_So_Far : Cost_Type := 0.0; Rest_Cost : Cost_Type := 0.0; end record; Visited : array (1 .. Container.Vertices.Last_Index) of Visited_Info; Frontier : Frontier_Queues.Heap; begin Frontier.Insert (0.0, Start); Visited (Start).Visited := True; Visited (Start).Rest_Cost := Estimate (Container.Vs (Start), Container.Vs (Finish)); while not Frontier.Is_Empty loop declare Current : constant Index_Type := Frontier.First_Element; Current_V : constant Vertex_Type := Container.Vs.Element (Current); Current_Cost : constant Cost_Type := Visited (Current).Cost_So_Far; begin Frontier.Delete_First; exit when Current = Finish; for Edge of Container.Vertices.Element (Current).Edges loop declare Next_V : constant Vertex_Type := Container.Vs.Element (Edge.To); begin if Passable (Current_V, Next_V) then declare New_Cost : constant Cost_Type := Current_Cost + Cost (Current_V, Next_V); Info : Visited_Info renames Visited (Edge.To); begin if not Info.Visited or else New_Cost < Info.Cost_So_Far then if Info.Visited then Frontier.Replace (New_Cost + Info.Rest_Cost, Edge.To); else Info.Rest_Cost := Estimate (Next_V, Container.Vs (Finish)); Frontier.Insert (New_Cost + Info.Rest_Cost, Edge.To); Info.Visited := True; end if; Info.Cost_So_Far := New_Cost; Info.Came_From := Current; end if; end; end if; end; end loop; end; end loop; declare Result : Path; It : Index_Type := Finish; begin Result.Cost := Visited (It).Cost_So_Far; while Visited (It).Came_From /= Sentinel loop if Result.List.Is_Empty then Result.List.Append (It); else Result.List.Insert (Result.List.First, It); end if; It := Visited (It).Came_From; end loop; return Result; end; end Shortest_Path; ------------------- -- Shortest_Path -- ------------------- function Shortest_Path (Container : Graph'Class; From, To : Index_Type; Cost : not null access function (From, To : Vertex_Type) return Cost_Type) return Path is function Passable (From, To : Vertex_Type) return Boolean is (True); function Estimate (From, To : Vertex_Type) return Cost_Type is (0.0); begin return Container.Shortest_Path (From, To, Passable'Access, Cost, Estimate'Access); end Shortest_Path; ------------------- -- Shortest_Path -- ------------------- function Shortest_Path (Container : Graph'Class; From, To : Index_Type; Cost : not null access function (From, To : Vertex_Type) return Cost_Type; Estimate : not null access function (From, To : Vertex_Type) return Cost_Type) return Path is function Passable (From, To : Vertex_Type) return Boolean is (True); begin return Container.Shortest_Path (From, To, Passable'Access, Cost, Estimate); end Shortest_Path; --------------------- -- Sub_Graph_Count -- --------------------- function Sub_Graph_Count (Collection : Sub_Graph_Collection) return Natural is begin return Collection.Vector.Last_Index; end Sub_Graph_Count; ------------ -- Vertex -- ------------ function Vertex (Container : Graph; Index : Index_Type) return Vertex_Type is begin return Container.Vs (Index); end Vertex; ------------------ -- Vertex_Count -- ------------------ function Vertex_Count (P : Path) return Extended_Index is begin return Extended_Index (P.List.Length); end Vertex_Count; end WL.Graphs;