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-2011, 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      L_Node : Count_Type;
610      R_Node : Count_Type;
611
612   begin
613      if Left'Address = Right'Address then
614         return True;
615      end if;
616
617      if Left.Length /= Right.Length then
618         return False;
619      end if;
620
621      L_Node := Left.First;
622      R_Node := Right.First;
623      while L_Node /= 0 loop
624         if not Is_Equal (Left.Nodes (L_Node), Right.Nodes (R_Node)) then
625            return False;
626         end if;
627
628         L_Node := Next (Left, L_Node);
629         R_Node := Next (Right, R_Node);
630      end loop;
631
632      return True;
633   end Generic_Equal;
634
635   -----------------------
636   -- Generic_Iteration --
637   -----------------------
638
639   procedure Generic_Iteration (Tree : Tree_Type'Class) is
640      procedure Iterate (P : Count_Type);
641
642      -------------
643      -- Iterate --
644      -------------
645
646      procedure Iterate (P : Count_Type) is
647         X : Count_Type := P;
648      begin
649         while X /= 0 loop
650            Iterate (Left (Tree.Nodes (X)));
651            Process (X);
652            X := Right (Tree.Nodes (X));
653         end loop;
654      end Iterate;
655
656   --  Start of processing for Generic_Iteration
657
658   begin
659      Iterate (Tree.Root);
660   end Generic_Iteration;
661
662   ------------------
663   -- Generic_Read --
664   ------------------
665
666   procedure Generic_Read
667     (Stream : not null access Root_Stream_Type'Class;
668      Tree   : in out Tree_Type'Class)
669   is
670      Len : Count_Type'Base;
671
672      Node, Last_Node : Count_Type;
673
674      N : Nodes_Type renames Tree.Nodes;
675
676   begin
677      Clear_Tree (Tree);
678      Count_Type'Base'Read (Stream, Len);
679
680      if Len < 0 then
681         raise Program_Error with "bad container length (corrupt stream)";
682      end if;
683
684      if Len = 0 then
685         return;
686      end if;
687
688      if Len > Tree.Capacity then
689         raise Constraint_Error with "length exceeds capacity";
690      end if;
691
692      --  Use Unconditional_Insert_With_Hint here instead ???
693
694      Allocate (Tree, Node);
695      pragma Assert (Node /= 0);
696
697      Set_Color (N (Node), Black);
698
699      Tree.Root   := Node;
700      Tree.First  := Node;
701      Tree.Last   := Node;
702      Tree.Length := 1;
703
704      for J in Count_Type range 2 .. Len loop
705         Last_Node := Node;
706         pragma Assert (Last_Node = Tree.Last);
707
708         Allocate (Tree, Node);
709         pragma Assert (Node /= 0);
710
711         Set_Color (N (Node), Red);
712         Set_Right (N (Last_Node), Right => Node);
713         Tree.Last := Node;
714         Set_Parent (N (Node), Parent => Last_Node);
715
716         Rebalance_For_Insert (Tree, Node);
717         Tree.Length := Tree.Length + 1;
718      end loop;
719   end Generic_Read;
720
721   -------------------------------
722   -- Generic_Reverse_Iteration --
723   -------------------------------
724
725   procedure Generic_Reverse_Iteration (Tree : Tree_Type'Class) is
726      procedure Iterate (P : Count_Type);
727
728      -------------
729      -- Iterate --
730      -------------
731
732      procedure Iterate (P : Count_Type) is
733         X : Count_Type := P;
734      begin
735         while X /= 0 loop
736            Iterate (Right (Tree.Nodes (X)));
737            Process (X);
738            X := Left (Tree.Nodes (X));
739         end loop;
740      end Iterate;
741
742   --  Start of processing for Generic_Reverse_Iteration
743
744   begin
745      Iterate (Tree.Root);
746   end Generic_Reverse_Iteration;
747
748   -------------------
749   -- Generic_Write --
750   -------------------
751
752   procedure Generic_Write
753     (Stream : not null access Root_Stream_Type'Class;
754      Tree   : Tree_Type'Class)
755   is
756      procedure Process (Node : Count_Type);
757      pragma Inline (Process);
758
759      procedure Iterate is new Generic_Iteration (Process);
760
761      -------------
762      -- Process --
763      -------------
764
765      procedure Process (Node : Count_Type) is
766      begin
767         Write_Node (Stream, Tree.Nodes (Node));
768      end Process;
769
770   --  Start of processing for Generic_Write
771
772   begin
773      Count_Type'Base'Write (Stream, Tree.Length);
774      Iterate (Tree);
775   end Generic_Write;
776
777   -----------------
778   -- Left_Rotate --
779   -----------------
780
781   procedure Left_Rotate (Tree : in out Tree_Type'Class; X : Count_Type) is
782      --  CLR p. 266
783
784      N : Nodes_Type renames Tree.Nodes;
785
786      Y : constant Count_Type := Right (N (X));
787      pragma Assert (Y /= 0);
788
789   begin
790      Set_Right (N (X), Left (N (Y)));
791
792      if Left (N (Y)) /= 0 then
793         Set_Parent (N (Left (N (Y))), X);
794      end if;
795
796      Set_Parent (N (Y), Parent (N (X)));
797
798      if X = Tree.Root then
799         Tree.Root := Y;
800      elsif X = Left (N (Parent (N (X)))) then
801         Set_Left (N (Parent (N (X))), Y);
802      else
803         pragma Assert (X = Right (N (Parent (N (X)))));
804         Set_Right (N (Parent (N (X))), Y);
805      end if;
806
807      Set_Left   (N (Y), X);
808      Set_Parent (N (X), Y);
809   end Left_Rotate;
810
811   ---------
812   -- Max --
813   ---------
814
815   function Max
816     (Tree : Tree_Type'Class;
817      Node : Count_Type) return Count_Type
818   is
819      --  CLR p. 248
820
821      X : Count_Type := Node;
822      Y : Count_Type;
823
824   begin
825      loop
826         Y := Right (Tree.Nodes (X));
827
828         if Y = 0 then
829            return X;
830         end if;
831
832         X := Y;
833      end loop;
834   end Max;
835
836   ---------
837   -- Min --
838   ---------
839
840   function Min
841     (Tree : Tree_Type'Class;
842      Node : Count_Type) return Count_Type
843   is
844      --  CLR p. 248
845
846      X : Count_Type := Node;
847      Y : Count_Type;
848
849   begin
850      loop
851         Y := Left (Tree.Nodes (X));
852
853         if Y = 0 then
854            return X;
855         end if;
856
857         X := Y;
858      end loop;
859   end Min;
860
861   ----------
862   -- Next --
863   ----------
864
865   function Next
866     (Tree : Tree_Type'Class;
867      Node : Count_Type) return Count_Type
868   is
869   begin
870      --  CLR p. 249
871
872      if Node = 0 then
873         return 0;
874      end if;
875
876      if Right (Tree.Nodes (Node)) /= 0 then
877         return Min (Tree, Right (Tree.Nodes (Node)));
878      end if;
879
880      declare
881         X : Count_Type := Node;
882         Y : Count_Type := Parent (Tree.Nodes (Node));
883
884      begin
885         while Y /= 0
886           and then X = Right (Tree.Nodes (Y))
887         loop
888            X := Y;
889            Y := Parent (Tree.Nodes (Y));
890         end loop;
891
892         return Y;
893      end;
894   end Next;
895
896   --------------
897   -- Previous --
898   --------------
899
900   function Previous
901     (Tree : Tree_Type'Class;
902      Node : Count_Type) return Count_Type
903   is
904   begin
905      if Node = 0 then
906         return 0;
907      end if;
908
909      if Left (Tree.Nodes (Node)) /= 0 then
910         return Max (Tree, Left (Tree.Nodes (Node)));
911      end if;
912
913      declare
914         X : Count_Type := Node;
915         Y : Count_Type := Parent (Tree.Nodes (Node));
916
917      begin
918         while Y /= 0
919           and then X = Left (Tree.Nodes (Y))
920         loop
921            X := Y;
922            Y := Parent (Tree.Nodes (Y));
923         end loop;
924
925         return Y;
926      end;
927   end Previous;
928
929   --------------------------
930   -- Rebalance_For_Insert --
931   --------------------------
932
933   procedure Rebalance_For_Insert
934     (Tree : in out Tree_Type'Class;
935      Node : Count_Type)
936   is
937      --  CLR p. 268
938
939      N : Nodes_Type renames Tree.Nodes;
940
941      X : Count_Type := Node;
942      pragma Assert (X /= 0);
943      pragma Assert (Color (N (X)) = Red);
944
945      Y : Count_Type;
946
947   begin
948      while X /= Tree.Root and then Color (N (Parent (N (X)))) = Red loop
949         if Parent (N (X)) = Left (N (Parent (N (Parent (N (X)))))) then
950            Y := Right (N (Parent (N (Parent (N (X))))));
951
952            if Y /= 0 and then Color (N (Y)) = Red then
953               Set_Color (N (Parent (N (X))), Black);
954               Set_Color (N (Y), Black);
955               Set_Color (N (Parent (N (Parent (N (X))))), Red);
956               X := Parent (N (Parent (N (X))));
957
958            else
959               if X = Right (N (Parent (N (X)))) then
960                  X := Parent (N (X));
961                  Left_Rotate (Tree, X);
962               end if;
963
964               Set_Color (N (Parent (N (X))), Black);
965               Set_Color (N (Parent (N (Parent (N (X))))), Red);
966               Right_Rotate (Tree, Parent (N (Parent (N (X)))));
967            end if;
968
969         else
970            pragma Assert (Parent (N (X)) =
971                             Right (N (Parent (N (Parent (N (X)))))));
972
973            Y := Left (N (Parent (N (Parent (N (X))))));
974
975            if Y /= 0 and then Color (N (Y)) = Red then
976               Set_Color (N (Parent (N (X))), Black);
977               Set_Color (N (Y), Black);
978               Set_Color (N (Parent (N (Parent (N (X))))), Red);
979               X := Parent (N (Parent (N (X))));
980
981            else
982               if X = Left (N (Parent (N (X)))) then
983                  X := Parent (N (X));
984                  Right_Rotate (Tree, X);
985               end if;
986
987               Set_Color (N (Parent (N (X))), Black);
988               Set_Color (N (Parent (N (Parent (N (X))))), Red);
989               Left_Rotate (Tree, Parent (N (Parent (N (X)))));
990            end if;
991         end if;
992      end loop;
993
994      Set_Color (N (Tree.Root), Black);
995   end Rebalance_For_Insert;
996
997   ------------------
998   -- Right_Rotate --
999   ------------------
1000
1001   procedure Right_Rotate (Tree : in out Tree_Type'Class; Y : Count_Type) is
1002      N : Nodes_Type renames Tree.Nodes;
1003
1004      X : constant Count_Type := Left (N (Y));
1005      pragma Assert (X /= 0);
1006
1007   begin
1008      Set_Left (N (Y), Right (N (X)));
1009
1010      if Right (N (X)) /= 0 then
1011         Set_Parent (N (Right (N (X))), Y);
1012      end if;
1013
1014      Set_Parent (N (X), Parent (N (Y)));
1015
1016      if Y = Tree.Root then
1017         Tree.Root := X;
1018      elsif Y = Left (N (Parent (N (Y)))) then
1019         Set_Left (N (Parent (N (Y))), X);
1020      else
1021         pragma Assert (Y = Right (N (Parent (N (Y)))));
1022         Set_Right (N (Parent (N (Y))), X);
1023      end if;
1024
1025      Set_Right  (N (X), Y);
1026      Set_Parent (N (Y), X);
1027   end Right_Rotate;
1028
1029   ---------
1030   -- Vet --
1031   ---------
1032
1033   function Vet (Tree : Tree_Type'Class; Index : Count_Type) return Boolean is
1034      Nodes : Nodes_Type renames Tree.Nodes;
1035      Node  : Node_Type renames Nodes (Index);
1036
1037   begin
1038      if Parent (Node) = Index
1039        or else Left (Node) = Index
1040        or else Right (Node) = Index
1041      then
1042         return False;
1043      end if;
1044
1045      if Tree.Length = 0
1046        or else Tree.Root = 0
1047        or else Tree.First = 0
1048        or else Tree.Last = 0
1049      then
1050         return False;
1051      end if;
1052
1053      if Parent (Nodes (Tree.Root)) /= 0 then
1054         return False;
1055      end if;
1056
1057      if Left (Nodes (Tree.First)) /= 0 then
1058         return False;
1059      end if;
1060
1061      if Right (Nodes (Tree.Last)) /= 0 then
1062         return False;
1063      end if;
1064
1065      if Tree.Length = 1 then
1066         if Tree.First /= Tree.Last
1067           or else Tree.First /= Tree.Root
1068         then
1069            return False;
1070         end if;
1071
1072         if Index /= Tree.First then
1073            return False;
1074         end if;
1075
1076         if Parent (Node) /= 0
1077           or else Left (Node) /= 0
1078           or else Right (Node) /= 0
1079         then
1080            return False;
1081         end if;
1082
1083         return True;
1084      end if;
1085
1086      if Tree.First = Tree.Last then
1087         return False;
1088      end if;
1089
1090      if Tree.Length = 2 then
1091         if Tree.First /= Tree.Root
1092           and then Tree.Last /= Tree.Root
1093         then
1094            return False;
1095         end if;
1096
1097         if Tree.First /= Index
1098           and then Tree.Last /= Index
1099         then
1100            return False;
1101         end if;
1102      end if;
1103
1104      if Left (Node) /= 0
1105        and then Parent (Nodes (Left (Node))) /= Index
1106      then
1107         return False;
1108      end if;
1109
1110      if Right (Node) /= 0
1111        and then Parent (Nodes (Right (Node))) /= Index
1112      then
1113         return False;
1114      end if;
1115
1116      if Parent (Node) = 0 then
1117         if Tree.Root /= Index then
1118            return False;
1119         end if;
1120
1121      elsif Left (Nodes (Parent (Node))) /= Index
1122        and then Right (Nodes (Parent (Node))) /= Index
1123      then
1124         return False;
1125      end if;
1126
1127      return True;
1128   end Vet;
1129
1130end Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations;
1131