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-2009, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- This unit was originally developed by Matthew J Heaney.                  --
  28 ------------------------------------------------------------------------------
  29
  30 --  The references below to "CLR" refer to the following book, from which
  31 --  several of the algorithms here were adapted:
  32 --     Introduction to Algorithms
  33 --     by Thomas H. Cormen, Charles E. Leiserson, Ronald L. Rivest
  34 --     Publisher: The MIT Press (June 18, 1990)
  35 --     ISBN: 0262031418
  36
  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 with
 250            "attempt to tamper with cursors (container is busy)";
 251       end if;
 252
 253 --    pragma Assert (Tree.Length > 0);
 254 --    pragma Assert (Tree.Root /= null);
 255 --    pragma Assert (Tree.First /= null);
 256 --    pragma Assert (Tree.Last /= null);
 257 --    pragma Assert (Parent (Tree.Root) = null);
 258 --    pragma Assert ((Tree.Length > 1)
 259 --                      or else (Tree.First = Tree.Last
 260 --                                 and then Tree.First = Tree.Root));
 261 --    pragma Assert ((Left (Node) = null)
 262 --                      or else (Parent (Left (Node)) = Node));
 263 --    pragma Assert ((Right (Node) = null)
 264 --                      or else (Parent (Right (Node)) = Node));
 265 --    pragma Assert (((Parent (Node) = null) and then (Tree.Root = Node))
 266 --                      or else ((Parent (Node) /= null) and then
 267 --                                ((Left (Parent (Node)) = Node)
 268 --                                   or else (Right (Parent (Node)) = Node))));
 269
 270       if Left (Z) = null then
 271          if Right (Z) = null then
 272             if Z = Tree.First then
 273                Tree.First := Parent (Z);
 274             end if;
 275
 276             if Z = Tree.Last then
 277                Tree.Last := Parent (Z);
 278             end if;
 279
 280             if Color (Z) = Black then
 281                Delete_Fixup (Tree, Z);
 282             end if;
 283
 284             pragma Assert (Left (Z) = null);
 285             pragma Assert (Right (Z) = null);
 286
 287             if Z = Tree.Root then
 288                pragma Assert (Tree.Length = 1);
 289                pragma Assert (Parent (Z) = null);
 290                Tree.Root := null;
 291             elsif Z = Left (Parent (Z)) then
 292                Set_Left (Parent (Z), null);
 293             else
 294                pragma Assert (Z = Right (Parent (Z)));
 295                Set_Right (Parent (Z), null);
 296             end if;
 297
 298          else
 299             pragma Assert (Z /= Tree.Last);
 300
 301             X := Right (Z);
 302
 303             if Z = Tree.First then
 304                Tree.First := Min (X);
 305             end if;
 306
 307             if Z = Tree.Root then
 308                Tree.Root := X;
 309             elsif Z = Left (Parent (Z)) then
 310                Set_Left (Parent (Z), X);
 311             else
 312                pragma Assert (Z = Right (Parent (Z)));
 313                Set_Right (Parent (Z), X);
 314             end if;
 315
 316             Set_Parent (X, Parent (Z));
 317
 318             if Color (Z) = Black then
 319                Delete_Fixup (Tree, X);
 320             end if;
 321          end if;
 322
 323       elsif Right (Z) = null then
 324          pragma Assert (Z /= Tree.First);
 325
 326          X := Left (Z);
 327
 328          if Z = Tree.Last then
 329             Tree.Last := Max (X);
 330          end if;
 331
 332          if Z = Tree.Root then
 333             Tree.Root := X;
 334          elsif Z = Left (Parent (Z)) then
 335             Set_Left (Parent (Z), X);
 336          else
 337             pragma Assert (Z = Right (Parent (Z)));
 338             Set_Right (Parent (Z), X);
 339          end if;
 340
 341          Set_Parent (X, Parent (Z));
 342
 343          if Color (Z) = Black then
 344             Delete_Fixup (Tree, X);
 345          end if;
 346
 347       else
 348          pragma Assert (Z /= Tree.First);
 349          pragma Assert (Z /= Tree.Last);
 350
 351          Y := Next (Z);
 352          pragma Assert (Left (Y) = null);
 353
 354          X := Right (Y);
 355
 356          if X = null then
 357             if Y = Left (Parent (Y)) then
 358                pragma Assert (Parent (Y) /= Z);
 359                Delete_Swap (Tree, Z, Y);
 360                Set_Left (Parent (Z), Z);
 361
 362             else
 363                pragma Assert (Y = Right (Parent (Y)));
 364                pragma Assert (Parent (Y) = Z);
 365                Set_Parent (Y, Parent (Z));
 366
 367                if Z = Tree.Root then
 368                   Tree.Root := Y;
 369                elsif Z = Left (Parent (Z)) then
 370                   Set_Left (Parent (Z), Y);
 371                else
 372                   pragma Assert (Z = Right (Parent (Z)));
 373                   Set_Right (Parent (Z), Y);
 374                end if;
 375
 376                Set_Left (Y, Left (Z));
 377                Set_Parent (Left (Y), Y);
 378                Set_Right (Y, Z);
 379                Set_Parent (Z, Y);
 380                Set_Left (Z, null);
 381                Set_Right (Z, null);
 382
 383                declare
 384                   Y_Color : constant Color_Type := Color (Y);
 385                begin
 386                   Set_Color (Y, Color (Z));
 387                   Set_Color (Z, Y_Color);
 388                end;
 389             end if;
 390
 391             if Color (Z) = Black then
 392                Delete_Fixup (Tree, Z);
 393             end if;
 394
 395             pragma Assert (Left (Z) = null);
 396             pragma Assert (Right (Z) = null);
 397
 398             if Z = Right (Parent (Z)) then
 399                Set_Right (Parent (Z), null);
 400             else
 401                pragma Assert (Z = Left (Parent (Z)));
 402                Set_Left (Parent (Z), null);
 403             end if;
 404
 405          else
 406             if Y = Left (Parent (Y)) then
 407                pragma Assert (Parent (Y) /= Z);
 408
 409                Delete_Swap (Tree, Z, Y);
 410
 411                Set_Left (Parent (Z), X);
 412                Set_Parent (X, Parent (Z));
 413
 414             else
 415                pragma Assert (Y = Right (Parent (Y)));
 416                pragma Assert (Parent (Y) = Z);
 417
 418                Set_Parent (Y, Parent (Z));
 419
 420                if Z = Tree.Root then
 421                   Tree.Root := Y;
 422                elsif Z = Left (Parent (Z)) then
 423                   Set_Left (Parent (Z), Y);
 424                else
 425                   pragma Assert (Z = Right (Parent (Z)));
 426                   Set_Right (Parent (Z), Y);
 427                end if;
 428
 429                Set_Left (Y, Left (Z));
 430                Set_Parent (Left (Y), Y);
 431
 432                declare
 433                   Y_Color : constant Color_Type := Color (Y);
 434                begin
 435                   Set_Color (Y, Color (Z));
 436                   Set_Color (Z, Y_Color);
 437                end;
 438             end if;
 439
 440             if Color (Z) = Black then
 441                Delete_Fixup (Tree, X);
 442             end if;
 443          end if;
 444       end if;
 445
 446       Tree.Length := Tree.Length - 1;
 447    end Delete_Node_Sans_Free;
 448
 449    -----------------
 450    -- Delete_Swap --
 451    -----------------
 452
 453    procedure Delete_Swap
 454      (Tree : in out Tree_Type;
 455       Z, Y : Node_Access)
 456    is
 457       pragma Assert (Z /= Y);
 458       pragma Assert (Parent (Y) /= Z);
 459
 460       Y_Parent : constant Node_Access := Parent (Y);
 461       Y_Color  : constant Color_Type  := Color (Y);
 462
 463    begin
 464       Set_Parent (Y, Parent (Z));
 465       Set_Left (Y, Left (Z));
 466       Set_Right (Y, Right (Z));
 467       Set_Color (Y, Color (Z));
 468
 469       if Tree.Root = Z then
 470          Tree.Root := Y;
 471       elsif Right (Parent (Y)) = Z then
 472          Set_Right (Parent (Y), Y);
 473       else
 474          pragma Assert (Left (Parent (Y)) = Z);
 475          Set_Left (Parent (Y), Y);
 476       end if;
 477
 478       if Right (Y) /= null then
 479          Set_Parent (Right (Y), Y);
 480       end if;
 481
 482       if Left (Y) /= null then
 483          Set_Parent (Left (Y), Y);
 484       end if;
 485
 486       Set_Parent (Z, Y_Parent);
 487       Set_Color (Z, Y_Color);
 488       Set_Left (Z, null);
 489       Set_Right (Z, null);
 490    end Delete_Swap;
 491
 492    --------------------
 493    -- Generic_Adjust --
 494    --------------------
 495
 496    procedure Generic_Adjust (Tree : in out Tree_Type) is
 497       N    : constant Count_Type := Tree.Length;
 498       Root : constant Node_Access := Tree.Root;
 499
 500    begin
 501       if N = 0 then
 502          pragma Assert (Root = null);
 503          pragma Assert (Tree.Busy = 0);
 504          pragma Assert (Tree.Lock = 0);
 505          return;
 506       end if;
 507
 508       Tree.Root := null;
 509       Tree.First := null;
 510       Tree.Last := null;
 511       Tree.Length := 0;
 512
 513       Tree.Root := Copy_Tree (Root);
 514       Tree.First := Min (Tree.Root);
 515       Tree.Last := Max (Tree.Root);
 516       Tree.Length := N;
 517    end Generic_Adjust;
 518
 519    -------------------
 520    -- Generic_Clear --
 521    -------------------
 522
 523    procedure Generic_Clear (Tree : in out Tree_Type) is
 524       Root : Node_Access := Tree.Root;
 525    begin
 526       if Tree.Busy > 0 then
 527          raise Program_Error with
 528            "attempt to tamper with cursors (container is busy)";
 529       end if;
 530
 531       Tree := (First  => null,
 532                Last   => null,
 533                Root   => null,
 534                Length => 0,
 535                Busy   => 0,
 536                Lock   => 0);
 537
 538       Delete_Tree (Root);
 539    end Generic_Clear;
 540
 541    -----------------------
 542    -- Generic_Copy_Tree --
 543    -----------------------
 544
 545    function Generic_Copy_Tree (Source_Root : Node_Access) return Node_Access is
 546       Target_Root : Node_Access := Copy_Node (Source_Root);
 547       P, X        : Node_Access;
 548
 549    begin
 550       if Right (Source_Root) /= null then
 551          Set_Right
 552            (Node  => Target_Root,
 553             Right => Generic_Copy_Tree (Right (Source_Root)));
 554
 555          Set_Parent
 556            (Node   => Right (Target_Root),
 557             Parent => Target_Root);
 558       end if;
 559
 560       P := Target_Root;
 561
 562       X := Left (Source_Root);
 563       while X /= null loop
 564          declare
 565             Y : constant Node_Access := Copy_Node (X);
 566          begin
 567             Set_Left (Node => P, Left => Y);
 568             Set_Parent (Node => Y, Parent => P);
 569
 570             if Right (X) /= null then
 571                Set_Right
 572                  (Node  => Y,
 573                   Right => Generic_Copy_Tree (Right (X)));
 574
 575                Set_Parent
 576                  (Node   => Right (Y),
 577                   Parent => Y);
 578             end if;
 579
 580             P := Y;
 581             X := Left (X);
 582          end;
 583       end loop;
 584
 585       return Target_Root;
 586    exception
 587       when others =>
 588          Delete_Tree (Target_Root);
 589          raise;
 590    end Generic_Copy_Tree;
 591
 592    -------------------------
 593    -- Generic_Delete_Tree --
 594    -------------------------
 595
 596    procedure Generic_Delete_Tree (X : in out Node_Access) is
 597       Y : Node_Access;
 598       pragma Warnings (Off, Y);
 599    begin
 600       while X /= null loop
 601          Y := Right (X);
 602          Generic_Delete_Tree (Y);
 603          Y := Left (X);
 604          Free (X);
 605          X := Y;
 606       end loop;
 607    end Generic_Delete_Tree;
 608
 609    -------------------
 610    -- Generic_Equal --
 611    -------------------
 612
 613    function Generic_Equal (Left, Right : Tree_Type) return Boolean is
 614       L_Node : Node_Access;
 615       R_Node : Node_Access;
 616
 617    begin
 618       if Left'Address = Right'Address then
 619          return True;
 620       end if;
 621
 622       if Left.Length /= Right.Length then
 623          return False;
 624       end if;
 625
 626       L_Node := Left.First;
 627       R_Node := Right.First;
 628       while L_Node /= null loop
 629          if not Is_Equal (L_Node, R_Node) then
 630             return False;
 631          end if;
 632
 633          L_Node := Next (L_Node);
 634          R_Node := Next (R_Node);
 635       end loop;
 636
 637       return True;
 638    end Generic_Equal;
 639
 640    -----------------------
 641    -- Generic_Iteration --
 642    -----------------------
 643
 644    procedure Generic_Iteration (Tree : Tree_Type) is
 645       procedure Iterate (P : Node_Access);
 646
 647       -------------
 648       -- Iterate --
 649       -------------
 650
 651       procedure Iterate (P : Node_Access) is
 652          X : Node_Access := P;
 653       begin
 654          while X /= null loop
 655             Iterate (Left (X));
 656             Process (X);
 657             X := Right (X);
 658          end loop;
 659       end Iterate;
 660
 661    --  Start of processing for Generic_Iteration
 662
 663    begin
 664       Iterate (Tree.Root);
 665    end Generic_Iteration;
 666
 667    ------------------
 668    -- Generic_Move --
 669    ------------------
 670
 671    procedure Generic_Move (Target, Source : in out Tree_Type) is
 672    begin
 673       if Target'Address = Source'Address then
 674          return;
 675       end if;
 676
 677       if Source.Busy > 0 then
 678          raise Program_Error with
 679            "attempt to tamper with cursors (container is busy)";
 680       end if;
 681
 682       Clear (Target);
 683
 684       Target := Source;
 685
 686       Source := (First  => null,
 687                  Last   => null,
 688                  Root   => null,
 689                  Length => 0,
 690                  Busy   => 0,
 691                  Lock   => 0);
 692    end Generic_Move;
 693
 694    ------------------
 695    -- Generic_Read --
 696    ------------------
 697
 698    procedure Generic_Read
 699      (Stream : not null access Root_Stream_Type'Class;
 700       Tree   : in out Tree_Type)
 701    is
 702       N : Count_Type'Base;
 703
 704       Node, Last_Node : Node_Access;
 705
 706    begin
 707       Clear (Tree);
 708
 709       Count_Type'Base'Read (Stream, N);
 710       pragma Assert (N >= 0);
 711
 712       if N = 0 then
 713          return;
 714       end if;
 715
 716       Node := Read_Node (Stream);
 717       pragma Assert (Node /= null);
 718       pragma Assert (Color (Node) = Red);
 719
 720       Set_Color (Node, Black);
 721
 722       Tree.Root := Node;
 723       Tree.First := Node;
 724       Tree.Last := Node;
 725
 726       Tree.Length := 1;
 727
 728       for J in Count_Type range 2 .. N loop
 729          Last_Node := Node;
 730          pragma Assert (Last_Node = Tree.Last);
 731
 732          Node := Read_Node (Stream);
 733          pragma Assert (Node /= null);
 734          pragma Assert (Color (Node) = Red);
 735
 736          Set_Right (Node => Last_Node, Right => Node);
 737          Tree.Last := Node;
 738          Set_Parent (Node => Node, Parent => Last_Node);
 739          Rebalance_For_Insert (Tree, Node);
 740          Tree.Length := Tree.Length + 1;
 741       end loop;
 742    end Generic_Read;
 743
 744    -------------------------------
 745    -- Generic_Reverse_Iteration --
 746    -------------------------------
 747
 748    procedure Generic_Reverse_Iteration (Tree : Tree_Type)
 749    is
 750       procedure Iterate (P : Node_Access);
 751
 752       -------------
 753       -- Iterate --
 754       -------------
 755
 756       procedure Iterate (P : Node_Access) is
 757          X : Node_Access := P;
 758       begin
 759          while X /= null loop
 760             Iterate (Right (X));
 761             Process (X);
 762             X := Left (X);
 763          end loop;
 764       end Iterate;
 765
 766    --  Start of processing for Generic_Reverse_Iteration
 767
 768    begin
 769       Iterate (Tree.Root);
 770    end Generic_Reverse_Iteration;
 771
 772    -------------------
 773    -- Generic_Write --
 774    -------------------
 775
 776    procedure Generic_Write
 777      (Stream : not null access Root_Stream_Type'Class;
 778       Tree   : Tree_Type)
 779    is
 780       procedure Process (Node : Node_Access);
 781       pragma Inline (Process);
 782
 783       procedure Iterate is
 784          new Generic_Iteration (Process);
 785
 786       -------------
 787       -- Process --
 788       -------------
 789
 790       procedure Process (Node : Node_Access) is
 791       begin
 792          Write_Node (Stream, Node);
 793       end Process;
 794
 795    --  Start of processing for Generic_Write
 796
 797    begin
 798       Count_Type'Base'Write (Stream, Tree.Length);
 799       Iterate (Tree);
 800    end Generic_Write;
 801
 802    -----------------
 803    -- Left_Rotate --
 804    -----------------
 805
 806    procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access) is
 807
 808       --  CLR p266
 809
 810       Y : constant Node_Access := Right (X);
 811       pragma Assert (Y /= null);
 812
 813    begin
 814       Set_Right (X, Left (Y));
 815
 816       if Left (Y) /= null then
 817          Set_Parent (Left (Y), X);
 818       end if;
 819
 820       Set_Parent (Y, Parent (X));
 821
 822       if X = Tree.Root then
 823          Tree.Root := Y;
 824       elsif X = Left (Parent (X)) then
 825          Set_Left (Parent (X), Y);
 826       else
 827          pragma Assert (X = Right (Parent (X)));
 828          Set_Right (Parent (X), Y);
 829       end if;
 830
 831       Set_Left (Y, X);
 832       Set_Parent (X, Y);
 833    end Left_Rotate;
 834
 835    ---------
 836    -- Max --
 837    ---------
 838
 839    function Max (Node : Node_Access) return Node_Access is
 840
 841       --  CLR p248
 842
 843       X : Node_Access := Node;
 844       Y : Node_Access;
 845
 846    begin
 847       loop
 848          Y := Right (X);
 849
 850          if Y = null then
 851             return X;
 852          end if;
 853
 854          X := Y;
 855       end loop;
 856    end Max;
 857
 858    ---------
 859    -- Min --
 860    ---------
 861
 862    function Min (Node : Node_Access) return Node_Access is
 863
 864       --  CLR p248
 865
 866       X : Node_Access := Node;
 867       Y : Node_Access;
 868
 869    begin
 870       loop
 871          Y := Left (X);
 872
 873          if Y = null then
 874             return X;
 875          end if;
 876
 877          X := Y;
 878       end loop;
 879    end Min;
 880
 881    ----------
 882    -- Next --
 883    ----------
 884
 885    function Next (Node : Node_Access) return Node_Access is
 886    begin
 887       --  CLR p249
 888
 889       if Node = null then
 890          return null;
 891       end if;
 892
 893       if Right (Node) /= null then
 894          return Min (Right (Node));
 895       end if;
 896
 897       declare
 898          X : Node_Access := Node;
 899          Y : Node_Access := Parent (Node);
 900
 901       begin
 902          while Y /= null
 903            and then X = Right (Y)
 904          loop
 905             X := Y;
 906             Y := Parent (Y);
 907          end loop;
 908
 909          return Y;
 910       end;
 911    end Next;
 912
 913    --------------
 914    -- Previous --
 915    --------------
 916
 917    function Previous (Node : Node_Access) return Node_Access is
 918    begin
 919       if Node = null then
 920          return null;
 921       end if;
 922
 923       if Left (Node) /= null then
 924          return Max (Left (Node));
 925       end if;
 926
 927       declare
 928          X : Node_Access := Node;
 929          Y : Node_Access := Parent (Node);
 930
 931       begin
 932          while Y /= null
 933            and then X = Left (Y)
 934          loop
 935             X := Y;
 936             Y := Parent (Y);
 937          end loop;
 938
 939          return Y;
 940       end;
 941    end Previous;
 942
 943    --------------------------
 944    -- Rebalance_For_Insert --
 945    --------------------------
 946
 947    procedure Rebalance_For_Insert
 948      (Tree : in out Tree_Type;
 949       Node : Node_Access)
 950    is
 951       --  CLR p.268
 952
 953       X : Node_Access := Node;
 954       pragma Assert (X /= null);
 955       pragma Assert (Color (X) = Red);
 956
 957       Y : Node_Access;
 958
 959    begin
 960       while X /= Tree.Root and then Color (Parent (X)) = Red loop
 961          if Parent (X) = Left (Parent (Parent (X))) then
 962             Y := Right (Parent (Parent (X)));
 963
 964             if Y /= null and then Color (Y) = Red then
 965                Set_Color (Parent (X), Black);
 966                Set_Color (Y, Black);
 967                Set_Color (Parent (Parent (X)), Red);
 968                X := Parent (Parent (X));
 969
 970             else
 971                if X = Right (Parent (X)) then
 972                   X := Parent (X);
 973                   Left_Rotate (Tree, X);
 974                end if;
 975
 976                Set_Color (Parent (X), Black);
 977                Set_Color (Parent (Parent (X)), Red);
 978                Right_Rotate (Tree, Parent (Parent (X)));
 979             end if;
 980
 981          else
 982             pragma Assert (Parent (X) = Right (Parent (Parent (X))));
 983
 984             Y := Left (Parent (Parent (X)));
 985
 986             if Y /= null and then Color (Y) = Red then
 987                Set_Color (Parent (X), Black);
 988                Set_Color (Y, Black);
 989                Set_Color (Parent (Parent (X)), Red);
 990                X := Parent (Parent (X));
 991
 992             else
 993                if X = Left (Parent (X)) then
 994                   X := Parent (X);
 995                   Right_Rotate (Tree, X);
 996                end if;
 997
 998                Set_Color (Parent (X), Black);
 999                Set_Color (Parent (Parent (X)), Red);
1000                Left_Rotate (Tree, Parent (Parent (X)));
1001             end if;
1002          end if;
1003       end loop;
1004
1005       Set_Color (Tree.Root, Black);
1006    end Rebalance_For_Insert;
1007
1008    ------------------
1009    -- Right_Rotate --
1010    ------------------
1011
1012    procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access) is
1013       X : constant Node_Access := Left (Y);
1014       pragma Assert (X /= null);
1015
1016    begin
1017       Set_Left (Y, Right (X));
1018
1019       if Right (X) /= null then
1020          Set_Parent (Right (X), Y);
1021       end if;
1022
1023       Set_Parent (X, Parent (Y));
1024
1025       if Y = Tree.Root then
1026          Tree.Root := X;
1027       elsif Y = Left (Parent (Y)) then
1028          Set_Left (Parent (Y), X);
1029       else
1030          pragma Assert (Y = Right (Parent (Y)));
1031          Set_Right (Parent (Y), X);
1032       end if;
1033
1034       Set_Right (X, Y);
1035       Set_Parent (Y, X);
1036    end Right_Rotate;
1037
1038    ---------
1039    -- Vet --
1040    ---------
1041
1042    function Vet (Tree : Tree_Type; Node : Node_Access) return Boolean is
1043    begin
1044       if Node = null then
1045          return True;
1046       end if;
1047
1048       if Parent (Node) = Node
1049         or else Left (Node) = Node
1050         or else Right (Node) = Node
1051       then
1052          return False;
1053       end if;
1054
1055       if Tree.Length = 0
1056         or else Tree.Root = null
1057         or else Tree.First = null
1058         or else Tree.Last = null
1059       then
1060          return False;
1061       end if;
1062
1063       if Parent (Tree.Root) /= null then
1064          return False;
1065       end if;
1066
1067       if Left (Tree.First) /= null then
1068          return False;
1069       end if;
1070
1071       if Right (Tree.Last) /= null then
1072          return False;
1073       end if;
1074
1075       if Tree.Length = 1 then
1076          if Tree.First /= Tree.Last
1077            or else Tree.First /= Tree.Root
1078          then
1079             return False;
1080          end if;
1081
1082          if Node /= Tree.First then
1083             return False;
1084          end if;
1085
1086          if Parent (Node) /= null
1087            or else Left (Node) /= null
1088            or else Right (Node) /= null
1089          then
1090             return False;
1091          end if;
1092
1093          return True;
1094       end if;
1095
1096       if Tree.First = Tree.Last then
1097          return False;
1098       end if;
1099
1100       if Tree.Length = 2 then
1101          if Tree.First /= Tree.Root
1102            and then Tree.Last /= Tree.Root
1103          then
1104             return False;
1105          end if;
1106
1107          if Tree.First /= Node
1108            and then Tree.Last /= Node
1109          then
1110             return False;
1111          end if;
1112       end if;
1113
1114       if Left (Node) /= null
1115         and then Parent (Left (Node)) /= Node
1116       then
1117          return False;
1118       end if;
1119
1120       if Right (Node) /= null
1121         and then Parent (Right (Node)) /= Node
1122       then
1123          return False;
1124       end if;
1125
1126       if Parent (Node) = null then
1127          if Tree.Root /= Node then
1128             return False;
1129          end if;
1130
1131       elsif Left (Parent (Node)) /= Node
1132         and then Right (Parent (Node)) /= Node
1133       then
1134          return False;
1135       end if;
1136
1137       return True;
1138    end Vet;
1139
1140 end Ada.Containers.Red_Black_Trees.Generic_Operations;