1------------------------------------------------------------------------------ 2-- -- 3-- GNAT LIBRARY COMPONENTS -- 4-- -- 5-- ADA.CONTAINERS.INDEFINITE_ORDERED_MULTISETS -- 6-- -- 7-- S p e c -- 8-- -- 9-- Copyright (C) 2004-2021, 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; 38private with Ada.Strings.Text_Buffers; 39with Ada.Iterator_Interfaces; 40 41generic 42 type Element_Type (<>) is private; 43 44 with function "<" (Left, Right : Element_Type) return Boolean is <>; 45 with function "=" (Left, Right : Element_Type) return Boolean is <>; 46 47package Ada.Containers.Indefinite_Ordered_Multisets with 48 SPARK_Mode => Off 49is 50 pragma Annotate (CodePeer, Skip_Analysis); 51 pragma Preelaborate; 52 pragma Remote_Types; 53 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. 57 58 type Set is tagged private 59 with Constant_Indexing => Constant_Reference, 60 Default_Iterator => Iterate, 61 Iterator_Element => Element_Type; 62 63 pragma Preelaborable_Initialization (Set); 64 65 type Cursor is private; 66 pragma Preelaborable_Initialization (Cursor); 67 68 Empty_Set : constant Set; 69 -- The default value for set objects declared without an explicit 70 -- initialization expression. 71 72 No_Element : constant Cursor; 73 -- The default value for cursor objects declared without an explicit 74 -- initialization expression. 75 76 function Has_Element (Position : Cursor) return Boolean; 77 -- Equivalent to Position /= No_Element 78 79 package Set_Iterator_Interfaces is new 80 Ada.Iterator_Interfaces (Cursor, Has_Element); 81 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. 90 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. 94 95 function To_Set (New_Item : Element_Type) return Set; 96 -- Constructs a set object with New_Item as its single element 97 98 function Length (Container : Set) return Count_Type; 99 -- Returns the total number of elements in Container 100 101 function Is_Empty (Container : Set) return Boolean; 102 -- Returns True if Container.Length is 0 103 104 procedure Clear (Container : in out Set); 105 -- Deletes all elements from Container 106 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. 110 111 procedure Replace_Element 112 (Container : in out Set; 113 Position : Cursor; 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). 126 127 procedure Query_Element 128 (Position : Cursor; 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. 135 136 type Constant_Reference_Type 137 (Element : not null access constant Element_Type) is private 138 with Implicit_Dereference => Element; 139 140 function Constant_Reference 141 (Container : aliased Set; 142 Position : Cursor) return Constant_Reference_Type; 143 pragma Inline (Constant_Reference); 144 145 procedure Assign (Target : in out Set; Source : Set); 146 147 function Copy (Source : Set) return Set; 148 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 154 -- becomes empty). 155 156 procedure Insert 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. 169 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. 173 174-- TODO: include Replace too??? 175-- 176-- procedure Replace 177-- (Container : in out Set; 178-- New_Item : Element_Type); 179 180 procedure Exclude (Container : in out Set; Item : Element_Type); 181 -- Deletes from Container all of the elements equivalent to Item 182 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. 186 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. 192 193 procedure Delete_First (Container : in out Set); 194 -- Removes the first node from Container 195 196 procedure Delete_Last (Container : in out Set); 197 -- Removes the last node from Container 198 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 204 -- in Target. 205 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. 210 211 function "or" (Left, Right : Set) return Set renames Union; 212 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. 218 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. 225 226 function "and" (Left, Right : Set) return Set renames Intersection; 227 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. 232 233 function Difference (Left, Right : Set) return Set; 234 -- Returns a set comprising the elements from Left that have no equivalent 235 -- element in Right. 236 237 function "-" (Left, Right : Set) return Set renames Difference; 238 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 243 -- into Target. 244 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 248 -- Target. 249 250 function "xor" (Left, Right : Set) return Set renames Symmetric_Difference; 251 252 function Overlap (Left, Right : Set) return Boolean; 253 -- Returns True if Left contains an element equivalent to an element of 254 -- Right. 255 256 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; 257 -- Returns True if every element in Subset has an equivalent element in 258 -- Of_Set. 259 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. 263 264 function First_Element (Container : Set) return Element_Type; 265 -- Equivalent to Element (First (Container)) 266 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. 270 271 function Last_Element (Container : Set) return Element_Type; 272 -- Equivalent to Element (Last (Container)) 273 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 278 -- Position. 279 280 procedure Next (Position : in out Cursor); 281 -- Equivalent to Position := Next (Position) 282 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 287 -- Position. 288 289 procedure Previous (Position : in out Cursor); 290 -- Equivalent to Position := Previous (Position) 291 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. 295 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. 302 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 308 -- less than Item. 309 310 function Contains (Container : Set; Item : Element_Type) return Boolean; 311 -- Equivalent to Container.Find (Item) /= No_Element 312 313 function "<" (Left, Right : Cursor) return Boolean; 314 -- Equivalent to Element (Left) < Element (Right) 315 316 function ">" (Left, Right : Cursor) return Boolean; 317 -- Equivalent to Element (Right) < Element (Left) 318 319 function "<" (Left : Cursor; Right : Element_Type) return Boolean; 320 -- Equivalent to Element (Left) < Right 321 322 function ">" (Left : Cursor; Right : Element_Type) return Boolean; 323 -- Equivalent to Right < Element (Left) 324 325 function "<" (Left : Element_Type; Right : Cursor) return Boolean; 326 -- Equivalent to Left < Element (Right) 327 328 function ">" (Left : Element_Type; Right : Cursor) return Boolean; 329 -- Equivalent to Element (Right) < Left 330 331 procedure Iterate 332 (Container : Set; 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. 336 337 procedure Reverse_Iterate 338 (Container : Set; 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. 342 343 procedure Iterate 344 (Container : Set; 345 Item : Element_Type; 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). 349 350 procedure Reverse_Iterate 351 (Container : Set; 352 Item : Element_Type; 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). 356 357 function Iterate 358 (Container : Set) 359 return Set_Iterator_Interfaces.Reversible_Iterator'class; 360 361 function Iterate 362 (Container : Set; 363 Start : Cursor) 364 return Set_Iterator_Interfaces.Reversible_Iterator'class; 365 366 generic 367 type Key_Type (<>) is private; 368 369 with function Key (Element : Element_Type) return Key_Type; 370 371 with function "<" (Left, Right : Key_Type) return Boolean is <>; 372 373 package Generic_Keys is 374 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. 378 379 function Key (Position : Cursor) return Key_Type; 380 -- Equivalent to Key (Element (Position)) 381 382 function Element (Container : Set; Key : Key_Type) return Element_Type; 383 -- Equivalent to Element (Find (Container, Key)) 384 385 procedure Exclude (Container : in out Set; Key : Key_Type); 386 -- Deletes from Container any elements whose key is equivalent to Key 387 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. 391 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 395 -- No_Element. 396 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. 403 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. 410 411 function Contains (Container : Set; Key : Key_Type) return Boolean; 412 -- Equivalent to Find (Container, Key) /= No_Element 413 414 procedure Update_Element -- Update_Element_Preserving_Key ??? 415 (Container : in out Set; 416 Position : Cursor; 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). 429 430 procedure Iterate 431 (Container : Set; 432 Key : Key_Type; 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). 437 438 procedure Reverse_Iterate 439 (Container : Set; 440 Key : Key_Type; 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). 445 446 end Generic_Keys; 447 448private 449 450 pragma Inline (Next); 451 pragma Inline (Previous); 452 453 type Node_Type; 454 type Node_Access is access Node_Type; 455 456 type Element_Access is access Element_Type; 457 458 type Node_Type is limited record 459 Parent : Node_Access; 460 Left : Node_Access; 461 Right : Node_Access; 462 Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red; 463 Element : Element_Access; 464 end record; 465 466 package Tree_Types is new Red_Black_Trees.Generic_Tree_Types 467 (Node_Type, 468 Node_Access); 469 470 type Set is new Ada.Finalization.Controlled with record 471 Tree : Tree_Types.Tree_Type; 472 end record with Put_Image => Put_Image; 473 474 procedure Put_Image 475 (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set); 476 477 overriding procedure Adjust (Container : in out Set); 478 479 overriding procedure Finalize (Container : in out Set) renames Clear; 480 481 use Red_Black_Trees; 482 use Tree_Types, Tree_Types.Implementation; 483 use Ada.Finalization; 484 use Ada.Streams; 485 486 type Set_Access is access all Set; 487 for Set_Access'Storage_Size use 0; 488 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. 492 493 type Reference_Control_Type is record 494 Container : Set_Access; 495 end record; 496 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 503 -- Program_Error." 504 end record; 505 506 type Cursor is record 507 Container : Set_Access; 508 Node : Node_Access; 509 end record; 510 511 procedure Write 512 (Stream : not null access Root_Stream_Type'Class; 513 Item : Cursor); 514 515 for Cursor'Write use Write; 516 517 procedure Read 518 (Stream : not null access Root_Stream_Type'Class; 519 Item : out Cursor); 520 521 for Cursor'Read use Read; 522 523 No_Element : constant Cursor := Cursor'(null, null); 524 525 procedure Write 526 (Stream : not null access Root_Stream_Type'Class; 527 Container : Set); 528 529 for Set'Write use Write; 530 531 procedure Read 532 (Stream : not null access Root_Stream_Type'Class; 533 Container : out Set); 534 535 for Set'Read use Read; 536 537 procedure Read 538 (Stream : not null access Root_Stream_Type'Class; 539 Item : out Constant_Reference_Type); 540 541 for Constant_Reference_Type'Read use Read; 542 543 procedure Write 544 (Stream : not null access Root_Stream_Type'Class; 545 Item : Constant_Reference_Type); 546 547 for Constant_Reference_Type'Write use Write; 548 549 Empty_Set : constant Set := (Controlled with others => <>); 550 551 type Iterator is new Limited_Controlled and 552 Set_Iterator_Interfaces.Reversible_Iterator with 553 record 554 Container : Set_Access; 555 Node : Node_Access; 556 end record 557 with Disable_Controlled => not T_Check; 558 559 overriding procedure Finalize (Object : in out Iterator); 560 561 overriding function First (Object : Iterator) return Cursor; 562 overriding function Last (Object : Iterator) return Cursor; 563 564 overriding function Next 565 (Object : Iterator; 566 Position : Cursor) return Cursor; 567 568 overriding function Previous 569 (Object : Iterator; 570 Position : Cursor) return Cursor; 571 572end Ada.Containers.Indefinite_Ordered_Multisets; 573