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