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 Ada.Unchecked_Deallocation;
25
26package body BC.Containers.Trees.Multiway is
27
28
29   function Create_Node
30     (I : Item; Parent, Child, Sibling : Multiway_Node_Ref)
31     return Multiway_Node_Ref;
32   pragma Inline (Create_Node);
33
34   function Create_Node
35     (I : Item; Parent, Child, Sibling : Multiway_Node_Ref)
36     return Multiway_Node_Ref is
37      Result : Multiway_Node_Ref;
38   begin
39      Result := new Multiway_Node'(Element => I,
40                                   Parent => Parent,
41                                   Child => Child,
42                                   Sibling => Sibling,
43                                   Count => 1);
44      if Child /= null then
45         Child.Parent := Result;
46      end if;
47      return Result;
48   end Create_Node;
49
50
51   procedure Delete
52   is new Ada.Unchecked_Deallocation (Multiway_Node, Multiway_Node_Ref);
53
54
55   procedure Purge (Curr : in out Multiway_Node_Ref);
56   procedure Purge (Curr : in out Multiway_Node_Ref) is
57   begin
58      if Curr /= null then
59         if Curr.Count > 1 then
60            Curr.Count := Curr.Count - 1;
61         else
62            declare
63               Ptr : Multiway_Node_Ref := Curr.Child;
64               Next : Multiway_Node_Ref;
65            begin
66               while Ptr /= null loop
67                  Next := Ptr.Sibling;
68                  Ptr.Sibling := null;
69                  Purge (Ptr);
70                  if Ptr /= null then
71                     Ptr.Parent := null;
72                  end if;
73                  Ptr := Next;
74               end loop;
75               Delete (Curr);
76            end;
77         end if;
78      end if;
79   end Purge;
80
81
82   function Create (From : Multiway_Tree) return Multiway_Tree is
83      Temp : constant Multiway_Tree
84        := (Ada.Finalization.Controlled with Rep => From.Rep);
85   begin
86      if From.Rep /= null then
87         Temp.Rep.Count := Temp.Rep.Count + 1;
88      end if;
89      return Temp;
90   end Create;
91
92
93   function "=" (Left, Right : Multiway_Tree) return Boolean is
94   begin
95      return Left.Rep = Right.Rep;
96   end "=";
97
98
99   procedure Clear (T : in out Multiway_Tree) is
100   begin
101      Purge (T.Rep);
102      T.Rep := null;
103   end Clear;
104
105
106   procedure Insert (T : in out Multiway_Tree; Elem : in Item) is
107   begin
108      if T.Rep /= null and then T.Rep.Parent /= null then
109         raise BC.Not_Root;
110      end if;
111      T.Rep := Create_Node (Elem,
112                            Parent => null,
113                            Child => T.Rep,
114                            Sibling => null);
115   end Insert;
116
117
118   procedure Append (T : in out Multiway_Tree; Elem : in Item) is
119   begin
120      if T.Rep = null then
121         raise BC.Is_Null;
122      end if;
123      declare
124         Curr : Multiway_Node_Ref := T.Rep.Child;
125      begin
126         if Curr = null then
127            T.Rep.Child := Create_Node (Elem,
128                                        Parent => T.Rep,
129                                        Child => null,
130                                        Sibling => null);
131         else
132            while Curr.Sibling /= null loop
133               Curr := Curr.Sibling;
134            end loop;
135            Curr.Sibling := Create_Node (Elem,
136                                         Parent => T.Rep,
137                                         Child => null,
138                                         Sibling => Curr.Sibling);
139         end if;
140      end;
141   end Append;
142
143
144   procedure Append (T : in out Multiway_Tree;
145                     Elem : in Item;
146                     After : Natural) is
147   begin
148      if T.Rep = null then
149         raise BC.Is_Null;
150      end if;
151      if After = 0 then
152         declare
153            C : constant Multiway_Node_Ref
154              := Create_Node (Elem,
155                              Parent => T.Rep,
156                              Child => null,
157                              Sibling => T.Rep.Child);
158         begin
159            T.Rep.Child := C;
160         end;
161      else
162         declare
163            Curr : Multiway_Node_Ref := T.Rep.Child;
164            I : Positive := 1;
165         begin
166            while Curr /= null and then I < After loop
167               Curr := Curr.Sibling;
168               I := I + 1;
169            end loop;
170            if Curr = null then
171               raise BC.Range_Error;
172            end if;
173            Curr.Sibling := Create_Node (Elem,
174                                         Parent => T.Rep,
175                                         Child => null,
176                                         Sibling => Curr.Sibling);
177         end;
178      end if;
179   end Append;
180
181
182   procedure Append (T : in out Multiway_Tree;
183                     From_Tree : in out Multiway_Tree) is
184   begin
185      if From_Tree.Rep = null then
186         return;
187      end if;
188      if From_Tree.Rep.Parent /= null then
189         raise BC.Not_Root;
190      end if;
191      if T.Rep = null then
192         raise BC.Is_Null;
193      end if;
194      declare
195         Curr : Multiway_Node_Ref := T.Rep.Child;
196      begin
197         if Curr = null then
198            T.Rep.Child := From_Tree.Rep;
199         else
200            while Curr.Sibling /= null loop
201               Curr := Curr.Sibling;
202            end loop;
203            Curr.Sibling := From_Tree.Rep;
204         end if;
205      end;
206      From_Tree.Rep.Parent := T.Rep;
207      From_Tree.Rep.Count := From_Tree.Rep.Count + 1;
208   end Append;
209
210
211   procedure Append (T : in out Multiway_Tree;
212                     From_Tree : in out Multiway_Tree;
213                     After : Natural) is
214   begin
215      if From_Tree.Rep = null then
216         return;
217      elsif From_Tree.Rep.Parent /= null then
218         raise BC.Not_Root;
219      end if;
220      if T.Rep = null then
221         raise BC.Is_Null;
222      end if;
223      pragma Assert (From_Tree.Rep.Sibling = null);  --  XXX
224      if After = 0 then
225         From_Tree.Rep.Sibling := T.Rep.Child;
226         T.Rep.Child := From_Tree.Rep;
227      else
228         declare
229            Curr : Multiway_Node_Ref := T.Rep.Child;
230            I : Positive := 1;
231         begin
232            while Curr /= null and then I < After loop
233               Curr := Curr.Sibling;
234               I := I + 1;
235            end loop;
236            if Curr = null then
237               raise BC.Range_Error;
238            end if;
239            From_Tree.Rep.Sibling := Curr.Sibling;
240            Curr.Sibling := From_Tree.Rep;
241         end;
242      end if;
243      From_Tree.Rep.Parent := T.Rep;
244      From_Tree.Rep.Count := From_Tree.Rep.Count + 1;
245   end Append;
246
247
248   procedure Remove (T : in out Multiway_Tree; Index : Positive) is
249   begin
250      if T.Rep = null then
251         raise BC.Is_Null;
252      end if;
253      declare
254         I : Positive := 1;
255         Prev : Multiway_Node_Ref;
256         Curr : Multiway_Node_Ref := T.Rep.Child;
257      begin
258         while Curr /= null and then I < Index loop
259            Prev := Curr;
260            Curr := Curr.Sibling;
261            I := I + 1;
262         end loop;
263         if Curr = null then
264            raise BC.Range_Error;
265         end if;
266         if Prev = null then
267            T.Rep.Child := Curr.Sibling;
268         else
269            Prev.Sibling := Curr.Sibling;
270         end if;
271         Curr.Parent := null;
272         Curr.Sibling := null;
273         Purge (Curr);
274      end;
275   end Remove;
276
277
278   procedure Share (T : in out Multiway_Tree;
279                    Share_With : in Multiway_Tree;
280                    Child : Positive) is
281      Ptr : Multiway_Node_Ref := Share_With.Rep;
282      I : Positive := 1;
283   begin
284      if Ptr = null then
285         raise BC.Is_Null;
286      end if;
287      Ptr := Ptr.Child;
288      while Ptr /= null and then I < Child loop
289         Ptr := Ptr.Sibling;
290         I := I + 1;
291      end loop;
292      if Ptr = null then
293         raise BC.Range_Error;
294      end if;
295      Clear (T);
296      T.Rep := Ptr;
297      T.Rep.Count := T.Rep.Count + 1;
298   end Share;
299
300
301   procedure Swap_Child (T : in out Multiway_Tree;
302                         Swap_With : in out Multiway_Tree;
303                         Child : in Positive) is
304      Prev : Multiway_Node_Ref;
305      Curr : Multiway_Node_Ref := T.Rep;
306      I : Positive := 1;
307   begin
308      if T.Rep = null then
309         raise BC.Is_Null;
310      end if;
311      if Swap_With.Rep /= null and then Swap_With.Rep.Parent /= null then
312         raise BC.Not_Root;
313      end if;
314      Curr := Curr.Child;
315      while Curr /= null and then I < Child loop
316         Prev := Curr;
317         Curr := Curr.Sibling;
318         I := I + 1;
319      end loop;
320      if Curr = null then
321         raise BC.Range_Error;
322      end if;
323      Swap_With.Rep.Sibling := Curr.Sibling;
324      if Prev = null then
325         T.Rep.Child := Swap_With.Rep;
326      else
327         Prev.Sibling := Swap_With.Rep;
328      end if;
329      if Swap_With.Rep /= null then
330         Swap_With.Rep.Parent := T.Rep;
331      end if;
332      Swap_With.Rep := Curr;
333      Swap_With.Rep.Sibling := null;
334      Swap_With.Rep.Parent := null;
335   end Swap_Child;
336
337
338   procedure Child (T : in out Multiway_Tree; Child : in Positive) is
339      Curr : Multiway_Node_Ref := T.Rep;
340      I : Positive := 1;
341   begin
342      if T.Rep = null then
343         raise BC.Is_Null;
344      end if;
345      Curr := Curr.Child;
346      while Curr /= null and then I < Child loop
347         Curr := Curr.Sibling;
348         I := I + 1;
349      end loop;
350      if Curr = null then
351         raise BC.Range_Error;
352      end if;
353      Curr.Count := Curr.Count + 1;
354      Purge (T.Rep);
355      T.Rep := Curr;
356   end Child;
357
358
359   procedure Parent (T : in out Multiway_Tree) is
360   begin
361      if T.Rep = null then
362         raise BC.Is_Null;
363      end if;
364      if T.Rep.Parent = null then
365         Clear (T);
366      else
367         T.Rep.Count := T.Rep.Count - 1;
368         T.Rep := T.Rep.Parent;
369         T.Rep.Count := T.Rep.Count + 1;
370      end if;
371   end Parent;
372
373
374   procedure Set_Item (T : in out Multiway_Tree; Elem : in Item) is
375   begin
376      if T.Rep = null then
377         raise BC.Is_Null;
378      end if;
379      T.Rep.Element := Elem;
380   end Set_Item;
381
382
383   function Arity (T : Multiway_Tree) return Natural is
384   begin
385      if T.Rep = null then
386         raise BC.Is_Null;
387      end if;
388      declare
389         Count : Natural := 0;
390         Ptr : Multiway_Node_Ref := T.Rep.Child;
391      begin
392         while Ptr /= null loop
393            Count := Count + 1;
394            Ptr := Ptr.Sibling;
395         end loop;
396         return Count;
397      end;
398   end Arity;
399
400
401   function Has_Children (T : in Multiway_Tree) return Boolean is
402   begin
403      return T.Rep /= null and then T.Rep.Child /= null;
404   end Has_Children;
405
406
407   function Is_Null (T : in Multiway_Tree) return Boolean is
408   begin
409      return T.Rep = null;
410   end Is_Null;
411
412
413   function Is_Shared (T : in Multiway_Tree) return Boolean is
414   begin
415      return T.Rep /= null and then T.Rep.Count > 1;
416   end Is_Shared;
417
418
419   function Is_Root (T : in Multiway_Tree) return Boolean is
420   begin
421      return T.Rep = null or else T.Rep.Parent = null;
422   end Is_Root;
423
424
425   function Item_At (T : in Multiway_Tree) return Item is
426   begin
427      if T.Rep = null then
428         raise BC.Is_Null;
429      end if;
430      return T.Rep.Element;
431   end Item_At;
432
433
434   procedure Initialize (T : in out Multiway_Tree) is
435      pragma Warnings (Off, T);
436   begin
437      null;
438   end Initialize;
439
440
441   procedure Adjust (T : in out Multiway_Tree) is
442   begin
443      if T.Rep /= null then
444         T.Rep.Count := T.Rep.Count + 1;
445      end if;
446   end Adjust;
447
448
449   procedure Finalize (T : in out Multiway_Tree) is
450   begin
451      Clear (T);
452   end Finalize;
453
454
455end BC.Containers.Trees.Multiway;
456