1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . O R D E R E D _ M U L T I S E T S --
9 -- Copyright (C) 2004-2024, 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 ordered multiset container is similar to the ordered set, but with the
31 -- difference that multiple equivalent elements are allowed. It also provides
32 -- additional operations, to iterate over items that are equivalent.
34 private with Ada
.Containers
.Red_Black_Trees
;
35 private with Ada
.Finalization
;
36 private with Ada
.Streams
;
37 private with Ada
.Strings
.Text_Buffers
;
38 with Ada
.Iterator_Interfaces
;
41 type Element_Type
is private;
43 with function "<" (Left
, Right
: Element_Type
) return Boolean is <>;
44 with function "=" (Left
, Right
: Element_Type
) return Boolean is <>;
46 package Ada
.Containers
.Ordered_Multisets
with
49 pragma Annotate
(CodePeer
, Skip_Analysis
);
53 function Equivalent_Elements
(Left
, Right
: Element_Type
) return Boolean;
54 -- Returns False if Left is less than Right, or Right is less than Left;
55 -- otherwise, it returns True.
57 type Set
is tagged private
58 with Constant_Indexing
=> Constant_Reference
,
59 Default_Iterator
=> Iterate
,
60 Iterator_Element
=> Element_Type
;
62 pragma Preelaborable_Initialization
(Set
);
64 type Cursor
is private;
65 pragma Preelaborable_Initialization
(Cursor
);
67 Empty_Set
: constant Set
;
68 -- The default value for set objects declared without an explicit
69 -- initialization expression.
71 No_Element
: constant Cursor
;
72 -- The default value for cursor objects declared without an explicit
73 -- initialization expression.
75 function Has_Element
(Position
: Cursor
) return Boolean;
76 -- Equivalent to Position /= No_Element
78 package Set_Iterator_Interfaces
is new
79 Ada
.Iterator_Interfaces
(Cursor
, Has_Element
);
81 function "=" (Left
, Right
: Set
) return Boolean;
82 -- If Left denotes the same set object as Right, then equality returns
83 -- True. If the length of Left is different from the length of Right, then
84 -- it returns False. Otherwise, set equality iterates over Left and Right,
85 -- comparing the element of Left to the element of Right using the equality
86 -- operator for elements. If the elements compare False, then the iteration
87 -- terminates and set equality returns False. Otherwise, if all elements
88 -- compare True, then set equality returns True.
90 function Equivalent_Sets
(Left
, Right
: Set
) return Boolean;
91 -- Similar to set equality, but with the difference that elements are
92 -- compared for equivalence instead of equality.
94 function To_Set
(New_Item
: Element_Type
) return Set
;
95 -- Constructs a set object with New_Item as its single element
97 function Length
(Container
: Set
) return Count_Type
;
98 -- Returns the total number of elements in Container
100 function Is_Empty
(Container
: Set
) return Boolean;
101 -- Returns True if Container.Length is 0
103 procedure Clear
(Container
: in out Set
);
104 -- Deletes all elements from Container
106 function Element
(Position
: Cursor
) return Element_Type
;
107 -- If Position equals No_Element, then Constraint_Error is raised.
108 -- Otherwise, function Element returns the element designed by Position.
110 procedure Replace_Element
111 (Container
: in out Set
;
113 New_Item
: Element_Type
);
114 -- If Position equals No_Element, then Constraint_Error is raised. If
115 -- Position is associated with a set different from Container, then
116 -- Program_Error is raised. If New_Item is equivalent to the element
117 -- designated by Position, then if Container is locked (element tampering
118 -- has been attempted), Program_Error is raised; otherwise, the element
119 -- designated by Position is assigned the value of New_Item. If New_Item is
120 -- not equivalent to the element designated by Position, then if the
121 -- container is busy (cursor tampering has been attempted), Program_Error
122 -- is raised; otherwise, the element designed by Position is assigned the
123 -- value of New_Item, and the node is moved to its new position (in
124 -- canonical insertion order).
126 procedure Query_Element
128 Process
: not null access procedure (Element
: Element_Type
));
129 -- If Position equals No_Element, then Constraint_Error is
130 -- raised. Otherwise, it calls Process with the element designated by
131 -- Position as the parameter. This call locks the container, so attempts to
132 -- change the value of the element while Process is executing (to "tamper
133 -- with elements") will raise Program_Error.
135 type Constant_Reference_Type
136 (Element
: not null access constant Element_Type
) is private
137 with Implicit_Dereference
=> Element
;
139 function Constant_Reference
140 (Container
: aliased Set
;
141 Position
: Cursor
) return Constant_Reference_Type
;
142 pragma Inline
(Constant_Reference
);
144 procedure Assign
(Target
: in out Set
; Source
: Set
);
146 function Copy
(Source
: Set
) return Set
;
148 procedure Move
(Target
: in out Set
; Source
: in out Set
);
149 -- If Target denotes the same object as Source, the operation does
150 -- nothing. If either Target or Source is busy (cursor tampering is
151 -- attempted), then it raises Program_Error. Otherwise, Target is cleared,
152 -- and the nodes from Source are moved (not copied) to Target (so Source
156 (Container
: in out Set
;
157 New_Item
: Element_Type
;
158 Position
: out Cursor
);
159 -- Insert adds New_Item to Container, and returns cursor Position
160 -- designating the newly inserted node. The node is inserted after any
161 -- existing elements less than or equivalent to New_Item (and before any
162 -- elements greater than New_Item). Note that the issue of where the new
163 -- node is inserted relative to equivalent elements does not arise for
164 -- unique-key containers, since in that case the insertion would simply
165 -- fail. For a multiple-key container (the case here), insertion always
166 -- succeeds, and is defined such that the new item is positioned after any
167 -- equivalent elements already in the container.
170 (Container
: in out Set
;
171 New_Item
: Element_Type
);
172 -- Inserts New_Item in Container, but does not return a cursor designating
173 -- the newly-inserted node.
175 -- TODO: include Replace too???
178 -- (Container : in out Set;
179 -- New_Item : Element_Type);
182 (Container
: in out Set
;
183 Item
: Element_Type
);
184 -- Deletes from Container all of the elements equivalent to Item
187 (Container
: in out Set
;
188 Item
: Element_Type
);
189 -- Deletes from Container all of the elements equivalent to Item. If there
190 -- are no elements equivalent to Item, then it raises Constraint_Error.
193 (Container
: in out Set
;
194 Position
: in out Cursor
);
195 -- If Position equals No_Element, then Constraint_Error is raised. If
196 -- Position is associated with a set different from Container, then
197 -- Program_Error is raised. Otherwise, the node designated by Position is
198 -- removed from Container, and Position is set to No_Element.
200 procedure Delete_First
(Container
: in out Set
);
201 -- Removes the first node from Container
203 procedure Delete_Last
(Container
: in out Set
);
204 -- Removes the last node from Container
206 procedure Union
(Target
: in out Set
; Source
: Set
);
207 -- If Target is busy (cursor tampering is attempted), the Program_Error is
208 -- raised. Otherwise, it inserts each element of Source into
209 -- Target. Elements are inserted in the canonical order for multisets, such
210 -- that the elements from Source are inserted after equivalent elements
211 -- already in Target.
213 function Union
(Left
, Right
: Set
) return Set
;
214 -- Returns a set comprising the all elements from Left and all of the
215 -- elements from Right. The elements from Right follow the equivalent
216 -- elements from Left.
218 function "or" (Left
, Right
: Set
) return Set
renames Union
;
220 procedure Intersection
(Target
: in out Set
; Source
: Set
);
221 -- If Target denotes the same object as Source, the operation does
222 -- nothing. If Target is busy (cursor tampering is attempted),
223 -- Program_Error is raised. Otherwise, the elements in Target having no
224 -- equivalent element in Source are deleted from Target.
226 function Intersection
(Left
, Right
: Set
) return Set
;
227 -- If Left denotes the same object as Right, then the function returns a
228 -- copy of Left. Otherwise, it returns a set comprising the equivalent
229 -- elements from both Left and Right. Items are inserted in the result set
230 -- in canonical order, such that the elements from Left precede the
231 -- equivalent elements from Right.
233 function "and" (Left
, Right
: Set
) return Set
renames Intersection
;
235 procedure Difference
(Target
: in out Set
; Source
: Set
);
236 -- If Target is busy (cursor tampering is attempted), then Program_Error is
237 -- raised. Otherwise, the elements in Target that are equivalent to
238 -- elements in Source are deleted from Target.
240 function Difference
(Left
, Right
: Set
) return Set
;
241 -- Returns a set comprising the elements from Left that have no equivalent
244 function "-" (Left
, Right
: Set
) return Set
renames Difference
;
246 procedure Symmetric_Difference
(Target
: in out Set
; Source
: Set
);
247 -- If Target is busy, then Program_Error is raised. Otherwise, the elements
248 -- in Target equivalent to elements in Source are deleted from Target, and
249 -- the elements in Source not equivalent to elements in Target are inserted
252 function Symmetric_Difference
(Left
, Right
: Set
) return Set
;
253 -- Returns a set comprising the union of the elements from Target having no
254 -- equivalent in Source, and the elements of Source having no equivalent in
257 function "xor" (Left
, Right
: Set
) return Set
renames Symmetric_Difference
;
259 function Overlap
(Left
, Right
: Set
) return Boolean;
260 -- Returns True if Left contains an element equivalent to an element of
263 function Is_Subset
(Subset
: Set
; Of_Set
: Set
) return Boolean;
264 -- Returns True if every element in Subset has an equivalent element in
267 function First
(Container
: Set
) return Cursor
;
268 -- If Container is empty, the function returns No_Element. Otherwise, it
269 -- returns a cursor designating the smallest element.
271 function First_Element
(Container
: Set
) return Element_Type
;
272 -- Equivalent to Element (First (Container))
274 function Last
(Container
: Set
) return Cursor
;
275 -- If Container is empty, the function returns No_Element. Otherwise, it
276 -- returns a cursor designating the largest element.
278 function Last_Element
(Container
: Set
) return Element_Type
;
279 -- Equivalent to Element (Last (Container))
281 function Next
(Position
: Cursor
) return Cursor
;
282 -- If Position equals No_Element or Last (Container), the function returns
283 -- No_Element. Otherwise, it returns a cursor designating the node that
284 -- immediately follows (as per the insertion order) the node designated by
287 procedure Next
(Position
: in out Cursor
);
288 -- Equivalent to Position := Next (Position)
290 function Previous
(Position
: Cursor
) return Cursor
;
291 -- If Position equals No_Element or First (Container), the function returns
292 -- No_Element. Otherwise, it returns a cursor designating the node that
293 -- immediately precedes (as per the insertion order) the node designated by
296 procedure Previous
(Position
: in out Cursor
);
297 -- Equivalent to Position := Previous (Position)
299 function Find
(Container
: Set
; Item
: Element_Type
) return Cursor
;
300 -- Returns a cursor designating the first element in Container equivalent
301 -- to Item. If there is no equivalent element, it returns No_Element.
303 function Floor
(Container
: Set
; Item
: Element_Type
) return Cursor
;
304 -- If Container is empty, the function returns No_Element. If Item is
305 -- equivalent to elements in Container, it returns a cursor designating the
306 -- first equivalent element. Otherwise, it returns a cursor designating the
307 -- largest element less than Item, or No_Element if all elements are
308 -- greater than Item.
310 function Ceiling
(Container
: Set
; Item
: Element_Type
) return Cursor
;
311 -- If Container is empty, the function returns No_Element. If Item is
312 -- equivalent to elements of Container, it returns a cursor designating the
313 -- last equivalent element. Otherwise, it returns a cursor designating the
314 -- smallest element greater than Item, or No_Element if all elements are
317 function Contains
(Container
: Set
; Item
: Element_Type
) return Boolean;
318 -- Equivalent to Container.Find (Item) /= No_Element
320 function "<" (Left
, Right
: Cursor
) return Boolean;
321 -- Equivalent to Element (Left) < Element (Right)
323 function ">" (Left
, Right
: Cursor
) return Boolean;
324 -- Equivalent to Element (Right) < Element (Left)
326 function "<" (Left
: Cursor
; Right
: Element_Type
) return Boolean;
327 -- Equivalent to Element (Left) < Right
329 function ">" (Left
: Cursor
; Right
: Element_Type
) return Boolean;
330 -- Equivalent to Right < Element (Left)
332 function "<" (Left
: Element_Type
; Right
: Cursor
) return Boolean;
333 -- Equivalent to Left < Element (Right)
335 function ">" (Left
: Element_Type
; Right
: Cursor
) return Boolean;
336 -- Equivalent to Element (Right) < Left
340 Process
: not null access procedure (Position
: Cursor
));
341 -- Calls Process with a cursor designating each element of Container, in
342 -- order from Container.First to Container.Last.
344 procedure Reverse_Iterate
346 Process
: not null access procedure (Position
: Cursor
));
347 -- Calls Process with a cursor designating each element of Container, in
348 -- order from Container.Last to Container.First.
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.Floor (Item) to Container.Ceiling (Item).
357 procedure Reverse_Iterate
360 Process
: not null access procedure (Position
: Cursor
));
361 -- Call Process with a cursor designating each element equivalent to Item,
362 -- in order from Container.Ceiling (Item) to Container.Floor (Item).
366 return Set_Iterator_Interfaces
.Reversible_Iterator
'class;
371 return Set_Iterator_Interfaces
.Reversible_Iterator
'class;
374 type Key_Type
(<>) is private;
376 with function Key
(Element
: Element_Type
) return Key_Type
;
378 with function "<" (Left
, Right
: Key_Type
) return Boolean is <>;
380 package Generic_Keys
is
382 function Equivalent_Keys
(Left
, Right
: Key_Type
) return Boolean;
383 -- Returns False if Left is less than Right, or Right is less than Left;
384 -- otherwise, it returns True.
386 function Key
(Position
: Cursor
) return Key_Type
;
387 -- Equivalent to Key (Element (Position))
389 function Element
(Container
: Set
; Key
: Key_Type
) return Element_Type
;
390 -- Equivalent to Element (Find (Container, Key))
392 procedure Exclude
(Container
: in out Set
; Key
: Key_Type
);
393 -- Deletes from Container any elements whose key is equivalent to Key
395 procedure Delete
(Container
: in out Set
; Key
: Key_Type
);
396 -- Deletes from Container any elements whose key is equivalent to
397 -- Key. If there are no such elements, then it raises Constraint_Error.
399 function Find
(Container
: Set
; Key
: Key_Type
) return Cursor
;
400 -- Returns a cursor designating the first element in Container whose key
401 -- is equivalent to Key. If there is no equivalent element, it returns
404 function Floor
(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 in Container, it returns a cursor
407 -- designating the first such element. Otherwise, it returns a cursor
408 -- designating the largest element whose key is less than Item, or
409 -- No_Element if all keys are greater than Item.
411 function Ceiling
(Container
: Set
; Key
: Key_Type
) return Cursor
;
412 -- If Container is empty, the function returns No_Element. If Item is
413 -- equivalent to the keys of elements of Container, it returns a cursor
414 -- designating the last such element. Otherwise, it returns a cursor
415 -- designating the smallest element whose key is greater than Item, or
416 -- No_Element if all keys are less than Item.
418 function Contains
(Container
: Set
; Key
: Key_Type
) return Boolean;
419 -- Equivalent to Find (Container, Key) /= No_Element
421 procedure Update_Element
-- Update_Element_Preserving_Key ???
422 (Container
: in out Set
;
424 Process
: not null access
425 procedure (Element
: in out Element_Type
));
426 -- If Position equals No_Element, then Constraint_Error is raised. If
427 -- Position is associated with a set object different from Container,
428 -- then Program_Error is raised. Otherwise, it makes a copy of the key
429 -- of the element designated by Position, and then calls Process with
430 -- the element as the parameter. Update_Element then compares the key
431 -- value obtained before calling Process to the key value obtained from
432 -- the element after calling Process. If the keys are equivalent then
433 -- the operation terminates. If Container is busy (cursor tampering has
434 -- been attempted), then Program_Error is raised. Otherwise, the node
435 -- is moved to its new position (in canonical order).
440 Process
: not null access procedure (Position
: Cursor
));
441 -- Call Process with a cursor designating each element equivalent to
442 -- Key, in order from Floor (Container, Key) to
443 -- Ceiling (Container, Key).
445 procedure Reverse_Iterate
448 Process
: not null access procedure (Position
: Cursor
));
449 -- Call Process with a cursor designating each element equivalent to
450 -- Key, in order from Ceiling (Container, Key) to
451 -- Floor (Container, Key).
457 pragma Inline
(Next
);
458 pragma Inline
(Previous
);
461 type Node_Access
is access Node_Type
;
463 type Node_Type
is limited record
464 Parent
: Node_Access
;
467 Color
: Red_Black_Trees
.Color_Type
:= Red_Black_Trees
.Red
;
468 Element
: Element_Type
;
471 package Tree_Types
is
472 new Red_Black_Trees
.Generic_Tree_Types
(Node_Type
, Node_Access
);
474 type Set
is new Ada
.Finalization
.Controlled
with record
475 Tree
: Tree_Types
.Tree_Type
;
476 end record with Put_Image
=> Put_Image
;
479 (S
: in out Ada
.Strings
.Text_Buffers
.Root_Buffer_Type
'Class; V
: Set
);
481 overriding
procedure Adjust
(Container
: in out Set
);
483 overriding
procedure Finalize
(Container
: in out Set
) renames Clear
;
486 use Tree_Types
, Tree_Types
.Implementation
;
487 use Ada
.Finalization
;
490 type Set_Access
is access all Set
;
491 for Set_Access
'Storage_Size use 0;
493 -- In all predefined libraries the following type is controlled, for proper
494 -- management of tampering checks. For performance reason we omit this
495 -- machinery for multisets, which are used in a number of our tools.
497 type Reference_Control_Type
is record
498 Container
: Set_Access
;
501 type Constant_Reference_Type
502 (Element
: not null access constant Element_Type
) is record
503 Control
: Reference_Control_Type
:=
504 raise Program_Error
with "uninitialized reference";
505 -- The RM says, "The default initialization of an object of
506 -- type Constant_Reference_Type or Reference_Type propagates
510 type Cursor
is record
511 Container
: Set_Access
;
516 (Stream
: not null access Root_Stream_Type
'Class;
519 for Cursor
'Write use Write
;
522 (Stream
: not null access Root_Stream_Type
'Class;
525 for Cursor
'Read use Read
;
527 No_Element
: constant Cursor
:= Cursor
'(null, null);
530 (Stream : not null access Root_Stream_Type'Class;
533 for Set'Write use Write;
536 (Stream : not null access Root_Stream_Type'Class;
537 Container : out Set);
539 for Set'Read use Read;
542 (Stream : not null access Root_Stream_Type'Class;
543 Item : out Constant_Reference_Type);
545 for Constant_Reference_Type'Read use Read;
548 (Stream : not null access Root_Stream_Type'Class;
549 Item : Constant_Reference_Type);
551 for Constant_Reference_Type'Write use Write;
553 Empty_Set : constant Set := (Controlled with others => <>);
555 type Iterator is new Limited_Controlled and
556 Set_Iterator_Interfaces.Reversible_Iterator with
558 Container : Set_Access;
561 with Disable_Controlled => not T_Check;
563 overriding procedure Finalize (Object : in out Iterator);
565 overriding function First (Object : Iterator) return Cursor;
566 overriding function Last (Object : Iterator) return Cursor;
568 overriding function Next
570 Position : Cursor) return Cursor;
572 overriding function Previous
574 Position : Cursor) return Cursor;
576 end Ada.Containers.Ordered_Multisets;