[Back to SORTING SWAG index] [Back to Main SWAG index] [Original]

    Unit SORTER;

    INTERFACE

    TYPE
      PtrArray     = ARRAY[1..1] OF Pointer;

      TCompareFunction = FUNCTION (VAR AnArray; Item1, Item2 : LongInt) : Integer;
        { A TCompareFunction must return:   }
        {   1  if the Item1 > Item2         }
        {   0  if the Item1 = Item2         }
        {  -1  if the Item1 < Item2         }

      TSwapProcedure  = PROCEDURE (VAR AnArray; Item1, Item2 : LongInt);

    PROCEDURE CombSort (VAR AnArray; Min, Max : LongInt;
                        Compare : TCompareFunction; Swap : TSwapProcedure);

      { Compare Procedures - Must write your own Compare for pointer variables. }
      { This allows one sort routine to be used on any array.                   }
    FUNCTION  CompareChars    (VAR AnArray; Item1, Item2 : LongInt) : Integer;
                               FAR;
    FUNCTION  CompareInts     (VAR AnArray; Item1, Item2 : LongInt) : Integer;
                               FAR;
    FUNCTION  CompareLongInts (VAR AnArray; Item1, Item2 : LongInt) : Integer;
                               FAR;
    FUNCTION  CompareReals    (VAR AnArray; Item1, Item2 : LongInt) : Integer;
                               FAR;
    FUNCTION  CompareStrs     (VAR AnArray; Item1, Item2 : LongInt) : Integer;
                               FAR;

      { Swap procedures to be used in any sorting routine.  }
      { This allows one sorting routine to be on any array. }
    PROCEDURE SwapChars    (VAR AnArray; A, B : LongInt); FAR;
    PROCEDURE SwapInts     (VAR AnArray; A, B : LongInt); FAR;
    PROCEDURE SwapLongInts (VAR AnArray; A, B : LongInt); FAR;
    PROCEDURE SwapPtrs     (VAR AnArray; A, B : LongInt); FAR;
    PROCEDURE SwapReals    (VAR AnArray; A, B : LongInt); FAR;
    PROCEDURE SwapStrs     (VAR AnArray; A, B : LongInt); FAR;
    {****************************************************************************}
                                   IMPLEMENTATION
    {****************************************************************************}
    TYPE
      CharArray    = ARRAY[1..1] OF Char;
      IntArray     = ARRAY[1..1] OF Integer;
      LongIntArray = ARRAY[1..1] OF LongInt;
      RealArray    = ARRAY[1..1] OF Real;
      StrArray     = ARRAY[1..1] OF String;

    {****************************************************************************}
    {                                                                            }
    {                      Local Procedures and Functions                        }
    {                                                                            }
    {****************************************************************************}
    PROCEDURE AdjustArrayIndexes (VAR Min, Max : LongInt);
      { Adjusts array indexes to a one-based array. }
    VAR Fudge : LongInt;
    BEGIN
      Fudge := 1 - Min;
      Inc(Min,Fudge);
      Inc(Max,Fudge);
    END;
    {****************************************************************************}
    {                                                                            }
    {                      Global Procedures and Functions                       }
    {                                                                            }
    {****************************************************************************
    }PROCEDURE CombSort (VAR AnArray; Min, Max : LongInt;
                        Compare : TCompareFunction; Swap : TSwapProcedure);
      { The combsort is an optimised version of the bubble sort. It uses a }
      { decreasing gap in order to compare values of more than one element }
      { apart.  By decreasing the gap the array is gradually "combed" into }
      { order ... like combing your hair. First you get rid of the large   }
      { tangles, then the smaller ones ...                                 }
      {                                                                    }
      { There are a few particular things about the combsort. Firstly, the }
      { optimal shrink factor is 1.3 (worked out through a process of      }
      { exhaustion by the guys at BYTE magazine). Secondly, by never       }
      { having a gap of 9 or 10, but always using 11, the sort is faster.  }
      {                                                                    }
      { This sort approximates an n log n sort - it's faster than any      }
      { other sort I've seen except the quicksort (and it beats that too   }
      { sometimes ... have you ever seen a quicksort become an (n-1)^2     }
      { sort ... ?). The combsort does not slow down under *any*           }
      { circumstances. In fact, on partially sorted lists (including       }
      { *reverse* sorted lists) it speeds up.                              }
      {                                                                    }
      { More information in the April 1991 BYTE magazine.                  }
    CONST ShrinkFactor = 1.3;
    VAR Gap, i   : LongInt;
        Finished : Boolean;
    BEGIN
      AdjustArrayIndexes(Min,Max);
      Gap := Round(Max/ShrinkFactor);
      REPEAT
        Finished := TRUE;
        Gap := Trunc(Gap/ShrinkFactor);
        IF Gap < 1
           THEN Gap := 1
           ELSE IF (Gap = 9) OR (Gap = 10)
                   THEN Gap := 11;
        FOR i := Min TO (Max - Gap) DO
            IF Compare(AnArray,i,i+Gap) = 1
               THEN BEGIN
                      Swap(AnArray,i,i+Gap);
                      Finished := False;
                    END;
      UNTIL ((Gap = 1) AND Finished);
    END;
    {****************************************************************************
    }{
     }{                            Compare
    Procedures                              }{
                                             }{**********************************
    ******************************************}FUNCTION CompareChars (VAR
    AnArray; Item1, Item2 : LongInt) : Integer;BEGIN
      IF CharArray(AnArray)[Item1] < CharArray(AnArray)[Item2]
         THEN CompareChars := -1
         ELSE IF CharArray(AnArray)[Item1] = CharArray(AnArray)[Item2]
                 THEN CompareChars := 0
                 ELSE CompareChars := 1;
    END;
    {*****************************************************************************}
    FUNCTION CompareInts (VAR AnArray; Item1, Item2 : LongInt) : Integer;
    BEGIN
      IF IntArray(AnArray)[Item1] < IntArray(AnArray)[Item2]
         THEN CompareInts := -1
         ELSE IF IntArray(AnArray)[Item1] = IntArray(AnArray)[Item2]
                 THEN CompareInts := 0
                 ELSE CompareInts := 1;
    END;
    {*****************************************************************************}
    FUNCTION CompareLongInts (VAR AnArray; Item1, Item2 : LongInt) : Integer;
    BEGIN
      IF LongIntArray(AnArray)[Item1] < LongIntArray(AnArray)[Item2]
         THEN CompareLongInts := -1
         ELSE IF LongIntArray(AnArray)[Item1] = LongIntArray(AnArray)[Item2]
                 THEN CompareLongInts := 0
                 ELSE CompareLongInts := 1;
    END;
    {*****************************************************************************}
    FUNCTION CompareReals (VAR AnArray; Item1, Item2 : LongInt) : Integer;
    BEGIN
      IF RealArray(AnArray)[Item1] < RealArray(AnArray)[Item2]
         THEN CompareReals := -1
         ELSE IF RealArray(AnArray)[Item1] = RealArray(AnArray)[Item2]
                 THEN CompareReals := 0
                 ELSE CompareReals := 1;
    END;
    {*****************************************************************************}
    FUNCTION CompareStrs (VAR AnArray; Item1, Item2 : LongInt) : Integer;
    BEGIN
      IF StrArray(AnArray)[Item1] < StrArray(AnArray)[Item2]
         THEN CompareStrs := -1
         ELSE IF StrArray(AnArray)[Item1] = StrArray(AnArray)[Item2]
                 THEN CompareStrs := 0
                 ELSE CompareStrs := 1;
    END;
    {****************************************************************************}
    {                                                                            }
    {                             Move Procedures                                }
    {                                                                            }
    {****************************************************************************}
    PROCEDURE MoveChar (VAR AnArray; Item : LongInt; VAR Hold);
    BEGIN
      Char(Hold) := CharArray(AnArray)[Item];
    END;
    {****************************************************************************}
    {                                                                            }
    {                           MoveBack Procedures                              }
    {                                                                            }
    {****************************************************************************}
    PROCEDURE MoveBackChar (VAR AnArray; Item : LongInt; VAR Hold);
    BEGIN
      CharArray(AnArray)[Item] := Char(Hold);
    END;
    {****************************************************************************}
    {                                                                            }
    {                             Swap Procedures                                }
    {                                                                            }
    {****************************************************************************}
    PROCEDURE SwapChars (VAR AnArray; A, B : LongInt);
    VAR Item : Char;
    BEGIN
      Item := CharArray(AnArray)[A];
      CharArray(AnArray)[A] := CharArray(AnArray)[B];
      CharArray(AnArray)[B] := Item;
    END;
    {*****************************************************************************}
    PROCEDURE SwapInts (VAR AnArray; A, B : LongInt);
    VAR Item : Integer;
    BEGIN
      Item := IntArray(AnArray)[A];
      IntArray(AnArray)[A] := IntArray(AnArray)[B];
      IntArray(AnArray)[B] := Item;
    END;
    {*****************************************************************************}
    PROCEDURE SwapLongInts (VAR AnArray; A, B : LongInt);
    VAR Item : LongInt;
    BEGIN
      Item := LongIntArray(AnArray)[A];
      LongIntArray(AnArray)[A] := LongIntArray(AnArray)[B];
      LongIntArray(AnArray)[B] := Item;
    END;
    {****************************************************************************}
    PROCEDURE SwapPtrs (VAR AnArray; A, B : LongInt);
    VAR Item : Pointer;
    BEGIN
      Item := PtrArray(AnArray)[A];
      PtrArray(AnArray)[A] := PtrArray(AnArray)[B];
      PtrArray(AnArray)[B] := Item;
    END;
    {****************************************************************************}
    PROCEDURE SwapReals (VAR AnArray; A, B : LongInt);
    VAR Item : Real;
    BEGIN
      Item := RealArray(AnArray)[A];
      RealArray(AnArray)[A] := RealArray(AnArray)[B];
      RealArray(AnArray)[B] := Item;
    END;
    {*****************************************************************************}
    PROCEDURE SwapStrs (VAR AnArray; A, B : LongInt);
    VAR Item : String;
    BEGIN
      Item := StrArray(AnArray)[A];
      StrArray(AnArray)[A] := StrArray(AnArray)[B];
      StrArray(AnArray)[B] := Item;
    END;
    {*****************************************************************************}
    BEGIN
    END.

[Back to SORTING SWAG index] [Back to Main SWAG index] [Original]