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-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 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 BL : Natural renames Left'Unrestricted_Access.Busy; 610 LL : Natural renames Left'Unrestricted_Access.Lock; 611 612 BR : Natural renames Right'Unrestricted_Access.Busy; 613 LR : Natural renames Right'Unrestricted_Access.Lock; 614 615 L_Node : Count_Type; 616 R_Node : Count_Type; 617 618 Result : Boolean; 619 620 begin 621 if Left'Address = Right'Address then 622 return True; 623 end if; 624 625 if Left.Length /= Right.Length then 626 return False; 627 end if; 628 629 -- If the containers are empty, return a result immediately, so as to 630 -- not manipulate the tamper bits unnecessarily. 631 632 if Left.Length = 0 then 633 return True; 634 end if; 635 636 -- Per AI05-0022, the container implementation is required to detect 637 -- element tampering by a generic actual subprogram. 638 639 BL := BL + 1; 640 LL := LL + 1; 641 642 BR := BR + 1; 643 LR := LR + 1; 644 645 L_Node := Left.First; 646 R_Node := Right.First; 647 Result := True; 648 while L_Node /= 0 loop 649 if not Is_Equal (Left.Nodes (L_Node), Right.Nodes (R_Node)) then 650 Result := False; 651 exit; 652 end if; 653 654 L_Node := Next (Left, L_Node); 655 R_Node := Next (Right, R_Node); 656 end loop; 657 658 BL := BL - 1; 659 LL := LL - 1; 660 661 BR := BR - 1; 662 LR := LR - 1; 663 664 return Result; 665 666 exception 667 when others => 668 BL := BL - 1; 669 LL := LL - 1; 670 671 BR := BR - 1; 672 LR := LR - 1; 673 674 raise; 675 end Generic_Equal; 676 677 ----------------------- 678 -- Generic_Iteration -- 679 ----------------------- 680 681 procedure Generic_Iteration (Tree : Tree_Type'Class) is 682 procedure Iterate (P : Count_Type); 683 684 ------------- 685 -- Iterate -- 686 ------------- 687 688 procedure Iterate (P : Count_Type) is 689 X : Count_Type := P; 690 begin 691 while X /= 0 loop 692 Iterate (Left (Tree.Nodes (X))); 693 Process (X); 694 X := Right (Tree.Nodes (X)); 695 end loop; 696 end Iterate; 697 698 -- Start of processing for Generic_Iteration 699 700 begin 701 Iterate (Tree.Root); 702 end Generic_Iteration; 703 704 ------------------ 705 -- Generic_Read -- 706 ------------------ 707 708 procedure Generic_Read 709 (Stream : not null access Root_Stream_Type'Class; 710 Tree : in out Tree_Type'Class) 711 is 712 Len : Count_Type'Base; 713 714 Node, Last_Node : Count_Type; 715 716 N : Nodes_Type renames Tree.Nodes; 717 718 begin 719 Clear_Tree (Tree); 720 Count_Type'Base'Read (Stream, Len); 721 722 if Len < 0 then 723 raise Program_Error with "bad container length (corrupt stream)"; 724 end if; 725 726 if Len = 0 then 727 return; 728 end if; 729 730 if Len > Tree.Capacity then 731 raise Constraint_Error with "length exceeds capacity"; 732 end if; 733 734 -- Use Unconditional_Insert_With_Hint here instead ??? 735 736 Allocate (Tree, Node); 737 pragma Assert (Node /= 0); 738 739 Set_Color (N (Node), Black); 740 741 Tree.Root := Node; 742 Tree.First := Node; 743 Tree.Last := Node; 744 Tree.Length := 1; 745 746 for J in Count_Type range 2 .. Len loop 747 Last_Node := Node; 748 pragma Assert (Last_Node = Tree.Last); 749 750 Allocate (Tree, Node); 751 pragma Assert (Node /= 0); 752 753 Set_Color (N (Node), Red); 754 Set_Right (N (Last_Node), Right => Node); 755 Tree.Last := Node; 756 Set_Parent (N (Node), Parent => Last_Node); 757 758 Rebalance_For_Insert (Tree, Node); 759 Tree.Length := Tree.Length + 1; 760 end loop; 761 end Generic_Read; 762 763 ------------------------------- 764 -- Generic_Reverse_Iteration -- 765 ------------------------------- 766 767 procedure Generic_Reverse_Iteration (Tree : Tree_Type'Class) is 768 procedure Iterate (P : Count_Type); 769 770 ------------- 771 -- Iterate -- 772 ------------- 773 774 procedure Iterate (P : Count_Type) is 775 X : Count_Type := P; 776 begin 777 while X /= 0 loop 778 Iterate (Right (Tree.Nodes (X))); 779 Process (X); 780 X := Left (Tree.Nodes (X)); 781 end loop; 782 end Iterate; 783 784 -- Start of processing for Generic_Reverse_Iteration 785 786 begin 787 Iterate (Tree.Root); 788 end Generic_Reverse_Iteration; 789 790 ------------------- 791 -- Generic_Write -- 792 ------------------- 793 794 procedure Generic_Write 795 (Stream : not null access Root_Stream_Type'Class; 796 Tree : Tree_Type'Class) 797 is 798 procedure Process (Node : Count_Type); 799 pragma Inline (Process); 800 801 procedure Iterate is new Generic_Iteration (Process); 802 803 ------------- 804 -- Process -- 805 ------------- 806 807 procedure Process (Node : Count_Type) is 808 begin 809 Write_Node (Stream, Tree.Nodes (Node)); 810 end Process; 811 812 -- Start of processing for Generic_Write 813 814 begin 815 Count_Type'Base'Write (Stream, Tree.Length); 816 Iterate (Tree); 817 end Generic_Write; 818 819 ----------------- 820 -- Left_Rotate -- 821 ----------------- 822 823 procedure Left_Rotate (Tree : in out Tree_Type'Class; X : Count_Type) is 824 -- CLR p. 266 825 826 N : Nodes_Type renames Tree.Nodes; 827 828 Y : constant Count_Type := Right (N (X)); 829 pragma Assert (Y /= 0); 830 831 begin 832 Set_Right (N (X), Left (N (Y))); 833 834 if Left (N (Y)) /= 0 then 835 Set_Parent (N (Left (N (Y))), X); 836 end if; 837 838 Set_Parent (N (Y), Parent (N (X))); 839 840 if X = Tree.Root then 841 Tree.Root := Y; 842 elsif X = Left (N (Parent (N (X)))) then 843 Set_Left (N (Parent (N (X))), Y); 844 else 845 pragma Assert (X = Right (N (Parent (N (X))))); 846 Set_Right (N (Parent (N (X))), Y); 847 end if; 848 849 Set_Left (N (Y), X); 850 Set_Parent (N (X), Y); 851 end Left_Rotate; 852 853 --------- 854 -- Max -- 855 --------- 856 857 function Max 858 (Tree : Tree_Type'Class; 859 Node : Count_Type) return Count_Type 860 is 861 -- CLR p. 248 862 863 X : Count_Type := Node; 864 Y : Count_Type; 865 866 begin 867 loop 868 Y := Right (Tree.Nodes (X)); 869 870 if Y = 0 then 871 return X; 872 end if; 873 874 X := Y; 875 end loop; 876 end Max; 877 878 --------- 879 -- Min -- 880 --------- 881 882 function Min 883 (Tree : Tree_Type'Class; 884 Node : Count_Type) return Count_Type 885 is 886 -- CLR p. 248 887 888 X : Count_Type := Node; 889 Y : Count_Type; 890 891 begin 892 loop 893 Y := Left (Tree.Nodes (X)); 894 895 if Y = 0 then 896 return X; 897 end if; 898 899 X := Y; 900 end loop; 901 end Min; 902 903 ---------- 904 -- Next -- 905 ---------- 906 907 function Next 908 (Tree : Tree_Type'Class; 909 Node : Count_Type) return Count_Type 910 is 911 begin 912 -- CLR p. 249 913 914 if Node = 0 then 915 return 0; 916 end if; 917 918 if Right (Tree.Nodes (Node)) /= 0 then 919 return Min (Tree, Right (Tree.Nodes (Node))); 920 end if; 921 922 declare 923 X : Count_Type := Node; 924 Y : Count_Type := Parent (Tree.Nodes (Node)); 925 926 begin 927 while Y /= 0 928 and then X = Right (Tree.Nodes (Y)) 929 loop 930 X := Y; 931 Y := Parent (Tree.Nodes (Y)); 932 end loop; 933 934 return Y; 935 end; 936 end Next; 937 938 -------------- 939 -- Previous -- 940 -------------- 941 942 function Previous 943 (Tree : Tree_Type'Class; 944 Node : Count_Type) return Count_Type 945 is 946 begin 947 if Node = 0 then 948 return 0; 949 end if; 950 951 if Left (Tree.Nodes (Node)) /= 0 then 952 return Max (Tree, Left (Tree.Nodes (Node))); 953 end if; 954 955 declare 956 X : Count_Type := Node; 957 Y : Count_Type := Parent (Tree.Nodes (Node)); 958 959 begin 960 while Y /= 0 961 and then X = Left (Tree.Nodes (Y)) 962 loop 963 X := Y; 964 Y := Parent (Tree.Nodes (Y)); 965 end loop; 966 967 return Y; 968 end; 969 end Previous; 970 971 -------------------------- 972 -- Rebalance_For_Insert -- 973 -------------------------- 974 975 procedure Rebalance_For_Insert 976 (Tree : in out Tree_Type'Class; 977 Node : Count_Type) 978 is 979 -- CLR p. 268 980 981 N : Nodes_Type renames Tree.Nodes; 982 983 X : Count_Type := Node; 984 pragma Assert (X /= 0); 985 pragma Assert (Color (N (X)) = Red); 986 987 Y : Count_Type; 988 989 begin 990 while X /= Tree.Root and then Color (N (Parent (N (X)))) = Red loop 991 if Parent (N (X)) = Left (N (Parent (N (Parent (N (X)))))) then 992 Y := Right (N (Parent (N (Parent (N (X)))))); 993 994 if Y /= 0 and then Color (N (Y)) = Red then 995 Set_Color (N (Parent (N (X))), Black); 996 Set_Color (N (Y), Black); 997 Set_Color (N (Parent (N (Parent (N (X))))), Red); 998 X := Parent (N (Parent (N (X)))); 999 1000 else 1001 if X = Right (N (Parent (N (X)))) then 1002 X := Parent (N (X)); 1003 Left_Rotate (Tree, X); 1004 end if; 1005 1006 Set_Color (N (Parent (N (X))), Black); 1007 Set_Color (N (Parent (N (Parent (N (X))))), Red); 1008 Right_Rotate (Tree, Parent (N (Parent (N (X))))); 1009 end if; 1010 1011 else 1012 pragma Assert (Parent (N (X)) = 1013 Right (N (Parent (N (Parent (N (X))))))); 1014 1015 Y := Left (N (Parent (N (Parent (N (X)))))); 1016 1017 if Y /= 0 and then Color (N (Y)) = Red then 1018 Set_Color (N (Parent (N (X))), Black); 1019 Set_Color (N (Y), Black); 1020 Set_Color (N (Parent (N (Parent (N (X))))), Red); 1021 X := Parent (N (Parent (N (X)))); 1022 1023 else 1024 if X = Left (N (Parent (N (X)))) then 1025 X := Parent (N (X)); 1026 Right_Rotate (Tree, X); 1027 end if; 1028 1029 Set_Color (N (Parent (N (X))), Black); 1030 Set_Color (N (Parent (N (Parent (N (X))))), Red); 1031 Left_Rotate (Tree, Parent (N (Parent (N (X))))); 1032 end if; 1033 end if; 1034 end loop; 1035 1036 Set_Color (N (Tree.Root), Black); 1037 end Rebalance_For_Insert; 1038 1039 ------------------ 1040 -- Right_Rotate -- 1041 ------------------ 1042 1043 procedure Right_Rotate (Tree : in out Tree_Type'Class; Y : Count_Type) is 1044 N : Nodes_Type renames Tree.Nodes; 1045 1046 X : constant Count_Type := Left (N (Y)); 1047 pragma Assert (X /= 0); 1048 1049 begin 1050 Set_Left (N (Y), Right (N (X))); 1051 1052 if Right (N (X)) /= 0 then 1053 Set_Parent (N (Right (N (X))), Y); 1054 end if; 1055 1056 Set_Parent (N (X), Parent (N (Y))); 1057 1058 if Y = Tree.Root then 1059 Tree.Root := X; 1060 elsif Y = Left (N (Parent (N (Y)))) then 1061 Set_Left (N (Parent (N (Y))), X); 1062 else 1063 pragma Assert (Y = Right (N (Parent (N (Y))))); 1064 Set_Right (N (Parent (N (Y))), X); 1065 end if; 1066 1067 Set_Right (N (X), Y); 1068 Set_Parent (N (Y), X); 1069 end Right_Rotate; 1070 1071 --------- 1072 -- Vet -- 1073 --------- 1074 1075 function Vet (Tree : Tree_Type'Class; Index : Count_Type) return Boolean is 1076 Nodes : Nodes_Type renames Tree.Nodes; 1077 Node : Node_Type renames Nodes (Index); 1078 1079 begin 1080 if Parent (Node) = Index 1081 or else Left (Node) = Index 1082 or else Right (Node) = Index 1083 then 1084 return False; 1085 end if; 1086 1087 if Tree.Length = 0 1088 or else Tree.Root = 0 1089 or else Tree.First = 0 1090 or else Tree.Last = 0 1091 then 1092 return False; 1093 end if; 1094 1095 if Parent (Nodes (Tree.Root)) /= 0 then 1096 return False; 1097 end if; 1098 1099 if Left (Nodes (Tree.First)) /= 0 then 1100 return False; 1101 end if; 1102 1103 if Right (Nodes (Tree.Last)) /= 0 then 1104 return False; 1105 end if; 1106 1107 if Tree.Length = 1 then 1108 if Tree.First /= Tree.Last 1109 or else Tree.First /= Tree.Root 1110 then 1111 return False; 1112 end if; 1113 1114 if Index /= Tree.First then 1115 return False; 1116 end if; 1117 1118 if Parent (Node) /= 0 1119 or else Left (Node) /= 0 1120 or else Right (Node) /= 0 1121 then 1122 return False; 1123 end if; 1124 1125 return True; 1126 end if; 1127 1128 if Tree.First = Tree.Last then 1129 return False; 1130 end if; 1131 1132 if Tree.Length = 2 then 1133 if Tree.First /= Tree.Root 1134 and then Tree.Last /= Tree.Root 1135 then 1136 return False; 1137 end if; 1138 1139 if Tree.First /= Index 1140 and then Tree.Last /= Index 1141 then 1142 return False; 1143 end if; 1144 end if; 1145 1146 if Left (Node) /= 0 1147 and then Parent (Nodes (Left (Node))) /= Index 1148 then 1149 return False; 1150 end if; 1151 1152 if Right (Node) /= 0 1153 and then Parent (Nodes (Right (Node))) /= Index 1154 then 1155 return False; 1156 end if; 1157 1158 if Parent (Node) = 0 then 1159 if Tree.Root /= Index then 1160 return False; 1161 end if; 1162 1163 elsif Left (Nodes (Parent (Node))) /= Index 1164 and then Right (Nodes (Parent (Node))) /= Index 1165 then 1166 return False; 1167 end if; 1168 1169 return True; 1170 end Vet; 1171 1172end Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; 1173