1--  Copyright 1994 Grady Booch
2--  Copyright 1994-1997 David Weller
3--  Copyright 1998-2014 Simon Wright <simon@pushface.org>
4
5--  This package is free software; you can redistribute it and/or
6--  modify it under terms of the GNU General Public License as
7--  published by the Free Software Foundation; either version 2, or
8--  (at your option) any later version. This package is distributed in
9--  the hope that it will be useful, but WITHOUT ANY WARRANTY; without
10--  even the implied warranty of MERCHANTABILITY or FITNESS FOR A
11--  PARTICULAR PURPOSE. See the GNU General Public License for more
12--  details. You should have received a copy of the GNU General Public
13--  License distributed with this package; see file COPYING.  If not,
14--  write to the Free Software Foundation, 59 Temple Place - Suite
15--  330, Boston, MA 02111-1307, USA.
16
17--  As a special exception, if other files instantiate generics from
18--  this unit, or you link this unit with other files to produce an
19--  executable, this unit does not by itself cause the resulting
20--  executable to be covered by the GNU General Public License.  This
21--  exception does not however invalidate any other reasons why the
22--  executable file might be covered by the GNU Public License.
23
24with System.Address_To_Access_Conversions;
25
26package body BC.Containers.Trees.AVL is
27
28   function "=" (L, R : AVL_Tree) return Boolean is
29   begin
30      return Support."=" (L.Rep, R.Rep);
31   end "=";
32
33   procedure Clear (T : in out AVL_Tree) is
34   begin
35      Support.Clear (T.Rep);
36   end Clear;
37
38   procedure Insert (T : in out AVL_Tree;
39                     Element : Item;
40                     Not_Found : out Boolean) is
41   begin
42      Support.Insert (T.Rep, Element, Not_Found);
43   end Insert;
44
45   procedure Delete
46     (T : in out AVL_Tree; Element : Item; Found : out Boolean) is
47   begin
48      Support.Delete (T.Rep, Element, Found);
49   end Delete;
50
51   function Extent (T : in AVL_Tree) return Natural is
52   begin
53      return T.Rep.Size;
54   end Extent;
55
56   function Is_Null (T : in AVL_Tree) return Boolean is
57   begin
58      return Support.Is_Null (T.Rep);
59   end Is_Null;
60
61   function Is_Member (T : in AVL_Tree; Element : Item) return Boolean is
62   begin
63      return Support.Is_Member (T.Rep, Element);
64   end Is_Member;
65
66   procedure Access_Actual_Item (In_The_Tree : AVL_Tree;
67                                 Elem : Item;
68                                 Found : out Boolean) is
69      procedure Access_Actual_Item (Node : Support.AVL_Node_Ref);
70      procedure Access_Actual_Item (Node : Support.AVL_Node_Ref) is
71         use type Support.AVL_Node_Ref;
72      begin
73         if Node /= null then
74            if Node.Element = Elem then
75               Found := True;
76               Apply (Node.Element);
77            elsif Elem < Node.Element then
78               Access_Actual_Item (Node.Left);
79            else
80               Access_Actual_Item (Node.Right);
81            end if;
82         end if;
83      end Access_Actual_Item;
84   begin
85      Found := False;
86      Access_Actual_Item (In_The_Tree.Rep.Rep);
87   end Access_Actual_Item;
88
89   procedure Visit (Over_The_Tree : AVL_Tree) is
90      Continue : Boolean := True;
91      procedure Visit (Node : Support.AVL_Node_Ref);
92      procedure Visit (Node : Support.AVL_Node_Ref) is
93         use type Support.AVL_Node_Ref;
94      begin
95         if Node /= null then
96            Visit (Node.Left);
97            if not Continue then
98               return;
99            end if;
100            Apply (Node.Element, Continue);
101            if not Continue then
102               return;
103            end if;
104            Visit (Node.Right);
105         end if;
106      end Visit;
107   begin
108      Visit (Over_The_Tree.Rep.Rep);
109   end Visit;
110
111   procedure Modify (Over_The_Tree : AVL_Tree) is
112      Continue : Boolean := True;
113      procedure Modify (Node : Support.AVL_Node_Ref);
114      procedure Modify (Node : Support.AVL_Node_Ref) is
115         use type Support.AVL_Node_Ref;
116      begin
117         if Node /= null then
118            Modify (Node.Left);
119            if not Continue then
120               return;
121            end if;
122            Apply (Node.Element, Continue);
123            if not Continue then
124               return;
125            end if;
126            Modify (Node.Right);
127         end if;
128      end Modify;
129   begin
130      Modify (Over_The_Tree.Rep.Rep);
131   end Modify;
132
133   function Null_Container return AVL_Tree is
134      Empty_Container : AVL_Tree;
135      pragma Warnings (Off, Empty_Container);
136   begin
137      return Empty_Container;
138   end Null_Container;
139
140   --  Iteration
141
142   package Address_Conversions
143   is new System.Address_To_Access_Conversions (AVL_Tree);
144
145   function New_Iterator (For_The_Tree : AVL_Tree) return Iterator'Class is
146      Result : AVL_Tree_Iterator;
147   begin
148      Result.For_The_Container :=
149        Container_Ptr (Address_Conversions.To_Pointer
150                         (For_The_Tree'Address));
151      Reset (Result);
152      return Result;
153   end New_Iterator;
154
155   procedure Reset (It : in out AVL_Tree_Iterator) is
156      This : Support.AVL_Node_Ref
157        := AVL_Tree (It.For_The_Container.all).Rep.Rep;
158      use type Support.AVL_Node_Ref;
159   begin
160      It.Previous := null;
161      It.Current := null;
162      while This /= null loop
163         It.Current := This;
164         This := This.Left;
165      end loop;
166   end Reset;
167
168   function Is_Done (It : AVL_Tree_Iterator) return Boolean is
169      use type Support.AVL_Node_Ref;
170   begin
171      return It.Current = null;
172   end Is_Done;
173
174   function Current_Item (It : AVL_Tree_Iterator) return Item is
175   begin
176      return It.Current.Element;
177   end Current_Item;
178
179   procedure Next (It : in out AVL_Tree_Iterator) is
180      procedure Visit (Node : Support.AVL_Node_Ref);
181      Found_Previous : Boolean := False;
182      Continue : Boolean := True;
183      procedure Visit (Node : Support.AVL_Node_Ref) is
184         use type Support.AVL_Node_Ref;
185      begin
186         if Node /= null then
187            Visit (Node.Left);
188            if not Continue then
189               return;
190            elsif Found_Previous then
191               It.Current := Node;
192               Continue := False;
193               return;
194            elsif Node = It.Previous then
195               Found_Previous := True;
196            end if;
197            Visit (Node.Right);
198         end if;
199      end Visit;
200   begin
201      It.Previous := It.Current;
202      It.Current := null;
203      Visit (AVL_Tree (It.For_The_Container.all).Rep.Rep);
204   end Next;
205
206   procedure Delete_Item_At (It : in out AVL_Tree_Iterator) is
207   begin
208      raise Not_Yet_Implemented;
209   end Delete_Item_At;
210
211   --  We can't take 'Access of non-aliased components. But if we
212   --  alias discriminated objects they become constrained - even if
213   --  the discriminant has a default.
214   package Allow_Element_Access
215   is new System.Address_To_Access_Conversions (Item);
216
217   function Current_Item_Ptr (It : AVL_Tree_Iterator) return Item_Ptr is
218   begin
219      if Is_Done (It) then
220         raise BC.Not_Found;
221      end if;
222      return Item_Ptr
223        (Allow_Element_Access.To_Pointer (It.Current.Element'Address));
224   end Current_Item_Ptr;
225
226end BC.Containers.Trees.AVL;
227