a-rbtgso.adb   [plain text]

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT LIBRARY COMPONENTS                          --
--                                                                          --
--          ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_SET_OPERATIONS           --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--             Copyright (C) 2004 Free Software Foundation, Inc.            --
--                                                                          --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the  contents of the part following the private keyword. --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT 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 GNAT;  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.                                      --
--                                                                          --
-- This unit was originally developed by Matthew J Heaney.                  --
------------------------------------------------------------------------------

package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is

   ----------------
   -- Difference --
   ----------------

   procedure Difference (Target : in out Tree_Type; Source : Tree_Type) is
      Tgt : Node_Access := Target.First;
      Src : Node_Access := Source.First;

   begin

      --  NOTE: must be done by client:
      --      if Target'Address = Source'Address then
      --         Clear (Target);
      --         return;
      --      end if;

      loop
         if Tgt = Tree_Operations.Null_Node then
            return;
         end if;

         if Src = Tree_Operations.Null_Node then
            return;
         end if;

         if Is_Less (Tgt, Src) then
            Tgt := Tree_Operations.Next (Tgt);

         elsif Is_Less (Src, Tgt) then
            Src := Tree_Operations.Next (Src);

         else
            declare
               X : Node_Access := Tgt;
            begin
               Tgt := Tree_Operations.Next (Tgt);
               Tree_Operations.Delete_Node_Sans_Free (Target, X);
               Free (X);
            end;

            Src := Tree_Operations.Next (Src);
         end if;
      end loop;
   end Difference;

   function Difference (Left, Right : Tree_Type) return Tree_Type is
      Tree : Tree_Type := (Length => 0, others => Tree_Operations.Null_Node);

      L_Node : Node_Access := Left.First;
      R_Node : Node_Access := Right.First;

      Dst_Node : Node_Access;

   begin
      --  NOTE: must by done by client:
      --      if Left'Address = Right'Address then
      --         return Empty_Set;
      --      end if;

      loop
         if L_Node = Tree_Operations.Null_Node then
            return Tree;
         end if;

         if R_Node = Tree_Operations.Null_Node then
            while L_Node /= Tree_Operations.Null_Node loop
               Insert_With_Hint
                 (Dst_Tree => Tree,
                  Dst_Hint => Tree_Operations.Null_Node,
                  Src_Node => L_Node,
                  Dst_Node => Dst_Node);

               L_Node := Tree_Operations.Next (L_Node);

            end loop;

            return Tree;
         end if;

         if Is_Less (L_Node, R_Node) then
            Insert_With_Hint
              (Dst_Tree => Tree,
               Dst_Hint => Tree_Operations.Null_Node,
               Src_Node => L_Node,
               Dst_Node => Dst_Node);

            L_Node := Tree_Operations.Next (L_Node);

         elsif Is_Less (R_Node, L_Node) then
            R_Node := Tree_Operations.Next (R_Node);

         else
            L_Node := Tree_Operations.Next (L_Node);
            R_Node := Tree_Operations.Next (R_Node);
         end if;
      end loop;

   exception
      when others =>
         Delete_Tree (Tree.Root);
         raise;
   end Difference;

   ------------------
   -- Intersection --
   ------------------

   procedure Intersection
     (Target : in out Tree_Type;
      Source : Tree_Type)
   is
      Tgt : Node_Access := Target.First;
      Src : Node_Access := Source.First;

   begin
      --  NOTE: must be done by caller: ???
      --      if Target'Address = Source'Address then
      --         return;
      --      end if;

      while Tgt /= Tree_Operations.Null_Node
        and then Src /= Tree_Operations.Null_Node
      loop
         if Is_Less (Tgt, Src) then
            declare
               X : Node_Access := Tgt;
            begin
               Tgt := Tree_Operations.Next (Tgt);
               Tree_Operations.Delete_Node_Sans_Free (Target, X);
               Free (X);
            end;

         elsif Is_Less (Src, Tgt) then
            Src := Tree_Operations.Next (Src);

         else
            Tgt := Tree_Operations.Next (Tgt);
            Src := Tree_Operations.Next (Src);
         end if;
      end loop;
   end Intersection;

   function Intersection (Left, Right : Tree_Type) return Tree_Type is
      Tree : Tree_Type := (Length => 0, others => Tree_Operations.Null_Node);

      L_Node : Node_Access := Left.First;
      R_Node : Node_Access := Right.First;

      Dst_Node : Node_Access;

   begin
      --  NOTE: must be done by caller: ???
      --      if Left'Address = Right'Address then
      --         return Left;
      --      end if;

      loop
         if L_Node = Tree_Operations.Null_Node then
            return Tree;
         end if;

         if R_Node = Tree_Operations.Null_Node then
            return Tree;
         end if;

         if Is_Less (L_Node, R_Node) then
            L_Node := Tree_Operations.Next (L_Node);

         elsif Is_Less (R_Node, L_Node) then
            R_Node := Tree_Operations.Next (R_Node);

         else
            Insert_With_Hint
              (Dst_Tree => Tree,
               Dst_Hint => Tree_Operations.Null_Node,
               Src_Node => L_Node,
               Dst_Node => Dst_Node);

            L_Node := Tree_Operations.Next (L_Node);
            R_Node := Tree_Operations.Next (R_Node);
         end if;
      end loop;

   exception
      when others =>
         Delete_Tree (Tree.Root);
         raise;
   end Intersection;

   ---------------
   -- Is_Subset --
   ---------------

   function Is_Subset
     (Subset : Tree_Type;
      Of_Set : Tree_Type) return Boolean
   is
   begin
      --  NOTE: must by done by caller:
      --      if Subset'Address = Of_Set'Address then
      --         return True;
      --      end if;

      if Subset.Length > Of_Set.Length then
         return False;
      end if;

      declare
         Subset_Node : Node_Access := Subset.First;
         Set_Node : Node_Access := Of_Set.First;

      begin
         loop
            if Set_Node = Tree_Operations.Null_Node then
               return Subset_Node = Tree_Operations.Null_Node;
            end if;

            if Subset_Node = Tree_Operations.Null_Node then
               return True;
            end if;

            if Is_Less (Subset_Node, Set_Node) then
               return False;
            end if;

            if Is_Less (Set_Node, Subset_Node) then
               Set_Node := Tree_Operations.Next (Set_Node);
            else
               Set_Node := Tree_Operations.Next (Set_Node);
               Subset_Node := Tree_Operations.Next (Subset_Node);
            end if;
         end loop;
      end;
   end Is_Subset;

   -------------
   -- Overlap --
   -------------

   function Overlap (Left, Right : Tree_Type) return Boolean is
      L_Node : Node_Access := Left.First;
      R_Node : Node_Access := Right.First;

   begin
      --  NOTE: must be done by caller: ???
      --      if Left'Address = Right'Address then
      --         return Left.Tree.Length /= 0;
      --      end if;

      loop
         if L_Node = Tree_Operations.Null_Node
           or else R_Node = Tree_Operations.Null_Node
         then
            return False;
         end if;

         if Is_Less (L_Node, R_Node) then
            L_Node := Tree_Operations.Next (L_Node);

         elsif Is_Less (R_Node, L_Node) then
            R_Node := Tree_Operations.Next (R_Node);

         else
            return True;
         end if;
      end loop;
   end Overlap;

   --------------------------
   -- Symmetric_Difference --
   --------------------------

   procedure Symmetric_Difference
     (Target : in out Tree_Type;
      Source : Tree_Type)
   is
      Tgt : Node_Access := Target.First;
      Src : Node_Access := Source.First;

      New_Tgt_Node : Node_Access;

   begin
      --  NOTE: must by done by client: ???
      --      if Target'Address = Source'Address then
      --         Clear (Target);
      --         return;
      --      end if;

      loop
         if Tgt = Tree_Operations.Null_Node then
            while Src /= Tree_Operations.Null_Node loop
               Insert_With_Hint
                 (Dst_Tree => Target,
                  Dst_Hint => Tree_Operations.Null_Node,
                  Src_Node => Src,
                  Dst_Node => New_Tgt_Node);

               Src := Tree_Operations.Next (Src);
            end loop;

            return;
         end if;

         if Src = Tree_Operations.Null_Node then
            return;
         end if;

         if Is_Less (Tgt, Src) then
            Tgt := Tree_Operations.Next (Tgt);

         elsif Is_Less (Src, Tgt) then
            Insert_With_Hint
              (Dst_Tree => Target,
               Dst_Hint => Tgt,
               Src_Node => Src,
               Dst_Node => New_Tgt_Node);

            Src := Tree_Operations.Next (Src);

         else
            declare
               X : Node_Access := Tgt;
            begin
               Tgt := Tree_Operations.Next (Tgt);
               Tree_Operations.Delete_Node_Sans_Free (Target, X);
               Free (X);
            end;

            Src := Tree_Operations.Next (Src);
         end if;
      end loop;
   end Symmetric_Difference;

   function Symmetric_Difference (Left, Right : Tree_Type) return Tree_Type is
      Tree : Tree_Type := (Length => 0, others => Tree_Operations.Null_Node);

      L_Node : Node_Access := Left.First;
      R_Node : Node_Access := Right.First;

      Dst_Node : Node_Access;

   begin
      --  NOTE: must by done by caller ???
      --      if Left'Address = Right'Address then
      --         return Empty_Set;
      --      end if;

      loop
         if L_Node = Tree_Operations.Null_Node then
            while R_Node /= Tree_Operations.Null_Node loop
               Insert_With_Hint
                 (Dst_Tree => Tree,
                  Dst_Hint => Tree_Operations.Null_Node,
                  Src_Node => R_Node,
                  Dst_Node => Dst_Node);
               R_Node := Tree_Operations.Next (R_Node);
            end loop;

            return Tree;
         end if;

         if R_Node = Tree_Operations.Null_Node then
            while L_Node /= Tree_Operations.Null_Node loop
               Insert_With_Hint
                 (Dst_Tree => Tree,
                  Dst_Hint => Tree_Operations.Null_Node,
                  Src_Node => L_Node,
                  Dst_Node => Dst_Node);

               L_Node := Tree_Operations.Next (L_Node);
            end loop;

            return Tree;
         end if;

         if Is_Less (L_Node, R_Node) then
            Insert_With_Hint
              (Dst_Tree => Tree,
               Dst_Hint => Tree_Operations.Null_Node,
               Src_Node => L_Node,
               Dst_Node => Dst_Node);

            L_Node := Tree_Operations.Next (L_Node);

         elsif Is_Less (R_Node, L_Node) then
            Insert_With_Hint
              (Dst_Tree => Tree,
               Dst_Hint => Tree_Operations.Null_Node,
               Src_Node => R_Node,
               Dst_Node => Dst_Node);

            R_Node := Tree_Operations.Next (R_Node);

         else
            L_Node := Tree_Operations.Next (L_Node);
            R_Node := Tree_Operations.Next (R_Node);
         end if;
      end loop;

   exception
      when others =>
         Delete_Tree (Tree.Root);
         raise;
   end Symmetric_Difference;

   -----------
   -- Union --
   -----------

   procedure Union (Target : in out Tree_Type; Source : Tree_Type)
   is
      Hint : Node_Access;

      procedure Process (Node : Node_Access);
      pragma Inline (Process);

      procedure Iterate is new Tree_Operations.Generic_Iteration (Process);

      -------------
      -- Process --
      -------------

      procedure Process (Node : Node_Access) is
      begin
         Insert_With_Hint
           (Dst_Tree => Target,
            Dst_Hint => Hint,
            Src_Node => Node,
            Dst_Node => Hint);
      end Process;

   --  Start of processing for Union

   begin
      --  NOTE: must be done by caller: ???
      --      if Target'Address = Source'Address then
      --         return;
      --      end if;

      Iterate (Source);
   end Union;

   function Union (Left, Right : Tree_Type) return Tree_Type is
      Tree : Tree_Type;

   begin
      --  NOTE: must be done by caller:
      --      if Left'Address = Right'Address then
      --         return Left;
      --      end if;

      declare
         Root : constant Node_Access := Copy_Tree (Left.Root);
      begin
         Tree := (Root   => Root,
                  First  => Tree_Operations.Min (Root),
                  Last   => Tree_Operations.Max (Root),
                  Length => Left.Length);
      end;

      declare
         Hint : Node_Access;

         procedure Process (Node : Node_Access);
         pragma Inline (Process);

         procedure Iterate is
           new Tree_Operations.Generic_Iteration (Process);

         -------------
         -- Process --
         -------------

         procedure Process (Node : Node_Access) is
         begin
            Insert_With_Hint
              (Dst_Tree => Tree,
               Dst_Hint => Hint,
               Src_Node => Node,
               Dst_Node => Hint);
         end Process;

      --  Start of processing for Union

      begin
         Iterate (Right);

      exception
         when others =>
            Delete_Tree (Tree.Root);
            raise;
      end;

      return Tree;
   end Union;

end Ada.Containers.Red_Black_Trees.Generic_Set_Operations;