-- Copyright 1994 Grady Booch
-- Copyright 1998-2002 Simon Wright <simon@pushface.org>
-- This package is free software; you can redistribute it and/or
-- modify it under terms of the GNU General Public License as
-- published by the Free Software Foundation; either version 2, or
-- (at your option) any later version. This package 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 GNU General Public License for more
-- details. You should have received a copy of the GNU General Public
-- License distributed with this package; see file COPYING. If not,
-- write to the Free Software Foundation, 59 Temple Place - Suite
-- 330, Boston, MA 02111-1307, USA.
-- As a special exception, if other files instantiate generics from
-- this unit, or you link this unit with other files to produce an
-- executable, this unit does not by itself cause the resulting
-- executable to be covered by the GNU General Public License. This
-- exception does not however invalidate any other reasons why the
-- executable file might be covered by the GNU Public License.
-- $RCSfile: bc-graphs.adb,v $
-- $Revision: 1.12.2.1 $
-- $Date: 2002/12/29 16:42:22 $
-- $Author: simon $
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 Abstract_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 Abstract_Graph;
V : in out Abstract_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 Abstract_Graph;
V : in out Abstract_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 the
-- 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 Abstract_Graph;
A : in out Abstract_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 : Abstract_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 : Abstract_Graph) return Boolean is
begin
return G.Rep = null;
end Is_Empty;
function Is_Member (G : Abstract_Graph;
V : Abstract_Vertex'Class) return Boolean is
-- Thanks to Tucker Taft for this workround to an access level
-- problem
type Graph_Const_Ptr is access constant Abstract_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 : Abstract_Graph;
A : Abstract_Arc'Class) return Boolean is
-- Thanks to Tucker Taft for this workround to an access level
-- problem
type Graph_Const_Ptr is access constant Abstract_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 : Abstract_Vertex) return Boolean is
begin
return L.Rep = R.Rep;
end "=";
procedure Clear (V : in out Abstract_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 Abstract_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 : Abstract_Vertex) return Boolean is
begin
return V.Rep = null;
end Is_Null;
function Is_Shared (V : Abstract_Vertex) return Boolean is
begin
return V.Rep /= null and then V.Rep.Count > 1;
end Is_Shared;
function Item (V : Abstract_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 : Abstract_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 : Abstract_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 : Abstract_Arc) return Boolean is
begin
return L.Rep = R.Rep;
end "=";
procedure Clear (A : in out Abstract_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 Abstract_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 : Abstract_Arc) return Boolean is
begin
return A.Rep = null;
end Is_Null;
function Is_Shared (A : Abstract_Arc) return Boolean is
begin
return A.Rep /= null and then A.Rep.Count > 1;
end Is_Shared;
function Item (A : Abstract_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 : Abstract_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 : Abstract_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 Visit_Vertices (Using : in out Graph_Iterator'Class) 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 Visit_Arcs (Using : in out Vertex_Iterator'Class) 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 Abstract_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
-- XXX should this be an assertion?
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
-- XXX should this be an assertion?
Ada.Text_IO.Put_Line ("Arc_Node finalized with Count"
& Integer'Image (A.Count));
end if;
end Finalize;
procedure Finalize (G : in out Abstract_Graph) is
begin
Clear (G);
end Finalize;
procedure Adjust (V : in out Abstract_Vertex) is
begin
if V.Rep /= null then
V.Rep.Count := V.Rep.Count + 1;
end if;
end Adjust;
procedure Finalize (V : in out Abstract_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 Abstract_Arc) is
begin
if A.Rep /= null then
A.Rep.Count := A.Rep.Count + 1;
end if;
end Adjust;
procedure Finalize (A : in out Abstract_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;
syntax highlighted by Code2HTML, v. 0.9.1