--  Copyright 1994 Grady Booch
--  Copyright 1994-1997 David Weller
--  Copyright 1998-2002 Simon Wright <simon@pushface.org>

--  This package is free software; you can redistribute it and/or
--  modify it under terms of the GNU General Public License as
--  published by the Free Software Foundation; either version 2, or
--  (at your option) any later version. This package is distributed in
--  the hope that it will be useful, but WITHOUT ANY WARRANTY; without
--  even the implied warranty of MERCHANTABILITY or FITNESS FOR A
--  PARTICULAR PURPOSE. See the GNU General Public License for more
--  details. You should have received a copy of the GNU General Public
--  License distributed with this package; see file COPYING.  If not,
--  write to the Free Software Foundation, 59 Temple Place - Suite
--  330, Boston, MA 02111-1307, USA.

--  As a special exception, if other files instantiate generics from
--  this unit, or you link this unit with other files to produce an
--  executable, this unit does not by itself cause the resulting
--  executable to be covered by the GNU General Public License.  This
--  exception does not however invalidate any other reasons why the
--  executable file might be covered by the GNU Public License.

--  $RCSfile: bc-containers-trees-avl.adb,v $
--  $Revision: 1.10.2.1 $
--  $Date: 2002/12/29 16:42:02 $
--  $Author: simon $

with Ada.Unchecked_Deallocation;

package body BC.Containers.Trees.AVL is

   procedure Delete is
      new Ada.Unchecked_Deallocation (AVL_Node, AVL_Node_Ref);

   --  Supporting subprograms
   procedure Purge (Node : in out AVL_Node_Ref);

   procedure Search_Insert (T : in out AVL_Tree;
                            Element : Item;
                            Node : in out AVL_Node_Ref;
                            Increased : in out Boolean;
                            Inserted : out Boolean);

   procedure Search_Delete (T : in out AVL_Tree;
                            Element : Item;
                            Node : in out AVL_Node_Ref;
                            Decreased : in out Boolean;
                            Deleted : out Boolean);

   procedure Balance_Left (Node : in out AVL_Node_Ref;
                           Decreased : in out Boolean);

   procedure Balance_Right (Node : in out AVL_Node_Ref;
                            Decreased : in out Boolean);

   procedure Delete
     (To_Be_Deleted, Candidate_Replacement : in out AVL_Node_Ref;
      Decreased : in out Boolean);

   function Search (T : AVL_Tree;
                    Element : Item;
                    Node : AVL_Node_Ref) return Boolean;

   procedure Purge (Node : in out AVL_Node_Ref) is
   begin
      if Node /= null then
         Purge (Node.Left);
         Purge (Node.Right);
         Delete (Node);
      end if;
   end Purge;

   procedure Search_Insert (T : in out AVL_Tree;
                            Element : Item;
                            Node : in out AVL_Node_Ref;
                            Increased : in out Boolean;
                            Inserted : out Boolean) is
      P1, P2 : AVL_Node_Ref;
   begin
      Inserted := True;
      if Node = null then
         Node := new AVL_Node'(Element => Element,
                                     Left => null,
                                     Right => null,
                                     Balance => Middle);
         Increased := True;
      elsif Element < Node.Element then
         Search_Insert (T, Element, Node.Left, Increased, Inserted);
         if Increased then
            case Node.Balance is
               when Right =>
                  Node.Balance := Middle;
                  Increased := False;
               when Middle =>
                  Node.Balance := Left;
               when Left =>
                  P1 := Node.Left;
                  if P1.Balance = Left then
                     Node.Left := P1.Right;
                     P1.Right := Node;
                     Node.Balance := Middle;
                     Node := P1;
                  else
                     P2 := P1.Right;
                     P1.Right := P2.Left;
                     P2.Left := P1;
                     Node.Left := P2.Right;
                     P2.Right := Node;
                     if P2.Balance = Left then
                        Node.Balance := Right;
                     else
                        Node.Balance := Middle;
                     end if;
                     if P2.Balance = Right then
                        P1.Balance := Left;
                     else
                        P1.Balance := Middle;
                     end if;
                     Node := P2;
                  end if;
                  Node.Balance := Middle;
                  Increased := False;
            end case;
         end if;
      elsif Node.Element < Element then
         Search_Insert (T, Element, Node.Right, Increased, Inserted);
         if Increased then
            case Node.Balance is
               when Left =>
                  Node.Balance := Middle;
                  Increased := False;
               when Middle =>
                  Node.Balance := Right;
               when Right =>
                  P1 := Node.Right;
                  if P1.Balance = Right then
                     Node.Right := P1.Left;
                     P1.Left := Node;
                     Node.Balance := Middle;
                     Node := P1;
                  else
                     P2 := P1.Left;
                     P1.Left := P2.Right;
                     P2.Right := P1;
                     Node.Right := P2.Left;
                     P2.Left := Node;
                     if P2.Balance = Right then
                        Node.Balance := Left;
                     else
                        Node.Balance := Middle;
                     end if;
                     if P2.Balance = Left then
                        P1.Balance := Right;
                     else
                        P1.Balance := Middle;
                     end if;
                     Node := P2;
                  end if;
                  Node.Balance := Middle;
                  Increased := False;
            end case;
         end if;
      else
         --  We need to cope with the case where elements _compare_
         --  equal but their non-key data content has changed.
         Node.Element := Element;
         Inserted := False;
      end if;
   end Search_Insert;

   procedure Balance_Left (Node : in out AVL_Node_Ref;
                           Decreased : in out Boolean) is
      P1, P2 : AVL_Node_Ref;
      Balance1, Balance2 : Node_Balance;
   begin
      case Node.Balance is
         when Left =>
            Node.Balance := Middle;
         when Middle =>
            Node.Balance := Right;
            Decreased := False;
         when Right =>
            P1 := Node.Right;
            Balance1 := P1.Balance;
            if Balance1 >= Middle then
               Node.Right := P1.Left;
               P1.Left := Node;
               if Balance1 = Middle then
                  Node.Balance := Right;
                  P1.Balance := Left;
                  Decreased := False;
               else
                  Node.Balance := Middle;
                  P1.Balance := Middle;
               end if;
               Node := P1;
            else
               P2 := P1.Left;
               Balance2 := P2.Balance;
               P1.Left := P2.Right;
               P2.Right := P1;
               Node.Right := P2.Left;
               P2.Left := Node;
               if Balance2 = Right then
                  Node.Balance := Left;
               else
                  Node.Balance := Middle;
               end if;
               if Balance2 = Left then
                  P1.Balance := Right;
               else
                  P1.Balance := Middle;
               end if;
               Node := P2;
               P2.Balance := Middle;
            end if;
      end case;
   end Balance_Left;

   procedure Balance_Right (Node : in out AVL_Node_Ref;
                            Decreased : in out Boolean)  is
      P1, P2 : AVL_Node_Ref;
      Balance1, Balance2 : Node_Balance;
   begin
      case Node.Balance is
         when Right =>
            Node.Balance := Middle;
         when Middle =>
            Node.Balance := Left;
            Decreased := False;
         when Left =>
            P1 := Node.Left;
            Balance1 := P1.Balance;
            if Balance1 <= Middle then
               Node.Left := P1.Right;
               P1.Right := Node;
               if Balance1 = Middle then
                  Node.Balance := Left;
                  P1.Balance := Right;
                  Decreased := False;
               else
                  Node.Balance := Middle;
                  P1.Balance := Middle;
               end if;
               Node := P1;
            else
               P2 := P1.Right;
               Balance2 := P2.Balance;
               P1.Right := P2.Left;
               P2.Left := P1;
               Node.Left := P2.Right;
               P2.Right := Node;
               if Balance2 = Left then
                  Node.Balance := Right;
               else
                  Node.Balance := Middle;
               end if;
               if Balance2 = Right then
                  P1.Balance := Left;
               else
                  P1.Balance := Middle;
               end if;
               Node := P2;
               P2.Balance := Middle;
            end if;
      end case;
   end Balance_Right;

   --  On entry, To_Be_Deleted is the node which contains the value
   --  that is to be deleted. Candidate_Replacement starts off as the
   --  left child of To_Be_Deleted, but the procedure recurses until
   --  Candidate_Replacement is the rightmost (largest) child of the
   --  left subtree of To_Be_Deleted.
   --
   --  The value at Candidate_Replacement is then transferred to the
   --  node To_Be_Deleted, and the pointer To_Be_Deleted is made to
   --  point to the rightmost child (so that that what eventually gets
   --  deleted is that rightmost child).
   --
   --  The tree is rebalanced as the recursion unwinds.
   procedure Delete
     (To_Be_Deleted, Candidate_Replacement : in out AVL_Node_Ref;
      Decreased : in out Boolean) is
   begin
      if Candidate_Replacement.Right /= null then
         --  Recurse down the right branch
         Delete (To_Be_Deleted, Candidate_Replacement.Right, Decreased);
         if Candidate_Replacement.Left = null
           and then Candidate_Replacement.Right = null then
            Candidate_Replacement.Balance := Middle;
         elsif Decreased then
            Balance_Right (Candidate_Replacement, Decreased);
         end if;
      else
         --  We've found the rightmost child.
         --  Copy the value there to the node that contained the value
         --  to be deleted.
         To_Be_Deleted.Element := Candidate_Replacement.Element;
         --  Replace the pointer to the node that contained the value
         --  to be deleted with a pointer to the rightmost child of
         --  the left subtree (no longer needed, and to be deleted by
         --  the caller).
         To_Be_Deleted := Candidate_Replacement;
         --  Candidate_Replacement is the actual pointer in the parent
         --  node; it needs to point to the left subtree, if any, of
         --  the node that was the rightmost child and which we are
         --  about to delete.
         Candidate_Replacement := Candidate_Replacement.Left;
         --  We've definitely reduced the depth.
         Decreased := True;
      end if;
   end Delete;

   procedure Search_Delete (T : in out AVL_Tree;
                            Element : Item;
                            Node : in out AVL_Node_Ref;
                            Decreased : in out Boolean;
                            Deleted : out Boolean) is
      Q : AVL_Node_Ref;
   begin
      Deleted := False;
      if Node /= null then
         if Element < Node.Element then
            Search_Delete (T, Element, Node.Left, Decreased, Deleted);
            if Decreased then
               Balance_Left (Node, Decreased);
            end if;
         elsif Node.Element < Element then
            Search_Delete (T, Element, Node.Right, Decreased, Deleted);
            if Decreased then
               Balance_Right (Node, Decreased);
            end if;
         else
            Q := Node;
            Deleted := True;
            if Q.Right = null then
               Node := Q.Left;
               Decreased := True;
            elsif Q.Left = null then
               Node := Q.Right;
               Decreased := True;
            else
               Delete (Q, Q.Left, Decreased);
               if Decreased then
                  Balance_Left (Node, Decreased);
               end if;
            end if;
            Delete (Q);
         end if;
      end if;
   end Search_Delete;

   function Search (T : AVL_Tree;
                    Element : Item;
                    Node : AVL_Node_Ref) return Boolean is
   begin
      if Node /= null then
         if Node.Element = Element then
            return True;
         elsif Element < Node.Element then
            return Search (T, Element, Node.Left);
         else
            return Search (T, Element, Node.Right);
         end if;
      else
         return False;
      end if;
   end Search;

   --  end supporting functions

   function "=" (L, R : AVL_Tree) return Boolean is
      --  Once we know that the sizes are the same, we only need to
      --  check that all members of L are in R, because we don't allow
      --  duplicate members.
      procedure Check_In_Right (Elem : in Item; Found : out Boolean);
      procedure Compare is new Visit (Apply => Check_In_Right);
      Are_Equal : Boolean := True;
      procedure Check_In_Right (Elem : in Item; Found : out Boolean) is
      begin
         Found := Is_Member (R, Elem); -- to terminate early
         if not Found then
            Are_Equal := False;
         end if;
      end Check_In_Right;
   begin
      if L.Size /= R.Size then
         return False;
      end if;
      Compare (Over_The_Tree => L);
      return Are_Equal;
   end "=";

   procedure Clear (T : in out AVL_Tree) is
   begin
      Purge (T.Rep);
      T.Size := 0;
   end Clear;

   procedure Insert (T : in out AVL_Tree;
                     Element : Item;
                     Not_Found : out Boolean) is
      Increased : Boolean := False;
      Result : Boolean;
   begin
      Search_Insert (T, Element, T.Rep, Increased, Result);
      if Result then
         T.Size := T.Size + 1;
         Not_Found := True;
      else
         Not_Found := False;
      end if;
   end Insert;

   procedure Delete
     (T : in out AVL_Tree; Element : Item; Found : out Boolean) is
      Decreased : Boolean := False;
      Result : Boolean;
   begin
      Search_Delete (T, Element, T.Rep, Decreased, Result);
      if Result then
         T.Size := T.Size - 1;
         Found := True;
      else
         Found := False;
      end if;
   end Delete;

   function Extent (T : in AVL_Tree) return Natural is
   begin
      return T.Size;
   end Extent;

   function Is_Null (T : in AVL_Tree) return Boolean is
   begin
      return T.Rep = null;
   end Is_Null;

   function Is_Member (T : in AVL_Tree; Element : Item) return Boolean is
   begin
      return Search (T, Element, T.Rep);
   end Is_Member;

   procedure Access_Actual_Item (In_The_Tree : AVL_Tree;
                                 Elem : Item;
                                 Found : out Boolean) is
      procedure Access_Actual_Item (Node : AVL_Node_Ref);
      procedure Access_Actual_Item (Node : AVL_Node_Ref) is
      begin
         if Node /= null then
            if Node.Element = Elem then
               Found := True;
               Apply (Node.Element);
            elsif Elem < Node.Element then
               Access_Actual_Item (Node.Left);
            else
               Access_Actual_Item (Node.Right);
            end if;
         end if;
      end Access_Actual_Item;
   begin
      Found := False;
      Access_Actual_Item (In_The_Tree.Rep);
   end Access_Actual_Item;

   --    function Traverse (Node : AVL_Node_Ref;
   --                      Iter_Func : Iteration_Function) return Boolean is
   --      Temp : AVL_Node_Ref;
   --    begin
   --      if Node /= null then
   --        Temp := Node.Left;
   --        if not Traverse (Temp, Iter_Func) then
   --          return False;
   --        end if;
   --        if not Iter_Func (Temp.Element) then
   --          return False;
   --        end if;
   --        Temp := Node.Right;
   --        if not Traverse (Temp, Iter_Func) then
   --          return False;
   --        end if;
   --      end if;
   --      return True;
   --    end Traverse;

   procedure Visit (Over_The_Tree : AVL_Tree) is
      Continue : Boolean := True;
      procedure Visit (Node : AVL_Node_Ref);
      procedure Visit (Node : AVL_Node_Ref) is
      begin
         if Node /= null then
            Visit (Node.Left);
            if not Continue then
               return;
            end if;
            Apply (Node.Element, Continue);
            if not Continue then
               return;
            end if;
            Visit (Node.Right);
         end if;
      end Visit;
   begin
      Visit (Over_The_Tree.Rep);
   end Visit;

   procedure Modify (Over_The_Tree : AVL_Tree) is
      Continue : Boolean := True;
      procedure Modify (Node : AVL_Node_Ref);
      procedure Modify (Node : AVL_Node_Ref) is
      begin
         if Node /= null then
            Modify (Node.Left);
            if not Continue then
               return;
            end if;
            Apply (Node.Element, Continue);
            if not Continue then
               return;
            end if;
            Modify (Node.Right);
         end if;
      end Modify;
   begin
      Modify (Over_The_Tree.Rep);
   end Modify;

   procedure Initialize (T : in out AVL_Tree) is
      pragma Warnings (Off, T);
   begin
      null;
   end Initialize;

   procedure Adjust (T : in out AVL_Tree) is
      New_Tree : AVL_Tree;
      procedure Add (Elem : in Item; OK : out Boolean);
      procedure Copy is new Visit (Apply => Add);
      procedure Add (Elem : in Item; OK : out Boolean) is
         Inserted : Boolean;
      begin
         Insert (T => New_Tree, Element => Elem, Not_Found => Inserted);
         --  XXX should test Inserted?
         OK := True;
      end Add;
   begin
      --  Create a deep copy of the representation
      Copy (Over_The_Tree => T);
      --  Replace the original representation with the copy
      T.Rep := New_Tree.Rep;
      --  Null out the spare reference to the copy (so that when
      --  New_Tree gets finalized on exit from this procedure, we
      --  don't Clear it down). NB, mustn't do a whole-record
      --  assignment here or we'll end up with a recursive disaster).
      New_Tree.Rep := null;
      New_Tree.Size := 0;
   end Adjust;

   procedure Finalize (T : in out AVL_Tree) is
   begin
      Clear (T);
   end Finalize;

end BC.Containers.Trees.AVL;