generic -- GENERIC_SORT ( ELEMENT_TYPE , INDEX_TYPE , ARRAY_TYPE , ">" )

-- See GENERIC_SORT_DEMO_*.ADA for examples of useage
-- See companion GENERIC_SEARCH

  type ELEMENT_TYPE is private ; -- simple objects, records or arrays
  type INDEX_TYPE is ( <> ) ; -- any discrete type
  type ARRAY_TYPE is array ( INDEX_TYPE range <> ) of ELEMENT_TYPE ; -- structure form

--              a comparison function must be provided if ELEMENT
--              is not a type or subtype for which ">" is visible.
--              ONLY the one comparison function is needed.
--              return true if the first parameter is larger than the second
  with function ">" ( SMALL , LARGE : ELEMENT_TYPE ) return BOOLEAN is <> ;

package GENERIC_SORT is


-- order N log N sort for large arrays

  procedure SHELL ( ARRAY_VAL : in out ARRAY_TYPE ) ;
  procedure QUIK  ( ARRAY_VAL : in out ARRAY_TYPE ) ;
  procedure HEAP  ( ARRAY_VAL : in out ARRAY_TYPE ) ;

-- low overhead sort for small arrays ( less than 20 elements )

  procedure BUBBLE ( ARRAY_VAL : in out ARRAY_TYPE ) ;

end GENERIC_SORT ;

package body GENERIC_SORT is


-- order N log N sort for large arrays

  procedure SHELL (ARRAY_VAL : in out ARRAY_TYPE ) is

    SIZE : INTEGER := INTEGER ( ARRAY_VAL'LENGTH ) ;
    M : INTEGER ;
    I : INTEGER ;
    J : INTEGER ;
    III : INTEGER ;
    LIMIT : INTEGER ;
    TEMP1 : ELEMENT_TYPE ;
    II : INDEX_TYPE ;
    IM : INDEX_TYPE ;
  begin
    M := SIZE ;
    while M > 1 loop  -- log base 2 of SIZE times
      M := M / 2 ;  -- through this loop
      LIMIT := SIZE - M ;
      for J in 1 .. LIMIT loop  -- at most SIZE times
        I := J ;  -- through this loop
        while I > 0 loop
          III := INDEX_TYPE'POS(ARRAY_VAL'FIRST) + ( I - 1 ) ;
          II := INDEX_TYPE'VAL(III) ;
          IM := INDEX_TYPE'VAL(III + M ) ;
          -- compare and interchange if necessary on whatever is being sorted
          if ARRAY_VAL ( II ) > ARRAY_VAL ( IM ) then
            TEMP1 := ARRAY_VAL ( II ) ;
            ARRAY_VAL ( II ) := ARRAY_VAL ( IM ) ;
            ARRAY_VAL ( IM ) := TEMP1 ;
            I := I - M ;  -- must check previous entry
          else
            exit ;  -- while I > 0 , previous entries sorted
          end if ;
        end loop ;  -- on while I > 0
      end loop ;  -- on for J in 1..LIMIT
    end loop ;  -- on while M > 1
  end SHELL ;

  procedure QUIK  ( ARRAY_VAL : in out ARRAY_TYPE ) is
    J : INDEX_TYPE ;
    LB : INDEX_TYPE := ARRAY_VAL'FIRST ;
    UB : INDEX_TYPE := ARRAY_VAL'LAST ;

    function REARRANGE ( LB : INDEX_TYPE ;
                         UB : INDEX_TYPE ) return INDEX_TYPE is
      A : ELEMENT_TYPE ;
      DOWN : INDEX_TYPE ;
      J : INDEX_TYPE ;
      UP : INDEX_TYPE ;
    begin
      A := ARRAY_VAL ( LB ) ;
      J := LB ;
      UP := UB ;
      DOWN := LB ;
      while DOWN < UP loop
        while ( DOWN < UP ) loop
          exit when A > ARRAY_VAL( UP ) ;
          UP := INDEX_TYPE'PRED ( UP ) ;
        end loop ;
        J := UP ;
        if DOWN < UP then
          ARRAY_VAL ( DOWN ) := ARRAY_VAL ( UP ) ;
          while DOWN < UP loop
            exit when ARRAY_VAL( DOWN ) > A ;
            DOWN := INDEX_TYPE'SUCC ( DOWN ) ;
          end loop ;
          J := DOWN ;
          if DOWN < UP then
            ARRAY_VAL ( UP ) := ARRAY_VAL ( DOWN ) ;
          end if ;
        end if ;
      end loop ;
      ARRAY_VAL ( J ) := A ;
      return J ;
    end REARRANGE ;
  begin
    if LB < UB then
      J := REARRANGE ( LB , UB ) ;
      if ( LB < J ) and then
         ( J > ARRAY_VAL'FIRST ) then
        QUIK ( ARRAY_VAL( LB .. INDEX_TYPE'PRED( J )) ) ;
      end if ;
      if ( J < UB ) and then
         ( J < ARRAY_VAL'LAST ) then
        QUIK ( ARRAY_VAL( INDEX_TYPE'SUCC( J ) .. UB) ) ;
      end if ;
    end if ;
  end QUIK ;

  procedure HEAP  ( ARRAY_VAL : in out ARRAY_TYPE ) is
    subtype POS_RANGE is INTEGER range 
                         INDEX_TYPE'Pos( Array_Val'First ) ..
                         INDEX_TYPE'Pos( Array_Val'Last );
    Last_Parent_Pos   : constant POS_RANGE := POS_RANGE'First +
                        ((( POS_RANGE'Last - POS_RANGE'First )-1 ) / 2 );     
    Last_Parent_Index : constant INDEX_TYPE := INDEX_TYPE'Val(
                        Last_Parent_Pos );
    Item_Temp : ELEMENT_TYPE ; -- Exchanges the value of two elements

    procedure REMAKE_HEAP ( Parent_Index : in     INDEX_TYPE;
                            Last_Index   : in     INDEX_TYPE ) is
      Last_Parent_Pos   : constant POS_RANGE := POS_RANGE'First +
                          ((( INDEX_TYPE'Pos( Last_Index ) -
                          POS_RANGE'First ) - 1 ) / 2 );     
      Last_Parent_Index : constant INDEX_TYPE := INDEX_TYPE'Val(
                          Last_Parent_Pos );
      L_Child           : INDEX_TYPE;
      R_Child           : INDEX_TYPE;
      Max_Child_Index   : INDEX_TYPE;
      Parent_Temp       : INDEX_TYPE := Parent_Index;
    begin 
      loop
        if Parent_Temp > Last_Parent_Index then
          exit;
        end if;
        L_Child := INDEX_TYPE'Val(((INDEX_TYPE'Pos(Parent_Temp)*2)-
                                  POS_RANGE'First)+1);
        if L_Child = Last_Index then
          Max_Child_Index := L_Child;
        else
          R_Child := INDEX_TYPE'Succ( L_Child );
          if Array_Val( L_Child ) > Array_Val( R_Child ) then
            Max_Child_Index := L_Child;
          else
            Max_Child_Index := R_Child;
          end if;
        end if;
        if Array_Val( Max_Child_Index ) > Array_Val( Parent_Temp ) then
          Item_Temp := Array_Val( Max_Child_Index ); 
          Array_Val( Max_Child_Index ) := Array_Val( Parent_Temp );
          Array_Val( Parent_Temp ) := Item_Temp;
          Parent_Temp := Max_Child_Index;
        else
          exit;
        end if;
      end loop;
    end REMAKE_HEAP;

  begin
    if Array_Val'Length <= 1 then
      return;
    end if;
    for Index_Val in reverse Array_Val'First .. Last_Parent_Index loop
      REMAKE_HEAP( Index_Val, Array_Val'Last );
    end loop;
    Item_Temp := Array_Val( Array_Val'First ); 
    Array_Val( Array_Val'First ) := Array_Val( Array_Val'Last );
    Array_Val( Array_Val'Last ) := Item_temp;
    for Index_Val in reverse INDEX_TYPE'Succ( Array_Val'First ) .. 
        INDEX_TYPE'Pred( Array_Val'Last ) loop
      REMAKE_HEAP( Array_Val'First, Index_Val );
      Item_Temp := Array_Val( Array_Val'First ); 
      Array_Val( Array_Val'First ) := Array_Val( Index_Val );
      Array_Val( Index_Val ) := Item_Temp;
    end loop;
  end HEAP ;

-- low overhead sort for small arrays

  procedure BUBBLE ( ARRAY_VAL : in out ARRAY_TYPE ) is
    TEMP : ELEMENT_TYPE ;
  begin
    for I in ARRAY_VAL'FIRST .. INDEX_TYPE'PRED ( ARRAY_VAL'LAST ) loop
      for J in INDEX_TYPE'SUCC ( I ) .. ARRAY_VAL'LAST loop
        if ARRAY_VAL ( I ) > ARRAY_VAL ( J ) then
          TEMP := ARRAY_VAL ( I ) ;
          ARRAY_VAL ( I ) := ARRAY_VAL ( J ) ;
          ARRAY_VAL ( J ) := TEMP ;
        end if ;
      end loop ;
    end loop ;
  end BUBBLE ;

end GENERIC_SORT ;