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-2017, 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
with
45 ------------------------------
46 -- Access to Fields of Node --
47 ------------------------------
49 -- These subprograms provide functional notation for access to fields
50 -- of a node, and procedural notation for modifiying these fields.
52 function Color
(Node
: Node_Type
) return Red_Black_Trees
.Color_Type
;
53 pragma Inline
(Color
);
55 function Left_Son
(Node
: Node_Type
) return Count_Type
;
56 pragma Inline
(Left_Son
);
58 function Parent
(Node
: Node_Type
) return Count_Type
;
59 pragma Inline
(Parent
);
61 function Right_Son
(Node
: Node_Type
) return Count_Type
;
62 pragma Inline
(Right_Son
);
65 (Node
: in out Node_Type
;
66 Color
: Red_Black_Trees
.Color_Type
);
67 pragma Inline
(Set_Color
);
69 procedure Set_Left
(Node
: in out Node_Type
; Left
: Count_Type
);
70 pragma Inline
(Set_Left
);
72 procedure Set_Right
(Node
: in out Node_Type
; Right
: Count_Type
);
73 pragma Inline
(Set_Right
);
75 procedure Set_Parent
(Node
: in out Node_Type
; Parent
: Count_Type
);
76 pragma Inline
(Set_Parent
);
78 -----------------------
79 -- Local Subprograms --
80 -----------------------
85 with procedure Set_Element
(Node
: in out Node_Type
);
86 procedure Generic_Allocate
87 (Tree
: in out Tree_Types
.Tree_Type
'Class;
88 Node
: out Count_Type
);
90 procedure Free
(Tree
: in out Set
; X
: Count_Type
);
92 procedure Insert_Sans_Hint
93 (Container
: in out Set
;
94 New_Item
: Element_Type
;
95 Node
: out Count_Type
;
96 Inserted
: out Boolean);
98 procedure Insert_With_Hint
99 (Dst_Set
: in out Set
;
100 Dst_Hint
: Count_Type
;
101 Src_Node
: Node_Type
;
102 Dst_Node
: out Count_Type
);
104 function Is_Greater_Element_Node
105 (Left
: Element_Type
;
106 Right
: Node_Type
) return Boolean;
107 pragma Inline
(Is_Greater_Element_Node
);
109 function Is_Less_Element_Node
110 (Left
: Element_Type
;
111 Right
: Node_Type
) return Boolean;
112 pragma Inline
(Is_Less_Element_Node
);
114 function Is_Less_Node_Node
(L
, R
: Node_Type
) return Boolean;
115 pragma Inline
(Is_Less_Node_Node
);
117 procedure Replace_Element
120 Item
: Element_Type
);
122 --------------------------
123 -- Local Instantiations --
124 --------------------------
126 package Tree_Operations
is
127 new Red_Black_Trees
.Generic_Bounded_Operations
134 package Element_Keys
is
135 new Red_Black_Trees
.Generic_Bounded_Keys
136 (Tree_Operations
=> Tree_Operations
,
137 Key_Type
=> Element_Type
,
138 Is_Less_Key_Node
=> Is_Less_Element_Node
,
139 Is_Greater_Key_Node
=> Is_Greater_Element_Node
);
142 new Red_Black_Trees
.Generic_Bounded_Set_Operations
143 (Tree_Operations
=> Tree_Operations
,
146 Insert_With_Hint
=> Insert_With_Hint
,
147 Is_Less
=> Is_Less_Node_Node
);
153 function "=" (Left
, Right
: Set
) return Boolean is
159 if Length
(Left
) /= Length
(Right
) then
163 if Is_Empty
(Left
) then
167 Lst
:= Next
(Left
, Last
(Left
).Node
);
169 Node
:= First
(Left
).Node
;
170 while Node
/= Lst
loop
171 ENode
:= Find
(Right
, Left
.Nodes
(Node
).Element
).Node
;
173 or else Left
.Nodes
(Node
).Element
/= Right
.Nodes
(ENode
).Element
178 Node
:= Next
(Left
, Node
);
188 procedure Assign
(Target
: in out Set
; Source
: Set
) is
189 procedure Append_Element
(Source_Node
: Count_Type
);
191 procedure Append_Elements
is
192 new Tree_Operations
.Generic_Iteration
(Append_Element
);
198 procedure Append_Element
(Source_Node
: Count_Type
) is
199 SN
: Node_Type
renames Source
.Nodes
(Source_Node
);
201 procedure Set_Element
(Node
: in out Node_Type
);
202 pragma Inline
(Set_Element
);
204 function New_Node
return Count_Type
;
205 pragma Inline
(New_Node
);
207 procedure Insert_Post
is
208 new Element_Keys
.Generic_Insert_Post
(New_Node
);
210 procedure Unconditional_Insert_Sans_Hint
is
211 new Element_Keys
.Generic_Unconditional_Insert
(Insert_Post
);
213 procedure Unconditional_Insert_Avec_Hint
is
214 new Element_Keys
.Generic_Unconditional_Insert_With_Hint
216 Unconditional_Insert_Sans_Hint
);
218 procedure Allocate
is new Generic_Allocate
(Set_Element
);
224 function New_Node
return Count_Type
is
227 Allocate
(Target
, Result
);
235 procedure Set_Element
(Node
: in out Node_Type
) is
237 Node
.Element
:= SN
.Element
;
242 Target_Node
: Count_Type
;
244 -- Start of processing for Append_Element
247 Unconditional_Insert_Avec_Hint
251 Node
=> Target_Node
);
254 -- Start of processing for Assign
257 if Target
'Address = Source
'Address then
261 if Target
.Capacity
< Source
.Length
then
262 raise Constraint_Error
263 with "Target capacity is less than Source length";
266 Tree_Operations
.Clear_Tree
(Target
);
267 Append_Elements
(Source
);
274 function Ceiling
(Container
: Set
; Item
: Element_Type
) return Cursor
is
275 Node
: constant Count_Type
:= Element_Keys
.Ceiling
(Container
, Item
);
282 return (Node
=> Node
);
289 procedure Clear
(Container
: in out Set
) is
291 Tree_Operations
.Clear_Tree
(Container
);
298 function Color
(Node
: Node_Type
) return Red_Black_Trees
.Color_Type
is
309 Item
: Element_Type
) return Boolean
312 return Find
(Container
, Item
) /= No_Element
;
319 function Copy
(Source
: Set
; Capacity
: Count_Type
:= 0) return Set
is
322 Target
: Set
(Count_Type
'Max (Source
.Capacity
, Capacity
));
325 if 0 < Capacity
and then Capacity
< Source
.Capacity
then
326 raise Capacity_Error
;
329 if Length
(Source
) > 0 then
330 Target
.Length
:= Source
.Length
;
331 Target
.Root
:= Source
.Root
;
332 Target
.First
:= Source
.First
;
333 Target
.Last
:= Source
.Last
;
334 Target
.Free
:= Source
.Free
;
337 while Node
<= Source
.Capacity
loop
338 Target
.Nodes
(Node
).Element
:=
339 Source
.Nodes
(Node
).Element
;
340 Target
.Nodes
(Node
).Parent
:=
341 Source
.Nodes
(Node
).Parent
;
342 Target
.Nodes
(Node
).Left
:=
343 Source
.Nodes
(Node
).Left
;
344 Target
.Nodes
(Node
).Right
:=
345 Source
.Nodes
(Node
).Right
;
346 Target
.Nodes
(Node
).Color
:=
347 Source
.Nodes
(Node
).Color
;
348 Target
.Nodes
(Node
).Has_Element
:=
349 Source
.Nodes
(Node
).Has_Element
;
353 while Node
<= Target
.Capacity
loop
355 Formal_Ordered_Sets
.Free
(Tree
=> Target
, X
=> N
);
367 procedure Delete
(Container
: in out Set
; Position
: in out Cursor
) is
369 if not Has_Element
(Container
, Position
) then
370 raise Constraint_Error
with "Position cursor has no element";
373 pragma Assert
(Vet
(Container
, Position
.Node
),
374 "bad cursor in Delete");
376 Tree_Operations
.Delete_Node_Sans_Free
(Container
,
378 Formal_Ordered_Sets
.Free
(Container
, Position
.Node
);
379 Position
:= No_Element
;
382 procedure Delete
(Container
: in out Set
; Item
: Element_Type
) is
383 X
: constant Count_Type
:= Element_Keys
.Find
(Container
, Item
);
387 raise Constraint_Error
with "attempt to delete element not in set";
390 Tree_Operations
.Delete_Node_Sans_Free
(Container
, X
);
391 Formal_Ordered_Sets
.Free
(Container
, X
);
398 procedure Delete_First
(Container
: in out Set
) is
399 X
: constant Count_Type
:= Container
.First
;
402 Tree_Operations
.Delete_Node_Sans_Free
(Container
, X
);
403 Formal_Ordered_Sets
.Free
(Container
, X
);
411 procedure Delete_Last
(Container
: in out Set
) is
412 X
: constant Count_Type
:= Container
.Last
;
415 Tree_Operations
.Delete_Node_Sans_Free
(Container
, X
);
416 Formal_Ordered_Sets
.Free
(Container
, X
);
424 procedure Difference
(Target
: in out Set
; Source
: Set
) is
426 Set_Ops
.Set_Difference
(Target
, Source
);
429 function Difference
(Left
, Right
: Set
) return Set
is
431 if Left
'Address = Right
'Address then
435 if Length
(Left
) = 0 then
439 if Length
(Right
) = 0 then
443 return S
: Set
(Length
(Left
)) do
444 Assign
(S
, Set_Ops
.Set_Difference
(Left
, Right
));
452 function Element
(Container
: Set
; Position
: Cursor
) return Element_Type
is
454 if not Has_Element
(Container
, Position
) then
455 raise Constraint_Error
with "Position cursor has no element";
458 pragma Assert
(Vet
(Container
, Position
.Node
),
459 "bad cursor in Element");
461 return Container
.Nodes
(Position
.Node
).Element
;
464 -------------------------
465 -- Equivalent_Elements --
466 -------------------------
468 function Equivalent_Elements
(Left
, Right
: Element_Type
) return Boolean is
477 end Equivalent_Elements
;
479 ---------------------
480 -- Equivalent_Sets --
481 ---------------------
483 function Equivalent_Sets
(Left
, Right
: Set
) return Boolean is
484 function Is_Equivalent_Node_Node
485 (L
, R
: Node_Type
) return Boolean;
486 pragma Inline
(Is_Equivalent_Node_Node
);
488 function Is_Equivalent
is
489 new Tree_Operations
.Generic_Equal
(Is_Equivalent_Node_Node
);
491 -----------------------------
492 -- Is_Equivalent_Node_Node --
493 -----------------------------
495 function Is_Equivalent_Node_Node
(L
, R
: Node_Type
) return Boolean is
497 if L
.Element
< R
.Element
then
499 elsif R
.Element
< L
.Element
then
504 end Is_Equivalent_Node_Node
;
506 -- Start of processing for Equivalent_Sets
509 return Is_Equivalent
(Left
, Right
);
516 procedure Exclude
(Container
: in out Set
; Item
: Element_Type
) is
517 X
: constant Count_Type
:= Element_Keys
.Find
(Container
, Item
);
520 Tree_Operations
.Delete_Node_Sans_Free
(Container
, X
);
521 Formal_Ordered_Sets
.Free
(Container
, X
);
529 function Find
(Container
: Set
; Item
: Element_Type
) return Cursor
is
530 Node
: constant Count_Type
:= Element_Keys
.Find
(Container
, Item
);
537 return (Node
=> Node
);
544 function First
(Container
: Set
) return Cursor
is
546 if Length
(Container
) = 0 then
550 return (Node
=> Container
.First
);
557 function First_Element
(Container
: Set
) return Element_Type
is
558 Fst
: constant Count_Type
:= First
(Container
).Node
;
561 raise Constraint_Error
with "set is empty";
565 N
: Tree_Types
.Nodes_Type
renames Container
.Nodes
;
567 return N
(Fst
).Element
;
575 function Floor
(Container
: Set
; Item
: Element_Type
) return Cursor
is
578 Node
: constant Count_Type
:= Element_Keys
.Floor
(Container
, Item
);
585 return (Node
=> Node
);
593 package body Formal_Model
is
595 -------------------------
596 -- E_Bigger_Than_Range --
597 -------------------------
599 function E_Bigger_Than_Range
600 (Container
: E
.Sequence
;
601 Fst
: Positive_Count_Type
;
603 Item
: Element_Type
) return Boolean
606 for I
in Fst
.. Lst
loop
607 if not (E
.Get
(Container
, I
) < Item
) then
613 end E_Bigger_Than_Range
;
615 -------------------------
616 -- E_Elements_Included --
617 -------------------------
619 function E_Elements_Included
621 Right
: E
.Sequence
) return Boolean
624 for I
in 1 .. E
.Length
(Left
) loop
625 if not E
.Contains
(Right
, 1, E
.Length
(Right
), E
.Get
(Left
, I
))
632 end E_Elements_Included
;
634 function E_Elements_Included
637 Right
: E
.Sequence
) return Boolean
640 for I
in 1 .. E
.Length
(Left
) loop
642 Item
: constant Element_Type
:= E
.Get
(Left
, I
);
644 if M
.Contains
(Model
, Item
) then
645 if not E
.Contains
(Right
, 1, E
.Length
(Right
), Item
) then
653 end E_Elements_Included
;
655 function E_Elements_Included
656 (Container
: E
.Sequence
;
659 Right
: E
.Sequence
) return Boolean
662 for I
in 1 .. E
.Length
(Container
) loop
664 Item
: constant Element_Type
:= E
.Get
(Container
, I
);
666 if M
.Contains
(Model
, Item
) then
667 if not E
.Contains
(Left
, 1, E
.Length
(Left
), Item
) then
671 if not E
.Contains
(Right
, 1, E
.Length
(Right
), Item
) then
679 end E_Elements_Included
;
686 (Container
: E
.Sequence
;
688 Position
: Count_Type
) return Boolean
691 for I
in 1 .. Position
- 1 loop
692 if Item
< E
.Get
(Container
, I
) then
697 if Position
< E
.Length
(Container
) then
698 for I
in Position
+ 1 .. E
.Length
(Container
) loop
699 if E
.Get
(Container
, I
) < Item
then
708 --------------------------
709 -- E_Smaller_Than_Range --
710 --------------------------
712 function E_Smaller_Than_Range
713 (Container
: E
.Sequence
;
714 Fst
: Positive_Count_Type
;
716 Item
: Element_Type
) return Boolean
719 for I
in Fst
.. Lst
loop
720 if not (Item
< E
.Get
(Container
, I
)) then
726 end E_Smaller_Than_Range
;
733 (Container
: E
.Sequence
;
734 Item
: Element_Type
) return Count_Type
737 for I
in 1 .. E
.Length
(Container
) loop
738 if Equivalent_Elements
(Item
, E
.Get
(Container
, I
)) then
750 function Elements
(Container
: Set
) return E
.Sequence
is
751 Position
: Count_Type
:= Container
.First
;
755 -- Can't use First, Next or Element here, since they depend on models
756 -- for their postconditions.
758 while Position
/= 0 loop
759 R
:= E
.Add
(R
, Container
.Nodes
(Position
).Element
);
760 Position
:= Tree_Operations
.Next
(Container
, Position
);
766 ----------------------------
767 -- Lift_Abstraction_Level --
768 ----------------------------
770 procedure Lift_Abstraction_Level
(Container
: Set
) is null;
772 -----------------------
773 -- Mapping_Preserved --
774 -----------------------
776 function Mapping_Preserved
777 (E_Left
: E
.Sequence
;
778 E_Right
: E
.Sequence
;
780 P_Right
: P
.Map
) return Boolean
784 if not P
.Has_Key
(P_Right
, C
)
785 or else P
.Get
(P_Left
, C
) > E
.Length
(E_Left
)
786 or else P
.Get
(P_Right
, C
) > E
.Length
(E_Right
)
787 or else E
.Get
(E_Left
, P
.Get
(P_Left
, C
)) /=
788 E
.Get
(E_Right
, P
.Get
(P_Right
, C
))
795 end Mapping_Preserved
;
797 ------------------------------
798 -- Mapping_Preserved_Except --
799 ------------------------------
801 function Mapping_Preserved_Except
802 (E_Left
: E
.Sequence
;
803 E_Right
: E
.Sequence
;
806 Position
: Cursor
) return Boolean
811 and (not P
.Has_Key
(P_Right
, C
)
812 or else P
.Get
(P_Left
, C
) > E
.Length
(E_Left
)
813 or else P
.Get
(P_Right
, C
) > E
.Length
(E_Right
)
814 or else E
.Get
(E_Left
, P
.Get
(P_Left
, C
)) /=
815 E
.Get
(E_Right
, P
.Get
(P_Right
, C
)))
822 end Mapping_Preserved_Except
;
824 -------------------------
825 -- P_Positions_Shifted --
826 -------------------------
828 function P_Positions_Shifted
831 Cut
: Positive_Count_Type
;
832 Count
: Count_Type
:= 1) return Boolean
836 if not P
.Has_Key
(Big
, Cu
) then
843 Pos
: constant Positive_Count_Type
:= P
.Get
(Big
, Cu
);
847 if not P
.Has_Key
(Small
, Cu
)
848 or else Pos
/= P
.Get
(Small
, Cu
)
853 elsif Pos
>= Cut
+ Count
then
854 if not P
.Has_Key
(Small
, Cu
)
855 or else Pos
/= P
.Get
(Small
, Cu
) + Count
861 if P
.Has_Key
(Small
, Cu
) then
869 end P_Positions_Shifted
;
875 function Model
(Container
: Set
) return M
.Set
is
876 Position
: Count_Type
:= Container
.First
;
880 -- Can't use First, Next or Element here, since they depend on models
881 -- for their postconditions.
883 while Position
/= 0 loop
887 Item
=> Container
.Nodes
(Position
).Element
);
889 Position
:= Tree_Operations
.Next
(Container
, Position
);
899 function Positions
(Container
: Set
) return P
.Map
is
901 Position
: Count_Type
:= Container
.First
;
905 -- Can't use First, Next or Element here, since they depend on models
906 -- for their postconditions.
908 while Position
/= 0 loop
909 R
:= P
.Add
(R
, (Node
=> Position
), I
);
910 pragma Assert
(P
.Length
(R
) = I
);
911 Position
:= Tree_Operations
.Next
(Container
, Position
);
924 procedure Free
(Tree
: in out Set
; X
: Count_Type
) is
926 Tree
.Nodes
(X
).Has_Element
:= False;
927 Tree_Operations
.Free
(Tree
, X
);
930 ----------------------
931 -- Generic_Allocate --
932 ----------------------
934 procedure Generic_Allocate
935 (Tree
: in out Tree_Types
.Tree_Type
'Class;
936 Node
: out Count_Type
)
938 procedure Allocate
is
939 new Tree_Operations
.Generic_Allocate
(Set_Element
);
941 Allocate
(Tree
, Node
);
942 Tree
.Nodes
(Node
).Has_Element
:= True;
943 end Generic_Allocate
;
949 package body Generic_Keys
with SPARK_Mode
=> Off
is
951 -----------------------
952 -- Local Subprograms --
953 -----------------------
955 function Is_Greater_Key_Node
957 Right
: Node_Type
) return Boolean;
958 pragma Inline
(Is_Greater_Key_Node
);
960 function Is_Less_Key_Node
962 Right
: Node_Type
) return Boolean;
963 pragma Inline
(Is_Less_Key_Node
);
965 --------------------------
966 -- Local Instantiations --
967 --------------------------
970 new Red_Black_Trees
.Generic_Bounded_Keys
971 (Tree_Operations
=> Tree_Operations
,
972 Key_Type
=> Key_Type
,
973 Is_Less_Key_Node
=> Is_Less_Key_Node
,
974 Is_Greater_Key_Node
=> Is_Greater_Key_Node
);
980 function Ceiling
(Container
: Set
; Key
: Key_Type
) return Cursor
is
981 Node
: constant Count_Type
:= Key_Keys
.Ceiling
(Container
, Key
);
988 return (Node
=> Node
);
995 function Contains
(Container
: Set
; Key
: Key_Type
) return Boolean is
997 return Find
(Container
, Key
) /= No_Element
;
1004 procedure Delete
(Container
: in out Set
; Key
: Key_Type
) is
1005 X
: constant Count_Type
:= Key_Keys
.Find
(Container
, Key
);
1009 raise Constraint_Error
with "attempt to delete key not in set";
1012 Delete_Node_Sans_Free
(Container
, X
);
1013 Formal_Ordered_Sets
.Free
(Container
, X
);
1020 function Element
(Container
: Set
; Key
: Key_Type
) return Element_Type
is
1021 Node
: constant Count_Type
:= Key_Keys
.Find
(Container
, Key
);
1025 raise Constraint_Error
with "key not in set";
1029 N
: Tree_Types
.Nodes_Type
renames Container
.Nodes
;
1031 return N
(Node
).Element
;
1035 ---------------------
1036 -- Equivalent_Keys --
1037 ---------------------
1039 function Equivalent_Keys
(Left
, Right
: Key_Type
) return Boolean is
1042 or else Right
< Left
1048 end Equivalent_Keys
;
1054 procedure Exclude
(Container
: in out Set
; Key
: Key_Type
) is
1055 X
: constant Count_Type
:= Key_Keys
.Find
(Container
, Key
);
1058 Delete_Node_Sans_Free
(Container
, X
);
1059 Formal_Ordered_Sets
.Free
(Container
, X
);
1067 function Find
(Container
: Set
; Key
: Key_Type
) return Cursor
is
1068 Node
: constant Count_Type
:= Key_Keys
.Find
(Container
, Key
);
1070 return (if Node
= 0 then No_Element
else (Node
=> Node
));
1077 function Floor
(Container
: Set
; Key
: Key_Type
) return Cursor
is
1078 Node
: constant Count_Type
:= Key_Keys
.Floor
(Container
, Key
);
1080 return (if Node
= 0 then No_Element
else (Node
=> Node
));
1087 package body Formal_Model
is
1089 -------------------------
1090 -- E_Bigger_Than_Range --
1091 -------------------------
1093 function E_Bigger_Than_Range
1094 (Container
: E
.Sequence
;
1095 Fst
: Positive_Count_Type
;
1097 Key
: Key_Type
) return Boolean
1100 for I
in Fst
.. Lst
loop
1101 if not (Generic_Keys
.Key
(E
.Get
(Container
, I
)) < Key
) then
1106 end E_Bigger_Than_Range
;
1113 (Container
: E
.Sequence
;
1115 Position
: Count_Type
) return Boolean
1118 for I
in 1 .. Position
- 1 loop
1119 if Key
< Generic_Keys
.Key
(E
.Get
(Container
, I
)) then
1124 if Position
< E
.Length
(Container
) then
1125 for I
in Position
+ 1 .. E
.Length
(Container
) loop
1126 if Generic_Keys
.Key
(E
.Get
(Container
, I
)) < Key
then
1134 --------------------------
1135 -- E_Smaller_Than_Range --
1136 --------------------------
1138 function E_Smaller_Than_Range
1139 (Container
: E
.Sequence
;
1140 Fst
: Positive_Count_Type
;
1142 Key
: Key_Type
) return Boolean
1145 for I
in Fst
.. Lst
loop
1146 if not (Key
< Generic_Keys
.Key
(E
.Get
(Container
, I
))) then
1151 end E_Smaller_Than_Range
;
1158 (Container
: E
.Sequence
;
1159 Key
: Key_Type
) return Count_Type
1162 for I
in 1 .. E
.Length
(Container
) loop
1164 (Key
, Generic_Keys
.Key
(E
.Get
(Container
, I
)))
1172 -----------------------
1173 -- M_Included_Except --
1174 -----------------------
1176 function M_Included_Except
1179 Key
: Key_Type
) return Boolean
1183 if not Contains
(Right
, E
)
1184 and not Equivalent_Keys
(Generic_Keys
.Key
(E
), Key
)
1190 end M_Included_Except
;
1193 -------------------------
1194 -- Is_Greater_Key_Node --
1195 -------------------------
1197 function Is_Greater_Key_Node
1199 Right
: Node_Type
) return Boolean
1202 return Key
(Right
.Element
) < Left
;
1203 end Is_Greater_Key_Node
;
1205 ----------------------
1206 -- Is_Less_Key_Node --
1207 ----------------------
1209 function Is_Less_Key_Node
1211 Right
: Node_Type
) return Boolean
1214 return Left
< Key
(Right
.Element
);
1215 end Is_Less_Key_Node
;
1221 function Key
(Container
: Set
; Position
: Cursor
) return Key_Type
is
1223 if not Has_Element
(Container
, Position
) then
1224 raise Constraint_Error
with
1225 "Position cursor has no element";
1228 pragma Assert
(Vet
(Container
, Position
.Node
),
1229 "bad cursor in Key");
1232 N
: Tree_Types
.Nodes_Type
renames Container
.Nodes
;
1234 return Key
(N
(Position
.Node
).Element
);
1243 (Container
: in out Set
;
1245 New_Item
: Element_Type
)
1247 Node
: constant Count_Type
:= Key_Keys
.Find
(Container
, Key
);
1249 if not Has_Element
(Container
, (Node
=> Node
)) then
1250 raise Constraint_Error
with
1251 "attempt to replace key not in set";
1253 Replace_Element
(Container
, Node
, New_Item
);
1263 function Has_Element
(Container
: Set
; Position
: Cursor
) return Boolean is
1265 if Position
.Node
= 0 then
1268 return Container
.Nodes
(Position
.Node
).Has_Element
;
1276 procedure Include
(Container
: in out Set
; New_Item
: Element_Type
) is
1281 Insert
(Container
, New_Item
, Position
, Inserted
);
1283 if not Inserted
then
1285 N
: Tree_Types
.Nodes_Type
renames Container
.Nodes
;
1287 N
(Position
.Node
).Element
:= New_Item
;
1297 (Container
: in out Set
;
1298 New_Item
: Element_Type
;
1299 Position
: out Cursor
;
1300 Inserted
: out Boolean)
1303 Insert_Sans_Hint
(Container
, New_Item
, Position
.Node
, Inserted
);
1307 (Container
: in out Set
;
1308 New_Item
: Element_Type
)
1314 Insert
(Container
, New_Item
, Position
, Inserted
);
1316 if not Inserted
then
1317 raise Constraint_Error
with
1318 "attempt to insert element already in set";
1322 ----------------------
1323 -- Insert_Sans_Hint --
1324 ----------------------
1326 procedure Insert_Sans_Hint
1327 (Container
: in out Set
;
1328 New_Item
: Element_Type
;
1329 Node
: out Count_Type
;
1330 Inserted
: out Boolean)
1332 procedure Set_Element
(Node
: in out Node_Type
);
1334 function New_Node
return Count_Type
;
1335 pragma Inline
(New_Node
);
1337 procedure Insert_Post
is
1338 new Element_Keys
.Generic_Insert_Post
(New_Node
);
1340 procedure Conditional_Insert_Sans_Hint
is
1341 new Element_Keys
.Generic_Conditional_Insert
(Insert_Post
);
1343 procedure Allocate
is new Generic_Allocate
(Set_Element
);
1349 function New_Node
return Count_Type
is
1350 Result
: Count_Type
;
1352 Allocate
(Container
, Result
);
1360 procedure Set_Element
(Node
: in out Node_Type
) is
1362 Node
.Element
:= New_Item
;
1365 -- Start of processing for Insert_Sans_Hint
1368 Conditional_Insert_Sans_Hint
1373 end Insert_Sans_Hint
;
1375 ----------------------
1376 -- Insert_With_Hint --
1377 ----------------------
1379 procedure Insert_With_Hint
1380 (Dst_Set
: in out Set
;
1381 Dst_Hint
: Count_Type
;
1382 Src_Node
: Node_Type
;
1383 Dst_Node
: out Count_Type
)
1386 pragma Unreferenced
(Success
);
1388 procedure Set_Element
(Node
: in out Node_Type
);
1390 function New_Node
return Count_Type
;
1391 pragma Inline
(New_Node
);
1393 procedure Insert_Post
is
1394 new Element_Keys
.Generic_Insert_Post
(New_Node
);
1396 procedure Insert_Sans_Hint
is
1397 new Element_Keys
.Generic_Conditional_Insert
(Insert_Post
);
1399 procedure Local_Insert_With_Hint
is
1400 new Element_Keys
.Generic_Conditional_Insert_With_Hint
1401 (Insert_Post
, Insert_Sans_Hint
);
1403 procedure Allocate
is new Generic_Allocate
(Set_Element
);
1409 function New_Node
return Count_Type
is
1410 Result
: Count_Type
;
1412 Allocate
(Dst_Set
, Result
);
1420 procedure Set_Element
(Node
: in out Node_Type
) is
1422 Node
.Element
:= Src_Node
.Element
;
1425 -- Start of processing for Insert_With_Hint
1428 Local_Insert_With_Hint
1434 end Insert_With_Hint
;
1440 procedure Intersection
(Target
: in out Set
; Source
: Set
) is
1442 Set_Ops
.Set_Intersection
(Target
, Source
);
1445 function Intersection
(Left
, Right
: Set
) return Set
is
1447 if Left
'Address = Right
'Address then
1451 return S
: Set
(Count_Type
'Min (Length
(Left
), Length
(Right
))) do
1452 Assign
(S
, Set_Ops
.Set_Intersection
(Left
, Right
));
1460 function Is_Empty
(Container
: Set
) return Boolean is
1462 return Length
(Container
) = 0;
1465 -----------------------------
1466 -- Is_Greater_Element_Node --
1467 -----------------------------
1469 function Is_Greater_Element_Node
1470 (Left
: Element_Type
;
1471 Right
: Node_Type
) return Boolean
1474 -- Compute e > node same as node < e
1476 return Right
.Element
< Left
;
1477 end Is_Greater_Element_Node
;
1479 --------------------------
1480 -- Is_Less_Element_Node --
1481 --------------------------
1483 function Is_Less_Element_Node
1484 (Left
: Element_Type
;
1485 Right
: Node_Type
) return Boolean
1488 return Left
< Right
.Element
;
1489 end Is_Less_Element_Node
;
1491 -----------------------
1492 -- Is_Less_Node_Node --
1493 -----------------------
1495 function Is_Less_Node_Node
(L
, R
: Node_Type
) return Boolean is
1497 return L
.Element
< R
.Element
;
1498 end Is_Less_Node_Node
;
1504 function Is_Subset
(Subset
: Set
; Of_Set
: Set
) return Boolean is
1506 return Set_Ops
.Set_Subset
(Subset
, Of_Set
=> Of_Set
);
1513 function Last
(Container
: Set
) return Cursor
is
1515 return (if Length
(Container
) = 0
1517 else (Node
=> Container
.Last
));
1524 function Last_Element
(Container
: Set
) return Element_Type
is
1526 if Last
(Container
).Node
= 0 then
1527 raise Constraint_Error
with "set is empty";
1531 N
: Tree_Types
.Nodes_Type
renames Container
.Nodes
;
1533 return N
(Last
(Container
).Node
).Element
;
1541 function Left_Son
(Node
: Node_Type
) return Count_Type
is
1550 function Length
(Container
: Set
) return Count_Type
is
1552 return Container
.Length
;
1559 procedure Move
(Target
: in out Set
; Source
: in out Set
) is
1560 N
: Tree_Types
.Nodes_Type
renames Source
.Nodes
;
1564 if Target
'Address = Source
'Address then
1568 if Target
.Capacity
< Length
(Source
) then
1569 raise Constraint_Error
with -- ???
1570 "Source length exceeds Target capacity";
1579 Insert
(Target
, N
(X
).Element
); -- optimize???
1581 Tree_Operations
.Delete_Node_Sans_Free
(Source
, X
);
1582 Formal_Ordered_Sets
.Free
(Source
, X
);
1590 function Next
(Container
: Set
; Position
: Cursor
) return Cursor
is
1592 if Position
= No_Element
then
1596 if not Has_Element
(Container
, Position
) then
1597 raise Constraint_Error
;
1600 pragma Assert
(Vet
(Container
, Position
.Node
),
1601 "bad cursor in Next");
1602 return (Node
=> Tree_Operations
.Next
(Container
, Position
.Node
));
1605 procedure Next
(Container
: Set
; Position
: in out Cursor
) is
1607 Position
:= Next
(Container
, Position
);
1614 function Overlap
(Left
, Right
: Set
) return Boolean is
1616 return Set_Ops
.Set_Overlap
(Left
, Right
);
1623 function Parent
(Node
: Node_Type
) return Count_Type
is
1632 function Previous
(Container
: Set
; Position
: Cursor
) return Cursor
is
1634 if Position
= No_Element
then
1638 if not Has_Element
(Container
, Position
) then
1639 raise Constraint_Error
;
1642 pragma Assert
(Vet
(Container
, Position
.Node
),
1643 "bad cursor in Previous");
1646 Node
: constant Count_Type
:=
1647 Tree_Operations
.Previous
(Container
, Position
.Node
);
1649 return (if Node
= 0 then No_Element
else (Node
=> Node
));
1653 procedure Previous
(Container
: Set
; Position
: in out Cursor
) is
1655 Position
:= Previous
(Container
, Position
);
1662 procedure Replace
(Container
: in out Set
; New_Item
: Element_Type
) is
1663 Node
: constant Count_Type
:= Element_Keys
.Find
(Container
, New_Item
);
1667 raise Constraint_Error
with
1668 "attempt to replace element not in set";
1671 Container
.Nodes
(Node
).Element
:= New_Item
;
1674 ---------------------
1675 -- Replace_Element --
1676 ---------------------
1678 procedure Replace_Element
1681 Item
: Element_Type
)
1683 pragma Assert
(Node
/= 0);
1685 function New_Node
return Count_Type
;
1686 pragma Inline
(New_Node
);
1688 procedure Local_Insert_Post
is
1689 new Element_Keys
.Generic_Insert_Post
(New_Node
);
1691 procedure Local_Insert_Sans_Hint
is
1692 new Element_Keys
.Generic_Conditional_Insert
(Local_Insert_Post
);
1694 procedure Local_Insert_With_Hint
is
1695 new Element_Keys
.Generic_Conditional_Insert_With_Hint
1697 Local_Insert_Sans_Hint
);
1699 NN
: Tree_Types
.Nodes_Type
renames Tree
.Nodes
;
1705 function New_Node
return Count_Type
is
1706 N
: Node_Type
renames NN
(Node
);
1717 Result
: Count_Type
;
1720 -- Start of processing for Insert
1723 if Item
< NN
(Node
).Element
1724 or else NN
(Node
).Element
< Item
1729 NN
(Node
).Element
:= Item
;
1733 Hint
:= Element_Keys
.Ceiling
(Tree
, Item
);
1738 elsif Item
< NN
(Hint
).Element
then
1740 NN
(Node
).Element
:= Item
;
1745 pragma Assert
(not (NN
(Hint
).Element
< Item
));
1746 raise Program_Error
with "attempt to replace existing element";
1749 Tree_Operations
.Delete_Node_Sans_Free
(Tree
, Node
);
1751 Local_Insert_With_Hint
1756 Inserted
=> Inserted
);
1758 pragma Assert
(Inserted
);
1759 pragma Assert
(Result
= Node
);
1760 end Replace_Element
;
1762 procedure Replace_Element
1763 (Container
: in out Set
;
1765 New_Item
: Element_Type
)
1768 if not Has_Element
(Container
, Position
) then
1769 raise Constraint_Error
with
1770 "Position cursor has no element";
1773 pragma Assert
(Vet
(Container
, Position
.Node
),
1774 "bad cursor in Replace_Element");
1776 Replace_Element
(Container
, Position
.Node
, New_Item
);
1777 end Replace_Element
;
1783 function Right_Son
(Node
: Node_Type
) return Count_Type
is
1793 (Node
: in out Node_Type
;
1794 Color
: Red_Black_Trees
.Color_Type
)
1797 Node
.Color
:= Color
;
1804 procedure Set_Left
(Node
: in out Node_Type
; Left
: Count_Type
) is
1813 procedure Set_Parent
(Node
: in out Node_Type
; Parent
: Count_Type
) is
1815 Node
.Parent
:= Parent
;
1822 procedure Set_Right
(Node
: in out Node_Type
; Right
: Count_Type
) is
1824 Node
.Right
:= Right
;
1827 --------------------------
1828 -- Symmetric_Difference --
1829 --------------------------
1831 procedure Symmetric_Difference
(Target
: in out Set
; Source
: Set
) is
1833 Set_Ops
.Set_Symmetric_Difference
(Target
, Source
);
1834 end Symmetric_Difference
;
1836 function Symmetric_Difference
(Left
, Right
: Set
) return Set
is
1838 if Left
'Address = Right
'Address then
1842 if Length
(Right
) = 0 then
1846 if Length
(Left
) = 0 then
1850 return S
: Set
(Length
(Left
) + Length
(Right
)) do
1851 Assign
(S
, Set_Ops
.Set_Symmetric_Difference
(Left
, Right
));
1853 end Symmetric_Difference
;
1859 function To_Set
(New_Item
: Element_Type
) return Set
is
1863 return S
: Set
(Capacity
=> 1) do
1864 Insert_Sans_Hint
(S
, New_Item
, Node
, Inserted
);
1865 pragma Assert
(Inserted
);
1873 procedure Union
(Target
: in out Set
; Source
: Set
) is
1875 Set_Ops
.Set_Union
(Target
, Source
);
1878 function Union
(Left
, Right
: Set
) return Set
is
1880 if Left
'Address = Right
'Address then
1884 if Length
(Left
) = 0 then
1888 if Length
(Right
) = 0 then
1892 return S
: Set
(Length
(Left
) + Length
(Right
)) do
1893 Assign
(S
, Source
=> Left
);
1898 end Ada
.Containers
.Formal_Ordered_Sets
;