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