gcc/ada/a-crbtgo.adb

   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-2007, 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 2,  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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- This unit was originally developed by Matthew J Heaney.                  --
  30 ------------------------------------------------------------------------------
  31
  32 --  The references below to "CLR" refer to the following book, from which
  33 --  several of the algorithms here were adapted:
  34 --     Introduction to Algorithms
  35 --     by Thomas H. Cormen, Charles E. Leiserson, Ronald L. Rivest
  36 --     Publisher: The MIT Press (June 18, 1990)
  37 --     ISBN: 0262031418
  38
  39 with System;  use type System.Address;
  40
  41 package body Ada.Containers.Red_Black_Trees.Generic_Operations is
  42
  43    -----------------------
  44    -- Local Subprograms --
  45    -----------------------
  46
  47    procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access);
  48
  49    procedure Delete_Swap (Tree : in out Tree_Type; Z, Y : Node_Access);
  50
  51    procedure Left_Rotate  (Tree : in out Tree_Type; X : Node_Access);
  52    procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access);
  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                   if Left (W) /= null then
 177                      Set_Color (Left (W), Black);
 178                   end if;
 179
 180                   Set_Color (W, Red);
 181                   Right_Rotate (Tree, W);
 182                   W := Right (Parent (X));
 183                end if;
 184
 185                Set_Color (W, Color (Parent (X)));
 186                Set_Color (Parent (X), Black);
 187                Set_Color (Right (W), Black);
 188                Left_Rotate  (Tree, Parent (X));
 189                X := Tree.Root;
 190             end if;
 191
 192          else
 193             pragma Assert (X = Right (Parent (X)));
 194
 195             W :=  Left (Parent (X));
 196
 197             if Color (W) = Red then
 198                Set_Color (W, Black);
 199                Set_Color (Parent (X), Red);
 200                Right_Rotate (Tree, Parent (X));
 201                W := Left (Parent (X));
 202             end if;
 203
 204             if (Left (W)  = null or else Color (Left (W)) = Black)
 205                   and then
 206                (Right (W) = null or else Color (Right (W)) = Black)
 207             then
 208                Set_Color (W, Red);
 209                X := Parent (X);
 210
 211             else
 212                if Left (W) = null or else Color (Left (W)) = Black then
 213                   if Right (W) /= null then
 214                      Set_Color (Right (W), Black);
 215                   end if;
 216
 217                   Set_Color (W, Red);
 218                   Left_Rotate (Tree, W);
 219                   W := Left (Parent (X));
 220                end if;
 221
 222                Set_Color (W, Color (Parent (X)));
 223                Set_Color (Parent (X), Black);
 224                Set_Color (Left (W), Black);
 225                Right_Rotate (Tree, Parent (X));
 226                X := Tree.Root;
 227             end if;
 228          end if;
 229       end loop;
 230
 231       Set_Color (X, Black);
 232    end Delete_Fixup;
 233
 234    ---------------------------
 235    -- Delete_Node_Sans_Free --
 236    ---------------------------
 237
 238    procedure Delete_Node_Sans_Free
 239      (Tree : in out Tree_Type;
 240       Node : Node_Access)
 241    is
 242       --  CLR p273
 243
 244       X, Y : Node_Access;
 245
 246       Z : constant Node_Access := Node;
 247       pragma Assert (Z /= null);
 248
 249    begin
 250       if Tree.Busy > 0 then
 251          raise Program_Error with
 252            "attempt to tamper with cursors (container is busy)";
 253       end if;
 254
 255 --    pragma Assert (Tree.Length > 0);
 256 --    pragma Assert (Tree.Root /= null);
 257 --    pragma Assert (Tree.First /= null);
 258 --    pragma Assert (Tree.Last /= null);
 259 --    pragma Assert (Parent (Tree.Root) = null);
 260 --    pragma Assert ((Tree.Length > 1)
 261 --                      or else (Tree.First = Tree.Last
 262 --                                 and then Tree.First = Tree.Root));
 263 --    pragma Assert ((Left (Node) = null)
 264 --                      or else (Parent (Left (Node)) = Node));
 265 --    pragma Assert ((Right (Node) = null)
 266 --                      or else (Parent (Right (Node)) = Node));
 267 --    pragma Assert (((Parent (Node) = null) and then (Tree.Root = Node))
 268 --                      or else ((Parent (Node) /= null) and then
 269 --                                ((Left (Parent (Node)) = Node)
 270 --                                   or else (Right (Parent (Node)) = Node))));
 271
 272       if Left (Z) = null then
 273          if Right (Z) = null then
 274             if Z = Tree.First then
 275                Tree.First := Parent (Z);
 276             end if;
 277
 278             if Z = Tree.Last then
 279                Tree.Last := Parent (Z);
 280             end if;
 281
 282             if Color (Z) = Black then
 283                Delete_Fixup (Tree, Z);
 284             end if;
 285
 286             pragma Assert (Left (Z) = null);
 287             pragma Assert (Right (Z) = null);
 288
 289             if Z = Tree.Root then
 290                pragma Assert (Tree.Length = 1);
 291                pragma Assert (Parent (Z) = null);
 292                Tree.Root := null;
 293             elsif Z = Left (Parent (Z)) then
 294                Set_Left (Parent (Z), null);
 295             else
 296                pragma Assert (Z = Right (Parent (Z)));
 297                Set_Right (Parent (Z), null);
 298             end if;
 299
 300          else
 301             pragma Assert (Z /= Tree.Last);
 302
 303             X := Right (Z);
 304
 305             if Z = Tree.First then
 306                Tree.First := Min (X);
 307             end if;
 308
 309             if Z = Tree.Root then
 310                Tree.Root := X;
 311             elsif Z = Left (Parent (Z)) then
 312                Set_Left (Parent (Z), X);
 313             else
 314                pragma Assert (Z = Right (Parent (Z)));
 315                Set_Right (Parent (Z), X);
 316             end if;
 317
 318             Set_Parent (X, Parent (Z));
 319
 320             if Color (Z) = Black then
 321                Delete_Fixup (Tree, X);
 322             end if;
 323          end if;
 324
 325       elsif Right (Z) = null then
 326          pragma Assert (Z /= Tree.First);
 327
 328          X := Left (Z);
 329
 330          if Z = Tree.Last then
 331             Tree.Last := Max (X);
 332          end if;
 333
 334          if Z = Tree.Root then
 335             Tree.Root := X;
 336          elsif Z = Left (Parent (Z)) then
 337             Set_Left (Parent (Z), X);
 338          else
 339             pragma Assert (Z = Right (Parent (Z)));
 340             Set_Right (Parent (Z), X);
 341          end if;
 342
 343          Set_Parent (X, Parent (Z));
 344
 345          if Color (Z) = Black then
 346             Delete_Fixup (Tree, X);
 347          end if;
 348
 349       else
 350          pragma Assert (Z /= Tree.First);
 351          pragma Assert (Z /= Tree.Last);
 352
 353          Y := Next (Z);
 354          pragma Assert (Left (Y) = null);
 355
 356          X := Right (Y);
 357
 358          if X = null then
 359             if Y = Left (Parent (Y)) then
 360                pragma Assert (Parent (Y) /= Z);
 361                Delete_Swap (Tree, Z, Y);
 362                Set_Left (Parent (Z), Z);
 363
 364             else
 365                pragma Assert (Y = Right (Parent (Y)));
 366                pragma Assert (Parent (Y) = Z);
 367                Set_Parent (Y, Parent (Z));
 368
 369                if Z = Tree.Root then
 370                   Tree.Root := Y;
 371                elsif Z = Left (Parent (Z)) then
 372                   Set_Left (Parent (Z), Y);
 373                else
 374                   pragma Assert (Z = Right (Parent (Z)));
 375                   Set_Right (Parent (Z), Y);
 376                end if;
 377
 378                Set_Left (Y, Left (Z));
 379                Set_Parent (Left (Y), Y);
 380                Set_Right (Y, Z);
 381                Set_Parent (Z, Y);
 382                Set_Left (Z, null);
 383                Set_Right (Z, null);
 384
 385                declare
 386                   Y_Color : constant Color_Type := Color (Y);
 387                begin
 388                   Set_Color (Y, Color (Z));
 389                   Set_Color (Z, Y_Color);
 390                end;
 391             end if;
 392
 393             if Color (Z) = Black then
 394                Delete_Fixup (Tree, Z);
 395             end if;
 396
 397             pragma Assert (Left (Z) = null);
 398             pragma Assert (Right (Z) = null);
 399
 400             if Z = Right (Parent (Z)) then
 401                Set_Right (Parent (Z), null);
 402             else
 403                pragma Assert (Z = Left (Parent (Z)));
 404                Set_Left (Parent (Z), null);
 405             end if;
 406
 407          else
 408             if Y = Left (Parent (Y)) then
 409                pragma Assert (Parent (Y) /= Z);
 410
 411                Delete_Swap (Tree, Z, Y);
 412
 413                Set_Left (Parent (Z), X);
 414                Set_Parent (X, Parent (Z));
 415
 416             else
 417                pragma Assert (Y = Right (Parent (Y)));
 418                pragma Assert (Parent (Y) = Z);
 419
 420                Set_Parent (Y, Parent (Z));
 421
 422                if Z = Tree.Root then
 423                   Tree.Root := Y;
 424                elsif Z = Left (Parent (Z)) then
 425                   Set_Left (Parent (Z), Y);
 426                else
 427                   pragma Assert (Z = Right (Parent (Z)));
 428                   Set_Right (Parent (Z), Y);
 429                end if;
 430
 431                Set_Left (Y, Left (Z));
 432                Set_Parent (Left (Y), Y);
 433
 434                declare
 435                   Y_Color : constant Color_Type := Color (Y);
 436                begin
 437                   Set_Color (Y, Color (Z));
 438                   Set_Color (Z, Y_Color);
 439                end;
 440             end if;
 441
 442             if Color (Z) = Black then
 443                Delete_Fixup (Tree, X);
 444             end if;
 445          end if;
 446       end if;
 447
 448       Tree.Length := Tree.Length - 1;
 449    end Delete_Node_Sans_Free;
 450
 451    -----------------
 452    -- Delete_Swap --
 453    -----------------
 454
 455    procedure Delete_Swap
 456      (Tree : in out Tree_Type;
 457       Z, Y : Node_Access)
 458    is
 459       pragma Assert (Z /= Y);
 460       pragma Assert (Parent (Y) /= Z);
 461
 462       Y_Parent : constant Node_Access := Parent (Y);
 463       Y_Color  : constant Color_Type  := Color (Y);
 464
 465    begin
 466       Set_Parent (Y, Parent (Z));
 467       Set_Left (Y, Left (Z));
 468       Set_Right (Y, Right (Z));
 469       Set_Color (Y, Color (Z));
 470
 471       if Tree.Root = Z then
 472          Tree.Root := Y;
 473       elsif Right (Parent (Y)) = Z then
 474          Set_Right (Parent (Y), Y);
 475       else
 476          pragma Assert (Left (Parent (Y)) = Z);
 477          Set_Left (Parent (Y), Y);
 478       end if;
 479
 480       if Right (Y) /= null then
 481          Set_Parent (Right (Y), Y);
 482       end if;
 483
 484       if Left (Y) /= null then
 485          Set_Parent (Left (Y), Y);
 486       end if;
 487
 488       Set_Parent (Z, Y_Parent);
 489       Set_Color (Z, Y_Color);
 490       Set_Left (Z, null);
 491       Set_Right (Z, null);
 492    end Delete_Swap;
 493
 494    --------------------
 495    -- Generic_Adjust --
 496    --------------------
 497
 498    procedure Generic_Adjust (Tree : in out Tree_Type) is
 499       N    : constant Count_Type := Tree.Length;
 500       Root : constant Node_Access := Tree.Root;
 501
 502    begin
 503       if N = 0 then
 504          pragma Assert (Root = null);
 505          pragma Assert (Tree.Busy = 0);
 506          pragma Assert (Tree.Lock = 0);
 507          return;
 508       end if;
 509
 510       Tree.Root := null;
 511       Tree.First := null;
 512       Tree.Last := null;
 513       Tree.Length := 0;
 514
 515       Tree.Root := Copy_Tree (Root);
 516       Tree.First := Min (Tree.Root);
 517       Tree.Last := Max (Tree.Root);
 518       Tree.Length := N;
 519    end Generic_Adjust;
 520
 521    -------------------
 522    -- Generic_Clear --
 523    -------------------
 524
 525    procedure Generic_Clear (Tree : in out Tree_Type) is
 526       Root : Node_Access := Tree.Root;
 527    begin
 528       if Tree.Busy > 0 then
 529          raise Program_Error with
 530            "attempt to tamper with cursors (container is busy)";
 531       end if;
 532
 533       Tree := (First  => null,
 534                Last   => null,
 535                Root   => null,
 536                Length => 0,
 537                Busy   => 0,
 538                Lock   => 0);
 539
 540       Delete_Tree (Root);
 541    end Generic_Clear;
 542
 543    -----------------------
 544    -- Generic_Copy_Tree --
 545    -----------------------
 546
 547    function Generic_Copy_Tree (Source_Root : Node_Access) return Node_Access is
 548       Target_Root : Node_Access := Copy_Node (Source_Root);
 549       P, X        : Node_Access;
 550
 551    begin
 552       if Right (Source_Root) /= null then
 553          Set_Right
 554            (Node  => Target_Root,
 555             Right => Generic_Copy_Tree (Right (Source_Root)));
 556
 557          Set_Parent
 558            (Node   => Right (Target_Root),
 559             Parent => Target_Root);
 560       end if;
 561
 562       P := Target_Root;
 563
 564       X := Left (Source_Root);
 565       while X /= null loop
 566          declare
 567             Y : constant Node_Access := Copy_Node (X);
 568          begin
 569             Set_Left (Node => P, Left => Y);
 570             Set_Parent (Node => Y, Parent => P);
 571
 572             if Right (X) /= null then
 573                Set_Right
 574                  (Node  => Y,
 575                   Right => Generic_Copy_Tree (Right (X)));
 576
 577                Set_Parent
 578                  (Node   => Right (Y),
 579                   Parent => Y);
 580             end if;
 581
 582             P := Y;
 583             X := Left (X);
 584          end;
 585       end loop;
 586
 587       return Target_Root;
 588    exception
 589       when others =>
 590          Delete_Tree (Target_Root);
 591          raise;
 592    end Generic_Copy_Tree;
 593
 594    -------------------------
 595    -- Generic_Delete_Tree --
 596    -------------------------
 597
 598    procedure Generic_Delete_Tree (X : in out Node_Access) is
 599       Y : Node_Access;
 600       pragma Warnings (Off, Y);
 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 : not null 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 : not null 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;