File : bc-graphs.adb
-- Copyright (C) 1994-1999 Grady Booch and Simon Wright.
-- All Rights Reserved.
--
-- This program is free software; you can redistribute it
-- and/or modify it under the terms of the Ada Community
-- License which comes with this Library.
--
-- This program is distributed in the hope that it will be
-- useful, but WITHOUT ANY WARRANTY; without even the implied
-- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
-- PURPOSE. See the Ada Community License for more details.
-- You should have received a copy of the Ada Community
-- License with this library, in the file named "Ada Community
-- License" or "ACL". If not, contact the author of this library
-- for a copy.
--
-- $Id: bc-graphs.adb,v 1.8 1999/04/10 14:38:20 simon Exp $
with Ada.Unchecked_Deallocation;
with BC.Support.Exceptions;
with Ada.Text_Io;
package body BC.Graphs is
package BSE renames BC.Support.Exceptions;
procedure Assert
is new BSE.Assert ("BC.Graphs");
procedure Delete is new Ada.Unchecked_Deallocation
(Vertex_Node, Vertex_Node_Ptr);
procedure Delete is new Ada.Unchecked_Deallocation
(Arc_Node, Arc_Node_Ptr);
----------------------
-- Graph operations --
----------------------
procedure Clear (G : in out Graph) is
Curr : Vertex_Node_Ptr := G.Rep;
Next : Vertex_Node_Ptr;
begin
-- In the C++, this was done using Iterators which created a Vertex and
-- then called Destroy_Vertex. We can't do that, because our Vertices
-- are abstract.
while Curr /= null loop
Next := Curr.Next;
Clear_Vertex_Node (G, Curr);
Curr := Next;
end loop;
end Clear;
procedure Create_Vertex (G : in out Graph;
V : in out Vertex'Class;
I : Vertex_Item) is
begin
Clear (V);
V.Rep := new Vertex_Node'(Ada.Finalization.Controlled with
Item => I,
Enclosing => G'Unchecked_Access,
Incoming => null,
Outgoing => null,
Next => G.Rep,
Count => 1);
G.Rep := V.Rep;
G.Rep.Count := G.Rep.Count + 1;
end Create_Vertex;
procedure Destroy_Vertex (G : in out Graph;
V : in out Vertex'Class) is
begin
Assert (Is_Member (G, V),
BC.Not_Found'Identity,
"Destroy_Vertex",
BSE.Disjoint);
if V.Rep /= null then
-- The C++ had the body of what is now Clear_Vertex_Node here,
-- because it had the iterators available for thr Clear (Graph)
-- operation. Also, the type Vertex wasn't abstract (GEB didn't make
-- much use of inheritance).
Clear_Vertex_Node (G, V.Rep);
Clear (V);
end if;
end Destroy_Vertex;
procedure Destroy_Arc (G : in out Graph;
A : in out Arc'Class) is
Prev, Curr : Arc_Node_Ptr;
begin
Assert (Is_Member (G, A),
BC.Not_Found'Identity,
"Destroy_Arc",
BSE.Disjoint);
if A.Rep /= null then
if A.Rep.To /= null then
Prev := null;
Curr := A.Rep.To.Incoming;
while Curr /= A.Rep loop
Prev := Curr;
Curr := Curr.Next_Incoming;
end loop;
if Prev = null then
A.Rep.To.Incoming := Curr.Next_Incoming;
else
Prev.Next_Incoming := Curr.Next_Incoming;
end if;
A.Rep.To.Count := A.Rep.To.Count - 1;
A.Rep.Count := A.Rep.Count - 1;
end if;
if A.Rep.From /= null then
Prev := null;
Curr := A.Rep.From.Outgoing;
while Curr /= A.Rep loop
Prev := Curr;
Curr := Curr.Next_Outgoing;
end loop;
if Prev = null then
A.Rep.From.Outgoing := Curr.Next_Outgoing;
else
Prev.Next_Outgoing := Curr.Next_Outgoing;
end if;
A.Rep.From.Count := A.Rep.From.Count - 1;
A.Rep.Count := A.Rep.Count - 1;
end if;
A.Rep.From := null;
A.Rep.To := null;
A.Rep.Next_Incoming := null;
A.Rep.Next_Outgoing := null;
A.Rep.Enclosing := null;
-- XXX should we decrement the count one more, like Destroy_Vertex?
-- (presumably for the lost Enclosing?)
Clear (A);
end if;
end Destroy_Arc;
function Number_Of_Vertices (G : Graph) return Natural is
Count : Natural := 0;
Curr : Vertex_Node_Ptr := G.Rep;
begin
while Curr /= null loop
Curr := Curr.Next;
Count := Count + 1;
end loop;
return Count;
end Number_Of_Vertices;
function Is_Empty (G : Graph) return Boolean is
begin
return G.Rep = null;
end Is_Empty;
function Is_Member (G : Graph; V : Vertex'Class) return Boolean is
-- Thanks to Tucker Taft for this workround to an access level problem
type Graph_Const_Ptr is access constant Graph;
begin
if V.Rep = null then
return False;
else
return Graph_Const_Ptr (V.Rep.Enclosing) = G'Access;
end if;
end Is_Member;
function Is_Member (G : Graph; A : Arc'Class) return Boolean is
-- Thanks to Tucker Taft for this workround to an access level problem
type Graph_Const_Ptr is access constant Graph;
begin
if A.Rep = null then
return False;
else
return Graph_Const_Ptr (A.Rep.Enclosing) = G'Access;
end if;
end Is_Member;
-----------------------
-- Vertex operations --
-----------------------
function "=" (L, R : Vertex) return Boolean is
begin
return L.Rep = R.Rep;
end "=";
procedure Clear (V : in out Vertex) is
begin
if V.Rep /= null then
if V.Rep.Count > 1 then
V.Rep.Count := V.Rep.Count - 1;
else
Delete (V.Rep);
end if;
V.Rep := null;
end if;
end Clear;
procedure Set_Item (V : in out Vertex; I : Vertex_Item) is
begin
Assert (V.Rep /= null,
BC.Is_Null'Identity,
"Set_Item(Vertex)",
BSE.Is_Null);
V.Rep.Item := I;
end Set_Item;
function Is_Null (V : Vertex) return Boolean is
begin
return V.Rep = null;
end Is_Null;
function Is_Shared (V : Vertex) return Boolean is
begin
return V.Rep /= null and then V.Rep.Count > 1;
end Is_Shared;
function Item (V : Vertex) return Vertex_Item is
begin
Assert (V.Rep /= null,
BC.Is_Null'Identity,
"Item(Vertex)",
BSE.Is_Null);
return V.Rep.Item;
end Item;
procedure Access_Vertex_Item (V : Vertex'Class) is
begin
Assert (V.Rep /= null,
BC.Is_Null'Identity,
"Access_Vertex_Item",
BSE.Is_Null);
Process (V.Rep.Item);
end Access_Vertex_Item;
function Enclosing_Graph (V : Vertex) return Graph_Ptr is
begin
Assert (V.Rep /= null,
BC.Is_Null'Identity,
"Enclosing_Graph(Vertex)",
BSE.Is_Null);
return V.Rep.Enclosing;
end Enclosing_Graph;
--------------------
-- Arc operations --
--------------------
function "=" (L, R : Arc) return Boolean is
begin
return L.Rep = R.Rep;
end "=";
procedure Clear (A : in out Arc) is
begin
if A.Rep /= null then
if A.Rep.Count > 1 then
A.Rep.Count := A.Rep.Count - 1;
else
Delete (A.Rep);
end if;
A.Rep := null;
end if;
end Clear;
procedure Set_Item (A : in out Arc; I : Arc_Item) is
begin
Assert (A.Rep /= null,
BC.Is_Null'Identity,
"Set_Item(Arc)",
BSE.Is_Null);
A.Rep.Item := I;
end Set_Item;
function Is_Null (A : Arc) return Boolean is
begin
return A.Rep = null;
end Is_Null;
function Is_Shared (A : Arc) return Boolean is
begin
return A.Rep /= null and then A.Rep.Count > 1;
end Is_Shared;
function Item (A : Arc) return Arc_Item is
begin
Assert (A.Rep /= null,
BC.Is_Null'Identity,
"Item(Arc)",
BSE.Is_Null);
return A.Rep.Item;
end Item;
procedure Access_Arc_Item (A : Arc'Class) is
begin
Assert (A.Rep /= null,
BC.Is_Null'Identity,
"Access_Arc_Item",
BSE.Is_Null);
Process (A.Rep.Item);
end Access_Arc_Item;
function Enclosing_Graph (A : Arc) return Graph_Ptr is
begin
Assert (A.Rep /= null,
BC.Is_Null'Identity,
"Enclosing_Graph(Arc)",
BSE.Is_Null);
return A.Rep.Enclosing;
end Enclosing_Graph;
--------------------------------------------
-- Iteration over the Vertices in a Graph --
--------------------------------------------
procedure Reset (Obj : in out Graph_Iterator) is
begin
Reset (GSP.Value (GSP.Pointer (Obj)).all);
end Reset;
procedure Next (Obj : in out Graph_Iterator) is
begin
Next (GSP.Value (GSP.Pointer (Obj)).all);
end Next;
function Is_Done (Obj : Graph_Iterator) return Boolean is
begin
return Is_Done (GSP.Value (GSP.Pointer (Obj)).all);
end Is_Done;
function Current_Vertex (Obj : Graph_Iterator) return Vertex'Class is
begin
return Current_Vertex (GSP.Value (GSP.Pointer (Obj)).all);
end Current_Vertex;
procedure Visit_Vertices (Using : in out Graph_Iterator) is
Success : Boolean;
begin
Reset (Using);
while not Is_Done (Using) loop
Apply (Current_Vertex (Using), Success);
exit when not Success;
Next (Using);
end loop;
end Visit_Vertices;
---------------------------------------------------
-- Iteration over the Arcs connected to a Vertex --
---------------------------------------------------
procedure Reset (Obj : in out Vertex_Iterator) is
begin
Reset (VSP.Value (VSP.Pointer (Obj)).all);
end Reset;
procedure Next (Obj : in out Vertex_Iterator) is
begin
Next (VSP.Value (VSP.Pointer (Obj)).all);
end Next;
function Is_Done (Obj : Vertex_Iterator) return Boolean is
begin
return Is_Done (VSP.Value (VSP.Pointer (Obj)).all);
end Is_Done;
function Current_Arc (Obj : Vertex_Iterator) return Arc'Class is
begin
return Current_Arc (VSP.Value (VSP.Pointer (Obj)).all);
end Current_Arc;
procedure Visit_Arcs (Using : in out Vertex_Iterator) is
Success : Boolean;
begin
Reset (Using);
while not Is_Done (Using) loop
Apply (Current_Arc (Using), Success);
exit when not Success;
Next (Using);
end loop;
end Visit_Arcs;
----------------------------------------------
-- Utilities, controlled storage management --
----------------------------------------------
procedure Clear_Vertex_Node (G : in out Graph'Class;
N : in out Vertex_Node_Ptr) is
Curr : Arc_Node_Ptr;
Prev, Index : Vertex_Node_Ptr;
begin
while N.Incoming /= null loop
Curr := N.Incoming;
N.Incoming := Curr.Next_Incoming;
Curr.To := null;
Curr.Next_Incoming := null;
Curr.Enclosing := null;
if Curr.Count > 1 then
Curr.Count := Curr.Count - 1;
else
Delete (Curr);
end if;
N.Count := N.Count - 1;
end loop;
while N.Outgoing /= null loop
Curr := N.Outgoing;
N.Outgoing := Curr.Next_Outgoing;
Curr.From := null;
Curr.Next_Outgoing := null;
Curr.Enclosing := null;
if Curr.Count > 1 then
Curr.Count := Curr.Count - 1;
else
Delete (Curr);
end if;
N.Count := N.Count - 1;
end loop;
Prev := null;
Index := G.Rep;
while Index /= N loop
Prev := Index;
Index := Index.Next;
end loop;
if Prev = null then
G.Rep := Index.Next;
else
Prev.Next := Index.Next;
end if;
Index.Next := null;
N.Enclosing := null;
N.Count := N.Count - 1;
if N.Count = 0 then
Delete (N);
end if;
end Clear_Vertex_Node;
procedure Finalize (V : in out Vertex_Node) is
begin
if V.Count > 1 then
Ada.Text_Io.Put_Line ("Vertex_Node finalized with Count"
& Integer'Image (V.Count));
end if;
end Finalize;
procedure Finalize (A : in out Arc_Node) is
begin
if A.Count > 1 then
Ada.Text_Io.Put_Line ("Arc_Node finalized with Count"
& Integer'Image (A.Count));
end if;
end Finalize;
procedure Finalize (G : in out Graph) is
begin
Clear (G);
end Finalize;
procedure Adjust (V : in out Vertex) is
begin
if V.Rep /= null then
V.Rep.Count := V.Rep.Count + 1;
end if;
end Adjust;
procedure Finalize (V : in out Vertex) is
Curr : Arc_Node_Ptr;
begin
if V.Rep /= null then
if V.Rep.Count > 1 then
V.Rep.Count := V.Rep.Count - 1;
else
while V.Rep.Incoming /= null loop
Curr := V.Rep.Incoming;
V.Rep.Incoming := Curr.Next_Incoming;
Curr.To := null;
Curr.Next_Incoming := null;
Curr.Enclosing := null;
if Curr.Count > 1 then
Curr.Count := Curr.Count - 1;
else
Delete (Curr);
end if;
end loop;
while V.Rep.Outgoing /= null loop
Curr := V.Rep.Outgoing;
V.Rep.Outgoing := Curr.Next_Outgoing;
Curr.From := null;
Curr.Next_Outgoing := null;
Curr.Enclosing := null;
if Curr.Count > 1 then
Curr.Count := Curr.Count - 1;
else
Delete (Curr);
end if;
end loop;
Clear (V);
end if;
end if;
end Finalize;
procedure Adjust (A : in out Arc) is
begin
if A.Rep /= null then
A.Rep.Count := A.Rep.Count + 1;
end if;
end Adjust;
procedure Finalize (A : in out Arc) is
Prev, Curr : Arc_Node_Ptr;
begin
if A.Rep /= null then
if A.Rep.Count > 1 then
A.Rep.Count := A.Rep.Count - 1;
else
if A.Rep.To /= null then
Prev := null;
Curr := A.Rep.To.Incoming;
while Curr /= A.Rep loop
Prev := Curr;
Curr := Curr.Next_Incoming;
end loop;
if Prev = null then
A.Rep.To.Incoming := Curr.Next_Incoming;
else
Prev.Next_Incoming := Curr.Next_Incoming;
end if;
if A.Rep.To.Count > 1 then
A.Rep.To.Count := A.Rep.To.Count - 1;
else
Delete (A.Rep.To);
end if;
A.Rep.Count := A.Rep.Count - 1;
end if;
if A.Rep.From /= null then
Prev := null;
Curr := A.Rep.From.Outgoing;
while Curr /= A.Rep loop
Prev := Curr;
Curr := Curr.Next_Outgoing;
end loop;
if Prev = null then
A.Rep.From.Outgoing := Curr.Next_Outgoing;
else
Prev.Next_Outgoing := Curr.Next_Outgoing;
end if;
if A.Rep.From.Count > 1 then
A.Rep.From.Count := A.Rep.From.Count - 1;
else
Delete (A.Rep.From);
end if;
-- XXX bug in C++ here?
A.Rep.Count := A.Rep.Count - 1;
end if;
Clear (A);
end if;
end if;
end Finalize;
end BC.Graphs;