File : charles-lists-double-unbounded.adb
------------------------------------------------------------------------------
-- --
-- CHARLES CONTAINER LIBRARY --
-- --
-- Copyright (C) 2001-2003 Matthew J Heaney --
-- --
-- The Charles Container Library ("Charles") 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. Charles 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 --
-- Charles; see file COPYING.TXT. 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. --
-- --
-- Charles is maintained by Matthew J Heaney. --
-- --
-- http://home.earthlink.net/~matthewjheaney/index.html --
-- mailto:matthewjheaney@earthlink.net --
-- --
------------------------------------------------------------------------------
with System; use type System.Address;
with Ada.Unchecked_Deallocation;
with Charles.Algorithms.Generic_Lexicographical_Compare;
package body Charles.Lists.Double.Unbounded is
procedure Free is
new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
procedure Initialize (Container : in out Container_Type) is
Back : Node_Access renames Container.Back;
begin
Back := new Node_Type;
Back.Next := Back;
Back.Prev := Back;
Container.Length := 0;
end;
procedure Do_Finalize (Back : in out Node_Access) is
First : Node_Access := Back.Next;
begin
while First /= Back loop
declare
X : Node_Access := First;
begin
First := First.Next;
Free (X);
end;
end loop;
Free (Back);
end Do_Finalize;
procedure Adjust (Container : in out Container_Type) is
Source_Back : constant Node_Access := Container.Back;
begin
Container.Back := null;
declare
Iter : Node_Access := Source_Back.Next;
Back_Iter : constant Node_Access := Source_Back;
Back : Node_Access := new Node_Type;
Last : Node_Access;
begin
Back.Next := Back;
Back.Prev := Back;
Last := Back;
while Iter /= Back_Iter loop
Last.Next := new Node_Type'(Element => Iter.Element,
Next => Back,
Prev => Last);
Last := Last.Next;
Iter := Iter.Next;
end loop;
Container.Back := Back;
exception
when others =>
Do_Finalize (Back);
raise;
end;
end Adjust;
procedure Finalize (Container : in out Container_Type) is
begin
if Container.Back /= null then
Do_Finalize (Container.Back);
end if;
end Finalize;
function "=" (Left, Right : Container_Type) return Boolean is
LI : Iterator_Type := First (Left);
RI : Iterator_Type := First (Right);
begin
if Left'Address = Right'Address then
return True;
end if;
if Left.Length /= Right.Length then
return False;
end if;
for I in 1 .. Left.Length loop
if LI.Node.Element /= RI.Node.Element then
return False;
end if;
LI := Succ (LI);
RI := Succ (RI);
end loop;
return True;
end "=";
function Generic_Less
(Left, Right : Container_Type) return Boolean is
function Is_Less (L, R : Node_Access) return Boolean is
pragma Inline (Is_Less);
begin
return L.Element < R.Element;
end;
function Succ (Iter : Node_Access) return Node_Access is
pragma Inline (Succ);
begin
return Iter.Next;
end;
function Lexicographical_Compare is
new Algorithms.Generic_Lexicographical_Compare (Node_Access);
LF : constant Node_Access := Left.Back.Next;
LB : constant Node_Access := Left.Back;
RF : constant Node_Access := Right.Back.Next;
RB : constant Node_Access := Right.Back;
begin
if Left'Address = Right'Address then
return False;
end if;
if Left.Length > Right.Length then
return False;
end if;
return Lexicographical_Compare (LF, LB, RF, RB);
end Generic_Less;
function Length (Container : Container_Type) return Natural is
begin
return Container.Length;
end;
function Is_Empty (Container : Container_Type) return Boolean is
begin
return Container.Length = 0;
end;
procedure Clear (Container : in out Container_Type) is
begin
while Container.Length > 0 loop
Delete_Last (Container);
end loop;
end Clear;
procedure Swap (Left, Right : in out Container_Type) is
L_Node : constant Node_Access := Left.Back;
L_Length : constant Natural := Left.Length;
begin
Left.Back := Right.Back;
Left.Length := Right.Length;
Right.Back := L_Node;
Right.Length := L_Length;
end Swap;
function To_Container (Length : Natural) return Container_Type is
Back : Node_Access := new Node_Type;
begin
Back.Next := Back;
Back.Prev := Back;
for I in 1 .. Length loop
declare
Node : constant Node_Access := new Node_Type;
First : constant Node_Access := Back.Next;
begin
Node.Next := First;
Node.Prev := Back;
Back.Next := Node;
First.Prev := Node;
end;
end loop;
return (Ada.Finalization.Controlled with Back, Length);
exception
when others =>
Do_Finalize (Back);
raise;
end To_Container;
function To_Container
(Length : Natural;
Item : Element_Type) return Container_Type is
Back : Node_Access := new Node_Type;
begin
Back.Next := Back;
Back.Prev := Back;
for I in 1 .. Length loop
declare
First : constant Node_Access := Back.Next;
Node : constant Node_Access :=
new Node_Type'(Element => Item,
Next => First,
Prev => Back);
begin
Back.Next := Node;
First.Prev := Node;
end;
end loop;
return (Ada.Finalization.Controlled with Back, Length);
exception
when others =>
Do_Finalize (Back);
raise;
end To_Container;
function To_Container
(First : Iterator_Type;
Back : Iterator_Type) return Container_Type is
Target_Back : Node_Access := new Node_Type;
Length : Natural := 0;
I : Iterator_Type := First;
begin
Target_Back.Next := Target_Back;
Target_Back.Prev := Target_Back;
while I /= Back loop
declare
Target_Last : constant Node_Access := Target_Back.Prev;
Node : constant Node_Access :=
new Node_Type'(Element => I.Node.Element,
Next => Target_Back,
Prev => Target_Last);
begin
Target_Back.Prev := Node;
Target_Last.Next := Node;
end;
Length := Length + 1;
I := Succ (I);
end loop;
return (Ada.Finalization.Controlled with Target_Back, Length);
exception
when others =>
Do_Finalize (Target_Back);
raise;
end To_Container;
procedure Assign
(Target : in out Container_Type;
Length : in Natural) is
Source : Container_Type := To_Container (Length);
begin
Swap (Target, Source);
end;
procedure Assign
(Target : in out Container_Type;
Length : in Natural;
Item : in Element_Type) is
Source : Container_Type := To_Container (Length, Item);
begin
Swap (Target, Source);
end;
procedure Assign
(Target : in out Container_Type;
Source : in Container_Type) is
begin
if Target'Address = Source'Address then
return;
end if;
declare
C : Container_Type := Source;
begin
Swap (Target, C);
end;
end Assign;
-- procedure Assign
-- (Target : in out Container_Type;
-- Source : in Container_Type;
-- First : in Iterator_Type;
-- Back : in Iterator_Type) is
--
-- pragma Assert (Target'Address /= Source'Address);
-- C : Container_Type := To_Container (Source, First, Back);
-- begin
-- Swap (Target, C);
-- end;
procedure Insert
(Container : in out Container_Type;
Before : in Node_Access;
New_Item : in Element_Type;
New_Node : out Node_Access) is
begin
New_Node := new Node_Type'(Element => New_Item,
Next => Before,
Prev => Before.Prev);
Before.Prev.Next := New_Node;
Before.Prev := New_Node;
Container.Length := Container.Length + 1;
end;
procedure Insert
(Container : in out Container_Type;
Before : in Node_Access;
New_Node : out Node_Access) is
Prev : constant Node_Access := Before.Prev;
begin
New_Node := new Node_Type;
New_Node.Next := Before;
New_Node.Prev := Prev;
Before.Prev.Next := New_Node;
Before.Prev := New_Node;
Container.Length := Container.Length + 1;
end;
procedure Delete
(Container : in out Container_Type;
Node : in out Node_Access) is
pragma Assert (Node /= null);
pragma Assert (Node /= Container.Back);
begin
Container.Length := Container.Length - 1;
Node.Next.Prev := Node.Prev;
Node.Prev.Next := Node.Next;
Free (Node);
end Delete;
procedure Prepend
(Container : in out Container_Type;
New_Item : in Element_Type) is
begin
Insert (Container, First (Container), New_Item);
end;
procedure Prepend
(Container : in out Container_Type) is
begin
Insert (Container, Before => First (Container));
end;
procedure Delete_First (Container : in out Container_Type) is
begin
Delete_Sans_Assign (Container, First (Container));
end;
procedure Append
(Container : in out Container_Type) is
begin
Insert (Container, Back (Container));
end;
procedure Append
(Container : in out Container_Type;
New_Item : in Element_Type) is
begin
Insert (Container, Back (Container), New_Item);
end;
procedure Delete_Last (Container : in out Container_Type) is
begin
Delete_Sans_Assign (Container, Last (Container));
end;
procedure Insert
(Container : in out Container_Type;
Before : in Iterator_Type) is
New_Node : Node_Access;
begin
Insert (Container, Before.Node, New_Node);
end;
procedure Insert
(Container : in out Container_Type;
Before : in Iterator_Type;
New_Item : in Element_Type) is
New_Node : Node_Access;
begin
Insert (Container, Before.Node, New_Item, New_Node);
end;
procedure Insert
(Container : in out Container_Type;
Before : in Iterator_Type;
New_Item : in Element_Type;
Iterator : out Iterator_Type) is
begin
Insert (Container, Before.Node, New_Item, Iterator.Node);
end;
procedure Insert
(Container : in out Container_Type;
Before : in Iterator_Type;
Iterator : out Iterator_Type) is
begin
Insert (Container, Before.Node, Iterator.Node);
end;
procedure Insert_Range
(Container : in out Container_Type;
Before : in Iterator_Type;
Length : in Natural;
Iterator : out Iterator_Type) is
begin
if Length = 0 then
Iterator := Before;
return;
end if;
declare
C : Container_Type := To_Container (Length);
begin
Iterator := First (C);
Splice (Container, Before, Source => C);
end;
end Insert_Range;
procedure Insert_Range
(Container : in out Container_Type;
Before : in Iterator_Type;
Length : in Natural) is
Iterator : Iterator_Type;
begin
Insert_Range (Container, Before, Length, Iterator);
end;
procedure Delete
(Container : in out Container_Type;
Iterator : in out Iterator_Type) is
Node : Node_Access := Iterator.Node;
begin
if Node = null or Node = Container.Back then
return;
end if;
Iterator := Succ (Iterator);
Delete (Container, Node);
end Delete;
procedure Delete_Sans_Increment
(Container : in out Container_Type;
Iterator : in out Iterator_Type) is
Node : Node_Access := Iterator.Node;
begin
if Node = null or Node = Container.Back then
return;
end if;
Iterator := Back (Container);
Delete (Container, Node);
end Delete_Sans_Increment;
procedure Delete_Sans_Assign
(Container : in out Container_Type;
Iterator : in Iterator_Type) is
Node : Node_Access := Iterator.Node;
begin
if Node = null or Node = Container.Back then
return;
end if;
Delete (Container, Node);
end Delete_Sans_Assign;
procedure Delete
(Container : in out Container_Type;
First : in out Iterator_Type;
Back : in Iterator_Type) is
Container_Back : constant Iterator_Type :=
Unbounded.Back (Container);
begin
if First = Null_Iterator or Back = Null_Iterator then
return;
end if;
while First /= Back and First /= Container_Back loop
Delete (Container, First);
end loop;
end Delete;
-- procedure Unchecked_Delete
-- (Container : in out Container_Type;
-- Iterator : in Iterator_Type) is
--
-- Node : Node_Access := Iterator.Node;
-- begin
-- Delete (Container, Node);
-- end;
--
-- procedure Unchecked_Delete
-- (Container : in out Container_Type;
-- First : in Iterator_Type;
-- Back : in Iterator_Type) is
--
-- Iterator : Iterator_Type := First;
-- begin
-- while Iterator /= Back loop
-- Delete (Container, Iterator);
-- end loop;
-- end;
procedure Delete
(Container : in out Container_Type;
Item : in Element_Type) is
Iter : Iterator_Type := First (Container);
Back_Iter : constant Iterator_Type := Back (Container);
begin
while Iter /= Back_Iter loop
if Iter.Node.Element = Item then
Delete (Container, Iter);
else
Iter := Succ (Iter);
end if;
end loop;
end;
procedure Generic_Delete (Container : in out Container_Type) is
Iter : Iterator_Type := First (Container);
Back_Iter : constant Iterator_Type := Back (Container);
begin
while Iter /= Back_Iter loop
if Predicate (Iter.Node.Element) then
Delete (Container, Iter);
else
Iter := Succ (Iter);
end if;
end loop;
end;
procedure Reverse_List (Container : in out Container_Type) is
procedure Swap (L, R : Node_Access) is
LN : constant Node_Access := L.Next;
LP : constant Node_Access := L.Prev;
RN : constant Node_Access := R.Next;
RP : constant Node_Access := R.Prev;
begin
LP.Next := R;
RN.Prev := L;
L.Next := RN;
R.Prev := LP;
if LN = R then
pragma Assert (RP = L);
L.Prev := R;
R.Next := L;
else
L.Prev := RP;
RP.Next := L;
R.Next := LN;
LN.Prev := R;
end if;
end Swap;
I : Node_Access := Container.Back.Next;
J : Node_Access := Container.Back;
begin
while I /= J loop
J := J.Prev;
exit when I = J;
Swap (I, J);
J := J.Next;
exit when I = J;
I := I.Prev;
exit when I = J;
Swap (J, I);
I := I.Next;
end loop;
end Reverse_List;
function First
(Container : Container_Type) return Iterator_Type is
begin
return (Node => Container.Back.Next);
end;
function First_Element
(Container : Container_Type) return Element_Type is
I : constant Iterator_Type := First (Container);
begin
return I.Node.Element;
end;
function Back
(Container : Container_Type) return Iterator_Type is
begin
return (Node => Container.Back);
end;
function Last
(Container : Container_Type) return Iterator_Type is
begin
return Pred (Back (Container));
end;
function Last_Element
(Container : Container_Type) return Element_Type is
I : constant Iterator_Type := Last (Container);
begin
return I.Node.Element;
end;
-- function Front
-- (Container : Container_Type) return Iterator_Type is
-- begin
-- return Pred (First (Container));
-- end;
function Element
(Iterator : Iterator_Type) return Element_Type is
begin
return Iterator.Node.Element;
end;
function Generic_Element
(Iterator : Iterator_Type) return Element_Access is
begin
return Iterator.Node.Element'Access;
end;
procedure Replace_Element
(Iterator : Iterator_Type;
By : Element_Type) is
begin
Iterator.Node.Element := By;
end;
procedure Copy_Element
(Iterator : in Iterator_Type;
Item : out Element_Type) is
begin
Item := Iterator.Node.Element;
end;
procedure Swap
(Iterator : in Iterator_Type;
Item : in out Element_Type) is
E : constant Element_Type := Iterator.Node.Element;
begin
Iterator.Node.Element := Item;
Item := E;
end;
procedure Generic_Swap
(Iterator : in Iterator_Type;
Item : in out Element_Type) is
begin
Swap (Iterator.Node.Element, Item);
end;
procedure Swap_Element (Left, Right : in Iterator_Type) is
LE : constant Element_Type := Left.Node.Element;
begin
Left.Node.Element := Right.Node.Element;
Right.Node.Element := LE;
end;
procedure Generic_Swap_Element (Left, Right : in Iterator_Type) is
LE : Element_Type renames Left.Node.Element;
RE : Element_Type renames Right.Node.Element;
begin
Swap (LE, RE);
end;
procedure Swap_Iterator (Left, Right : in out Iterator_Type) is
LI : constant Iterator_Type := Left;
begin
Left := Right;
Right := LI;
end;
procedure Generic_Select_Element
(Iterator : in Iterator_Type) is
begin
Process (Iterator.Node.Element);
end;
procedure Generic_Modify_Element
(Iterator : in Iterator_Type) is
begin
Process (Iterator.Node.Element);
end;
procedure Generic_Access_Element
(Iterator : in Iterator_Type) is
begin
Process (Iterator.Node.Element'Access);
end;
procedure Generic_Iteration
(First : in Iterator_Type;
Back : in Iterator_Type) is
Iter : Iterator_Type := First;
begin
while Iter /= Back loop
Process (Iter);
Iter := Succ (Iter);
end loop;
end;
procedure Generic_Reverse_Iteration
(First : in Iterator_Type;
Back : in Iterator_Type) is
Iter : Iterator_Type := Back;
begin
while Iter /= First loop
Iter := Pred (Iter);
Process (Iter);
end loop;
end;
procedure Generic_Select_Elements
(First : in Iterator_Type;
Back : in Iterator_Type) is
Iter : Iterator_Type := First;
begin
while Iter /= Back loop
Process (Iter.Node.Element);
Iter := Succ (Iter);
end loop;
end;
procedure Generic_Modify_Elements
(First : in Iterator_Type;
Back : in Iterator_Type) is
Iter : Iterator_Type := First;
begin
while Iter /= Back loop
Process (Iter.Node.Element);
Iter := Succ (Iter);
end loop;
end;
procedure Generic_Access_Elements
(First : in Iterator_Type;
Back : in Iterator_Type) is
Iter : Iterator_Type := First;
begin
while Iter /= Back loop
Process (Iter.Node.Element'Access);
Iter := Succ (Iter);
end loop;
end;
procedure Generic_Reverse_Select_Elements
(First : in Iterator_Type;
Back : in Iterator_Type) is
Iter : Iterator_Type := Back;
begin
while Iter /= First loop
Iter := Pred (Iter);
Process (Iter.Node.Element);
end loop;
end;
procedure Generic_Reverse_Modify_Elements
(First : in Iterator_Type;
Back : in Iterator_Type) is
Iter : Iterator_Type := Back;
begin
while Iter /= First loop
Iter := Pred (Iter);
Process (Iter.Node.Element);
end loop;
end;
procedure Generic_Reverse_Access_Elements
(First : in Iterator_Type;
Back : in Iterator_Type) is
Iter : Iterator_Type := Back;
begin
while Iter /= First loop
Iter := Pred (Iter);
Process (Iter.Node.Element'Access);
end loop;
end;
function Generic_Find
(First : Iterator_Type;
Back : Iterator_Type) return Iterator_Type is
Iter : Iterator_Type := First;
begin
while Iter /= Back loop
if Predicate (Iter.Node.Element) then
return Iter;
end if;
Iter := Succ (Iter);
end loop;
return Back;
end;
function Find
(First : Iterator_Type;
Back : Iterator_Type;
Item : Element_Type) return Iterator_Type is
function Predicate (Element : Element_Type) return Boolean is
begin
return Item = Element;
end;
function Find is
new Generic_Find (Predicate);
begin
return Find (First, Back);
end;
function Find
(Container : Container_Type;
Item : Element_Type) return Iterator_Type is
begin
return Find (First (Container), Back (Container), Item);
end;
function Is_In
(Item : Element_Type;
First, Back : Iterator_Type) return Boolean is
begin
return Find (First, Back, Item) /= Back;
end;
function Is_In
(Item : Element_Type;
Container : Container_Type) return Boolean is
begin
return Is_In (Item, First (Container), Back (Container));
end;
function Is_In
(Iterator : Iterator_Type;
First, Back : Iterator_Type) return Boolean is
I : Iterator_Type := First;
begin
if Iterator = Null_Iterator
or else First = Null_Iterator
or else Back = Null_Iterator
then
return False; --or true?
end if;
while I /= Back loop
if I = Iterator then
return True;
end if;
I := Succ (I);
end loop;
return False;
end Is_In;
function Generic_Reverse_Find
(First : Iterator_Type;
Back : Iterator_Type) return Iterator_Type is
Iter : Iterator_Type := Back;
begin
while Iter /= First loop
Iter := Pred (Iter);
if Predicate (Iter.Node.Element) then
return Iter;
end if;
end loop;
return Back;
end;
function Reverse_Find
(First : Iterator_Type;
Back : Iterator_Type;
Item : Element_Type) return Iterator_Type is
function Predicate (Element : Element_Type) return Boolean is
begin
return Item = Element;
end;
function Reverse_Find is
new Generic_Reverse_Find (Predicate);
begin
return Reverse_Find (First, Back);
end;
function Reverse_Find
(Container : Container_Type;
Item : Element_Type) return Iterator_Type is
begin
return Reverse_Find (First (Container), Back (Container), Item);
end;
procedure Splice
(Container : in out Container_Type;
Before : in Iterator_Type;
Source : in out Container_Type) is
begin
if Container'Address = Source'Address
or else Before = Null_Iterator
or else Source.Length = 0
then
return;
end if;
Before.Node.Prev.Next := Source.Back.Next;
Source.Back.Next.Prev := Before.Node.Prev;
Before.Node.Prev := Source.Back.Prev;
Source.Back.Prev.Next := Before.Node;
Source.Back.Next := Source.Back;
Source.Back.Prev := Source.Back;
Container.Length := Container.Length + Source.Length;
Source.Length := 0;
end Splice;
procedure Splice
(Container : in Container_Type;
Before : in Iterator_Type;
Iterator : in Iterator_Type) is
begin
if Before = Null_Iterator
or else Iterator = Null_Iterator
or else Iterator = Back (Container)
or else Iterator = Before
or else Succ (Iterator) = Before
then
return;
end if;
pragma Assert (Container.Length > 0);
Iterator.Node.Prev.Next := Iterator.Node.Next;
Iterator.Node.Next.Prev := Iterator.Node.Prev;
Before.Node.Prev.Next := Iterator.Node;
Iterator.Node.Prev := Before.Node.Prev;
Before.Node.Prev := Iterator.Node;
Iterator.Node.Next := Before.Node;
end Splice;
procedure Splice
(Container : in out Container_Type;
Before : in Iterator_Type;
Source : in out Container_Type;
Iterator : in Iterator_Type) is
begin
if Before = Null_Iterator
or else Iterator = Null_Iterator
or else Iterator = Back (Source)
or else Iterator = Before
or else Succ (Iterator) = Before
then
return;
end if;
pragma Assert (Source.Length > 0);
Iterator.Node.Prev.Next := Iterator.Node.Next;
Iterator.Node.Next.Prev := Iterator.Node.Prev;
Before.Node.Prev.Next := Iterator.Node;
Iterator.Node.Prev := Before.Node.Prev;
Before.Node.Prev := Iterator.Node;
Iterator.Node.Next := Before.Node;
if Container'Address /= Source'Address then
Container.Length := Container.Length + 1;
Source.Length := Source.Length - 1;
end if;
end Splice;
procedure Splice
(Container : in Container_Type;
Before : in Iterator_Type;
First : in Iterator_Type;
Back : in Iterator_Type) is
pragma Warnings (Off, Container);
Last : Node_Access;
begin
if Before = Null_Iterator
or else First = Null_Iterator
or else Back = Null_Iterator
or else Before = Back
or else First = Back
then
return;
end if;
pragma Assert (not Is_In (Before, First, Back));
pragma Assert (not Is_In (Unbounded.Back (Container), First, Back));
Last := Back.Node.Prev;
First.Node.Prev.Next := Back.Node;
Back.Node.Prev := First.Node.Prev;
First.Node.Prev := Before.Node.Prev;
Before.Node.Prev.Next := First.Node;
Last.Next := Before.Node;
Before.Node.Prev := Last;
end Splice;
procedure Splice
(Container : in out Container_Type;
Before : in Iterator_Type;
Source : in out Container_Type;
First : in Iterator_Type;
Back : in Iterator_Type) is
Count : Positive;
Last : Node_Access;
begin
if Container'Address = Source'Address then
Splice (Container, Before, First, Back);
return;
end if;
if Before = Null_Iterator
or else First = Null_Iterator
or else Back = Null_Iterator
or else First = Back
then
return;
end if;
pragma Assert (Before /= Back);
pragma Assert (Source.Length > 0);
pragma Assert (not Is_In (Unbounded.Back (Source), First, Back));
Count := Offset (From => First, To => Back);
pragma Assert (Count <= Source.Length);
Last := Back.Node.Prev;
First.Node.Prev.Next := Back.Node;
Back.Node.Prev := First.Node.Prev;
First.Node.Prev := Before.Node.Prev;
Before.Node.Prev.Next := First.Node;
Last.Next := Before.Node;
Before.Node.Prev := Last;
Container.Length := Container.Length + Count;
Source.Length := Source.Length - Count;
end Splice;
function Succ
(Iterator : Iterator_Type) return Iterator_Type is
begin
return (Node => Iterator.Node.Next);
end;
function Succ
(Iterator : Iterator_Type;
Offset : Natural) return Iterator_Type is
Result : Iterator_Type := Iterator;
begin
for I in 1 .. Offset loop
Result := Succ (Result);
end loop;
return Result;
end;
function Pred
(Iterator : Iterator_Type) return Iterator_Type is
begin
return (Node => Iterator.Node.Prev);
end;
function Pred
(Iterator : Iterator_Type;
Offset : Natural) return Iterator_Type is
Result : Iterator_Type := Iterator;
begin
for I in 1 .. Offset loop
Result := Pred (Result);
end loop;
return Result;
end;
procedure Increment (Iterator : in out Iterator_Type) is
begin
Iterator := Succ (Iterator);
end;
procedure Increment
(Iterator : in out Iterator_Type;
Offset : in Natural) is
begin
Iterator := Succ (Iterator, Offset);
end;
procedure Decrement (Iterator : in out Iterator_Type) is
begin
Iterator := Pred (Iterator);
end;
procedure Decrement
(Iterator : in out Iterator_Type;
Offset : in Natural) is
begin
Iterator := Pred (Iterator, Offset);
end;
function Offset
(From, To : Iterator_Type) return Natural is
Result : Integer'Base := 0;
I : Iterator_Type := From;
begin
while I /= To loop
Result := Result + 1;
I := Succ (I);
end loop;
return Result;
end;
procedure Generic_Unique (Container : in out Container_Type) is
I : Iterator_Type := First (Container);
J : Iterator_Type;
B : constant Iterator_Type := Back (Container);
begin
if Container.Length = 0 then
return;
end if;
J := Succ (I);
while J /= B loop
if Predicate (J.Node.Element, I.Node.Element) then
Delete (Container, J);
else
I := J;
J := Succ (I);
end if;
end loop;
end Generic_Unique;
procedure Unique (Container : in out Container_Type) is
procedure Do_Unique is
new Generic_Unique (Predicate => "=");
begin
Do_Unique (Container);
end;
procedure Generic_Merge
(Container : in out Container_Type;
Source : in out Container_Type) is
LI : Iterator_Type := First (Container);
LB : constant Iterator_Type := Back (Container);
RI : Iterator_Type := First (Source);
RB : constant Iterator_Type := Back (Source);
begin
if Container'Address = Source'Address then
return;
end if;
while RI /= RB loop
if LI = LB then
Splice (Container, LB, Source);
return;
end if;
if RI.Node.Element < LI.Node.Element then
declare
RJ : constant Iterator_Type := RI;
begin
RI := Succ (RI);
Splice (Container, LI, Source, RJ);
end;
else
LI := Succ (LI);
end if;
end loop;
end Generic_Merge;
procedure Generic_Quicksort
(Container : in out Container_Type) is
procedure Partition
(Pivot : in Node_Access;
Back : in Node_Access) is
Node : Node_Access := Pivot.Next;
begin
while Node /= Back loop
if Node.Element < Pivot.Element then
declare
Prev : constant Node_Access := Node.Prev;
Next : constant Node_Access := Node.Next;
begin
Prev.Next := Next;
Next.Prev := Prev;
Node.Next := Pivot;
Node.Prev := Pivot.Prev;
Pivot.Prev := Node;
Node.Prev.Next := Node;
Node := Next;
end;
else
Node := Node.Next;
end if;
end loop;
end Partition;
procedure Sort (Front, Back : Node_Access) is
Pivot : constant Node_Access := Front.Next;
begin
if Pivot /= Back then
Partition (Pivot, Back);
Sort (Front, Pivot);
Sort (Pivot, Back);
end if;
end Sort;
begin
Sort (Container.Back, Container.Back);
end Generic_Quicksort;
function Is_Equal (Left, Right : Iterator_Type) return Boolean is
begin
return Left.Node.Element = Right.Node.Element;
end;
function Is_Equal
(Left : Iterator_Type;
Right : Element_Type) return Boolean is
begin
return Left.Node.Element = Right;
end;
function Is_Equal
(Left : Element_Type;
Right : Iterator_Type) return Boolean is
begin
return Left = Right.Node.Element;
end;
end Charles.Lists.Double.Unbounded;