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

    {*******************************************************************}
    {                                                                   }
    {     WVS Software Company                                          }
    {     Turbo Pascal Sorting Unit for TCollections                    }
    {     Usage Fee: None, public domain                                }
    {     Version: 1.0                                                  }
    {     Release Date: 6/27/93                                         }
    {                                                                   }
    {     Programmer: Brad Williams                                     }
    {     E-mail    : bwilliams@marvin.ag.uidaho.edu                    }
    {     US Mail   : 1008 E. 7th                                       }
    {                 Moscow, Idaho 83843                               }
    {                                                                   }
    {*******************************************************************}
    {                                                                   }
    {  This unit contains objects for performing various types of       }
    {  sorts.  To use any of the sorting methods, simply pass them a    }
    {  collection and a compare or test function.  You can write your   }
    {  programs to accept a TSortProcedure/TSearchFunction as a         }
    {  parameter to any function or procedure and use whichever type    }
    {  of sort/search you require at that point in your program.  The   }
    {  search and sort methods accept pointers to compare and test      }
    {  functions so that the same functions can be used for iterative   }
    {  procedures/functions in a TSortedCollection.                     }
    {                                                                   }
    {*******************************************************************}
    UNIT TVSorts;
    {****************************************************************************}
                                     INTERFACE
    {****************************************************************************}
    USES Objects;

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

      TSortProcedure = PROCEDURE  (ACollection : PCollection;
                                   Compare : TCompareFunction);

      { Sort Procedures }
    PROCEDURE BinaryInsertionSort (ACollection : PCollection;
                                   Compare : TCompareFunction);
    PROCEDURE BubbleSort (ACollection : PCollection; Compare : TCompareFunction);
    PROCEDURE CombSort   (ACollection : PCollection; Compare : TCompareFunction);
    PROCEDURE HeapSort   (ACollection : PCollection; Compare : TCompareFunction);
    PROCEDURE QuickSort  (ACollection : PCollection; Compare : TCompareFunction);
    PROCEDURE QuickSortNonRecursive (ACollection : PCollection;
                                     Compare : TCompareFunction);
    PROCEDURE ShakerSort (ACollection : PCollection; Compare : TCompareFunction);
    PROCEDURE ShellSort  (ACollection : PCollection; Compare : TCompareFunction);
    PROCEDURE StraightInsertionSort (ACollection : PCollection;
                                     Compare : TCompareFunction);
    PROCEDURE StraightSelectionSort (ACollection : PCollection;
                                     Compare : TCompareFunction);
    PROCEDURE TreeSort (ACollection : PCollection; Compare : TCompareFunction);

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

    {****************************************************************************}
                                   IMPLEMENTATION
    {****************************************************************************}
    {                                                                            }
    {                      Local Procedures and Functions                        }
    {                                                                            }
    {****************************************************************************}
    PROCEDURE Swap (ACollection : PCollection; A, B : Integer);
    VAR Item : Pointer;
    BEGIN
      Item := ACollection^.At(A);
      ACollection^.AtPut(A,ACollection^.At(B));
      ACollection^.AtPut(B,Item);
    END;
    {****************************************************************************}
    {                                                                            }
    {                      Global Procedures and Functions                       }
    {                                                                            }
    {****************************************************************************}
    PROCEDURE BinaryInsertionSort (ACollection : PCollection;
                                   Compare : TCompareFunction);
    VAR i, j, Middle, Left, Right : LongInt;
    BEGIN
      FOR i := 0 TO (ACollection^.Count - 1) DO
          BEGIN
            Left := 0;
            Right := i;
            WHILE Left < Right DO
              BEGIN
                Middle := (Left + Right) DIV 2;
                WITH ACollection^ DO
                  IF Compare(At(Middle),At(i)) < 1
                     THEN Left := Middle + 1
                     ELSE Right := Middle;
              END;
            FOR j := i DOWNTO (Right + 1) DO
                Swap(ACollection,j,j-1);
          END;
    END;
    {****************************************************************************}
    PROCEDURE BubbleSort (ACollection : PCollection; Compare : TCompareFunction);
    VAR i, j : Integer;
    BEGIN
      WITH ACollection^ DO
        FOR i := 1 TO (Count - 1) DO
            FOR j := (Count - 1) DOWNTO i DO
            IF Compare(At(j-1),At(j)) = 1
               THEN Swap(ACollection,j,j-1);
    END;
    {****************************************************************************}
    PROCEDURE CombSort (ACollection : PCollection; Compare : TCompareFunction);
      { 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
      Gap := Round((ACollection^.Count-1)/ShrinkFactor);
      WITH ACollection^ DO
        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 := 0 TO ((Count - 1) - Gap) DO
              IF Compare(At(i),At(i+Gap)) = 1
                 THEN BEGIN
                        Swap(ACollection,i,i+gap);
                        Finished := False;
                      END;
      UNTIL ((Gap = 1) AND Finished);
    END;
    {****************************************************************************}
    PROCEDURE HeapSort (ACollection : PCollection; Compare : TCompareFunction);
      { Performs best when items are in inverse order. }
    VAR L, R : LongInt;
        X : Pointer;
        {*****************************************}
        PROCEDURE Sift;
        VAR i, j : LongInt;
            Label 13;
        BEGIN
          i := L;
          j := 2 * i;
          X := ACollection^.At(i);
          WITH ACollection^ DO
            WHILE j <= R DO
              BEGIN
                IF j < R
                   THEN IF Compare(At(j),At(j+1)) = -1
                           THEN Inc(j);
                IF Compare(X,At(j)) >= 0
                   THEN GoTo 13;
                AtPut(i,At(j));
                i := j;
                j := 2 * i;
              END;
          13: ACollection^.AtPut(i,X);
        END;
        {*****************************************}
    BEGIN
      L := ((ACollection^.Count - 1) DIV 2) + 1;
      R := ACollection^.Count - 1;
      WHILE L > 0 DO
        BEGIN
          Dec(L);
          Sift;
        END;
      WHILE R > 0 DO
        BEGIN
          X := ACollection^.At(1);
          Swap(ACollection,0,R);
          Dec(R);
          Sift;
        END;
    END;
    {****************************************************************************}
    PROCEDURE QuickSort (ACollection : PCollection; Compare : TCompareFunction);
      {****************************************************************}
      PROCEDURE Sort (Left, Right : LongInt);
      VAR i, j  : LongInt;
          X : Pointer;
      BEGIN
        WITH ACollection^ DO
          BEGIN
            i := Left;
            j := Right;
            X := At((Left + Right) DIV 2);
            REPEAT
              WHILE Compare(At(i),X) = -1 DO Inc(i);
              WHILE Compare(X,At(j)) = -1 DO Dec(j);
              IF i <= j
                 THEN BEGIN
                        Swap(ACollection,i,j);
                        Inc(i);
                        Dec(j)
                    END;
            UNTIL i > j;
            IF Left < j
               THEN Sort(Left,j);
            IF i < Right
               THEN Sort(i,Right)
          END;
      END;
      {****************************************************************}
    BEGIN
      Sort(0,ACollection^.Count-1);
    END;
    {****************************************************************************}
    PROCEDURE QuickSortNonRecursive (ACollection : PCollection;
                                     Compare : TCompareFunction);
    CONST m = 12;
    VAR i, j, L, R : LongInt;
        x : Pointer;
        s : 0..m;
        Stack : ARRAY[1..m] OF RECORD
                                 l, r : LongInt;
                               END;
    BEGIN
      s := 1;
      Stack[1].l := 0;
      Stack[1].r := ACollection^.Count - 1;
      WITH ACollection^ DO
        REPEAT
          L := Stack[s].l;
          R := Stack[s].r;
          Dec(S);
          REPEAT
            i := L;
            j := R;
            x := At((L + R) DIV 2);
            REPEAT
              WHILE Compare(x,At(i)) =  1 DO Inc(i);
              WHILE Compare(x,At(j)) = -1 DO Dec(j);
              IF i <= j
                 THEN BEGIN
                        Swap(ACollection,i,j);
                        Inc(i);
                        Dec(j);
                      END;
            UNTIL i > j;
            IF i < R
               THEN BEGIN
                      Inc(s);
                      Stack[s].l := i;
                      Stack[s].r := R;
                    END;
            R := j;
          UNTIL L >= R;
        UNTIL s = 0;
    END;
    {****************************************************************************}
    PROCEDURE ShakerSort (ACollection : PCollection; Compare : TCompareFunction);
      { Works for any array and any index range. }
    VAR j, k, Left, Right : LongInt;
    BEGIN
      Left := 1;
      Right := (ACollection^.Count - 1);
      k := Right;
      WITH ACollection^ DO
        REPEAT
          FOR j := Right DOWNTO Left DO
              IF Compare(At(j-1),At(j)) = 1
                 THEN BEGIN
                        Swap(ACollection,j,j-1);
                        k := j;
                      END;
          Left := k + 1;
          FOR j := Left TO Right DO
              IF Compare(At(j-1),At(j)) = 1
                 THEN BEGIN
                        Swap(ACollection,j,j-1);
                        k := j;
                      END;
          Right := k - 1;
        UNTIL Left > Right;
    END;
    {****************************************************************************}
    PROCEDURE ShellSort (ACollection : PCollection; Compare : TCompareFunction);
    VAR Gap, i, j, k : LongInt;
    BEGIN
      Gap := (ACollection^.Count - 1) DIV 2;
      WHILE (Gap > 0) DO
        BEGIN
          FOR i := Gap TO (ACollection^.Count - 1) DO
              BEGIN
                j := i - Gap;
                WHILE (j > -1) DO
                  BEGIN
                    k := j + Gap;
                    IF Compare(ACollection^.At(j),ACollection^.At(k)) < 1
                       THEN j := 0
                       ELSE Swap(ACollection,j,k);
                    Dec(j,Gap);
                  END;
              END;
          Gap := Gap DIV 2;
        END;
    END;
    {****************************************************************************}
    PROCEDURE StraightInsertionSort (ACollection : PCollection;
                                     Compare : TCompareFunction);
    VAR i, j : LongInt;
        X : Pointer;
    BEGIN
      WITH ACollection^ DO
        FOR i := 0 TO (Count - 1) DO
          BEGIN
            X := At(i);
            j := i;
            WHILE (j > 0) AND (Compare(X,At(j-1)) = -1) DO
              BEGIN
                AtPut(j,At(j-1));
                Dec(j);
              END;
            AtPut(j,X);
          END;
    END;
    {****************************************************************************}
    PROCEDURE StraightSelectionSort (ACollection : PCollection;
                                     Compare : TCompareFunction);
    VAR i, j, k  : LongInt;
    BEGIN
      FOR i := 0 TO (ACollection^.Count - 1) DO
          BEGIN
            k := i;
            FOR j := (i + 1) TO (ACollection^.Count - 1) DO
                IF Compare(ACollection^.At(j),ACollection^.At(k)) = -1
                   THEN k := j;
            Swap(ACollection,i,k);
          END;
    END;
    {****************************************************************************}
    PROCEDURE TreeSort (ACollection : PCollection; Compare : TCompareFunction);
    {after D.Cooke, A.H.Craven, G.M.Clarke: Statistical Computing
     in Pascal, Publisher: Edward Arnold, London 1985 ISBN 0-7131-3545-X }
    TYPE PNode    = ^Node;
         Node = RECORD
                  Value : Pointer;
                  Left  : PNode;
                  Right : PNode;
                END;
    VAR  Add, Top : PNode;
         i    : LongInt;
        {***********************************************************}
        PROCEDURE MakeTree (VAR Node : PNode);
        BEGIN
          IF Node = NIL
             THEN Node := Add
             ELSE IF Compare(Add^.Value,Node^.Value) = 1
                     THEN MakeTree(Node^.Right)
                     ELSE MakeTree(Node^.Left);
        END;
        {**********************************************************}
         PROCEDURE StripTree (Node : PNode);
         BEGIN
           IF Node <> NIL
              THEN BEGIN
                     StripTree(Node^.Left);
                     ACollection^.AtPut(i,Node^.Value);
                     Inc(i);
                     StripTree(Node^.Right)
                   END;
         END;
        {**********************************************************}
    BEGIN
      Top := NIL;
      FOR i := 0 TO (ACollection^.Count - 1) DO
        BEGIN
          New(Add);
          Add^.Value := ACollection^.At(i);
          Add^.Left  := NIL;
          Add^.Right := NIL;
          MakeTree(Top)
        END;
        i := 0;
        StripTree(Top)
    END;
    {****************************************************************************}
    {                                                                            }
    {                            Compare Procedures                              }
    {                                                                            }
    {****************************************************************************}
    FUNCTION CompareChars (Item1, Item2 : Pointer) : Integer;
    BEGIN
      IF Char(Item1^) < Char(Item2^)
         THEN CompareChars := -1
         ELSE CompareChars := Ord(Char(Item1^) <> Char(Item2^));
    END;
    {*****************************************************************************}
    FUNCTION CompareInts (Item1, Item2 : Pointer) : Integer;
    BEGIN
      IF Integer(Item1^) < Integer(Item2^)
         THEN CompareInts := -1
         ELSE CompareInts := Ord(Integer(Item1^) <> Integer(Item2^));
    END;
    {*****************************************************************************}
    FUNCTION CompareLongInts (Item1, Item2 : Pointer) : Integer;
    BEGIN
      IF LongInt(Item1^) < LongInt(Item2^)
         THEN CompareLongInts := -1
         ELSE CompareLongInts := Ord(LongInt(Item1^) <> LongInt(Item2^));
    END;
    {*****************************************************************************}
    FUNCTION CompareReals (Item1, Item2 : Pointer) : Integer;
    BEGIN
      IF Real(Item1^) < Real(Item2^)
         THEN CompareReals := -1
         ELSE CompareReals := Ord(Real(Item1^) <> Real(Item2^));
    END;
    {*****************************************************************************}
    FUNCTION CompareStrs (Item1, Item2 : Pointer) : Integer;
    BEGIN
      IF String(Item1^) < String(Item2^)
         THEN CompareStrs := -1
         ELSE CompareStrs := Ord(String(Item1^) <> String(Item2^));
    END;
    {*****************************************************************************}
    BEGIN
    END.

    { -----------------------------------  DEMO PROGRAM ---------------------}

    PROGRAM Test;
    USES Crt, Objects, TVSorts;

    CONST
      MaxCollectionSize = 10;

    VAR C : TCollection;
        i, j, k : Integer;
        Ch : ^Char;

    BEGIN
      Randomize;
      FOR i := 1 TO 11 DO
        BEGIN
            { initialize collection and load with data in reverse order }
          C.Init(MaxCollectionSize,1);
          FOR j := MaxCollectionSize DOWNTO 0 DO
              BEGIN
                k := Random(255);
                WHILE (k < 65) OR (k > 90) DO k := Random(255);
                New(Ch);
                Ch^ := Char(k);
                C.AtInsert(0,Ch);
              END;
            { display unsorted data }
          ClrScr;
          CASE i OF
            1 : WriteLn('Binary Insertion Sort');
            2 : WriteLn('Bubble Sort');
            3 : WriteLn('Comb Sort');
            4 : WriteLn('Heap Sort');
            5 : WriteLn('Quick Sort');
            6 : WriteLn('Non-recursive Quick Sort');
            7 : WriteLn('Shaker Sort');
            8 : WriteLn('Shell Sort');
            9 : WriteLn('Straight Insertion Sort');
           10 : WriteLn('Straight Selection Sort');
           11 : WriteLn('Tree Sort');
          END;
          FOR j := 0 TO (C.Count - 1) DO Write(Char(C.At(j)^):2);
            { sort data }
          CASE i OF
            1 : BinaryInsertionSort(@C,CompareChars);
            2 : BubbleSort(@C,CompareChars);
            3 : CombSort(@C,CompareChars);
            4 : HeapSort(@C,CompareChars);
            5 : QuickSort(@C,CompareChars);
            6 : QuickSortNonRecursive(@C,CompareChars);
            7 : ShakerSort(@C,CompareChars);
            8 : ShellSort(@C,CompareChars);
            9 : StraightInsertionSort(@C,CompareChars);
           10 : StraightSelectionSort(@C,CompareChars);
           11 : TreeSort(@C,CompareChars);
          END;
            { display sorted data }
          WriteLn;
          FOR j := 0 TO (C.Count - 1) DO Write(Char(C.At(j)^):2);
          ReadLn;
            { clear of collection }
        END;
    END.

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