1------------------------------------------------------------------------------ 2-- -- 3-- GNAT LIBRARY COMPONENTS -- 4-- -- 5-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_OPERATIONS -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2004-2011, 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 references below to "CLR" refer to the following book, from which 31-- several of the algorithms here were adapted: 32-- Introduction to Algorithms 33-- by Thomas H. Cormen, Charles E. Leiserson, Ronald L. Rivest 34-- Publisher: The MIT Press (June 18, 1990) 35-- ISBN: 0262031418 36 37with System; use type System.Address; 38 39package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is 40 41 ----------------------- 42 -- Local Subprograms -- 43 ----------------------- 44 45 procedure Delete_Fixup (Tree : in out Tree_Type'Class; Node : Count_Type); 46 procedure Delete_Swap (Tree : in out Tree_Type'Class; Z, Y : Count_Type); 47 48 procedure Left_Rotate (Tree : in out Tree_Type'Class; X : Count_Type); 49 procedure Right_Rotate (Tree : in out Tree_Type'Class; Y : Count_Type); 50 51 ---------------- 52 -- Clear_Tree -- 53 ---------------- 54 55 procedure Clear_Tree (Tree : in out Tree_Type'Class) is 56 begin 57 if Tree.Busy > 0 then 58 raise Program_Error with 59 "attempt to tamper with cursors (container is busy)"; 60 end if; 61 62 -- The lock status (which monitors "element tampering") always implies 63 -- that the busy status (which monitors "cursor tampering") is set too; 64 -- this is a representation invariant. Thus if the busy bit is not set, 65 -- then the lock bit must not be set either. 66 67 pragma Assert (Tree.Lock = 0); 68 69 Tree.First := 0; 70 Tree.Last := 0; 71 Tree.Root := 0; 72 Tree.Length := 0; 73 Tree.Free := -1; 74 end Clear_Tree; 75 76 ------------------ 77 -- Delete_Fixup -- 78 ------------------ 79 80 procedure Delete_Fixup 81 (Tree : in out Tree_Type'Class; 82 Node : Count_Type) 83 is 84 -- CLR p. 274 85 86 X : Count_Type; 87 W : Count_Type; 88 N : Nodes_Type renames Tree.Nodes; 89 90 begin 91 X := Node; 92 while X /= Tree.Root 93 and then Color (N (X)) = Black 94 loop 95 if X = Left (N (Parent (N (X)))) then 96 W := Right (N (Parent (N (X)))); 97 98 if Color (N (W)) = Red then 99 Set_Color (N (W), Black); 100 Set_Color (N (Parent (N (X))), Red); 101 Left_Rotate (Tree, Parent (N (X))); 102 W := Right (N (Parent (N (X)))); 103 end if; 104 105 if (Left (N (W)) = 0 or else Color (N (Left (N (W)))) = Black) 106 and then 107 (Right (N (W)) = 0 or else Color (N (Right (N (W)))) = Black) 108 then 109 Set_Color (N (W), Red); 110 X := Parent (N (X)); 111 112 else 113 if Right (N (W)) = 0 114 or else Color (N (Right (N (W)))) = Black 115 then 116 -- As a condition for setting the color of the left child to 117 -- black, the left child access value must be non-null. A 118 -- truth table analysis shows that if we arrive here, that 119 -- condition holds, so there's no need for an explicit test. 120 -- The assertion is here to document what we know is true. 121 122 pragma Assert (Left (N (W)) /= 0); 123 Set_Color (N (Left (N (W))), Black); 124 125 Set_Color (N (W), Red); 126 Right_Rotate (Tree, W); 127 W := Right (N (Parent (N (X)))); 128 end if; 129 130 Set_Color (N (W), Color (N (Parent (N (X))))); 131 Set_Color (N (Parent (N (X))), Black); 132 Set_Color (N (Right (N (W))), Black); 133 Left_Rotate (Tree, Parent (N (X))); 134 X := Tree.Root; 135 end if; 136 137 else 138 pragma Assert (X = Right (N (Parent (N (X))))); 139 140 W := Left (N (Parent (N (X)))); 141 142 if Color (N (W)) = Red then 143 Set_Color (N (W), Black); 144 Set_Color (N (Parent (N (X))), Red); 145 Right_Rotate (Tree, Parent (N (X))); 146 W := Left (N (Parent (N (X)))); 147 end if; 148 149 if (Left (N (W)) = 0 or else Color (N (Left (N (W)))) = Black) 150 and then 151 (Right (N (W)) = 0 or else Color (N (Right (N (W)))) = Black) 152 then 153 Set_Color (N (W), Red); 154 X := Parent (N (X)); 155 156 else 157 if Left (N (W)) = 0 158 or else Color (N (Left (N (W)))) = Black 159 then 160 -- As a condition for setting the color of the right child 161 -- to black, the right child access value must be non-null. 162 -- A truth table analysis shows that if we arrive here, that 163 -- condition holds, so there's no need for an explicit test. 164 -- The assertion is here to document what we know is true. 165 166 pragma Assert (Right (N (W)) /= 0); 167 Set_Color (N (Right (N (W))), Black); 168 169 Set_Color (N (W), Red); 170 Left_Rotate (Tree, W); 171 W := Left (N (Parent (N (X)))); 172 end if; 173 174 Set_Color (N (W), Color (N (Parent (N (X))))); 175 Set_Color (N (Parent (N (X))), Black); 176 Set_Color (N (Left (N (W))), Black); 177 Right_Rotate (Tree, Parent (N (X))); 178 X := Tree.Root; 179 end if; 180 end if; 181 end loop; 182 183 Set_Color (N (X), Black); 184 end Delete_Fixup; 185 186 --------------------------- 187 -- Delete_Node_Sans_Free -- 188 --------------------------- 189 190 procedure Delete_Node_Sans_Free 191 (Tree : in out Tree_Type'Class; 192 Node : Count_Type) 193 is 194 -- CLR p. 273 195 196 X, Y : Count_Type; 197 198 Z : constant Count_Type := Node; 199 pragma Assert (Z /= 0); 200 201 N : Nodes_Type renames Tree.Nodes; 202 203 begin 204 if Tree.Busy > 0 then 205 raise Program_Error with 206 "attempt to tamper with cursors (container is busy)"; 207 end if; 208 209 pragma Assert (Tree.Length > 0); 210 pragma Assert (Tree.Root /= 0); 211 pragma Assert (Tree.First /= 0); 212 pragma Assert (Tree.Last /= 0); 213 pragma Assert (Parent (N (Tree.Root)) = 0); 214 215 pragma Assert ((Tree.Length > 1) 216 or else (Tree.First = Tree.Last 217 and then Tree.First = Tree.Root)); 218 219 pragma Assert ((Left (N (Node)) = 0) 220 or else (Parent (N (Left (N (Node)))) = Node)); 221 222 pragma Assert ((Right (N (Node)) = 0) 223 or else (Parent (N (Right (N (Node)))) = Node)); 224 225 pragma Assert (((Parent (N (Node)) = 0) and then (Tree.Root = Node)) 226 or else ((Parent (N (Node)) /= 0) and then 227 ((Left (N (Parent (N (Node)))) = Node) 228 or else 229 (Right (N (Parent (N (Node)))) = Node)))); 230 231 if Left (N (Z)) = 0 then 232 if Right (N (Z)) = 0 then 233 if Z = Tree.First then 234 Tree.First := Parent (N (Z)); 235 end if; 236 237 if Z = Tree.Last then 238 Tree.Last := Parent (N (Z)); 239 end if; 240 241 if Color (N (Z)) = Black then 242 Delete_Fixup (Tree, Z); 243 end if; 244 245 pragma Assert (Left (N (Z)) = 0); 246 pragma Assert (Right (N (Z)) = 0); 247 248 if Z = Tree.Root then 249 pragma Assert (Tree.Length = 1); 250 pragma Assert (Parent (N (Z)) = 0); 251 Tree.Root := 0; 252 elsif Z = Left (N (Parent (N (Z)))) then 253 Set_Left (N (Parent (N (Z))), 0); 254 else 255 pragma Assert (Z = Right (N (Parent (N (Z))))); 256 Set_Right (N (Parent (N (Z))), 0); 257 end if; 258 259 else 260 pragma Assert (Z /= Tree.Last); 261 262 X := Right (N (Z)); 263 264 if Z = Tree.First then 265 Tree.First := Min (Tree, X); 266 end if; 267 268 if Z = Tree.Root then 269 Tree.Root := X; 270 elsif Z = Left (N (Parent (N (Z)))) then 271 Set_Left (N (Parent (N (Z))), X); 272 else 273 pragma Assert (Z = Right (N (Parent (N (Z))))); 274 Set_Right (N (Parent (N (Z))), X); 275 end if; 276 277 Set_Parent (N (X), Parent (N (Z))); 278 279 if Color (N (Z)) = Black then 280 Delete_Fixup (Tree, X); 281 end if; 282 end if; 283 284 elsif Right (N (Z)) = 0 then 285 pragma Assert (Z /= Tree.First); 286 287 X := Left (N (Z)); 288 289 if Z = Tree.Last then 290 Tree.Last := Max (Tree, X); 291 end if; 292 293 if Z = Tree.Root then 294 Tree.Root := X; 295 elsif Z = Left (N (Parent (N (Z)))) then 296 Set_Left (N (Parent (N (Z))), X); 297 else 298 pragma Assert (Z = Right (N (Parent (N (Z))))); 299 Set_Right (N (Parent (N (Z))), X); 300 end if; 301 302 Set_Parent (N (X), Parent (N (Z))); 303 304 if Color (N (Z)) = Black then 305 Delete_Fixup (Tree, X); 306 end if; 307 308 else 309 pragma Assert (Z /= Tree.First); 310 pragma Assert (Z /= Tree.Last); 311 312 Y := Next (Tree, Z); 313 pragma Assert (Left (N (Y)) = 0); 314 315 X := Right (N (Y)); 316 317 if X = 0 then 318 if Y = Left (N (Parent (N (Y)))) then 319 pragma Assert (Parent (N (Y)) /= Z); 320 Delete_Swap (Tree, Z, Y); 321 Set_Left (N (Parent (N (Z))), Z); 322 323 else 324 pragma Assert (Y = Right (N (Parent (N (Y))))); 325 pragma Assert (Parent (N (Y)) = Z); 326 Set_Parent (N (Y), Parent (N (Z))); 327 328 if Z = Tree.Root then 329 Tree.Root := Y; 330 elsif Z = Left (N (Parent (N (Z)))) then 331 Set_Left (N (Parent (N (Z))), Y); 332 else 333 pragma Assert (Z = Right (N (Parent (N (Z))))); 334 Set_Right (N (Parent (N (Z))), Y); 335 end if; 336 337 Set_Left (N (Y), Left (N (Z))); 338 Set_Parent (N (Left (N (Y))), Y); 339 Set_Right (N (Y), Z); 340 341 Set_Parent (N (Z), Y); 342 Set_Left (N (Z), 0); 343 Set_Right (N (Z), 0); 344 345 declare 346 Y_Color : constant Color_Type := Color (N (Y)); 347 begin 348 Set_Color (N (Y), Color (N (Z))); 349 Set_Color (N (Z), Y_Color); 350 end; 351 end if; 352 353 if Color (N (Z)) = Black then 354 Delete_Fixup (Tree, Z); 355 end if; 356 357 pragma Assert (Left (N (Z)) = 0); 358 pragma Assert (Right (N (Z)) = 0); 359 360 if Z = Right (N (Parent (N (Z)))) then 361 Set_Right (N (Parent (N (Z))), 0); 362 else 363 pragma Assert (Z = Left (N (Parent (N (Z))))); 364 Set_Left (N (Parent (N (Z))), 0); 365 end if; 366 367 else 368 if Y = Left (N (Parent (N (Y)))) then 369 pragma Assert (Parent (N (Y)) /= Z); 370 371 Delete_Swap (Tree, Z, Y); 372 373 Set_Left (N (Parent (N (Z))), X); 374 Set_Parent (N (X), Parent (N (Z))); 375 376 else 377 pragma Assert (Y = Right (N (Parent (N (Y))))); 378 pragma Assert (Parent (N (Y)) = Z); 379 380 Set_Parent (N (Y), Parent (N (Z))); 381 382 if Z = Tree.Root then 383 Tree.Root := Y; 384 elsif Z = Left (N (Parent (N (Z)))) then 385 Set_Left (N (Parent (N (Z))), Y); 386 else 387 pragma Assert (Z = Right (N (Parent (N (Z))))); 388 Set_Right (N (Parent (N (Z))), Y); 389 end if; 390 391 Set_Left (N (Y), Left (N (Z))); 392 Set_Parent (N (Left (N (Y))), Y); 393 394 declare 395 Y_Color : constant Color_Type := Color (N (Y)); 396 begin 397 Set_Color (N (Y), Color (N (Z))); 398 Set_Color (N (Z), Y_Color); 399 end; 400 end if; 401 402 if Color (N (Z)) = Black then 403 Delete_Fixup (Tree, X); 404 end if; 405 end if; 406 end if; 407 408 Tree.Length := Tree.Length - 1; 409 end Delete_Node_Sans_Free; 410 411 ----------------- 412 -- Delete_Swap -- 413 ----------------- 414 415 procedure Delete_Swap 416 (Tree : in out Tree_Type'Class; 417 Z, Y : Count_Type) 418 is 419 N : Nodes_Type renames Tree.Nodes; 420 421 pragma Assert (Z /= Y); 422 pragma Assert (Parent (N (Y)) /= Z); 423 424 Y_Parent : constant Count_Type := Parent (N (Y)); 425 Y_Color : constant Color_Type := Color (N (Y)); 426 427 begin 428 Set_Parent (N (Y), Parent (N (Z))); 429 Set_Left (N (Y), Left (N (Z))); 430 Set_Right (N (Y), Right (N (Z))); 431 Set_Color (N (Y), Color (N (Z))); 432 433 if Tree.Root = Z then 434 Tree.Root := Y; 435 elsif Right (N (Parent (N (Y)))) = Z then 436 Set_Right (N (Parent (N (Y))), Y); 437 else 438 pragma Assert (Left (N (Parent (N (Y)))) = Z); 439 Set_Left (N (Parent (N (Y))), Y); 440 end if; 441 442 if Right (N (Y)) /= 0 then 443 Set_Parent (N (Right (N (Y))), Y); 444 end if; 445 446 if Left (N (Y)) /= 0 then 447 Set_Parent (N (Left (N (Y))), Y); 448 end if; 449 450 Set_Parent (N (Z), Y_Parent); 451 Set_Color (N (Z), Y_Color); 452 Set_Left (N (Z), 0); 453 Set_Right (N (Z), 0); 454 end Delete_Swap; 455 456 ---------- 457 -- Free -- 458 ---------- 459 460 procedure Free (Tree : in out Tree_Type'Class; X : Count_Type) is 461 pragma Assert (X > 0); 462 pragma Assert (X <= Tree.Capacity); 463 464 N : Nodes_Type renames Tree.Nodes; 465 -- pragma Assert (N (X).Prev >= 0); -- node is active 466 -- Find a way to mark a node as active vs. inactive; we could 467 -- use a special value in Color_Type for this. ??? 468 469 begin 470 -- The set container actually contains two data structures: a list for 471 -- the "active" nodes that contain elements that have been inserted 472 -- onto the tree, and another for the "inactive" nodes of the free 473 -- store. 474 -- 475 -- We desire that merely declaring an object should have only minimal 476 -- cost; specially, we want to avoid having to initialize the free 477 -- store (to fill in the links), especially if the capacity is large. 478 -- 479 -- The head of the free list is indicated by Container.Free. If its 480 -- value is non-negative, then the free store has been initialized 481 -- in the "normal" way: Container.Free points to the head of the list 482 -- of free (inactive) nodes, and the value 0 means the free list is 483 -- empty. Each node on the free list has been initialized to point 484 -- to the next free node (via its Parent component), and the value 0 485 -- means that this is the last free node. 486 -- 487 -- If Container.Free is negative, then the links on the free store 488 -- have not been initialized. In this case the link values are 489 -- implied: the free store comprises the components of the node array 490 -- started with the absolute value of Container.Free, and continuing 491 -- until the end of the array (Nodes'Last). 492 -- 493 -- ??? 494 -- It might be possible to perform an optimization here. Suppose that 495 -- the free store can be represented as having two parts: one 496 -- comprising the non-contiguous inactive nodes linked together 497 -- in the normal way, and the other comprising the contiguous 498 -- inactive nodes (that are not linked together, at the end of the 499 -- nodes array). This would allow us to never have to initialize 500 -- the free store, except in a lazy way as nodes become inactive. 501 502 -- When an element is deleted from the list container, its node 503 -- becomes inactive, and so we set its Prev component to a negative 504 -- value, to indicate that it is now inactive. This provides a useful 505 -- way to detect a dangling cursor reference. 506 507 -- The comment above is incorrect; we need some other way to 508 -- indicate a node is inactive, for example by using a special 509 -- Color_Type value. ??? 510 -- N (X).Prev := -1; -- Node is deallocated (not on active list) 511 512 if Tree.Free >= 0 then 513 -- The free store has previously been initialized. All we need to 514 -- do here is link the newly-free'd node onto the free list. 515 516 Set_Parent (N (X), Tree.Free); 517 Tree.Free := X; 518 519 elsif X + 1 = abs Tree.Free then 520 -- The free store has not been initialized, and the node becoming 521 -- inactive immediately precedes the start of the free store. All 522 -- we need to do is move the start of the free store back by one. 523 524 Tree.Free := Tree.Free + 1; 525 526 else 527 -- The free store has not been initialized, and the node becoming 528 -- inactive does not immediately precede the free store. Here we 529 -- first initialize the free store (meaning the links are given 530 -- values in the traditional way), and then link the newly-free'd 531 -- node onto the head of the free store. 532 533 -- ??? 534 -- See the comments above for an optimization opportunity. If the 535 -- next link for a node on the free store is negative, then this 536 -- means the remaining nodes on the free store are physically 537 -- contiguous, starting as the absolute value of that index value. 538 539 Tree.Free := abs Tree.Free; 540 541 if Tree.Free > Tree.Capacity then 542 Tree.Free := 0; 543 544 else 545 for I in Tree.Free .. Tree.Capacity - 1 loop 546 Set_Parent (N (I), I + 1); 547 end loop; 548 549 Set_Parent (N (Tree.Capacity), 0); 550 end if; 551 552 Set_Parent (N (X), Tree.Free); 553 Tree.Free := X; 554 end if; 555 end Free; 556 557 ----------------------- 558 -- Generic_Allocate -- 559 ----------------------- 560 561 procedure Generic_Allocate 562 (Tree : in out Tree_Type'Class; 563 Node : out Count_Type) 564 is 565 N : Nodes_Type renames Tree.Nodes; 566 567 begin 568 if Tree.Free >= 0 then 569 Node := Tree.Free; 570 571 -- We always perform the assignment first, before we 572 -- change container state, in order to defend against 573 -- exceptions duration assignment. 574 575 Set_Element (N (Node)); 576 Tree.Free := Parent (N (Node)); 577 578 else 579 -- A negative free store value means that the links of the nodes 580 -- in the free store have not been initialized. In this case, the 581 -- nodes are physically contiguous in the array, starting at the 582 -- index that is the absolute value of the Container.Free, and 583 -- continuing until the end of the array (Nodes'Last). 584 585 Node := abs Tree.Free; 586 587 -- As above, we perform this assignment first, before modifying 588 -- any container state. 589 590 Set_Element (N (Node)); 591 Tree.Free := Tree.Free - 1; 592 end if; 593 594 -- When a node is allocated from the free store, its pointer components 595 -- (the links to other nodes in the tree) must also be initialized (to 596 -- 0, the equivalent of null). This simplifies the post-allocation 597 -- handling of nodes inserted into terminal positions. 598 599 Set_Parent (N (Node), Parent => 0); 600 Set_Left (N (Node), Left => 0); 601 Set_Right (N (Node), Right => 0); 602 end Generic_Allocate; 603 604 ------------------- 605 -- Generic_Equal -- 606 ------------------- 607 608 function Generic_Equal (Left, Right : Tree_Type'Class) return Boolean is 609 L_Node : Count_Type; 610 R_Node : Count_Type; 611 612 begin 613 if Left'Address = Right'Address then 614 return True; 615 end if; 616 617 if Left.Length /= Right.Length then 618 return False; 619 end if; 620 621 L_Node := Left.First; 622 R_Node := Right.First; 623 while L_Node /= 0 loop 624 if not Is_Equal (Left.Nodes (L_Node), Right.Nodes (R_Node)) then 625 return False; 626 end if; 627 628 L_Node := Next (Left, L_Node); 629 R_Node := Next (Right, R_Node); 630 end loop; 631 632 return True; 633 end Generic_Equal; 634 635 ----------------------- 636 -- Generic_Iteration -- 637 ----------------------- 638 639 procedure Generic_Iteration (Tree : Tree_Type'Class) is 640 procedure Iterate (P : Count_Type); 641 642 ------------- 643 -- Iterate -- 644 ------------- 645 646 procedure Iterate (P : Count_Type) is 647 X : Count_Type := P; 648 begin 649 while X /= 0 loop 650 Iterate (Left (Tree.Nodes (X))); 651 Process (X); 652 X := Right (Tree.Nodes (X)); 653 end loop; 654 end Iterate; 655 656 -- Start of processing for Generic_Iteration 657 658 begin 659 Iterate (Tree.Root); 660 end Generic_Iteration; 661 662 ------------------ 663 -- Generic_Read -- 664 ------------------ 665 666 procedure Generic_Read 667 (Stream : not null access Root_Stream_Type'Class; 668 Tree : in out Tree_Type'Class) 669 is 670 Len : Count_Type'Base; 671 672 Node, Last_Node : Count_Type; 673 674 N : Nodes_Type renames Tree.Nodes; 675 676 begin 677 Clear_Tree (Tree); 678 Count_Type'Base'Read (Stream, Len); 679 680 if Len < 0 then 681 raise Program_Error with "bad container length (corrupt stream)"; 682 end if; 683 684 if Len = 0 then 685 return; 686 end if; 687 688 if Len > Tree.Capacity then 689 raise Constraint_Error with "length exceeds capacity"; 690 end if; 691 692 -- Use Unconditional_Insert_With_Hint here instead ??? 693 694 Allocate (Tree, Node); 695 pragma Assert (Node /= 0); 696 697 Set_Color (N (Node), Black); 698 699 Tree.Root := Node; 700 Tree.First := Node; 701 Tree.Last := Node; 702 Tree.Length := 1; 703 704 for J in Count_Type range 2 .. Len loop 705 Last_Node := Node; 706 pragma Assert (Last_Node = Tree.Last); 707 708 Allocate (Tree, Node); 709 pragma Assert (Node /= 0); 710 711 Set_Color (N (Node), Red); 712 Set_Right (N (Last_Node), Right => Node); 713 Tree.Last := Node; 714 Set_Parent (N (Node), Parent => Last_Node); 715 716 Rebalance_For_Insert (Tree, Node); 717 Tree.Length := Tree.Length + 1; 718 end loop; 719 end Generic_Read; 720 721 ------------------------------- 722 -- Generic_Reverse_Iteration -- 723 ------------------------------- 724 725 procedure Generic_Reverse_Iteration (Tree : Tree_Type'Class) is 726 procedure Iterate (P : Count_Type); 727 728 ------------- 729 -- Iterate -- 730 ------------- 731 732 procedure Iterate (P : Count_Type) is 733 X : Count_Type := P; 734 begin 735 while X /= 0 loop 736 Iterate (Right (Tree.Nodes (X))); 737 Process (X); 738 X := Left (Tree.Nodes (X)); 739 end loop; 740 end Iterate; 741 742 -- Start of processing for Generic_Reverse_Iteration 743 744 begin 745 Iterate (Tree.Root); 746 end Generic_Reverse_Iteration; 747 748 ------------------- 749 -- Generic_Write -- 750 ------------------- 751 752 procedure Generic_Write 753 (Stream : not null access Root_Stream_Type'Class; 754 Tree : Tree_Type'Class) 755 is 756 procedure Process (Node : Count_Type); 757 pragma Inline (Process); 758 759 procedure Iterate is new Generic_Iteration (Process); 760 761 ------------- 762 -- Process -- 763 ------------- 764 765 procedure Process (Node : Count_Type) is 766 begin 767 Write_Node (Stream, Tree.Nodes (Node)); 768 end Process; 769 770 -- Start of processing for Generic_Write 771 772 begin 773 Count_Type'Base'Write (Stream, Tree.Length); 774 Iterate (Tree); 775 end Generic_Write; 776 777 ----------------- 778 -- Left_Rotate -- 779 ----------------- 780 781 procedure Left_Rotate (Tree : in out Tree_Type'Class; X : Count_Type) is 782 -- CLR p. 266 783 784 N : Nodes_Type renames Tree.Nodes; 785 786 Y : constant Count_Type := Right (N (X)); 787 pragma Assert (Y /= 0); 788 789 begin 790 Set_Right (N (X), Left (N (Y))); 791 792 if Left (N (Y)) /= 0 then 793 Set_Parent (N (Left (N (Y))), X); 794 end if; 795 796 Set_Parent (N (Y), Parent (N (X))); 797 798 if X = Tree.Root then 799 Tree.Root := Y; 800 elsif X = Left (N (Parent (N (X)))) then 801 Set_Left (N (Parent (N (X))), Y); 802 else 803 pragma Assert (X = Right (N (Parent (N (X))))); 804 Set_Right (N (Parent (N (X))), Y); 805 end if; 806 807 Set_Left (N (Y), X); 808 Set_Parent (N (X), Y); 809 end Left_Rotate; 810 811 --------- 812 -- Max -- 813 --------- 814 815 function Max 816 (Tree : Tree_Type'Class; 817 Node : Count_Type) return Count_Type 818 is 819 -- CLR p. 248 820 821 X : Count_Type := Node; 822 Y : Count_Type; 823 824 begin 825 loop 826 Y := Right (Tree.Nodes (X)); 827 828 if Y = 0 then 829 return X; 830 end if; 831 832 X := Y; 833 end loop; 834 end Max; 835 836 --------- 837 -- Min -- 838 --------- 839 840 function Min 841 (Tree : Tree_Type'Class; 842 Node : Count_Type) return Count_Type 843 is 844 -- CLR p. 248 845 846 X : Count_Type := Node; 847 Y : Count_Type; 848 849 begin 850 loop 851 Y := Left (Tree.Nodes (X)); 852 853 if Y = 0 then 854 return X; 855 end if; 856 857 X := Y; 858 end loop; 859 end Min; 860 861 ---------- 862 -- Next -- 863 ---------- 864 865 function Next 866 (Tree : Tree_Type'Class; 867 Node : Count_Type) return Count_Type 868 is 869 begin 870 -- CLR p. 249 871 872 if Node = 0 then 873 return 0; 874 end if; 875 876 if Right (Tree.Nodes (Node)) /= 0 then 877 return Min (Tree, Right (Tree.Nodes (Node))); 878 end if; 879 880 declare 881 X : Count_Type := Node; 882 Y : Count_Type := Parent (Tree.Nodes (Node)); 883 884 begin 885 while Y /= 0 886 and then X = Right (Tree.Nodes (Y)) 887 loop 888 X := Y; 889 Y := Parent (Tree.Nodes (Y)); 890 end loop; 891 892 return Y; 893 end; 894 end Next; 895 896 -------------- 897 -- Previous -- 898 -------------- 899 900 function Previous 901 (Tree : Tree_Type'Class; 902 Node : Count_Type) return Count_Type 903 is 904 begin 905 if Node = 0 then 906 return 0; 907 end if; 908 909 if Left (Tree.Nodes (Node)) /= 0 then 910 return Max (Tree, Left (Tree.Nodes (Node))); 911 end if; 912 913 declare 914 X : Count_Type := Node; 915 Y : Count_Type := Parent (Tree.Nodes (Node)); 916 917 begin 918 while Y /= 0 919 and then X = Left (Tree.Nodes (Y)) 920 loop 921 X := Y; 922 Y := Parent (Tree.Nodes (Y)); 923 end loop; 924 925 return Y; 926 end; 927 end Previous; 928 929 -------------------------- 930 -- Rebalance_For_Insert -- 931 -------------------------- 932 933 procedure Rebalance_For_Insert 934 (Tree : in out Tree_Type'Class; 935 Node : Count_Type) 936 is 937 -- CLR p. 268 938 939 N : Nodes_Type renames Tree.Nodes; 940 941 X : Count_Type := Node; 942 pragma Assert (X /= 0); 943 pragma Assert (Color (N (X)) = Red); 944 945 Y : Count_Type; 946 947 begin 948 while X /= Tree.Root and then Color (N (Parent (N (X)))) = Red loop 949 if Parent (N (X)) = Left (N (Parent (N (Parent (N (X)))))) then 950 Y := Right (N (Parent (N (Parent (N (X)))))); 951 952 if Y /= 0 and then Color (N (Y)) = Red then 953 Set_Color (N (Parent (N (X))), Black); 954 Set_Color (N (Y), Black); 955 Set_Color (N (Parent (N (Parent (N (X))))), Red); 956 X := Parent (N (Parent (N (X)))); 957 958 else 959 if X = Right (N (Parent (N (X)))) then 960 X := Parent (N (X)); 961 Left_Rotate (Tree, X); 962 end if; 963 964 Set_Color (N (Parent (N (X))), Black); 965 Set_Color (N (Parent (N (Parent (N (X))))), Red); 966 Right_Rotate (Tree, Parent (N (Parent (N (X))))); 967 end if; 968 969 else 970 pragma Assert (Parent (N (X)) = 971 Right (N (Parent (N (Parent (N (X))))))); 972 973 Y := Left (N (Parent (N (Parent (N (X)))))); 974 975 if Y /= 0 and then Color (N (Y)) = Red then 976 Set_Color (N (Parent (N (X))), Black); 977 Set_Color (N (Y), Black); 978 Set_Color (N (Parent (N (Parent (N (X))))), Red); 979 X := Parent (N (Parent (N (X)))); 980 981 else 982 if X = Left (N (Parent (N (X)))) then 983 X := Parent (N (X)); 984 Right_Rotate (Tree, X); 985 end if; 986 987 Set_Color (N (Parent (N (X))), Black); 988 Set_Color (N (Parent (N (Parent (N (X))))), Red); 989 Left_Rotate (Tree, Parent (N (Parent (N (X))))); 990 end if; 991 end if; 992 end loop; 993 994 Set_Color (N (Tree.Root), Black); 995 end Rebalance_For_Insert; 996 997 ------------------ 998 -- Right_Rotate -- 999 ------------------ 1000 1001 procedure Right_Rotate (Tree : in out Tree_Type'Class; Y : Count_Type) is 1002 N : Nodes_Type renames Tree.Nodes; 1003 1004 X : constant Count_Type := Left (N (Y)); 1005 pragma Assert (X /= 0); 1006 1007 begin 1008 Set_Left (N (Y), Right (N (X))); 1009 1010 if Right (N (X)) /= 0 then 1011 Set_Parent (N (Right (N (X))), Y); 1012 end if; 1013 1014 Set_Parent (N (X), Parent (N (Y))); 1015 1016 if Y = Tree.Root then 1017 Tree.Root := X; 1018 elsif Y = Left (N (Parent (N (Y)))) then 1019 Set_Left (N (Parent (N (Y))), X); 1020 else 1021 pragma Assert (Y = Right (N (Parent (N (Y))))); 1022 Set_Right (N (Parent (N (Y))), X); 1023 end if; 1024 1025 Set_Right (N (X), Y); 1026 Set_Parent (N (Y), X); 1027 end Right_Rotate; 1028 1029 --------- 1030 -- Vet -- 1031 --------- 1032 1033 function Vet (Tree : Tree_Type'Class; Index : Count_Type) return Boolean is 1034 Nodes : Nodes_Type renames Tree.Nodes; 1035 Node : Node_Type renames Nodes (Index); 1036 1037 begin 1038 if Parent (Node) = Index 1039 or else Left (Node) = Index 1040 or else Right (Node) = Index 1041 then 1042 return False; 1043 end if; 1044 1045 if Tree.Length = 0 1046 or else Tree.Root = 0 1047 or else Tree.First = 0 1048 or else Tree.Last = 0 1049 then 1050 return False; 1051 end if; 1052 1053 if Parent (Nodes (Tree.Root)) /= 0 then 1054 return False; 1055 end if; 1056 1057 if Left (Nodes (Tree.First)) /= 0 then 1058 return False; 1059 end if; 1060 1061 if Right (Nodes (Tree.Last)) /= 0 then 1062 return False; 1063 end if; 1064 1065 if Tree.Length = 1 then 1066 if Tree.First /= Tree.Last 1067 or else Tree.First /= Tree.Root 1068 then 1069 return False; 1070 end if; 1071 1072 if Index /= Tree.First then 1073 return False; 1074 end if; 1075 1076 if Parent (Node) /= 0 1077 or else Left (Node) /= 0 1078 or else Right (Node) /= 0 1079 then 1080 return False; 1081 end if; 1082 1083 return True; 1084 end if; 1085 1086 if Tree.First = Tree.Last then 1087 return False; 1088 end if; 1089 1090 if Tree.Length = 2 then 1091 if Tree.First /= Tree.Root 1092 and then Tree.Last /= Tree.Root 1093 then 1094 return False; 1095 end if; 1096 1097 if Tree.First /= Index 1098 and then Tree.Last /= Index 1099 then 1100 return False; 1101 end if; 1102 end if; 1103 1104 if Left (Node) /= 0 1105 and then Parent (Nodes (Left (Node))) /= Index 1106 then 1107 return False; 1108 end if; 1109 1110 if Right (Node) /= 0 1111 and then Parent (Nodes (Right (Node))) /= Index 1112 then 1113 return False; 1114 end if; 1115 1116 if Parent (Node) = 0 then 1117 if Tree.Root /= Index then 1118 return False; 1119 end if; 1120 1121 elsif Left (Nodes (Parent (Node))) /= Index 1122 and then Right (Nodes (Parent (Node))) /= Index 1123 then 1124 return False; 1125 end if; 1126 1127 return True; 1128 end Vet; 1129 1130end Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; 1131