Programmer's ROM - The Computer Language Library/programmersrom.iso/ada/misc/sortarry.ada

Text File | 1988-05-03 | 60.8 KB | 1,587 lines

-------- SIMTEL20 Ada Software Repository Prologue ------------
--                                                           -*
-- Unit name    : generic package Sort_Utilities
-- Version      : 1.3 (FRAY297)
-- Author       : Geoffrey O. Mendal
--              : Stanford University
--              : Computer Systems Laboratory, ERL 456
--              : Stanford, CA  94305
--              : [phone] or 723-1175
-- DDN Address  : [e-mail]
-- Copyright    : (c) 1985, 1986, 1987 Geoffrey O. Mendal
-- Date created : Mon 11 Nov 85
-- Release date : Sun 25 Dec 85
-- Last update  : MENDAL Fri 29 May 87
-- Machine/System Compiled/Run on : DG MV10000, ROLM ADE
--                                  VAX 11/780, DEC ACS
--                                  RATIONAL R1000
--                                  SEQUENT B21000, VERDIX VADS
--                                  SUN/3, VERDIX VADS
-- Dependent Units : package SYSTEM
--                                                           -*
---------------------------------------------------------------
--                                                           -*
-- Keywords     :  SORT
----------------:  SORT UTILITIES
--
-- Abstract     :  This generic package contains several
----------------:  array sorting routines.
--                                                           -*
------------------ Revision history ---------------------------
--                                                           -*
-- DATE         VERSION              AUTHOR     HISTORY
-- 12/29/85     1.0 (MOOV115)     Mendal     Initial Release
-- 04/11/86     1.1 (FRPR116)     Mendal     ANNA formal comments
-- 12/07/86     1.2 (SUEC076)     Mendal     more ANNA annotations
-- 05/29/87     1.3 (FRAY297)     Mendal     annotation changes
--                                                           -*
------------------ Distribution and Copyright -----------------
--                                                           -*
-- This prologue must be included in all copies of this software.
--
-- This software is copyright by the author.
--
-- This software is released to the Ada community.
-- This software is released to the Public Domain (note:
--   software released to the Public Domain is not subject
--   to copyright protection).
-- Restrictions on use or distribution:  NONE
--                                                           -*
------------------ Disclaimer ---------------------------------
--                                                           -*
-- This software and its documentation are provided "AS IS" and
-- without any expressed or implied warranties whatsoever.
-- No warranties as to performance, merchantability, or fitness
-- for a particular purpose exist.
--
-- Because of the diversity of conditions and hardware under
-- which this software may be used, no warranty of fitness for
-- a particular purpose is offered.  The user is advised to
-- test the software thoroughly before relying on it.  The user
-- must assume the entire risk and liability of using this
-- software.
--
-- In no event shall any person or organization of people be
-- held responsible for any direct, indirect, consequential
-- or inconsequential damages or lost profits.
--                                                           -*
-------------------END-PROLOGUE--------------------------------

-- Sort_Utilities is a generic sorting package. The Sort subprograms
-- will sort a one dimensional array of any component type that supports
-- assignment, equality, and inequality (private types) indexed by
-- discrete type components. The default linear order is ascending order
-- but may be overridden by the user. The default sort algorithm,
-- Quicksort (non-recursive), may also be overridden.

-- Note that the component type can be a record type. The Sort subprograms
-- are not restricted to simple data types. If records are to be sorted,
-- then the formal generic subprogram parameter "<" must be
-- specified with by a linear order, e.g., a function provided
-- as an actual generic subprogram parameter at instantiation.

-- Note that the component type can be an access type (which can
-- point to other objects, improving sort efficiency). If access types
-- are to be sorted, then the formal generic subprogram parameter "<"
-- must be specified by a linear order (see example #3 below).
-- Since access types can be sorted, the Sort routine below can be
-- used to sort limited types and unconstrained types (designated by
-- an access type).

-- For data in which equality does not truly apply (i.e., real types)
-- one can use the Equal function to specify an equality operation.
-- Hence, one can decide that two numbers are "close enough" to be
-- equal (see example #4 below).

-- The number of comparisons and exchanges made to sort the array
-- can be returned. These numbers should give some indication on how
-- much work was actually performed by the sorting algorithms. These
-- numbers can also be used to compare the relative efficiency
-- of the sorting algorithms.

-- This package can be used to sort data on external devices. The user
-- should use this package to sort a subset of the external data, then
-- use a merge operation on all sorted subsets. For example, if the
-- system can only hold 1000 components in RAM, but you need to sort
-- 3000 components, bring in components #1-1000 and sort them using this
-- routine, and then write them to a file. Next do the same with
-- components #1001-2000, and finally with components #2001-3000. Now
-- merge the three sorted files using a merge package.

-- One of the Sort subprograms is a function which can be used to sort
-- an array and test it against another in an inline expression. This
-- can be useful when comparing the contents of two arrays which may be
-- equal, but not at the identical indices. This will be most useful for
-- comparing the equality of sets implemented as arrays (see example #5
-- below).

-- Other Sort subprograms allow the user to maintain the original state
-- of the array by returning a new array that is sorted. These subprograms
-- will be useful in cases where sorting is required, but the original
-- (unsorted) data must be preserved.

-- This package has been formally annotated using the ANNA specification
-- language. For more information, contact the author. Also, the
-- design of this package has been documented in the IEEE Computer
-- Society Second International Conference on Ada Applications and
-- Environments proceedings. Contact the IEEE or the author for a copy
-- of the paper. This paper is forthcoming in a special issue of IEEE
-- Software also.

with SYSTEM;  -- predefined package SYSTEM

generic
  type Component_Type is private;  -- type of the data components
  type Index_Type     is (<>);     -- type of array index

  -- The following generic formal type is required due to Ada's
  -- strong typing requirements. The SORT subprograms cannot handle
  -- anonymous array types. This type will match any unconstrained
  -- array type definition (so that array slices can be sorted
  -- too -- see example #3 below).

  type Array_Type is array (Index_Type range <>) of Component_Type;

  -- The following formal subprogram parameter defaults to the
  -- predefined "<" operator which will sort one-dimensional
  -- arrays of Component_Type in ascending order (by default).
  -- If composite or access types are to be sorted, a selector
  -- function must be specified.

  with function "<" (Left,Right : in Component_Type) return BOOLEAN is <>;

  -- The following formal subprogram parameter defaults to the predefined
  -- "=" operator. If user-defined equality is desired, one can write
  -- an equality function and specify it here.

  with function Equal (Left,Right : in Component_Type) return BOOLEAN is "=";

  -- The annotations below formally specify assumptions about the
  -- generic formals above that must be satisfied in order to perform
  -- correct sorting.

  --| for all X, Y, Z : Component_Type =>
  --|   (not (X < X)) and
  --|   (Equal (X, Y) xor (X < Y) xor (Y < X)) and
  --|   ((X < Y) and (Y < Z) -> (X < Z)) and

  --|   Equal (X, X) and
  --|   (Equal (X, Y) -> Equal (Y, X)) and
  --|   (Equal (X, Y) and Equal (Y, Z) -> Equal (X, Z)) and
  --|   (Equal (X, Y) and (X < Z) -> (Y < Z)) and
  --|   (Equal (X, Y) and (Z < X) -> (Z < Y));
package Sort_Utilities is
  function Version return STRING;  -- Returns the version number.

  -- Users can specify the type of sorting algorithm they want by
  -- specifying an enumeration literal from the type below. The default
  -- algorithm, Quicksort (non-recursive), generally performs best.

  -- One note about stability of the algorithms: only the Bubble Sorts
  -- and Insertion Sort are stable algorithms. Thus, they are the
  -- only algorithms that preserve the ordering of equal components
  -- without use of a selector function. In all cases, a selector
  -- function may be specified to introduce stability into the
  -- sorting algorithms (see example #3 below).

  type Sort_Algorithm_Type is (Quicksort, Recursive_Quicksort, Bsort,
    Bubble_Sort, Bubble_Sort_with_Quick_Exit, Selection_Sort, Heapsort,
    Insertion_Sort, Merge_Sort);

  -- Quicksort:   O(NlogN). Is most efficient when used with large, unsorted
  --              arrays. Uses an explicit stack to maintain state and
  --              partitions. Instable. This is the default algorithm.
  -- Recursive_Quicksort:  O(NlogN). Is most efficient when used with large,
  --              unsorted arrays. Recursive nature may introduce significant
  --              memory overhead for very large arrays. Instable.
  -- Bsort:       O(NlogN). Is most efficient when used with large arrays
  --              that are already sorted, partially sorted, or sorted in
  --              reverse. Recursive. Instable.
  -- Bubble_Sort: O(N**2). Is most efficient when used with small
  --              arrays that are almost already sorted. Non-recursive.
  --              Brute force. Low memory requirements. Stable.
  -- Bubble_Sort_with_Quick_Exit: O(N**2). Is most efficient when
  --              used with small arrays that are almost already sorted.
  --              Non-recursive. Same as bubble sort above except brute
  --              force is limited. Stable.
  -- Selection_Sort: O(N**2). Is most efficient when used with
  --              small arrays in which the Component_Type is a
  --              record type. Non-recursive. Brute force. Instable.
  -- Heapsort:    O(NlogN). Is most efficient when used with
  --              large, unsorted arrays. Non-recursive. Very low
  --              memory requirements. Instable.
  -- Insertion_Sort: O(N**2). Is most efficient when used with
  --              small arrays that are almost already sorted. Non-
  --              recursive. Brute force. Stable.
  -- Merge_Sort:  O(NlogN). Is most efficient when used with medium-large
  --              arrays. Non-recursive. Instable. Uses an auxiliary array
  --              to perform merging.

  -- The following type declaration should be used to specify the
  -- instrumentation analysis results that can be returned by the Sort
  -- subprograms below. -1 is only returned if an overflow in calculations
  -- has occurred. The Sort subprograms will still sort the array if an
  -- overflow in instrumentation analysis data calculations
  -- occurs.

  type Performance_Instrumentation_Type is range -1 .. SYSTEM.MAX_INT;

  -- The following exception is raised during execution of the Sort
  -- subprograms which take two arrays as parameters.  These two arrays
  -- must be of the same length.

  Sort_Arrays_Length_Mismatch : exception;

  -- The following virtual functions define the semantics of sorting.
  -- The use of Index_Type'SUCC and Index_Type'PRED might raise
  -- CONSTRAINT_ERROR on boundary limits, and need to be enhanced
  -- in these cases.  (An annotation that raises an exception during
  -- its evaluation is not consistent with the specification.)

  --: function Ordered (A : in Array_Type) return BOOLEAN;
  --|   where return (A'LENGTH <= 1) or else
  --|           (((A (A'FIRST) < A (Index_Type'SUCC (A'FIRST))) or
  --|             (Equal (A (A'FIRST), A (Index_Type'SUCC (A'FIRST))))) and
  --|            Ordered (A (Index_Type'SUCC (A'FIRST) .. A'LAST)));

  --: function Permutation (A, B : in Array_Type) return BOOLEAN;
  --|   where A'LENGTH = B'LENGTH,
  --|         Ordered (B),
  --|         return (A'LENGTH = 0) or else
  --|           (exist I : B'RANGE =>
  --|            Equal (A (A'FIRST), B (I)) and
  --|            Permutation (A (Index_Type'SUCC (A'FIRST) .. A'LAST),
  --|              B (B'FIRST .. Index_Type'PRED (I)) &
  --|              B (Index_Type'SUCC (I) .. B'LAST)));

  -- The following procedure will sort a one dimensional array of
  -- components. It can sort in ascending/descending order or any
  -- user-defined order. It can sort components of any type that
  -- support equality, inequality, and assignment (private types).
  -- The array indices can be of any discrete type. The number of
  -- comparisons and exchanges can also be returned.

  procedure Sort (
    Sort_Array             : in out Array_Type;
    Number_of_Comparisons,
    Number_of_Exchanges    :    out Performance_Instrumentation_Type;
    Sort_Algorithm         : in     Sort_Algorithm_Type := Quicksort);
    --| where out Ordered (Sort_Array),
    --|       out Permutation (in Sort_Array, Sort_Array),
    --|       out Number_of_Comparisons'DEFINED,
    --|       out Number_of_Exchanges'DEFINED,
    --|       raise Sort_Arrays_Length_Mismatch => FALSE;

  -- The following overloading of procedure Sort should be specified
  -- when no instrumentation analysis data are required.

  procedure Sort (
    Sort_Array     : in out Array_Type;
    Sort_Algorithm : in     Sort_Algorithm_Type := Quicksort);
    --| where out Ordered (Sort_Array),
    --|       out Permutation (in Sort_Array, Sort_Array),
    --|       raise Sort_Arrays_Length_Mismatch => FALSE;

  -- The following overloading of procedure Sort should be used when
  -- the original data must be preserved and instrumentation analysis
  -- results are required.

  procedure Sort (
    Unsorted_Array         : in     Array_Type;
    Sorted_Array           :    out Array_Type;
    Number_of_Comparisons,
    Number_of_Exchanges    :    out Performance_Instrumentation_Type;
    Sort_Algorithm         : in     Sort_Algorithm_Type := Quicksort);
    --| where out Ordered (Sorted_Array),
    --|       out Permutation (Unsorted_Array, Sorted_Array),
    --|       out Number_of_Comparisons'DEFINED,
    --|       out Number_of_Exchanges'DEFINED,
    --|       Unsorted_Array'LENGTH /= Sorted_Array'LENGTH =>
    --|         raise Sort_Arrays_Length_Mismatch;

  -- The following overloading of procedure Sort should be used when
  -- the original data must be preserved and no instrumentation analysis
  -- results are required.

  procedure Sort (
    Unsorted_Array : in     Array_Type;
    Sorted_Array   :    out Array_Type;
    Sort_Algorithm : in     Sort_Algorithm_Type := Quicksort);
    --| where out Ordered (Sorted_Array),
    --|       out Permutation (Unsorted_Array, Sorted_Array),
    --|       Unsorted_Array'LENGTH /= Sorted_Array'LENGTH =>
    --|         raise Sort_Arrays_Length_Mismatch;

  -- The following overloading of function Sort should be used when
  -- sorting is required in an inline expression.

  function Sort (
    Sort_Array     : in Array_Type;
    Sort_Algorithm : in Sort_Algorithm_Type := Quicksort)
    return Array_Type;
    --| where return A : Array_Type =>
    --|   Ordered (A) and Permutation (Sort_Array, A);
    --| raise Sort_Arrays_Length_Mismatch => FALSE;
end Sort_Utilities;

-- Example uses/instantiations:
--   -- EXAMPLE #1: Sorting an array of CHARACTERs
--   with Sort_Utilities;
--   procedure Main is
--     type My_Index_Type is (Sun,Mon,Tue,Wed,Thu,Fri,Sat);
--     type My_Array_Type is array (My_Index_Type range <>) of CHARACTER;
--     package Ascending_Sort is new Sort_Utilities (
--       Component_Type => CHARACTER,
--       Index_Type     => My_Index_Type,
--       Array_Type     => My_Array_Type);
--     package Descending_Sort is new Sort_Utilities (
--       Component_Type => CHARACTER,
--       Index_Type     => My_Index_Type,
--       Array_Type     => My_Array_Type,
--       "<"            => ">");
--     My_Array               : My_Array_Type (Mon .. Fri);
--     Number_of_Comparisons,
--     Number_of_Exchanges,   : Descending_Sort.Performance_Instrumentation_Type;
--   begin
--     Ascending_Sort.Sort (My_Array);
--     Descending_Sort.Sort (
--       Sort_Array             => My_Array,
--       Number_of_Comparisons  => Number_of_Comparisons,
--       Number_of_Exchanges    => Number_of_Exchanges,
--       Sort_Algorithm         => Descending_Sort.Bubble_Sort);
--   end Main;
--   -------------------------------------------------------------------
--   -- EXAMPLE #2: Sorting an array of records based on a key field
--   with Sort_Utilities;
--   procedure Main is
--     type My_Component_Type is
--       record
--         Field1 : INTEGER;
--         Field2 : FLOAT;
--         Field3 : CHARACTER;
--       end record;
--     subtype My_Index_Type is INTEGER range -10 .. 10;
--     type My_Array_Type is array (My_Index_Type range <>) of My_Component_Type;
--     My_Array : My_Array_Type (-10 .. 10);
--     function Ascending_Order_on_Field1 (Left,Right : in My_Component_Type) return BOOLEAN is
--     begin
--       return Left.Field1 < Right.Field1;
--     end Ascending_Order_on_Field1;
--     function Descending_Order_on_Field3 (Left,Right : in My_Component_Type) return BOOLEAN is
--     begin
--       return Left.Field3 > Right.Field3;
--     end Descending_Order_on_Field3;
--     package Ascending_Sort_on_Field1 is new Sort_Utilities (
--       Component_Type => My_Component_Type,
--       Index_Type     => My_Index_Type,
--       Array_Type     => My_Array_Type,
--       "<"            => Ascending_Order_on_Field1);
--     package Descending_Sort_on_Field3 is new Sort_Utilities (
--       Component_Type => My_Component_Type,
--       Index_Type     => My_Index_Type,
--       Array_Type     => My_Array_Type,
--       "<"            => Descending_Order_on_Field3);
--     Ascending_Sort_on_Field1.Sort (My_Array);
--     Descending_Sort_on_Field3.Sort (
--       Sort_Array     => My_Array,
--       Sort_Algorithm => Descending_Sort_on_Field3.Selection_Sort);
--   end Main;
--   -------------------------------------------------------------------
--   EXAMPLE #3: Sorting an array slice of access types that designate
--               records.
--   with Sort_Utilities;
--   procedure Main is
--     type Taxpayer_Type is
--       record
--         Name        : STRING (1 .. 40);
--         Age         : NATURAL;
--         ID_Number   : POSITIVE;   -- social security number
--       end record;
--     type Taxpayer_Access_Type is access Taxpayer_Type;
--     type My_Index_Type is range 1 .. 1_000_000;
--     type My_Array_Type is array (My_Index_Type range <>) of Taxpayer_Access_Type;
--     My_Array : My_Array_Type (1 .. 1_000_000);
--     function Ascending_Taxpayers (Left,Right : in Taxpayer_Access_Type) return BOOLEAN is
--     begin
--       return (Left.Name < Right.Name) or
--              ((Left.Name = Right.Name) and (Left.ID_Number < Right.ID_Number));
--     end Ascending_Taxpayers;
--     package Ascending_Taxpayer_Sort is new Sort_Utilities (
--       Taxpayer_Access_Type,My_Index_Type,My_Array_Type,Ascending_Taxpayers);
--     Ascending_Taxpayer_Sort.Sort (My_Array(100..1_000));
--   end Main;
--   ---------------------------------------------------------------------------
--   EXAMPLE #4: Sorting an array of floating point numbers using a
--               constrained array subtype
--   with Sort_Utilities;
--   procedure Main is
--     type My_Array_Type is array (POSITIVE range <>) of FLOAT;
--     subtype My_Array_Subtype is My_Array_Type (1 .. 10);
--     My_Array : My_Array_Subtype;
--     function My_Equality (L, R : in FLOAT) is
--     begin
--       . . .  -- check for "close enough" on equality
--       return <some BOOLEAN expression>;
--     end My_Equality;
--     package My_Sort_Utilities is new Sort_Utilities (FLOAT,POSITIVE,My_Array_Type,
--       My_Equality);
--   begin
--     My_Sort_Utilities.Sort (My_Array);
--   end Main;
--   ---------------------------------------------------------------------------
--   EXAMPLE #5: Sorting in an inline expression
--   with Sort_Utilities;
--   procedure Main is
--     type Set_Type is array (POSITIVE range <>) of CHARACTER;
--     Set1,
--     Set2 : Set_Type (1 .. 10);
--     package My_Sort_Utilities is new Sort_Utilities (CHARACTER,POSITIVE,Set_Type);
--   begin
--     if My_Sort_Utilities.Sort (Set1) = My_Sort_Utilities.Sort (Set2) then
--       . . .
--     end if;
--   end Main;

package body Sort_Utilities is
  Version_Number : constant STRING := "1.3 (FRAY297)";

--: function Ordered (A : in Array_Type) return BOOLEAN is
--: begin
--:   for I in A'FIRST .. Index_Type'PRED (A'LAST) loop
--:     if A (Index_Type'SUCC (I)) < A (I) then
--:       return FALSE;
--:     end if;
--:   end loop;
--:   return TRUE;
--: end Ordered;

--: function Permutation (A, B : in Array_Type) return BOOLEAN is
--:   type Mark_Array_Type is array (A'RANGE) of BOOLEAN;
--:   Mark       : Mark_Array_Type := (others => FALSE);
--:   Mark_Pos   : Index_Type;
--:   Not_Marked : BOOLEAN;
--: begin
--:   for I in A'RANGE loop
--:     Not_Marked := TRUE;
--:     for J in B'RANGE loop
--:       if Equal (A (I), B (J)) and not Mark (J) then
--:         Mark_Pos := J;
--:         exit;
--:       end if;
--:     end loop;
--:     if Not_Marked then
--:       return FALSE;
--:     else
--:       Mark (Mark_Pos) := TRUE;
--:     end if;
--:   end loop;
--:   return Mark = (others => TRUE);
--: end Permutation;

  function Version return STRING is
  begin
    return Version_Number;
  end Version;

  -- The following subprograms are utilities for the sorting
  -- procedures that follow them.

  procedure Update_Performance_Instrumentation (
    Instrumentation_Count : in out Performance_Instrumentation_Type) is
  begin
    -- Bump the counter unless an overflow has occurred.

    if Instrumentation_Count /= Performance_Instrumentation_Type'FIRST then
      if Instrumentation_Count /= Performance_Instrumentation_Type'LAST then
        Instrumentation_Count := Instrumentation_Count + 1;
      else
        Instrumentation_Count := Performance_Instrumentation_Type'FIRST;
      end if;
    end if;
  end Update_Performance_Instrumentation;

  procedure Exchange_Array_Components (
    Sort_Array          : in out Array_Type;
    Number_of_Exchanges : in out Performance_Instrumentation_Type) is

    Temporary_Component : constant Component_Type :=
      Sort_Array (Sort_Array'FIRST);
  begin
    Sort_Array (Sort_Array'FIRST) := Sort_Array (Sort_Array'LAST);
    Sort_Array (Sort_Array'LAST) := Temporary_Component;

    Update_Performance_Instrumentation (Number_of_Exchanges);
  end Exchange_Array_Components;

  -- Procedure Quicksort is the default sort algorithm used. It is
  -- a non-recursive method of sorting by constantly partitioning the
  -- array in half and sorting only that half. This algorithm is
  -- O(NlogN) and is instable.

  procedure Quicksort (
    Sort_Array             : in out Array_Type;
    Number_of_Comparisons,
    Number_of_Exchanges    :    out Performance_Instrumentation_Type) is

    type Sort_Array_Index_Save_Type is
      record
        Left,
        Right : Index_Type;
      end record;

    subtype Stack_Index_Type is NATURAL range 0 .. Sort_Array'LENGTH;

    type Stack_Array_Type is array (Stack_Index_Type) of
      Sort_Array_Index_Save_Type;

    Local_Comparisons,
    Local_Exchanges    : Performance_Instrumentation_Type := 0;
    I, J, L, R          : Index_Type;
    Temporary_Component : Component_Type;
    Stack_Pointer       : Stack_Index_Type;
    Stack_Array         : Stack_Array_Type;
  begin
    if Sort_Array'FIRST < Sort_Array'LAST then
      Stack_Pointer := 1;
      Stack_Array (1).Left  := Sort_Array'FIRST;
      Stack_Array (1).Right := Sort_Array'LAST;

      loop  -- Take top request from stack.
        L := Stack_Array (Stack_Pointer).Left;
        R := Stack_Array (Stack_Pointer).Right;
        Stack_Pointer := Stack_Pointer - 1;

        loop  -- Split Sort_Array (Sort_Array'FIRST) .. Sort_Array (R).
          I := L;
          J := R;
          Temporary_Component := Sort_Array (Index_Type'VAL (
            ((Index_Type'POS (L) + Index_Type'POS (R)) / 2)));

          loop
            loop
              Update_Performance_Instrumentation (Local_Comparisons);

              exit when (not (Sort_Array (I) < Temporary_Component)) or
                        (I = Sort_Array'LAST);

              I := Index_Type'SUCC (I);
            end loop;

            loop
              Update_Performance_Instrumentation (Local_Comparisons);

              exit when (not (Temporary_Component < Sort_Array (J))) or
                        (J = Sort_Array'FIRST);

              J := Index_Type'PRED (J);
            end loop;

            if I <= J then
              if I /= J then
                Exchange_Array_Components (Sort_Array (I .. J),Local_Exchanges);
              end if;

              if I /= Sort_Array'LAST then
                I := Index_Type'SUCC (I);
              end if;

              if J /= Sort_Array'FIRST then
                J := Index_Type'PRED (J);
              end if;
            end if;

            exit when I > J;
          end loop;

          if (Index_Type'POS (J) - Index_Type'POS (L)) <
             (Index_Type'POS (R) - Index_Type'POS (I)) then
            if I < R then
              -- Stack request for sorting right partition.

              Stack_Pointer := Stack_Pointer + 1;
              Stack_Array (Stack_Pointer).Left  := I;
              Stack_Array (Stack_Pointer).Right := R;
            end if;

            R := J;  -- Continue sorting left partition.
          else
            if L < J then
              -- Stack request for sorting left partition.

              Stack_Pointer := Stack_Pointer + 1;
              Stack_Array (Stack_Pointer).Left  := L;
              Stack_Array (Stack_Pointer).Right := J;
            end if;

            L := I;  -- Continue sorting right partition.
          end if;

          exit when L >= R;
        end loop;

        exit when Stack_Pointer = 0;
      end loop;
    end if;

    Number_of_Comparisons := Local_Comparisons;
    Number_of_Exchanges   := Local_Exchanges;
  end Quicksort;

  -- The following procedure houses a Quicksort that is identical to
  -- the one above, except that recursion manages the state and paritions
  -- instead of an explicit stack.

  procedure Recursive_Quicksort (
    Sort_Array             : in out Array_Type;
    Number_of_Comparisons,
    Number_of_Exchanges    :    out Performance_Instrumentation_Type) is

    Local_Comparisons,
    Local_Exchanges    : Performance_Instrumentation_Type := 0;

    -- The recursive nature of the sorting algorithm is found in
    -- the procedure below.

    procedure Recursive_Quick (Sort_Array : in out Array_Type) is
      I : Index_Type := Sort_Array'FIRST;
      J : Index_Type := Sort_Array'LAST;

      -- The partitioning of the array in half is found in the
      -- procedure below. It is this procedure that really sorts
      -- the array by making the necessary exchanges.

      -- This algorithm DEPENDS on the fact that there are two or
      -- more array components. Singleton or null arrays are special cases
      -- and should be handled by the outermost level of the
      -- Quicksort algorithm.

      procedure Partition is
        Sort_Array_Mid_Value : constant Component_Type :=
          Sort_Array (Index_Type'VAL ((Index_Type'POS (I) + Index_Type'POS (J)) / 2));
      begin
        loop
          while (Sort_Array (I) < Sort_Array_Mid_Value) and
                (I /= Sort_Array'LAST) loop
            Update_Performance_Instrumentation (Local_Comparisons);

            I := Index_Type'SUCC (I);
          end loop;

          while (Sort_Array_Mid_Value < Sort_Array (J)) and
                (J /= Sort_Array'FIRST) loop
            Update_Performance_Instrumentation (Local_Comparisons);

            J := Index_Type'PRED (J);
          end loop;

          if I <= J then
            if I < J then
              Exchange_Array_Components (Sort_Array (I .. J),Local_Exchanges);
            end if;

            if I /= Sort_Array'LAST then
              I := Index_Type'SUCC (I);
            end if;

            if J /= Sort_Array'FIRST then
              J := Index_Type'PRED (J);
            end if;
          end if;

          exit when (I > J) or
                    ((I = Sort_Array'LAST) and (J = Sort_Array'FIRST));
        end loop;
      end Partition;
    begin  -- Recursive_Quick
      Partition;

      if Sort_Array'FIRST < J then
        Recursive_Quick (Sort_Array (Sort_Array'FIRST .. J));
      end if;

      if I < Sort_Array'LAST then
        Recursive_Quick (Sort_Array (I .. Sort_Array'LAST));
      end if;
    end Recursive_Quick;
  begin  -- Recursive_Quicksort
    -- Handle the special cases of singleton and null arrays...
    -- do nothing.

    if Sort_Array'FIRST < Sort_Array'LAST then
      Recursive_Quick (Sort_Array);
    end if;

    Number_of_Comparisons := Local_Comparisons;
    Number_of_Exchanges   := Local_Exchanges;
  end Recursive_Quicksort;

  -- A variation on Recursive_Quicksort is found in the procedure below. It
  -- is good for sorting data that is already ordered, partially ordered,
  -- or reverse ordered. The algorithm is O(NlogN) and instable. It is
  -- a combination of Recursive_Quicksort and Bubble_Sort_with_Quick_Exit.

  procedure Bsort (
    Sort_Array             : in out Array_Type;
    Number_of_Comparisons,
    Number_of_Exchanges    :    out Performance_Instrumentation_Type) is

    Local_Comparisons,
    Local_Exchanges    : Performance_Instrumentation_Type := 0;

    -- The recursive nature of the algorithm is found in the procedure below.

    procedure Recursive_Bsort (
      Low_Index,
      High_Index    : in Index_Type;
      Mid_Component : in Component_Type) is

      Flag, Left_Flag, Right_Flag : BOOLEAN;
      I, J                        : Index_Type;
      Size                        : NATURAL;

      -- Sort_Array (Low_Index .. High_Index) are the components to be
      -- sorted, and Mid_Component is the value of the middle component.
      -- I and J are used to partition the subfiles so that at any time
      -- Sort_Array (I) < Mid_Component and (Mid_Component < Sort_Array (J)
      -- or Mid_Component = Sort_Array (J)). Left_Flag is TRUE whenever
      -- the left subfile is not in sorted order, and Right_Flag is
      -- TRUE whenever the right subfile is not in sorted order. Flag is
      -- FALSE when the partitioning processes are completed.
    begin
      if Low_Index < High_Index then
        Left_Flag  := FALSE;
        Right_Flag := FALSE;
        I          := Low_Index;
        J          := High_Index;
        Flag       := TRUE;

        while Flag loop
          loop
            Update_Performance_Instrumentation (Local_Comparisons);

            exit when (Mid_Component < Sort_Array (I)) or
                      Equal (Mid_Component,Sort_Array (I)) or (I = J);

            -- Build the left subfile ensuring that the rightmost component
            -- is always the largest of the subfile.

            if I /= Low_Index then
              Update_Performance_Instrumentation (Local_Comparisons);

              if Sort_Array (I) < Sort_Array (Index_Type'PRED (I)) then
                Exchange_Array_Components (
                  Sort_Array (Index_Type'PRED (I) .. I),Local_Exchanges);

                Left_Flag := TRUE;
              end if;
            end if;

            I := Index_Type'SUCC (I);
          end loop;

          loop
            Update_Performance_Instrumentation (Local_Comparisons);

            exit when (Sort_Array (J) < Mid_Component) or (I = J);

            -- Build the right subfile ensuring that the leftmost component
            -- is always the smallest of the subfile.

            if J /= High_Index then
              Update_Performance_Instrumentation (Local_Comparisons);

              if Sort_Array (Index_Type'SUCC (J)) < Sort_Array (J) then
                Exchange_Array_Components (
                  Sort_Array (J .. Index_Type'SUCC (J)),Local_Exchanges);

                Right_Flag := TRUE;
              end if;
            end if;

            J := Index_Type'PRED (J);
          end loop;

          if I /= J then
            -- Interchange Sort_Array (I) from the left subfile with
            -- Sort_Array (J) from the right subfile.

            Exchange_Array_Components (Sort_Array (I .. J),Local_Exchanges);
          else  -- I = J
            -- Partitioning into left and right subfiles has been completed.

            Update_Performance_Instrumentation (Local_Comparisons);

            if (Mid_Component < Sort_Array (J)) or
               Equal (Mid_Component,Sort_Array (J)) then
              -- Check the right subfile to ensure the first component,
              -- Sort_Array (J), is the smallest.

              if J /= Sort_Array'LAST then
                Update_Performance_Instrumentation (Local_Comparisons);

                if Sort_Array (Index_Type'SUCC (J)) < Sort_Array (J) then
                  Exchange_Array_Components (
                    Sort_Array (J .. Index_Type'SUCC (J)),Local_Exchanges);

                  Right_Flag := TRUE;
                end if;
              end if;
            else
              -- Check the left subfile to ensure the last component,
              -- Sort_Array (Index_Type'PRED (I)), is the largest.

              if I /= Sort_Array'FIRST then
                Update_Performance_Instrumentation (Local_Comparisons);

                if Sort_Array (I) < Sort_Array (Index_Type'PRED (I)) then
                  Exchange_Array_Components (
                    Sort_Array (Index_Type'PRED (I) .. I),Local_Exchanges);

                  Left_Flag := TRUE;
                end if;
              end if;

              if I > Index_Type'SUCC (Sort_Array'FIRST) then
                Update_Performance_Instrumentation (Local_Comparisons);

                if Sort_Array (Index_Type'PRED (I)) <
                   Sort_Array (Index_Type'PRED (Index_Type'PRED (I))) then
                  Exchange_Array_Components (
                    Sort_Array (Index_Type'PRED (Index_Type'PRED (I)) ..
                                Index_Type'PRED (I)),Local_Exchanges);
                end if;
              end if;
            end if;

            Flag := FALSE;
          end if;  -- end of "if I /= J"
        end loop;  -- end of "while Flag loop"

        -- Process the left subfile.

        Size := Index_Type'POS (I) - Index_Type'POS (Low_Index);

        if Size > 2 then
          -- Subfile must have at least three components to process and
          -- not already sorted.

          if Left_Flag then
            if Size = 3 then
              -- Special case of 3 components; place Sort_Array (Low_Index)
              -- and Sort_Array (Index_Type'SUCC (Low_Index)) in sorted order.

              Update_Performance_Instrumentation (Local_Comparisons);

              if Sort_Array (Index_Type'SUCC (Low_Index)) <
                 Sort_Array (Low_Index) then
                Exchange_Array_Components (
                  Sort_Array (Low_Index .. Index_Type'SUCC (Low_Index)),
                    Local_Exchanges);
              end if;
            else
              Recursive_Bsort (Low_Index,Index_Type'PRED (Index_Type'PRED (I)),
                Sort_Array (Index_Type'VAL (
                           ((Index_Type'POS (Low_Index) + Index_Type'POS (I)
                             - 2) / 2)
                          )));
            end if;
          end if;
        end if;

        -- Process the right subfile.

        Size := Index_Type'POS (High_Index) - Index_Type'POS (J) + 1;

        if Size > 2 then
          -- Subfile must have at least 3 components to process and not
          -- already sorted.

          if Right_Flag then
            if Size = 3 then
              -- Special case of 3 components; place
              -- Sort_Array (Index_Type'SUCC (J)) and
              -- Sort_Array (Index_Type'SUCC (Index_Type'SUCC (J))) in sorted
              -- order.

              Update_Performance_Instrumentation (Local_Comparisons);

              if Sort_Array (Index_Type'SUCC (Index_Type'SUCC (J))) <
                 Sort_Array (Index_Type'SUCC (J)) then
                Exchange_Array_Components (
                  Sort_Array (Index_Type'SUCC (J) ..
                              Index_Type'SUCC (Index_Type'SUCC (J))),
                              Local_Exchanges);
              end if;
            else
              Recursive_Bsort (Index_Type'SUCC (J),High_Index,
                Sort_Array (Index_Type'VAL (
                           ((Index_Type'POS (J) + Index_Type'POS (High_Index)
                             + 1) / 2)
                          )));
            end if;
          end if;
        end if;
      end if;  -- end of "if M < N then"
    end Recursive_Bsort;
  begin  -- Bsort
    -- Do not bother with singleton and null arrays.

    if Sort_Array'FIRST < Sort_Array'LAST then
      Recursive_Bsort (Sort_Array'FIRST,Sort_Array'LAST,
        Sort_Array (Index_Type'VAL (
         ((Index_Type'POS (Sort_Array'FIRST) +
           Index_Type'POS (Sort_Array'LAST)) / 2))));
    end if;

    Number_of_Comparisons := Local_Comparisons;
    Number_of_Exchanges   := Local_Exchanges;
  end Bsort;

  -- A bubble sort algorithm is found in the procedure below. The
  -- algorithm used is a standard bubble sort. This algorithm is
  -- O(N**2) and is stable.

  procedure Bubble_Sort (
    Sort_Array             : in out Array_Type;
    Number_of_Comparisons,
    Number_of_Exchanges    :    out Performance_Instrumentation_Type) is

    Local_Comparisons,
    Local_Exchanges    : Performance_Instrumentation_Type := 0;
  begin
    -- Check for the singleton/null array cases... do nothing.

    if Sort_Array'FIRST < Sort_Array'LAST then
      for I in Sort_Array'FIRST .. Index_Type'VAL (Index_Type'POS (Sort_Array'LAST) - 1) loop
        for J in Sort_Array'FIRST ..
                 Index_Type'VAL (
                                 (Index_Type'POS (Sort_Array'LAST)  +
                                  Index_Type'POS (Sort_Array'FIRST) - 1
                                 ) -
                                 Index_Type'POS (I)
                                ) loop
          Update_Performance_Instrumentation (Local_Comparisons);

          if Sort_Array (Index_Type'SUCC (J)) < Sort_Array (J) then
            Exchange_Array_Components (Sort_Array (J .. Index_Type'SUCC (J)),
                                       Local_Exchanges);
          end if;
        end loop;
      end loop;
    end if;

    Number_of_Comparisons := Local_Comparisons;
    Number_of_Exchanges   := Local_Exchanges;
  end Bubble_Sort;

  -- A bubble sort algorithm is found in the procedure below. The
  -- algorithm used is a standard bubble sort with a quick exit. The
  -- quick exit is taken if the data just happens to be sorted
  -- in the middle of the process. Thus, this algorithm may be faster
  -- than O(N**2) for arrays that are already partially ordered.

  procedure Bubble_Sort_with_Quick_Exit (
    Sort_Array             : in out Array_Type;
    Number_of_Comparisons,
    Number_of_Exchanges    :    out Performance_Instrumentation_Type) is

    Local_Comparisons,
    Local_Exchanges    : Performance_Instrumentation_Type := 0;
    Interchange_Made   : BOOLEAN;
  begin
    -- Check for the singleton/null array cases... do nothing.

    if Sort_Array'FIRST < Sort_Array'LAST then
      for I in Sort_Array'FIRST .. Index_Type'VAL (
               Index_Type'POS (Sort_Array'LAST) - 1) loop
        Interchange_Made := FALSE;

        for J in Sort_Array'FIRST ..
                 Index_Type'VAL (
                                 (Index_Type'POS (Sort_Array'LAST) +
                                  Index_Type'POS (Sort_Array'FIRST) - 1
                                 ) -
                                 Index_Type'POS (I)
                                ) loop
          Update_Performance_Instrumentation (Local_Comparisons);

          if Sort_Array (Index_Type'SUCC (J)) < Sort_Array (J) then
            Interchange_Made := TRUE;
            Exchange_Array_Components (Sort_Array (J .. Index_Type'SUCC (J)),
                                       Local_Exchanges);
          end if;
        end loop;

        exit when not Interchange_Made;
      end loop;
    end if;

    Number_of_Comparisons := Local_Comparisons;
    Number_of_Exchanges   := Local_Exchanges;
  end Bubble_Sort_with_Quick_Exit;

  -- A straight selection sort follows below. It is O(N**2) and
  -- is instable.

  procedure Selection_Sort (
    Sort_Array             : in out Array_Type;
    Number_of_Comparisons,
    Number_of_Exchanges    :    out Performance_Instrumentation_Type) is

    Local_Comparisons,
    Local_Exchanges    : Performance_Instrumentation_Type := 0;
    Small              : Index_Type;
  begin
    -- Check for singelton/null array case... do nothing.

    if Sort_Array'FIRST < Sort_Array'LAST then
      for I in Sort_Array'FIRST .. Index_Type'PRED (Sort_Array'LAST) loop
        Small := I;

        for J in Index_Type'SUCC (I) .. Sort_Array'LAST loop
          Update_Performance_Instrumentation (Local_Comparisons);

          if Sort_Array (J) < Sort_Array (Small) then
            Small := J;
          end if;
        end loop;

        if I /= Small then
          Exchange_Array_Components (Sort_Array (I .. Small),Local_Exchanges);
        end if;
      end loop;
    end if;

    Number_of_Comparisons := Local_Comparisons;
    Number_of_Exchanges   := Local_Exchanges;
  end Selection_Sort;

  -- Heapsort follows below. It is O(NlogN) and is instable.

  procedure Heapsort (
    Sort_Array             : in out Array_Type;
    Number_of_Comparisons,
    Number_of_Exchanges    :    out Performance_Instrumentation_Type) is

    Local_Comparisons,
    Local_Exchanges     : Performance_Instrumentation_Type := 0;
    I,J                 : Index_Type;
    Temporary_Component : Component_Type;
  begin
    -- Check for special array cases: do nothing on singleton/null,
    -- must handle an array of 2 elements separate since the algorithm
    -- assumes that Sort_Array'LENGTH >= 3.

    if Sort_Array'LENGTH = 2 then
      Update_Performance_Instrumentation (Local_Comparisons);

      if Sort_Array (Sort_Array'LAST) < Sort_Array (Sort_Array'FIRST) then
        Exchange_Array_Components (Sort_Array,Local_Exchanges);
      end if;
    elsif Sort_Array'FIRST < Sort_Array'LAST then
      -- Create initial heap.

      for K in Index_Type'SUCC (Sort_Array'FIRST) .. Sort_Array'LAST loop
        -- Insert Sort_Array (K) into existing heap of size K-1.

        I := K;
        Temporary_Component := Sort_Array (K);

        -- The complex expression in assigning to J below is necessary
        -- due to the generic nature of the algorithm. This
        -- expression is used in other places below too.

        if Index_Type'POS (I) >= 0 then
          J := Index_Type'VAL ((Index_Type'POS (I) +
               Index_Type'POS (Sort_Array'FIRST) - 1) / 2);
        elsif ((Index_Type'POS (I) + Index_Type'POS (Sort_Array'FIRST) - 1)
               mod 2) = 0 then
          J := Index_Type'VAL ((Index_Type'POS (I) +
               Index_Type'POS (Sort_Array'FIRST) - 1) / 2);
        else
          J := Index_Type'VAL ((Index_Type'POS (I) +
               Index_Type'POS (Sort_Array'FIRST) - 2) / 2);
        end if;

        while J >= Sort_Array'FIRST loop
          Update_Performance_Instrumentation (Local_Comparisons);

          exit when (Temporary_Component < Sort_Array (J)) or
            Equal (Temporary_Component,Sort_Array (J));

          Update_Performance_Instrumentation (Local_Exchanges);
          Sort_Array (I) := Sort_Array (J);
          I := J;

          if Index_Type'POS (I) >= 0 then
            if (((Index_Type'POS (I) + Index_Type'POS (Sort_Array'FIRST) - 1) / 2) >=
                Index_Type'POS (Sort_Array'FIRST)
               ) and
               (I /= Sort_Array'FIRST) then
              J := Index_Type'VAL (
                     (Index_Type'POS (I) + Index_Type'POS (Sort_Array'FIRST) - 1)
                     / 2);
            else
              exit;  -- Exit while loop.
            end if;
          elsif ((Index_Type'POS (I) + Index_Type'POS (Sort_Array'FIRST) - 1)
                 mod 2) = 0 then
             if (((Index_Type'POS (I) + Index_Type'POS (Sort_Array'FIRST) - 1) / 2) >=
                 Index_Type'POS (Sort_Array'FIRST)
                ) and
                (I /= Sort_Array'FIRST) then
               J := Index_Type'VAL (
                      (Index_Type'POS (I) + Index_Type'POS (Sort_Array'FIRST) - 1)
                      / 2);
             else
               exit;  -- Exit while loop.
             end if;
           elsif (((Index_Type'POS (I) + Index_Type'POS (Sort_Array'FIRST) - 1) / 2) >=
                  Index_Type'POS (Sort_Array'FIRST)
                 ) and
                 (I /= Sort_Array'FIRST) then
                J := Index_Type'VAL (
                       (Index_Type'POS (I) + Index_Type'POS (Sort_Array'FIRST) - 2)
                       / 2);
           else
             exit;  -- Exit while loop.
          end if;
        end loop;  -- End of while loop.

        Update_Performance_Instrumentation (Local_Comparisons);

        if not Equal (Temporary_Component,Sort_Array (I)) then
          Update_Performance_Instrumentation (Local_Exchanges);
          Sort_Array (I) := Temporary_Component;
        end if;
      end loop;  -- End of for loop.

      -- We remove Sort_Array (Sort_Array'FIRST) and place it in its
      -- proper position in the array. We then adjust the heap.

      for K in reverse Index_Type'SUCC (Sort_Array'FIRST) .. Sort_Array'LAST loop
        Update_Performance_Instrumentation (Local_Exchanges);
        Temporary_Component := Sort_Array (K);
        Sort_Array (K) := Sort_Array (Sort_Array'FIRST);

        -- Readjust the heap of order K-1. Move Temporary_Component down the
        -- heap for proper position.

        I := Sort_Array'FIRST;
        J := Index_Type'SUCC (I);

        -- The following if statement can be described as follows:
        --   if (Sort_Array (Element#2) < Sort_Array (Element#3)) and
        --      (Position of K's predecessor >= Position of Element#3) then
        --     J := Position of Element#3;
        --   end if;
        -- The complications are due to the generic nature of the
        -- algorithm.

        Update_Performance_Instrumentation (Local_Comparisons);

        if ((Sort_Array (Index_Type'SUCC (Sort_Array'FIRST))) <
            (Sort_Array (Index_Type'SUCC (Index_Type'SUCC (Sort_Array'FIRST))))
           ) and
           (Index_Type'PRED (K) >=
            Index_Type'SUCC (Index_Type'SUCC (Sort_Array'FIRST))
           ) then
          J := Index_Type'SUCC (Index_Type'SUCC (Sort_Array'FIRST));
        end if;

        -- J is the larger son of I in the heap of size K-1.

        while J <= Index_Type'PRED (K) loop
          Update_Performance_Instrumentation (Local_Comparisons);

          if (Sort_Array (J) < Temporary_Component) or
             Equal (Sort_Array (J),Temporary_Component) then
            exit;  -- exit while loop
          end if;

          Update_Performance_Instrumentation (Local_Exchanges);
          Sort_Array (I) := Sort_Array (J);
          I := J;

          if (((Index_Type'POS (I) * 2) - Index_Type'POS (Sort_Array'FIRST) + 1) <=
              Index_Type'POS (Index_Type'PRED (Sort_Array'LAST))
             ) and
             (((Index_Type'POS (I) * 2) - Index_Type'POS (Sort_Array'FIRST) + 1) >=
              Index_Type'POS (Sort_Array'FIRST)
             ) then
            J := Index_Type'VAL (
                   (Index_Type'POS (I) * 2) - Index_Type'POS (Sort_Array'FIRST) + 1);
          else
            exit;  -- Exit while loop.
          end if;

          if Index_Type'SUCC (J) <= Index_Type'PRED (K) then
            Update_Performance_Instrumentation (Local_Comparisons);

            if Sort_Array (J) < Sort_Array (Index_Type'SUCC (J)) then
              J := Index_Type'SUCC (J);
            end if;
          end if;
        end loop;  -- End of while loop.

        Update_Performance_Instrumentation (Local_Exchanges);
        Sort_Array (I) := Temporary_Component;
      end loop;  -- End of for loop.
    end if;

    Number_of_Comparisons := Local_Comparisons;
    Number_of_Exchanges   := Local_Exchanges;
  end Heapsort;

  -- Simple insertion sort follows below. It is O(N**2), but usually
  -- better than a bubble sort.

  procedure Insertion_Sort (
    Sort_Array             : in out Array_Type;
    Number_of_Comparisons,
    Number_of_Exchanges    :    out Performance_Instrumentation_Type) is

    Local_Comparisons,
    Local_Exchanges     : Performance_Instrumentation_Type := 0;
    I                   : Index_Type;
    Temporary_Component : Component_Type;
    Found               : BOOLEAN;
  begin
    -- Handle special cases of singleton/null arrays...
    -- do nothing.

    if Sort_Array'FIRST < Sort_Array'LAST then
      -- Initially Sort_Array (Sort_Array'FIRST) may be thought of
      -- as a sorted file of one element. After each repetition of
      -- the following loop, the elements Sort_Array (Sort_Array'FIRST)
      -- through Sort_Array (K) are in order.

      for K in Index_Type'SUCC (Sort_Array'FIRST) .. Sort_Array'LAST loop
        -- insert Sort_Array (K) into the sorted file

        Temporary_Component := Sort_Array (K);

        -- Move down one position all elements "greater" than
        -- Temporary_Component

        I := Index_Type'PRED (K);
        Found := FALSE;

        while (not Found) loop
          Update_Performance_Instrumentation (Local_Comparisons);

          if Temporary_Component < Sort_Array (I) then
            Update_Performance_Instrumentation (Local_Exchanges);
            Sort_Array (Index_Type'SUCC (I)) := Sort_Array (I);

            if I /= Sort_Array'FIRST then
              I := Index_Type'PRED (I);
            else
              exit;  -- Exit while loop.
            end if;
          else
            Found := TRUE;
          end if;
        end loop;  -- End of while loop.

        -- Insert Temporary_Component at proper position.

        Update_Performance_Instrumentation (Local_Exchanges);

        if Found then
          Sort_Array (Index_Type'SUCC (I)) := Temporary_Component;
        else
          Sort_Array (Sort_Array'FIRST) := Temporary_Component;
        end if;
      end loop;  -- End of for loop.
    end if;

    Number_of_Comparisons := Local_Comparisons;
    Number_of_Exchanges := Local_Exchanges;
  end Insertion_Sort;

  -- The straight merge sort procedure below is O(NlogN) and is instable.

  procedure Merge_Sort (
    Sort_Array             : in out Array_Type;
    Number_of_Comparisons,
    Number_of_Exchanges    :    out Performance_Instrumentation_Type) is

    Auxiliary_Array    : Array_Type (Sort_Array'FIRST .. Sort_Array'LAST);
    Lower_Bound1,
    Lower_Bound2,
    Upper_Bound1,
    Upper_Bound2,
    Auxiliary_Index,
    I, J               : Index_Type;
    I_Overflow,
    J_Overflow,
    Aux_Overflow       : BOOLEAN;
    Size               : POSITIVE := 1;  -- Merge files of size 1.
    Local_Comparisons,
    Local_Exchanges    : Performance_Instrumentation_Type := 0;
  begin
    while Size < Sort_Array'LENGTH loop
      Lower_Bound1 := Sort_Array'FIRST;
      Auxiliary_Index := Auxiliary_Array'FIRST;

      -- Check if there are two files to merge.

      while (Index_Type'POS (Lower_Bound1) + Size) <=
             Index_Type'POS (Sort_Array'LAST) loop
        I_Overflow := FALSE;
        J_Overflow := FALSE;
        Aux_Overflow := FALSE;

        -- Compute remaining indices.

        Lower_Bound2 := Index_Type'VAL (Index_Type'POS (Lower_Bound1) +
                                        Size);
        Upper_Bound1 := Index_Type'PRED (Lower_Bound2);

        if Index_Type'POS (Lower_Bound2) + Size - 1 >
           Index_Type'POS (Sort_Array'LAST) then
          Upper_Bound2 := Sort_Array'LAST;
        else
          Upper_Bound2 := Index_Type'VAL (Index_Type'POS (Lower_Bound2) +
                                          Size - 1);
        end if;

        -- Proceed through the two subfiles.

        I := Lower_Bound1;
        J := Lower_Bound2;

        while (I <= Upper_Bound1) and (J <= Upper_Bound2) loop
          -- Enter smaller into Auxiliary_Array.

          Update_Performance_Instrumentation (Local_Comparisons);
          Update_Performance_Instrumentation (Local_Exchanges);

          if (Sort_Array (I) < Sort_Array (J)) or
             Equal (Sort_Array (I),Sort_Array (J)) then
            Auxiliary_Array (Auxiliary_Index) := Sort_Array (I);

            if Auxiliary_Index /= Auxiliary_Array'LAST then
              Auxiliary_Index := Index_Type'SUCC (Auxiliary_Index);
            else
              Aux_Overflow := TRUE;
            end if;

            if I /= Sort_Array'LAST then
              I := Index_Type'SUCC (I);
            else
              I_Overflow := TRUE;
              exit;
            end if;
          else
            Auxiliary_Array (Auxiliary_Index) := Sort_Array (J);

            if Auxiliary_Index /= Auxiliary_Array'LAST then
              Auxiliary_Index := Index_Type'SUCC (Auxiliary_Index);
            else
              Aux_Overflow := TRUE;
            end if;

            if J /= Sort_Array'LAST then
              J := Index_Type'SUCC (J);
            else
              J_Overflow := TRUE;
              exit;
            end if;
          end if;
        end loop;  -- While loop.

        -- At this point one of the subfiles has been exhausted.
        -- Insert any remaining portions of the other file.

        while (not I_Overflow) and (I <= Upper_Bound1) loop
          Update_Performance_Instrumentation (Local_Exchanges);

          Auxiliary_Array (Auxiliary_Index) := Sort_Array (I);

          if I /= Sort_Array'LAST then
            I := Index_Type'SUCC (I);
          else
            I_Overflow := TRUE;
          end if;

          if Auxiliary_Index /= Auxiliary_Array'LAST then
            Auxiliary_Index := Index_Type'SUCC (Auxiliary_Index);
          else
            Aux_Overflow := TRUE;
          end if;
        end loop;

        while (not J_Overflow) and (J <= Upper_Bound2) loop
          Update_Performance_Instrumentation (Local_Exchanges);

          Auxiliary_Array (Auxiliary_Index) := Sort_Array (J);

          if J /= Sort_Array'LAST then
            J := Index_Type'SUCC (J);
          else
            J_Overflow := TRUE;
          end if;

          if Auxiliary_Index /= Auxiliary_Array'LAST then
            Auxiliary_Index := Index_Type'SUCC (Auxiliary_Index);
          else
            Aux_Overflow := TRUE;
          end if;
        end loop;

        -- Advance Lower_Bound1 to start of next pair of files.

        if Index_Type'POS (Upper_Bound2) + 1 <=
           Index_Type'POS (Sort_Array'LAST) then
          Lower_Bound1 := Index_Type'SUCC (Upper_Bound2);
        else
          Lower_Bound1 := Sort_Array'LAST;
        end if;
      end loop;  -- While loop.

      -- Copy any remaining single file.

      I := Lower_Bound1;

      while not Aux_Overflow loop
        Update_Performance_Instrumentation (Local_Exchanges);

        Auxiliary_Array (Auxiliary_Index) := Sort_Array (I);

        if Auxiliary_Index /= Auxiliary_Array'LAST then
          Auxiliary_Index := Index_Type'SUCC (Auxiliary_Index);
        else
          Aux_Overflow := TRUE;
        end if;

        if I /= Sort_Array'LAST then
          I := Index_Type'SUCC (I);
        else
          I_Overflow := TRUE;
        end if;
      end loop;

      -- Adjust Sort_Array and Size.

      Sort_Array := Auxiliary_Array;

      Size := Size * 2;
    end loop;  -- While loop.

    Number_of_Comparisons := Local_Comparisons;
    Number_of_Exchanges := Local_Exchanges;
  end Merge_Sort;

  procedure Sort (
    Sort_Array             : in out Array_Type;
    Number_of_Comparisons,
    Number_of_Exchanges    :    out Performance_Instrumentation_Type;
    Sort_Algorithm         : in     Sort_Algorithm_Type := Quicksort) is
  begin
    -- Call the right sorting algorithm.

    case Sort_Algorithm is
      when Quicksort =>
        Quicksort (Sort_Array,Number_of_Comparisons,Number_of_Exchanges);
      when Recursive_Quicksort =>
        Recursive_Quicksort (Sort_Array,Number_of_Comparisons,Number_of_Exchanges);
      when Bsort =>
        Bsort (Sort_Array,Number_of_Comparisons,Number_of_Exchanges);
      when Bubble_Sort =>
        Bubble_Sort (Sort_Array,Number_of_Comparisons,Number_of_Exchanges);
      when Bubble_Sort_with_Quick_Exit =>
        Bubble_Sort_with_Quick_Exit (Sort_Array,Number_of_Comparisons,Number_of_Exchanges);
      when Selection_Sort =>
        Selection_Sort (Sort_Array,Number_of_Comparisons,Number_of_Exchanges);
      when Heapsort =>
        Heapsort (Sort_Array,Number_of_Comparisons,Number_of_Exchanges);
      when Insertion_Sort =>
        Insertion_Sort (Sort_Array,Number_of_Comparisons,Number_of_Exchanges);
      when Merge_Sort =>
        Merge_Sort (Sort_Array,Number_of_Comparisons,Number_of_Exchanges);
    end case;
  end Sort;

  -- Overloading of procedure Sort that does not return instrumentation
  -- analysis data follows below.

  procedure Sort (
    Sort_Array     : in out Array_Type;
    Sort_Algorithm : in     Sort_Algorithm_Type := Quicksort) is

    Dummy_Comparisons,
    Dummy_Exchanges    : Performance_Instrumentation_Type;
  begin
    Sort (Sort_Array,Dummy_Comparisons,Dummy_Exchanges,Sort_Algorithm);
  end Sort;

  -- Overloading of procedure Sort used to preserve original data and to
  -- return instrumentation analysis results follows below.

  procedure Sort (
    Unsorted_Array         : in     Array_Type;
    Sorted_Array           :    out Array_Type;
    Number_of_Comparisons,
    Number_of_Exchanges    :    out Performance_Instrumentation_Type;
    Sort_Algorithm         : in     Sort_Algorithm_Type := Quicksort) is

    Local_Array : Array_Type (Unsorted_Array'RANGE) := Unsorted_Array;
  begin
    Number_of_Comparisons := 0;
    Number_of_Exchanges   := 0;

    -- Check for equal length of both arrays.

    if Unsorted_Array'LENGTH /= Sorted_Array'LENGTH then
      raise Sort_Arrays_Length_Mismatch;
    end if;

    Sort (Local_Array,Number_of_Comparisons,Number_of_Exchanges,
      Sort_Algorithm);

    Sorted_Array := Local_Array;
  end Sort;

  -- Overloading of procedure Sort used to preserve the original data
  -- follows below.

  procedure Sort (
    Unsorted_Array : in     Array_Type;
    Sorted_Array   :    out Array_Type;
    Sort_Algorithm : in     Sort_Algorithm_Type := Quicksort) is

    Local_Array        : Array_Type (Unsorted_Array'RANGE) := Unsorted_Array;
    Dummy_Comparisons,
    Dummy_Exchanges    : Performance_Instrumentation_Type;
  begin
    -- Check for equal length of both arrays.

    if Unsorted_Array'LENGTH /= Sorted_Array'LENGTH then
      raise Sort_Arrays_Length_Mismatch;
    end if;

    Sort (Local_Array,Dummy_Comparisons,Dummy_Exchanges,Sort_Algorithm);

    Sorted_Array := Local_Array;
  end Sort;

  -- Overloading of function Sort used in inline expressions follows below.

  function Sort (
    Sort_Array     : in Array_Type;
    Sort_Algorithm : in Sort_Algorithm_Type := Quicksort)
    return Array_Type is

    Sorted_Array       : Array_Type (Sort_Array'RANGE) := Sort_Array;
    Dummy_Comparisons,
    Dummy_Exchanges    : Performance_Instrumentation_Type;
  begin
    Sort (Sorted_Array,Dummy_Comparisons,Dummy_Exchanges,Sort_Algorithm);

    return Sorted_Array;
  end Sort;
end Sort_Utilities;