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-2008, 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 2, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- This unit was originally developed by Matthew J Heaney. --
30 ------------------------------------------------------------------------------
32 -- The ordered multiset container is similar to the ordered set, but with the
33 -- difference that multiple equivalent elements are allowed. It also provides
34 -- additional operations, to iterate over items that are equivalent.
36 private with Ada
.Containers
.Red_Black_Trees
;
37 private with Ada
.Finalization
;
38 private with Ada
.Streams
;
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
is
50 function Equivalent_Elements
(Left
, Right
: Element_Type
) return Boolean;
51 -- Returns False if Left is less than Right, or Right is less than Left;
52 -- otherwise, it returns True.
54 type Set
is tagged private;
55 pragma Preelaborable_Initialization
(Set
);
57 type Cursor
is private;
58 pragma Preelaborable_Initialization
(Cursor
);
60 Empty_Set
: constant Set
;
61 -- The default value for set objects declared without an explicit
62 -- initialization expression.
64 No_Element
: constant Cursor
;
65 -- The default value for cursor objects declared without an explicit
66 -- initialization expression.
68 function "=" (Left
, Right
: Set
) return Boolean;
69 -- If Left denotes the same set object as Right, then equality returns
70 -- True. If the length of Left is different from the length of Right, then
71 -- it returns False. Otherwise, set equality iterates over Left and Right,
72 -- comparing the element of Left to the element of Right using the equality
73 -- operator for elements. If the elements compare False, then the iteration
74 -- terminates and set equality returns False. Otherwise, if all elements
75 -- compare True, then set equality returns True.
77 function Equivalent_Sets
(Left
, Right
: Set
) return Boolean;
78 -- Similar to set equality, but with the difference that elements are
79 -- compared for equivalence instead of equality.
81 function To_Set
(New_Item
: Element_Type
) return Set
;
82 -- Constructs a set object with New_Item as its single element
84 function Length
(Container
: Set
) return Count_Type
;
85 -- Returns the total number of elements in Container
87 function Is_Empty
(Container
: Set
) return Boolean;
88 -- Returns True if Container.Length is 0
90 procedure Clear
(Container
: in out Set
);
91 -- Deletes all elements from Container
93 function Element
(Position
: Cursor
) return Element_Type
;
94 -- If Position equals No_Element, then Constraint_Error is raised.
95 -- Otherwise, function Element returns the element designed by Position.
97 procedure Replace_Element
98 (Container
: in out Set
;
100 New_Item
: Element_Type
);
101 -- If Position equals No_Element, then Constraint_Error is raised. If
102 -- Position is associated with a set different from Container, then
103 -- Program_Error is raised. If New_Item is equivalent to the element
104 -- designated by Position, then if Container is locked (element tampering
105 -- has been attempted), Program_Error is raised; otherwise, the element
106 -- designated by Position is assigned the value of New_Item. If New_Item is
107 -- not equivalent to the element designated by Position, then if the
108 -- container is busy (cursor tampering has been attempted), Program_Error
109 -- is raised; otherwise, the element designed by Position is assigned the
110 -- value of New_Item, and the node is moved to its new position (in
111 -- canonical insertion order).
113 procedure Query_Element
115 Process
: not null access procedure (Element
: Element_Type
));
116 -- If Position equals No_Element, then Constraint_Error is
117 -- raised. Otherwise, it calls Process with the element designated by
118 -- Position as the parameter. This call locks the container, so attempts to
119 -- change the value of the element while Process is executing (to "tamper
120 -- with elements") will raise Program_Error.
122 procedure Move
(Target
: in out Set
; Source
: in out Set
);
123 -- If Target denotes the same object as Source, the operation does
124 -- nothing. If either Target or Source is busy (cursor tampering is
125 -- attempted), then it raises Program_Error. Otherwise, Target is cleared,
126 -- and the nodes from Source are moved (not copied) to Target (so Source
130 (Container
: in out Set
;
131 New_Item
: Element_Type
;
132 Position
: out Cursor
);
133 -- Insert adds New_Item to Container, and returns cursor Position
134 -- designating the newly inserted node. The node is inserted after any
135 -- existing elements less than or equivalent to New_Item (and before any
136 -- elements greater than New_Item). Note that the issue of where the new
137 -- node is inserted relative to equivalent elements does not arise for
138 -- unique-key containers, since in that case the insertion would simply
139 -- fail. For a multiple-key container (the case here), insertion always
140 -- succeeds, and is defined such that the new item is positioned after any
141 -- equivalent elements already in the container.
144 (Container
: in out Set
;
145 New_Item
: Element_Type
);
146 -- Inserts New_Item in Container, but does not return a cursor designating
147 -- the newly-inserted node.
149 -- TODO: include Replace too???
152 -- (Container : in out Set;
153 -- New_Item : Element_Type);
156 (Container
: in out Set
;
157 Item
: Element_Type
);
158 -- Deletes from Container all of the elements equivalent to Item
161 (Container
: in out Set
;
162 Item
: Element_Type
);
163 -- Deletes from Container all of the elements equivalent to Item. If there
164 -- are no elements equivalent to Item, then it raises Constraint_Error.
167 (Container
: in out Set
;
168 Position
: in out Cursor
);
169 -- If Position equals No_Element, then Constraint_Error is raised. If
170 -- Position is associated with a set different from Container, then
171 -- Program_Error is raised. Otherwise, the node designated by Position is
172 -- removed from Container, and Position is set to No_Element.
174 procedure Delete_First
(Container
: in out Set
);
175 -- Removes the first node from Container
177 procedure Delete_Last
(Container
: in out Set
);
178 -- Removes the last node from Container
180 procedure Union
(Target
: in out Set
; Source
: Set
);
181 -- If Target is busy (cursor tampering is attempted), the Program_Error is
182 -- raised. Otherwise, it inserts each element of Source into
183 -- Target. Elements are inserted in the canonical order for multisets, such
184 -- that the elements from Source are inserted after equivalent elements
185 -- already in Target.
187 function Union
(Left
, Right
: Set
) return Set
;
188 -- Returns a set comprising the all elements from Left and all of the
189 -- elements from Right. The elements from Right follow the equivalent
190 -- elements from Left.
192 function "or" (Left
, Right
: Set
) return Set
renames Union
;
194 procedure Intersection
(Target
: in out Set
; Source
: Set
);
195 -- If Target denotes the same object as Source, the operation does
196 -- nothing. If Target is busy (cursor tampering is attempted),
197 -- Program_Error is raised. Otherwise, the elements in Target having no
198 -- equivalent element in Source are deleted from Target.
200 function Intersection
(Left
, Right
: Set
) return Set
;
201 -- If Left denotes the same object as Right, then the function returns a
202 -- copy of Left. Otherwise, it returns a set comprising the equivalent
203 -- elements from both Left and Right. Items are inserted in the result set
204 -- in canonical order, such that the elements from Left precede the
205 -- equivalent elements from Right.
207 function "and" (Left
, Right
: Set
) return Set
renames Intersection
;
209 procedure Difference
(Target
: in out Set
; Source
: Set
);
210 -- If Target is busy (cursor tampering is attempted), then Program_Error is
211 -- raised. Otherwise, the elements in Target that are equivalent to
212 -- elements in Source are deleted from Target.
214 function Difference
(Left
, Right
: Set
) return Set
;
215 -- Returns a set comprising the elements from Left that have no equivalent
218 function "-" (Left
, Right
: Set
) return Set
renames Difference
;
220 procedure Symmetric_Difference
(Target
: in out Set
; Source
: Set
);
221 -- If Target is busy, then Program_Error is raised. Otherwise, the elements
222 -- in Target equivalent to elements in Source are deleted from Target, and
223 -- the elements in Source not equivalent to elements in Target are inserted
226 function Symmetric_Difference
(Left
, Right
: Set
) return Set
;
227 -- Returns a set comprising the union of the elements from Target having no
228 -- equivalent in Source, and the elements of Source having no equivalent in
231 function "xor" (Left
, Right
: Set
) return Set
renames Symmetric_Difference
;
233 function Overlap
(Left
, Right
: Set
) return Boolean;
234 -- Returns True if Left contains an element equivalent to an element of
237 function Is_Subset
(Subset
: Set
; Of_Set
: Set
) return Boolean;
238 -- Returns True if every element in Subset has an equivalent element in
241 function First
(Container
: Set
) return Cursor
;
242 -- If Container is empty, the function returns No_Element. Otherwise, it
243 -- returns a cursor designating the smallest element.
245 function First_Element
(Container
: Set
) return Element_Type
;
246 -- Equivalent to Element (First (Container))
248 function Last
(Container
: Set
) return Cursor
;
249 -- If Container is empty, the function returns No_Element. Otherwise, it
250 -- returns a cursor designating the largest element.
252 function Last_Element
(Container
: Set
) return Element_Type
;
253 -- Equivalent to Element (Last (Container))
255 function Next
(Position
: Cursor
) return Cursor
;
256 -- If Position equals No_Element or Last (Container), the function returns
257 -- No_Element. Otherwise, it returns a cursor designating the node that
258 -- immediately follows (as per the insertion order) the node designated by
261 procedure Next
(Position
: in out Cursor
);
262 -- Equivalent to Position := Next (Position)
264 function Previous
(Position
: Cursor
) return Cursor
;
265 -- If Position equals No_Element or First (Container), the function returns
266 -- No_Element. Otherwise, it returns a cursor designating the node that
267 -- immediately precedes (as per the insertion order) the node designated by
270 procedure Previous
(Position
: in out Cursor
);
271 -- Equivalent to Position := Previous (Position)
273 function Find
(Container
: Set
; Item
: Element_Type
) return Cursor
;
274 -- Returns a cursor designating the first element in Container equivalent
275 -- to Item. If there is no equivalent element, it returns No_Element.
277 function Floor
(Container
: Set
; Item
: Element_Type
) return Cursor
;
278 -- If Container is empty, the function returns No_Element. If Item is
279 -- equivalent to elements in Container, it returns a cursor designating the
280 -- first equivalent element. Otherwise, it returns a cursor designating the
281 -- largest element less than Item, or No_Element if all elements are
282 -- greater than Item.
284 function Ceiling
(Container
: Set
; Item
: Element_Type
) return Cursor
;
285 -- If Container is empty, the function returns No_Element. If Item is
286 -- equivalent to elements of Container, it returns a cursor designating the
287 -- last equivalent element. Otherwise, it returns a cursor designating the
288 -- smallest element greater than Item, or No_Element if all elements are
291 function Contains
(Container
: Set
; Item
: Element_Type
) return Boolean;
292 -- Equivalent to Container.Find (Item) /= No_Element
294 function Has_Element
(Position
: Cursor
) return Boolean;
295 -- Equivalent to Position /= No_Element
297 function "<" (Left
, Right
: Cursor
) return Boolean;
298 -- Equivalent to Element (Left) < Element (Right)
300 function ">" (Left
, Right
: Cursor
) return Boolean;
301 -- Equivalent to Element (Right) < Element (Left)
303 function "<" (Left
: Cursor
; Right
: Element_Type
) return Boolean;
304 -- Equivalent to Element (Left) < Right
306 function ">" (Left
: Cursor
; Right
: Element_Type
) return Boolean;
307 -- Equivalent to Right < Element (Left)
309 function "<" (Left
: Element_Type
; Right
: Cursor
) return Boolean;
310 -- Equivalent to Left < Element (Right)
312 function ">" (Left
: Element_Type
; Right
: Cursor
) return Boolean;
313 -- Equivalent to Element (Right) < Left
317 Process
: not null access procedure (Position
: Cursor
));
318 -- Calls Process with a cursor designating each element of Container, in
319 -- order from Container.First to Container.Last.
321 procedure Reverse_Iterate
323 Process
: not null access procedure (Position
: Cursor
));
324 -- Calls Process with a cursor designating each element of Container, in
325 -- order from Container.Last to Container.First.
330 Process
: not null access procedure (Position
: Cursor
));
331 -- Call Process with a cursor designating each element equivalent to Item,
332 -- in order from Container.Floor (Item) to Container.Ceiling (Item).
334 procedure Reverse_Iterate
337 Process
: not null access procedure (Position
: Cursor
));
338 -- Call Process with a cursor designating each element equivalent to Item,
339 -- in order from Container.Ceiling (Item) to Container.Floor (Item).
342 type Key_Type
(<>) is private;
344 with function Key
(Element
: Element_Type
) return Key_Type
;
346 with function "<" (Left
, Right
: Key_Type
) return Boolean is <>;
348 package Generic_Keys
is
350 function Equivalent_Keys
(Left
, Right
: Key_Type
) return Boolean;
351 -- Returns False if Left is less than Right, or Right is less than Left;
352 -- otherwise, it returns True.
354 function Key
(Position
: Cursor
) return Key_Type
;
355 -- Equivalent to Key (Element (Position))
357 function Element
(Container
: Set
; Key
: Key_Type
) return Element_Type
;
358 -- Equivalent to Element (Find (Container, Key))
360 procedure Exclude
(Container
: in out Set
; Key
: Key_Type
);
361 -- Deletes from Container any elements whose key is equivalent to Key
363 procedure Delete
(Container
: in out Set
; Key
: Key_Type
);
364 -- Deletes from Container any elements whose key is equivalent to
365 -- Key. If there are no such elements, then it raises Constraint_Error.
367 function Find
(Container
: Set
; Key
: Key_Type
) return Cursor
;
368 -- Returns a cursor designating the first element in Container whose key
369 -- is equivalent to Key. If there is no equivalent element, it returns
372 function Floor
(Container
: Set
; Key
: Key_Type
) return Cursor
;
373 -- If Container is empty, the function returns No_Element. If Item is
374 -- equivalent to the keys of elements in Container, it returns a cursor
375 -- designating the first such element. Otherwise, it returns a cursor
376 -- designating the largest element whose key is less than Item, or
377 -- No_Element if all keys are greater than Item.
379 function Ceiling
(Container
: Set
; Key
: Key_Type
) return Cursor
;
380 -- If Container is empty, the function returns No_Element. If Item is
381 -- equivalent to the keys of elements of Container, it returns a cursor
382 -- designating the last such element. Otherwise, it returns a cursor
383 -- designating the smallest element whose key is greater than Item, or
384 -- No_Element if all keys are less than Item.
386 function Contains
(Container
: Set
; Key
: Key_Type
) return Boolean;
387 -- Equivalent to Find (Container, Key) /= No_Element
389 procedure Update_Element
-- Update_Element_Preserving_Key ???
390 (Container
: in out Set
;
392 Process
: not null access
393 procedure (Element
: in out Element_Type
));
394 -- If Position equals No_Element, then Constraint_Error is raised. If
395 -- Position is associated with a set object different from Container,
396 -- then Program_Error is raised. Otherwise, it makes a copy of the key
397 -- of the element designated by Position, and then calls Process with
398 -- the element as the parameter. Update_Element then compares the key
399 -- value obtained before calling Process to the key value obtained from
400 -- the element after calling Process. If the keys are equivalent then
401 -- the operation terminates. If Container is busy (cursor tampering has
402 -- been attempted), then Program_Error is raised. Otherwise, the node
403 -- is moved to its new position (in canonical order).
408 Process
: not null access procedure (Position
: Cursor
));
409 -- Call Process with a cursor designating each element equivalent to
410 -- Key, in order from Floor (Container, Key) to
411 -- Ceiling (Container, Key).
413 procedure Reverse_Iterate
416 Process
: not null access procedure (Position
: Cursor
));
417 -- Call Process with a cursor designating each element equivalent to
418 -- Key, in order from Ceiling (Container, Key) to
419 -- Floor (Container, Key).
425 pragma Inline
(Next
);
426 pragma Inline
(Previous
);
429 type Node_Access
is access Node_Type
;
431 type Node_Type
is limited record
432 Parent
: Node_Access
;
435 Color
: Red_Black_Trees
.Color_Type
:= Red_Black_Trees
.Red
;
436 Element
: Element_Type
;
439 package Tree_Types
is new Red_Black_Trees
.Generic_Tree_Types
443 type Set
is new Ada
.Finalization
.Controlled
with record
444 Tree
: Tree_Types
.Tree_Type
;
448 procedure Adjust
(Container
: in out Set
);
451 procedure Finalize
(Container
: in out Set
) renames Clear
;
455 use Ada
.Finalization
;
458 type Set_Access
is access all Set
;
459 for Set_Access
'Storage_Size use 0;
461 type Cursor
is record
462 Container
: Set_Access
;
467 (Stream
: not null access Root_Stream_Type
'Class;
470 for Cursor
'Write use Write
;
473 (Stream
: not null access Root_Stream_Type
'Class;
476 for Cursor
'Read use Read
;
478 No_Element
: constant Cursor
:= Cursor
'(null, null);
481 (Stream : not null access Root_Stream_Type'Class;
484 for Set'Write use Write;
487 (Stream : not null access Root_Stream_Type'Class;
488 Container : out Set);
490 for Set'Read use Read;
492 Empty_Set : constant Set :=
493 (Controlled with Tree => (First => null,
500 end Ada.Containers.Ordered_Multisets;