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