Category : Pascal Source Code
Archive   : ALLSWAG4.ZIP
Filename : SORTING.SWG

SWAGOLX.EXE (c) 1993 GDSOFT ALL RIGHTS RESERVED 00048 SORTING ROUTINES 1 05-28-9313:57ALL SWAG SUPPORT TEAM ALPHAREC.PAS IMPORT 7 S¬Í { Alphabetic Rec Sort }ããProcedure SortIt(Key : Byte);ãVarã I, J : Byte;ããProcedure Swapper;ãVarã T : Member;ããbeginã T := Memrec[I];ã MemRec[I] := MemRec[J];ã MemRec[J] := T;ãend;ããbeginã For I := 1 to MaxMem - 1 DOã For J := I To MaxMem do beginã Case Key OFã 1 : if MemRec[I].Firstname < MemRec[J].FirstName then Swapper;ã 2 : if MemRec[I].LastName < MemRec[J].LastName then Swapper;ã 3 : if MemRec[I].Points < MemRec[J].Points then Swapper;ã end;ãend;ãã{ãAnother Alternative would be to do as C does, make a Generic Sort routineãwhere you pass it a Function that returns > 0 if Record1 is greater thanãRecord2, < 0 if Record1 is Less than Record2, and 0 if they are the same.ã}ã 2 05-28-9313:57ALL GUY MCLOUGHLIN Anangram Sort IMPORT 196 SÀj (* Start of PART 1 of 7 *)ãã(***********************************************************************ã Contest 3 Entry : Anagram Sort by Guy McLoughlinã Compiler : Borland Pascal 7.0ã***********************************************************************)ãã {.$DEFINE DebugMode}ãã {$IFDEF DebugMode}ã {$A+,B-,D+,E-,F-,G+,I+,L+,N-,O-,P-,Q+,R+,S+,T+,V+,X-}ã {$ELSE}ã {$A+,B-,D-,E-,F-,G+,I-,L-,N-,O-,P-,Q-,R-,S+,T-,V-,X-}ã {$endIF}ãã {$M 16384,374784,655360}ããProgram Anagram_Sort;ããConstã co_MaxWord = 2500;ã co_MaxSize = 65519;ã co_SafeSize = 64500;ããTypeã Char_12 = Array[1..12] of Char;ãã st_4 = String[4];ã st_10 = String[10];ã st_80 = String[80];ãã byar_26 = Array[97..122] of Byte;ãã po_Buff = ^byar_Buffer;ã byar_Buffer = Array[1..co_MaxSize] of Byte;ãã porc_Word = ^rc_Word;ã rc_Word = Recordã wo_Pos : Word;ã ar_LtrChk : Char_12;ã st_Word : st_10ã end;ãã poar_Word = Array[0..co_MaxWord] of porc_Word;ãã porc_AnaGroup = ^rc_AnaGroup;ã rc_AnaGroup = Recordã wo_Pos : Word;ã st_Group : st_80ã end;ãã poar_AnaGroup = Array[0..co_MaxWord] of porc_AnaGroup;ã poar_Generic = Array[0..co_MaxWord] of Pointer;ãã (***** Check For I/O errors. *)ã (* *)ã Procedure CheckIOerror;ã Varã by_Error : Byte;ã beginã by_Error := ioresult;ã if (by_Error <> 0) thenã beginã Writeln('Input/Output error = ', by_Error);ã haltã endã end; (* CheckIOerror. *)ãã (***** Display HEAP error message. *)ã (* *)ã Procedure HeapError;ã beginã Writeln('Insuficient free HEAP memory');ã haltã end; (* HeapError. *)ããTypeã Item = Pointer;ã ar_Item = poar_Generic;ã CompFunc = Function(Var Item1, Item2 : Item) : Boolean;ãã (* end of PART 1 of 7 *)ã (* Start of PART 2 of 7 *)ãã (***** QuickSort routine. *)ã (* *)ã Procedure QuickSort({update} Var ar_Data : ar_Item;ã {input } wo_Left,ã wo_Right : Word;ã LessThan : CompFunc);ã Varã Pivot,ã TempItem : Item;ã wo_Index1,ã wo_Index2 : Word;ã beginã wo_Index1 := wo_Left;ã wo_Index2 := wo_Right;ã Pivot := ar_Data[(wo_Left + wo_Right) div 2];ã Repeatã While LessThan(ar_Data[wo_Index1], Pivot) doã inc(wo_Index1);ã While LessThan(Pivot, ar_Data[wo_Index2]) doã dec(wo_Index2);ã if (wo_Index1 <= wo_Index2) thenã beginã TempItem := ar_Data[wo_Index1];ã ar_Data[wo_Index1] := ar_Data[wo_Index2];ã ar_Data[wo_Index2] := TempItem;ã inc(wo_Index1);ã dec(wo_Index2)ã endã Until (wo_Index1 > wo_Index2);ã if (wo_Left < wo_Index2) thenã QuickSort(ar_Data, wo_Left, wo_Index2, LessThan);ã if (wo_Index1 < wo_Right) thenã QuickSort(ar_Data, wo_Index1, wo_Right, LessThan)ã end; (* QuickSort. *)ãã (***** Sort Function to check if anagram-Word's are in sorted order *)ã (* *)ã Function AlphaSort(Var Item1, Item2 : Item) : Boolean; Far;ã beginã AlphaSort := (porc_Word(Item1)^.st_Word < porc_Word(Item2)^.st_Word)ã end; (* AlphaSort. *)ãã (***** Sort Function to check: *)ã (* *)ã (* 1 - If anagram-Words are sorted by length. *)ã (* 2 - If anagram-Words are sorted by anagram-group. *)ã (* 3- If anagram-Words are sorted alphabeticly. *)ã (* *)ã Function Sort1(Var Item1, Item2 : Item) : Boolean; Far;ã beginã if (porc_Word(Item1)^.st_Word[0] <>ã porc_Word(Item2)^.st_Word[0]) thenã Sort1 := (porc_Word(Item1)^.st_Word[0] <ã porc_Word(Item2)^.st_Word[0])ã elseã if (porc_Word(Item1)^.ar_LtrChk <>ã porc_Word(Item2)^.ar_LtrChk) thenã Sort1 := (porc_Word(Item1)^.ar_LtrChk <ã porc_Word(Item2)^.ar_LtrChk)ã elseã Sort1 := (porc_Word(Item1)^.wo_Pos < porc_Word(Item2)^.wo_Pos)ã end; (* Sort1. *)ãã (***** Sort Function to check: *)ã (* *)ã (* If anagram-group Strings are sorted alphabeticly. *)ã (* *)ã Function Sort2(Var Item1, Item2 : Item) : Boolean; Far;ã beginã Sort2 := (porc_AnaGroup(Item1)^.wo_Pos <ã porc_AnaGroup(Item2)^.wo_Pos)ã end; (* Sort2. *)ãã (* end of PART 2 of 7 *)ã (* Start of PART 3 of 7 *)ãã (***** Check if the anagram-Word table is in sorted order. *)ã (* *)ã Function TableSorted({input } Var ar_Data : poar_Word;ã wo_Left,ã wo_Right : Word) : {output} Boolean;ã Varã wo_Index : Word;ã beginã (* Set Function result to True. *)ã TableSorted := True;ãã (* Loop through all but the last Word in the anagram- *)ã (* Word "table". *)ã For wo_Index := wo_Left to pred(wo_Right) doã (* Check if the current and next anagram-Words are not *)ã (* sorted. *)ã if (ar_Data[wo_Index]^.st_Word >ã ar_Data[succ(wo_Index)]^.st_Word) thenã beginã (* Set Function result to False, and break the "for" *)ã (* loop. *)ã TableSorted := False;ã breakã endã end; (* TableSorted. *)ãã (***** Pack bits 0,1,2 of each Byte in 26 Byte Array into 10 Chars. *)ã (* *)ã Procedure PackBits({input } Var byar_Temp : byar_26;ã {output} Var Char_Temp : Char_12);ã beginã Char_Temp[ 1] := chr((byar_Temp[ 97] and $7) shl 5 +ã (byar_Temp[ 98] and $7) shl 2 +ã (byar_Temp[ 99] and $6) shr 1);ã Char_Temp[ 2] := chr((byar_Temp[ 99] and $1) shl 7 +ã (byar_Temp[100] and $7) shl 4 +ã (byar_Temp[101] and $7) shl 1 +ã (byar_Temp[102] and $4) shr 2);ã Char_Temp[ 3] := chr((byar_Temp[102] and $3) shl 6 +ã (byar_Temp[103] and $7) shl 3 +ã (byar_Temp[104] and $7));ã Char_Temp[ 4] := chr((byar_Temp[105] and $7) shl 5 +ã (byar_Temp[106] and $7) shl 2 +ã (byar_Temp[107] and $6) shr 1);ã Char_Temp[ 5] := chr((byar_Temp[107] and $1) shl 7 +ã (byar_Temp[108] and $7) shl 4 +ã (byar_Temp[109] and $7) shl 1 +ã (byar_Temp[110] and $4) shr 2);ã Char_Temp[ 6] := chr((byar_Temp[110] and $3) shl 6 +ã (byar_Temp[111] and $7) shl 3 +ã (byar_Temp[112] and $7));ã Char_Temp[ 7] := chr((byar_Temp[113] and $7) shl 5 +ã (byar_Temp[114] and $7) shl 2 +ã (byar_Temp[115] and $6) shr 1);ã Char_Temp[ 8] := chr((byar_Temp[115] and $1) shl 7 +ã (byar_Temp[116] and $7) shl 4 +ã (byar_Temp[117] and $7) shl 1 +ã (byar_Temp[118] and $4) shr 2);ã Char_Temp[ 9] := chr((byar_Temp[118] and $3) shl 6 +ã (byar_Temp[119] and $7) shl 3 +ã (byar_Temp[120] and $7));ã Char_Temp[10] := chr((byar_Temp[121] and $7) shl 5 +ã (byar_Temp[122] and $7) shl 2)ã end; (* PackBits. *)ããVarã po_Buffer : po_Buff;ãã by_Index,ã by_LastAnagram,ã by_CurrentWord : Byte;ãã wo_Index,ã wo_ReadIndex,ã wo_TableIndex,ã wo_BufferIndex,ã wo_CurrentIndex : Word;ãã (* end of PART 3 of 7 *)ã (* Start of PART 4 of 7 *)ãã st_Temp : st_4;ãã byar_LtrChk : byar_26;ãã fi_Temp : File;ãã rcar_Table : poar_Word;ãã rcar_Groups : poar_AnaGroup;ããã (* Main Program execution block. *)ãbeginã (* If there is sufficient room, allocate the main data- *)ã (* buffer on the HEAP. *)ã if (maxavail > co_MaxSize) thenã new(po_Buffer)ã elseã (* Else, inform user of insufficient HEAP memory, and *)ã (* halt the Program. *)ã HeapError;ãã (* Clear the data-buffer. *)ã fillChar(po_Buffer^, co_MaxSize, 0);ãã (* Initialize counter Variable. *)ã wo_Index := 0;ãã (* While the counter is less than co_MaxWord do... *)ã While (co_MaxWord > wo_Index) doãã (* If there is sufficient memory, allocate another *)ã (* anagram-Word Record on the HEAP. *)ã if (maxavail > sizeof(rc_Word)) thenã beginã inc(wo_Index);ã new(rcar_Table[wo_Index]);ã fillChar(rcar_Table[wo_Index]^, sizeof(rc_Word), 0);ã endã elseã (* Else, inform user of insufficient HEAP memory, and *)ã (* halt the Program. *)ã HeapError;ãã (* Initialize counter Variable. *)ã wo_Index := 0;ãã (* While the counter is less than co_MaxWord do... *)ã While (co_MaxWord > wo_Index) doãã (* If there is sufficient memory, allocate another *)ã (* anagram-group String on the HEAP. *)ã if (maxavail > sizeof(rc_AnaGroup)) thenã beginã inc(wo_Index);ã new(rcar_Groups[wo_Index]);ã fillChar(rcar_Groups[wo_Index]^, sizeof(rc_AnaGroup), 32);ã endã elseã (* Else, inform user of insufficient HEAP memory, and *)ã (* halt the Program. *)ã HeapError;ãã (* Attempt to open File containing the anagram-Words. *)ã assign(fi_Temp, 'WordLIST.DAT');ãã (* Set Filemode to "read-only". *)ã Filemode := 0;ã {$I-}ã reset(fi_Temp, 1);ã {$I+}ã (* Check For I/O errors. *)ã if (ioresult <> 0) thenã beginã Writeln('Error opening anagram data File ---> WordLIST.DAT');ã haltã end;ã (* Read-in the entire anagram list into the data-buffer *)ã blockread(fi_Temp, po_Buffer^, co_MaxSize, wo_ReadIndex);ãã (* end of PART 4 of 7 *)ã (* Start of PART 5 of 7 *)ãã (* Check For I/O errors. *)ã CheckIOerror;ãã close(fi_Temp);ãã (* Check For I/O errors. *)ã CheckIOerror;ãã (* Initialize index Variables. *)ã wo_TableIndex := 0;ã wo_BufferIndex := 0;ãã (* Repeat...Until all data in the data-buffer has been *)ã (* processed. *)ã Repeatãã (* Repeat...Until a valid anagram-Word Character has *)ã (* been found, or the complete data-buffer has been *)ã (* processed. *)ã Repeatã inc(wo_BufferIndex)ã Until ((po_Buffer^[wo_BufferIndex] > 96)ã and (po_Buffer^[wo_BufferIndex] < 123))ã or (wo_BufferIndex > wo_ReadIndex);ãã (* If the complete data-buffer has been processed then *)ã (* break the Repeat...Until loop. *)ã if (wo_BufferIndex > wo_ReadIndex) thenã break;ãã (* Advance the anagram-Word "table" index. *)ã inc(wo_TableIndex);ãã (* Clear the "letter check" Byte-Array Variable. *)ã fillChar(byar_LtrChk, sizeof(byar_26), 0);ãã (* Repeat...Until not an anagram-Word Character, or *)ã (* complete data-buffer has been processed. *)ã Repeatãã (* With the current anagram-Word Record do... *)ã With rcar_Table[wo_TableIndex]^ doã beginã (* Record the number of each alphabetical Character in *)ã (* the anagram-Word. *)ã inc(byar_LtrChk[po_Buffer^[wo_BufferIndex]]);ãã (* Advance the String length-Character. *)ã inc(st_Word[0]);ãã (* Add the current anagram-Word Character to anagram- *)ã (* Word String. *)ã st_Word[ord(st_Word[0])] :=ã chr(po_Buffer^[wo_BufferIndex]);ãã (* Advance the data-buffer index. *)ã inc(wo_BufferIndex)ãã endã Until (po_Buffer^[wo_BufferIndex] < 97)ã or (po_Buffer^[wo_BufferIndex] > 122)ã or (wo_BufferIndex > wo_ReadIndex);ãã (* Pack bits 0,1,2 of each Character in "letter-check" *)ã (* Variable, to store Variable as 10 Char data. This *)ã (* reduces memory storage requirements by 16 Bytes For *)ã (* each anagram-Word, and makes data faster to sort. *)ã PackBits(byar_LtrChk, rcar_Table[wo_TableIndex]^.ar_LtrChk);ãã Until (wo_BufferIndex > wo_ReadIndex);ãã (* Check if the Array of anagram-Words in the "table" *)ã (* Array are sorted. If not then sort them. *)ã if not TableSorted(rcar_Table, 1, wo_TableIndex) thenã QuickSort(poar_Generic(rcar_Table), 1, wo_TableIndex, AlphaSort);ãã (* Record the position of all the anagram-Words on the *)ã (* "table" Array. This will be used as a faster sorting *)ã (* index. *)ã For wo_Index := 1 to wo_TableIndex doã rcar_Table[wo_Index]^.wo_Pos := wo_Index;ãã (* end of PART 5 of 7 *)ã (* Start of PART 6 of 7 *)ãã (* QuickSort the "table" of anagram Words, using Sort1 *)ã (* routine. *)ã QuickSort(poar_Generic(rcar_Table), 1, wo_TableIndex, Sort1);ãã (* Attempt to open a File to Write sorted data to. *)ã assign(fi_Temp, 'SORTED.DAT');ã {$I-}ã reWrite(fi_Temp, 1);ãã (* Check For I/O errors. *)ã CheckIOerror;ãã (* Set the temporary String to ', ' + Cr + Lf. *)ã st_Temp := ', ' + #13#10;ãã (* Reset the loop index. *)ã wo_Index := 1;ãã (* Repeat...Until all anagram-Word on "table" Array are *)ã (* processed. *)ã Repeatãã (* Reset the counter Variables. *)ã by_LastAnagram := 0;ã by_CurrentWord := 0;ãã (* While the next anagram-Word belongs to the same *)ã (* anagram-group, advance the by_LastAnagram Variable. *)ã While (rcar_Table[(wo_Index + by_LastAnagram)]^.ar_LtrChk =ã rcar_Table[succ(wo_Index + by_LastAnagram)]^.ar_LtrChk) doã inc(by_LastAnagram);ãã (* Repeat...Until next anagram-Word is not in the same *)ã (* anagram group. *)ã Repeatãã (* With current anagram group do... *)ã With rcar_Groups[(wo_Index + by_CurrentWord)]^ doã beginãã (* Move the first anagram-Word in "table" Array to the *)ã (* current anagram group-String. *)ã move(rcar_Table[(wo_Index + by_CurrentWord)]^.st_Word[1],ã st_Group[1], ord(rcar_Table[(wo_Index +ã by_CurrentWord)]^.st_Word[0]));ãã (* Set the length-Char of current anagram-String to 12. *)ã st_Group[0] := #12;ãã (* Record the first anagram-Word position. *)ã wo_Pos := rcar_Table[(wo_Index + by_CurrentWord)]^.wo_Pos;ãã (* Loop from 0 to total number of anagrams in the group *)ã For by_Index := 0 to by_LastAnagram doãã (* If the loop index is not equal the the current *)ã (* anagram-Word, then... *)ã if (by_Index <> by_CurrentWord) thenã beginãã (* Add the next anagram-Word to the anagram-String. *)ã move(rcar_Table[(wo_Index + by_Index)]^.st_Word[1],ã st_Group[succ(length(st_Group))],ã ord(rcar_Table[(wo_Index +ã by_Index)]^.st_Word[0]));ãã (* Record the length of the anagram-Word added to the *)ã (* anagram-String. *)ã inc(st_Group[0],ã ord(rcar_Table[(wo_Index +ã by_Index)]^.st_Word[0]));ãã (* If the current anagram-Word is not the last anagram- *)ã (* Word of the anagram-group, and the loop-index is *)ã (* less than the last anagram-Word, or the loop-index *)ã (* is less than the 2nd to last anagram-Word in group *)ã if ((by_CurrentWord <> by_LastAnagram) andã (by_Index < by_LastAnagram))ã or (by_Index < pred(by_LastAnagram)) thenã beginãã (* end of PART 6 of 7 *)ã (* Start of PART 7 of 7 *)ãã (* Add the comma and space Character to anagram-String. *)ã move(st_Temp[1],ã st_Group[succ(length(st_Group))], 2);ã inc(st_Group[0], 2)ã endã end;ãã (* Add the CR + Lf to anagram String. *)ã move(st_Temp[3], st_Group[succ(length(st_Group))], 2);ã inc(st_Group[0], 2);ãã (* Advance the currrent anagram-Word index. *)ã inc(by_CurrentWord)ãã endã Until (by_CurrentWord > by_LastAnagram);ãã (* Advance the anagram-group index by the current *)ã (* anagram-Word index. *)ã inc(wo_Index, by_CurrentWord);ãã Until (wo_Index > wo_TableIndex);ãã (* QuickSort the anagram-Strings, using Sort2. *)ã QuickSort(poar_Generic(rcar_Groups), 1, wo_TableIndex, Sort2);ãã (* Initialize loop control Variable. *)ã wo_CurrentIndex := 1;ãã (* Repeat Until all the anagram Words in the "table" *)ã (* Array have been processed. *)ã Repeatãã (* Initialize loop control Variable. *)ã wo_BufferIndex := 1;ãã (* Place all the anagram-Strings in the data-buffer. *)ã While (wo_CurrentIndex <= wo_TableIndex)ã and (wo_BufferIndex < co_SafeSize) doã With rcar_Groups[wo_CurrentIndex]^ doã beginã (* Place current anagram-String in the data-buffer. *)ã move(st_Group[1], po_Buffer^[wo_BufferIndex],ã length(st_Group));ãã (* Advance the data-buffer index by length of anagram- *)ã (* String. *)ã inc(wo_BufferIndex, length(st_Group));ãã (* Advance current anagram-String index. *)ã inc(wo_CurrentIndex)ãã end;ãã (* Write the anagram Text data in the buffer to disk. *)ã blockWrite(fi_Temp, po_Buffer^[1], pred(wo_BufferIndex));ãã (* Check For I/O errors. *)ã CheckIOerror;ãã Until (wo_CurrentIndex >= wo_TableIndex);ãã (* Close the sorted anagram-Text File. *)ã close(fi_Temp);ãã (* Check For I/O errors. *)ã CheckIOerrorããend.ãã (* end of PART 7 of 7 *)ã{ Hi, to All:ãã ...I gather that the 3rd Programming contest (Anagram Word sort)ã is officially over, and am now posting my entry's source-code.ãã This Program should execute in well under 1 second on a 486-33ã ram-disk. (It's about 3.21 sec on my 386sx-25) The final compiledã size of the .EXE is 7360 Bytes.ãã ...I've commented the h*ll out of my source-code, so it's a bitã on the big side.ãã ...Here is a "quick" run-down of how it works:ãã 1- Creates a 60K buffer on the HEAP.ãã 2- Creates an Array table to store all the anagram Wordsã and data about each Word, on the HEAP.ãã 3- Creates an Array of anagram-group Strings on the HEAP.ãã 4- Read the entire anagram-Word input File WordLIST.DATã into the 60K buffer in 1 big chunk.ãã 5- Finds all the anagram-Words in the buffer, and assignsã their data to the anagram-Word table on the HEAP.ãã 6- Each letter of every anagram-Word is Recorded in anã Array of 26 Bytes. Then the first 3 bits of each ofã the 26 Bytes is packed, so that this data can beã stored in a 10 Character Array in each anagram-Wordã table Record. (The bits are packed to save space andã to make the sorting faster.) This method allows forã a maximum of 7 of the same letter in each Word, whichã should be sufficient For this contest.ãã 7- The table of anagram Records is then checked to see ifã the anagram-Words are in sorted order. (In this contestã the original input File is in sorted order.) If they areã not in sorted order, QuickSort is called to put theã Words (actually Pointers to the Words) in order.ãã 8- Now that the anagram-Words are in sorted order, theirã position in the anagram-Word table is Recorded in aã position field within each anagram-Word Record.ãã 9- The table of anagram-Word Records is now sorted usingã a multi-key QuickSort. This will sort the anagram-Wordã Records by:ã 1- Length of anagram-Word.ã 2- Letters that each anagram-Word contains.ã 3- Alphabeticly.ãã ...This multi-key sort will establish the anagram groups,ã and sort the members of each group alphabeticly.ãã 10- Open the sorted output File.ãã 11- Create N number of anagram-Strings from N mumber of anagram-ã Words in each anagram-group. Keeping the anagram Words inã the String in sorted order.ãã 12- QuickSort the anagram-group Strings into alphabetical order.ãã 13- Place all the sorted anagram-group Strings back into theã 60K buffer.ãã 14- Write the entire buffer to the SORTED.DAT File, and closeã this File.ãã NOTES: Well this is the first time I've figured out how to doã multi-key QuickSorts, which I wasn't sure was possibleã at first.ãã I also tried using a 32-bit CRC value to identify theã anagram-groups which ran even faster, but should notã be considered a "safe" method, as it's accuracy is onlyã guaranteed For 2-7 Character Words.ãã File I/O and repetitive loops are usually the big speedã killers in these Types of contests, so I always try toã keep them to a minimum.ãã ...My entry could possibly be tweaked further still,ã but I've got a life. ãã} 3 05-28-9313:57ALL SWAG SUPPORT TEAM ANAGRAM2.PAS IMPORT 125 Sh¢ { ANAGRAM. --------------------------------------------------------------------ã Rapha‰l Vanney, 01/93ãã Purpose : Reads a list of Words 4 to 10 Characters long from a Fileã named 'LIST.#1', outputs a list of anagrams founds in aã specified format to a File named 'ANAGRAM.RES'.ãã Note : I commented-out the source using a langage, say English, whichã I'm not Really fluent in ; please forgive mistakes.ã------------------------------------------------------------------------------}ãã{$m 8192,65536,655360}ã{$a+,d+,e-,f-,g+,i+,l+,n-,o-,q-,r-,s-,v+}ãã{$b-} { Turns off complete Boolean evaluation ; this allows easiestã combined Boolean tests. }ããUses Crt,ã Objects ;ããConstã MaxWordLen = 10 ; { Offically specified by GP ! }ã CntAnagrams : Word = 0 ; { Actually, this counter shows the }ã { number of Words found in the }ã { output File. }ã OutFileName = 'ANAGRAM.RES' ;ãããType TWordString = String[MaxWordLen] ;ãã { TWordCollection.ã This Object will be used to store the Words in a sorted fashion. Asã long as the input list is already sorted, it could have inheritedã from TCollection, put there is no big penalty using a sorted one. }ãã TWordCollection =ã Object (TSortedCollection)ã Function KeyOf(Item : Pointer) : Pointer ; Virtual ;ã Function Compare(Key1, Key2 : Pointer) : Integer ; Virtual ;ã Procedure FreeItem(Item : Pointer) ; Virtual ;ã end ;ã PWordCollection = ^TWordCollection ;ãã { TWord.ã This is the Object we'll use to store a Word. Each Word knows :ã - it's 'Textual form' : Itã - the first of it's anagrams, if it has been found to be theã anagram of another Word,ã - the next of it's anagrams, in the same condition. }ãã PWord = ^TWord ;ã TWord =ã Objectã It : TWordString ;ã FirstAng : PWord ;ã NextAng : PWord ;ãã Constructor Init(Var Wrd : TWordString) ;ã Destructor Done ;ã end ;ããVar WordsList : PWordCollection ; { The main list of Words }ã OrgMem : LongInt ; { Original MemAvail }ã UsedMem : LongInt ; { Amount of RAM used }ãã{-------------------------------------- TWord --------------------------------}ããConstructor TWord.Init ;ãbeginã It:=Wrd ;ã FirstAng:=Nil ;ã NextAng:=Nil ;ãend ;ããDestructor TWord.Done ;ãbeginãend ;ãã{-------------------------------------- TWordCollection ----------------------}ã{ The following methods are not commented out, since they already are inã Turbo-Pascal's documentations, and they do nothing unusual. }ããFunction TWordCollection.KeyOf ;ãbeginã KeyOf:=Addr(PWord(Item)^.It) ;ãend ;ããFunction TWordCollection.Compare ;ãVar k1 : PString Absolute Key1 ;ã k2 : PString Absolute Key2 ;ãbeginã If k1^>k2^ã Then Compare:=1ã Else If k1^lengthes, not anagrams }ãã LDS SI, WordBãã { Let's make a local copy of WordB ; enhanced version of TP's "Move" }ã ClD { Clear direction flag }ã Push SSã Pop ES { Segment part of WordC's address }ã LEA DI, WordC { Offset part of it }ã Mov CL, DS:[SI] { Get length Byte }ã XOr CH, CH { Make it a Word }ã Mov DL, CL { Save length For later use }ã Inc CX { # of Bytes to store the String }ã ShR CX, 1 { We'll copy Words ; CF is importt }ã Rep MovSW { Copy WordB to WordC }ã JNC @NoByteã MovSB { Copy last Byte }ã@NoByte:ã LDS SI, WordA { DS:SI contains WordA's address }ã Inc SI { SI points to first Char of WordA }ã Mov DH, DL { Use DH as a loop counter }ã LEA BX, WordC { Load offset of WordC in BX }ã Inc BX { Skip length Byte }ã { For each letter in WordA, search it in WordB ; if found, mark it asã 'used' in WordB, then proceed With next.ã If a letter is not found, Words are not anagrams ; if all areã found, Words are anagrams. }ã{ Registers usage :ã AL : scratch For SCASã AH : unusedã BX : offset part of WordC's addressã CX : will be used as a counter For SCASã DL : contains length of Strings ; 'll be used to reset CXã DH : loop counter ; initially =DLã ES : segment part of WordC's addressã DI : scratch For SCASã DS:SI : Pointer to next Char to process in WordAã}ã@Bcle:ã LodSB { Load next Char of WordA in AL }ã Mov CL, DL { Load length of String in CX }ã Mov DI, BX { Copy offset of WordC to DI }ã RepNE ScaSB { Scan WordC For AL 'till found }ã JNE @NotAng { Char not found, not anagrams }ã Dec DI { Back-up to matching Char }ã Mov Byte Ptr ES:[DI], '*' { Mark the Character as 'used' }ã Dec DH { Dec loop counter }ã Or DH, DH { Done all Chars ? }ã JNZ @Bcle { No, loop }ãã { All Chars done, the Words are anagrams }ã Mov AL, 1 { Result=True }ã Or AL, AL { Set accordingly the ZF }ã Jmp @Doneã@NotAng:ã XOr AL, AL { Result=False }ã@Done:ã Pop DS { Restore DS }ãend ;ããFunction ReadWordsFrom(FName : String) : Boolean ;ãVar InF : Text ; { Input File }ã Buf : Array[1..2048] Of Byte ; { Speed-up Text buffer }ã Lig : String ; { Read line }ã Wrd : String ; { Word gotten from parsed Lig }ã WSt : TWordString ; { Checked version of Wrd }ã p : Integer ; { Work }ã Cnt : LongInt ; { Line counter }ãbeginã ReadWordsFrom:=False ; { 'till now, at least ! }ã WordsList:=New(PWordCollection, Init(20, 20)) ;ã Assign(InF, FName) ;ã {$i-}ã ReSet(InF) ;ã {$i+}ã If IOResult<>0 Then Exit ;ã SetTextBuf(InF, Buf, SizeOf(Buf)) ;ã Cnt:=0 ;ãã While Not EOF(InF) Doã beginã Inc(Cnt) ;ã ReadLn(InF, Lig) ;ã While Lig<>'' Doã beginã { Let's parse the read line into Words }ã p:=Pos(',', Lig) ;ã If p=0 Then p:=Length(Lig)+1 ;ã Wrd:=Copy(Lig, 1, p-1) ;ã { Check of overflowing Word length }ã If Length(Wrd)>MaxWordLen Thenã WriteLn('Word length > ', MaxWordLen, ' : ', Wrd) ;ã WSt:=Wrd ;ã CleanUp(WSt) ;ã If WSt<>'' Then WordsList^.Insert(New(PWord, Init(WSt))) ;ã Delete(Lig, 1, p) ;ã end ;ã end ;ã {$i-}ã Close(InF) ;ã {$i+}ã If IOResult<>0 Then ;ã ReadWordsFrom:=True ;ãã WriteLn(Cnt, ' lines, ', WordsList^.Count, ' Words found.') ;ãend ;ããProcedure CheckAnagrams(i : Integer) ;ã{ This Procedure builds, if necessary (i.e. not already done), the anagramsã list For Word #i of the list. }ãVar Org : PWord ; { Original Word (1st of list) }ã j : Integer ; { Work }ã Last : PWord ; { Last anagram found }ãbeginã Org:=WordsList^.Items^[i] ;ã If Org^.FirstAng<>Nil Thenã beginã { This Word is already known to be the anagram of at least anotherã one ; don't re-do the job. }ã { _or_ this Word is known to have no anagrams in the list }ã Exit ;ã end ;ãã { Search anagrams }ã Last:=Org ;ã Org^.FirstAng:=Org ; { This Word is the first of it's }ã { own anagrams list ; normal, no ? }ã For j:=Succ(i) To Pred(WordsList^.Count) Doã { Don't search the begining of the list, of course ! }ã beginã { Let's skip anagram checking if lengths are <> }ã If Org^.It[0]=PWord(WordsList^.Items^[j])^.It[0] Thenã If AreAnagrams(Org^.It, PWord(WordsList^.Items^[j])^.It) Thenã beginã { Build chained list of anagrams }ã Last^.NextAng:=WordsList^.Items^[j] ;ã Last:=WordsList^.Items^[j] ;ã Last^.FirstAng:=Org ;ã end ;ã end ;ã Last^.NextAng:=Nil ; { Unusefull, but keep carefull }ãend ;ããProcedure ScanForAnagrams ;ã{ This Procedure scans the list of Words For anagrams, and do the outputingã to the 'ANAGRAM.RES' File. }ããVar i : Integer ; { Work }ã Tmp : PWord ; { Temporary Word }ã Out : Text ; { Output File }ã Comma : Boolean ; { Helps dealing With commas }ã Current : PWord ; { Currently handled Word }ãbeginã Assign(Out, OutFileName) ;ã ReWrite(Out) ;ãã With WordsList^ Doã For i:=0 To Pred(Count) Doã beginã Current:=Items^[i] ;ã CheckAnagrams(i) ;ã { We're now gonna scan the chained list of known anagrams forã this Word. }ã If (Current^.NextAng<>Nil) Or (Current^.FirstAng<>Current) Thenã { This Word has at least an anagram other than itself }ã beginã Write(Out, PadStr(Current^.It, 12)) ;ã Inc(CntAnagrams) ;ã Comma:=False ;ã Tmp:=Current^.FirstAng ;ã While Tmp<>Nil Doã beginã If Tmp<>Current Then { Don't reWrite it... }ã beginã If Comma Then Write(Out, ', ') ;ã Comma:=True ;ã Write(Out, Tmp^.It) ;ã Inc(CntAnagrams) ;ã end ;ã Tmp:=Tmp^.NextAng ;ã end ;ã WriteLn(Out) ;ã end ;ã end ;ãã Close(Out) ;ãend ;ããVar Tmp : LongInt ;ããbeginã { Check command line parameter }ãã If ParamCount<>1 Thenã beginã WriteLn('Anagram. Rapha‰l Vanney, 01/93 - Anagram''s contest entry.');ã WriteLn ;ã WriteLn('Anagram ') ;ã WriteLn ;ã WriteLn('Please specify input File name.') ;ã Halt(1) ;ã end ;ãã OrgMem:=MemAvail ;ãã { Read Words list from input File }ãã If Not ReadWordsFrom(ParamStr(1)) Thenã beginã WriteLn('Error reading Words from input File.') ;ã Halt(1) ;ã end ;ãã { Display statistics stuff }ãã WriteLn('Reading and sorting done.') ;ã UsedMem:=OrgMem-MemAvail ;ã WriteLn('Used RAM : ', UsedMem, ' Bytes') ;ã Tmp := Trunc(1.0 * MemAvail / (1.0 * UsedMem / WordsList^.Count)) ;ã If Tmp > 16383 Thenã Tmp := 16383 ;ã WriteLn('Potential Words manageable : ', Tmp) ;ãã { Scan For anagrams, create output File }ãã ScanForAnagrams ;ã WriteLn('Anagrams scanning & output done.') ;ã WriteLn(CntAnagrams, ' Words written to ', OutFileName) ;ãã { Clean-up }ã Dispose(WordsList, Done) ;ãend.ã{ãã------------------------------------------------------------------------------ããOkay, this is my entry For the 'anagram contest' !ããThe few things I'd like to point-out about it :ãã. I chosed to use OOP, in contrast to seeking speed. I wouldn't say myã Program is Really slow (7.25 secs on my 386-33), but speed was not myã first concern.ã. It fully Uses one of the interresting points of OOP in TP, i.e.ã reusability, through inheritance,ã. When a Word (A) has been found to be an anagram of another (B), theã Program never searches again For the anagrams of (A) ; thisã highly reduces computing time... but I believe anybody does the same.ã. I also quite like the assembly langage Function 'AreAnagrams'.ãã------------------------------------------------------------------------------ããThe Words list is stored in memory in the following maner :ã. A collection (say, a list) of the Words,ã. Within this list, anagrams are chained as a listã. Each Word knows the first and the next of its anagramsãã------------------------------------------------------------------------------ããFor the sake of speed, I did something I'm quite ashamed of ; but itãsaves 32% of execution time, so...ãThe usual way to access element #i of a TCollection is to call Function Atãwith parameter i (i.e. At(i)) ; there is also another way, which is not Reallyãclean, but which I chosed to use : access it directly through Items^[i].ã 4 05-28-9313:57ALL SWAG SUPPORT TEAM BUBBLE1.PAS IMPORT 6 SÀQ {ã> Does anyone know of a routine or code that would allow For aã> alphabetical sort?ããDepends on what Type of sorting you want to do- For a very small list, aãsimple BubbleSort will suffice.ã}ãConstã max = 50;ãVarã i,j:Integer;ã a : Array[1..max] of String;ã temp : String;ãbeginã For i := 1 to 50 doã For j := 1 to 50 doã if a[i] < a[j] thenã beginã temp := a[i];ã a[i] := a[j];ã a[j] := temp;ã end; { if }ãend.ãã{ãIf it's a bigger list than, say 100 or so elements, or it needs to beãsorted often, you'll probably need a better algorithm, like a shell sortãor a quicksort.ã}ãã 5 05-28-9313:57ALL SWAG SUPPORT TEAM BUBBLE2.PAS IMPORT 8 SÍM {ã> Does anyone know of a routine or code that would allow forã> a alphbetical sort in pascal? If so could you mail orã> Write it in this base? Thanks!ããI know of a couple but this is the best and fastest one that I know ofããBubble Sortã}ããTypeã StArray = Array [1..10] of String;ããProcedure bubble_sort(Var names : StArray);ãVarã i,ã last,ã latest : Integer;ã temp : String;ã exchanged : Boolean;ãbeginã last := max_names - 1;ã Repeatã i := 1;ã exchanged := False;ã latest := last;ã Repeatã if names[i] > names[i+1] thenã beginã temp := names[i];ã names[i] := names[i+1];ã names[i+1] := temp;ã exchanged := True;ã latest := i;ã end;ã inc(i);ã Until not (i <= last);ã last := latest;ã Until not ((last >= 2) and exchanged);ãend;ã 6 05-28-9313:57ALL SWAG SUPPORT TEAM COMB1.PAS IMPORT 11 SO{ {ã>Has anyone successfully converted the Combsort algorithm (I think it wasã>published in DDJ or Byte about two years ago) from C to Pascal? I'veã>lost the original C source For this, but if anyone has any info, I wouldã>appreciate it.ã}ããProgram TestCombSort; { Byte magazine, April '91 page 315ff }ãConstã Size = 25;ãTypeã SortType = Integer;ãVarã A: Array [1..size] of SortType;ã i: Word;ããProcedure CombSort (Var Ain);ãVarã A: Array [1..Size] of SortType Absolute Ain;ã Switch: Boolean;ã i, j, Gap: Word;ã Hold: SortType;ãbeginã Gap := Size;ã Repeatã Gap := Trunc (Gap / 1.3);ã if Gap < 1 thenã Gap := 1;ã Switch := False;ã For i := 1 to Size - Gap doã beginã j := i + Gap;ã if A [i] > A [j] then { swap }ã beginã Hold := A [i];ã A [i] := A [j];ã A [j] := Hold;ã Switch := True;;ã end;ã end;ã Until (Gap = 1) and not Switch;ãend;ããbeginã Randomize;ã For i := 1 to Size doã A [i] := Random (32767);ã WriteLn;ã WriteLn ('Unsorted:');ã For i := 1 to Size doã Write (A [i]:8);ã WriteLn;ã CombSort (A);ã WriteLn ('Sorted:');ã For i := 1 to Size doã Write (A [i]:8);ã WriteLn;ãend.ã 7 05-28-9313:57ALL SWAG SUPPORT TEAM COUNT1.PAS IMPORT 16 S‚ƒ {ã ...Well, as Greg Vigneault reminded me, there is a much fasterã method of sorting this sort of data called a "Count" sort. Iã often overlook this method, as it doesn't appear to be a sortã at all at first glance:ã}ãProgram Count_Sort_Demo;ããConstã co_MaxItem = 200;ããTypeã byar_MaxItem = Array[1..co_MaxItem] of Byte;ã byar_256 = Array[0..255] of Byte;ããVarã by_Index : Byte;ã wo_Index : Word;ã DataBuffer : byar_MaxItem;ã SortTable : byar_256;ããbeginã (* Initialize the pseudo-random number generator. *)ã randomize;ãã (* Clear the CountSort table. *)ã fillChar(SortTable, sizeof(SortTable), 0);ãã (* Create random Byte data. *)ã For wo_Index := 1 to co_MaxItem doã DataBuffer[wo_Index] := random(256);ãã (* Display random data. *)ã Writeln;ã Writeln('RANDOM Byte DATA');ã For wo_Index := 1 to co_MaxItem doã Write(DataBuffer[wo_Index]:4);ãã (* CountSort the random data. *)ã For wo_Index := 1 to co_MaxItem doã inc(SortTable[DataBuffer[wo_Index]]);ãã (* Display the CountSorted data. *)ã Writeln;ã Writeln('COUNTSORTED Byte DATA');ã For by_Index := 0 to 255 doã if (SortTable[by_Index] > 0) thenã For wo_Index := 1 to SortTable[by_Index] doã Write(by_Index:4)ãend.ã{ã ...This Type of sort is EXTEMELY fast, even when compared toã QuickSort, as there is so little data manipulation being done.ãã>BTW, why are there so many different sorting methods?ã>Quick, bubble, Radix.. etc, etcãã ...Because, Not all data is created equally.ã (ie: Some Types of sorts perform well on data that is veryã random, While other Types of sorts perform well on dataã that is "semi-sorted" or "almost sorted".)ãã} 8 05-28-9313:57ALL SWAG SUPPORT TEAM COUNT2.PAS IMPORT 34 Sö\ {ã>I'm in need of a FAST way of finding the largest and the smallestã>30 numbers out of about 1000 different numbers.ã> ...Assuming that the 1000 numbers are in random-order, I imagineã> that the simplest (perhaps fastest too) method would be to:ã> 1- Read the numbers in an Array.ã> 2- QuickSort the Array.ã> 3- First 30 and last 30 of Array are the numbers you want.ã> ...Here's a QuickSort demo Program that should help you With theã> sort: ...ãã Stop the presses, stop the presses!ãã Remember the recent Integer sort contest, on the Intelec Programmingã conference? The fastest method was a "counting" sort technique, whichã used the Integers (to be sorted) as indexes of an Array.ãã You asked John Kuhn how it worked, as his example code was in messyã C. I sent you an explanation, along With example TP source. Aroundã that time my link to Intelec was intermittently broken; I didn'tã hear back from you - so you may not have received my message (datedã Jan.02.1993). I hope you won't mind if I re-post it here and now...ãã In a message With John Kuhn...ã> Simply toggle the sign bit of the values beFore sorting. Everythingã> falls into place appropriately from there.ã> ...OK, but how about toggling them back to their originalã> state AFTER sorting? (I want to maintain negative numbers)ã> How can you tell which data elements are negative numbers???ãã Hi Guy,ãã if you've got all of this under your belt, then please disregardã the following explanation ...ãã By toggling the high bit, the Integers are changed in a way that,ã conveniently, allows sorting by magnitude: from the "most negative"ã to "most positive," left to right, using an Array With unsignedã indexes numbering 0...FFFFh. The Array size represents the numberã of all possible (16-bit) Integers... -32768 to 32767.ãã The "Count Sort" involves taking an Integer, toggling its high bitã (whether the Integer is originally positive or negative), thenã using this tweaked value as an index into the Array. The tweakedã value is used only as an Array index (it becomes an unsignedã index somewhere within 0..FFFFh, inclusive).ãã The Array elements, which are initialized to zero, are simply theã counts of the _occurrences_ of each Integer. The original Integers,ã With proper sign, are _derived_ from the indexes which point toã non-zero elements (after the "sort")... ie. an original Integer isã derived by toggling the high bit of a non-zero element's index.ãã Array elements of zero indicate that no Integer of the correspondingã (derived) value was encountered, and can be ignored. if any elementã is non-zero, its index is used to derive the original Integer. ifã an Array element is greater than one (1), then the correspondingã Integer occurred more than once.ãã A picture is worth 1000 Words: The following simplified exampleã sorts some negative Integers. The entire Count Sort is done byã a Single For-do-inC() loop - hence its speed. The xors do theã required high-bit toggling ...ã}ãããProgram DemoCountSort; { Turbo Pascal Count Sort. G.Vigneault }ãã{ some negative Integers to sort ... }ãConstã SomeNegs : Array [0..20] of Integer =ã (-2,-18,-18,-20000,-100,-10,-8,-11,-5,ã -1300,-17,-1,-16000,-4,-12,-15,-19,-1,ã -31234,-6,-7000 );ãã{ pick an Array to acComplish Count Sort ... }ãVarã NegNumArray : Array [$0000..$7FFF] of Byte;ã{ PosNumArray : Array [$8000..$FFFF] of Byte; }ã{ AllNumArray : Array [$0000..$FFFF] of Byte; use heap }ã Index : Word;ã IntCount : Byte;ããbeginã { Initialize }ã FillChar( NegNumArray, Sizeof(NegNumArray), 0 );ãã { Count Sort (the inC does this) ... }ãã For Index := 0 to 20 doã { Just 21 negative Integers to sort }ã inC( NegNumArray[ Word(SomeNegs[Index] xor $8000) ]);ãã { then display the sorted Integers ... }ã For Index := 0 to $7FFF doã { Check each Array element }ã For IntCount:= 1 to NegNumArray[Index] doã { For multiples }ã WriteLn( Integer(Index xor $8000) ); { derive value }ããend { DemoCountSort }.ã 9 05-28-9313:57ALL PEDRO DUARTE Elevator Sort IMPORT 15 SMb {ã> Thanks For the code... It worked great! BTW, why are there so manyã> different sorting methods? Quick, bubble, Radix.. etc, etcããYes, there are lots of sorting algorithms out there! I also found this outãthe hard way! 🙂 A couple of years ago, I only knew the so-called "bubble"ãsort, and decided to create my own sorting algorithm. It would have to beãfaster than bubble, yet remaining small, simple, and not memory hungry.ãand I did it, but only to find out a few weeks later that there were muchãbetter sorts than the one I created... But it sure was great fun beatingãbubble! (which is brain-dead anyway! ;-)ããSo here it is, my two cents to the history of sorting algorithms, theãamazing, blazingly fast (*)... ELEVAtoR SorT!... Why ELEVAtoR??, you ask inãunison! Because it keeps going up & down! :-)ã}ããProgram mysort;ããUses Crt;ããConstã max = 1000;ããTypeã list = Array[1..max] of Word;ããVarã data : list;ã dummy : Word;ãããProcedure elevatorsort(Var a: list; hi: Word);ããVarã lo,ã peak,ã temp,ã temp2 : Word;ããbeginã peak := 1;ã lo := 1;ã Repeatã temp := a[lo];ã temp2 := a[lo + 1];ã if temp > temp2 thenã beginã a[lo] := temp2;ã a[lo + 1] := temp;ã if lo <> 1 then dec(lo);ã endã elseã beginã inc(peak);ã lo:=peak;ã end;ã Until lo = hi;ãend;ãããbeginã ClrScr;ã Writeln('Generating ', max ,' random numbers...');ã randomize;ã For dummy:=1 to max do data[dummy]:=random(65535);ã Writeln('Sorting random numbers...');ã elevatorsort(data,max);ã For dummy:=1 to max do Write(data[dummy]:5,' ');ãend.ãã{ã(*) it's speed lies somewhere between "BUBBLE" and "inSERT"; it's muchãfaster than "BUBBLE", and a little slower than "inSERT"... :-)ã}ã 10 05-28-9313:57ALL SWAG SUPPORT TEAM ELEVATR2.PAS IMPORT 11 S†c {ã>Why can't Borland come out With a Universal sort since they made theã>Program.. ããI guess there's no such thing as a "universal" sort... There are a few veryãgood sorting algorithms, and depending on some factors, you just have toãchoose the one that best fits your needs!ããHere's an update to my ELEVAtoR sort, this one's even faster!ã}ããProgram mysort;ããUses Crt;ããConstã max = 1000;ããTypeã list = Array[1..max] of Word;ããVarã data : list;ã dummy : Word;ãããProcedure elevatorsort(Var a: list; hi: Word);ããVarã dummy,ã low,ã peak,ã temp,ã temp2 : Word;ããbeginã peak := 1;ã low := 1;ã temp2 := a[low + 1];ã Repeatã temp := a[low];ã if temp > temp2 thenã beginã a[low] := temp2;ã a[low + 1] := temp;ã if low <> 1 then dec(low);ã endã elseã beginã inc(peak);ã low:=peak;ã if low <> hi then temp2:=a[low + 1];ã end;ã Until low = hi;ãend;ããbeginã ClrScr;ã Writeln('Generating ', max ,' random numbers...');ã randomize;ã For dummy:=1 to max do data[dummy]:=random(65535);ã Writeln('Sorting random numbers...');ã elevatorsort(data,max);ã For dummy:=1 to max do Write(data[dummy]:5,' ');ãend.ã 11 05-28-9313:57ALL SWAG SUPPORT TEAM IMROVSRT.PAS IMPORT 20 S¾= {ãMARK OUELLETãã> I code these things this way:ã>ã> for I := 1 to MAX-1 doã> for J := I+1 to MAX doã> if A[I] < A[J] thenã> beginã> ( swap code )ã> endãã this can be improved even more. By limiting the MAX value on eachãsuccessive loop by keeping track of the highest swaped pair.ãã If on a particular loop, no swap is performed from element MAX-10ãonto the end. Then the next loop does not need to go anyhigher thanãMAX-11. Remember you are moving the highest value up, if no swap isãperformed from MAX-10 on, it means all values above MAX-11 are in orderãand all values below MAX-10 are smaller than MAX-10.ã}ãã{$X+}ãprogram MKOSort;ããUSESã Crt;ããConstã MAX = 1000;ããvarã A : Array[1..MAX] of word;ã Loops : word;ããprocedure Swap(Var A1, A2 : word);ãvarã Temp : word;ãbeginã Temp := A1;ã A1 := A2;ã A2 := Temp;ãend;ããprocedure working;ãconstã cursor : array[0..3] of char = '\|/-';ã CurrentCursor : byte = 1;ã Update : word = 0;ãbeginã update := (update + 1) mod 2500;ã if update = 0 thenã beginã DirectVideo := False;ã write(Cursor[CurrentCursor], #13);ã CurrentCursor := ((CurrentCursor + 1) mod 4);ã DirectVideo := true;ã end;ãend;ããprocedure Bubble;ãvarã Highest,ã Limit, I : word;ã NotSwaped : boolean;ãbeginã Limit := MAX;ã Loops := 0;ã repeatã I := 1;ã Highest := 2;ã NotSwaped := true;ã repeatã working;ã if A[I] > A[I + 1] thenã beginã Highest := I;ã NotSwaped := False;ã Swap(A[I], A[I + 1]);ã end;ã Inc(I);ã until (I = Limit);ã Limit := Highest;ã Inc(Loops);ã until (NotSwaped) or (Limit <= 2);ãend;ããprocedure InitArray;ãvarã I, J : word;ã Temp : word;ãbeginã randomize;ã for I := 1 to MAX doã A[I] := I;ã for I := MAX - 1 downto 1 doã beginã J := random(I) + 1;ã Swap(A[I + 1], A[J]);ã end;ãend;ããprocedure Pause;ãbeginã writeln;ã writeln('Press any key to continue...');ã while keypressed doã readkey;ã while not keypressed do;ã readkey;ãend;ããprocedure PrintOut;ãvarã I : word;ãbeginã ClrScr;ã For I := 1 to MAX doã beginã if WhereY >= 22 thenã beginã Pause;ã ClrScr;ã end;ã if (WhereX >= 70) thenã Writeln(A[I] : 5)ã elseã Write(A[I] : 5);ã end;ã writeln;ã Pause;ãend;ããbeginã ClrScr;ã InitArray;ã PrintOut;ã Bubble;ã PrintOut;ã writeln;ã writeln('Took ', Loops, ' Loops to complete');ãend.ã 12 05-28-9313:57ALL SWAG SUPPORT TEAM MODHEAP.PAS IMPORT 39 Sv§ {ãOk, here is your "fastest sort routine." I spent a couple hours just tweakingãand testing to make sure that it was performing 100%.ããAdding $G+ only yielded a very slight speed increase but a noticeable one. (Theãspeed results below are based on $G-.) Using anything other than Integer forãVariables caused a slight degredation in performance. I would guess thatãInteger arithmetic is where Borland focused its optimizations on. Word andãLongInt all caused performance degredation.ããAND, it used to be that previous to v6 or v5.5 that multiplication was a bottleãneck too, as in J := I * 3; The faster method was to say J := I+I+I; sinceãaddition is faster than multiplication. I didn't see any appreciable differenceãwith respect to multiplication over addition here.ããThe following algorithm is a modified Fibonacci Heap sort With the addition ofãa mid-sort bounce technique. It runs almost twice the speed of the Quick Sortãalgorithm as posted in my last message.ããIt Uses considerably less stack then Quick Sort since it is non-recursive. And,ãfor those of you who hate GOTO's, there's three in this code. Any other way Iãcould think of would increase data and reduce performance. But you're certainlyãwelcome to jump in and knock 'em outa there if you can!ããHere are the speed results as tested on 386-40mhz:ãã 500 Elements - (Less than 1/10 second)ã 1000 Elements - 0.1 Secondsã 1500 Elements - 0.2 Secondsã 2000 Elements - 0.3 Secondsã 5000 Elements - 1.0 Secondsã 7500 Elements - 1.7 Secondsã 10000 Elements - 2.3 SecondsããI modified the skeleton Program slightly to increase the number of 10 CharacterãStrings to 10,000 so that I could test that far.ããHere is the source code For the algorithm. Just "Plug" it into the skeletonãProgram I posted a day or so ago.ãã{------------------------------------------------------------------------}ãProcedure ModHeapSort( Total : Integer );ãVarã I,J,K,L : Integer;ã X, Temp : Pointer;ã M,M1,M2 : Integer;ãã Label JumpOut;ã Label Terminate;ã Label SmallSort;ããbeginã if Total <= 4 Thenã Goto SmallSort; { Too small For Split sorting }ãã M := Pred(Total) div 3;ã M1 := ( M * 3 ) + 2;ãã if M1 <= Total Thenã beginã if M1 < Total Thenã if SortArray[M1]^ < SortArray[Total]^ Thenã M2 := Totalã ELSEã M2 := M1ã ELSEã M2 := M1;ãã if SortArray[1]^ < SortArray[M2]^ Thenã begin { Swap first element to M2 }ã Temp := SortArray[1];ã SortArray[1] := SortArray[M2];ã SortArray[M2] := Temp;ã end;ãã end; {IF M1 <= Total}ãã For L := M DownTo 1 DOã beginã X := SortArray[L];ã I := L;ã J := I * 3;ãã Repeatãã K := Pred(J);ãã if SortArray[K]^ < SortArray[J]^ Thenã K := J;ã if SortArray[K]^ < SortArray[Succ(J)]^ Thenã K := Succ(J);ãã SortArray[I] := SortArray[K];ã I := K;ã J := I * 3;ãã Until J > M1;ãã J := Succ(I) div 3;ãã Repeatãã if SortArray[J]^ >= SmallArrPtr(X)^ Thenã Goto JumpOut;ãã SortArray[I] := SortArray[J];ã I := J;ã J := Succ(J) div 3;ãã Until J < L;ãã JumpOut:ã SortArray[I] := X;ãã end;ãã For L := M1 To Total DOã beginã X := SortArray[L];ã I := L;ã J := Succ(I) div 3;ãã if SortArray[J]^ < SmallArrPtr(X)^ Thenã beginãã Repeatã SortArray[I] := SortArray[J];ã I := J;ã J := Succ(J) div 3;ã Until SortArray[J]^ >= SmallArrPtr(X)^;ãã SortArray[I] := X;ãã end; {IF}ã end; {For}ãã L := Total;ãã While L > 4 DOã beginã X := SortArray[L];ã SortArray[L] := SortArray[1];ã Dec(L,1);ã I := 1;ã J := 3;ãã Repeatã K := Pred(J);ãã if SortArray[K]^ < SortArray[J]^ Thenã K := J;ã if SortArray[K]^ < SortArray[Succ(J)]^ Thenã K := Succ(J);ãã SortArray[I] := SortArray[K];ã I := K;ã J := I * 3;ã Until J >= L;ãã Dec(J,1);ãã if J <= L Thenã beginã if J < L Thenã if SortArray[J]^ < SortArray[L]^ Thenã J := L;ã SortArray[I] := SortArray[J];ã I := J;ã end; {IF}ãã J := Succ(I) div 3;ãã if SortArray[J]^ < SmallArrPtr(X)^ Thenã Repeatã SortArray[I] := SortArray[J];ã I := J;ã J := Succ(J) div 3;ã Until SortArray[J]^ >= SmallArrPtr(X)^;ãã SortArray[I] := X;ã end;ãã { Process last four remaining elements, or less than 4 to sort }ã { Use "Insertion sort" method For best linear time performance }ãã SmallSort :ã if Total <= 4 Thenã L := Totalã ELSEã L := 4;ãã For I := 2 To L DOã beginã X := SortArray[I];ã For J := Pred(I) DownTo 1 DOã if SortArray[J]^ > SmallArrPtr(X)^ Thenã SortArray[Succ(J)] := SortArray[J]ã ELSEã Goto Terminate;ã J := 0;ãã Terminate : SortArray[Succ(J)] := X;ãã end; {For I}ãend;ã 13 05-28-9313:57ALL SWAG SUPPORT TEAM OOP-SORT.PAS IMPORT 10 Suÿ {ãWL> Say, would anyone know how-to sort a Record With 5 thingã WL> in it one of which is "NAME"...I want to sort each Recordã WL> in the Array by name and can't figure it out....my Arrayã WL> name is LabelS and my Record name is SofT....so any helpã WL> would greatly be appreciated...thanksããThe easiest way is to make it an Object, and put it in a TSortedCollection.ãFor example:ã}ãã Typeã PMyrec = ^TMyrec;ã TMyrec = Object(tObject)ã name : String;ã other : Integer;ã end;ãã TSortedRecs = Object(TSortedCollection)ã Function Compare(Key1,key2:Pointer):Integer; Virtual;ã end;ãã Function TSortedRecs.Compare;ã Varã p1 : PMyrec Absolute Key1;ã p2 : PMyrec Absolute Key2;ã beginã if p1^.name < p2^.name thenã Compare := -1ã else if p1^.name = p2^.name thenã Compare := 0ã elseã Compare := 1;ã end;ããVarã rec : PMyrec;ã coll: TSortedRecs; beginã coll.init(100,10); { Init to 100 Records, grow by 10s }ãã While More_Records doã beginã new(rec,init);ã rec^.name := Get_Name;ã rec^.other:= Get_Other;ã coll.insert(rec);ã end;ã 14 05-28-9313:57ALL REYNIR STEFANSSON Pointer Sort IMPORT 28 S8í {ãREYNIR STEFANSSONããSome time ago I wangled myself into a beta testing team For a floppyãdisk catalogger called FlopiCat. This is a rather BASIC (in more than oneãway) Program, but works well enough.ããThe built-in sorting routine was a bit quacked, so I wrote my ownãexternal sorter, which is both more versatile and faster (by far) than theãinternal one.ãã Here it is, in Case someone can use the idea (and code):ã}ããProgram FlopiSrt; { Sorts FlopiCat.Dat. }ããConstã Maximum = 6000; { I don't need that many meself... }ã FName : String[12] = 'Flopicat.Dat';ããTypeã fEntry = Recordã n : Array[1..4] of Char;ã i : Array[1..35] of Char;ã d : Array[1..39] of Char;ã end;ãã En1 = Array[1..78] of Char;ã En2 = Recordã n : Array[1..4] of Char;ã f : Array[1..9] of Char;ã e : Array[1..3] of Char;ã z : Array[1..8] of Char;ã t : Array[1..15] of Char;ã d : Array[1..39] of Char;ã end;ãã En3 = Recordã f, d : Array[1..39] of Char;ã end;ãã pEntry = ^fEntry;ããVarã Entry : Array [1..Maximum] of pEntry;ã fc : File of fEntry;ã Rev : Boolean;ã LoMem : Pointer;ã i,ã NumOfEntries : Integer;ã nfd : Char;ã s : String;ããFunction ToSwap(i, j : Integer) : Boolean;ãVarã Swop : Boolean;ãbeginã Swop := False;ã Case nfd OFã { Sorting by disk number: }ã 'N' : if Entry[i]^.n > Entry[j]^.n thenã Swop := True;ã { Sorting by File information: }ã 'I' : if Entry[i]^.i > Entry[j]^.i thenã Swop := True;ã { Sorting by description: }ã 'D' : if Entry[i]^.d > Entry[j]^.d thenã Swop := True;ã { Sorting by all the String: }ã 'A' : if En1(Entry[i]^) > En1(Entry[j]^) thenã Swop := True;ã { Sorting by File name only: }ã 'F' : if En2(Entry[i]^).f > En2(Entry[j]^).f thenã Swop := True;ã { Sorting by File extension only: }ã 'E' : if En2(Entry[i]^).e > En2(Entry[j]^).e thenã Swop := True;ã { Sorting by File size: }ã 'Z' : if En2(Entry[i]^).z > En2(Entry[j]^).z thenã Swop := True;ã { Sorting by date/time stamp: }ã 'T' : if En2(Entry[i]^).t > En2(Entry[j]^).t thenã Swop := True;ã { Sorting by disk number/File info block: }ã 'B' : if En3(Entry[i]^).f > En3(Entry[j]^).f thenã Swop := True;ã end;ã ToSwap := Swop xor Rev;ãend;ãã{ if I remember correctly, I settled on using shaker/shuttle sort. }ãProcedure SortIt;ãVarã i, j,ã pb, pf,ã pp, pt : Integer;ã t : pEntry;ãã Procedure SwapIt(i, j : Integer);ã beginã t := Entry[i];ã Entry[i] := Entry[j];ã Entry[j] := t;ã end;ããbeginã Write('0 entries processed.');ã i := 0;ã pt := 2;ã pb := NumOfEntries;ã pf := 0;ã Repeatã pp := pt;ã Repeatã if ToSwap(pp - 1, pp) thenã beginã SwapIt(pp - 1, pp);ã pf := pp;ã end;ã Inc(pp);ã Until pp > pb;ãã pb := pf - 1;ã j := i;ã i := NumOfEntries - (pb - pt + 2);ã if (i MOD 10) < (j MOD 10) thenã Write(#13, i);ã if pb < pt thenã Exit;ã pp := pb;ãã Repeatã if ToSwap(pp - 1, pp) thenã beginã SwapIt(pp - 1, pp);ã pf := pp;ã end;ã Dec(pp);ã Until pp < pt;ãã pt := pf + 1;ã j := i;ã i := NumOfEntries - (pb - pt + 2);ã if (i MOD 10) < (j MOD 10) thenã Write(#13, i);ã Until pb < pt;ãend;ãã 15 05-28-9313:57ALL SWAG SUPPORT TEAM QUICK1.PAS IMPORT 15 Så£ Unit Qsort;ãã{ããCopyright 1990 Trevor J CarlsenãAll rights reserved.ããAuthor: Trevor J Carlsenã PO Box 568ã Port Hedland WA 6721ã ãA general purpose sorting Unit.ããã}ããInterfaceããTypeã updown = (ascending,descending);ã str255 = String;ã dataType = str255; { the Type of data to be sorted }ã dataptr = ^dataType;ã ptrArray = Array[1..10000] of dataptr;ã Arrayptr = ^ptrArray;ã ãConst ã maxsize : Word = 10000;ã SortType : updown = ascending;ã ãProcedure QuickSort(Var da; left,right : Word);ãã{============================================================================}ãImplementationã ãProcedure swap(Var a,b : dataptr); { Swap the Pointers }ã Var t : dataptr;ã beginã t := a;ã a := b;ã b := t;ã end;ã ã ãProcedure QuickSort(Var da; left,right : Word);ã Varã d : ptrArray Absolute da;ã pivot : dataType;ã lower,ã upper,ã middle : Word;ãã beginã lower := left;ã upper := right;ã middle:= (left + right) div 2;ã pivot := d[middle]^;ã Repeatã Case SortType ofã ascending : beginã While d[lower]^ < pivot do inc(lower);ã While pivot < d[upper]^ do dec(upper);ã end;ã descending: beginã While d[lower]^ > pivot do inc(lower);ã While pivot > d[upper]^ do dec(upper);ã end;ã end; { Case } ã if lower <= upper then beginã { swap the Pointers not the data }ã swap(d[lower],d[upper]);ã inc(lower);ã dec(upper);ã end;ã Until lower > upper;ã if left < upper then QuickSort(d,left,upper);ã if lower < right then QuickSort(d,lower,right);ã end; { QuickSort }ããend.ããã 16 05-28-9313:57ALL SWAG SUPPORT TEAM QUICK2.PAS IMPORT 16 Sƒ {...This is as generic a QuickSort as I currently use:ã}ã{$A+,B-,D-,E-,F-,G-,I-,L-,N-,O-,P-,R-,S-,T-,V-}ã{$M 60000,0,0}ããProgram QuickSortDemo;ãUsesã Crt;ããConstã coMaxItem = 30000;ããTypeã Item = Word;ã arItem = Array[1..coMaxItem] of Item;ãã (***** QuickSort routine. *)ã (* *)ãProcedure QuickSort({update} Var arData : arItem;ã {input } woLeft,ã woRight : Word);ãVarã Pivot,ã TempItem : Item;ã woIndex1,ã woIndex2 : Word;ãbeginã woIndex1 := woLeft;ã woIndex2 := woRight;ã Pivot := arData[(woLeft + woRight) div 2];ã Repeatã While (arData[woIndex1] < Pivot) doã inc(woIndex1);ã While (Pivot < arData[woIndex2]) doã dec(woIndex2);ã if (woIndex1 <= woIndex2) thenã beginã TempItem := arData[woIndex1];ã arData[woIndex1] := arData[woIndex2];ã arData[woIndex2] := TempItem;ã inc(woIndex1);ã dec(woIndex2)ã endã Until (woIndex1 > woIndex2);ã if (woLeft < woIndex2) thenã QuickSort(arData, woLeft, woIndex2);ã if (woIndex1 < woRight) thenã QuickSort(arData, woIndex1, woRight)ãend; (* QuickSort. *)ããVarã woIndex : Word;ã Buffer : arItem;ããbeginã Write('Creating ', coMaxItem, ' random numbers... ');ã For woIndex := 1 to coMaxItem doã Buffer[woIndex] := random(65535);ã Writeln('Finished!');ã Write('Sorting ', coMaxItem, ' random numbers... ');ã QuickSort(Buffer, 1, coMaxItem);ã Writeln('Finished!');ã Writeln;ã Writeln('Press the key to display all ', coMaxItem,ã ' sorted numbers...');ã readln;ã For woIndex := 1 to coMaxItem doã Write(Buffer[woIndex]:8)ãend.ã 17 05-28-9313:57ALL TEK CHAN Quick Sort IMPORT 13 SÐO { File that will teach me how to quick sort? I know how quick sort worksã but I don't know why my Program doesn't sort properaly. Sometimes it goesã through one cycle of sort and sometimes it goes through two cycles of sortã but it never sorts it Completely! Tek ChanããHere is some generic source code, change it to suit your needs/Types:ã}ããProcedure Split(Var Info: ArrayType; First: Integer; Last: Integer; VarãSplitPt1: Integer; Var SplitPt2: Integer);ããVar SplitVal, Temp: ArrayElementType;ããbeginã SplitVal:=Info[(First+Last) div 2];ã Repeatã While Info[First] < SplitVal doã First:=First+1;ã While Info[Last] > SplitVal doã Last:=Last-1;ã if First <= Last thenã beginã Temp:=Info[First];ã Info[First]:=Info[Last];ã Info[Last]:=Temp;ã First:=First+1;ã Last:=Last-1;ã endã Until First > Last;ã SplitPt1:=First;ã SplitPt2:=Last;ãend;ããProcedure QuickSort(Var Info: ArrayType; First:Integer; Last: Integer);ããVar SplitPt1, SplitPt2: Integer;ããbeginã if First < Last thenã beginã Split(Info, First, Last, SplitPt1, SplitPt2);ã if SplitPt1 < Lastã then QuickSort(Info, SplitPt1, Last);ã if First < SplitPt2ã then QuickSort(Info, First, SplitPt2);ã endãend;ãã{ãThis is a -very- fast sort, much faster than any other I have. Does aãnon-recursive version exist? Are there any faster sorts? Brianã} 18 05-28-9313:57ALL SWAG SUPPORT TEAM QUICK4.PAS IMPORT 17 Sôv Unit qsort;ããInterfaceããProcedure quicksort(Var s; left,right : Word);ããImplementationããProcedure quicksort(Var s; left,right : Word; SortType: sType);ã { On the first call left should always be = to min and right = to max }ã Varã data : DataArr Absolute s;ã pivotStr,ã tempStr : String;ã pivotLong,ã tempLong : LongIntã lower,ã upper,ã middle : Word;ãã Procedure swap(Var a,b);ã Var x : DirRec Absolute a;ã y : DirRec Absolute b;ã t : DirRec;ã beginã t := x;ã x := y;ã y := t;ã end;ãã beginã lower := left;ã upper := right;ã middle:= (left + right) div 2;ã Case SortType ofã _name: pivotStr := data[middle].name;ã _ext : pivotStr := data[middle].ext;ã _size: pivotLong := data[middle].Lsize;ã _date: pivotLong := data[middle].Ldate;ã end; { Case SortType }ã Repeatã Case SortType ofã _name: beginã While data[lower].name < pivotStr do inc(lower);ã While pivotStr < data[upper].name do dec(upper);ã end;ã _ext : beginã While data[lower].ext < pivotStr do inc(lower);ã While pivotStr < data[upper].ext do dec(upper);ã end;ã _size: beginã While data[lower].Lsize < pivotLong do inc(lower);ã While pivotLong < data[upper].Lsize do dec(upper);ã end;ã _date: beginã While data[lower].Ldate < pivotLong do inc(lower);ã While pivotLong < data[upper].Ldate do dec(upper);ã end;ã end; { Case SortType }ã if lower <= upper then beginã swap(data[lower],data[upper]);ã inc(lower);ã dec(upper);ã end;ã Until lower > upper;ã if left < upper then quicksort(data,left,upper);ã if lower < right then quicksort(data,lower,right);ã end; { quicksort }ãããããããã 19 05-28-9313:57ALL SWAG SUPPORT TEAM QUICK5.PAS IMPORT 19 Sè, {ã>I'm in need of a FAST way of finding the largest and the smallestã>30 numbers out of about 1000 different numbers.ãã ...Assuming that the 1000 numbers are in random-order, I imagineã that the simplest (perhaps fastest too) method would be to:ãã 1- Read the numbers in an Array.ãã 2- QuickSort the Array.ãã 3- First 30 and last 30 of Array are the numbers you want.ãã ...Here's a QuickSort demo Program that should help you With theã sort:ã}ãã{$A+,B-,D-,E-,F-,I-,L-,N-,O-,R-,S+,V-}ã{$M 60000,0,0}ããProgram QuickSort_Demo;ãUsesã Crt;ããConstã co_MaxItem = 30000;ããTypeã Item = Word;ã ar_Item = Array[1..co_MaxItem] of Item;ããã (***** QuickSort routine. *)ã (* *)ãProcedure QuickSort({update} Var ar_Data : ar_Item;ã {input } wo_Left,ã wo_Right : Word);ãVarã Pivot,ã TempItem : Item;ã wo_Index1,ã wo_Index2 : Word;ãbeginã wo_Index1 := wo_Left;ã wo_Index2 := wo_Right;ã Pivot := ar_Data[(wo_Left + wo_Right) div 2];ã Repeatã While (ar_Data[wo_Index1] < Pivot) doã inc(wo_Index1);ã While (Pivot < ar_Data[wo_Index2]) doã dec(wo_Index2);ã if (wo_Index1 <= wo_Index2) thenã beginã TempItem := ar_Data[wo_Index1];ã ar_Data[wo_Index1] := ar_Data[wo_Index2];ã ar_Data[wo_Index2] := TempItem;ã inc(wo_Index1);ã dec(wo_Index2)ã endã Until (wo_Index1 > wo_Index2);ã if (wo_Left < wo_Index2) thenã QuickSort(ar_Data, wo_Left, wo_Index2);ã if (wo_Index1 < wo_Right) thenã QuickSort(ar_Data, wo_Index1, wo_Right)ãend; (* QuickSort. *)ããVarã wo_Index : Word;ã ar_Buffer : ar_Item;ããbeginã Write('Creating ', co_MaxItem, ' random numbers... ');ã For wo_Index := 1 to co_MaxItem doã ar_Buffer[wo_Index] := random(65535);ã Writeln('Finished!');ã Write('Sorting ', co_MaxItem, ' random numbers... ');ã QuickSort(ar_Buffer, 1, co_MaxItem);ã Writeln('Finished!');ã Writeln;ã Writeln('Press the key to display all ', co_MaxItem,ã ' sorted numbers...');ã readln;ã For wo_Index := 1 to co_MaxItem doã Write(ar_Buffer[wo_Index]:8)ãend.ã 20 05-28-9313:57ALL SWAG SUPPORT TEAM RADIX1.PAS IMPORT 34 S€l {ã Here's my solution to your "contest". The first I'm rather proudã of, it incorporates bAsm to beat your devilshly efficient CASEã Implementation by a factor of 2x.ãã The second, I am rather disappointed With as it doesn't even comeã CLOSE to TP's inbuilt STR Function. (The reason, I have found, isã because TP's implementaion Uses a table based approach that wouldã be hard to duplicate With Variable radixes. I am working on aã Variable radix table now)ããã ****************************************************************ã Converts String pointed to by S into unsigned Integer V. Noã range or error checking is performed. Caller is responsible forã ensuring that Radix is in proper range of 2-36, and that noã invalid Characters exist in the String.ã ****************************************************************ã}ãTypeã pChar = ^chr_Array;ã chr_Array = Array[0..255] of Char;ã Byte_arry = Array[Char] of Byte;ããConstã sym_tab : Byte_arry = (ã 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,ã 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,ã 0,0,0,0,0,0,0,0,0,1,2,3,4,5,6,7,8,9,ã 0,0,0,0,0,0,0,10,11,12,13,14,15,16,17,ã 18,19,20,21,22,23,24,25,26,27,28,29,30,ã 31,32,33,34,35,0,0,0,0,0,0,10,11,12,13,ã 14,15,16,17,18,19,20,21,22,23,24,25,26,ã 27,28,29,30,31,32,33,34,35,0,0,0,0,0,0,ã 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,ã 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,ã 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,ã 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,ã 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,ã 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,ã 0,0,0,0,0,0,0,0,0,0,0,0,0ã );ããProcedure RadixVal(Var V:LongInt; S:PChar;Radix:Byte);ãVarã digit :Byte;ã p, p2 :Pointer;ã hiwd, lowd :Word;ãbeginã V := 0;ã p := @S^[0];ã p2 := @V;ã Asmã les bx, p2ã push dsã pop esã lds si, pã @loop3:ã lea di, [sym_tab]ã xor ah, ahã lodsbã cmp al, 0ã je @quitã add di, ax { index to Char position in table }ã mov al, Byte PTR [di]ã mov digit, alã xor ah, ahã mov al, Radixã mov cx, axã mul Word PTR [bx]ã mov lowd, axã mov hiwd, dxã mov ax, cxã mul Word PTR [bx+2] { mutliply high Word With radix }ã add hiwd, ax { add result to previous result - assume hi result 0 }ã mov ax, lowdã mov dx, hiwdã add al, digit { add digit value }ã adc ah, 0 { resolve any carry }ã mov [bx], ax { store final values }ã mov [bx+2], dxã jmp @loop3ã @quit:ã end;ãend;ãã{ã ****************************************************************ã Convert unsigned Integer in V to String pointed to by S.ã Radix determines the base to use in the conversion. No rangeã checking is performed, the caller is responsible For ensuringã the radix is in the proper range (2-36), and that V is positive.ã ****************************************************************ã}ãTypeã Char_arry = Array[0..35] of Char;ããConstã symbols :Char_arry = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ';ããProcedure RadixStr(V:LongInt; S:PChar; Radix:Byte);ãVarã digit, c :Byte;ã ts :String;ã p, p2 :Pointer;ãbeginã c := 255;ã ts[255] := #0;ã p := @V;ã p2 := @ts[0];ã Asmã push dsã lea si, [symbols]ã les bx, pã les di, p2ã add di, 255ã stdã xor cx, cxã mov cl, Radixã @loop:ã SEGES mov ax, Word PTR [bx]ã SEGES mov dx, Word PTR [bx+2]ã div cxã SEGES mov Word PTR [bx], axã SEGES mov Word PTR [bx+2], 0ã mov digit, dlã push siã xor ah, ahã mov al, digitã add si, axã movsbã pop siã dec cã SEGES cmp Word PTR [bx], 0ã je @doneã SEGES cmp Word PTR [bx+2], 0ã je @loopã @done:ã pop dsã end;ã ts[c] := Chr(255-c);ã p := @S^[0];ã Asmã push dsã cldã lds si, p2ã les di, pã xor bx, bxã mov bl, cã add si, bxã mov cx, 256ã sub cl, cã sbb ch, 0ã rep movsbã pop dsã end;ãend;ã 21 05-28-9313:57ALL SWAG SUPPORT TEAM RADIX2.PAS IMPORT 16 SÕ^ {>...Assuming that the 1000 numbers are in random-order, I imagineã> that the simplest (perhaps fastest too) method would be to:ã> 1- Read the numbers in an Array.ã> 2- QuickSort the Array.ã> 3- First 30 and last 30 of Array are the numbers you want.ãã>Stop the presses, stop the presses!ãã ãã>Remember the recent Integer sort contest, on the Intelecã>Programming conference?ãã ...Ah, yes... I always tend to Forget about that method.ã Yes, a "count" sort would definitely be the fastest methodã of sorting random numerical data.ã ...What I had a few troubles figuring out from that postã in the Intelec confrence, wasn't the "count sort" method,ã but rather the "radix sort" or "digital sort" method,ã where specific bits within each data element are usedã to sort the data.ãã ...Here's the algorithm listed in Robert Sedgewick'sã "Algorithms" book, published by Addison-Wesley Publishingã Company, ISBN 0-201-06673-4 :ã}ããProcedure RadixExchange(l, r, b:Integer);ãVarã t, i, j : Integer;ãbeginã if (r > l) and (b >= 0) thenã beginã i := l;ã j := r;ã Repeatã While (bits(a[i], b, 1) = 0) and (i < j) doã i := I + 1;ã While (bits(a[j], b, 1) = 1) and (i < j) doã j := j - j;ã t := a[i];ã a[i] := a;ã a[j] := t;ã Until (j = i);ã if bits(a[r], b, 1) = 0 thenã j := j + 1;ã RadixExchange(l, (j - 1), b - 1);ã RadixExchange(j, r, (b - 1));ã end;ãend;ãã{ã>By toggling the high bit, the Integers are changed in a way that,ã>conveniently, allows sorting by magnitude: from the "most negative"ã>to "most positive," left to right, using an Array With unsignedã>indexes numbering 0...FFFFh.ãã ...Why bother With the bit toggling at all? Why not just defineã the Array's range as being: Array[-32768..32767] of Byte;ã}ãã 22 05-28-9313:57ALL SWAG SUPPORT TEAM RADIXQUE.PAS IMPORT 16 S9  Turbo Pascal Optimization Contest # 51.ããNo tangible prizes, just some bragging rights, and a brain workout.ããAssignment: Write conversion routines similar to VAL and STR that canã handle a radix (base) of any number. For example, below isã a straight Pascal Procedure to convert a String of any baseã to a LongInt. Can you improve the speed of this routine,ã and Write a correspondingly fast routine to convert from aã LongInt to a String of any base?ããRules: No rules. BAsm is allowed, as long as the Functions areã readily Compilable without the use of TAsm.ããJudging: Code will be tested on a 386-40 on March 10th, by beingã placed into a loop With no output, like this:ãã StartTiming;ã For Loop := 1 to 10000000 { ten million } doã { Execute the test, no output }ã WriteLn(StopTiming);ããReady, set, code! Here's the sample...ãã(* This Function converts an ASCIIZ String S in base Radix to LongInt Iã * With no verification of radix validity. The calling Programmer isã * responsible For insuring that the radix range is 2 through 36. Theã * calling Programmer is also responsible For insuring that the passedã * String contains only valid digits in the specified Radix. No checkingã * is done on the individual digits of a given String. For bases 11-36ã * the letters 'A'-'Z' represent the corresponding values.ã *)ããProcedure StrtoLong(Var I : LongInt; S : PChar; Radix : Integer);ã beginã I := 0;ã While S[0] <> #0 doã beginã Case S[0] of '0'..'9' : I := I * Radix + (ord(S[0])-48);ã 'A'..'Z' : I := I * Radix + (ord(S[0])-54);ã 'a'..'z' : I := I * Radix + (ord(S[0])-86);ã Inc(s);ã end;ã end;ãã 23 05-28-9313:57ALL JOY MUKHERJEE Radix Sort IMPORT 24 S€^ {ã> I agree... unFortunately the Radix algorithm (which is aã> sophisticated modification of a Distribution Sort algorithm) isã> very Complex, highly CPU dependent and highly data dependent.ããWe must be speaking of a different Radix Sort. Is the sort you areãtalking about sort numbers on the basis of their digits?ãã> My understanding is that a Radix sort cannot be implemented inã> Pascal without using a majority of Asm (which means you might asã> well code the whole thing in Asm.)ãã> assembly) or dig up some working code, I would love to play With it!ãã************************************************************************ã* *ã* Name : Joy Mukherjee *ã* Date : Mar. 26, 1990 *ã* Description : This is the Radix sort implemented in Pascal *ã* *ã************************************************************************ã}ããProgram SortStuff;ããUses Crt, Dos;ããTypeã AType = Array [1..400] of Integer;ã Ptr = ^Node;ã Node = Recordã Info : Integer;ã Link : Ptr;ã end;ã LType = Array [0..9] of Ptr;ããVarã Ran : AType;ã MaxData : Integer;ããProcedure ReadData (Var A : AType; Var MaxData : Integer);ããVar I : Integer;ããbeginã MaxData := 400;ã For I := 1 to 400 do A [I] := Random (9999);ãend;ããProcedure WriteArray (A : AType; MaxData : Integer);ããVar I : Integer;ããbeginã For I := 1 to MaxData doã Write (A [I] : 5);ã Writeln;ãend;ããProcedure Insert (Var L : LType; Number, LN : Integer);ããVarã P, Q : Ptr;ããbeginã New (P);ã P^.Info := Number;ã P^.Link := Nil;ã Q := L [LN];ã if Q = Nil thenã L [LN] := Pã elseã beginã While Q^.Link <> Nil doã Q := Q^.Link;ã Q^.Link := P;ã end;ãend;ãããProcedure Refill (Var A : AType; Var L : LType);ãVarã I, J : Integer;ã P : Ptr;ãbeginã J := 1;ã For I := 0 to 9 doã beginã P := L [I];ã While P <> Nil doã beginã A [J] := P^.Info;ã P := P^.Link;ã J := J + 1;ã end;ã end;ã For I := 0 to 9 doã L [I] := Nil;ãend;ããProcedure RadixSort (Var A : AType; MaxData : Integer);ãVarã L : LType;ã I,ã divisor,ã ListNo,ã Number : Integer;ãbeginã For I := 0 to 9 do L [I] := Nil;ã divisor := 1;ã While divisor <= 1000 doã beginã I := 1;ã While I <= MaxData doã beginã Number := A [I];ã ListNo := Number div divisor MOD 10;ã Insert (L, Number, ListNo);ã I := I + 1;ã end;ã Refill (A, L);ã divisor := 10 * divisor;ã end;ãend;ããbeginã ReadData (Ran, MaxData);ã Writeln ('Unsorted : ');ã WriteArray (Ran, MaxData);ã RadixSort (Ran, MaxData);ã Writeln ('Sorted : ');ã WriteArray (Ran, MaxData);ãend.ã 24 05-28-9313:57ALL SWAG SUPPORT TEAM SHELL1.PAS IMPORT 14 S*K { Arrrggghh. I hate Bubble sorts. Why don't you use Merge sort? It's a hellã of a lot faster and if you have a large enough stack, there wouldn't beã any problems. if you were not interested in doing a recursive sort, thenã here is an example fo the Shell sort which is one of the most efficientã non recursive sorts around.ã}ãããConstã Max = 50;ãTypeã ArrayType = Array[1..Max] of Integer;ããVarã Data, Temp : ArrayType;ã Response : Char;ã X, Iteration : Integer;ããProcedure ShellSort (Var Data : ArrayType;Var Iteration : Integer;ã NumberItems : Integer);ããProcedure Sort (Var Data : ArrayType; Var Iteration : Integer;ã NumberItems, Distance : Integer);ããVarã X, Y : Integer;ããbegin {Sort}ã Iteration := 0;ã For Y := Distance + 1 to NumberItems Doã begin {For}ã X := Y - Distance;ã While X > 0 Doã begin {While}ã if Data[X+Distance] < Data[X] thenã begin {if}ã Switch (Data[X+Distance], Data[X], Iteration);ã X := X - Distance;ã Iteration := Iteration + 1ã end {if}ã elseã X := 0;ã end; {While}ã end {For}ãend; {Sort}ããbegin {ShellSort}ã Distance := NumberItems div 2;ã While Distance > 0 doã begin {While}ã Sort (Data, Iteration, NumberItems, Distance);ã Distance := Distance div 2ã end; {While}ãend; {ShellSort}ã 25 05-28-9313:57ALL SWAG SUPPORT TEAM SOMESORT.PAS IMPORT 18 S£ { Author: Brian Pape. }ããConstã maxrange = 5000;ããTypeã ListRange = 1..MaxRange;ã list = Array[ListRange] of Integer;ããVarã a,b: list;ã i: Integer;ããProcedure BubbleSort(Var B : list; Terms : Integer);ãVarã J, Temp : Integer;ã Changed : Boolean;ã Last,ã LastSwitch : Integer;ãbeginã changed := True;ã Last := Terms-1;ã While Changed doã beginã changed := False;ã For J := 1 to Last doã If B[J] > B[J+1] thenã beginã Temp := B[J];ã B[J] := B[J+1];ã B[J+1] := Temp;ã Changed := True;ã LastSwitch := j;ã end; { If B[J] }ã Last := LastSwitch -1;ã end { While Changed }ãend; { BubbleSort }ããProcedure Min_MaxSort(Var a : list; NumberTerms : ListRange);ãVarã temp,ã i,l,r,ã min,max,ã tempMin,ã tempMax,ã indexMin,ã indexMax,ã s1,s2,s3,s4 : Integer;ã changed : Boolean;ãbeginã l := 1; r := NumberTerms; max := MaxInt;ã Repeatã min := max;ã changed := False;ã max := 0;ã For i := l to r doã beginã if a[i] > max thenã beginã changed := True;ã Max := a[i];ã indexMax := i;ã end; { if }ã if a[i] < min thenã beginã changed := True;ã Min := a[i];ã indexMin := i;ã end; { if }ã end; { For }ãã tempMin := a[indexMin];ã tempMax := a[indexMax];ã a[indexMax] := a[l];ã a[l] := tempMin;ã a[indexMin] := a[r];ã a[r] := tempMax;ã inc(l); dec(r);ã Until (l>=r) or not changed;ãend; { Min_MaxSort }ãããProcedure ShellSort(Var a : list; NumberTerms : ListRange);ãConstã start = 1;ã increment = 3; { division factor of terms }ãVarã i,j : ListRange;ã t : Integer;ã found : Boolean;ãbeginã i := start + increment;ã While i <= NumberTerms doã beginã if a[i] < a[i - increment] thenã beginã j := 1;ã t := a[i];ã Repeatã j := j - increment;ã a[j + increment] := a[j];ã if j = 1 thenã found := Trueã elseã found := a[j - increment] <= t;ã Until found;ã a[j] := t;ã end; { if }ã i := i + increment;ã end; { While }ãend; { ShellSort }ã 26 05-28-9313:57ALL SWAG SUPPORT TEAM SORT-DLL.PAS IMPORT 25 SÎ {ã> Now, I gotta work on sortin' em. I believe I can 'swap' theã> positions of the Pointers eh?ã>ã> I can't figure out how to swap the Pointers. Could you pleaseã> gimme a wee bit more help? I've just started doing sorts, andã> have only used the Bubble sort at the moment in a few Programs,ã> so I'm still a little shakey on sorts. I understand the Bubbleãã Here's an *example* on how to sort a linked list. There are moreã efficient ways to sort a list, but this gives you all theã essential elements in doing a sort. (note that ListPtr is a doublyã linked list)ã}ããProcedure SortList(Var FCL:ListPtr);ãVarã TempAnchor, TemPtr1, TemPtr2 :ListPtr;ãã Procedure MoveLink(Var Anchor, Ptr1, Ptr2 :ListPtr);ã Varã TemPtr3, TemPtr4 :ListPtr;ã beginã TemPtr3 := Ptr1^.Next; { temporary Pointer preserves oldã Pointer value }ã TemPtr4 := Ptr2^.Last; { ditto }ãã Ptr2^.Last := Ptr1; { do the Pointer swap }ã Ptr1^.Next := Ptr2;ãã Ptr1^.Last^.Next := TemPtr3; { fixup secondary Pointers }ã TemPtr3^.Last := Ptr1^.Last;ã Ptr1^.Last := TemPtr4;ãã if TemPtr4 <> NIL then { if temporary Pointer is notã NIL, then it has to point toã swapped Pointer }ã TemPtr4^.Next := Ptr1;ãã if Ptr1^.Last = NIL then { if swapped Pointer points toã preceding NIL Pointer, thisã Pointer is the new root. }ã Anchor := Ptr1;ã end;ããbeginã TempAnchor := FCL; { holds root of list during sort }ã TemPtr2 := TempAnchor; { TemPtr2 points to current data beingã Compared }ã Repeatã TemPtr1 := TemPtr2; { TemPtr1 points to the next orderedã data }ã FCL := TemPtr2; { start FCL at root of UNSorTED list -ã sorted data precede this Pointer }ã Repeatã FCL := FCL^.Next;ã if FCL^.data < TemPtr1^.data then { Compare data values }ã TemPtr1 := FCL; { if necessary, reset TemPtr1 toã point to the new ordered value }ã Until FCL^.Next = NIL; { keep going Until you reach theã end of the list. After Exit,ã the next value in order will beã pointed to by TemPtr1 }ã if TemPtr1<>TemPtr2 then { if TemPtr1 changed, a valueã was found out of order }ã MoveLink(TempAnchor,TemPtr1,TemPtr2) { then swap Pointers }ã elseã TemPtr2 := TemPtr2^.Next; { else advance to the nextã Pointer in list }ã Until TemPtr2^.Next = NIL; { Until we are finished sortingã the list }ã FCL := TempAnchor; { changes root Pointer to new root value }ãend;ãã 27 05-28-9313:57ALL SWAG SUPPORT TEAM SORT-LL.PAS IMPORT 25 Sf {ã> I have a linked list structure that I would like to sort in one ofã> four different ways. I can sort Arrays using QuickSort, etc., but have noã> experience sorting linked lists. Does anyone have any source codeã> (preferably) or any suggestions on how to proceed? Any help would beã> appreciated.ããI got Modula-2 code I wrote about one year ago. I post an excerpt fromãthe Implementation MODULE. It should be no problem to convert it toãPascal, since the languages are rather similar.ã}ãProcedure LISTSort(Var List : LISTType;ã Ascending: Boolean);ããVarã Last : NodeTypePtr;ã Result: LISTCompareResultType;ãã Procedure TailIns( Rec : NodeTypePtr;ã Var First: NodeTypePtr;ã Var Last : NodeTypePtr);ãã beginã if (First=NIL) then First := Rec else Last^.Next := Rec end;ã Last := Recã end TailIns;ãã Procedure MergeLists( a: NodeTypePtr;ã b: NodeTypePtr): NodeTypePtr;ãã Varã First: NodeTypePtr;ã Last : NodeTypePtr;ã Help : NodeTypePtr;ãã beginã First := NIL;ã While (b#NIL) doã if (a=NIL) thenã a := b; b := NILã elseã if (Classes[List^.ClassID].Cmp(b^.DataPtr,a^.DataPtr)=Result)ã thenã Help := a; a := a^.Nextã elseã Help := b; b := b^.Nextã end;ã Help^.Next := NIL;ã TailIns(Help,First,Last)ã endã end;ã TailIns(a,First,Last);ã RETURN(First)ã end MergeLists;ãã Procedure MergeSort(Var Root: NodeTypePtr;ã N : CARDinAL): NodeTypePtr;ãã Varã Help: NodeTypePtr;ã a,b : NodeTypePtr;ãã beginã if (Root=NIL) thenã RETURN(NIL)ã ELSif (N>1) thenã a := MergeSort(Root,N div 2);ã b := MergeSort(Root,(N+1) div 2);ã RETURN(MergeLists(a,b))ã elseã Help := Root;ã Root := Root^.Next;ã Help^.Next := NIL;ã RETURN(Help)ã endã end MergeSort;ããbeginã if (List^.N<2) then RETURN end;ã if (Ascending) then Result := LISTGreater else Result := LISTLess end;ã List^.top^.Next := MergeSort(List^.top^.Next,List^.N);ã Last := List^.top;ã List^.Cursor := List^.top^.Next;ã While (List^.Cursor#NIL) doã List^.Cursor^.Prev := Last;ã Last := List^.Cursor;ã List^.Cursor := List^.Cursor^.Nextã end;ã Last^.Next := List^.Bottom;ã List^.Bottom^.Prev := Last;ã List^.CurPos := 1;ã List^.Cursor := List^.top^.Nextãend LISTSort;ãã{ãThe basic data structure is defined as follows:ã}ããConstã MaxClasses = 256;ããTypeã NodeTypePtr = Pointer to NodeType;ãã NodeType = Recordã Prev : NodeTypePtr;ã Next : NodeTypePtr;ã DataPtr: ADDRESSã end;ãã LISTType = Pointer to ListType;ãã ListType = Recordã top : NodeTypePtr;ã Bottom : NodeTypePtr;ã Cursor : NodeTypePtr;ã N : CARDinAL;ã CurPos : CARDinAL;ã ClassID: CARDinALã end;ãã ClassType = Recordã Cmp : LISTCompareProcType;ã Bytes: CARDinALã end;ããVarã Classes: Array [0..MaxClasses-1] of ClassType;ã 28 05-28-9313:57ALL SWAG SUPPORT TEAM SORT-PTR.PAS IMPORT 11 SÓ° {ã This is using the concept of a PoINter Array (an Array of PoINters). Itãallows For a _very_ large amount of data, sINce you allocate each Record spaceãof the Heap. You must allocate each space For each Record as you create theãRecord:ã}ãã New (INFOSTUFF[3]); { allocates space For 3rd Record }ã With INFOSTUFF[6]^ do { works With 6th Record }ã beginã NAME := 'Patrick Edwards'; IDNUM := 60000; MOM := ''ã end;ãã The sort could be:ããVar T : INFO;ãProcedure L_HSorT (LEFT,RIGHT : Word); { Lo-Hi QuickSort }ãVar LOWER,UPPER,MIDDLE : Word;ã PIVOT : INFO;ãbeginã LOWER := LEFT; UPPER := RIGHT; MIDDLE := (LEFT+RIGHT) div 2;ã PIVOT := INFOSTUFF[MIDDLE]^;ã Repeatã While INFOSTUFF[LOWER]^.NAME < PIVOT.NAME do INc(LOWER);ã While PIVOT.NAME < INFOSTUFF[UPPER]^.NAME do Dec(UPPER);ã if LOWER <= UPPER thenã beginã T := INFOSTUFF[LOWER]^; INFOSTUFF[LOWER]^ := INFOSTUFF[UPPER]^;ã INFOSTUFF[UPPER]^ := T;ã INc (LOWER); Dec (UPPER);ã end;ã Until LOWER > UPPER;ã if LEFT < UPPER then L_HSorT (LEFT, UPPER);ã if LOWER < RIGHT then L_HSorT (LOWER, RIGHT);ãend; { L_HSorT }ãã{ called as:ããL_HSorT (1,10);ã}ã 29 05-28-9313:57ALL SWAG SUPPORT TEAM SORT-STR.PAS IMPORT 7 Så  {ãIt gets better and better. The Procedure below is incredibly fast in theãsorting of the Strings in the Arrays! 1.2 sec For 1485 Strings.ã}ããProcedure Sort(item : PFilearr; Last : Integer);ãVarã i, j : Integer;ã span : Integer;ãbeginã item^[0] := newstr(' ');ã span := Last shr 1; {Span=Last/2}ã While span > 0 doã beginã For i := Span to Last - 1 doã beginã For j := (i - Span + 1) downto 1 doã if item^[j]^ <= item^[j + Span]^ thenã j:=1 {to make it quit the j-loop}ã elseã begin {swap Array(j) With Array(j+Span)}ã item^[0] := item^[j];ã item^[j] := item^[j + Span];ã item^[j + Span] := item^[0];ã end;ã end;ã Span := Span shr 1; {Span=Span/2}ã end;ãend;ã 30 05-28-9313:57ALL SWAG SUPPORT TEAM SORTFAST.PAS IMPORT 21 S} {ã> I might share With you a sorting Procedure which I developed Forã> 'those Arrays we were talking about:ã> ...ã> Exeperimentally I used it on 1485 Strings, which took about 3 secã> on my 386DX40. Could you advise on some method to do it evenã> faster?ããI'll share With you a little sort routine which I use often in my Programsãwhenever I need a fast and efficient routine With very low overhead... It Usesãconsiderably less code than your example, and should outperForm it. (It wouldãbe even faster if it was all coded in Assembly!-- hint hint DJ) :-)ã}ããProcedure Sort_It( totalItems : Word );ãã Function Is_Less( TemPtr1, TemPtr2 : Pointer ) : Boolean;ã beginã Is_Less := ( YourStruct(TemPtr1^).Item < YourStruct(TemPtr2^).Item );ã end;ããVarã I,J : Word;ã Cur : Word;ããbeginã For I := 1 to Pred(totalItems) doã beginã Cur := I;ãã For J := I + 1 to totalItems doã if Is_Less( Item[J], Item[Cur] ) thenã ExchangeLongInts( LongInt(Item[J]), LongInt(Item[Cur]) );ã end; { For }ããend; { Proc }ãã{ãThere's a couple things I should explain: The "ExchangeLongInts" Procedure isãfrom the TurboPower Opro's OpInline Unit. All it does is exchange two LongIntãTypes without you having to use a temporary Variable. It's fast and convenient,ãbut not the only possible solution here. (I'm Typecasting the Pointer into aãLongInt For a 4-Byte swap.)ãã"totalItems" is the total number of items in your Array to sort.ãã"Item" is the actual Array; Item : Array[1..xx] of Pointer_to_Record;ãã"YourStruct" used in the "Is_Less" Function is Typecasting the actual structureãor Record that "Item" is referring to. It's the only portion of the code whichãlooks at your actual data. to reverse the sort order, simply change the "<" toã">". to change what is being sorted, just change the ".Item" to something elseãlike ".Name" or ".Zip" or whatever else might be contained in your structure.ããThis routine is simple, has a minimum amount of code, Uses very little stack,ãworks only With Pointers and you are only sorting memory addresses; it neverãactually move any of your physical data. (if you did, then it would be slow.)ããIt'll sort several thousand items in only a couple seconds even on slowerãmachines, and is super on small volume runs. I would imagine that it wouldã(90 min left), (H)elp, More? start loosing steam around 1,000 to 2,000 items, but For me, it's the bestãchoice when memory is at a premium and the Arrays are fairly small.ã}ãã 31 05-28-9313:57ALL SWAG SUPPORT TEAM TIMESORT.PAS IMPORT 69 SÎ {I wrote a small Program to bench both sort routines we posted. It was anãinteresting test, however it did raise a couple questions For me, which I'llãget to in a moment. (The following Program can be used as a skeleton For tryingãother sort routines too.)ããNeedless to say, the routine you posted was dramatically faster than the one Iãposted, even though both routines are non-recursive simple sorts.ããThe maximum efficient load of the routine you posted appears to be about 3000ãelements. After that, additonal elements add time exponentially. For example,ãit will sort 3000 elements in 5.1 seconds, but 5000 elements takes almost 16ãseconds. The sort I posted became un-benchable [bearable] at about 3000ãelements when it took over a minute to Complete. I didn't test it beyond thisãpoint.ããHere are the results from my 386 33Mhz machine-- your algorithm.ãã 500 Elements - 0.1 Secondsã 1000 Elements - 0.8 Secondsã 1500 Elements - 1.4 Secondsã 2000 Elements - 2.6 Secondsã 3000 Elements - 5.1 Seconds <- Peak efficiency reachedã 5000 Elements - 15.8 SecondsããHere is the Program I used to benchmark with. I made it so that you couldã"tweak" portions of the sort and re-run the Program.ããIncidentally, I also Compiled this Program under Stony Brook's Pascal Plus andãwas suprised to find that it ran substantially slower. All optimizations on.ããRange Checking ($R+) exactly Doubled the time it took to sort.ããChanging "Span+1" to Succ(Span) and "total-1" to Pred(total) made the routineãabout 3% faster. However the routine then neglected to sort that last twoãelements. Adding "Inc(total,2)" solved the problem but I'm not sure why. I didãnot expect this behavior. Perhaps someone could explain why?ããI added a temporary Pointer Variable to your routine in place of the "NewStr('ã... ')" code you used to simplify it.ããand one last thing... Using OPRO's OpInline Function calledã"ExchangeLongInts()" to do the swapping instead of using a temporary Varãincreased speed another 2% (Evident at > 2000 elements.) However I did notãinclude this so that anyone interested could Compile and run this without extraãUnits.ã}ãã{$A+,B-,D-,E-,F-,G-,I+,L+,N-,O-,P-,Q+,R-,S+,T-,V-,X-,Y+}ã{$M 32768,0,655360}ããProgram Sort_Test; { Sorting Benchmark Using P. Beeftink's Algorithm }ããTypeã SmallArrPtr = ^SmallArr;ã SmallArr = Array[1..10] of Char; { Skip String & Length Byte }ãã TTimeString = String[20];ãããVarã SortArray : Array[1..5000] of SmallArrPtr; { A LARGE Array }ãã TickCount : LongInt Absolute $0040:$006C;ã { TickCount : LongInt VOLATILE Absolute $0040:$006C; } { For Pascal+ }ã Tstart,ã Ttime : LongInt;ãã{------------------------------------------------------------------------}ãProcedure StartTiming;ãbeginã TStart := TickCount;ãã {start at the beginning of a tick!}ã Repeat Until TStart <> TickCount;ãã TStart := TickCount;ããend;ã{------------------------------------------------------------------------}ãProcedure StopTiming;ãbeginã TTime := TickCount - TStart;ãend;ã{------------------------------------------------------------------------}ãFunction Elapsed : TTimeString;ãVar Temp : TTimeString;ã Sec10 : LongInt;ãbeginãã Sec10 := TTime * 2470 div 4497;ã Str( Sec10 : 4, Temp );ãã if Temp[1] = ' ' then Temp[1] := '0';ãã Inc( Temp[0] );ã Temp[ Length(Temp) ] := Temp[ Pred( Length( Temp ) ) ];ã Temp[ Pred( length( Temp ) ) ] := '.';ãã Elapsed := Temp;ãend;ã{------------------------------------------------------------------------}ãProcedure MakeRandomStrings( NumtoMake : Word );ãVar RNum,ã I,S : Word;ã Temp : String;ãbeginãã Temp := '';ã Temp[0] := Chr( 10 );ã Randomize;ãã For I := 1 to NumtoMake doã beginãã For S := 1 to 10 do { Create Random Strings 10 Chars in length }ã beginã RNum := Random(26);ã Temp[S] := Chr( RNum + 65 );ã end;ãã Move( Temp[1], SortArray[I]^, 10 );ãã end;ããend; { Proc }ã{------------------------------------------------------------------------}ãProcedure KDSort( total : Word );ã {-My simple sort routine as posted in Pascal Echo }ã { With 2 slight modifications }ãVarã i,j,ã Current : Word;ã TempPtr : Pointer;ãbeginãã For I := 1 to total doã beginãã Current := I;ãã For J := Succ(I) to total doã beginã if SortArray[J]^ < SortArray[Current]^ thenã beginã TempPtr := SortArray[j];ã SortArray[j] := SortArray[Current];ã SortArray[Current] := TempPtr;ã end; {if}ã end; {For}ãã end; {For}ããend;ã{------------------------------------------------------------------------}ãProcedure PBSort(total : Integer);ã {-Peter Beeftink's Sort as Posted in Pascal Echo }ã { Also With slight modifications }ãVarã I,j : Integer;ã Span : Integer;ã TempPtr : Pointer;ãbeginãã Inc(total,2); { Required to Compensate For PRED and SUCC ? }ãã Span := total SHR $01;ãã While Span > 0 doã beginãã For I := Span to Pred(total) {total-1} doã beginãã For j := (I - Succ(Span) {Span+1} ) Downto 1 doã if (SortArray[j]^ <= SortArray[j+Span]^) then j := 1 elseã beginã TempPtr := SortArray[j];ã SortArray[j] := SortArray[j+Span];ã SortArray[j+Span] := TempPtr;ã end;ãã end; {For}ãã Span := Span SHR $01; { This does help speed over Span div 2! }ãã end; {WhIle}ããend;ã{------------------------------------------------------------------------}ãProcedure Do_Sorting( SortAmount : Word );ãbeginãã MakeRandomStrings(SortAmount);ãã Write('Sorting... ');ãã StartTiming;ãã PBSort(SortAmount); { Change to KDSort() to bench second sort routine }ãã StopTiming;ãã WriteLn(SortAmount:5,' Elements - ',Elapsed,' Seconds');ããend;ã{------------------------------------------------------------------------}ãVar C : Word;ããbeginãã if MaxAvail < 5000 * Sizeof(SmallArr) then Halt; { not enough memory! }ãã For C := 1 to 5000 do { pre-allocate up front }ã GetMem(SortArray[C],Sizeof(SmallArr));ããã Do_Sorting( 500 ); { Add more Do_Sorting()'s For whatever count }ã Do_Sorting( 1000 ); { you wish to test with. }ã Do_Sorting( 1500 );ã Do_Sorting( 2000 );ã Do_Sorting( 3000 );ã Do_Sorting( 5000 );ããã { Un-comment the following if you wish to see the sorted output }ãã {ã For C := 1 to 5000 do { Change 5000 to the amount you sorted }ã WriteLn( SortArray[C]^ );ããã For C := 1 to 5000 doã FreeMem(SortArray[C],Sizeof(SmallArr));ããend.ã{ãI plugged in a QuickSort algorithm in the "skeleton" Program in my previousãmessage to test perFormance. Here are the results:ãã 500 Elements - 0.1 Secondsã 1000 Elements - 0.2 Secondsã 1500 Elements - 0.4 Secondsã 2000 Elements - 0.6 Secondsã 3000 Elements - 0.9 Secondsã 5000 Elements - 1.8 SecondsããVery fast indeed. I modified the algorithm to sort only by Pointers, andãoptimized a couple spots. Again, a slight speed increase is noted using OPRO'sãExchangeLongInts() in leu of using temporary Variables in 1 spot. if you haveãOPRO, replace them and you reduce the number of instructions by 2 perãiteration.ããThis is a split-list recursive sort. Works by making a pass through the entireãArray first and moves all "small" data to the left, and all "Large" data to theãright. then it sorts each half seperately.ããTake the following code segment and "plug" it into the skeleton in my previousãmessage. then change the "PBSort(SortAmount)" to "QuickSort(SortAmount)" to runãthe tests.ããHere is the code segment:ãã{------------------------------------------------------------------------}ãProcedure QuickSort( total : Integer );ã {------------------------------------------}ã Procedure recQuickSort( L, R : Integer );ã Var K,I,J : Integer;ã T,ã Temp : Pointer;ãã beginãã if L < R thenã beginã T := SortArray[L];ã I := Pred(L);ã J := L;ã K := Succ(R);ãã While Succ(J) < K doã if SortArray[Succ(J)]^ < SmallArrPtr(T)^ thenã beginã Inc(I,1);ã Inc(J,1);ã SortArray[I] := SortArray[J];ã SortArray[j] := T;ã end {if}ã elseã if SortArray[Succ(J)]^ > SmallArrPtr(T)^ thenã beginã Dec(K,1);ã Temp := SortArray[K];ã SortArray[K] := SortArray[Succ(J)];ã SortArray[Succ(J)] := Temp;ã end {if}ã elseã Inc(J,1);ãã recQuickSort(L,I);ã recQuickSort(K,R);ãã end; { if L < R }ãã end; { Proc recQuickSort }ã {------------------------------------------}ããbeginãã recQuickSort(1,total);ããend;{QuickSort}ã{------------------------------------------------------------------------}ã 32 05-31-9307:15ALL GUY MCLOUGHLIN Various SORT Methods IMPORT 45 SҒ constã MaxItem = 30000;ããtypeã Item = word;ã Ar1K = array[1..MaxItem] of Item;ããã (***** Selection sort routine. *)ã (* *)ã procedure SelectionSort ({update} var Data : Ar1K;ã {input } ItemsToSort : word);ã varã Temp : Item;ã Min,ã Index1,ã Index2 : word;ã beginã for Index1 := 1 to pred(ItemsToSort) doã beginã Min := Index1;ã for Index2 := succ(Index1) to ItemsToSort doã if Data[Index2] < Data[Min] thenã Min := Index2;ã Temp := Data[Min];ã Data[Min] := Data[Index1];ã Data[Index1] := Tempã endã end; (* SelectionSort. *)ããã (***** Insertion sort routine. *)ã (* *)ã procedure InsertionSort ({update} var Data : Ar1K;ã {input } ItemsToSort : word);ã varã Temp : Item;ã Index1,ã Index2 : word;ã beginã for Index1 := 2 to ItemsToSort doã beginã Temp := Data[Index1];ã Index2 := Index1;ã while (Data[pred(Index2)] > Temp) doã beginã Data[Index2] := Data[pred(Index2)];ã dec(Index2)ã end;ã Data[Index2] := Tempã endã end; (* InsertionSort. *)ããã (***** Bubble sort routine. *)ã (* *)ã procedure BubbleSort ({update} var Data : Ar1K;ã {input } ItemsToSort : word);ã varã Temp : Item;ã Index1,ã Index2 : word;ã beginã for Index1 := ItemsToSort downto 1 doã for Index2 := 2 to Index1 doã if (Data[pred(Index2)] > Data[Index2]) thenã beginã Temp := Data[pred(Index2)];ã Data[pred(Index2)] := Data[Index2];ã Data[Index2] := Tempã endã end; (* BubbleSort. *)ãã (***** Shell sort routine. *)ã (* *)ã procedure ShellSort ({update} var Data : Ar1K;ã {input } ItemsToSort : word);ã varã Temp : Item;ã Index1, Index2, Index3 : word;ã beginã Index3 := 1;ã repeatã Index3 := succ(3 * Index3)ã until (Index3 > ItemsToSort);ã repeatã Index3 := (Index3 div 3);ã for Index1 := succ(Index3) to ItemsToSort doã beginã Temp := Data[Index1];ã Index2 := Index1;ã while (Data[(Index2 - Index3)] > Temp) doã beginã Data[Index2] := Data[(Index2 - Index3)];ã Index2 := (Index2 - Index3);ã if (Index2 <= Index3) thenã breakã end;ã Data[Index2] := Tempã endã until (Index3 = 1)ã end; (* ShellSort. *)ããã (***** QuickSort routine. *)ã (* *)ã procedure QuickSort({update} var Data : Ar1K;ã {input } Left,ã Right : word);ã varã Temp : Item;ã Index1, Index2, Pivot : word;ã beginã Index1 := Left;ã Index2 := Right;ã Pivot := Data[(Left + Right) div 2];ã repeatã while (Data[Index1] < Pivot) doã inc(Index1);ã while (Pivot < Data[Index2]) doã dec(Index2);ã if (Index1 <= Index2) thenã beginã Temp := Data[Index1];ã Data[Index1] := Data[Index2];ã Data[Index2] := Temp;ã inc(Index1);ã dec(Index2)ã endã until (Index1 > Index2);ã if (Left < Index2) thenã QuickSort(Data, Left, Index2);ã if (Index1 < Right) thenã QuickSort(Data, Index1, Right)ã end; (* QuickSort. *)ãã (***** Radix Exchange sort routine. *)ã (* *)ã procedure RadixExchange ({update} var Data : ar1K;ã {input } ItemsToSort,ã Left,ã Right : word;ã BitNum : shortint);ã varã Temp : Item;ã Index1, Index2 : word;ã beginã if (Right > Left) and ( BitNum >= 0) thenã beginã Index1 := Left;ã Index2 := Right;ã repeatã while (((Data[Index1] shr BitNum) AND 1) = 0)ã and (Index1 < Index2) doã inc(Index1);ã while (((Data[Index2] shr BitNum) AND 1) = 1)ã and (Index1 < Index2) doã dec(Index2);ã Temp := Data[Index1];ã Data[Index1] := Data[Index2];ã Data[Index2] := Tempã until (Index2 = Index1);ã if (((Data[Right] shr BitNum) AND 1) = 0) thenã inc(Index2);ã RadixExchange(Data, ItemsToSort, Left, pred(Index2),ã pred(BitNum));ã RadixExchange(Data, ItemsToSort, Index2, Right, pred(BitNum))ã endã end; (* RadixExchange. *)ããã(*ã - Guyã---ã þ DeLuxeý/386 1.25 #5060 þãã*) 33 08-27-9319:59ALL GREGORY P. SMITH Alpha Sorting IMPORT 30 S§ {ãGREGORY P. SMITHãã> Well, that's easier said than done ! So far I've accomplished aã> selection sort which takes about 10-15 minutes For 1000 Records, and I'mã> gonna be needin to sort about 5000 For the Programz intended applicationã> !!! Also the place that I'm writing this For has an 8088 With 640K RAMã> !!! Could you pleez tell me how to do a merge sort easier than quicksortããHere is an example followed by an exlpanation.ã}ããTypeã ListPtr = ^List;ã List = Recordã next : ListPtr; { next node }ã str : String; { data to sort }ã end;ãã{ Splits List l into two half lists, h1 & h2 }ãProcedure SplitList(l : ListPtr; Var h1, h2 : ListPtr);ãVarã listone : Boolean;ã tmp : ListPtr;ãbeginã h1 := nil;ã h2 := nil;ã listone := True; { start With first list }ã While l <> nil doã beginã tmp := l^.next; { save next node to split }ã if listone thenã begin { insert a node in the first list }ã l^.next := h1;ã h1 := l; { keep h1 at head }ã endã elseã begin { insert a node in the second list }ã l^.next := h2;ã h2 := l; { keep h2 at head }ã end;ã l := tmp; { move to next node }ã listone := not listone; { alternate lists to insert into }ã end;ãend; { SplitList }ãã{----------------- Merge Sort -------------------}ãã{ merges sorted l1 & l2 into one sorted list (alphabetically) }ãFunction MergeAlphaLists(l1, l2 : ListPtr) : ListPtr;ãVarã tmp : ListPtr; { resulting list }ãbeginã if (l1 = nil) thenã tmp := l2ã elseã if (l2 = nil) thenã tmp := l1ã elseã if l1^.str < l2^.str thenã begin { lesser node first }ã tmp := l1;ã l1 := l1^.next;ã endã elseã beginã tmp := l2;ã l2 := l2^.next;ã end;ã MergeAlphaLists := tmp; { return head of merged sorted list }ã While (l1 <> nil) and (l2 <> nil) do { traverse lists }ã if l1^.str < l2^.str thenã beginã tmp^.next := l1; { add the lesser node }ã tmp := l1; { move ahead }ã l1 := l1^.next; { next node }ã endã elseã beginã tmp^.next := l2; { add the lesser node }ã tmp := l2; { ahead 1 }ã l2 := l2^.next; { next node }ã end;ã if (l1 <> nil) thenã tmp^.next := l1 { append remaining nodes }ã elseã tmp^.next := l2;ãend; { MergeAlphaLists }ãã{ Sorts list l alphabetically }ãFunction MergeSortAlpha(l : ListPtr) : ListPtr;ãVarã sl1,ã sl2 : ListPtr;ãbeginã if l <> nil then { empty list? }ã if l^.next <> nil thenã begin { single node list? }ã inc(progress);ã SplitList(l, sl1, sl2); { split list into two halves }ã sl1 := MergeSortAlpha(sl1); { sort the first half }ã sl2 := MergeSortAlpha(sl2); { sort the second half }ã MergeSortAlpha := MergeAlphaLists(sl1, sl2) { combine sorted lists }ã endã elseã MergeSortAlpha := l { single node is already sorted }ã elseã MergeSortAlpha := nilãend;ãã{ãWhat mergesort does is to split the list into two equal halves. It thenãmergesorts each of these halves, and merges them back together. The Real workãis done in the merging step. When the lists are split down to the level ofãsingle node lists they are merged together again in the correct order. As itãpops out of the recursion the larger lists are sorted so that merging willãstill keep them in order because each node is > than the previous one. This isãprobably the most widely used sorting algorithm (don't quote me) because it isãsimple but delivers n*log(n) performance like any good algorithm would.ã}ã 34 08-27-9320:16ALL NIKLAUS WIRHT Classic Quicksort IMPORT 35 S2T {ã> Can you show me any version of thew quick sort that you may have? I'veã> never seen it and never used it before. I always used an insertion sortã> For anything that I was doing.ããHere is one (long) non-recursive version, quite fast.ã}ããTypeã _Compare = Function(Var A, B) : Boolean;{ QuickSort Calls This }ãã{ --------------------------------------------------------------- }ã{ QuickSort Algorithm by C.A.R. Hoare. Non-Recursive adaptation }ã{ from "ALGORITHMS + DATA STRUCTURES = ProgramS" by Niklaus Wirth }ã{ Prentice-Hall, 1976. Generalized For unTyped arguments. }ã{ --------------------------------------------------------------- }ããProcedure QuickSort(V : Pointer; { To Array of Records }ã Cnt : Word; { Record Count }ã Len : Word; { Record Length }ã ALessB : _Compare); { Compare Function }ããTypeã SortRec = Recordã Lt, Rt : Integerã end;ãã SortStak = Array [0..1] of SortRec;ããVarã StkT,ã StkM,ã Ki, Kj,ã M : Word;ã Rt, Lt,ã I, J : Integer;ã Ps : ^SortStak;ã Pw, Px : Pointer;ãã Procedure Push(Left, Right : Integer);ã beginã Ps^[StkT].Lt := Left;ã Ps^[StkT].Rt := Right;ã Inc(StkT);ã end;ãã Procedure Pop(Var Left, Right : Integer);ã beginã Dec(StkT);ã Left := Ps^[StkT].Lt;ã Right := Ps^[StkT].Rt;ã end;ããbegin {QSort}ã if (Cnt > 1) and (V <> Nil) Thenã beginã StkT := Cnt - 1; { Record Count - 1 }ã Lt := 1; { Safety Valve }ãã { We need a stack of Log2(n-1) entries plus 1 spare For safety }ãã Repeatã StkT := StkT SHR 1;ã Inc(Lt);ã Until StkT = 0; { 1+Log2(n-1) }ãã StkM := Lt * SizeOf(SortRec) + Len + Len; { Stack Size + 2 Records }ãã GetMem(Ps, StkM); { Allocate Memory }ãã if Ps = Nil Thenã RunError(215); { Catastrophic Error }ãã Pw := @Ps^[Lt]; { Swap Area Pointer }ã Px := Ptr(Seg(Pw^), Ofs(Pw^) + Len); { Hold Area Pointer }ãã Lt := 0;ã Rt := Cnt - 1; { Initial Partition }ãã Push(Lt, Rt); { Push Entire Table }ãã While StkT > 0 Doã begin { QuickSort Main Loop }ã Pop(Lt, Rt); { Get Next Partition }ã Repeatã I := Lt; J := Rt; { Set Work Pointers }ãã { Save Record at Partition Mid-Point in Hold Area }ã M := (LongInt(Lt) + Rt) div 2;ã Move(Ptr(Seg(V^), Ofs(V^) + M * Len)^, Px^, Len);ãã { Get Useful Offsets to speed loops }ã Ki := I * Len + Ofs(V^);ã Kj := J * Len + Ofs(V^);ãã Repeatã { Find Left-Most Entry >= Mid-Point Entry }ã While ALessB(Ptr(Seg(V^), Ki)^, Px^) Doã beginã Inc(Ki, Len);ã Inc(I)ã end;ãã { Find Right-Most Entry <= Mid-Point Entry }ã While ALessB(Px^, Ptr(Seg(V^), Kj)^) Doã beginã Dec(Kj, Len);ã Dec(J)ã end;ãã { if I > J, the partition has been exhausted }ã if I <= J Thenã beginã if I < J Then { we have two Records to exchange }ã beginã Move(Ptr(Seg(V^), Ki)^, Pw^, Len);ã Move(Ptr(Seg(V^), Kj)^, Ptr(Seg(V^), Ki)^, Len);ã Move(Pw^, Ptr(Seg(V^), Kj)^, Len);ã end;ãã Inc(I);ã Dec(J);ã Inc(Ki, Len);ã Dec(Kj, Len);ã end; { if I <= J }ã Until I > J; { Until All Swaps Done }ãã { We now have two partitions. At left are all Records }ã { < X, and at right are all Records > X. The larger }ã { partition is stacked and we re-partition the residue }ã { Until time to pop a deferred partition. }ãã if (J - Lt) < (Rt - I) Then { Right-Most Partition is Larger }ã beginã if I < Rt Thenã Push(I, Rt); { Stack Right Side }ã Rt := J; { Resume With Left }ã endã else { Left-Most Partition is Larger }ã beginã if Lt < J Thenã Push(Lt, J); { Stack Left Side }ã Lt := I; { Resume With Right }ã end;ãã Until Lt >= Rt; { QuickSort is now Complete }ã end;ã FreeMem(Ps, StkM); { Free Stack and Work Areas }ã end;ãend; {QSort}ã 35 08-27-9321:48ALL ALEXANDER CHRISTOV QSort Methods IMPORT 82 SÚ {ãALEXANDER CHRISTOVãã I don't know if code like this has been posted on this echo, but anyway hereãit goes. It implements three different versions of Qsort which so far if theãfastest sorting algorithm known. However, it is not adequate For sorting FileãRecords. I've tested the routines and have worked With them For quite a While,ãbut don't trust me 😎 Murphy never sleeps 8-)ã}ããUnit SORT;ã{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}ã{ Purpose : Unit that implements a generic QSort(), similar to }ã{ the one in the standard C library. }ã{ Author : Alexander Christov }ã{ Notes : Very instructive on the use of Pointers in TP. }ã{ }ã{ Use freely. }ã{ }ã{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}ãInterfaceããType CmpFunc=Function(El1,El2:Pointer):Boolean;ããProcedure QSort(Base:Pointer;Elements,Size:Word;GT:CmpFunc);ãã{ Base - Pointer to the first elementã Elements - Number of elementsã Size - Size of an element in Bytes. Use SizeOf() if in doubtã GT - A Function of Type CmpFunc that compares the elements pointedã to by the first and the second arguments and returns Trueã if the first is greater than the second. GT = Greater Thanã 8-)ã}ãã{ Some commonly used CmpFunc }ããFunction bGT(El1,El2:Pointer):Boolean; { Compares ^Byte }ãFunction wGT(El1,El2:Pointer):Boolean; { Compares ^Word }ãFunction lGT(El1,El2:Pointer):Boolean; { Compares ^LongInt }ãFunction rGT(El1,El2:Pointer):Boolean; { Compares ^Real }ããImplementationã{$F+}ããType Dummy=Array[0..0] of Byte;ã pDummy=^Dummy;ããã{ Recursive Implementation }ããProcedure _Sort(Base:Pointer;L,R,Size:Word;GT:CmpFunc);ãVar I,J:Integer;ãVar X:Pointer;ã Procedure SwapElements(El1,El2:Word);ã Var Tmp:Pointer;ã beginã GetMem(Tmp,Size);ã Move(pDummy(Base)^[El1*Size],Tmp^,Size);ã Move(pDummy(Base)^[El2*Size],pDummy(Base)^[El1*Size],Size);ã Move(Tmp^,pDummy(Base)^[El2*Size],Size);ã FreeMem(Tmp,Size);ã end;ãbeginã I:=L;ã J:=R;ã GetMem(X,Size);ã Move(pDummy(Base)^[((L+R) div 2)*Size],X^,Size);ã Repeatã While GT(X,@pDummy(Base)^[I*Size]) do INC(I);ã While GT(@pDummy(Base)^[J*Size],X) do DEC(J);ã if I<=J then beginã if I<>J then SwapElements(I,J);ã INC(I);ã DEC(J);ã end;ã Until I>J;ã FreeMem(X,Size);ã if LpByte(El2)^);ãend;ããFunction wGT(El1,El2:Pointer):Boolean;ãType pWord=^Word;ãbeginã wGt:=(pWord(El1)^>pWord(El2)^);ãend;ããFunction lGT(El1,El2:Pointer):Boolean;ãType pLongInt=^LongInt;ãbeginã lGt:=(pLongInt(El1)^>pLongInt(El2)^);ãend;ããFunction rGT(El1,El2:Pointer):Boolean;ãType pReal=^Real;ãbeginã rGt:=(pReal(El1)^>pReal(El2)^);ãend;ããend.ãããã{$A-,B-,D+,E-,F+,G+,I-,L+,N-,O+,P+,Q-,R-,S-,T-,V-,X+,Y+}ã{ I don't know which settings are Really necessary For this Unit, but sinceã I always work With the above, I'm including them to make sure the Unitã compiles in your computer. The only critical ones (I Think) are R- and F+ã}ãUnit SORT;ã{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}ã{ Purpose: Unit that implements a generic QSort, similar to the }ã{ one in the standard C library, but a lot more general }ã{ This new version allows ordering of almost anything, }ã{ even structures whose elements are not contiguous in memory }ã{ or have strange mutual dependancies that don't allow "happy }ã{ swapping". Obviously, this version is slower than the }ã{ previous one. if you won't be sorting Linked Lists or }ã{ Collections, use the previous one. }ã{ Author : Alexander Christov }ã{ Notes : Very instructive on the use of Pointers in TP. }ã{ This version does not limit the number of elements to }ã{ 65535 since the need not be contiguous. }ã{ }ã{ Use freely. }ã{ }ã{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}ãInterfaceããType CmpFunc=Function(El1,El2:Pointer):Boolean;ã AddrFunc=Function(Base:Pointer;Size,N:LongInt):Pointer;ã SwapProc=Procedure(El1,El2:Pointer;Size:LongInt);ããProcedure QSort(Base:Pointer; { Pointer to the first element.ã if the user Writes his own GT, Addr andã Swap, this isn't Really necessary.ã }ã Elements:LongInt; { Total number of elements }ã Size:Word; { Size of an element in Bytes }ã GT:CmpFunc; { Comparing Function }ã Addr:AddrFunc; { Addressing Function }ã Swap:SwapProc); { Swapping Function }ãã{ã GT - A funcion of Type CmpFunc that compares the elements pointedã to by its first and second arguments, and returns True if theã first element is Greater Than the second one. This Unit definesã some commonly used CmpFuncs:ã bGT - Compares Bytesã wGT - Compares Wordsã lGT - Compares LongIntsã rGT - Compares Realsãã Addr - A Function that receives the index of an element and mustã return a Pointer to it.ã This Unit defines the Functionã LinearAddrã which can be used whenever the elements are locatedã contiguously in memory.ãã Swap - A Procedure that swaps the elements pointed by its arguments.ã DirectSwapã is defined in the Unit, which can be used whenever the elementsã are mutually independent or no external processes are neededã when swapping two elementsã}ãã{ Commonly used CmpFuncs }ããFunction bGT(El1,El2:Pointer):Boolean; { Compares ^Byte }ãFunction wGT(El1,El2:Pointer):Boolean; { Compares ^Word }ãFunction lGT(El1,El2:Pointer):Boolean; { Compares ^LongInt }ãFunction rGT(El1,El2:Pointer):Boolean; { Compares ^Real }ããFunction LinearAddr(Base:Pointer;Size,N:LongInt):Pointer;ãProcedure DirectSwap(El1,El2:Pointer;Size:LongInt);ããImplementationã{$F+}ããType Dummy=Array[0..0] of Byte;ã pDummy=^Dummy;ãããVar X,Middle:Pointer;ããProcedureã_Sort(Base:Pointer;L,R:LongInt;Size:Word;GT:CmpFunc;Addr:AddrFunc;Swap:SwapProcã);ãVar I,J:LongInt;ãbeginã I:=L;ã J:=R;ã Move(Addr(Base,Size,(L+R) div 2)^,Middle^,Size);ã Repeatã While GT(Middle,Addr(Base,Size,I)) do INC(I);ã While GT(Addr(Base,Size,J),Middle) do DEC(J);ã if I<=J then beginã if I<>J then Swap(Addr(Base,Size,I),Addr(Base,Size,J),Size);ã INC(I);ã DEC(J);ã end;ã Until I>J;ã if LpByte(El2)^);ãend;ããFunction wGT(El1,El2:Pointer):Boolean;ãType pWord=^Word;ãbeginã wGt:=(pWord(El1)^>pWord(El2)^);ãend;ããFunction lGT(El1,El2:Pointer):Boolean;ãType pLongInt=^LongInt;ãbeginã lGt:=(pLongInt(El1)^>pLongInt(El2)^);ãend;ããFunction rGT(El1,El2:Pointer):Boolean;ãType pReal=^Real;ãbeginã rGt:=(pReal(El1)^>pReal(El2)^);ãend;ãã{ Linear Addressing }ããFunction LinearAddr;ãbeginã LinearAddr:=@pdummy(Base)^[N*Size];ãend;ãã{ Direct swapping of elements. With the use of Addr() it is quite moreã legible 😎 }ããProcedure DirectSwap;ãVar Tmp:Pointer;ãbeginã GetMem(Tmp,Size);ã Move(El1^,Tmp^,Size);ã Move(El2^,El1^,Size);ã Move(Tmp^,El2^,Size);ã FreeMem(Tmp,Size);ãend;ããend.ããã{ And finally a specific version of QSort() written in Assembler. It isã non recursive and sorts Arrays of Words of up to 16383 elements (sinceã it Uses the addresses of the elements rather than their indexes, and sinceã SizeOf(Word)=2 -> 16384*2=32768 "=" -32768, and the routine Uses signedã comparisons between adresses.ã On my 386/33 it sorts 10 times an Array of 10000 Words in 3.6 sec, Whileã the first QSort() does the same in 46 sec.ãã Must be called Withãã Qsort(Pointer to the first element, 0, elements-1)ãã Use freely. if you include the source directly in your Program, creditã must be given.ã}ããProcedure QSort(Base:Pointer;L,R:Word);Assembler;ãVar TmpL,TmpR,TmpDI:Word;ãAsmã xor AX,AXã PUSH AXã PUSH AX { 0 0 will act as a flag on the stack indicating that no more }ã PUSH R { (L,R) pairs need to be sorted }ã PUSH Lã@MainLoop:ã LES DI,Baseã MOV TmpDI,DIã xor SI,SIã MOV BX,DIã POP AX { AX<-L }ã MOV TmpL,AXã MOV SI,AXã SHL AX,1ã ADD DI,AXã POP AX { AX<-R }ã MOV TmpR,AXã and AX,AX { R can be never 0 except if this is the (0,0) flag }ã JZ @endã ADD SI,AXã SHL AX,1ã ADD BX,AXã and SI,$FFFEã ADD SI,TmpDIãã { ES:DI -> Element[I] (L)ã ES:BX -> Element[J] (R)ã ES:SI -> Element[(L+R) div 2]ã }ãã MOV AX,ES:[SI]ã@Loop1:ã MOV CX,ES:[DI]ã CMP AX,CXã JNA @Loop2ã ADD DI,2ã JMP @Loop1ã@Loop2:ã MOV CX,ES:[BX]ã CMP CX,AXã JNA @Checkã SUB BX,2ã JMP @Loop2ã@Check:ã CMP DI,BXã JG @Cont1ã MOV CX,ES:[DI]ã MOV DX,ES:[BX]ã MOV ES:[DI],DXã MOV ES:[BX],CXã ADD DI,2ã SUB BX,2ã CMP DI,BXã JNG @Loop1ãã@Cont1:ã SUB DI,TmpDIã SAR DI,1 { DI - I }ã SUB BX,TmpDIã SAR BX,1 { BX - J }ã CMP DI,TmpRã JGE @Cont2ã PUSH TmpR { Ii0 then Swap(i0^,m0^,ElementGroesse);ã inc(i,i0)ã end; (* WHILE i *)ã EXIT:ã end; (* E_Sort *)ãã procedure Sort(von, bis : word); (* Rekursive Quicksort *)ã label EXIT;ã var i, j : word;ã beginã if bis-von<6 then begin E_Sort(von,bis); goto EXIT end;ã i:=von; j:=bis; m0:=Element((i+j) SHR 1);ã move(m0^,Mitte^,ElementGroesse); i0:=Element(i); j0:=Element(j);ã while i<=j do beginã while SortKleiner(i0^,Mitte^) do inc(i,i0);ã while SortKleiner(Mitte^,j0^) do dec(j,j0);ã if i<=j then beginã if i<>j then Swap(i0^,j0^,ElementGroesse);ã inc(i,i0); dec(j,j0)ã end (* if i<=j *)ã end; (* while i<=j *)ã if bis-i Can someone show me an example of how to properly dispose of a linked list?ããI was just as bad when I started in February. 🙂 Anyhow, use mark andãrelease. They're 2 new things I've discovered and love much more thanãdispose or freemem. Use MARK(ram) where VAR RAM:POINTER {an untypedãpointer}. This will save the state of the heap. NOW, when you are done,ãdo this: release(ram) and it's back the way it was. No freemem, no dispose,ãjust RELEASE! I REALLY love it. 🙂 Need to allocate and deallocate someãtimes in between the beginning and the end? Use more untyped pointers (eg.ãRAM2, RAM3, etc.) and you get the picture. Gotta love it. 🙂 Look for aãmessage from me in here about linked list sorting. I wrote an entireãprogram that does this (to replace DOS's sort. Mine's faster and can useãmore than 64k RAM). Here it is. Some of it is maybe too hard for you butãthen you can ignore that part and just see how I used mark and release.ã*)ãã{$A+,B-,D-,E-,F-,G-,I-,L-,N-,O-,R-,S-,V-,X-}ã{$M 8192, 0, 655360}ããtypeã pstring = ^string;ã prec = ^rec;ãã rec = recordã s : pstring;ã n : prec;ã end;ããVarã dash : byte;ã err,ã max, c : word;ã list,ã list2,ã node,ã node2 : prec;ã ram,ã ram2,ã ram3 : pointer;ã tf : text;ã f : file;ããprocedure dodash;ãbeginã case dash ofã 1 : write('-');ã 2 : write('\');ã 3 : write('|');ã 4 : write('/');ã end;ã write(#8, ' ', #8);ã dash := dash mod 4 + 1;ãend;ããprocedure TheEnd;ãbeginã writeln('Assassin Technologies, NetRunner.');ã halt(err);ãend;ããprocedure showhelp;ãbeginã writeln('Heavy duty sorter. Syntax: NSORT .');ã writeln('Exit codes: 0-normal; 1-not enough RAM; 2-can''t open infile;');ã writeln('3-outfile can''t be created');ã halt;ãend;ããprocedure noram;ãbeginã release(ram);ã assign(f, paramstr(1));ã writeln('Not enough RAM. ', memavail div 1024, 'k; file: ', filesize(f));ã err := 1;ã halt;ãend;ããprocedure newnode(var pntr : prec);ãbeginã if sizeof(prec) > maxavail thenã beginã close(tf);ã noram;ã end;ã new(pntr);ã dodash;ã pntr^.n := nil;ãend;ããprocedure getln(var ln : pstring);ãvarã line : string;ã size : word;ãbeginã readln(tf, line);ã size := succ(length(line));ã if size > maxavail thenã noram;ã getmem(ln, size);ã move(line, ln^, succ(length(line)));ã dodash;ãend;ããbeginã err := 0;ã exitproc := @TheEnd;ã if paramcount = 0 thenã showhelp;ã assign(tf, paramstr(1));ã reset(tf);ãã if ioresult <> 0 thenã beginã writeln('Can''t open "', paramstr(1), '".');ã err := 2;ã halt;ã end;ãã mark(ram);ã newnode(list);ãã if not eof(tf) thenã beginã getln(list^.s);ã node := list;ãã while not eof(tf) doã beginã newnode(node^.n);ã node := node^.n;ã getln(node^.s);ã end;ãã close(tf);ã newnode(list2);ã list2^.n := list;ã list := list^.n;ã list2^.n^.n := nil;ãã while list <> nil doã beginã dodash;ã node := list;ã list := list^.n;ã node2 := list2;ãã while (node2^.n <> nil) and (node^.s^ > node2^.n^.s^) doã node2 := node2^.n;ãã node^.n := node2^.n;ã node2^.n := node;ã dodash;ã end;ã list := list2^.n;ãã assign(tf, paramstr(2));ã rewrite(tf);ã if ioresult <> 0 thenã beginã writeln('Can''t create "', paramstr(2), '"');ã err := 3;ã end;ãã node := list;ã while node <> nil doã beginã writeln(tf, node^.s^);ã node := node^.n;ã dodash;ã end;ã writeln;ã close(tf);ã release(ram);ã end;ãend.ã 39 11-02-9306:22ALL IAN LIN Quick Sort using LINK IMPORT 21 S»b {ãIAN LINããMy pride and joy, this baby sorts FAST! This is For anyone who wants anãexample of code For sorting linked lists.ã}ãã{$A+,B-,D+,E-,F-,G+,I-,L+,N-,O-,R-,S+,V-,X-}ã{$M 4096,0,655360}ããProcedure Theend; {could you think of a better name???}ãbeginã Writeln('Assassin Technologies, NetRunner.');ã {members: Ian Lin, Martin Young, William Parslow, Scott Rogers; just a newã Programming group, that's all.}ã halt; {duh, kinda obvious you need to end the Program. 🙂 }ãend;ããTypeã prec = ^rec;ã dType = String[96]; {put what you want here, it's fast anyhow}ã rec = Recordã d : dType;ã n : prec; {"next" field"}ã end;ããVarã max, c : Word; {maximum # of elements; Counter}ã list,ã list2,ã node,ã node2 : prec; {first and second lists, temporary Pointers to nodes in the lists}ã ram : Pointer; {save heap state For use With mark/release}ããbeginã max := memavail div sizeof(dType); {this takes too long but is THE maximum}ã max := 675; {I picked this at random--it sorts in 2 seconds or so}ã Exitproc := @Theend; {just to be fancy}ã randomize;ã mark(ram);ã new(list); {create list}ã list^.d := Char(random(10) + 48); {put something in it}ã node := list;ã For c := 2 to max doã beginã new(node^.n);ã node := node^.n;ã node^.n := nil;ã node^.d := Char(random(10) + 48);ã end;ãã new(list2); {begin NEW sorted list}ã list2^.n := list; {steal the first node of list For list2}ã list := list^.n;ã list2^.n^.n := nil;ã While list <> nil doã begin {now steal 'em all and add them in order}ã node := list; {point node to first node in LIST}ã list := list^.n; {advance LIST Pointer one node, first node is now seperate}ã node2 := list2; {ready to use NODE2 to find the correct entry point}ã While (node2^.n <> nil) and (node^.d > node2^.n^.d) doã node2 := node2^.n; {advance NODE2 as needed Until it marks theã right place For NODE to be inserted}ã node^.n := node2^.n;{insert NODE into the new list, in the correct order}ã node2^.n := node; {connect node to the previous nodes in new list, if any}ã end;ã list := list2^.n; {point LIST back to the top of the list, now in order}ãã node := list; {the rest is just to display it}ã Write('List: ');ã While node <> nil doã begin {as usual (at least With me), NIL is the end}ã Write(node^.d);ã node := node^.n;ã end;ã Writeln;ã release(ram); {give all heap RAM back}ãend.ã 40 11-21-9309:46ALL BOB SWART QUICK SORTER IMPORT 20 S™ {ãFrom: BOB SWARTãSubj: Sorting...ã---------------------------------------------------------------------------ã Does anyone know of a VERY fast way to sort something? I wouldã really like to view some source code on this if possible. I need toã sort over 1200 strings, and do it rather quickly.ãã Try this, it uses a TStringCollection...ã}ãã{$IFDEF VER70}ã{$A+,B-,D-,E-,F-,G-,I-,L-,N-,O-,P-,Q-,R-,S+,T-,V-,X-}ã{$ELSE}ã{$A+,B-,D-,E-,F-,G-,I-,L-,N-,O-,R-,S+,V-,X-}ã{$ENDIF}ã{$M 16384,0,655360}ã{ã Sorteer 3.0ã Borland Pascal (Objects) 7.0.ã Copr. (c) 9-29-1993 DwarFools & Consultancy drs. Robert E. Swartã P.O. box 799ã 5702 NP Helmondã The Netherlandsã Code size: 5824 Bytesã Data size: 1254 Bytesã .EXE size: 4971 Bytesã ----------------------------------------------------------------ã Authors: Bob Swart (2:281/256.12)ã Hans van der Veeke (2:282/517.2)ã}ãuses {$IFDEF WINDOWS}ã WinCrt,ã {$ENDIF}ã Objects;ããTypeã PStr = ^TStr;ã TStr = object(TObject)ã StrName: PString;ã constructor Init(_StrName: String);ã end {TStr};ãã constructor TStr.Init(_StrName: String);ã beginã TObject.Init;ã StrName := NewStr(_StrName)ã end {Init};ããTypeã PStrColl = ^TStrColl;ã TStrColl = object(TStringCollection)ã function KeyOf(Item: Pointer): Pointer; virtual;ã end {TStrColl};ãã function TStrColl.KeyOf(Item: Pointer): Pointer;ã beginã KeyOf := PStr(Item)^.StrNameã end {KeyOf};ããvar StrColl: PStrColl;ã Line: String;ã F: Text;ãbeginã writeln('Sorteer - Sort strings (c) 1993 by Bob Swart & Hans van der Veeke.'#13#10);ã if ParamCount = 0 thenã beginã writeln('Usage: Sorteer [ASCII file to be sorted]');ã Halt(0)ã end;ã Assign(F,ParamStr(1));ã reset(F);ã if IOResult <> 0 thenã beginã writeln('Error - could not open file ',ParamStr(1));ã Halt(1)ã end;ã StrColl := New(PStrColl,Init(1000,500));ã StrColl^.Duplicates := True; { make False for NO duplicates }ã while not Eof(F) doã beginã readln(F,Line);ã if Length(Line) > 0 then StrColl^.Insert(New(PStr, Init(Line)))ã end;ã Close(F);ã while StrColl^.Count > 0 doã beginã writeln(PStr(StrColl^.At(0))^.StrName^); { print first element }ã StrColl^.AtFree(0); { delete and dispose first element StrColl }ã endãend.ã 41 11-26-9317:00ALL SWAG SUPPORT TEAM Full featured Sort Unit IMPORT 83 SÆ¢ 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.ã 42 11-26-9317:46ALL SWAG SUPPORT GROUP Complete Sorting Unit IMPORT 53 SA¥ UNIT Sort;ãã { These sort routines are for arrays of Integers. Count is the maximum }ã { number of items in the array. }ãã{****************************************************************************}ã INTERFACEã{****************************************************************************}ãFUNCTION BinarySearch (VAR A; X : Integer; Count : Integer) : Integer;ãPROCEDURE BubbleSort (VAR A; Count : Integer); {slow}ãPROCEDURE CombSort (VAR A; Count : Integer);ãPROCEDURE QuickSort (VAR A; Count : Integer); {fast}ãFUNCTION SequentialSearch (VAR A; X : Integer; Count : Integer) : Integer;ãPROCEDURE ShellSort (VAR A; Count : Integer); {moderate}ã{****************************************************************************}ã IMPLEMENTATIONã{****************************************************************************}ãTYPEã SortArray = ARRAY[0..0] OF Integer;ã{****************************************************************************}ã{ }ã{ Local Procedures and Functions }ã{ }ã{****************************************************************************}ãPROCEDURE Swap (VAR A, B : Integer);ãVAR C : Integer;ãBEGINã C := A;ã A := B;ã B := C;ãEND;ã{****************************************************************************}ã{ }ã{ Global Procedures and Functions }ã{ }ã{****************************************************************************}ãFUNCTION BinarySearch (VAR A; X : Integer; Count : Integer) : Integer;ãVAR High, Low, Mid : Integer;ãBEGINã Low := 1;ã High := Count;ã WHILE High >= Low DOã BEGINã Mid := Trunc(High + Low) DIV 2;ã IF X > SortArray(A)[mid]ã THEN Low := Mid + 1ã ELSE IF X < SortArray(A)[Mid]ã THEN High := Mid - 1ã ELSE High := -1;ã END;ã IF High = -1ã THEN BinarySearch := Midã ELSE BinarySearch := 0;ã END;ã{****************************************************************************}ãPROCEDURE BubbleSort (VAR A; Count : Integer);ãVAR i, j : Integer;ãBEGINã FOR i := 2 TO Count DOã FOR j := Count DOWNTO i DOã IF SortArray(A)[j-1] > SortArray(A)[j]ã THEN Swap(SortArray(A)[j],SortArray(A)[j-1]);ãEND;ã{****************************************************************************}ãPROCEDURE CombSort (VAR A; Count : Integer);ã { 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). }ã { The combsort does not slow down under *any* circumstances. In fact, on }ã { partially sorted lists (including *reverse* sorted lists) it speeds up.}ãCONST ShrinkFactor = 1.3; { Optimal shrink factor ... }ãVARã Gap, i, Temp : Integer;ã Finished : Boolean;ãBEGINã Gap := Trunc(ShrinkFactor);ã REPEATã Finished := TRUE;ã Gap := Trunc(Gap/ShrinkFactor);ã IF Gap < 1ã THEN { Gap must *never* be less than 1 } Gap := 1ã ELSE IF Gap IN [9,10]ã THEN { Optimises the sort ... } Gap := 11;ã FOR i := 1 TO (Count - Gap) DOã IF SortArray(A)[i] < SortArray(A)[i+gap]ã THEN BEGINã Swap(SortArray(A)[i],SortArray(A)[i + Gap]);ã Finished := FALSE;ã END;ã UNTIL (Gap = 1) AND Finished;ãEND;ã{****************************************************************************}ãPROCEDURE QuickSort (VAR A; Count : Integer);ã {**************************************************************************}ã PROCEDURE PartialSort(LowerBoundary, UpperBoundary : Integer; VAR A);ã VAR ii, l1, r1, i, j, k : Integer;ã BEGINã k := (SortArray(A)[LowerBoundary] + SortArray(A)[UpperBoundary]) DIV 2;ã i := LowerBoundary;ã j := UpperBoundary;ã REPEATã WHILE SortArray(A)[i] < k DO Inc(i);ã WHILE k < SortArray(A)[j] DO Dec(j);ã IF i <= jã THEN BEGINã Swap(SortArray(A)[i],SortArray(A)[j]);ã Inc(i);ã Dec(j);ã END;ã UNTIL i > j;ã IF LowerBoundary < jã THEN PartialSort(LowerBoundary,j,A);ã IF i < UpperBoundaryã THEN PartialSort(UpperBoundary,i,A);ã END;ã {*************************************************************************}ãBEGINã PartialSort(1,Count,A);ãEND;ã{****************************************************************************}ãFUNCTION SequentialSearch (VAR A; X : Integer; Count : Integer) : Integer;ãVAR i : Integer;ãBEGINã FOR i := 1 TO Count DOã IF X = Sortarray(A)[i]ã THEN BEGINã SequentialSearch := i;ã Exit;ã END;ã SequentialSearch := 0;ãEND;ã{****************************************************************************}ãPROCEDURE ShellSort (VAR A; Count : Integer);ãVAR Gap, i, j, k : Integer;ãBEGINã Gap := Count DIV 2;ã WHILE (gap > 0) DOã BEGINã FOR i := (Gap + 1) TO Count DOã BEGINã j := i - Gap;ã WHILE (j > 0) DOã BEGINã k := j + gap;ã IF (SortArray(A)[j] <= SortArray(A)[k])ã THEN j := 0ã ELSE Swap(SortArray(A)[j],SortArray(A)[k]);ã j := j - Gap;ã END;ã END;ã Gap := Gap DIV 2;ã END;ãEND;ã{*****************************************************************************}ãEND.ã 43 01-27-9412:19ALL BJORN FELTEN Generic QSort IMPORT 28 S§é {ã> Could someone please post some code on using a quickã> sort to sort an array of strings?ãã I can do even better than that. I can give you some code on a general qsortãroutine that works like in C (if you're familiar with that). I. e. you can sortãany type of arrays, if only you supply the correct compare function. Hereãgoes...ã}ããunit QSort;ã{*********************************************************ã * QSORT.PAS *ã * C-like QuickSort implementation *ã * Written 931118 by Bj”rn Felten @ 2:203/208 *ã * After an idea by Pontus Rydin *ã *********************************************************}ãinterfaceãtype CompFunc = function(Item1, Item2 : word) : integer;ããprocedure QuickSort(ã var Data;ã{An array. Must be [0..Count-1] and not [1..Count] or anything else! }ã Count,ã{Number of elements in the array}ã Size : word;ã{Size in bytes of a single element -- e.g. 2 for integers or words,ã4 for longints, 256 for strings and so on }ã Compare : CompFunc);ã{The function that decides which element is "greater" or "less". Mustãreturn an integer that's < 0 if the first element is less, 0 if they'reãequal and > 0 if the first element is greater. A simple Compare forãwords can look like this:ãã function WordCompare(Item1, Item2: word): integer;ã beginã WordCompare := MyArray[Item1] - MyArray[Item2]ã end;ããNB. It's not the =indices= that shall be compared, it's the elements thatãthe supplied indices points to! Very important to remember!ãAlso note that the array may be sorted in descending order just byãmeans of a simple swap of Item1 and Item2 in the example.}ããimplementationãprocedure QuickSort;ãã procedure Swap(Item1, Item2 : word);ã var P1, P2 : ^byte; I : word;ã beginã if Item1 <> Item2 thenã beginã I := Size;ã P1 := @Data; inc(P1, Item1 * Size);ã P2 := @Data; inc(P2, Item2 * Size);ã asmã mov cx,I { Size }ã les di,P1ã push dsã lds si,P2ã @L:ã mov ah,es:[di]ã lodsbã mov [si-1],ahã stosbã loop @Lã pop dsã endã endã end;ãã procedure Sort(Left, Right: integer);ã var i, j, x, y : integer;ã beginã i := Left; j := Right; x := (Left+Right) div 2;ã repeatã while compare(i, x) < 0 do inc(i);ã while compare(x, j) < 0 do dec(j);ã if i <= j thenã beginã swap(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;ããbegin Sort(0, Count) end;ããend. { of unit }ãã{ A simple testprogram can look like this: }ããprogram QS_Test; {Test QuickSort   la C}ãuses qsort;ãvar v: array[0..9999] of word;ã i: word;ãã{$F+} {Must be compiled as FAR calls!}ãfunction cmpr(a, b: word): integer;ãbegin cmpr := v[a] - v[b] end;ããfunction cmpr2(a, b: word): integer;ãbegin cmpr2 := v[b] - v[a] end;ã{$F-}ããbeginã randomize;ã for i := 0 to 9999 do v[i] := random(20000);ã quicksort(v, 10000, 2, cmpr); {in order lo to hi}ã quicksort(v, 10000, 2, cmpr2); {we now have a sorted list, sort it inã {reverse -- nasty for qsort!}ã quicksort(v, 10000, 2, cmpr); {and reverse again}ã quicksort(v, 10000, 2, cmpr); {sort a sorted list -- also not very popular}ãend.ãã 44 02-03-9416:23ALL JAMES SURLES Sorting a Text File IMPORT 22 SD? {ã---------------------------------------------------------------------------ã > What I want to do here, is take a textfile with about 1,000-10,000ã > lines in it, go and read a string starting at the XPosition of 13, goingã > until XPosition of 38 on each line of the textfile. Then, putã > everything in memory if possible, and then sort all of the strings onã > the screen by ABC order. Can somebody help me out with a few hints, orã > some code? Either reply here, or send me Netmail @ 1:105/60.77.ãThis will take some modification by you, but it should not be too much trouble.ã This is a sort based on a file of records, but the necessary modificationsãshould not be too difficult.}ãã{$N+,E+}ãprogram DiskSort;ãusesã Crt,ã Dos;ãtypeã String72 = string[72];ã ElementType = String72;ã ElementFile = file of ElementType;ãvarã A : ElementFile;ã Temp : String72;ã I : LongInt;ãfunction Precedes (A, B : ElementType) : boolean;ã begin {Precedes}ã if A < B thenã Precedes := Trueã elseã Precedes := False;ã end; {Precedes}ãprocedure Swap (var A : ElementFile; Index1, Index2 : Integer; Temp1, Temp2 :ãElementType);ã begin {Swap}ã Seek (A, Index1);ã Write (A, Temp2);ã Seek (A, Index2);ã Write (A, Temp1);ã end; {Swap}ãprocedure ShellSortInsertion (var A : ElementFile; NumVals : Integer);ãvarã EleDist : Integer;ã Temp1, Temp2 : ElementType;ã procedure SegmentedInsertion (var A : ElementFile; N, K : Integer);ã varã J, L : Integer;ã begin {SegmentedInsertion}ã for L := K + 1 to N doã beginã J := L - K;ã while J > 0 doã beginã Seek (A, J+K-1);ã Read (A, Temp1);ã Seek (A, J-1);ã Read (A, Temp2);ã if Precedes (Temp1, Temp2) thenã beginã Swap (A, J+K-1, J-1, Temp1, Temp2);ã J := J - K;ã endã elseã J := 0;ã end;ã end;ã end; {SegmentedInsertion}ãbegin {ShellSortInsertion}ã EleDist := NumVals div 2;ã while EleDist > 0 doã beginã SegmentedInsertion (A, NumVals, EleDist);ã EleDist := EleDist div 2;ã end;ãend; {ShellSortInsertion}ãbeginã ClrScr;ã Assign (A, 'Strings.dat');ã Reset (A);ãã ShellSortInsertion (A, FileSize(A));ããend.ã 45 02-05-9407:57ALL BRIAN RICHARDSON Turbovison Text Sort IMPORT 10 S´ß {ã Here is an example of a TStringCollection decendant that sorts theã strings by the 30th character and beyond. The defaultã TStringCollection sorts from the first character. }ãã uses Objects;ãã typeã PMyCollection = ^TMyCollection;ã TMyCollection = object(TStringCollection)ã function Compare(Key1, Key2 : Pointer); virtual;ã end;ãã function TMyCollection.Compare(Key1, Key2 : Pointer); virtual;ã var s, t : string;ã beginã { This is where you would sort two strings Compare mustã return -1 if Key1 < Key2, 0 if Key1 = Key2, andã 1 if Key1 > Key2 }ã s := Copy(Key1^, 30, Length(Key1^) - 30);ã t := Copy(Key2^, 30, Length(Key2^) - 30);ã if s < t then Compare := -1 elseã if s = t then Compare := 0 elseã Compare := 1;ã end;ãã var P : PMyCollection;ã beginã P := New(PMyCollection, Init(10, 10));ã ReadLineFromFile;ã Insert(NewStr(LineFromFile));ã for x := 0 to P^.Count - 1 doã writeln(PString(P^.At(x))^);ã Dispose(P, Done);ã end;ã 46 05-25-9408:19ALL TED HANSEN Re: Sorting an Array of SWAG9405 22 S (*ã -=> Quoting Tim Benoit to All <=-ãã TB> I am having a bit of difficulty figuring out how to sort anã TB> array of records by numerical or alphabetical order.ã TB> I need all the information that goes with thatã TB> specific Record to stay with it...ãã This example uses a modified bubblesort algorithm, not real fast butãfairly easy to follow. You may want to use a faster sort procedure butãthe basic idea is to examine the data in your selected sortãfield (RecArray[i].variable) but do the sort on the wholeãrecord (RecArray[i]):ããeg:ã Varãã Buffer : Rec;ãã If RecArray[3].Number1 > RecArray[4].Number1 then { sort }ãã Begin { interchange RecArray[3] and RecArray[4] }ã Buffer := RecArray[3];ã RecArray[3] := RecArray[4];ã RecArray[4] := Bufferã End;ããBubblesort makes multiple passes moving data only one place per pass.ãThis example is similar but uses only one pass.ã*)ããProgram Modsort;ããuses Crt; {only needed for clrscr}ããConstã max = 10; {max number of records}ããTypeã fieldtype = string[2];ã datatype = recordã rec1 : fieldtype;ã rec2 : fieldtype;ã end;ãVarã data : array [1..max] of datatype;ã i,j : byte;ããProcedure interchange(r,l:datatype);ããVarã buffer : datatype;ããBeginã buffer := r;ã data[i] := l;ã data[i+1] := buffer;ã dec(i);ãEnd;ããProcedure sort(j : byte); {j is the selected sort field number}ããVarã field : array [1..2] of fieldtype;ããBeginã i := 1;ãã While i < max doã Beginã Case j ofã 1 : Beginã field[1] := data[i].rec1;ã field[2] := data[i+1].rec1;ã End;ã 2 : Beginã field[1] := data[i].rec2;ã field[2] := data[i+1].rec2;ã End;ã End;ãã If field[1] > field[2] thenã Interchange(data[i], data[i+1])ã Elseã Inc(i);ã End;ãEnd;ããBegin {main}ããClrscr;ãWriteln('UNSORTED :');ãFor i := 1 to max do {make up random array of alphas}ã Beginã j := random(26);ã data[i].rec1 := chr(j+65);ã Write(data[i].rec1);ã j := random(26);ã Data[i].rec2 := chr(j+65);ã Writeln(',',data[i].rec2);ã End;ããWrite('Sort on which field? ');ãReadln(j);ãSort(j);ãWriteln('SORTED ON FIELD: ',j);ããFor i := 1 to max doã Beginã Write(data[i].rec1);ã Writeln(',',data[i].rec2);ã End;ããEnd.ã 47 05-25-9408:20ALL MIKE COPELAND Sorting SWAG9405 11 S {ã DR> Does anyone have a good routine to sort a string array intoã DR> alphabetical order - I really only know how to do a bubbleã DR> sort, and that's a bit slow for >1000 in the array...ã DR> Preferably written in standard Pascal, as I would like toã DR> understand it,ãã Here's the conventional QuickSort (which is also included in the fullãTP/BP packages as examples):ã}ããvar T : string; { swap variable }ã GUESS : array[1..1000] of ^string; { pointer array of strings }ãprocedure L_HSORT (LEFT,RIGHT : word); { Lo-Hi QuickSort }ãvar LOWER,UPPER,MIDDLE : word;ã PIVOT : string;ãbeginã LOWER := LEFT; UPPER := RIGHT; MIDDLE := (LEFT+RIGHT) div 2;ã PIVOT := GUESS[MIDDLE]^;ã repeatã while GUESS[LOWER]^ < PIVOT do Inc(LOWER);ã while PIVOT < GUESS[UPPER]^ do Dec(UPPER);ã if LOWER <= UPPER thenã beginã T := GUESS[LOWER]^; GUESS[LOWER]^ := GUESS[UPPER]^;ã GUESS[UPPER]^ := T; Inc (LOWER); Dec (UPPER);ã end;ã until LOWER > UPPER;ã if LEFT < UPPER then L_HSORT (LEFT, UPPER);ã if LOWER < RIGHT then L_HSORT (LOWER, RIGHT)ãend; { L_HSORT }ã 48 05-25-9408:23ALL LARRY HADLEY Sort Object SWAG9405 38 S {ããPeterborough, Ontario, CANADAããHi !ãã If any of you boys have been reading BYTE magazine, you may haveã noticed an article in the Dec/93 issue on Directory objects (inã C++ however). I was keenly interested in this article, because itã showed a quick and easy way to handle directory recursion - whichã was necessary for a project I was doing.ãã While the complete code listings weren't given, they were in C soã I couldn't use them directly anyways, so I just wrote my ownã object in TP. (Works great, btw)ãã I've decided to wake this conference up a bit so I'm going to postã this stuff over the next couple of days. The first installment isã the SORT unit which implements a binary-tree sorting object forã the sort method of the directory object. This object is completelyã re-usable and extendable (designed so from the ground up) andã helps demonstrate more uses for OOP.ã----------------------------------------------------------------------ã}ãUnit SORT;ããINTERFACEããTYPEã comparefunc = function(d1, d2 :pointer):integer;ã { function returns sort value for data }ã ptree = ^treenode;ã treenode = recordã data :pointer;ã left,ã right :ptree;ã end;ã { ****** Abstract sort object ******ã Must be inheritedã }ã pSortTree = ^oSortTree;ã oSortTree = OBJECTã root :ptree;ã comp :comparefunc;ãã constructor Init(cf :comparefunc);ã destructor Done;ãã procedure InsertNode(n :pointer);ã procedure DeleteNode(var Node); virtual; { abstract }ã function ReadLeftNode:pointer;ã end;ããIMPLEMENTATIONããconstructor oSortTree.Init(cf :comparefunc);ãbeginã FillChar(self, SizeOf(self), #0); { zero out object data }ã comp := cf; { set "compare" function to user defined far-local }ãend;ããdestructor oSortTree.Done;ãã procedure disposetree(var t :ptree);ã beginã if t=NIL thenã EXIT;ã disposetree(t^.left);ã disposetree(t^.right);ã DeleteNode(t^.data);ã dispose(t);ã end;ããbeginã disposetree(root);ãend;ããprocedure oSortTree.InsertNode(n :pointer);ã { Insert the data pointer in sorted order, as defined by theã passed "compare" functionã }ã procedure recursetree(var t :ptree);ãã procedure PutNode(node :ptree);ã beginã node^.right := NIL;ã node^.left := NIL;ã node^.data := n;ã end;ãã beginã if comp(n, t^.data)>0 thenã beginã if t^.right<>NIL thenã recursetree(t^.right)ã elseã beginã New(t^.right);ã PutNode(t^.right);ã end;ã endã elseã beginã if t^.left<>NIL thenã recursetree(t^.left)ã elseã beginã New(t^.left);ã PutNode(t^.left);ã end;ã end;ã end;ããbeginã if n<>NIL thenã if root=NIL thenã beginã New(root);ã root^.left := NIL;ã root^.right := NIL;ã root^.data := n;ã endã elseã recursetree(root);ãend;ããprocedure oSortTree.DeleteNode(var Node);ã { The calling code must define how to dispose of the data fieldã by inheritance }ãbeginã Halt(255); {abstract method}ãend;ããfunction oSortTree.ReadLeftNode:pointer;ã { This function is intended to be called one-at-a-time to recoverã data in sorted order. The data is returned as an untypedã pointer. It is assumed that the calling code will type theã pointer as required. The data pointer is set to NIL after beingã passed to the caller. }ãvarã ln :pointer;ãã procedure recurseTree(var t :pTree;var result :pointer);ã beginã if t^.left<>NIL thenã beginã recurseTree(t^.left, result);ã if result=NIL thenã beginã result := t^.data;ã t^.data := NIL;ã end;ã endã elseã beginã if t^.data<>NIL thenã beginã result := t^.data;ã t^.data := NIL;ã endã elseã if t^.right<>NIL thenã beginã recurseTree(t^.right, result);ã if result=NIL thenã beginã dispose(t);ã t := NIL;ã endã endã elseã beginã dispose(t);ã t := NIL;ã result := NIL;ã end;ã end;ã end;ããbeginã if root<>NIL thenã beginã recurseTree(root, ln);ã ReadLeftNode := ln;ã endã elseã ReadLeftNode := NIL;ãend;ããEND.ã