home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / swag / sorting.swg / 0045_Full featured Sort Unit.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-11-26  |  10.5 KB  |  233 lines
  1. Unit SORTER;
  2.  
  3. INTERFACE
  4.  
  5. TYPE
  6.   PtrArray     = ARRAY[1..1] OF Pointer;
  7.  
  8.   TCompareFunction = FUNCTION (VAR AnArray; Item1, Item2 : LongInt) : Integer;
  9.     { A TCompareFunction must return:   }
  10.     {   1  if the Item1 > Item2         }
  11.     {   0  if the Item1 = Item2         }
  12.     {  -1  if the Item1 < Item2         }
  13.  
  14.   TSwapProcedure  = PROCEDURE (VAR AnArray; Item1, Item2 : LongInt);
  15.  
  16.  
  17. PROCEDURE CombSort (VAR AnArray; Min, Max : LongInt;
  18.                     Compare : TCompareFunction; Swap : TSwapProcedure);
  19.  
  20.   { Compare Procedures - Must write your own Compare for pointer variables. }
  21.   { This allows one sort routine to be used on any array.                   }
  22. FUNCTION  CompareChars    (VAR AnArray; Item1, Item2 : LongInt) : Integer;
  23.                            FAR;
  24. FUNCTION  CompareInts     (VAR AnArray; Item1, Item2 : LongInt) : Integer;
  25.                            FAR;
  26. FUNCTION  CompareLongInts (VAR AnArray; Item1, Item2 : LongInt) : Integer;
  27.                            FAR;
  28. FUNCTION  CompareReals    (VAR AnArray; Item1, Item2 : LongInt) : Integer;
  29.                            FAR;
  30. FUNCTION  CompareStrs     (VAR AnArray; Item1, Item2 : LongInt) : Integer;
  31.                            FAR;
  32.  
  33.   { Swap procedures to be used in any sorting routine.  }
  34.   { This allows one sorting routine to be on any array. }
  35. PROCEDURE SwapChars    (VAR AnArray; A, B : LongInt); FAR;
  36. PROCEDURE SwapInts     (VAR AnArray; A, B : LongInt); FAR;
  37. PROCEDURE SwapLongInts (VAR AnArray; A, B : LongInt); FAR;
  38. PROCEDURE SwapPtrs     (VAR AnArray; A, B : LongInt); FAR;
  39. PROCEDURE SwapReals    (VAR AnArray; A, B : LongInt); FAR;
  40. PROCEDURE SwapStrs     (VAR AnArray; A, B : LongInt); FAR;
  41. {****************************************************************************}
  42.                                IMPLEMENTATION
  43. {****************************************************************************}
  44. TYPE
  45.   CharArray    = ARRAY[1..1] OF Char;
  46.   IntArray     = ARRAY[1..1] OF Integer;
  47.   LongIntArray = ARRAY[1..1] OF LongInt;
  48.   RealArray    = ARRAY[1..1] OF Real;
  49.   StrArray     = ARRAY[1..1] OF String;
  50.  
  51. {****************************************************************************}
  52. {                                                                            }
  53. {                      Local Procedures and Functions                        }
  54. {                                                                            }
  55. {****************************************************************************}
  56. PROCEDURE AdjustArrayIndexes (VAR Min, Max : LongInt);
  57.   { Adjusts array indexes to a one-based array. }
  58. VAR Fudge : LongInt;
  59. BEGIN
  60.   Fudge := 1 - Min;
  61.   Inc(Min,Fudge);
  62.   Inc(Max,Fudge);
  63. END;
  64. {****************************************************************************}
  65. {                                                                            }
  66. {                      Global Procedures and Functions                       }
  67. {                                                                            }
  68. {****************************************************************************
  69. }PROCEDURE CombSort (VAR AnArray; Min, Max : LongInt;
  70.                     Compare : TCompareFunction; Swap : TSwapProcedure);
  71.   { The combsort is an optimised version of the bubble sort. It uses a }
  72.   { decreasing gap in order to compare values of more than one element }
  73.   { apart.  By decreasing the gap the array is gradually "combed" into }
  74.   { order ... like combing your hair. First you get rid of the large   }
  75.   { tangles, then the smaller ones ...                                 }
  76.   {                                                                    }
  77.   { There are a few particular things about the combsort. Firstly, the }
  78.   { optimal shrink factor is 1.3 (worked out through a process of      }
  79.   { exhaustion by the guys at BYTE magazine). Secondly, by never       }
  80.   { having a gap of 9 or 10, but always using 11, the sort is faster.  }
  81.   {                                                                    }
  82.   { This sort approximates an n log n sort - it's faster than any      }
  83.   { other sort I've seen except the quicksort (and it beats that too   }
  84.   { sometimes ... have you ever seen a quicksort become an (n-1)^2     }
  85.   { sort ... ?). The combsort does not slow down under *any*           }
  86.   { circumstances. In fact, on partially sorted lists (including       }
  87.   { *reverse* sorted lists) it speeds up.                              }
  88.   {                                                                    }
  89.   { More information in the April 1991 BYTE magazine.                  }
  90. CONST ShrinkFactor = 1.3;
  91. VAR Gap, i   : LongInt;
  92.     Finished : Boolean;
  93. BEGIN
  94.   AdjustArrayIndexes(Min,Max);
  95.   Gap := Round(Max/ShrinkFactor);
  96.   REPEAT
  97.     Finished := TRUE;
  98.     Gap := Trunc(Gap/ShrinkFactor);
  99.     IF Gap < 1
  100.        THEN Gap := 1
  101.        ELSE IF (Gap = 9) OR (Gap = 10)
  102.                THEN Gap := 11;
  103.     FOR i := Min TO (Max - Gap) DO
  104.         IF Compare(AnArray,i,i+Gap) = 1
  105.            THEN BEGIN
  106.                   Swap(AnArray,i,i+Gap);
  107.                   Finished := False;
  108.                 END;
  109.   UNTIL ((Gap = 1) AND Finished);
  110. END;
  111. {****************************************************************************
  112. }{                                                                           
  113.  }{                            Compare
  114. Procedures                              }{                                   
  115.                                          }{**********************************
  116. ******************************************}FUNCTION CompareChars (VAR 
  117. AnArray; Item1, Item2 : LongInt) : Integer;BEGIN
  118.   IF CharArray(AnArray)[Item1] < CharArray(AnArray)[Item2]
  119.      THEN CompareChars := -1
  120.      ELSE IF CharArray(AnArray)[Item1] = CharArray(AnArray)[Item2]
  121.              THEN CompareChars := 0
  122.              ELSE CompareChars := 1;
  123. END;
  124. {*****************************************************************************}
  125. FUNCTION CompareInts (VAR AnArray; Item1, Item2 : LongInt) : Integer;
  126. BEGIN
  127.   IF IntArray(AnArray)[Item1] < IntArray(AnArray)[Item2]
  128.      THEN CompareInts := -1
  129.      ELSE IF IntArray(AnArray)[Item1] = IntArray(AnArray)[Item2]
  130.              THEN CompareInts := 0
  131.              ELSE CompareInts := 1;
  132. END;
  133. {*****************************************************************************}
  134. FUNCTION CompareLongInts (VAR AnArray; Item1, Item2 : LongInt) : Integer;
  135. BEGIN
  136.   IF LongIntArray(AnArray)[Item1] < LongIntArray(AnArray)[Item2]
  137.      THEN CompareLongInts := -1
  138.      ELSE IF LongIntArray(AnArray)[Item1] = LongIntArray(AnArray)[Item2]
  139.              THEN CompareLongInts := 0
  140.              ELSE CompareLongInts := 1;
  141. END;
  142. {*****************************************************************************}
  143. FUNCTION CompareReals (VAR AnArray; Item1, Item2 : LongInt) : Integer;
  144. BEGIN
  145.   IF RealArray(AnArray)[Item1] < RealArray(AnArray)[Item2]
  146.      THEN CompareReals := -1
  147.      ELSE IF RealArray(AnArray)[Item1] = RealArray(AnArray)[Item2]
  148.              THEN CompareReals := 0
  149.              ELSE CompareReals := 1;
  150. END;
  151. {*****************************************************************************}
  152. FUNCTION CompareStrs (VAR AnArray; Item1, Item2 : LongInt) : Integer;
  153. BEGIN
  154.   IF StrArray(AnArray)[Item1] < StrArray(AnArray)[Item2]
  155.      THEN CompareStrs := -1
  156.      ELSE IF StrArray(AnArray)[Item1] = StrArray(AnArray)[Item2]
  157.              THEN CompareStrs := 0
  158.              ELSE CompareStrs := 1;
  159. END;
  160. {****************************************************************************}
  161. {                                                                            }
  162. {                             Move Procedures                                }
  163. {                                                                            }
  164. {****************************************************************************}
  165. PROCEDURE MoveChar (VAR AnArray; Item : LongInt; VAR Hold);
  166. BEGIN
  167.   Char(Hold) := CharArray(AnArray)[Item];
  168. END;
  169. {****************************************************************************}
  170. {                                                                            }
  171. {                           MoveBack Procedures                              }
  172. {                                                                            }
  173. {****************************************************************************}
  174. PROCEDURE MoveBackChar (VAR AnArray; Item : LongInt; VAR Hold);
  175. BEGIN
  176.   CharArray(AnArray)[Item] := Char(Hold);
  177. END;
  178. {****************************************************************************}
  179. {                                                                            }
  180. {                             Swap Procedures                                }
  181. {                                                                            }
  182. {****************************************************************************}
  183. PROCEDURE SwapChars (VAR AnArray; A, B : LongInt);
  184. VAR Item : Char;
  185. BEGIN
  186.   Item := CharArray(AnArray)[A];
  187.   CharArray(AnArray)[A] := CharArray(AnArray)[B];
  188.   CharArray(AnArray)[B] := Item;
  189. END;
  190. {*****************************************************************************}
  191. PROCEDURE SwapInts (VAR AnArray; A, B : LongInt);
  192. VAR Item : Integer;
  193. BEGIN
  194.   Item := IntArray(AnArray)[A];
  195.   IntArray(AnArray)[A] := IntArray(AnArray)[B];
  196.   IntArray(AnArray)[B] := Item;
  197. END;
  198. {*****************************************************************************}
  199. PROCEDURE SwapLongInts (VAR AnArray; A, B : LongInt);
  200. VAR Item : LongInt;
  201. BEGIN
  202.   Item := LongIntArray(AnArray)[A];
  203.   LongIntArray(AnArray)[A] := LongIntArray(AnArray)[B];
  204.   LongIntArray(AnArray)[B] := Item;
  205. END;
  206. {****************************************************************************}
  207. PROCEDURE SwapPtrs (VAR AnArray; A, B : LongInt);
  208. VAR Item : Pointer;
  209. BEGIN
  210.   Item := PtrArray(AnArray)[A];
  211.   PtrArray(AnArray)[A] := PtrArray(AnArray)[B];
  212.   PtrArray(AnArray)[B] := Item;
  213. END;
  214. {****************************************************************************}
  215. PROCEDURE SwapReals (VAR AnArray; A, B : LongInt);
  216. VAR Item : Real;
  217. BEGIN
  218.   Item := RealArray(AnArray)[A];
  219.   RealArray(AnArray)[A] := RealArray(AnArray)[B];
  220.   RealArray(AnArray)[B] := Item;
  221. END;
  222. {*****************************************************************************}
  223. PROCEDURE SwapStrs (VAR AnArray; A, B : LongInt);
  224. VAR Item : String;
  225. BEGIN
  226.   Item := StrArray(AnArray)[A];
  227.   StrArray(AnArray)[A] := StrArray(AnArray)[B];
  228.   StrArray(AnArray)[B] := Item;
  229. END;
  230. {*****************************************************************************}
  231. BEGIN
  232. END.
  233.