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