------------------------------------------------------------------------------
--                                                                          --
--                         GNAT LIBRARY COMPONENTS                         --
--                                                                          --
--         A D A . C O N T A I N E R S . S T A B L E _ S O R T I N G        --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                     Copyright (C) 1995-2023, AdaCore                     --
--                                                                          --
-- 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 3,  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.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

package body Ada.Containers.Stable_Sorting is
   package body List_Descriptors is
      procedure Doubly_Linked_List_Sort (List : List_Descriptor) is

         Empty  : constant List_Descriptor := (Nil, Nil, 0);

         function Merge_Sort (Arg : List_Descriptor) return List_Descriptor;
         --  Sort list of given length using MergeSort; length must be >= 2.
         --  As required by RM, the sort is stable.

         ----------------
         -- Merge_Sort --
         ----------------

         function Merge_Sort (Arg : List_Descriptor) return List_Descriptor
         is
            procedure Split_List
              (Unsplit : List_Descriptor; Part1, Part2 : out List_Descriptor);
            --  Split list into two parts for divide-and-conquer.
            --  Unsplit.Length must be >= 2.

            function Merge_Parts
              (Part1, Part2 : List_Descriptor) return List_Descriptor;
            --  Merge two sorted lists, preserving sorted property.

            ----------------
            -- Split_List --
            ----------------

            procedure Split_List
              (Unsplit : List_Descriptor; Part1, Part2 : out List_Descriptor)
            is
               Rover : Node_Ref := Unsplit.First;
               Bump_Count : constant Count_Type := (Unsplit.Length - 1) / 2;
            begin
               for Iter in 1 .. Bump_Count loop
                  Rover := Next (Rover);
               end loop;

               Part1 := (First  => Unsplit.First,
                         Last   => Rover,
                         Length => Bump_Count + 1);

               Part2 := (First => Next (Rover),
                         Last  => Unsplit.Last,
                         Length => Unsplit.Length - Part1.Length);

               --  Detach
               Set_Next (Part1.Last, Nil);
               Set_Prev (Part2.First, Nil);
            end Split_List;

            -----------------
            -- Merge_Parts --
            -----------------

            function Merge_Parts
              (Part1, Part2 : List_Descriptor) return List_Descriptor
            is
               procedure Detach_First (Source   : in out List_Descriptor;
                                       Detached : out Node_Ref);
               --  Detach the first element from a non-empty list and
               --  return the detached node via the Detached parameter.

               ------------------
               -- Detach_First --
               ------------------

               procedure Detach_First (Source   : in out List_Descriptor;
                                       Detached : out Node_Ref) is
               begin
                  Detached := Source.First;

                  if Source.Length = 1 then
                     Source := Empty;
                  else
                     Source := (Next (Source.First),
                                Source.Last,
                                Source.Length - 1);

                     Set_Prev (Next (Detached), Nil);
                     Set_Next (Detached, Nil);
                  end if;
               end Detach_First;

               P1     : List_Descriptor := Part1;
               P2     : List_Descriptor := Part2;
               Merged : List_Descriptor := Empty;

               Take_From_P2 : Boolean;
               Detached     : Node_Ref;

            --  Start of processing for Merge_Parts

            begin
               while P1.Length /= 0 or P2.Length /= 0 loop
                  if P1.Length = 0 then
                     Take_From_P2 := True;
                  elsif P2.Length = 0 then
                     Take_From_P2 := False;
                  else
                     --  If the compared elements are equal then Take_From_P2
                     --  must be False in order to ensure stability.

                     Take_From_P2 := P2.First < P1.First;
                  end if;

                  if Take_From_P2 then
                     Detach_First (P2, Detached);
                  else
                     Detach_First (P1, Detached);
                  end if;

                  if Merged.Length = 0 then
                     Merged := (First | Last => Detached, Length => 1);
                  else
                     Set_Prev (Detached, Merged.Last);
                     Set_Next (Merged.Last, Detached);
                     Merged.Last := Detached;
                     Merged.Length := Merged.Length + 1;
                  end if;
               end loop;
               return Merged;
            end Merge_Parts;

         --  Start of processing for Merge_Sort

         begin
            if Positive (Arg.Length) < 2 then
               --  already sorted
               return Arg;
            end if;

            declare
               Part1, Part2 : List_Descriptor;
            begin
               Split_List (Unsplit => Arg, Part1 => Part1, Part2 => Part2);

               Part1 := Merge_Sort (Part1);
               Part2 := Merge_Sort (Part2);

               return Merge_Parts (Part1, Part2);
            end;
         end Merge_Sort;

      --  Start of processing for Sort

      begin
         if List.Length > 1 then
            --  If a call to the formal "<" op references the container
            --  during sorting, seeing an empty container seems preferable
            --  to seeing an internally inconsistent container.
            --
            Update_Container (Empty);

            Update_Container (Merge_Sort (List));
         end if;
      end Doubly_Linked_List_Sort;
   end List_Descriptors;
end Ada.Containers.Stable_Sorting;