1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.INDEFINITE_ORDERED_MULTISETS --
9 -- Copyright (C) 2004-2023, 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/>. --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
30 -- The indefinite ordered multiset container is similar to the indefinite
31 -- ordered set, but with the difference that multiple equivalent elements are
32 -- allowed. It also provides additional operations, to iterate over items that
35 private with Ada
.Containers
.Red_Black_Trees
;
36 private with Ada
.Finalization
;
37 private with Ada
.Streams
;
38 private with Ada
.Strings
.Text_Buffers
;
39 with Ada
.Iterator_Interfaces
;
42 type Element_Type
(<>) is private;
44 with function "<" (Left
, Right
: Element_Type
) return Boolean is <>;
45 with function "=" (Left
, Right
: Element_Type
) return Boolean is <>;
47 package Ada
.Containers
.Indefinite_Ordered_Multisets
with
50 pragma Annotate
(CodePeer
, Skip_Analysis
);
54 function Equivalent_Elements
(Left
, Right
: Element_Type
) return Boolean;
55 -- Returns False if Left is less than Right, or Right is less than Left;
56 -- otherwise, it returns True.
58 type Set
is tagged private
59 with Constant_Indexing
=> Constant_Reference
,
60 Default_Iterator
=> Iterate
,
61 Iterator_Element
=> Element_Type
;
63 pragma Preelaborable_Initialization
(Set
);
65 type Cursor
is private;
66 pragma Preelaborable_Initialization
(Cursor
);
68 Empty_Set
: constant Set
;
69 -- The default value for set objects declared without an explicit
70 -- initialization expression.
72 No_Element
: constant Cursor
;
73 -- The default value for cursor objects declared without an explicit
74 -- initialization expression.
76 function Has_Element
(Position
: Cursor
) return Boolean;
77 -- Equivalent to Position /= No_Element
79 package Set_Iterator_Interfaces
is new
80 Ada
.Iterator_Interfaces
(Cursor
, Has_Element
);
82 function "=" (Left
, Right
: Set
) return Boolean;
83 -- If Left denotes the same set object as Right, then equality returns
84 -- True. If the length of Left is different from the length of Right, then
85 -- it returns False. Otherwise, set equality iterates over Left and Right,
86 -- comparing the element of Left to the element of Right using the equality
87 -- operator for elements. If the elements compare False, then the iteration
88 -- terminates and set equality returns False. Otherwise, if all elements
89 -- compare True, then set equality returns True.
91 function Equivalent_Sets
(Left
, Right
: Set
) return Boolean;
92 -- Similar to set equality, but with the difference that elements are
93 -- compared for equivalence instead of equality.
95 function To_Set
(New_Item
: Element_Type
) return Set
;
96 -- Constructs a set object with New_Item as its single element
98 function Length
(Container
: Set
) return Count_Type
;
99 -- Returns the total number of elements in Container
101 function Is_Empty
(Container
: Set
) return Boolean;
102 -- Returns True if Container.Length is 0
104 procedure Clear
(Container
: in out Set
);
105 -- Deletes all elements from Container
107 function Element
(Position
: Cursor
) return Element_Type
;
108 -- If Position equals No_Element, then Constraint_Error is raised.
109 -- Otherwise, function Element returns the element designed by Position.
111 procedure Replace_Element
112 (Container
: in out Set
;
114 New_Item
: Element_Type
);
115 -- If Position equals No_Element, then Constraint_Error is raised. If
116 -- Position is associated with a set different from Container, then
117 -- Program_Error is raised. If New_Item is equivalent to the element
118 -- designated by Position, then if Container is locked (element tampering
119 -- has been attempted), Program_Error is raised; otherwise, the element
120 -- designated by Position is assigned the value of New_Item. If New_Item is
121 -- not equivalent to the element designated by Position, then if the
122 -- container is busy (cursor tampering has been attempted), Program_Error
123 -- is raised; otherwise, the element designed by Position is assigned the
124 -- value of New_Item, and the node is moved to its new position (in
125 -- canonical insertion order).
127 procedure Query_Element
129 Process
: not null access procedure (Element
: Element_Type
));
130 -- If Position equals No_Element, then Constraint_Error is
131 -- raised. Otherwise, it calls Process with the element designated by
132 -- Position as the parameter. This call locks the container, so attempts to
133 -- change the value of the element while Process is executing (to "tamper
134 -- with elements") will raise Program_Error.
136 type Constant_Reference_Type
137 (Element
: not null access constant Element_Type
) is private
138 with Implicit_Dereference
=> Element
;
140 function Constant_Reference
141 (Container
: aliased Set
;
142 Position
: Cursor
) return Constant_Reference_Type
;
143 pragma Inline
(Constant_Reference
);
145 procedure Assign
(Target
: in out Set
; Source
: Set
);
147 function Copy
(Source
: Set
) return Set
;
149 procedure Move
(Target
: in out Set
; Source
: in out Set
);
150 -- If Target denotes the same object as Source, the operation does
151 -- nothing. If either Target or Source is busy (cursor tampering is
152 -- attempted), then it raises Program_Error. Otherwise, Target is cleared,
153 -- and the nodes from Source are moved (not copied) to Target (so Source
157 (Container
: in out Set
;
158 New_Item
: Element_Type
;
159 Position
: out Cursor
);
160 -- Insert adds New_Item to Container, and returns cursor Position
161 -- designating the newly inserted node. The node is inserted after any
162 -- existing elements less than or equivalent to New_Item (and before any
163 -- elements greater than New_Item). Note that the issue of where the new
164 -- node is inserted relative to equivalent elements does not arise for
165 -- unique-key containers, since in that case the insertion would simply
166 -- fail. For a multiple-key container (the case here), insertion always
167 -- succeeds, and is defined such that the new item is positioned after any
168 -- equivalent elements already in the container.
170 procedure Insert
(Container
: in out Set
; New_Item
: Element_Type
);
171 -- Inserts New_Item in Container, but does not return a cursor designating
172 -- the newly-inserted node.
174 -- TODO: include Replace too???
177 -- (Container : in out Set;
178 -- New_Item : Element_Type);
180 procedure Exclude
(Container
: in out Set
; Item
: Element_Type
);
181 -- Deletes from Container all of the elements equivalent to Item
183 procedure Delete
(Container
: in out Set
; Item
: Element_Type
);
184 -- Deletes from Container all of the elements equivalent to Item. If there
185 -- are no elements equivalent to Item, then it raises Constraint_Error.
187 procedure Delete
(Container
: in out Set
; Position
: in out Cursor
);
188 -- If Position equals No_Element, then Constraint_Error is raised. If
189 -- Position is associated with a set different from Container, then
190 -- Program_Error is raised. Otherwise, the node designated by Position is
191 -- removed from Container, and Position is set to No_Element.
193 procedure Delete_First
(Container
: in out Set
);
194 -- Removes the first node from Container
196 procedure Delete_Last
(Container
: in out Set
);
197 -- Removes the last node from Container
199 procedure Union
(Target
: in out Set
; Source
: Set
);
200 -- If Target is busy (cursor tampering is attempted), then Program_Error is
201 -- raised. Otherwise, it inserts each element of Source into Target.
202 -- Elements are inserted in the canonical order for multisets, such that
203 -- the elements from Source are inserted after equivalent elements already
206 function Union
(Left
, Right
: Set
) return Set
;
207 -- Returns a set comprising the all elements from Left and all of the
208 -- elements from Right. The elements from Right follow the equivalent
209 -- elements from Left.
211 function "or" (Left
, Right
: Set
) return Set
renames Union
;
213 procedure Intersection
(Target
: in out Set
; Source
: Set
);
214 -- If Target denotes the same object as Source, the operation does
215 -- nothing. If Target is busy (cursor tampering is attempted),
216 -- Program_Error is raised. Otherwise, the elements in Target having no
217 -- equivalent element in Source are deleted from Target.
219 function Intersection
(Left
, Right
: Set
) return Set
;
220 -- If Left denotes the same object as Right, then the function returns a
221 -- copy of Left. Otherwise, it returns a set comprising the equivalent
222 -- elements from both Left and Right. Items are inserted in the result set
223 -- in canonical order, such that the elements from Left precede the
224 -- equivalent elements from Right.
226 function "and" (Left
, Right
: Set
) return Set
renames Intersection
;
228 procedure Difference
(Target
: in out Set
; Source
: Set
);
229 -- If Target is busy (cursor tampering is attempted), then Program_Error is
230 -- raised. Otherwise, the elements in Target that are equivalent to
231 -- elements in Source are deleted from Target.
233 function Difference
(Left
, Right
: Set
) return Set
;
234 -- Returns a set comprising the elements from Left that have no equivalent
237 function "-" (Left
, Right
: Set
) return Set
renames Difference
;
239 procedure Symmetric_Difference
(Target
: in out Set
; Source
: Set
);
240 -- If Target is busy, then Program_Error is raised. Otherwise, the elements
241 -- in Target equivalent to elements in Source are deleted from Target, and
242 -- the elements in Source not equivalent to elements in Target are inserted
245 function Symmetric_Difference
(Left
, Right
: Set
) return Set
;
246 -- Returns a set comprising the union of the elements from Target having no
247 -- equivalent in Source, and the elements of Source having no equivalent in
250 function "xor" (Left
, Right
: Set
) return Set
renames Symmetric_Difference
;
252 function Overlap
(Left
, Right
: Set
) return Boolean;
253 -- Returns True if Left contains an element equivalent to an element of
256 function Is_Subset
(Subset
: Set
; Of_Set
: Set
) return Boolean;
257 -- Returns True if every element in Subset has an equivalent element in
260 function First
(Container
: Set
) return Cursor
;
261 -- If Container is empty, the function returns No_Element. Otherwise, it
262 -- returns a cursor designating the smallest element.
264 function First_Element
(Container
: Set
) return Element_Type
;
265 -- Equivalent to Element (First (Container))
267 function Last
(Container
: Set
) return Cursor
;
268 -- If Container is empty, the function returns No_Element. Otherwise, it
269 -- returns a cursor designating the largest element.
271 function Last_Element
(Container
: Set
) return Element_Type
;
272 -- Equivalent to Element (Last (Container))
274 function Next
(Position
: Cursor
) return Cursor
;
275 -- If Position equals No_Element or Last (Container), the function returns
276 -- No_Element. Otherwise, it returns a cursor designating the node that
277 -- immediately follows (as per the insertion order) the node designated by
280 procedure Next
(Position
: in out Cursor
);
281 -- Equivalent to Position := Next (Position)
283 function Previous
(Position
: Cursor
) return Cursor
;
284 -- If Position equals No_Element or First (Container), the function returns
285 -- No_Element. Otherwise, it returns a cursor designating the node that
286 -- immediately precedes (as per the insertion order) the node designated by
289 procedure Previous
(Position
: in out Cursor
);
290 -- Equivalent to Position := Previous (Position)
292 function Find
(Container
: Set
; Item
: Element_Type
) return Cursor
;
293 -- Returns a cursor designating the first element in Container equivalent
294 -- to Item. If there is no equivalent element, it returns No_Element.
296 function Floor
(Container
: Set
; Item
: Element_Type
) return Cursor
;
297 -- If Container is empty, the function returns No_Element. If Item is
298 -- equivalent to elements in Container, it returns a cursor designating the
299 -- first equivalent element. Otherwise, it returns a cursor designating the
300 -- largest element less than Item, or No_Element if all elements are
301 -- greater than Item.
303 function Ceiling
(Container
: Set
; Item
: Element_Type
) return Cursor
;
304 -- If Container is empty, the function returns No_Element. If Item is
305 -- equivalent to elements of Container, it returns a cursor designating the
306 -- last equivalent element. Otherwise, it returns a cursor designating the
307 -- smallest element greater than Item, or No_Element if all elements are
310 function Contains
(Container
: Set
; Item
: Element_Type
) return Boolean;
311 -- Equivalent to Container.Find (Item) /= No_Element
313 function "<" (Left
, Right
: Cursor
) return Boolean;
314 -- Equivalent to Element (Left) < Element (Right)
316 function ">" (Left
, Right
: Cursor
) return Boolean;
317 -- Equivalent to Element (Right) < Element (Left)
319 function "<" (Left
: Cursor
; Right
: Element_Type
) return Boolean;
320 -- Equivalent to Element (Left) < Right
322 function ">" (Left
: Cursor
; Right
: Element_Type
) return Boolean;
323 -- Equivalent to Right < Element (Left)
325 function "<" (Left
: Element_Type
; Right
: Cursor
) return Boolean;
326 -- Equivalent to Left < Element (Right)
328 function ">" (Left
: Element_Type
; Right
: Cursor
) return Boolean;
329 -- Equivalent to Element (Right) < Left
333 Process
: not null access procedure (Position
: Cursor
));
334 -- Calls Process with a cursor designating each element of Container, in
335 -- order from Container.First to Container.Last.
337 procedure Reverse_Iterate
339 Process
: not null access procedure (Position
: Cursor
));
340 -- Calls Process with a cursor designating each element of Container, in
341 -- order from Container.Last to Container.First.
346 Process
: not null access procedure (Position
: Cursor
));
347 -- Call Process with a cursor designating each element equivalent to Item,
348 -- in order from Container.Floor (Item) to Container.Ceiling (Item).
350 procedure Reverse_Iterate
353 Process
: not null access procedure (Position
: Cursor
));
354 -- Call Process with a cursor designating each element equivalent to Item,
355 -- in order from Container.Ceiling (Item) to Container.Floor (Item).
359 return Set_Iterator_Interfaces
.Reversible_Iterator
'class;
364 return Set_Iterator_Interfaces
.Reversible_Iterator
'class;
367 type Key_Type
(<>) is private;
369 with function Key
(Element
: Element_Type
) return Key_Type
;
371 with function "<" (Left
, Right
: Key_Type
) return Boolean is <>;
373 package Generic_Keys
is
375 function Equivalent_Keys
(Left
, Right
: Key_Type
) return Boolean;
376 -- Returns False if Left is less than Right, or Right is less than Left;
377 -- otherwise, it returns True.
379 function Key
(Position
: Cursor
) return Key_Type
;
380 -- Equivalent to Key (Element (Position))
382 function Element
(Container
: Set
; Key
: Key_Type
) return Element_Type
;
383 -- Equivalent to Element (Find (Container, Key))
385 procedure Exclude
(Container
: in out Set
; Key
: Key_Type
);
386 -- Deletes from Container any elements whose key is equivalent to Key
388 procedure Delete
(Container
: in out Set
; Key
: Key_Type
);
389 -- Deletes from Container any elements whose key is equivalent to
390 -- Key. If there are no such elements, then it raises Constraint_Error.
392 function Find
(Container
: Set
; Key
: Key_Type
) return Cursor
;
393 -- Returns a cursor designating the first element in Container whose key
394 -- is equivalent to Key. If there is no equivalent element, it returns
397 function Floor
(Container
: Set
; Key
: Key_Type
) return Cursor
;
398 -- If Container is empty, the function returns No_Element. If Item is
399 -- equivalent to the keys of elements in Container, it returns a cursor
400 -- designating the first such element. Otherwise, it returns a cursor
401 -- designating the largest element whose key is less than Item, or
402 -- No_Element if all keys are greater than Item.
404 function Ceiling
(Container
: Set
; Key
: Key_Type
) return Cursor
;
405 -- If Container is empty, the function returns No_Element. If Item is
406 -- equivalent to the keys of elements of Container, it returns a cursor
407 -- designating the last such element. Otherwise, it returns a cursor
408 -- designating the smallest element whose key is greater than Item, or
409 -- No_Element if all keys are less than Item.
411 function Contains
(Container
: Set
; Key
: Key_Type
) return Boolean;
412 -- Equivalent to Find (Container, Key) /= No_Element
414 procedure Update_Element
-- Update_Element_Preserving_Key ???
415 (Container
: in out Set
;
417 Process
: not null access
418 procedure (Element
: in out Element_Type
));
419 -- If Position equals No_Element, then Constraint_Error is raised. If
420 -- Position is associated with a set object different from Container,
421 -- then Program_Error is raised. Otherwise, it makes a copy of the key
422 -- of the element designated by Position, and then calls Process with
423 -- the element as the parameter. Update_Element then compares the key
424 -- value obtained before calling Process to the key value obtained from
425 -- the element after calling Process. If the keys are equivalent then
426 -- the operation terminates. If Container is busy (cursor tampering has
427 -- been attempted), then Program_Error is raised. Otherwise, the node
428 -- is moved to its new position (in canonical order).
433 Process
: not null access procedure (Position
: Cursor
));
434 -- Call Process with a cursor designating each element equivalent to
435 -- Key, in order from Floor (Container, Key) to
436 -- Ceiling (Container, Key).
438 procedure Reverse_Iterate
441 Process
: not null access procedure (Position
: Cursor
));
442 -- Call Process with a cursor designating each element equivalent to
443 -- Key, in order from Ceiling (Container, Key) to
444 -- Floor (Container, Key).
450 pragma Inline
(Next
);
451 pragma Inline
(Previous
);
454 type Node_Access
is access Node_Type
;
456 type Element_Access
is access Element_Type
;
458 type Node_Type
is limited record
459 Parent
: Node_Access
;
462 Color
: Red_Black_Trees
.Color_Type
:= Red_Black_Trees
.Red
;
463 Element
: Element_Access
;
466 package Tree_Types
is new Red_Black_Trees
.Generic_Tree_Types
470 type Set
is new Ada
.Finalization
.Controlled
with record
471 Tree
: Tree_Types
.Tree_Type
;
472 end record with Put_Image
=> Put_Image
;
475 (S
: in out Ada
.Strings
.Text_Buffers
.Root_Buffer_Type
'Class; V
: Set
);
477 overriding
procedure Adjust
(Container
: in out Set
);
479 overriding
procedure Finalize
(Container
: in out Set
) renames Clear
;
482 use Tree_Types
, Tree_Types
.Implementation
;
483 use Ada
.Finalization
;
486 type Set_Access
is access all Set
;
487 for Set_Access
'Storage_Size use 0;
489 -- In all predefined libraries the following type is controlled, for proper
490 -- management of tampering checks. For performance reason we omit this
491 -- machinery for multisets, which are used in a number of our tools.
493 type Reference_Control_Type
is record
494 Container
: Set_Access
;
497 type Constant_Reference_Type
498 (Element
: not null access constant Element_Type
) is record
499 Control
: Reference_Control_Type
:=
500 raise Program_Error
with "uninitialized reference";
501 -- The RM says, "The default initialization of an object of
502 -- type Constant_Reference_Type or Reference_Type propagates
506 type Cursor
is record
507 Container
: Set_Access
;
512 (Stream
: not null access Root_Stream_Type
'Class;
515 for Cursor
'Write use Write
;
518 (Stream
: not null access Root_Stream_Type
'Class;
521 for Cursor
'Read use Read
;
523 No_Element
: constant Cursor
:= Cursor
'(null, null);
526 (Stream : not null access Root_Stream_Type'Class;
529 for Set'Write use Write;
532 (Stream : not null access Root_Stream_Type'Class;
533 Container : out Set);
535 for Set'Read use Read;
538 (Stream : not null access Root_Stream_Type'Class;
539 Item : out Constant_Reference_Type);
541 for Constant_Reference_Type'Read use Read;
544 (Stream : not null access Root_Stream_Type'Class;
545 Item : Constant_Reference_Type);
547 for Constant_Reference_Type'Write use Write;
549 Empty_Set : constant Set := (Controlled with others => <>);
551 type Iterator is new Limited_Controlled and
552 Set_Iterator_Interfaces.Reversible_Iterator with
554 Container : Set_Access;
557 with Disable_Controlled => not T_Check;
559 overriding procedure Finalize (Object : in out Iterator);
561 overriding function First (Object : Iterator) return Cursor;
562 overriding function Last (Object : Iterator) return Cursor;
564 overriding function Next
566 Position : Cursor) return Cursor;
568 overriding function Previous
570 Position : Cursor) return Cursor;
572 end Ada.Containers.Indefinite_Ordered_Multisets;