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