1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT LIBRARY COMPONENTS                          --
4--                                                                          --
5--         ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_OPERATIONS        --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 2004-2013, Free Software Foundation, Inc.         --
10--                                                                          --
11-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12-- terms of the  GNU General Public License as published  by the Free Soft- --
13-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
17--                                                                          --
18-- As a special exception under Section 7 of GPL version 3, you are granted --
19-- additional permissions described in the GCC Runtime Library Exception,   --
20-- version 3.1, as published by the Free Software Foundation.               --
21--                                                                          --
22-- You should have received a copy of the GNU General Public License and    --
23-- a copy of the GCC Runtime Library Exception along with this program;     --
24-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25-- <http://www.gnu.org/licenses/>.                                          --
26--                                                                          --
27-- This unit was originally developed by Matthew J Heaney.                  --
28------------------------------------------------------------------------------
29
30--  The references below to "CLR" refer to the following book, from which
31--  several of the algorithms here were adapted:
32--     Introduction to Algorithms
33--     by Thomas H. Cormen, Charles E. Leiserson, Ronald L. Rivest
34--     Publisher: The MIT Press (June 18, 1990)
35--     ISBN: 0262031418
36
37with System;  use type System.Address;
38
39package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is
40
41   -----------------------
42   -- Local Subprograms --
43   -----------------------
44
45   procedure Delete_Fixup (Tree : in out Tree_Type'Class; Node : Count_Type);
46   procedure Delete_Swap (Tree : in out Tree_Type'Class; Z, Y : Count_Type);
47
48   procedure Left_Rotate  (Tree : in out Tree_Type'Class; X : Count_Type);
49   procedure Right_Rotate (Tree : in out Tree_Type'Class; Y : Count_Type);
50
51   ----------------
52   -- Clear_Tree --
53   ----------------
54
55   procedure Clear_Tree (Tree : in out Tree_Type'Class) is
56   begin
57      if Tree.Busy > 0 then
58         raise Program_Error with
59           "attempt to tamper with cursors (container is busy)";
60      end if;
61
62      --  The lock status (which monitors "element tampering") always implies
63      --  that the busy status (which monitors "cursor tampering") is set too;
64      --  this is a representation invariant. Thus if the busy bit is not set,
65      --  then the lock bit must not be set either.
66
67      pragma Assert (Tree.Lock = 0);
68
69      Tree.First  := 0;
70      Tree.Last   := 0;
71      Tree.Root   := 0;
72      Tree.Length := 0;
73      Tree.Free   := -1;
74   end Clear_Tree;
75
76   ------------------
77   -- Delete_Fixup --
78   ------------------
79
80   procedure Delete_Fixup
81     (Tree : in out Tree_Type'Class;
82      Node : Count_Type)
83   is
84      --  CLR p. 274
85
86      X : Count_Type;
87      W : Count_Type;
88      N : Nodes_Type renames Tree.Nodes;
89
90   begin
91      X := Node;
92      while X /= Tree.Root
93        and then Color (N (X)) = Black
94      loop
95         if X = Left (N (Parent (N (X)))) then
96            W :=  Right (N (Parent (N (X))));
97
98            if Color (N (W)) = Red then
99               Set_Color (N (W), Black);
100               Set_Color (N (Parent (N (X))), Red);
101               Left_Rotate (Tree, Parent (N (X)));
102               W := Right (N (Parent (N (X))));
103            end if;
104
105            if (Left (N (W))  = 0 or else Color (N (Left (N (W)))) = Black)
106              and then
107               (Right (N (W)) = 0 or else Color (N (Right (N (W)))) = Black)
108            then
109               Set_Color (N (W), Red);
110               X := Parent (N (X));
111
112            else
113               if Right (N (W)) = 0
114                 or else Color (N (Right (N (W)))) = Black
115               then
116                  --  As a condition for setting the color of the left child to
117                  --  black, the left child access value must be non-null. A
118                  --  truth table analysis shows that if we arrive here, that
119                  --  condition holds, so there's no need for an explicit test.
120                  --  The assertion is here to document what we know is true.
121
122                  pragma Assert (Left (N (W)) /= 0);
123                  Set_Color (N (Left (N (W))), Black);
124
125                  Set_Color (N (W), Red);
126                  Right_Rotate (Tree, W);
127                  W := Right (N (Parent (N (X))));
128               end if;
129
130               Set_Color (N (W), Color (N (Parent (N (X)))));
131               Set_Color (N (Parent (N (X))), Black);
132               Set_Color (N (Right (N (W))), Black);
133               Left_Rotate  (Tree, Parent (N (X)));
134               X := Tree.Root;
135            end if;
136
137         else
138            pragma Assert (X = Right (N (Parent (N (X)))));
139
140            W :=  Left (N (Parent (N (X))));
141
142            if Color (N (W)) = Red then
143               Set_Color (N (W), Black);
144               Set_Color (N (Parent (N (X))), Red);
145               Right_Rotate (Tree, Parent (N (X)));
146               W := Left (N (Parent (N (X))));
147            end if;
148
149            if (Left (N (W))  = 0 or else Color (N (Left (N (W)))) = Black)
150                 and then
151               (Right (N (W)) = 0 or else Color (N (Right (N (W)))) = Black)
152            then
153               Set_Color (N (W), Red);
154               X := Parent (N (X));
155
156            else
157               if Left (N (W)) = 0
158                 or else Color (N (Left (N (W)))) = Black
159               then
160                  --  As a condition for setting the color of the right child
161                  --  to black, the right child access value must be non-null.
162                  --  A truth table analysis shows that if we arrive here, that
163                  --  condition holds, so there's no need for an explicit test.
164                  --  The assertion is here to document what we know is true.
165
166                  pragma Assert (Right (N (W)) /= 0);
167                  Set_Color (N (Right (N (W))), Black);
168
169                  Set_Color (N (W), Red);
170                  Left_Rotate (Tree, W);
171                  W := Left (N (Parent (N (X))));
172               end if;
173
174               Set_Color (N (W), Color (N (Parent (N (X)))));
175               Set_Color (N (Parent (N (X))), Black);
176               Set_Color (N (Left (N (W))), Black);
177               Right_Rotate (Tree, Parent (N (X)));
178               X := Tree.Root;
179            end if;
180         end if;
181      end loop;
182
183      Set_Color (N (X), Black);
184   end Delete_Fixup;
185
186   ---------------------------
187   -- Delete_Node_Sans_Free --
188   ---------------------------
189
190   procedure Delete_Node_Sans_Free
191     (Tree : in out Tree_Type'Class;
192      Node : Count_Type)
193   is
194      --  CLR p. 273
195
196      X, Y : Count_Type;
197
198      Z : constant Count_Type := Node;
199      pragma Assert (Z /= 0);
200
201      N : Nodes_Type renames Tree.Nodes;
202
203   begin
204      if Tree.Busy > 0 then
205         raise Program_Error with
206           "attempt to tamper with cursors (container is busy)";
207      end if;
208
209      pragma Assert (Tree.Length > 0);
210      pragma Assert (Tree.Root  /= 0);
211      pragma Assert (Tree.First /= 0);
212      pragma Assert (Tree.Last  /= 0);
213      pragma Assert (Parent (N (Tree.Root)) = 0);
214
215      pragma Assert ((Tree.Length > 1)
216                        or else (Tree.First = Tree.Last
217                                   and then Tree.First = Tree.Root));
218
219      pragma Assert ((Left (N (Node)) = 0)
220                        or else (Parent (N (Left (N (Node)))) = Node));
221
222      pragma Assert ((Right (N (Node)) = 0)
223                        or else (Parent (N (Right (N (Node)))) = Node));
224
225      pragma Assert (((Parent (N (Node)) = 0) and then (Tree.Root = Node))
226                        or else ((Parent (N (Node)) /= 0) and then
227                                  ((Left (N (Parent (N (Node)))) = Node)
228                                      or else
229                                   (Right (N (Parent (N (Node)))) = Node))));
230
231      if Left (N (Z)) = 0 then
232         if Right (N (Z)) = 0 then
233            if Z = Tree.First then
234               Tree.First := Parent (N (Z));
235            end if;
236
237            if Z = Tree.Last then
238               Tree.Last := Parent (N (Z));
239            end if;
240
241            if Color (N (Z)) = Black then
242               Delete_Fixup (Tree, Z);
243            end if;
244
245            pragma Assert (Left (N (Z)) = 0);
246            pragma Assert (Right (N (Z)) = 0);
247
248            if Z = Tree.Root then
249               pragma Assert (Tree.Length = 1);
250               pragma Assert (Parent (N (Z)) = 0);
251               Tree.Root := 0;
252            elsif Z = Left (N (Parent (N (Z)))) then
253               Set_Left (N (Parent (N (Z))), 0);
254            else
255               pragma Assert (Z = Right (N (Parent (N (Z)))));
256               Set_Right (N (Parent (N (Z))), 0);
257            end if;
258
259         else
260            pragma Assert (Z /= Tree.Last);
261
262            X := Right (N (Z));
263
264            if Z = Tree.First then
265               Tree.First := Min (Tree, X);
266            end if;
267
268            if Z = Tree.Root then
269               Tree.Root := X;
270            elsif Z = Left (N (Parent (N (Z)))) then
271               Set_Left (N (Parent (N (Z))), X);
272            else
273               pragma Assert (Z = Right (N (Parent (N (Z)))));
274               Set_Right (N (Parent (N (Z))), X);
275            end if;
276
277            Set_Parent (N (X), Parent (N (Z)));
278
279            if Color (N (Z)) = Black then
280               Delete_Fixup (Tree, X);
281            end if;
282         end if;
283
284      elsif Right (N (Z)) = 0 then
285         pragma Assert (Z /= Tree.First);
286
287         X := Left (N (Z));
288
289         if Z = Tree.Last then
290            Tree.Last := Max (Tree, X);
291         end if;
292
293         if Z = Tree.Root then
294            Tree.Root := X;
295         elsif Z = Left (N (Parent (N (Z)))) then
296            Set_Left (N (Parent (N (Z))), X);
297         else
298            pragma Assert (Z = Right (N (Parent (N (Z)))));
299            Set_Right (N (Parent (N (Z))), X);
300         end if;
301
302         Set_Parent (N (X), Parent (N (Z)));
303
304         if Color (N (Z)) = Black then
305            Delete_Fixup (Tree, X);
306         end if;
307
308      else
309         pragma Assert (Z /= Tree.First);
310         pragma Assert (Z /= Tree.Last);
311
312         Y := Next (Tree, Z);
313         pragma Assert (Left (N (Y)) = 0);
314
315         X := Right (N (Y));
316
317         if X = 0 then
318            if Y = Left (N (Parent (N (Y)))) then
319               pragma Assert (Parent (N (Y)) /= Z);
320               Delete_Swap (Tree, Z, Y);
321               Set_Left (N (Parent (N (Z))), Z);
322
323            else
324               pragma Assert (Y = Right (N (Parent (N (Y)))));
325               pragma Assert (Parent (N (Y)) = Z);
326               Set_Parent (N (Y), Parent (N (Z)));
327
328               if Z = Tree.Root then
329                  Tree.Root := Y;
330               elsif Z = Left (N (Parent (N (Z)))) then
331                  Set_Left (N (Parent (N (Z))), Y);
332               else
333                  pragma Assert (Z = Right (N (Parent (N (Z)))));
334                  Set_Right (N (Parent (N (Z))), Y);
335               end if;
336
337               Set_Left   (N (Y), Left (N (Z)));
338               Set_Parent (N (Left (N (Y))), Y);
339               Set_Right  (N (Y), Z);
340
341               Set_Parent (N (Z), Y);
342               Set_Left   (N (Z), 0);
343               Set_Right  (N (Z), 0);
344
345               declare
346                  Y_Color : constant Color_Type := Color (N (Y));
347               begin
348                  Set_Color (N (Y), Color (N (Z)));
349                  Set_Color (N (Z), Y_Color);
350               end;
351            end if;
352
353            if Color (N (Z)) = Black then
354               Delete_Fixup (Tree, Z);
355            end if;
356
357            pragma Assert (Left (N (Z)) = 0);
358            pragma Assert (Right (N (Z)) = 0);
359
360            if Z = Right (N (Parent (N (Z)))) then
361               Set_Right (N (Parent (N (Z))), 0);
362            else
363               pragma Assert (Z = Left (N (Parent (N (Z)))));
364               Set_Left (N (Parent (N (Z))), 0);
365            end if;
366
367         else
368            if Y = Left (N (Parent (N (Y)))) then
369               pragma Assert (Parent (N (Y)) /= Z);
370
371               Delete_Swap (Tree, Z, Y);
372
373               Set_Left (N (Parent (N (Z))), X);
374               Set_Parent (N (X), Parent (N (Z)));
375
376            else
377               pragma Assert (Y = Right (N (Parent (N (Y)))));
378               pragma Assert (Parent (N (Y)) = Z);
379
380               Set_Parent (N (Y), Parent (N (Z)));
381
382               if Z = Tree.Root then
383                  Tree.Root := Y;
384               elsif Z = Left (N (Parent (N (Z)))) then
385                  Set_Left (N (Parent (N (Z))), Y);
386               else
387                  pragma Assert (Z = Right (N (Parent (N (Z)))));
388                  Set_Right (N (Parent (N (Z))), Y);
389               end if;
390
391               Set_Left (N (Y), Left (N (Z)));
392               Set_Parent (N (Left (N (Y))), Y);
393
394               declare
395                  Y_Color : constant Color_Type := Color (N (Y));
396               begin
397                  Set_Color (N (Y), Color (N (Z)));
398                  Set_Color (N (Z), Y_Color);
399               end;
400            end if;
401
402            if Color (N (Z)) = Black then
403               Delete_Fixup (Tree, X);
404            end if;
405         end if;
406      end if;
407
408      Tree.Length := Tree.Length - 1;
409   end Delete_Node_Sans_Free;
410
411   -----------------
412   -- Delete_Swap --
413   -----------------
414
415   procedure Delete_Swap
416     (Tree : in out Tree_Type'Class;
417      Z, Y : Count_Type)
418   is
419      N : Nodes_Type renames Tree.Nodes;
420
421      pragma Assert (Z /= Y);
422      pragma Assert (Parent (N (Y)) /= Z);
423
424      Y_Parent : constant Count_Type := Parent (N (Y));
425      Y_Color  : constant Color_Type := Color (N (Y));
426
427   begin
428      Set_Parent (N (Y), Parent (N (Z)));
429      Set_Left   (N (Y), Left   (N (Z)));
430      Set_Right  (N (Y), Right  (N (Z)));
431      Set_Color  (N (Y), Color  (N (Z)));
432
433      if Tree.Root = Z then
434         Tree.Root := Y;
435      elsif Right (N (Parent (N (Y)))) = Z then
436         Set_Right (N (Parent (N (Y))), Y);
437      else
438         pragma Assert (Left (N (Parent (N (Y)))) = Z);
439         Set_Left (N (Parent (N (Y))), Y);
440      end if;
441
442      if Right (N (Y)) /= 0 then
443         Set_Parent (N (Right (N (Y))), Y);
444      end if;
445
446      if Left (N (Y)) /= 0 then
447         Set_Parent (N (Left (N (Y))), Y);
448      end if;
449
450      Set_Parent (N (Z), Y_Parent);
451      Set_Color  (N (Z), Y_Color);
452      Set_Left   (N (Z), 0);
453      Set_Right  (N (Z), 0);
454   end Delete_Swap;
455
456   ----------
457   -- Free --
458   ----------
459
460   procedure Free (Tree : in out Tree_Type'Class; X : Count_Type) is
461      pragma Assert (X > 0);
462      pragma Assert (X <= Tree.Capacity);
463
464      N : Nodes_Type renames Tree.Nodes;
465      --  pragma Assert (N (X).Prev >= 0);  -- node is active
466      --  Find a way to mark a node as active vs. inactive; we could
467      --  use a special value in Color_Type for this.  ???
468
469   begin
470      --  The set container actually contains two data structures: a list for
471      --  the "active" nodes that contain elements that have been inserted
472      --  onto the tree, and another for the "inactive" nodes of the free
473      --  store.
474      --
475      --  We desire that merely declaring an object should have only minimal
476      --  cost; specially, we want to avoid having to initialize the free
477      --  store (to fill in the links), especially if the capacity is large.
478      --
479      --  The head of the free list is indicated by Container.Free. If its
480      --  value is non-negative, then the free store has been initialized
481      --  in the "normal" way: Container.Free points to the head of the list
482      --  of free (inactive) nodes, and the value 0 means the free list is
483      --  empty. Each node on the free list has been initialized to point
484      --  to the next free node (via its Parent component), and the value 0
485      --  means that this is the last free node.
486      --
487      --  If Container.Free is negative, then the links on the free store
488      --  have not been initialized. In this case the link values are
489      --  implied: the free store comprises the components of the node array
490      --  started with the absolute value of Container.Free, and continuing
491      --  until the end of the array (Nodes'Last).
492      --
493      --  ???
494      --  It might be possible to perform an optimization here. Suppose that
495      --  the free store can be represented as having two parts: one
496      --  comprising the non-contiguous inactive nodes linked together
497      --  in the normal way, and the other comprising the contiguous
498      --  inactive nodes (that are not linked together, at the end of the
499      --  nodes array). This would allow us to never have to initialize
500      --  the free store, except in a lazy way as nodes become inactive.
501
502      --  When an element is deleted from the list container, its node
503      --  becomes inactive, and so we set its Prev component to a negative
504      --  value, to indicate that it is now inactive. This provides a useful
505      --  way to detect a dangling cursor reference.
506
507      --  The comment above is incorrect; we need some other way to
508      --  indicate a node is inactive, for example by using a special
509      --  Color_Type value.  ???
510      --  N (X).Prev := -1;  -- Node is deallocated (not on active list)
511
512      if Tree.Free >= 0 then
513         --  The free store has previously been initialized. All we need to
514         --  do here is link the newly-free'd node onto the free list.
515
516         Set_Parent (N (X), Tree.Free);
517         Tree.Free := X;
518
519      elsif X + 1 = abs Tree.Free then
520         --  The free store has not been initialized, and the node becoming
521         --  inactive immediately precedes the start of the free store. All
522         --  we need to do is move the start of the free store back by one.
523
524         Tree.Free := Tree.Free + 1;
525
526      else
527         --  The free store has not been initialized, and the node becoming
528         --  inactive does not immediately precede the free store. Here we
529         --  first initialize the free store (meaning the links are given
530         --  values in the traditional way), and then link the newly-free'd
531         --  node onto the head of the free store.
532
533         --  ???
534         --  See the comments above for an optimization opportunity. If the
535         --  next link for a node on the free store is negative, then this
536         --  means the remaining nodes on the free store are physically
537         --  contiguous, starting as the absolute value of that index value.
538
539         Tree.Free := abs Tree.Free;
540
541         if Tree.Free > Tree.Capacity then
542            Tree.Free := 0;
543
544         else
545            for I in Tree.Free .. Tree.Capacity - 1 loop
546               Set_Parent (N (I), I + 1);
547            end loop;
548
549            Set_Parent (N (Tree.Capacity), 0);
550         end if;
551
552         Set_Parent (N (X), Tree.Free);
553         Tree.Free := X;
554      end if;
555   end Free;
556
557   -----------------------
558   -- Generic_Allocate --
559   -----------------------
560
561   procedure Generic_Allocate
562     (Tree : in out Tree_Type'Class;
563      Node : out Count_Type)
564   is
565      N : Nodes_Type renames Tree.Nodes;
566
567   begin
568      if Tree.Free >= 0 then
569         Node := Tree.Free;
570
571         --  We always perform the assignment first, before we
572         --  change container state, in order to defend against
573         --  exceptions duration assignment.
574
575         Set_Element (N (Node));
576         Tree.Free := Parent (N (Node));
577
578      else
579         --  A negative free store value means that the links of the nodes
580         --  in the free store have not been initialized. In this case, the
581         --  nodes are physically contiguous in the array, starting at the
582         --  index that is the absolute value of the Container.Free, and
583         --  continuing until the end of the array (Nodes'Last).
584
585         Node := abs Tree.Free;
586
587         --  As above, we perform this assignment first, before modifying
588         --  any container state.
589
590         Set_Element (N (Node));
591         Tree.Free := Tree.Free - 1;
592      end if;
593
594      --  When a node is allocated from the free store, its pointer components
595      --  (the links to other nodes in the tree) must also be initialized (to
596      --  0, the equivalent of null). This simplifies the post-allocation
597      --  handling of nodes inserted into terminal positions.
598
599      Set_Parent (N (Node), Parent => 0);
600      Set_Left   (N (Node), Left   => 0);
601      Set_Right  (N (Node), Right  => 0);
602   end Generic_Allocate;
603
604   -------------------
605   -- Generic_Equal --
606   -------------------
607
608   function Generic_Equal (Left, Right : Tree_Type'Class) return Boolean is
609      BL : Natural renames Left'Unrestricted_Access.Busy;
610      LL : Natural renames Left'Unrestricted_Access.Lock;
611
612      BR : Natural renames Right'Unrestricted_Access.Busy;
613      LR : Natural renames Right'Unrestricted_Access.Lock;
614
615      L_Node : Count_Type;
616      R_Node : Count_Type;
617
618      Result : Boolean;
619
620   begin
621      if Left'Address = Right'Address then
622         return True;
623      end if;
624
625      if Left.Length /= Right.Length then
626         return False;
627      end if;
628
629      --  If the containers are empty, return a result immediately, so as to
630      --  not manipulate the tamper bits unnecessarily.
631
632      if Left.Length = 0 then
633         return True;
634      end if;
635
636      --  Per AI05-0022, the container implementation is required to detect
637      --  element tampering by a generic actual subprogram.
638
639      BL := BL + 1;
640      LL := LL + 1;
641
642      BR := BR + 1;
643      LR := LR + 1;
644
645      L_Node := Left.First;
646      R_Node := Right.First;
647      Result := True;
648      while L_Node /= 0 loop
649         if not Is_Equal (Left.Nodes (L_Node), Right.Nodes (R_Node)) then
650            Result := False;
651            exit;
652         end if;
653
654         L_Node := Next (Left, L_Node);
655         R_Node := Next (Right, R_Node);
656      end loop;
657
658      BL := BL - 1;
659      LL := LL - 1;
660
661      BR := BR - 1;
662      LR := LR - 1;
663
664      return Result;
665
666   exception
667      when others =>
668         BL := BL - 1;
669         LL := LL - 1;
670
671         BR := BR - 1;
672         LR := LR - 1;
673
674         raise;
675   end Generic_Equal;
676
677   -----------------------
678   -- Generic_Iteration --
679   -----------------------
680
681   procedure Generic_Iteration (Tree : Tree_Type'Class) is
682      procedure Iterate (P : Count_Type);
683
684      -------------
685      -- Iterate --
686      -------------
687
688      procedure Iterate (P : Count_Type) is
689         X : Count_Type := P;
690      begin
691         while X /= 0 loop
692            Iterate (Left (Tree.Nodes (X)));
693            Process (X);
694            X := Right (Tree.Nodes (X));
695         end loop;
696      end Iterate;
697
698   --  Start of processing for Generic_Iteration
699
700   begin
701      Iterate (Tree.Root);
702   end Generic_Iteration;
703
704   ------------------
705   -- Generic_Read --
706   ------------------
707
708   procedure Generic_Read
709     (Stream : not null access Root_Stream_Type'Class;
710      Tree   : in out Tree_Type'Class)
711   is
712      Len : Count_Type'Base;
713
714      Node, Last_Node : Count_Type;
715
716      N : Nodes_Type renames Tree.Nodes;
717
718   begin
719      Clear_Tree (Tree);
720      Count_Type'Base'Read (Stream, Len);
721
722      if Len < 0 then
723         raise Program_Error with "bad container length (corrupt stream)";
724      end if;
725
726      if Len = 0 then
727         return;
728      end if;
729
730      if Len > Tree.Capacity then
731         raise Constraint_Error with "length exceeds capacity";
732      end if;
733
734      --  Use Unconditional_Insert_With_Hint here instead ???
735
736      Allocate (Tree, Node);
737      pragma Assert (Node /= 0);
738
739      Set_Color (N (Node), Black);
740
741      Tree.Root   := Node;
742      Tree.First  := Node;
743      Tree.Last   := Node;
744      Tree.Length := 1;
745
746      for J in Count_Type range 2 .. Len loop
747         Last_Node := Node;
748         pragma Assert (Last_Node = Tree.Last);
749
750         Allocate (Tree, Node);
751         pragma Assert (Node /= 0);
752
753         Set_Color (N (Node), Red);
754         Set_Right (N (Last_Node), Right => Node);
755         Tree.Last := Node;
756         Set_Parent (N (Node), Parent => Last_Node);
757
758         Rebalance_For_Insert (Tree, Node);
759         Tree.Length := Tree.Length + 1;
760      end loop;
761   end Generic_Read;
762
763   -------------------------------
764   -- Generic_Reverse_Iteration --
765   -------------------------------
766
767   procedure Generic_Reverse_Iteration (Tree : Tree_Type'Class) is
768      procedure Iterate (P : Count_Type);
769
770      -------------
771      -- Iterate --
772      -------------
773
774      procedure Iterate (P : Count_Type) is
775         X : Count_Type := P;
776      begin
777         while X /= 0 loop
778            Iterate (Right (Tree.Nodes (X)));
779            Process (X);
780            X := Left (Tree.Nodes (X));
781         end loop;
782      end Iterate;
783
784   --  Start of processing for Generic_Reverse_Iteration
785
786   begin
787      Iterate (Tree.Root);
788   end Generic_Reverse_Iteration;
789
790   -------------------
791   -- Generic_Write --
792   -------------------
793
794   procedure Generic_Write
795     (Stream : not null access Root_Stream_Type'Class;
796      Tree   : Tree_Type'Class)
797   is
798      procedure Process (Node : Count_Type);
799      pragma Inline (Process);
800
801      procedure Iterate is new Generic_Iteration (Process);
802
803      -------------
804      -- Process --
805      -------------
806
807      procedure Process (Node : Count_Type) is
808      begin
809         Write_Node (Stream, Tree.Nodes (Node));
810      end Process;
811
812   --  Start of processing for Generic_Write
813
814   begin
815      Count_Type'Base'Write (Stream, Tree.Length);
816      Iterate (Tree);
817   end Generic_Write;
818
819   -----------------
820   -- Left_Rotate --
821   -----------------
822
823   procedure Left_Rotate (Tree : in out Tree_Type'Class; X : Count_Type) is
824      --  CLR p. 266
825
826      N : Nodes_Type renames Tree.Nodes;
827
828      Y : constant Count_Type := Right (N (X));
829      pragma Assert (Y /= 0);
830
831   begin
832      Set_Right (N (X), Left (N (Y)));
833
834      if Left (N (Y)) /= 0 then
835         Set_Parent (N (Left (N (Y))), X);
836      end if;
837
838      Set_Parent (N (Y), Parent (N (X)));
839
840      if X = Tree.Root then
841         Tree.Root := Y;
842      elsif X = Left (N (Parent (N (X)))) then
843         Set_Left (N (Parent (N (X))), Y);
844      else
845         pragma Assert (X = Right (N (Parent (N (X)))));
846         Set_Right (N (Parent (N (X))), Y);
847      end if;
848
849      Set_Left   (N (Y), X);
850      Set_Parent (N (X), Y);
851   end Left_Rotate;
852
853   ---------
854   -- Max --
855   ---------
856
857   function Max
858     (Tree : Tree_Type'Class;
859      Node : Count_Type) return Count_Type
860   is
861      --  CLR p. 248
862
863      X : Count_Type := Node;
864      Y : Count_Type;
865
866   begin
867      loop
868         Y := Right (Tree.Nodes (X));
869
870         if Y = 0 then
871            return X;
872         end if;
873
874         X := Y;
875      end loop;
876   end Max;
877
878   ---------
879   -- Min --
880   ---------
881
882   function Min
883     (Tree : Tree_Type'Class;
884      Node : Count_Type) return Count_Type
885   is
886      --  CLR p. 248
887
888      X : Count_Type := Node;
889      Y : Count_Type;
890
891   begin
892      loop
893         Y := Left (Tree.Nodes (X));
894
895         if Y = 0 then
896            return X;
897         end if;
898
899         X := Y;
900      end loop;
901   end Min;
902
903   ----------
904   -- Next --
905   ----------
906
907   function Next
908     (Tree : Tree_Type'Class;
909      Node : Count_Type) return Count_Type
910   is
911   begin
912      --  CLR p. 249
913
914      if Node = 0 then
915         return 0;
916      end if;
917
918      if Right (Tree.Nodes (Node)) /= 0 then
919         return Min (Tree, Right (Tree.Nodes (Node)));
920      end if;
921
922      declare
923         X : Count_Type := Node;
924         Y : Count_Type := Parent (Tree.Nodes (Node));
925
926      begin
927         while Y /= 0
928           and then X = Right (Tree.Nodes (Y))
929         loop
930            X := Y;
931            Y := Parent (Tree.Nodes (Y));
932         end loop;
933
934         return Y;
935      end;
936   end Next;
937
938   --------------
939   -- Previous --
940   --------------
941
942   function Previous
943     (Tree : Tree_Type'Class;
944      Node : Count_Type) return Count_Type
945   is
946   begin
947      if Node = 0 then
948         return 0;
949      end if;
950
951      if Left (Tree.Nodes (Node)) /= 0 then
952         return Max (Tree, Left (Tree.Nodes (Node)));
953      end if;
954
955      declare
956         X : Count_Type := Node;
957         Y : Count_Type := Parent (Tree.Nodes (Node));
958
959      begin
960         while Y /= 0
961           and then X = Left (Tree.Nodes (Y))
962         loop
963            X := Y;
964            Y := Parent (Tree.Nodes (Y));
965         end loop;
966
967         return Y;
968      end;
969   end Previous;
970
971   --------------------------
972   -- Rebalance_For_Insert --
973   --------------------------
974
975   procedure Rebalance_For_Insert
976     (Tree : in out Tree_Type'Class;
977      Node : Count_Type)
978   is
979      --  CLR p. 268
980
981      N : Nodes_Type renames Tree.Nodes;
982
983      X : Count_Type := Node;
984      pragma Assert (X /= 0);
985      pragma Assert (Color (N (X)) = Red);
986
987      Y : Count_Type;
988
989   begin
990      while X /= Tree.Root and then Color (N (Parent (N (X)))) = Red loop
991         if Parent (N (X)) = Left (N (Parent (N (Parent (N (X)))))) then
992            Y := Right (N (Parent (N (Parent (N (X))))));
993
994            if Y /= 0 and then Color (N (Y)) = Red then
995               Set_Color (N (Parent (N (X))), Black);
996               Set_Color (N (Y), Black);
997               Set_Color (N (Parent (N (Parent (N (X))))), Red);
998               X := Parent (N (Parent (N (X))));
999
1000            else
1001               if X = Right (N (Parent (N (X)))) then
1002                  X := Parent (N (X));
1003                  Left_Rotate (Tree, X);
1004               end if;
1005
1006               Set_Color (N (Parent (N (X))), Black);
1007               Set_Color (N (Parent (N (Parent (N (X))))), Red);
1008               Right_Rotate (Tree, Parent (N (Parent (N (X)))));
1009            end if;
1010
1011         else
1012            pragma Assert (Parent (N (X)) =
1013                             Right (N (Parent (N (Parent (N (X)))))));
1014
1015            Y := Left (N (Parent (N (Parent (N (X))))));
1016
1017            if Y /= 0 and then Color (N (Y)) = Red then
1018               Set_Color (N (Parent (N (X))), Black);
1019               Set_Color (N (Y), Black);
1020               Set_Color (N (Parent (N (Parent (N (X))))), Red);
1021               X := Parent (N (Parent (N (X))));
1022
1023            else
1024               if X = Left (N (Parent (N (X)))) then
1025                  X := Parent (N (X));
1026                  Right_Rotate (Tree, X);
1027               end if;
1028
1029               Set_Color (N (Parent (N (X))), Black);
1030               Set_Color (N (Parent (N (Parent (N (X))))), Red);
1031               Left_Rotate (Tree, Parent (N (Parent (N (X)))));
1032            end if;
1033         end if;
1034      end loop;
1035
1036      Set_Color (N (Tree.Root), Black);
1037   end Rebalance_For_Insert;
1038
1039   ------------------
1040   -- Right_Rotate --
1041   ------------------
1042
1043   procedure Right_Rotate (Tree : in out Tree_Type'Class; Y : Count_Type) is
1044      N : Nodes_Type renames Tree.Nodes;
1045
1046      X : constant Count_Type := Left (N (Y));
1047      pragma Assert (X /= 0);
1048
1049   begin
1050      Set_Left (N (Y), Right (N (X)));
1051
1052      if Right (N (X)) /= 0 then
1053         Set_Parent (N (Right (N (X))), Y);
1054      end if;
1055
1056      Set_Parent (N (X), Parent (N (Y)));
1057
1058      if Y = Tree.Root then
1059         Tree.Root := X;
1060      elsif Y = Left (N (Parent (N (Y)))) then
1061         Set_Left (N (Parent (N (Y))), X);
1062      else
1063         pragma Assert (Y = Right (N (Parent (N (Y)))));
1064         Set_Right (N (Parent (N (Y))), X);
1065      end if;
1066
1067      Set_Right  (N (X), Y);
1068      Set_Parent (N (Y), X);
1069   end Right_Rotate;
1070
1071   ---------
1072   -- Vet --
1073   ---------
1074
1075   function Vet (Tree : Tree_Type'Class; Index : Count_Type) return Boolean is
1076      Nodes : Nodes_Type renames Tree.Nodes;
1077      Node  : Node_Type renames Nodes (Index);
1078
1079   begin
1080      if Parent (Node) = Index
1081        or else Left (Node) = Index
1082        or else Right (Node) = Index
1083      then
1084         return False;
1085      end if;
1086
1087      if Tree.Length = 0
1088        or else Tree.Root = 0
1089        or else Tree.First = 0
1090        or else Tree.Last = 0
1091      then
1092         return False;
1093      end if;
1094
1095      if Parent (Nodes (Tree.Root)) /= 0 then
1096         return False;
1097      end if;
1098
1099      if Left (Nodes (Tree.First)) /= 0 then
1100         return False;
1101      end if;
1102
1103      if Right (Nodes (Tree.Last)) /= 0 then
1104         return False;
1105      end if;
1106
1107      if Tree.Length = 1 then
1108         if Tree.First /= Tree.Last
1109           or else Tree.First /= Tree.Root
1110         then
1111            return False;
1112         end if;
1113
1114         if Index /= Tree.First then
1115            return False;
1116         end if;
1117
1118         if Parent (Node) /= 0
1119           or else Left (Node) /= 0
1120           or else Right (Node) /= 0
1121         then
1122            return False;
1123         end if;
1124
1125         return True;
1126      end if;
1127
1128      if Tree.First = Tree.Last then
1129         return False;
1130      end if;
1131
1132      if Tree.Length = 2 then
1133         if Tree.First /= Tree.Root
1134           and then Tree.Last /= Tree.Root
1135         then
1136            return False;
1137         end if;
1138
1139         if Tree.First /= Index
1140           and then Tree.Last /= Index
1141         then
1142            return False;
1143         end if;
1144      end if;
1145
1146      if Left (Node) /= 0
1147        and then Parent (Nodes (Left (Node))) /= Index
1148      then
1149         return False;
1150      end if;
1151
1152      if Right (Node) /= 0
1153        and then Parent (Nodes (Right (Node))) /= Index
1154      then
1155         return False;
1156      end if;
1157
1158      if Parent (Node) = 0 then
1159         if Tree.Root /= Index then
1160            return False;
1161         end if;
1162
1163      elsif Left (Nodes (Parent (Node))) /= Index
1164        and then Right (Nodes (Parent (Node))) /= Index
1165      then
1166         return False;
1167      end if;
1168
1169      return True;
1170   end Vet;
1171
1172end Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations;
1173