gcc/ada/a-crbtgo.adb

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