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