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