File : bc-containers-lists-double.adb
-- Copyright (C) 1994-1999 Grady Booch, David Weller 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-containers-lists-double.adb,v 1.7.2.3 1999/12/31 14:58:27 simon Exp $
with BC.Support.Exceptions;
with System.Address_To_Access_Conversions;
package body BC.Containers.Lists.Double is
package BSE renames BC.Support.Exceptions;
procedure Assert
is new BSE.Assert ("BC.Containers.Lists.Double");
use type Double_Nodes.Double_Node_Ref;
function "=" (L, R : Double_List) return Boolean is
begin
return L.Rep = R.Rep;
end "=";
procedure Clear (L : in out Double_List) is
Curr : Double_Nodes.Double_Node_Ref := L.Rep;
Ptr : Double_Nodes.Double_Node_Ref;
begin
while Curr /= null loop
Ptr := Curr;
Curr := Curr.Next;
if Ptr.Count > 1 then
Ptr.Count := Ptr.Count - 1;
exit;
else
if Curr /= null then
Curr.Previous := null;
end if;
Double_Nodes.Delete (Ptr);
end if;
end loop;
L.Rep := null;
end Clear;
procedure Insert (L : in out Double_List; Elem : Item) is
begin
Assert (L.Rep = null or else L.Rep.Previous = null,
BC.Not_Root'Identity,
"Insert",
BSE.Not_Root);
L.Rep := Double_Nodes.Create (Elem, Previous => null, Next => L.Rep);
end Insert;
procedure Insert (L : in out Double_List; From_List : in Double_List) is
Ptr : Double_Nodes.Double_Node_Ref := From_List.Rep;
begin
Assert (L.Rep = null or else L.Rep.Previous = null,
BC.Not_Root'Identity,
"Insert",
BSE.Not_Root);
if Ptr /= null then
while Ptr.Next /= null loop
Ptr := Ptr.Next;
end loop;
end if;
Ptr.Next := L.Rep;
if L.Rep /= null then
L.Rep.Previous := Ptr;
end if;
L.Rep := From_List.Rep;
L.Rep.Count := L.Rep.Count + 1;
end Insert;
procedure Insert (L : in out Double_List;
Elem : Item;
Before : Positive) is
Prev : Double_Nodes.Double_Node_Ref;
Curr : Double_Nodes.Double_Node_Ref := L.Rep;
Index : Positive := 1;
begin
if Curr = null or else Before = 1 then
Insert (L, Elem);
else
while Curr /= null and then Index < Before loop
Prev := Curr;
Curr := Curr.Next;
Index := Index + 1;
end loop;
Assert (Curr /= null,
BC.Range_Error'Identity,
"Insert",
BSE.Invalid_Index);
Prev.Next := Double_Nodes.Create (Elem, Previous => Prev, Next => Curr);
end if;
end Insert;
procedure Insert (L : in out Double_List;
From_List: in out Double_List;
Before : Positive) is
Prev : Double_Nodes.Double_Node_Ref;
Curr : Double_Nodes.Double_Node_Ref := L.Rep;
Ptr : Double_Nodes.Double_Node_Ref := From_List.Rep;
Index : Positive := 1;
begin
if Ptr /= null then
if Curr = null or else Before = 1 then
Insert (L, From_List);
else
Assert (Ptr /= null or else Ptr.Previous = null,
BC.Not_Root'Identity,
"Insert",
BSE.Not_Root);
while Curr /= null and then Index < Before loop
Prev := Curr;
Curr := Curr.Next;
Index := Index + 1;
end loop;
Assert (Curr /= null,
BC.Range_Error'Identity,
"Insert",
BSE.Invalid_Index);
while Ptr.Next /= null loop
Ptr := Ptr.Next;
end loop;
Ptr.Next := Curr;
Curr.Previous := Ptr;
Prev.Next := From_List.Rep;
From_List.Rep.Previous := Prev;
From_List.Rep.Count := From_List.Rep.Count + 1;
end if;
end if;
end Insert;
procedure Append (L : in out Double_List; Elem : Item) is
Curr : Double_Nodes.Double_Node_Ref := L.Rep;
begin
if Curr /= null then
while Curr.Next /= null loop
Curr := Curr.Next;
end loop;
Curr.Next := Double_Nodes.Create (Elem, Previous => Curr, Next => null);
else
L.Rep := Double_Nodes.Create (Elem, Previous => null, Next => null);
end if;
end Append;
procedure Append (L : in out Double_List; From_List : in Double_List) is
Curr : Double_Nodes.Double_Node_Ref := L.Rep;
begin
Assert (From_List.Rep = null or else From_List.Rep.Previous = null,
BC.Not_Root'Identity,
"Append",
BSE.Not_Root);
if From_List.Rep /= null then
if Curr /= null then
while Curr.Next /= null loop
Curr := Curr.Next;
end loop;
end if;
if Curr /= null then
Curr.Next := From_List.Rep;
From_List.Rep.Previous := Curr;
else
L.Rep := From_List.Rep;
end if;
From_List.Rep.Count := From_List.Rep.Count + 1;
end if;
end Append;
procedure Append (L : in out Double_List; Elem : Item; After : Positive) is
Curr : Double_Nodes.Double_Node_Ref := L.Rep;
Index : Positive := 1;
begin
if Curr = null then
Append (L, ELem);
else
while Curr /= null and then Index < After loop
Curr := Curr.Next;
Index := Index + 1;
end loop;
Assert (Curr /= null,
BC.Range_Error'Identity,
"Append",
BSE.Invalid_Index);
Curr.Next := Double_Nodes.Create (Elem,
Previous => Curr,
Next => Curr.Next);
end if;
end Append;
procedure Append (L : in out Double_List;
From_List : in Double_List;
After : Positive) is
Curr : Double_Nodes.Double_Node_Ref := L.Rep;
Ptr : Double_Nodes.Double_Node_Ref := From_List.Rep;
Index : Positive := 1;
begin
if Ptr /= null then
if Curr = null then
Append (L, From_List);
else
Assert (From_List.Rep /= null or else
From_List.Rep.Previous = null,
BC.Not_Root'Identity,
"Append",
BSE.Not_Root);
while Curr /= null and then Index < After loop
Curr := Curr.Next;
Index := Index + 1;
end loop;
Assert (Curr /= null,
BC.Range_Error'Identity,
"Append",
BSE.Invalid_Index);
while Ptr.Next /= null loop
Ptr := Ptr.Next;
end loop;
Ptr.Next := Curr.Next;
if Curr.Next /= null then
Curr.Next.Previous := Ptr;
end if;
Curr.Next := From_List.Rep;
From_List.Rep.Previous := Curr;
From_List.Rep.Count := From_List.Rep.Count + 1;
end if;
end if;
end Append;
procedure Remove (L : in out Double_List; From : Positive) is
Prev : Double_Nodes.Double_Node_Ref;
Curr : Double_Nodes.Double_Node_Ref := L.Rep;
Index : Positive := 1;
begin
while Curr /= null and then Index < From loop
Prev := Curr;
Curr := Curr.Next;
Index := Index + 1;
end loop;
Assert (Curr /= null,
BC.Range_Error'Identity,
"Remove",
BSE.Invalid_Index);
if Prev /= null then
Prev.Next := Curr.Next;
else
L.Rep := Curr.Next;
end if;
if Curr.Next /= null then
Curr.Next.Previous := Prev;
end if;
if Curr.Count > 1 then
Curr.Count := Curr.Count - 1;
else
Double_Nodes.Delete (Curr);
end if;
end Remove;
procedure Purge (L : in out Double_LIst; From : Positive) is
Prev : Double_Nodes.Double_Node_Ref;
Curr : Double_Nodes.Double_Node_Ref := L.Rep;
Ptr : Double_Nodes.Double_Node_Ref;
Index : Positive := 1;
begin
while Curr /= null and then Index < From loop
Prev := Curr;
Curr := Curr.Next;
Index := Index + 1;
end loop;
Assert (Curr /= null,
BC.Range_Error'Identity,
"Purge",
BSE.Invalid_Index);
if Prev /= null then
Prev.Next := null;
else
L.Rep := null;
end if;
while Curr /= null loop
Curr.Previous := null;
Ptr := Curr;
Curr := Curr.Next;
if Ptr.Count > 1 then
Ptr.Count := Ptr.Count - 1;
exit;
else
Double_Nodes.Delete (Ptr);
end if;
end loop;
end Purge;
procedure Purge (L : in out Double_List;
From : Positive;
Count : Positive) is
Prev, Ptr : Double_Nodes.Double_Node_Ref;
Curr : Double_Nodes.Double_Node_Ref := L.Rep;
Index : Positive := 1;
Shared_Node_Found : Boolean := False;
begin
while Curr /= null and then Index < From loop
Prev := Curr;
Curr := Curr.Next;
Index := Index + 1;
end loop;
Assert (Curr /= null,
BC.Range_Error'Identity,
"Purge",
BSE.Invalid_Index);
if Prev /= null then
Prev.Next := null;
else
L.Rep := null;
end if;
Index := 1;
while Curr /= null and then Index <= Count loop
Ptr := Curr;
Curr := Curr.Next;
if not Shared_Node_Found then
if Ptr.Count > 1 then
Ptr.Count := Ptr.Count - 1;
Shared_Node_Found := True;
else
if Curr /= null then
Curr.Previous := null;
Double_Nodes.Delete (Ptr);
end if;
end if;
end if;
Index := Index + 1;
end loop;
if Shared_Node_Found then
Ptr.Next := null;
end if;
if Curr /= null then
Curr.Previous := Prev;
if Prev /= null then
Prev.Next := Curr;
else
L.Rep := Curr;
end if;
end if;
end Purge;
procedure Preserve (L : in out Double_List; From : Positive) is
Temp : Double_List;
begin
Share (Temp, L, From);
Share_Head (L, Temp);
end Preserve;
procedure Preserve (L: in out Double_List;
From : Positive;
Count : Positive) is
begin
Preserve (L, From);
if Length (L) > Count then
Purge (L, Count + 1); -- we start at 1, remember!
end if;
end Preserve;
procedure Share (L : in out Double_List;
With_List: Double_List;
Starting_At : Positive) is
Ptr : Double_Nodes.Double_Node_Ref := With_List.Rep;
Index : Positive := 1;
begin
Assert (Ptr /= null,
BC.Is_Null'Identity,
"Share",
BSE.Is_Null);
while Ptr /= null and then Index < Starting_At loop
Ptr := Ptr.Next;
Index := Index + 1;
end loop;
Assert (Ptr /= null,
BC.Range_Error'Identity,
"Share",
BSE.Invalid_Index);
Clear (L);
L.Rep := Ptr;
L.Rep.Count := L.Rep.Count + 1;
end Share;
procedure Share_Head (L : in out Double_List;
With_List : in Double_List) is
begin
Assert (With_List.Rep /= null,
BC.Is_Null'Identity,
"Share_Head",
BSE.Is_Null);
Clear (L);
L.Rep := With_List.Rep;
L.Rep.Count := L.Rep.Count + 1;
end Share_Head;
procedure Share_Foot (L : in out Double_List;
With_List : in Double_List) is
Ptr : Double_Nodes.Double_Node_Ref := With_List.Rep;
begin
Assert (Ptr /= null,
BC.Is_Null'Identity,
"Share_Foot",
BSE.Is_Null);
Clear (L);
while Ptr.Next /= null loop
Ptr := Ptr.Next;
end loop;
L.Rep := Ptr;
L.Rep.Count := L.Rep.Count + 1;
end Share_Foot;
procedure Swap_Tail (L : in out Double_List;
With_List : in out Double_List) is
Curr : Double_Nodes.Double_Node_Ref;
begin
Assert (L.Rep /= null,
BC.Is_Null'Identity,
"Swap_Tail",
BSE.Is_Null);
Assert (With_List.Rep = null or else With_List.Rep.Previous = null,
BC.Not_Root'Identity,
"Swap_Tail",
BSE.Not_Root);
Curr := L.Rep.Next;
L.Rep.Next := With_List.Rep;
With_List.Rep.Previous := L.Rep;
With_List.Rep := Curr;
if With_List.Rep /= null then
With_List.Rep.Previous := null;
end if;
end Swap_Tail;
procedure Tail (L : in out Double_List) is
Curr : Double_Nodes.Double_Node_Ref := L.Rep;
begin
Assert (L.Rep /= null,
BC.Is_Null'Identity,
"Tail",
BSE.Is_Null);
L.Rep := L.Rep.Next;
if L.Rep /= null then
L.Rep.Count := L.Rep.Count + 1;
end if;
if Curr.Count > 1 then
Curr.Count := Curr.Count - 1;
else
if L.Rep /= null then
L.Rep.Count := L.Rep.Count - 1;
L.Rep.Previous := null;
end if;
Double_Nodes.Delete (Curr);
end if;
end Tail;
procedure Predecessor (L : in out Double_List) is
begin
Assert (L.Rep /= null,
BC.Is_Null'Identity,
"Predecessor",
BSE.Is_Null);
if L.Rep.Previous = null then
Clear (L);
else
L.Rep.Count := L.Rep.Count - 1;
L.Rep := L.Rep.Previous;
L.Rep.Count := L.Rep.Count + 1;
end if;
end Predecessor;
procedure Set_Head (L : in out Double_List; Elem : Item) is
begin
Assert (L.Rep /= null,
BC.Is_Null'Identity,
"Set_Head",
BSE.Is_Null);
L.Rep.Element := ELem;
end Set_Head;
procedure Set_Item (L : in out Double_List;
Elem : Item;
At_Loc : Positive) is
Curr : Double_Nodes.Double_Node_Ref := L.Rep;
Index : Positive := 1;
begin
while Curr /= null and then Index < At_Loc loop
Curr := Curr.Next;
Index := Index + 1;
end loop;
Assert (Curr /= null,
BC.Range_Error'Identity,
"Set_Item",
BSE.Invalid_Index);
Curr.Element := ELem;
end Set_Item;
function Length (L : Double_List) return Natural is
Curr : Double_Nodes.Double_Node_Ref := L.Rep;
Count : Natural := 0;
begin
while Curr /= null loop
Curr := Curr.Next;
Count := Count + 1;
end loop;
return Count;
end Length;
function Is_Null (L : Double_List) return Boolean is
begin
return L.Rep = null;
end Is_Null;
function Is_Shared (L : Double_List) return Boolean is
begin
if L.Rep /= null then
return L.Rep.Count > 1;
else
return False;
end if;
end Is_Shared;
function Is_Head (L : Double_List) return Boolean is
begin
return L.Rep = null or else L.Rep.Previous = null;
end Is_Head;
function Head (L : Double_List) return Item is
begin
Assert (L.Rep /= null,
BC.Is_Null'Identity,
"Head",
BSE.Is_Null);
return L.Rep.Element;
end Head;
procedure Process_Head (L : in out Double_List) is
begin
Assert (L.Rep /= null,
BC.Is_Null'Identity,
"Process_Head",
BSE.Is_Null);
Process (L.Rep.Element);
end Process_Head;
function Foot (L : Double_List) return Item is
Curr : Double_Nodes.Double_Node_Ref := L.Rep;
begin
Assert (L.Rep /= null,
BC.Is_Null'Identity,
"Foot",
BSE.Is_Null);
while Curr.Next /= null loop
Curr := Curr.Next;
end loop;
return Curr.Element;
end Foot;
procedure Process_Foot (L : in out Double_List) is
Curr : Double_Nodes.Double_Node_Ref := L.Rep;
begin
Assert (L.Rep /= null,
BC.Is_Null'Identity,
"Process_Foot",
BSE.Is_Null);
while Curr.Next /= null loop
Curr := Curr.Next;
end loop;
Process (Curr.Element);
end Process_Foot;
function Item_At (L : Double_List; Index : Positive) return Item is
begin
return Item_At (L, Index).all;
end Item_At;
package Address_Conversions
is new System.Address_To_Access_Conversions (Double_List);
function New_Iterator (For_The_List : Double_List) return Iterator is
P : Address_Conversions.Object_Pointer
:= Address_Conversions.To_Pointer (For_The_List'Address);
begin
return Iterator (SP.Create (new Double_List_Iterator (P)));
end New_Iterator;
function Cardinality (L : Double_List) return Natural is
begin
return Length (L);
end Cardinality;
function Item_At (L : Double_List; Index : Positive) return Item_Ptr is
Curr : Double_Nodes.Double_Node_Ref := L.Rep;
Loc : Positive := 1;
begin
Assert (L.Rep /= null,
BC.Is_Null'Identity,
"Item_At",
BSE.Is_Null);
while Curr /= null and then Loc < Index loop
Curr := Curr.Next;
Loc := Loc + 1;
end loop;
Assert (Curr /= null,
BC.Range_Error'Identity,
"Item_At",
BSE.Invalid_Index);
return Curr.Element'access;
end Item_At;
procedure Initialize (L : in out Double_List) is
begin
null;
end Initialize;
procedure Adjust (L : in out Double_List) is
begin
if L.Rep /= null then
L.Rep.Count := L.Rep.Count + 1;
end if;
end Adjust;
procedure Finalize (L : in out Double_List) is
begin
Clear (L);
end Finalize;
procedure Initialize (It : in out Double_List_Iterator) is
begin
Reset (It);
end Initialize;
procedure Reset (It : in out Double_List_Iterator) is
begin
It.Index := It.L.Rep;
end Reset;
procedure Next (It : in out Double_List_Iterator) is
begin
if It.Index /= null then
It.Index := It.Index.Next;
end if;
end Next;
function Is_Done (It : Double_List_Iterator) return Boolean is
begin
return It.Index = null;
end Is_Done;
function Current_Item (It : Double_List_Iterator) return Item is
begin
if Is_Done (It) then
raise BC.Not_Found;
end if;
return It.Index.Element;
end Current_Item;
function Current_Item (It : Double_List_Iterator) return Item_Ptr is
begin
if Is_Done (It) then
raise BC.Not_Found;
end if;
return It.Index.Element'Access;
end Current_Item;
procedure Delete_Item_At (It : Double_List_Iterator) is
Prev : Double_Nodes.Double_Node_Ref;
Curr : Double_Nodes.Double_Node_Ref := It.L.Rep;
begin
if Is_Done (It) then
raise BC.Not_Found;
end if;
while Curr /= null and then Curr /= It.Index loop
Prev := Curr;
Curr := Curr.Next;
end loop;
Assert (Curr /= null,
BC.Range_Error'Identity,
"Delete_Item_At",
BSE.Invalid_Index);
It.Relay.Reference.Index := Curr.Next;
if Prev /= null then
Prev.Next := Curr.Next;
else
It.L.Rep := Curr.Next;
end if;
if Curr.Next /= null then
Curr.Next.Previous := Prev;
end if;
if Curr.Count > 1 then
Curr.Count := Curr.Count - 1;
else
Double_Nodes.Delete (Curr);
end if;
end Delete_Item_At;
end BC.Containers.Lists.Double;