File : a-coormu.ads
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT LIBRARY COMPONENTS --
4 -- --
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 --
6 -- --
7 -- S p e c --
8 -- --
9 -- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
10 -- --
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. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
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 -- --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
29
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.
33
34 private with Ada.Containers.Red_Black_Trees;
35 private with Ada.Finalization;
36 private with Ada.Streams;
37 with Ada.Iterator_Interfaces;
38
39 generic
40 type Element_Type is private;
41
42 with function "<" (Left, Right : Element_Type) return Boolean is <>;
43 with function "=" (Left, Right : Element_Type) return Boolean is <>;
44
45 package Ada.Containers.Ordered_Multisets is
46 pragma Annotate (CodePeer, Skip_Analysis);
47 pragma Preelaborate;
48 pragma Remote_Types;
49
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.
53
54 type Set is tagged private
55 with Constant_Indexing => Constant_Reference,
56 Default_Iterator => Iterate,
57 Iterator_Element => Element_Type;
58
59 pragma Preelaborable_Initialization (Set);
60
61 type Cursor is private;
62 pragma Preelaborable_Initialization (Cursor);
63
64 Empty_Set : constant Set;
65 -- The default value for set objects declared without an explicit
66 -- initialization expression.
67
68 No_Element : constant Cursor;
69 -- The default value for cursor objects declared without an explicit
70 -- initialization expression.
71
72 function Has_Element (Position : Cursor) return Boolean;
73 -- Equivalent to Position /= No_Element
74
75 package Set_Iterator_Interfaces is new
76 Ada.Iterator_Interfaces (Cursor, Has_Element);
77
78 function "=" (Left, Right : Set) return Boolean;
79 -- If Left denotes the same set object as Right, then equality returns
80 -- True. If the length of Left is different from the length of Right, then
81 -- it returns False. Otherwise, set equality iterates over Left and Right,
82 -- comparing the element of Left to the element of Right using the equality
83 -- operator for elements. If the elements compare False, then the iteration
84 -- terminates and set equality returns False. Otherwise, if all elements
85 -- compare True, then set equality returns True.
86
87 function Equivalent_Sets (Left, Right : Set) return Boolean;
88 -- Similar to set equality, but with the difference that elements are
89 -- compared for equivalence instead of equality.
90
91 function To_Set (New_Item : Element_Type) return Set;
92 -- Constructs a set object with New_Item as its single element
93
94 function Length (Container : Set) return Count_Type;
95 -- Returns the total number of elements in Container
96
97 function Is_Empty (Container : Set) return Boolean;
98 -- Returns True if Container.Length is 0
99
100 procedure Clear (Container : in out Set);
101 -- Deletes all elements from Container
102
103 function Element (Position : Cursor) return Element_Type;
104 -- If Position equals No_Element, then Constraint_Error is raised.
105 -- Otherwise, function Element returns the element designed by Position.
106
107 procedure Replace_Element
108 (Container : in out Set;
109 Position : Cursor;
110 New_Item : Element_Type);
111 -- If Position equals No_Element, then Constraint_Error is raised. If
112 -- Position is associated with a set different from Container, then
113 -- Program_Error is raised. If New_Item is equivalent to the element
114 -- designated by Position, then if Container is locked (element tampering
115 -- has been attempted), Program_Error is raised; otherwise, the element
116 -- designated by Position is assigned the value of New_Item. If New_Item is
117 -- not equivalent to the element designated by Position, then if the
118 -- container is busy (cursor tampering has been attempted), Program_Error
119 -- is raised; otherwise, the element designed by Position is assigned the
120 -- value of New_Item, and the node is moved to its new position (in
121 -- canonical insertion order).
122
123 procedure Query_Element
124 (Position : Cursor;
125 Process : not null access procedure (Element : Element_Type));
126 -- If Position equals No_Element, then Constraint_Error is
127 -- raised. Otherwise, it calls Process with the element designated by
128 -- Position as the parameter. This call locks the container, so attempts to
129 -- change the value of the element while Process is executing (to "tamper
130 -- with elements") will raise Program_Error.
131
132 type Constant_Reference_Type
133 (Element : not null access constant Element_Type) is private
134 with Implicit_Dereference => Element;
135
136 function Constant_Reference
137 (Container : aliased Set;
138 Position : Cursor) return Constant_Reference_Type;
139 pragma Inline (Constant_Reference);
140
141 procedure Assign (Target : in out Set; Source : Set);
142
143 function Copy (Source : Set) return Set;
144
145 procedure Move (Target : in out Set; Source : in out Set);
146 -- If Target denotes the same object as Source, the operation does
147 -- nothing. If either Target or Source is busy (cursor tampering is
148 -- attempted), then it raises Program_Error. Otherwise, Target is cleared,
149 -- and the nodes from Source are moved (not copied) to Target (so Source
150 -- becomes empty).
151
152 procedure Insert
153 (Container : in out Set;
154 New_Item : Element_Type;
155 Position : out Cursor);
156 -- Insert adds New_Item to Container, and returns cursor Position
157 -- designating the newly inserted node. The node is inserted after any
158 -- existing elements less than or equivalent to New_Item (and before any
159 -- elements greater than New_Item). Note that the issue of where the new
160 -- node is inserted relative to equivalent elements does not arise for
161 -- unique-key containers, since in that case the insertion would simply
162 -- fail. For a multiple-key container (the case here), insertion always
163 -- succeeds, and is defined such that the new item is positioned after any
164 -- equivalent elements already in the container.
165
166 procedure Insert
167 (Container : in out Set;
168 New_Item : Element_Type);
169 -- Inserts New_Item in Container, but does not return a cursor designating
170 -- the newly-inserted node.
171
172 -- TODO: include Replace too???
173 --
174 -- procedure Replace
175 -- (Container : in out Set;
176 -- New_Item : Element_Type);
177
178 procedure Exclude
179 (Container : in out Set;
180 Item : Element_Type);
181 -- Deletes from Container all of the elements equivalent to Item
182
183 procedure Delete
184 (Container : in out Set;
185 Item : Element_Type);
186 -- Deletes from Container all of the elements equivalent to Item. If there
187 -- are no elements equivalent to Item, then it raises Constraint_Error.
188
189 procedure Delete
190 (Container : in out Set;
191 Position : in out Cursor);
192 -- If Position equals No_Element, then Constraint_Error is raised. If
193 -- Position is associated with a set different from Container, then
194 -- Program_Error is raised. Otherwise, the node designated by Position is
195 -- removed from Container, and Position is set to No_Element.
196
197 procedure Delete_First (Container : in out Set);
198 -- Removes the first node from Container
199
200 procedure Delete_Last (Container : in out Set);
201 -- Removes the last node from Container
202
203 procedure Union (Target : in out Set; Source : Set);
204 -- If Target is busy (cursor tampering is attempted), the Program_Error is
205 -- raised. Otherwise, it inserts each element of Source into
206 -- Target. Elements are inserted in the canonical order for multisets, such
207 -- that the elements from Source are inserted after equivalent elements
208 -- already in Target.
209
210 function Union (Left, Right : Set) return Set;
211 -- Returns a set comprising the all elements from Left and all of the
212 -- elements from Right. The elements from Right follow the equivalent
213 -- elements from Left.
214
215 function "or" (Left, Right : Set) return Set renames Union;
216
217 procedure Intersection (Target : in out Set; Source : Set);
218 -- If Target denotes the same object as Source, the operation does
219 -- nothing. If Target is busy (cursor tampering is attempted),
220 -- Program_Error is raised. Otherwise, the elements in Target having no
221 -- equivalent element in Source are deleted from Target.
222
223 function Intersection (Left, Right : Set) return Set;
224 -- If Left denotes the same object as Right, then the function returns a
225 -- copy of Left. Otherwise, it returns a set comprising the equivalent
226 -- elements from both Left and Right. Items are inserted in the result set
227 -- in canonical order, such that the elements from Left precede the
228 -- equivalent elements from Right.
229
230 function "and" (Left, Right : Set) return Set renames Intersection;
231
232 procedure Difference (Target : in out Set; Source : Set);
233 -- If Target is busy (cursor tampering is attempted), then Program_Error is
234 -- raised. Otherwise, the elements in Target that are equivalent to
235 -- elements in Source are deleted from Target.
236
237 function Difference (Left, Right : Set) return Set;
238 -- Returns a set comprising the elements from Left that have no equivalent
239 -- element in Right.
240
241 function "-" (Left, Right : Set) return Set renames Difference;
242
243 procedure Symmetric_Difference (Target : in out Set; Source : Set);
244 -- If Target is busy, then Program_Error is raised. Otherwise, the elements
245 -- in Target equivalent to elements in Source are deleted from Target, and
246 -- the elements in Source not equivalent to elements in Target are inserted
247 -- into Target.
248
249 function Symmetric_Difference (Left, Right : Set) return Set;
250 -- Returns a set comprising the union of the elements from Target having no
251 -- equivalent in Source, and the elements of Source having no equivalent in
252 -- Target.
253
254 function "xor" (Left, Right : Set) return Set renames Symmetric_Difference;
255
256 function Overlap (Left, Right : Set) return Boolean;
257 -- Returns True if Left contains an element equivalent to an element of
258 -- Right.
259
260 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean;
261 -- Returns True if every element in Subset has an equivalent element in
262 -- Of_Set.
263
264 function First (Container : Set) return Cursor;
265 -- If Container is empty, the function returns No_Element. Otherwise, it
266 -- returns a cursor designating the smallest element.
267
268 function First_Element (Container : Set) return Element_Type;
269 -- Equivalent to Element (First (Container))
270
271 function Last (Container : Set) return Cursor;
272 -- If Container is empty, the function returns No_Element. Otherwise, it
273 -- returns a cursor designating the largest element.
274
275 function Last_Element (Container : Set) return Element_Type;
276 -- Equivalent to Element (Last (Container))
277
278 function Next (Position : Cursor) return Cursor;
279 -- If Position equals No_Element or Last (Container), the function returns
280 -- No_Element. Otherwise, it returns a cursor designating the node that
281 -- immediately follows (as per the insertion order) the node designated by
282 -- Position.
283
284 procedure Next (Position : in out Cursor);
285 -- Equivalent to Position := Next (Position)
286
287 function Previous (Position : Cursor) return Cursor;
288 -- If Position equals No_Element or First (Container), the function returns
289 -- No_Element. Otherwise, it returns a cursor designating the node that
290 -- immediately precedes (as per the insertion order) the node designated by
291 -- Position.
292
293 procedure Previous (Position : in out Cursor);
294 -- Equivalent to Position := Previous (Position)
295
296 function Find (Container : Set; Item : Element_Type) return Cursor;
297 -- Returns a cursor designating the first element in Container equivalent
298 -- to Item. If there is no equivalent element, it returns No_Element.
299
300 function Floor (Container : Set; Item : Element_Type) return Cursor;
301 -- If Container is empty, the function returns No_Element. If Item is
302 -- equivalent to elements in Container, it returns a cursor designating the
303 -- first equivalent element. Otherwise, it returns a cursor designating the
304 -- largest element less than Item, or No_Element if all elements are
305 -- greater than Item.
306
307 function Ceiling (Container : Set; Item : Element_Type) return Cursor;
308 -- If Container is empty, the function returns No_Element. If Item is
309 -- equivalent to elements of Container, it returns a cursor designating the
310 -- last equivalent element. Otherwise, it returns a cursor designating the
311 -- smallest element greater than Item, or No_Element if all elements are
312 -- less than Item.
313
314 function Contains (Container : Set; Item : Element_Type) return Boolean;
315 -- Equivalent to Container.Find (Item) /= No_Element
316
317 function "<" (Left, Right : Cursor) return Boolean;
318 -- Equivalent to Element (Left) < Element (Right)
319
320 function ">" (Left, Right : Cursor) return Boolean;
321 -- Equivalent to Element (Right) < Element (Left)
322
323 function "<" (Left : Cursor; Right : Element_Type) return Boolean;
324 -- Equivalent to Element (Left) < Right
325
326 function ">" (Left : Cursor; Right : Element_Type) return Boolean;
327 -- Equivalent to Right < Element (Left)
328
329 function "<" (Left : Element_Type; Right : Cursor) return Boolean;
330 -- Equivalent to Left < Element (Right)
331
332 function ">" (Left : Element_Type; Right : Cursor) return Boolean;
333 -- Equivalent to Element (Right) < Left
334
335 procedure Iterate
336 (Container : Set;
337 Process : not null access procedure (Position : Cursor));
338 -- Calls Process with a cursor designating each element of Container, in
339 -- order from Container.First to Container.Last.
340
341 procedure Reverse_Iterate
342 (Container : Set;
343 Process : not null access procedure (Position : Cursor));
344 -- Calls Process with a cursor designating each element of Container, in
345 -- order from Container.Last to Container.First.
346
347 procedure Iterate
348 (Container : Set;
349 Item : Element_Type;
350 Process : not null access procedure (Position : Cursor));
351 -- Call Process with a cursor designating each element equivalent to Item,
352 -- in order from Container.Floor (Item) to Container.Ceiling (Item).
353
354 procedure Reverse_Iterate
355 (Container : Set;
356 Item : Element_Type;
357 Process : not null access procedure (Position : Cursor));
358 -- Call Process with a cursor designating each element equivalent to Item,
359 -- in order from Container.Ceiling (Item) to Container.Floor (Item).
360
361 function Iterate
362 (Container : Set)
363 return Set_Iterator_Interfaces.Reversible_Iterator'class;
364
365 function Iterate
366 (Container : Set;
367 Start : Cursor)
368 return Set_Iterator_Interfaces.Reversible_Iterator'class;
369
370 generic
371 type Key_Type (<>) is private;
372
373 with function Key (Element : Element_Type) return Key_Type;
374
375 with function "<" (Left, Right : Key_Type) return Boolean is <>;
376
377 package Generic_Keys is
378
379 function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
380 -- Returns False if Left is less than Right, or Right is less than Left;
381 -- otherwise, it returns True.
382
383 function Key (Position : Cursor) return Key_Type;
384 -- Equivalent to Key (Element (Position))
385
386 function Element (Container : Set; Key : Key_Type) return Element_Type;
387 -- Equivalent to Element (Find (Container, Key))
388
389 procedure Exclude (Container : in out Set; Key : Key_Type);
390 -- Deletes from Container any elements whose key is equivalent to Key
391
392 procedure Delete (Container : in out Set; Key : Key_Type);
393 -- Deletes from Container any elements whose key is equivalent to
394 -- Key. If there are no such elements, then it raises Constraint_Error.
395
396 function Find (Container : Set; Key : Key_Type) return Cursor;
397 -- Returns a cursor designating the first element in Container whose key
398 -- is equivalent to Key. If there is no equivalent element, it returns
399 -- No_Element.
400
401 function Floor (Container : Set; Key : Key_Type) return Cursor;
402 -- If Container is empty, the function returns No_Element. If Item is
403 -- equivalent to the keys of elements in Container, it returns a cursor
404 -- designating the first such element. Otherwise, it returns a cursor
405 -- designating the largest element whose key is less than Item, or
406 -- No_Element if all keys are greater than Item.
407
408 function Ceiling (Container : Set; Key : Key_Type) return Cursor;
409 -- If Container is empty, the function returns No_Element. If Item is
410 -- equivalent to the keys of elements of Container, it returns a cursor
411 -- designating the last such element. Otherwise, it returns a cursor
412 -- designating the smallest element whose key is greater than Item, or
413 -- No_Element if all keys are less than Item.
414
415 function Contains (Container : Set; Key : Key_Type) return Boolean;
416 -- Equivalent to Find (Container, Key) /= No_Element
417
418 procedure Update_Element -- Update_Element_Preserving_Key ???
419 (Container : in out Set;
420 Position : Cursor;
421 Process : not null access
422 procedure (Element : in out Element_Type));
423 -- If Position equals No_Element, then Constraint_Error is raised. If
424 -- Position is associated with a set object different from Container,
425 -- then Program_Error is raised. Otherwise, it makes a copy of the key
426 -- of the element designated by Position, and then calls Process with
427 -- the element as the parameter. Update_Element then compares the key
428 -- value obtained before calling Process to the key value obtained from
429 -- the element after calling Process. If the keys are equivalent then
430 -- the operation terminates. If Container is busy (cursor tampering has
431 -- been attempted), then Program_Error is raised. Otherwise, the node
432 -- is moved to its new position (in canonical order).
433
434 procedure Iterate
435 (Container : Set;
436 Key : Key_Type;
437 Process : not null access procedure (Position : Cursor));
438 -- Call Process with a cursor designating each element equivalent to
439 -- Key, in order from Floor (Container, Key) to
440 -- Ceiling (Container, Key).
441
442 procedure Reverse_Iterate
443 (Container : Set;
444 Key : Key_Type;
445 Process : not null access procedure (Position : Cursor));
446 -- Call Process with a cursor designating each element equivalent to
447 -- Key, in order from Ceiling (Container, Key) to
448 -- Floor (Container, Key).
449
450 end Generic_Keys;
451
452 private
453
454 pragma Inline (Next);
455 pragma Inline (Previous);
456
457 type Node_Type;
458 type Node_Access is access Node_Type;
459
460 type Node_Type is limited record
461 Parent : Node_Access;
462 Left : Node_Access;
463 Right : Node_Access;
464 Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red;
465 Element : Element_Type;
466 end record;
467
468 package Tree_Types is
469 new Red_Black_Trees.Generic_Tree_Types (Node_Type, Node_Access);
470
471 type Set is new Ada.Finalization.Controlled with record
472 Tree : Tree_Types.Tree_Type;
473 end record;
474
475 overriding procedure Adjust (Container : in out Set);
476
477 overriding procedure Finalize (Container : in out Set) renames Clear;
478
479 use Red_Black_Trees;
480 use Tree_Types, Tree_Types.Implementation;
481 use Ada.Finalization;
482 use Ada.Streams;
483
484 type Set_Access is access all Set;
485 for Set_Access'Storage_Size use 0;
486
487 -- In all predefined libraries the following type is controlled, for proper
488 -- management of tampering checks. For performance reason we omit this
489 -- machinery for multisets, which are used in a number of our tools.
490
491 type Reference_Control_Type is record
492 Container : Set_Access;
493 end record;
494
495 type Constant_Reference_Type
496 (Element : not null access constant Element_Type) is record
497 Control : Reference_Control_Type :=
498 raise Program_Error with "uninitialized reference";
499 -- The RM says, "The default initialization of an object of
500 -- type Constant_Reference_Type or Reference_Type propagates
501 -- Program_Error."
502 end record;
503
504 type Cursor is record
505 Container : Set_Access;
506 Node : Node_Access;
507 end record;
508
509 procedure Write
510 (Stream : not null access Root_Stream_Type'Class;
511 Item : Cursor);
512
513 for Cursor'Write use Write;
514
515 procedure Read
516 (Stream : not null access Root_Stream_Type'Class;
517 Item : out Cursor);
518
519 for Cursor'Read use Read;
520
521 No_Element : constant Cursor := Cursor'(null, null);
522
523 procedure Write
524 (Stream : not null access Root_Stream_Type'Class;
525 Container : Set);
526
527 for Set'Write use Write;
528
529 procedure Read
530 (Stream : not null access Root_Stream_Type'Class;
531 Container : out Set);
532
533 for Set'Read use Read;
534
535 procedure Read
536 (Stream : not null access Root_Stream_Type'Class;
537 Item : out Constant_Reference_Type);
538
539 for Constant_Reference_Type'Read use Read;
540
541 procedure Write
542 (Stream : not null access Root_Stream_Type'Class;
543 Item : Constant_Reference_Type);
544
545 for Constant_Reference_Type'Write use Write;
546
547 Empty_Set : constant Set := (Controlled with others => <>);
548
549 type Iterator is new Limited_Controlled and
550 Set_Iterator_Interfaces.Reversible_Iterator with
551 record
552 Container : Set_Access;
553 Node : Node_Access;
554 end record
555 with Disable_Controlled => not T_Check;
556
557 overriding procedure Finalize (Object : in out Iterator);
558
559 overriding function First (Object : Iterator) return Cursor;
560 overriding function Last (Object : Iterator) return Cursor;
561
562 overriding function Next
563 (Object : Iterator;
564 Position : Cursor) return Cursor;
565
566 overriding function Previous
567 (Object : Iterator;
568 Position : Cursor) return Cursor;
569
570 end Ada.Containers.Ordered_Multisets;