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