1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . F O R M A L _ O R D E R E D _ S E T S --
9 -- Copyright (C) 2010-2013, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
26 ------------------------------------------------------------------------------
28 with Ada
.Containers
.Red_Black_Trees
.Generic_Bounded_Operations
;
30 (Ada
.Containers
.Red_Black_Trees
.Generic_Bounded_Operations
);
32 with Ada
.Containers
.Red_Black_Trees
.Generic_Bounded_Keys
;
33 pragma Elaborate_All
(Ada
.Containers
.Red_Black_Trees
.Generic_Bounded_Keys
);
35 with Ada
.Containers
.Red_Black_Trees
.Generic_Bounded_Set_Operations
;
37 (Ada
.Containers
.Red_Black_Trees
.Generic_Bounded_Set_Operations
);
39 with System
; use type System
.Address
;
41 package body Ada
.Containers
.Formal_Ordered_Sets
is
43 ------------------------------
44 -- Access to Fields of Node --
45 ------------------------------
47 -- These subprograms provide functional notation for access to fields
48 -- of a node, and procedural notation for modifiying these fields.
50 function Color
(Node
: Node_Type
) return Red_Black_Trees
.Color_Type
;
51 pragma Inline
(Color
);
53 function Left_Son
(Node
: Node_Type
) return Count_Type
;
54 pragma Inline
(Left_Son
);
56 function Parent
(Node
: Node_Type
) return Count_Type
;
57 pragma Inline
(Parent
);
59 function Right_Son
(Node
: Node_Type
) return Count_Type
;
60 pragma Inline
(Right_Son
);
63 (Node
: in out Node_Type
;
64 Color
: Red_Black_Trees
.Color_Type
);
65 pragma Inline
(Set_Color
);
67 procedure Set_Left
(Node
: in out Node_Type
; Left
: Count_Type
);
68 pragma Inline
(Set_Left
);
70 procedure Set_Right
(Node
: in out Node_Type
; Right
: Count_Type
);
71 pragma Inline
(Set_Right
);
73 procedure Set_Parent
(Node
: in out Node_Type
; Parent
: Count_Type
);
74 pragma Inline
(Set_Parent
);
76 -----------------------
77 -- Local Subprograms --
78 -----------------------
83 with procedure Set_Element
(Node
: in out Node_Type
);
84 procedure Generic_Allocate
85 (Tree
: in out Tree_Types
.Tree_Type
'Class;
86 Node
: out Count_Type
);
88 procedure Free
(Tree
: in out Set
; X
: Count_Type
);
90 procedure Insert_Sans_Hint
91 (Container
: in out Set
;
92 New_Item
: Element_Type
;
93 Node
: out Count_Type
;
94 Inserted
: out Boolean);
96 procedure Insert_With_Hint
97 (Dst_Set
: in out Set
;
98 Dst_Hint
: Count_Type
;
100 Dst_Node
: out Count_Type
);
102 function Is_Greater_Element_Node
103 (Left
: Element_Type
;
104 Right
: Node_Type
) return Boolean;
105 pragma Inline
(Is_Greater_Element_Node
);
107 function Is_Less_Element_Node
108 (Left
: Element_Type
;
109 Right
: Node_Type
) return Boolean;
110 pragma Inline
(Is_Less_Element_Node
);
112 function Is_Less_Node_Node
(L
, R
: Node_Type
) return Boolean;
113 pragma Inline
(Is_Less_Node_Node
);
115 procedure Replace_Element
118 Item
: Element_Type
);
120 --------------------------
121 -- Local Instantiations --
122 --------------------------
124 package Tree_Operations
is
125 new Red_Black_Trees
.Generic_Bounded_Operations
132 package Element_Keys
is
133 new Red_Black_Trees
.Generic_Bounded_Keys
134 (Tree_Operations
=> Tree_Operations
,
135 Key_Type
=> Element_Type
,
136 Is_Less_Key_Node
=> Is_Less_Element_Node
,
137 Is_Greater_Key_Node
=> Is_Greater_Element_Node
);
140 new Red_Black_Trees
.Generic_Bounded_Set_Operations
141 (Tree_Operations
=> Tree_Operations
,
144 Insert_With_Hint
=> Insert_With_Hint
,
145 Is_Less
=> Is_Less_Node_Node
);
151 function "=" (Left
, Right
: Set
) return Boolean is
157 if Length
(Left
) /= Length
(Right
) then
161 if Is_Empty
(Left
) then
165 Lst
:= Next
(Left
, Last
(Left
).Node
);
167 Node
:= First
(Left
).Node
;
168 while Node
/= Lst
loop
169 ENode
:= Find
(Right
, Left
.Nodes
(Node
).Element
).Node
;
171 or else Left
.Nodes
(Node
).Element
/= Right
.Nodes
(ENode
).Element
176 Node
:= Next
(Left
, Node
);
186 procedure Assign
(Target
: in out Set
; Source
: Set
) is
187 procedure Append_Element
(Source_Node
: Count_Type
);
189 procedure Append_Elements
is
190 new Tree_Operations
.Generic_Iteration
(Append_Element
);
196 procedure Append_Element
(Source_Node
: Count_Type
) is
197 SN
: Node_Type
renames Source
.Nodes
(Source_Node
);
199 procedure Set_Element
(Node
: in out Node_Type
);
200 pragma Inline
(Set_Element
);
202 function New_Node
return Count_Type
;
203 pragma Inline
(New_Node
);
205 procedure Insert_Post
is
206 new Element_Keys
.Generic_Insert_Post
(New_Node
);
208 procedure Unconditional_Insert_Sans_Hint
is
209 new Element_Keys
.Generic_Unconditional_Insert
(Insert_Post
);
211 procedure Unconditional_Insert_Avec_Hint
is
212 new Element_Keys
.Generic_Unconditional_Insert_With_Hint
214 Unconditional_Insert_Sans_Hint
);
216 procedure Allocate
is new Generic_Allocate
(Set_Element
);
222 function New_Node
return Count_Type
is
225 Allocate
(Target
, Result
);
233 procedure Set_Element
(Node
: in out Node_Type
) is
235 Node
.Element
:= SN
.Element
;
240 Target_Node
: Count_Type
;
242 -- Start of processing for Append_Element
245 Unconditional_Insert_Avec_Hint
249 Node
=> Target_Node
);
252 -- Start of processing for Assign
255 if Target
'Address = Source
'Address then
259 if Target
.Capacity
< Source
.Length
then
260 raise Constraint_Error
261 with "Target capacity is less than Source length";
264 Tree_Operations
.Clear_Tree
(Target
);
265 Append_Elements
(Source
);
272 function Ceiling
(Container
: Set
; Item
: Element_Type
) return Cursor
is
273 Node
: constant Count_Type
:= Element_Keys
.Ceiling
(Container
, Item
);
280 return (Node
=> Node
);
287 procedure Clear
(Container
: in out Set
) is
289 Tree_Operations
.Clear_Tree
(Container
);
296 function Color
(Node
: Node_Type
) return Red_Black_Trees
.Color_Type
is
307 Item
: Element_Type
) return Boolean
310 return Find
(Container
, Item
) /= No_Element
;
317 function Copy
(Source
: Set
; Capacity
: Count_Type
:= 0) return Set
is
320 Target
: Set
(Count_Type
'Max (Source
.Capacity
, Capacity
));
323 if 0 < Capacity
and then Capacity
< Source
.Capacity
then
324 raise Capacity_Error
;
327 if Length
(Source
) > 0 then
328 Target
.Length
:= Source
.Length
;
329 Target
.Root
:= Source
.Root
;
330 Target
.First
:= Source
.First
;
331 Target
.Last
:= Source
.Last
;
332 Target
.Free
:= Source
.Free
;
335 while Node
<= Source
.Capacity
loop
336 Target
.Nodes
(Node
).Element
:=
337 Source
.Nodes
(Node
).Element
;
338 Target
.Nodes
(Node
).Parent
:=
339 Source
.Nodes
(Node
).Parent
;
340 Target
.Nodes
(Node
).Left
:=
341 Source
.Nodes
(Node
).Left
;
342 Target
.Nodes
(Node
).Right
:=
343 Source
.Nodes
(Node
).Right
;
344 Target
.Nodes
(Node
).Color
:=
345 Source
.Nodes
(Node
).Color
;
346 Target
.Nodes
(Node
).Has_Element
:=
347 Source
.Nodes
(Node
).Has_Element
;
351 while Node
<= Target
.Capacity
loop
353 Formal_Ordered_Sets
.Free
(Tree
=> Target
, X
=> N
);
361 ---------------------
362 -- Current_To_Last --
363 ---------------------
365 function Current_To_Last
(Container
: Set
; Current
: Cursor
) return Set
is
366 Curs
: Cursor
:= First
(Container
);
367 C
: Set
(Container
.Capacity
) := Copy
(Container
, Container
.Capacity
);
371 if Curs
= No_Element
then
376 if Current
/= No_Element
and not Has_Element
(Container
, Current
) then
377 raise Constraint_Error
;
380 while Curs
.Node
/= Current
.Node
loop
383 Curs
:= Next
(Container
, (Node
=> Node
));
393 procedure Delete
(Container
: in out Set
; Position
: in out Cursor
) is
395 if not Has_Element
(Container
, Position
) then
396 raise Constraint_Error
with "Position cursor has no element";
399 pragma Assert
(Vet
(Container
, Position
.Node
),
400 "bad cursor in Delete");
402 Tree_Operations
.Delete_Node_Sans_Free
(Container
,
404 Formal_Ordered_Sets
.Free
(Container
, Position
.Node
);
405 Position
:= No_Element
;
408 procedure Delete
(Container
: in out Set
; Item
: Element_Type
) is
409 X
: constant Count_Type
:= Element_Keys
.Find
(Container
, Item
);
413 raise Constraint_Error
with "attempt to delete element not in set";
416 Tree_Operations
.Delete_Node_Sans_Free
(Container
, X
);
417 Formal_Ordered_Sets
.Free
(Container
, X
);
424 procedure Delete_First
(Container
: in out Set
) is
425 X
: constant Count_Type
:= Container
.First
;
428 Tree_Operations
.Delete_Node_Sans_Free
(Container
, X
);
429 Formal_Ordered_Sets
.Free
(Container
, X
);
437 procedure Delete_Last
(Container
: in out Set
) is
438 X
: constant Count_Type
:= Container
.Last
;
441 Tree_Operations
.Delete_Node_Sans_Free
(Container
, X
);
442 Formal_Ordered_Sets
.Free
(Container
, X
);
450 procedure Difference
(Target
: in out Set
; Source
: Set
) is
452 Set_Ops
.Set_Difference
(Target
, Source
);
455 function Difference
(Left
, Right
: Set
) return Set
is
457 if Left
'Address = Right
'Address then
461 if Length
(Left
) = 0 then
465 if Length
(Right
) = 0 then
469 return S
: Set
(Length
(Left
)) do
470 Assign
(S
, Set_Ops
.Set_Difference
(Left
, Right
));
478 function Element
(Container
: Set
; Position
: Cursor
) return Element_Type
is
480 if not Has_Element
(Container
, Position
) then
481 raise Constraint_Error
with "Position cursor has no element";
484 pragma Assert
(Vet
(Container
, Position
.Node
),
485 "bad cursor in Element");
487 return Container
.Nodes
(Position
.Node
).Element
;
490 -------------------------
491 -- Equivalent_Elements --
492 -------------------------
494 function Equivalent_Elements
(Left
, Right
: Element_Type
) return Boolean is
503 end Equivalent_Elements
;
505 ---------------------
506 -- Equivalent_Sets --
507 ---------------------
509 function Equivalent_Sets
(Left
, Right
: Set
) return Boolean is
510 function Is_Equivalent_Node_Node
511 (L
, R
: Node_Type
) return Boolean;
512 pragma Inline
(Is_Equivalent_Node_Node
);
514 function Is_Equivalent
is
515 new Tree_Operations
.Generic_Equal
(Is_Equivalent_Node_Node
);
517 -----------------------------
518 -- Is_Equivalent_Node_Node --
519 -----------------------------
521 function Is_Equivalent_Node_Node
(L
, R
: Node_Type
) return Boolean is
523 if L
.Element
< R
.Element
then
525 elsif R
.Element
< L
.Element
then
530 end Is_Equivalent_Node_Node
;
532 -- Start of processing for Equivalent_Sets
535 return Is_Equivalent
(Left
, Right
);
542 procedure Exclude
(Container
: in out Set
; Item
: Element_Type
) is
543 X
: constant Count_Type
:= Element_Keys
.Find
(Container
, Item
);
546 Tree_Operations
.Delete_Node_Sans_Free
(Container
, X
);
547 Formal_Ordered_Sets
.Free
(Container
, X
);
555 function Find
(Container
: Set
; Item
: Element_Type
) return Cursor
is
556 Node
: constant Count_Type
:= Element_Keys
.Find
(Container
, Item
);
563 return (Node
=> Node
);
570 function First
(Container
: Set
) return Cursor
is
572 if Length
(Container
) = 0 then
576 return (Node
=> Container
.First
);
583 function First_Element
(Container
: Set
) return Element_Type
is
584 Fst
: constant Count_Type
:= First
(Container
).Node
;
587 raise Constraint_Error
with "set is empty";
591 N
: Tree_Types
.Nodes_Type
renames Container
.Nodes
;
593 return N
(Fst
).Element
;
597 -----------------------
598 -- First_To_Previous --
599 -----------------------
601 function First_To_Previous
603 Current
: Cursor
) return Set
605 Curs
: Cursor
:= Current
;
606 C
: Set
(Container
.Capacity
) := Copy
(Container
, Container
.Capacity
);
610 if Curs
= No_Element
then
613 elsif not Has_Element
(Container
, Curs
) then
614 raise Constraint_Error
;
617 while Curs
.Node
/= 0 loop
620 Curs
:= Next
(Container
, (Node
=> Node
));
625 end First_To_Previous
;
631 function Floor
(Container
: Set
; Item
: Element_Type
) return Cursor
is
634 Node
: constant Count_Type
:= Element_Keys
.Floor
(Container
, Item
);
641 return (Node
=> Node
);
649 procedure Free
(Tree
: in out Set
; X
: Count_Type
) is
651 Tree
.Nodes
(X
).Has_Element
:= False;
652 Tree_Operations
.Free
(Tree
, X
);
655 ----------------------
656 -- Generic_Allocate --
657 ----------------------
659 procedure Generic_Allocate
660 (Tree
: in out Tree_Types
.Tree_Type
'Class;
661 Node
: out Count_Type
)
663 procedure Allocate
is
664 new Tree_Operations
.Generic_Allocate
(Set_Element
);
666 Allocate
(Tree
, Node
);
667 Tree
.Nodes
(Node
).Has_Element
:= True;
668 end Generic_Allocate
;
674 package body Generic_Keys
is
676 -----------------------
677 -- Local Subprograms --
678 -----------------------
680 function Is_Greater_Key_Node
682 Right
: Node_Type
) return Boolean;
683 pragma Inline
(Is_Greater_Key_Node
);
685 function Is_Less_Key_Node
687 Right
: Node_Type
) return Boolean;
688 pragma Inline
(Is_Less_Key_Node
);
690 --------------------------
691 -- Local Instantiations --
692 --------------------------
695 new Red_Black_Trees
.Generic_Bounded_Keys
696 (Tree_Operations
=> Tree_Operations
,
697 Key_Type
=> Key_Type
,
698 Is_Less_Key_Node
=> Is_Less_Key_Node
,
699 Is_Greater_Key_Node
=> Is_Greater_Key_Node
);
705 function Ceiling
(Container
: Set
; Key
: Key_Type
) return Cursor
is
706 Node
: constant Count_Type
:= Key_Keys
.Ceiling
(Container
, Key
);
713 return (Node
=> Node
);
720 function Contains
(Container
: Set
; Key
: Key_Type
) return Boolean is
722 return Find
(Container
, Key
) /= No_Element
;
729 procedure Delete
(Container
: in out Set
; Key
: Key_Type
) is
730 X
: constant Count_Type
:= Key_Keys
.Find
(Container
, Key
);
734 raise Constraint_Error
with "attempt to delete key not in set";
737 Delete_Node_Sans_Free
(Container
, X
);
738 Formal_Ordered_Sets
.Free
(Container
, X
);
745 function Element
(Container
: Set
; Key
: Key_Type
) return Element_Type
is
746 Node
: constant Count_Type
:= Key_Keys
.Find
(Container
, Key
);
750 raise Constraint_Error
with "key not in set";
754 N
: Tree_Types
.Nodes_Type
renames Container
.Nodes
;
756 return N
(Node
).Element
;
760 ---------------------
761 -- Equivalent_Keys --
762 ---------------------
764 function Equivalent_Keys
(Left
, Right
: Key_Type
) return Boolean is
779 procedure Exclude
(Container
: in out Set
; Key
: Key_Type
) is
780 X
: constant Count_Type
:= Key_Keys
.Find
(Container
, Key
);
783 Delete_Node_Sans_Free
(Container
, X
);
784 Formal_Ordered_Sets
.Free
(Container
, X
);
792 function Find
(Container
: Set
; Key
: Key_Type
) return Cursor
is
793 Node
: constant Count_Type
:= Key_Keys
.Find
(Container
, Key
);
795 return (if Node
= 0 then No_Element
else (Node
=> Node
));
802 function Floor
(Container
: Set
; Key
: Key_Type
) return Cursor
is
803 Node
: constant Count_Type
:= Key_Keys
.Floor
(Container
, Key
);
805 return (if Node
= 0 then No_Element
else (Node
=> Node
));
808 -------------------------
809 -- Is_Greater_Key_Node --
810 -------------------------
812 function Is_Greater_Key_Node
814 Right
: Node_Type
) return Boolean
817 return Key
(Right
.Element
) < Left
;
818 end Is_Greater_Key_Node
;
820 ----------------------
821 -- Is_Less_Key_Node --
822 ----------------------
824 function Is_Less_Key_Node
826 Right
: Node_Type
) return Boolean
829 return Left
< Key
(Right
.Element
);
830 end Is_Less_Key_Node
;
836 function Key
(Container
: Set
; Position
: Cursor
) return Key_Type
is
838 if not Has_Element
(Container
, Position
) then
839 raise Constraint_Error
with
840 "Position cursor has no element";
843 pragma Assert
(Vet
(Container
, Position
.Node
),
844 "bad cursor in Key");
847 N
: Tree_Types
.Nodes_Type
renames Container
.Nodes
;
849 return Key
(N
(Position
.Node
).Element
);
858 (Container
: in out Set
;
860 New_Item
: Element_Type
)
862 Node
: constant Count_Type
:= Key_Keys
.Find
(Container
, Key
);
864 if not Has_Element
(Container
, (Node
=> Node
)) then
865 raise Constraint_Error
with
866 "attempt to replace key not in set";
868 Replace_Element
(Container
, Node
, New_Item
);
878 function Has_Element
(Container
: Set
; Position
: Cursor
) return Boolean is
880 if Position
.Node
= 0 then
883 return Container
.Nodes
(Position
.Node
).Has_Element
;
891 procedure Include
(Container
: in out Set
; New_Item
: Element_Type
) is
896 Insert
(Container
, New_Item
, Position
, Inserted
);
900 N
: Tree_Types
.Nodes_Type
renames Container
.Nodes
;
902 N
(Position
.Node
).Element
:= New_Item
;
912 (Container
: in out Set
;
913 New_Item
: Element_Type
;
914 Position
: out Cursor
;
915 Inserted
: out Boolean)
918 Insert_Sans_Hint
(Container
, New_Item
, Position
.Node
, Inserted
);
922 (Container
: in out Set
;
923 New_Item
: Element_Type
)
929 Insert
(Container
, New_Item
, Position
, Inserted
);
932 raise Constraint_Error
with
933 "attempt to insert element already in set";
937 ----------------------
938 -- Insert_Sans_Hint --
939 ----------------------
941 procedure Insert_Sans_Hint
942 (Container
: in out Set
;
943 New_Item
: Element_Type
;
944 Node
: out Count_Type
;
945 Inserted
: out Boolean)
947 procedure Set_Element
(Node
: in out Node_Type
);
949 function New_Node
return Count_Type
;
950 pragma Inline
(New_Node
);
952 procedure Insert_Post
is
953 new Element_Keys
.Generic_Insert_Post
(New_Node
);
955 procedure Conditional_Insert_Sans_Hint
is
956 new Element_Keys
.Generic_Conditional_Insert
(Insert_Post
);
958 procedure Allocate
is new Generic_Allocate
(Set_Element
);
964 function New_Node
return Count_Type
is
967 Allocate
(Container
, Result
);
975 procedure Set_Element
(Node
: in out Node_Type
) is
977 Node
.Element
:= New_Item
;
980 -- Start of processing for Insert_Sans_Hint
983 Conditional_Insert_Sans_Hint
988 end Insert_Sans_Hint
;
990 ----------------------
991 -- Insert_With_Hint --
992 ----------------------
994 procedure Insert_With_Hint
995 (Dst_Set
: in out Set
;
996 Dst_Hint
: Count_Type
;
997 Src_Node
: Node_Type
;
998 Dst_Node
: out Count_Type
)
1001 pragma Unreferenced
(Success
);
1003 procedure Set_Element
(Node
: in out Node_Type
);
1005 function New_Node
return Count_Type
;
1006 pragma Inline
(New_Node
);
1008 procedure Insert_Post
is
1009 new Element_Keys
.Generic_Insert_Post
(New_Node
);
1011 procedure Insert_Sans_Hint
is
1012 new Element_Keys
.Generic_Conditional_Insert
(Insert_Post
);
1014 procedure Local_Insert_With_Hint
is
1015 new Element_Keys
.Generic_Conditional_Insert_With_Hint
1016 (Insert_Post
, Insert_Sans_Hint
);
1018 procedure Allocate
is new Generic_Allocate
(Set_Element
);
1024 function New_Node
return Count_Type
is
1025 Result
: Count_Type
;
1027 Allocate
(Dst_Set
, Result
);
1035 procedure Set_Element
(Node
: in out Node_Type
) is
1037 Node
.Element
:= Src_Node
.Element
;
1040 -- Start of processing for Insert_With_Hint
1043 Local_Insert_With_Hint
1049 end Insert_With_Hint
;
1055 procedure Intersection
(Target
: in out Set
; Source
: Set
) is
1057 Set_Ops
.Set_Intersection
(Target
, Source
);
1060 function Intersection
(Left
, Right
: Set
) return Set
is
1062 if Left
'Address = Right
'Address then
1066 return S
: Set
(Count_Type
'Min (Length
(Left
), Length
(Right
))) do
1067 Assign
(S
, Set_Ops
.Set_Intersection
(Left
, Right
));
1075 function Is_Empty
(Container
: Set
) return Boolean is
1077 return Length
(Container
) = 0;
1080 -----------------------------
1081 -- Is_Greater_Element_Node --
1082 -----------------------------
1084 function Is_Greater_Element_Node
1085 (Left
: Element_Type
;
1086 Right
: Node_Type
) return Boolean
1089 -- Compute e > node same as node < e
1091 return Right
.Element
< Left
;
1092 end Is_Greater_Element_Node
;
1094 --------------------------
1095 -- Is_Less_Element_Node --
1096 --------------------------
1098 function Is_Less_Element_Node
1099 (Left
: Element_Type
;
1100 Right
: Node_Type
) return Boolean
1103 return Left
< Right
.Element
;
1104 end Is_Less_Element_Node
;
1106 -----------------------
1107 -- Is_Less_Node_Node --
1108 -----------------------
1110 function Is_Less_Node_Node
(L
, R
: Node_Type
) return Boolean is
1112 return L
.Element
< R
.Element
;
1113 end Is_Less_Node_Node
;
1119 function Is_Subset
(Subset
: Set
; Of_Set
: Set
) return Boolean is
1121 return Set_Ops
.Set_Subset
(Subset
, Of_Set
=> Of_Set
);
1128 function Last
(Container
: Set
) return Cursor
is
1130 return (if Length
(Container
) = 0
1132 else (Node
=> Container
.Last
));
1139 function Last_Element
(Container
: Set
) return Element_Type
is
1141 if Last
(Container
).Node
= 0 then
1142 raise Constraint_Error
with "set is empty";
1146 N
: Tree_Types
.Nodes_Type
renames Container
.Nodes
;
1148 return N
(Last
(Container
).Node
).Element
;
1156 function Left_Son
(Node
: Node_Type
) return Count_Type
is
1165 function Length
(Container
: Set
) return Count_Type
is
1167 return Container
.Length
;
1174 procedure Move
(Target
: in out Set
; Source
: in out Set
) is
1175 N
: Tree_Types
.Nodes_Type
renames Source
.Nodes
;
1179 if Target
'Address = Source
'Address then
1183 if Target
.Capacity
< Length
(Source
) then
1184 raise Constraint_Error
with -- ???
1185 "Source length exceeds Target capacity";
1194 Insert
(Target
, N
(X
).Element
); -- optimize???
1196 Tree_Operations
.Delete_Node_Sans_Free
(Source
, X
);
1197 Formal_Ordered_Sets
.Free
(Source
, X
);
1205 function Next
(Container
: Set
; Position
: Cursor
) return Cursor
is
1207 if Position
= No_Element
then
1211 if not Has_Element
(Container
, Position
) then
1212 raise Constraint_Error
;
1215 pragma Assert
(Vet
(Container
, Position
.Node
),
1216 "bad cursor in Next");
1217 return (Node
=> Tree_Operations
.Next
(Container
, Position
.Node
));
1220 procedure Next
(Container
: Set
; Position
: in out Cursor
) is
1222 Position
:= Next
(Container
, Position
);
1229 function Overlap
(Left
, Right
: Set
) return Boolean is
1231 return Set_Ops
.Set_Overlap
(Left
, Right
);
1238 function Parent
(Node
: Node_Type
) return Count_Type
is
1247 function Previous
(Container
: Set
; Position
: Cursor
) return Cursor
is
1249 if Position
= No_Element
then
1253 if not Has_Element
(Container
, Position
) then
1254 raise Constraint_Error
;
1257 pragma Assert
(Vet
(Container
, Position
.Node
),
1258 "bad cursor in Previous");
1261 Node
: constant Count_Type
:=
1262 Tree_Operations
.Previous
(Container
, Position
.Node
);
1264 return (if Node
= 0 then No_Element
else (Node
=> Node
));
1268 procedure Previous
(Container
: Set
; Position
: in out Cursor
) is
1270 Position
:= Previous
(Container
, Position
);
1277 procedure Replace
(Container
: in out Set
; New_Item
: Element_Type
) is
1278 Node
: constant Count_Type
:= Element_Keys
.Find
(Container
, New_Item
);
1282 raise Constraint_Error
with
1283 "attempt to replace element not in set";
1286 Container
.Nodes
(Node
).Element
:= New_Item
;
1289 ---------------------
1290 -- Replace_Element --
1291 ---------------------
1293 procedure Replace_Element
1296 Item
: Element_Type
)
1298 pragma Assert
(Node
/= 0);
1300 function New_Node
return Count_Type
;
1301 pragma Inline
(New_Node
);
1303 procedure Local_Insert_Post
is
1304 new Element_Keys
.Generic_Insert_Post
(New_Node
);
1306 procedure Local_Insert_Sans_Hint
is
1307 new Element_Keys
.Generic_Conditional_Insert
(Local_Insert_Post
);
1309 procedure Local_Insert_With_Hint
is
1310 new Element_Keys
.Generic_Conditional_Insert_With_Hint
1312 Local_Insert_Sans_Hint
);
1314 NN
: Tree_Types
.Nodes_Type
renames Tree
.Nodes
;
1320 function New_Node
return Count_Type
is
1321 N
: Node_Type
renames NN
(Node
);
1332 Result
: Count_Type
;
1335 -- Start of processing for Insert
1338 if Item
< NN
(Node
).Element
1339 or else NN
(Node
).Element
< Item
1344 NN
(Node
).Element
:= Item
;
1348 Hint
:= Element_Keys
.Ceiling
(Tree
, Item
);
1353 elsif Item
< NN
(Hint
).Element
then
1355 NN
(Node
).Element
:= Item
;
1360 pragma Assert
(not (NN
(Hint
).Element
< Item
));
1361 raise Program_Error
with "attempt to replace existing element";
1364 Tree_Operations
.Delete_Node_Sans_Free
(Tree
, Node
);
1366 Local_Insert_With_Hint
1371 Inserted
=> Inserted
);
1373 pragma Assert
(Inserted
);
1374 pragma Assert
(Result
= Node
);
1375 end Replace_Element
;
1377 procedure Replace_Element
1378 (Container
: in out Set
;
1380 New_Item
: Element_Type
)
1383 if not Has_Element
(Container
, Position
) then
1384 raise Constraint_Error
with
1385 "Position cursor has no element";
1388 pragma Assert
(Vet
(Container
, Position
.Node
),
1389 "bad cursor in Replace_Element");
1391 Replace_Element
(Container
, Position
.Node
, New_Item
);
1392 end Replace_Element
;
1398 function Right_Son
(Node
: Node_Type
) return Count_Type
is
1408 (Node
: in out Node_Type
;
1409 Color
: Red_Black_Trees
.Color_Type
)
1412 Node
.Color
:= Color
;
1419 procedure Set_Left
(Node
: in out Node_Type
; Left
: Count_Type
) is
1428 procedure Set_Parent
(Node
: in out Node_Type
; Parent
: Count_Type
) is
1430 Node
.Parent
:= Parent
;
1437 procedure Set_Right
(Node
: in out Node_Type
; Right
: Count_Type
) is
1439 Node
.Right
:= Right
;
1446 function Strict_Equal
(Left
, Right
: Set
) return Boolean is
1447 LNode
: Count_Type
:= First
(Left
).Node
;
1448 RNode
: Count_Type
:= First
(Right
).Node
;
1451 if Length
(Left
) /= Length
(Right
) then
1455 while LNode
= RNode
loop
1460 if Left
.Nodes
(LNode
).Element
/= Right
.Nodes
(RNode
).Element
then
1464 LNode
:= Next
(Left
, LNode
);
1465 RNode
:= Next
(Right
, RNode
);
1471 --------------------------
1472 -- Symmetric_Difference --
1473 --------------------------
1475 procedure Symmetric_Difference
(Target
: in out Set
; Source
: Set
) is
1477 Set_Ops
.Set_Symmetric_Difference
(Target
, Source
);
1478 end Symmetric_Difference
;
1480 function Symmetric_Difference
(Left
, Right
: Set
) return Set
is
1482 if Left
'Address = Right
'Address then
1486 if Length
(Right
) = 0 then
1490 if Length
(Left
) = 0 then
1494 return S
: Set
(Length
(Left
) + Length
(Right
)) do
1495 Assign
(S
, Set_Ops
.Set_Symmetric_Difference
(Left
, Right
));
1497 end Symmetric_Difference
;
1503 function To_Set
(New_Item
: Element_Type
) return Set
is
1507 return S
: Set
(Capacity
=> 1) do
1508 Insert_Sans_Hint
(S
, New_Item
, Node
, Inserted
);
1509 pragma Assert
(Inserted
);
1517 procedure Union
(Target
: in out Set
; Source
: Set
) is
1519 Set_Ops
.Set_Union
(Target
, Source
);
1522 function Union
(Left
, Right
: Set
) return Set
is
1524 if Left
'Address = Right
'Address then
1528 if Length
(Left
) = 0 then
1532 if Length
(Right
) = 0 then
1536 return S
: Set
(Length
(Left
) + Length
(Right
)) do
1537 S
.Assign
(Source
=> Left
);
1542 end Ada
.Containers
.Formal_Ordered_Sets
;