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-2011, 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
;
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
);
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 Length
(Source
) > 0 then
324 Target
.Length
:= Source
.Length
;
325 Target
.Root
:= Source
.Root
;
326 Target
.First
:= Source
.First
;
327 Target
.Last
:= Source
.Last
;
328 Target
.Free
:= Source
.Free
;
331 while Node
<= Source
.Capacity
loop
332 Target
.Nodes
(Node
).Element
:=
333 Source
.Nodes
(Node
).Element
;
334 Target
.Nodes
(Node
).Parent
:=
335 Source
.Nodes
(Node
).Parent
;
336 Target
.Nodes
(Node
).Left
:=
337 Source
.Nodes
(Node
).Left
;
338 Target
.Nodes
(Node
).Right
:=
339 Source
.Nodes
(Node
).Right
;
340 Target
.Nodes
(Node
).Color
:=
341 Source
.Nodes
(Node
).Color
;
342 Target
.Nodes
(Node
).Has_Element
:=
343 Source
.Nodes
(Node
).Has_Element
;
347 while Node
<= Target
.Capacity
loop
349 Formal_Ordered_Sets
.Free
(Tree
=> Target
, X
=> N
);
361 procedure Delete
(Container
: in out Set
; Position
: in out Cursor
) is
363 if not Has_Element
(Container
, Position
) then
364 raise Constraint_Error
with "Position cursor has no element";
367 pragma Assert
(Vet
(Container
, Position
.Node
),
368 "bad cursor in Delete");
370 Tree_Operations
.Delete_Node_Sans_Free
(Container
,
372 Formal_Ordered_Sets
.Free
(Container
, Position
.Node
);
373 Position
:= No_Element
;
376 procedure Delete
(Container
: in out Set
; Item
: Element_Type
) is
377 X
: constant Count_Type
:= Element_Keys
.Find
(Container
, Item
);
381 raise Constraint_Error
with "attempt to delete element not in set";
384 Tree_Operations
.Delete_Node_Sans_Free
(Container
, X
);
385 Formal_Ordered_Sets
.Free
(Container
, X
);
392 procedure Delete_First
(Container
: in out Set
) is
393 X
: constant Count_Type
:= Container
.First
;
396 Tree_Operations
.Delete_Node_Sans_Free
(Container
, X
);
397 Formal_Ordered_Sets
.Free
(Container
, X
);
405 procedure Delete_Last
(Container
: in out Set
) is
406 X
: constant Count_Type
:= Container
.Last
;
409 Tree_Operations
.Delete_Node_Sans_Free
(Container
, X
);
410 Formal_Ordered_Sets
.Free
(Container
, X
);
418 procedure Difference
(Target
: in out Set
; Source
: Set
) is
420 Set_Ops
.Set_Difference
(Target
, Source
);
423 function Difference
(Left
, Right
: Set
) return Set
is
425 if Left
'Address = Right
'Address then
429 if Length
(Left
) = 0 then
433 if Length
(Right
) = 0 then
437 return S
: Set
(Length
(Left
)) do
438 Assign
(S
, Set_Ops
.Set_Difference
(Left
, Right
));
446 function Element
(Container
: Set
; Position
: Cursor
) return Element_Type
is
448 if not Has_Element
(Container
, Position
) then
449 raise Constraint_Error
with "Position cursor has no element";
452 pragma Assert
(Vet
(Container
, Position
.Node
),
453 "bad cursor in Element");
456 N
: Tree_Types
.Nodes_Type
renames Container
.Nodes
;
458 return N
(Position
.Node
).Element
;
462 -------------------------
463 -- Equivalent_Elements --
464 -------------------------
466 function Equivalent_Elements
(Left
, Right
: Element_Type
) return Boolean is
475 end Equivalent_Elements
;
477 ---------------------
478 -- Equivalent_Sets --
479 ---------------------
481 function Equivalent_Sets
(Left
, Right
: Set
) return Boolean is
482 function Is_Equivalent_Node_Node
483 (L
, R
: Node_Type
) return Boolean;
484 pragma Inline
(Is_Equivalent_Node_Node
);
486 function Is_Equivalent
is
487 new Tree_Operations
.Generic_Equal
(Is_Equivalent_Node_Node
);
489 -----------------------------
490 -- Is_Equivalent_Node_Node --
491 -----------------------------
493 function Is_Equivalent_Node_Node
(L
, R
: Node_Type
) return Boolean is
495 if L
.Element
< R
.Element
then
497 elsif R
.Element
< L
.Element
then
502 end Is_Equivalent_Node_Node
;
504 -- Start of processing for Equivalent_Sets
507 return Is_Equivalent
(Left
, Right
);
514 procedure Exclude
(Container
: in out Set
; Item
: Element_Type
) is
515 X
: constant Count_Type
:= Element_Keys
.Find
(Container
, Item
);
518 Tree_Operations
.Delete_Node_Sans_Free
(Container
, X
);
519 Formal_Ordered_Sets
.Free
(Container
, X
);
527 function Find
(Container
: Set
; Item
: Element_Type
) return Cursor
is
528 Node
: constant Count_Type
:= Element_Keys
.Find
(Container
, Item
);
535 return (Node
=> Node
);
542 function First
(Container
: Set
) return Cursor
is
544 if Length
(Container
) = 0 then
548 return (Node
=> Container
.First
);
555 function First_Element
(Container
: Set
) return Element_Type
is
556 Fst
: constant Count_Type
:= First
(Container
).Node
;
559 raise Constraint_Error
with "set is empty";
563 N
: Tree_Types
.Nodes_Type
renames Container
.Nodes
;
565 return N
(Fst
).Element
;
573 function Floor
(Container
: Set
; Item
: Element_Type
) return Cursor
is
576 Node
: constant Count_Type
:= Element_Keys
.Floor
(Container
, Item
);
583 return (Node
=> Node
);
591 procedure Free
(Tree
: in out Set
; X
: Count_Type
) is
593 Tree
.Nodes
(X
).Has_Element
:= False;
594 Tree_Operations
.Free
(Tree
, X
);
597 ----------------------
598 -- Generic_Allocate --
599 ----------------------
601 procedure Generic_Allocate
602 (Tree
: in out Tree_Types
.Tree_Type
'Class;
603 Node
: out Count_Type
)
605 procedure Allocate
is
606 new Tree_Operations
.Generic_Allocate
(Set_Element
);
608 Allocate
(Tree
, Node
);
609 Tree
.Nodes
(Node
).Has_Element
:= True;
610 end Generic_Allocate
;
616 package body Generic_Keys
is
618 -----------------------
619 -- Local Subprograms --
620 -----------------------
622 function Is_Greater_Key_Node
624 Right
: Node_Type
) return Boolean;
625 pragma Inline
(Is_Greater_Key_Node
);
627 function Is_Less_Key_Node
629 Right
: Node_Type
) return Boolean;
630 pragma Inline
(Is_Less_Key_Node
);
632 --------------------------
633 -- Local Instantiations --
634 --------------------------
637 new Red_Black_Trees
.Generic_Bounded_Keys
638 (Tree_Operations
=> Tree_Operations
,
639 Key_Type
=> Key_Type
,
640 Is_Less_Key_Node
=> Is_Less_Key_Node
,
641 Is_Greater_Key_Node
=> Is_Greater_Key_Node
);
647 function Ceiling
(Container
: Set
; Key
: Key_Type
) return Cursor
is
648 Node
: constant Count_Type
:= Key_Keys
.Ceiling
(Container
, Key
);
655 return (Node
=> Node
);
662 function Contains
(Container
: Set
; Key
: Key_Type
) return Boolean is
664 return Find
(Container
, Key
) /= No_Element
;
671 procedure Delete
(Container
: in out Set
; Key
: Key_Type
) is
672 X
: constant Count_Type
:= Key_Keys
.Find
(Container
, Key
);
676 raise Constraint_Error
with "attempt to delete key not in set";
679 Delete_Node_Sans_Free
(Container
, X
);
680 Formal_Ordered_Sets
.Free
(Container
, X
);
687 function Element
(Container
: Set
; Key
: Key_Type
) return Element_Type
is
688 Node
: constant Count_Type
:= Key_Keys
.Find
(Container
, Key
);
692 raise Constraint_Error
with "key not in set";
696 N
: Tree_Types
.Nodes_Type
renames Container
.Nodes
;
698 return N
(Node
).Element
;
702 ---------------------
703 -- Equivalent_Keys --
704 ---------------------
706 function Equivalent_Keys
(Left
, Right
: Key_Type
) return Boolean is
721 procedure Exclude
(Container
: in out Set
; Key
: Key_Type
) is
722 X
: constant Count_Type
:= Key_Keys
.Find
(Container
, Key
);
725 Delete_Node_Sans_Free
(Container
, X
);
726 Formal_Ordered_Sets
.Free
(Container
, X
);
734 function Find
(Container
: Set
; Key
: Key_Type
) return Cursor
is
735 Node
: constant Count_Type
:= Key_Keys
.Find
(Container
, Key
);
737 return (if Node
= 0 then No_Element
else (Node
=> Node
));
744 function Floor
(Container
: Set
; Key
: Key_Type
) return Cursor
is
745 Node
: constant Count_Type
:= Key_Keys
.Floor
(Container
, Key
);
747 return (if Node
= 0 then No_Element
else (Node
=> Node
));
750 -------------------------
751 -- Is_Greater_Key_Node --
752 -------------------------
754 function Is_Greater_Key_Node
756 Right
: Node_Type
) return Boolean
759 return Key
(Right
.Element
) < Left
;
760 end Is_Greater_Key_Node
;
762 ----------------------
763 -- Is_Less_Key_Node --
764 ----------------------
766 function Is_Less_Key_Node
768 Right
: Node_Type
) return Boolean
771 return Left
< Key
(Right
.Element
);
772 end Is_Less_Key_Node
;
778 function Key
(Container
: Set
; Position
: Cursor
) return Key_Type
is
780 if not Has_Element
(Container
, Position
) then
781 raise Constraint_Error
with
782 "Position cursor has no element";
785 pragma Assert
(Vet
(Container
, Position
.Node
),
786 "bad cursor in Key");
789 N
: Tree_Types
.Nodes_Type
renames Container
.Nodes
;
791 return Key
(N
(Position
.Node
).Element
);
800 (Container
: in out Set
;
802 New_Item
: Element_Type
)
804 Node
: constant Count_Type
:= Key_Keys
.Find
(Container
, Key
);
806 if not Has_Element
(Container
, (Node
=> Node
)) then
807 raise Constraint_Error
with
808 "attempt to replace key not in set";
810 Replace_Element
(Container
, Node
, New_Item
);
814 -----------------------------------
815 -- Update_Element_Preserving_Key --
816 -----------------------------------
818 procedure Update_Element_Preserving_Key
819 (Container
: in out Set
;
821 Process
: not null access procedure (Element
: in out Element_Type
))
824 if not Has_Element
(Container
, Position
) then
825 raise Constraint_Error
with
826 "Position cursor has no element";
829 pragma Assert
(Vet
(Container
, Position
.Node
),
830 "bad cursor in Update_Element_Preserving_Key");
833 N
: Tree_Types
.Nodes_Type
renames Container
.Nodes
;
835 E
: Element_Type
renames N
(Position
.Node
).Element
;
836 K
: constant Key_Type
:= Key
(E
);
838 B
: Natural renames Container
.Busy
;
839 L
: Natural renames Container
.Lock
;
857 if Equivalent_Keys
(K
, Key
(E
)) then
863 X
: constant Count_Type
:= Position
.Node
;
865 Tree_Operations
.Delete_Node_Sans_Free
(Container
, X
);
866 Formal_Ordered_Sets
.Free
(Container
, X
);
869 raise Program_Error
with "key was modified";
870 end Update_Element_Preserving_Key
;
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
);
899 if Container
.Lock
> 0 then
900 raise Program_Error
with
901 "attempt to tamper with cursors (set is locked)";
905 N
: Tree_Types
.Nodes_Type
renames Container
.Nodes
;
907 N
(Position
.Node
).Element
:= New_Item
;
917 (Container
: in out Set
;
918 New_Item
: Element_Type
;
919 Position
: out Cursor
;
920 Inserted
: out Boolean)
923 Insert_Sans_Hint
(Container
, New_Item
, Position
.Node
, Inserted
);
927 (Container
: in out Set
;
928 New_Item
: Element_Type
)
934 Insert
(Container
, New_Item
, Position
, Inserted
);
937 raise Constraint_Error
with
938 "attempt to insert element already in set";
942 ----------------------
943 -- Insert_Sans_Hint --
944 ----------------------
946 procedure Insert_Sans_Hint
947 (Container
: in out Set
;
948 New_Item
: Element_Type
;
949 Node
: out Count_Type
;
950 Inserted
: out Boolean)
952 procedure Set_Element
(Node
: in out Node_Type
);
954 function New_Node
return Count_Type
;
955 pragma Inline
(New_Node
);
957 procedure Insert_Post
is
958 new Element_Keys
.Generic_Insert_Post
(New_Node
);
960 procedure Conditional_Insert_Sans_Hint
is
961 new Element_Keys
.Generic_Conditional_Insert
(Insert_Post
);
963 procedure Allocate
is new Generic_Allocate
(Set_Element
);
969 function New_Node
return Count_Type
is
972 Allocate
(Container
, Result
);
980 procedure Set_Element
(Node
: in out Node_Type
) is
982 Node
.Element
:= New_Item
;
985 -- Start of processing for Insert_Sans_Hint
988 Conditional_Insert_Sans_Hint
993 end Insert_Sans_Hint
;
995 ----------------------
996 -- Insert_With_Hint --
997 ----------------------
999 procedure Insert_With_Hint
1000 (Dst_Set
: in out Set
;
1001 Dst_Hint
: Count_Type
;
1002 Src_Node
: Node_Type
;
1003 Dst_Node
: out Count_Type
)
1006 pragma Unreferenced
(Success
);
1008 procedure Set_Element
(Node
: in out Node_Type
);
1010 function New_Node
return Count_Type
;
1011 pragma Inline
(New_Node
);
1013 procedure Insert_Post
is
1014 new Element_Keys
.Generic_Insert_Post
(New_Node
);
1016 procedure Insert_Sans_Hint
is
1017 new Element_Keys
.Generic_Conditional_Insert
(Insert_Post
);
1019 procedure Local_Insert_With_Hint
is
1020 new Element_Keys
.Generic_Conditional_Insert_With_Hint
1021 (Insert_Post
, Insert_Sans_Hint
);
1023 procedure Allocate
is new Generic_Allocate
(Set_Element
);
1029 function New_Node
return Count_Type
is
1030 Result
: Count_Type
;
1032 Allocate
(Dst_Set
, Result
);
1040 procedure Set_Element
(Node
: in out Node_Type
) is
1042 Node
.Element
:= Src_Node
.Element
;
1045 -- Start of processing for Insert_With_Hint
1048 Local_Insert_With_Hint
1054 end Insert_With_Hint
;
1060 procedure Intersection
(Target
: in out Set
; Source
: Set
) is
1062 Set_Ops
.Set_Intersection
(Target
, Source
);
1065 function Intersection
(Left
, Right
: Set
) return Set
is
1067 if Left
'Address = Right
'Address then
1071 return S
: Set
(Count_Type
'Min (Length
(Left
), Length
(Right
))) do
1072 Assign
(S
, Set_Ops
.Set_Intersection
(Left
, Right
));
1080 function Is_Empty
(Container
: Set
) return Boolean is
1082 return Length
(Container
) = 0;
1085 -----------------------------
1086 -- Is_Greater_Element_Node --
1087 -----------------------------
1089 function Is_Greater_Element_Node
1090 (Left
: Element_Type
;
1091 Right
: Node_Type
) return Boolean
1094 -- Compute e > node same as node < e
1096 return Right
.Element
< Left
;
1097 end Is_Greater_Element_Node
;
1099 --------------------------
1100 -- Is_Less_Element_Node --
1101 --------------------------
1103 function Is_Less_Element_Node
1104 (Left
: Element_Type
;
1105 Right
: Node_Type
) return Boolean
1108 return Left
< Right
.Element
;
1109 end Is_Less_Element_Node
;
1111 -----------------------
1112 -- Is_Less_Node_Node --
1113 -----------------------
1115 function Is_Less_Node_Node
(L
, R
: Node_Type
) return Boolean is
1117 return L
.Element
< R
.Element
;
1118 end Is_Less_Node_Node
;
1124 function Is_Subset
(Subset
: Set
; Of_Set
: Set
) return Boolean is
1126 return Set_Ops
.Set_Subset
(Subset
, Of_Set
=> Of_Set
);
1135 Process
: not null access procedure (Container
: Set
;
1138 procedure Process_Node
(Node
: Count_Type
);
1139 pragma Inline
(Process_Node
);
1141 procedure Local_Iterate
is
1142 new Tree_Operations
.Generic_Iteration
(Process_Node
);
1148 procedure Process_Node
(Node
: Count_Type
) is
1150 Process
(Container
, (Node
=> Node
));
1155 B
: Natural renames Container
'Unrestricted_Access.Busy
;
1157 -- Start of prccessing for Iterate
1163 Local_Iterate
(Container
);
1177 function Last
(Container
: Set
) return Cursor
is
1179 return (if Length
(Container
) = 0
1181 else (Node
=> Container
.Last
));
1188 function Last_Element
(Container
: Set
) return Element_Type
is
1190 if Last
(Container
).Node
= 0 then
1191 raise Constraint_Error
with "set is empty";
1195 N
: Tree_Types
.Nodes_Type
renames Container
.Nodes
;
1197 return N
(Last
(Container
).Node
).Element
;
1205 function Left
(Container
: Set
; Position
: Cursor
) return Set
is
1206 Curs
: Cursor
:= Position
;
1207 C
: Set
(Container
.Capacity
) := Copy
(Container
, Container
.Capacity
);
1211 if Curs
= No_Element
then
1215 if not Has_Element
(Container
, Curs
) then
1216 raise Constraint_Error
;
1219 while Curs
.Node
/= 0 loop
1222 Curs
:= Next
(Container
, (Node
=> Node
));
1232 function Left_Son
(Node
: Node_Type
) return Count_Type
is
1241 function Length
(Container
: Set
) return Count_Type
is
1243 return Container
.Length
;
1250 procedure Move
(Target
: in out Set
; Source
: in out Set
) is
1251 N
: Tree_Types
.Nodes_Type
renames Source
.Nodes
;
1255 if Target
'Address = Source
'Address then
1259 if Target
.Capacity
< Length
(Source
) then
1260 raise Constraint_Error
with -- ???
1261 "Source length exceeds Target capacity";
1264 if Source
.Busy
> 0 then
1265 raise Program_Error
with
1266 "attempt to tamper with cursors of Source (list is busy)";
1275 Insert
(Target
, N
(X
).Element
); -- optimize???
1277 Tree_Operations
.Delete_Node_Sans_Free
(Source
, X
);
1278 Formal_Ordered_Sets
.Free
(Source
, X
);
1286 function Next
(Container
: Set
; Position
: Cursor
) return Cursor
is
1288 if Position
= No_Element
then
1292 if not Has_Element
(Container
, Position
) then
1293 raise Constraint_Error
;
1296 pragma Assert
(Vet
(Container
, Position
.Node
),
1297 "bad cursor in Next");
1298 return (Node
=> Tree_Operations
.Next
(Container
, Position
.Node
));
1301 procedure Next
(Container
: Set
; Position
: in out Cursor
) is
1303 Position
:= Next
(Container
, Position
);
1310 function Overlap
(Left
, Right
: Set
) return Boolean is
1312 return Set_Ops
.Set_Overlap
(Left
, Right
);
1319 function Parent
(Node
: Node_Type
) return Count_Type
is
1328 function Previous
(Container
: Set
; Position
: Cursor
) return Cursor
is
1330 if Position
= No_Element
then
1334 if not Has_Element
(Container
, Position
) then
1335 raise Constraint_Error
;
1338 pragma Assert
(Vet
(Container
, Position
.Node
),
1339 "bad cursor in Previous");
1342 Node
: constant Count_Type
:=
1343 Tree_Operations
.Previous
(Container
, Position
.Node
);
1345 return (if Node
= 0 then No_Element
else (Node
=> Node
));
1349 procedure Previous
(Container
: Set
; Position
: in out Cursor
) is
1351 Position
:= Previous
(Container
, Position
);
1358 procedure Query_Element
1359 (Container
: in out Set
;
1361 Process
: not null access procedure (Element
: Element_Type
))
1364 if not Has_Element
(Container
, Position
) then
1365 raise Constraint_Error
with "Position cursor has no element";
1368 pragma Assert
(Vet
(Container
, Position
.Node
),
1369 "bad cursor in Query_Element");
1372 B
: Natural renames Container
.Busy
;
1373 L
: Natural renames Container
.Lock
;
1380 Process
(Container
.Nodes
(Position
.Node
).Element
);
1398 (Stream
: not null access Root_Stream_Type
'Class;
1399 Container
: out Set
)
1401 procedure Read_Element
(Node
: in out Node_Type
);
1402 pragma Inline
(Read_Element
);
1404 procedure Allocate
is
1405 new Generic_Allocate
(Read_Element
);
1407 procedure Read_Elements
is
1408 new Tree_Operations
.Generic_Read
(Allocate
);
1414 procedure Read_Element
(Node
: in out Node_Type
) is
1416 Element_Type
'Read (Stream
, Node
.Element
);
1419 -- Start of processing for Read
1422 Read_Elements
(Stream
, Container
);
1426 (Stream
: not null access Root_Stream_Type
'Class;
1430 raise Program_Error
with "attempt to stream set cursor";
1437 procedure Replace
(Container
: in out Set
; New_Item
: Element_Type
) is
1438 Node
: constant Count_Type
:= Element_Keys
.Find
(Container
, New_Item
);
1442 raise Constraint_Error
with
1443 "attempt to replace element not in set";
1446 if Container
.Lock
> 0 then
1447 raise Program_Error
with
1448 "attempt to tamper with cursors (set is locked)";
1451 Container
.Nodes
(Node
).Element
:= New_Item
;
1454 ---------------------
1455 -- Replace_Element --
1456 ---------------------
1458 procedure Replace_Element
1461 Item
: Element_Type
)
1463 pragma Assert
(Node
/= 0);
1465 function New_Node
return Count_Type
;
1466 pragma Inline
(New_Node
);
1468 procedure Local_Insert_Post
is
1469 new Element_Keys
.Generic_Insert_Post
(New_Node
);
1471 procedure Local_Insert_Sans_Hint
is
1472 new Element_Keys
.Generic_Conditional_Insert
(Local_Insert_Post
);
1474 procedure Local_Insert_With_Hint
is
1475 new Element_Keys
.Generic_Conditional_Insert_With_Hint
1477 Local_Insert_Sans_Hint
);
1479 NN
: Tree_Types
.Nodes_Type
renames Tree
.Nodes
;
1485 function New_Node
return Count_Type
is
1486 N
: Node_Type
renames NN
(Node
);
1497 Result
: Count_Type
;
1500 -- Start of processing for Insert
1503 if Item
< NN
(Node
).Element
1504 or else NN
(Node
).Element
< Item
1509 if Tree
.Lock
> 0 then
1510 raise Program_Error
with
1511 "attempt to tamper with cursors (set is locked)";
1514 NN
(Node
).Element
:= Item
;
1518 Hint
:= Element_Keys
.Ceiling
(Tree
, Item
);
1523 elsif Item
< NN
(Hint
).Element
then
1525 if Tree
.Lock
> 0 then
1526 raise Program_Error
with
1527 "attempt to tamper with cursors (set is locked)";
1530 NN
(Node
).Element
:= Item
;
1535 pragma Assert
(not (NN
(Hint
).Element
< Item
));
1536 raise Program_Error
with "attempt to replace existing element";
1539 Tree_Operations
.Delete_Node_Sans_Free
(Tree
, Node
); -- Checks busy-bit
1541 Local_Insert_With_Hint
1546 Inserted
=> Inserted
);
1548 pragma Assert
(Inserted
);
1549 pragma Assert
(Result
= Node
);
1550 end Replace_Element
;
1552 procedure Replace_Element
1553 (Container
: in out Set
;
1555 New_Item
: Element_Type
)
1558 if not Has_Element
(Container
, Position
) then
1559 raise Constraint_Error
with
1560 "Position cursor has no element";
1563 pragma Assert
(Vet
(Container
, Position
.Node
),
1564 "bad cursor in Replace_Element");
1566 Replace_Element
(Container
, Position
.Node
, New_Item
);
1567 end Replace_Element
;
1569 ---------------------
1570 -- Reverse_Iterate --
1571 ---------------------
1573 procedure Reverse_Iterate
1575 Process
: not null access procedure (Container
: Set
;
1578 procedure Process_Node
(Node
: Count_Type
);
1579 pragma Inline
(Process_Node
);
1581 procedure Local_Reverse_Iterate
is
1582 new Tree_Operations
.Generic_Reverse_Iteration
(Process_Node
);
1588 procedure Process_Node
(Node
: Count_Type
) is
1590 Process
(Container
, (Node
=> Node
));
1593 B
: Natural renames Container
'Unrestricted_Access.Busy
;
1595 -- Start of processing for Reverse_Iterate
1601 Local_Reverse_Iterate
(Container
);
1609 end Reverse_Iterate
;
1615 function Right
(Container
: Set
; Position
: Cursor
) return Set
is
1616 Curs
: Cursor
:= First
(Container
);
1617 C
: Set
(Container
.Capacity
) := Copy
(Container
, Container
.Capacity
);
1621 if Curs
= No_Element
then
1626 if Position
/= No_Element
and not Has_Element
(Container
, Position
) then
1627 raise Constraint_Error
;
1630 while Curs
.Node
/= Position
.Node
loop
1633 Curs
:= Next
(Container
, (Node
=> Node
));
1643 function Right_Son
(Node
: Node_Type
) return Count_Type
is
1653 (Node
: in out Node_Type
;
1654 Color
: Red_Black_Trees
.Color_Type
)
1657 Node
.Color
:= Color
;
1664 procedure Set_Left
(Node
: in out Node_Type
; Left
: Count_Type
) is
1673 procedure Set_Parent
(Node
: in out Node_Type
; Parent
: Count_Type
) is
1675 Node
.Parent
:= Parent
;
1682 procedure Set_Right
(Node
: in out Node_Type
; Right
: Count_Type
) is
1684 Node
.Right
:= Right
;
1691 function Strict_Equal
(Left
, Right
: Set
) return Boolean is
1692 LNode
: Count_Type
:= First
(Left
).Node
;
1693 RNode
: Count_Type
:= First
(Right
).Node
;
1696 if Length
(Left
) /= Length
(Right
) then
1700 while LNode
= RNode
loop
1705 if Left
.Nodes
(LNode
).Element
/=
1706 Right
.Nodes
(RNode
).Element
then
1710 LNode
:= Next
(Left
, LNode
);
1711 RNode
:= Next
(Right
, RNode
);
1717 --------------------------
1718 -- Symmetric_Difference --
1719 --------------------------
1721 procedure Symmetric_Difference
(Target
: in out Set
; Source
: Set
) is
1723 Set_Ops
.Set_Symmetric_Difference
(Target
, Source
);
1724 end Symmetric_Difference
;
1726 function Symmetric_Difference
(Left
, Right
: Set
) return Set
is
1728 if Left
'Address = Right
'Address then
1732 if Length
(Right
) = 0 then
1736 if Length
(Left
) = 0 then
1740 return S
: Set
(Length
(Left
) + Length
(Right
)) do
1741 Assign
(S
, Set_Ops
.Set_Symmetric_Difference
(Left
, Right
));
1743 end Symmetric_Difference
;
1749 function To_Set
(New_Item
: Element_Type
) return Set
is
1753 return S
: Set
(Capacity
=> 1) do
1754 Insert_Sans_Hint
(S
, New_Item
, Node
, Inserted
);
1755 pragma Assert
(Inserted
);
1763 procedure Union
(Target
: in out Set
; Source
: Set
) is
1765 Set_Ops
.Set_Union
(Target
, Source
);
1768 function Union
(Left
, Right
: Set
) return Set
is
1770 if Left
'Address = Right
'Address then
1774 if Length
(Left
) = 0 then
1778 if Length
(Right
) = 0 then
1782 return S
: Set
(Length
(Left
) + Length
(Right
)) do
1783 S
.Assign
(Source
=> Left
);
1793 (Stream
: not null access Root_Stream_Type
'Class;
1796 procedure Write_Element
1797 (Stream
: not null access Root_Stream_Type
'Class;
1799 pragma Inline
(Write_Element
);
1801 procedure Write_Elements
is
1802 new Tree_Operations
.Generic_Write
(Write_Element
);
1808 procedure Write_Element
1809 (Stream
: not null access Root_Stream_Type
'Class;
1813 Element_Type
'Write (Stream
, Node
.Element
);
1816 -- Start of processing for Write
1819 Write_Elements
(Stream
, Container
);
1823 (Stream
: not null access Root_Stream_Type
'Class;
1827 raise Program_Error
with "attempt to stream set cursor";
1830 end Ada
.Containers
.Formal_Ordered_Sets
;