View Full Version : Replacing ARRAY SORT
MikeTrader
10-08-2009, 00:32
powerbasics ARRAY SORT is a convenient way sort arrays of any data type. It also allows you to tag a second array of any kind to be sorted. Under the hood there is a lot going on and it took many years to implement.
When converting PB code to another language, this functionality needs to be replaced. This thread accomplishes that task by using a string sorting algorithm posted by Stan Durham for string arrays and Quick sort for integer arrays. Both are as fast or faster than the PB implementation and the code is in a high level language for easy porting.
Under the hood, PB selects sorting algorithms for the data type. Since the data type of an array is held in the array descriptor table (and only available using the keyword ARRAYATTR) a seperate function must be used for each datatype. Most real world implementations will be complete with three, STRING, LONG, QUAD, as most everything can be squeezed into these (floats can be multiplied by 1000 for example and fed through sorting as integers)
Strings are by far the tricky one. The challenge is to not only implement a fast method, but give it traction meaning tag an array, allow case to be ignored and sort ascend/descend with a call that is not overly long and combersome to use. For strings the criteria are:
Handle any length String including Zero length
ASCENDING/DESCENDING order
TAG an ARRAY of pointers
Select FIRST & LAST elements TO SORT
Equivalent speed to PBs SORT ARRAY
Zero or 1+ based Arrays
A generic CALL that is user friendly
High level language compatible (no ASM or PB keywords)
The Algorithm sorts the handles the PB Dynamic BStr Strings.
A Dynamic String array in powerbasic is an array of pointers to BStr Strings.
pArr = VARPTR(b(1)) will return the address of the first element of this array
pStr = @pArr will return a pointer to the actual BStr STRING
@pStr will return the STRING contents.
This is equivelent to the powerbasic reserved word pStr = STRPTR(b(1))
But these two operations are not equivelent.
When a zero length string is assigned with b(x) = "" powerbasic does not request memory
for a non existant string, so the pointer is set to zero (NULL Pointer).
To compensate for this, STRPTR returns a pointer to a real memory location (one address is used for all NULL strings) to avoid a GPF when dereferencing a NULL pointer. Unfortunatly this is not the case when when you do the two step de-referencing.
As this algorithm derives part of its speed by sorting the pointers to the strings and swapping them
(not swapping the actual strings themselves) it uses the two step deferencing to find the character
at each position in each string. When a zero length string is encountered a GPF would occur.
To make this implementation work, a conditional statement must check each pointer.
In testing with 1300 first names, it performed a little slower 5400 Clks than PBs 3400.
This is because there are many slots of two names that are swapped unecessarily. This
is a product of the method the algorithm uses
Additional testing would be required to determine if additional conditional statements
would make a significant difference to this.
But when 2000, random strings up to 32 Chars are used it performed 2x faster 1700 Clks than PBs 3500
Undoubtably PB uses ASM which would speed this algorithm up a little, but the purpose is to use
a high level language to replace the PB ARRAY SORT functionality and thus convert PB code to
another language (with friendly support).
First = First element in the array = LBOUND()
Last = Last element in the array = UBOUND()
In this example code, a UDT is sorted as the TAG array. Notice the Tagged pointer array
is declared AS MyTYPE PTR. This is tricky, because PB does not allow an array of pointers
to be passed BYREF for some reason. To get around this, we use the same trick of passing
a pointer to the array table (an array of DWORDS).
Then we use DIM AT to create and array in the SUB that can be used to access the
pointers as though we had sent them BYREF.
This was found to be 2x faster when sorting 1m LONG values with QuickSort rather than using
pointer offsets @pArr[i].
MikeTrader
10-08-2009, 00:38
Quick Sort implementation:
Sorting an array of 100k LONGs, PB avg time is 1650 Clks/String, QuickSort is 1450 Clks/String
A LONG/QUAD Array sorting algorithm designed for:
Handle all values including Zero
ASCENDING/DESCENDING order
TAG an ARRAY of pointers
Select FIRST & LAST elements TO SORT
Equivelent speed to PBs SORT ARRAY
Zero or 1+ based Arrays
A generic CALL that is user friendly
High level language compatible (no ASM or PB keywords)
Since PB does not allow passing a pointer array BYREF as an argument,
a pointer to the array is passed and then DIM AT is used to create an
array of the pointers within the Function.
This function was found to be 2x faster (when sorting 1m elements) using
an array of pointers rather than pointer offsets ie @pArr[i].
' Sorting an array of 100k LONGs, PB avg time is 1650 Clks/String, QuickSort is 1450 Clks/String
' A littler faster WITHOUT the benfit of ASM.
' http://www.cse.iitk.ac.in/users/dsrkg/cs210/applets/sortingII/quickSort/quickSort.html
' http://en.wikipedia.org/wiki/Quick_sort
#If 0
A LONG/QUAD Array sorting algorithm designed for:
Handle all values including Zero
ASCENDING/DESCENDING order
TAG an ARRAY of pointers
Select FIRST & LAST elements TO SORT
Equivelent speed to PBs SORT ARRAY
Zero or 1+ based Arrays
A generic CALL that is user friendly
High level language compatible (no ASM or PB keywords)
Since PB does not allow passing a pointer array BYREF as an argument,
a pointer to the array is passed and then DIM AT is used to create an
array of the pointers within the Function.
This function was found to be 2x faster (when sorting 1m elements) using
an array of pointers rather than pointer offsets ie @pArr[i].
#EndIf
' Mike Trader 2009
#COMPILE EXE "QwikSort.exe"
#DIM ALL
#INCLUDE "WIN32API.INC"
GLOBAL hDbg, TotSwaps AS LONG
TYPE MyTYPE
Rand AS LONG
Num AS LONG
Beg AS LONG
sName AS STRING * 32
END TYPE
GLOBAL MaxIx AS LONG
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤'
SUB time_stamp_count(tick AS QUAD) ' CPU Clock count Charles E V Pegge
' ' approx because it is not a serialised instruction
' ' it may execute before or after other instructions in the pipeline.
! mov ebx,tick ' var address where count is to be stored.
! db &h0f,&h31 ' RDTSC read time-stamp counter into edx:eax hi lo.
! mov [ebx],eax ' save low order 4 bytes.
! mov [ebx+4],edx ' save high order 4 bytes.
END SUB
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤'
SUB QSortQUAD( BYVAL pArr AS DWORD, BYVAL nElem AS LONG, OPT BYVAL pTag AS DWORD, BYVAL DescendFlag AS LONG )
LOCAL i, j, StkIx, First, Last AS LONG
LOCAL Temp AS QUAD '
i = 128 * (1+(Last\1000000)) ' 128 per 1m elements should be more than double what's needed
DIM QStack(i) AS LONG '
First = 1
Last = First + nElem
IF pTag = 0 THEN ' Create a Dummy array
DIM Tg(First TO Last) AS LONG
pTag = VARPTR(Tg(0)) ' ALL Zero Based Arrays from here on
END IF
DIM Arr(First TO Last) AS LONG AT pArr
DIM Tag(First TO Last) AS DWORD AT pTag
DO
DO
Temp = Arr((Last+First)\2) ' seek midpoint
i = First
j = Last '
IF DescendFlag = 0 THEN
DO '
WHILE Arr(i) < Temp
INCR i
WEND '
WHILE Arr(j) > Temp
DECR j
WEND '
IF i > j THEN EXIT DO
IF i < j THEN SWAP Arr(i), Arr(j) : SWAP Tag(i), Tag(j) ' : INCR TotSwaps
INCR i
DECR j
LOOP WHILE i <= j
ELSE ' Descending
DO
WHILE Arr(i) > Temp
INCR i
WEND
WHILE Arr(j) < Temp
DECR j
WEND
IF i > j THEN EXIT DO
IF i < j THEN SWAP Arr(i), Arr(j) : SWAP Tag(i), Tag(j) ' : INCR TotSwaps
INCR i
DECR j
LOOP WHILE i <= j
END IF '
IF i < Last THEN ' Done
QStack(StkIx) = i ' Push i
QStack(StkIx + 1) = Last ' Push Last
StkIx = StkIx + 2 '
END IF
Last = j
LOOP WHILE First < Last
IF StkIx = 0 THEN EXIT DO
StkIx = StkIx - 2 '
First = QStack(StkIx) ' Pop First
Last = QStack(StkIx + 1) ' Pop Last
LOOP
END SUB
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤'
SUB QSortLONG( BYVAL pArr AS DWORD, BYVAL nElem AS LONG, OPT BYVAL pTag AS DWORD, BYVAL DescendFlag AS LONG )
LOCAL i, j, StkIx, First, Last AS LONG
LOCAL Temp AS LONG '
i = 128 * (1+(Last\1000000)) ' 128 per 1m elements should be more than double what's needed
DIM QStack(i) AS LONG '
First = 1
Last = First + nElem
IF pTag = 0 THEN ' Create a Dummy array
DIM Tg(First TO Last) AS LONG
pTag = VARPTR(Tg(0)) ' ALL Zero Based Arrays from here on
END IF
DIM Arr(First TO Last) AS LONG AT pArr
DIM Tag(First TO Last) AS DWORD AT pTag
DO
DO
Temp = Arr((Last+First)\2) ' seek midpoint
i = First
j = Last '
IF DescendFlag = 0 THEN
DO ' PRINT #hDbg, "A: Temp=" + STR$(Temp)
WHILE Arr(i) < Temp
INCR i
WEND '
WHILE Arr(j) > Temp
DECR j
WEND ' PRINT #hDbg, "B: j=" + STR$(j)
IF i > j THEN EXIT DO
IF i < j THEN SWAP Arr(i), Arr(j) : SWAP Tag(i), Tag(j) ' : INCR TotSwaps
INCR i
DECR j
LOOP WHILE i <= j
ELSE ' Descending
DO
WHILE Arr(i) > Temp
INCR i
WEND
WHILE Arr(j) < Temp
DECR j
WEND
IF i > j THEN EXIT DO
IF i < j THEN SWAP Arr(i), Arr(j) : SWAP Tag(i), Tag(j) ' : INCR TotSwaps
INCR i
DECR j
LOOP WHILE i <= j
END IF '
IF i < Last THEN ' Done
QStack(StkIx) = i ' Push i
QStack(StkIx + 1) = Last ' Push Last
StkIx = StkIx + 2 ' IF StkIx > MaxIx THEN MaxIx = StkIx : PRINT #hDbg, "A MaxIx=" + STR$(MaxIx)
END IF
Last = j
LOOP WHILE First < Last
IF StkIx = 0 THEN EXIT DO
StkIx = StkIx - 2 ' IF StkIx > MaxIx THEN MaxIx = StkIx : PRINT #hDbg, "B MaxIx=" + STR$(MaxIx)
First = QStack(StkIx) ' Pop First
Last = QStack(StkIx + 1) ' Pop Last
LOOP
END SUB
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤'
FUNCTION PBMAIN()
hDbg = FREEFILE : OPEN "QwikSort_Debug.txt" FOR OUTPUT LOCK SHARED AS hDbg
PRINT #hDbg, "Time=" + TIME$ + ", Date=" + DATE$
LOCAL i, j, RetVal, First, Last, TotElem, Count, Descending AS LONG
LOCAL s AS STRING
LOCAL pStr AS STRING PTR
LOCAL sTxt() AS STRING
LOCAL cBeg, cEnd AS QUAD ' for time stamp, measuring cpu Clks
LOCAL LongVal AS LONG
First = 1
Last = 99000
DIM aI(Last) AS LONG '
DIM bI(Last) AS LONG '
DIM aQ(Last) AS QUAD ' LONG
DIM bQ(Last) AS QUAD ' LONG
DIM DataType(Last) AS MyTYPE
DIM pData(Last) AS MyTYPE PTR ' Cannot pass an array of pointers BYVAL with PB
TotElem = Last - First + 1 '
PRINT #hDbg, "TotElem=" + STR$(TotElem)
'- Fill Arrays
Count = 0
FOR i = First TO Last
INCR Count
LongVal = RND(-2147483648, 2147483647) ' LongVal = RND(-254, 255)
aI(i) = LongVal
bI(i) = LongVal '
aQ(i) = LongVal
bQ(i) = LongVal '
DataType(i).Rand = LongVal
DataType(i).Num = i
DataType(i).sName = STRING$(3, STR$(LongVal))
pData(i) = VARPTR(DataType(i))
IF i < 100 THEN PRINT #hDbg, STR$(i) + " " + STR$(@pData(i).Rand) + " " + STR$(@pData(i).Num)
NEXT i
s = s + "TotElem="+STR$(TotElem) + $CRLF + $CRLF
time_stamp_count(cBeg) ' measuring cpu Clks. The overhead just for making this call is about 25 clocks
ARRAY SORT aI(First)' , DESCEND
' ARRAY SORT aQ(First)' , DESCEND
time_stamp_count(cEnd) ' measuring cpu Clks. The overhead just for making this call is about 25 clocks
s = s + "PB ARRAY SORT Clks="+STR$( (cEnd-cBeg)\TotElem ) + $CRLF
Descending = 0
TotSwaps = 0
time_stamp_count(cBeg) ' measuring cpu Clks. The overhead just for making this call is about 25 clocks
' CALL QSortLONG( VARPTR(bI(First)), Last-First ) ' Simple Call
CALL QSortLONG( VARPTR(bI(First)), Last-First, VARPTR(pData(First)), Descending ) ' Descending
time_stamp_count(cEnd) ' measuring cpu Clks. The overhead just for making this call is about 25 clocks
s = s + "QSortLONG Clks="+STR$( (cEnd-cBeg)\TotElem ) + $CRLF
s = s + "TotSwaps="+STR$(TotSwaps) + ", MaxIx=" + STR$(MaxIx) + $CRLF
' TotSwaps = 0
' time_stamp_count(cBeg) ' measuring cpu Clks. The overhead just for making this call is about 25 clocks
' CALL QSortQUAD( VARPTR(bQ(First)), Last-First, VARPTR(pData(First)), Descending ) ' Descending
' time_stamp_count(cEnd) ' measuring cpu Clks. The overhead just for making this call is about 25 clocks
' s = s + "QSortQUAD Clks="+STR$( (cEnd-cBeg)\TotElem ) + $CRLF
' s = s + "TotSwaps="+STR$(TotSwaps) + ", MaxIx=" + STR$(MaxIx) + $CRLF
PRINT #hDbg, $CRLF + " New Order"
FOR i = First TO Last
IF i < 100 THEN PRINT #hDbg, STR$(i)+ " "+STR$(bI(i))+ " "+STR$(@pData(i).Rand)+ " "+STR$(@pData(i).Num)
NEXT i
PRINT #hDbg, "Compare sort results"
'- Compare sort results
FOR i = First TO Last
IF aI(i) <> bI(i) THEN
MSGBOX "out of order at element" + STR$(i)
EXIT FOR
END IF
NEXT i
'PRINT #hDbg, s
' FOR i = First TO Last
'PRINT #hDbg, ""
'PRINT #hDbg, "PB: " + STR$(aI(i))
'PRINT #hDbg, "QS: " + TRIM$(@pData(i).sName)
'IF i > 100 THEN EXIT FOR
' NEXT i
MSGBOX s,64,"QSort"
END FUNCTION
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤'
That's really great that the PowerBasic programmers are adding to thinBasic. Thanks Mike.
MikeTrader
10-08-2009, 13:21
This version, is based on Stan's re-write and is 5x faster than PB's SORT ARRAY
Sorting an array of 100k strings of random length (0-255 Chars), PB avg time is 9550 Clks/String, Sidewinder is 2040 Clks/String
' Mike Trader 2009 (based on work by Stan Durham)
' This version requires a little more memory (12*nElem bytes)
' Sorting an array of 100k strings of random length (0-255 Chars), PB avg time is 9550 Clks/String, Sidewinder is 2040 Clks/String
' Thats 5x faster WITHOUT the benfit of ASM.
' Can be called with:
' CALL SWSort( VARPTR(b(First)), Last-First ) ' Simplist call
' or with all the options:
' CALL SWSort( VARPTR(b(First)), Last-First, VARPTR(pData(First)), CaseIgnore, Descending ) ' Full Call
'Where:
' First = First element in the ARRAY = LBOUND()
' Last = Last element in the ARRAY = UBOUND()
#If 0
A LONG/QUAD ARRAY sorting algorithm designed FOR:
Handle any length String including Zero length
ASCENDING/DESCENDING order
TAG an ARRAY of pointers
Select FIRST & LAST elements TO SORT
Equivelent speed to PBs SORT ARRAY
Zero or 1+ based Arrays
A generic CALL that is user friendly
High level language compatible (no ASM or PB keywords)
PB does not allow passing arrays BYREF as an argument,
The function would be 2x faster using an array of pointers
rather than pointer offsets ie @pArr[i].
#EndIf
#COMPILE EXE "Sidewinder.exe"
#DIM ALL
#INCLUDE "WIN32API.INC"
GLOBAL hDbg AS LONG
TYPE BucketInfoTYPE ' For Sidewinder
BukNum(255) AS LONG
BktBeg(255) AS LONG
BktEnd(255) AS LONG
LastBktNum AS LONG
LastBktBeg AS LONG
END TYPE
TYPE MyTYPE ' An example UDT to Tag Sort
Rand AS LONG
Num AS LONG
Beg AS LONG
sName AS STRING * 255
END TYPE
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤'
SUB time_stamp_count(tick AS QUAD) ' CPU Clock count Charles E V Pegge
'---------------------------'
' ' approx because it is not a serialised instruction
' ' it may execute before or after other instructions
' ' in the pipeline.
! mov ebx,tick ' var address where count is to be stored.
! db &h0f,&h31 ' RDTSC read time-stamp counter into edx:eax hi lo.
! mov [ebx],eax ' save low order 4 bytes.
! mov [ebx+4],edx ' save high order 4 bytes.
'---------------------------'
END SUB
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
FUNCTION ReadTextFile( sPathnFile AS STRING, sTxt() AS STRING ) AS LONG ' Zero Based Array
LOCAL hFile, TotRec, Count AS LONG
hFile = FREEFILE ' nElements = LOF(hFile) \ SIZEOF (MyUDT)
OPEN sPathnFile FOR INPUT AS #hFile ' LEN = SIZEOF(UDT(0)) ' path and file in element 2
IF ERR THEN
CLOSE hFile
FUNCTION = -ERR
EXIT FUNCTION
END IF
FILESCAN #hFile, RECORDS TO TotRec
REDIM sTxt(TotRec)
Count = 0
WHILE NOT EOF(hFile)
INCR Count
LINE INPUT #hFile, sTxt(Count)
WEND ' PRINT #hDbg, "TotRec="+STR$(TotRec) + ", Count="+STR$(Count)
CLOSE hFile
FUNCTION = Count
END FUNCTION
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤'
SUB SidewinderRecur( BYVAL pArr AS LONG PTR, _ ' Pointer to String array
BYVAL pBuf AS LONG PTR, _ ' Pointer to Long array for string sorting
BYVAL pTag AS LONG PTR, _ ' Pointer to Tagged Pointer array
BYVAL pTuf AS LONG PTR, _ ' Pointer to Long array for Tagged Pointer array sorting
BYVAL pChr AS LONG PTR, _ ' Pointer to Array of character values
BYVAL Pos AS LONG, _ ' Character position in the string
BYVAL First AS LONG, _ ' First element in the String Array to sort
BYVAL Last AS LONG, _ ' Last element in the String Array to sort
BYVAL CsIg AS LONG, _ ' Ignore Case Flag
BYVAL Desc AS LONG ) ' Sort Descending Flag
LOCAL i, bVal AS LONG
LOCAL pByt AS BYTE PTR
LOCAL BI AS BucketInfoTYPE ' Faster than DIM each seperatly
' DIM Arr(First TO Last) AS QUAD AT pArr + 4*First ' PB cannot pass an array of pointers BYREF
' DIM Buf(First TO Last) AS QUAD AT pBuf + 4*First
' DIM Tag(First TO Last) AS DWORD AT pTag + 4*First
' DIM Tuf(First TO Last) AS QUAD AT pTuf + 4*First
' DIM Chr(First TO Last) AS QUAD AT pChr + 4*First
INCR Pos
BI.LastBktBeg = First
BI.LastBktNum = 0
IF Desc THEN ' Descending
'- Count occurence of each bVal
FOR i = First TO Last
pByt = @pArr[i] ' Arr(i)
@pChr[i] = @pByt[Pos] ' PRINT #hDbg, "i=" + STR$(i) + ", bVal=" + STR$(@pChr[i])
IF CsIg AND @pChr[i] > 96 AND @pChr[i] < 123 THEN @pChr[i] = @pChr[i] - 32
INCR BI.BukNum(@pChr[i])
NEXT i
'- Determine the start pos/ Size of each bucket at the current character Pos
FOR bVal = 255 TO 0 STEP -1
IF BI.BukNum(bVal) THEN
BI.BktBeg(bVal) = BI.LastBktBeg + BI.LastBktNum
BI.BktEnd(bVal) = BI.BktBeg(bVal) - 1
BI.LastBktBeg = BI.BktBeg(bVal)
BI.LastBktNum = BI.BukNum(bVal)
END IF
NEXT bVal
ELSE ' Ascending
FOR i = Last TO First STEP -1
pByt = @pArr[i]
@pChr[i] = @pByt[Pos]
IF CsIg AND @pChr[i] > 96 AND @pChr[i] < 123 THEN @pChr[i] = @pChr[i] - 32
INCR BI.BukNum(@pChr[i])
NEXT i
FOR bVal = 0 TO 255
IF BI.BukNum(bVal) THEN
BI.BktBeg(bVal) = BI.LastBktBeg + BI.LastBktNum
BI.BktEnd(bVal) = BI.BktBeg(bVal) - 1
BI.LastBktBeg = BI.BktBeg(bVal)
BI.LastBktNum = BI.BukNum(bVal)
END IF
NEXT bVal
END IF
'- Place each string in proper bucket
FOR i = First TO Last
INCR BI.BktEnd(@pChr[i]) ' Chr(i)
@pBuf[BI.BktEnd(@pChr[i])] = @pArr[i] ' Arr(i)
@pTuf[BI.BktEnd(@pChr[i])] = @pTag[i] ' Tag(i)
NEXT i
'- Copy sorted order to original array
FOR i = First TO Last
@pArr[i] = @pBuf[i] ' Buf(i)
@pTag[i] = @pTuf[i] ' Tuf(i)
NEXT i ' PRINT #hDbg, "Round"+STR$(Pos+1)+" Completed --------" + $CRLF
'- Recursively sort each slot of elements for each Pos
IF Desc THEN ' Descending
FOR bVal = 1 TO 255
IF BI.BukNum(bVal) > 1 THEN CALL SidewinderRecur( pArr, pBuf, pTag, pTuf, pChr, Pos, BI.BktBeg(bVal), BI.BktEnd(bVal), CsIg, Desc )
NEXT bVal
ELSE ' Ascending
FOR bVal = 255 TO 1 STEP - 1
IF BI.BukNum(bVal) > 1 THEN CALL SidewinderRecur( pArr, pBuf, pTag, pTuf, pChr, Pos, BI.BktBeg(bVal), BI.BktEnd(bVal), CsIg, Desc )
NEXT bVal
END IF
END SUB
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤'
SUB SWSort( BYVAL pArr AS DWORD PTR, BYVAL nElem AS LONG, _
OPT BYVAL pTag AS DWORD PTR, BYVAL CsIg AS LONG, BYVAL Desc AS LONG )
LOCAL i, First AS LONG
IF pTag = 0 THEN ' Create a Dummy array
DIM Tag(nElem) AS LONG
pTag = VARPTR(Tag(0)) ' ALL Zero Based Arrays from here on
END IF
' DIM Tag(nElem) AS DWORD AT pTag ' PB cannot pass an array of pointers BYREF
' DIM Arr(nElem) AS DWORD AT pArr
IF Desc THEN
FOR i = nElem TO 0 STEP -1
IF @pArr[i] = 0 THEN ' Swap any NULL strings to far left
IF i < nElem THEN SWAP @pArr[i], @pArr[nElem] : SWAP @pTag[i], @pTag[nElem]
DECR nElem
END IF
NEXT i ' PRINT #hDbg, "First=" + STR$(First)
ELSE
FOR i = 0 TO nElem
IF @pArr[i] = 0 THEN ' Swap any NULL strings to far left
IF i > First THEN SWAP @pArr[i], @pArr[First] : SWAP @pTag[i], @pTag[First]
INCR First
END IF
NEXT i ' PRINT #hDbg, "First=" + STR$(First)
END IF
DIM Chr(nElem) AS LONG ' Holds a Character from each string
DIM Buf(nElem) AS LONG ' Buffer for sorting Stings
DIM Tuf(nElem) AS LONG ' Buffer for sorting Tagged Pointers
CALL SidewinderRecur( pArr, VARPTR(Buf(0)), pTag, VARPTR(Tuf(0)), VARPTR(Chr(0)), -1, First, nElem, CsIg, Desc )
END SUB
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤'
FUNCTION PBMAIN()
LOCAL i, j, RetVal, CaseIgnore, Descending AS LONG
LOCAL First, Last, TotElem, Count AS LONG
LOCAL shortestString, longestString, lowestChar, highestChar AS LONG
LOCAL cBeg, cEnd AS QUAD ' for time stamp, measuring cpu Clks
LOCAL s AS STRING
LOCAL sTxt() AS STRING
LOCAL a() AS STRING
LOCAL b() AS STRING
hDbg = FREEFILE : OPEN "Sidewinder_Debug.txt" FOR OUTPUT LOCK SHARED AS hDbg
PRINT #hDbg, "Time=" + TIME$ + ", Date=" + DATE$
'=========
First = 1
DIM sTxt(First)
TotElem = ReadTextFile( "UCaseNames.csv", sTxt() ) ' base 1
PRINT #hDbg, "Read "+STR$(TotElem)+" Names"
Last = TotElem
Last = 99000
DIM a(Last) AS STRING '
DIM b(Last) AS STRING '
DIM DataType(Last) AS MyTYPE
DIM pData(Last) AS MyTYPE PTR ' Cannot pass an array of pointers BYVAL with PB
'- Xfer random length strings
' FOR i = First TO Last
'IF i = 4 THEN sTxt(i) = "" ' Test NULL string handling
'IF i = 9 THEN sTxt(i) = ""
' a(i) = sTxt(i)
' b(i) = sTxt(i) '
' DataType(i).sName = sTxt(i)
' DataType(i).Rand = RND(-2147483648, 2147483647)
' DataType(i).Num = i
' pData(i) = VARPTR(DataType(i))
'IF i < 100 THEN PRINT #hDbg, STR$(i) + STR$(@pData(i).Num) + " " + STR$(STRPTR(b(i))) + " >" + TRIM$(@pData(i).sName) + "< "
' NEXT '
'PRINT #hDbg, " --------" + $CRLF
'==========
shortestString = 0 ' shortest random string
longestString = 255 ' longest random string
lowestChar = 32 ' ASC() smallest random character
highestChar = 126 ' ASC() largest random character
'- Make a series of random length strings
FOR i = First TO Last
s = ""
FOR j = First TO RND(shortestString, longestString)
s = s + CHR$(RND(lowestChar, highestChar))
NEXT j
a(i) = s
b(i) = s
DataType(i).sName = s
DataType(i).Rand = RND(-2147483648, 2147483647)
DataType(i).Num = i
pData(i) = VARPTR(DataType(i))
IF i < 100 THEN PRINT #hDbg, STR$(i) + " Len=" + STR$(LEN(TRIM$(@pData(i).sName))) + " pData=" + STR$(pData(i)) + " >" + TRIM$(@pData(i).sName) + "< " + STR$(@pData(i).Num)
NEXT i
'==========
s = ""
time_stamp_count(cBeg) ' measuring CPU Clks. The overhead just for making this call is about 25 clocks
ARRAY SORT a(First) ', DESCEND
time_stamp_count(cEnd) ' measuring CPU Clks. The overhead just for making this call is about 25 clocks
s = s + "ARRAY SORT Clks="+STR$( (cEnd-cBeg)\Last ) + $CRLF
CaseIgnore = 0
Descending = 0
time_stamp_count(cBeg) ' measuring CPU Clks. The overhead just for making this call is about 25 clocks
' CALL SWSort( VARPTR(b(First)), Last-First ) ' Simplist call w/no tag array
CALL SWSort( VARPTR(b(First)), Last-First, VARPTR(pData(First)), CaseIgnore, Descending ) ' Full Call
time_stamp_count(cEnd) ' Measuring CPU Clks. The overhead just for making this call is about 25 clocks
s = s + "SideWinder Clks="+STR$( (cEnd-cBeg)\Last ) + $CRLF + $CRLF
'=========
'- Compare Sort Results
' PRINT #hDbg, ""
' FOR i = First TO Last
' IF TRIM$(a(i)) <> TRIM$(b(i)) THEN
' PRINT #hDbg, STR$(i) + $TAB + ">" +TRIM$(a(i)) + "< >" + TRIM$(b(i)) + "<--- out of order"
' ELSE
' IF i < 100 THEN PRINT #hDbg, STR$(i) + $TAB + a(i)
' END IF
' NEXT i
PRINT #hDbg, ""
FOR i = First TO Last
IF TRIM$(a(i)) <> TRIM$(@pData(i).sName) THEN
PRINT #hDbg, STR$(i)
PRINT #hDbg, ">" +TRIM$(a(i)) + "<"
PRINT #hDbg, ">" +TRIM$(@pData(i).sName) + "<--- Bad Match"
MSGBOX STR$(i)+"Sorted Element out of order" : EXIT FOR
ELSE
IF i < 100 THEN PRINT #hDbg, STR$(i) + $TAB + a(i)
END IF
NEXT i
PRINT #hDbg, s
MSGBOX s,64,STR$(Last-First)+" Random Length STRINGs"
END FUNCTION
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤'
Charles Pegge
13-08-2009, 11:05
Hi Mike,
An efficient general purpose sorting algorithm requires about n*log2(n) cycles to sort an array of n elements. So for 1024 elements: 20x1024 cycles are required. for 2048 it would be 21x2048 cycles, and so forth.
Taking the overall sorting time and dividing through by this factor will give you the time per cycle and this is a fair predictor of performance over a wide range of sample sizes. In your example of 2550 clocks for 100k strings, we can divide this figure by 17 to get an estimate of the per cycle clock count. Which yield a figure of 150 clocks. Similarly in your previous posting: 2000 strings in 1700 clocks per string when divided through by 11 yields 154 clocks per cycle.
I hope this will be a useful benchmark.
Charles
John Spikowski
14-08-2009, 09:23
Charles,
I bet some of that sort code you did for the word count code challenge (http://www.allbasic.info/forum/index.php?topic=688.msg2266#msg2266) could help with Mike's project. (if Oxygen is planed to be used)
John
Charles Pegge
14-08-2009, 10:44
Yes John,
Here is an example of the merge sort algorithm that I used in your code challenge. This is not the fastest version but it is almost entirely Basic.
It uses a callback to a comparator function which decides which 1 of 2 indices points to the lower ordered element. This separates the sorting algorigm from the comparator function completely, allowing any type of data and comparison procedure to be used.
This merge sort shuttles an array of indexes back and forth successively sorting groups of 2 4 8 16 32 .. elements each time until all the element indexes are within 1 fully sorted group.
Charles
'======
' SORTM
'######
'
' Indexer using a MergeSort and Callbacks
'
'
' Charles E V Pegge
' 9 Aug 2009
' The sortm function is written in Oxygen, and based on a MergeSort
' which is one of the most efficient sort algorithms available, requiring
' n/2 * log2(n) comparisons.
'
' For example, A database of 1 meg data elements would require 10 meg comparisons
' whereas a simple pick-one sort would take n*n/2 = 500 gig comparisons.
'
' The sortm function requires twice the workspace of the final index, since it
' shuttles the indices from one buffer to the other during the merge sort process.
'
' This function uses a callback Chooser function to make each comparison, so
' it can be applied to any type of data on any criterion. The output is
' an array of 4 byte integers indexing the array of data elements.
' The index array must first be initialised with a set of indices, one for each
' data element. The merge sort function then rearranges the order of these indices
' in the array.
uses "oxygen","file"
'-----------------------
'NUMBER OF WORDS TO SORT
'=======================
dim sz as long=10000
'-------------------------
'FOR INDEX AND DATA ARRAYS
'=========================
dim ri(sz*2+1) as long ' must be twice the number of data elements
dim rs(sz+1) as string ' test sample of random string data
'---------------
'FOR SAMPLE DATA
'===============
dim i,j as long
dim r as long
dim rst as string
'---------------------------------
'GENERATE RANDOM STRINGS AND INDEX
'=================================
for i=1 to sz
ri(i)=i ' this is our initial index for each element in the string array.
rst=string$(16," ")
for j= 1 to 16 ' generate a string of 16 random uppercase characters
r=rnd(1)*25+65
mid$(rst,j)=chr$(r)
next
rs(i)=rst ' store a random string in each data element in the string array
'print rst
next
dim src as string
src="
#basic
'-------------------------------------
' CALLBACK FUNCTION TO MAKE THE CHOICE
'=====================================
' choose between first and second or abort the sorting process
' this is called by the bisort function
'
' Parameters:
' first index number for data element
' second index number for data element
'
' Return:
' 1 for first choice 2 for second choice 0 to abort the bisort function
'
'----------------------------------------------------------------
function ChooseWhich (byval first, byval second) as long callback
'================================================================
'
' BASIC
'------
' dim as bstr rs at #rs
' if rs(first) > rs(second) then function=1
' exit function
'ASM USING DIRECT STRING COMPARE
'-------------------------------
mov ecx,#rs : mov eax,first : mov edx,second
comparestr [ecx+edx*4-4], [ecx+eax*4-4] 'DIRECT STRING COMPARE
( : jle exit : inc _function : )
end function
'-------------------
'CALL THE MERGE SORT
'===================
'declare function sortm (byval p as long ptr,byval sz as long, byval cbk as long) as long
'###########
' MERGE SORT
'###########
'
' requires an index array of twice the number of elements
'
' parameters
' 1 p pointer to index array
' 2 sz size of index array in elements
' 3 cbk address of Choosing function for callback
' Return:
' 0
'
'----------------------------------------------------
function sortmb(byval dp, byval sz, byval cb) as long
'====================================================
' dp ' pointer to base of data index array
' cb ' pointer to comparator callback function
' sz ' point to number of elements to sort
dim a ' comparator flag
dim c ' chooser index
dim e ' end of upper buffer block
dim g ' element counter
dim i ' first selector
dim j ' second selector
dim k ' target index
dim n ' number of elements
dim q ' flag for toggling source/target buffer blocks
dim bi ' boundary for fist selector
dim bj ' boundary for second selector
dim st ' start of source buffer
dim en ' end of source buffer
dim dd at dp
'
'INITIAL
'-------
'
n=*sz : e=n+n
st=1 : g=n+1
'
do
if g>n then
if st>=n then exit do
'
'SWAP SOURCE SOURCE INDEX BLOCK AND TARGET INDEX BLOCK
'
q=1-q
if q then
k=n+1 : i=1 : en=n
else
k=1 : i=n+1 : en=e
end if
'
j=i+st : bi=j : bj=bi+st
if bj>en then bj=en+1 ' LIMIT
shl st,1 'DOUBLE NEXT STRIDE
g=1
end if
'
if i>=bi then
if j>=bj then
i=bj : bi+=st : bj+=st : j=bi ' NEXT SET
if bj>en then bj=en+1 ' LIMIT
if bi>en then bi=en+1 ' LIMIT
continue do
else
c=j : inc j
end if
elseif j>=bj then
c=i : inc i
else
a=call cb dd(i),dd(j)
if a then c=j : inc j else c=i : inc i
end if
'
dd(k)=dd(c)
inc k : inc g
loop
'TRANSFER SHUTTLE BUFFER TO START IF NECESSARY
if q then for i=1 to n : dd(i)=dd(i+n) : next
end function
'-----------------------------------------------------------
function check_sample(byval ds, byval ri,byval sz) as string
'===========================================================
dim as bstr rs at ds ' array of data strings
dim as long dd at ri ' array of indexes to data
dim as long e at sz ' number of elements
'
dim i,j
function=`
SAMPLE:
ASCENDING ORDER
`
j=e
if j>16 then j=16
for i=1 to j
function+=rs(dd(i))+`
`
next
end function
'-----------------
'PERFORMANCE CHECK
'=================
'
DECLARE FUNCTION QueryPerformanceCounter LIB `KERNEL32.DLL` ALIAS `QueryPerformanceCounter` (lpPerformanceCount AS QUAD) AS LONG
DECLARE FUNCTION QueryPerformanceFrequency LIB `KERNEL32.DLL` ALIAS `QueryPerformanceFrequency` (lpFrequency AS QUAD) AS LONG
dim as quad t1,t2,fr
QueryPerformanceFrequency fr
'----
'MAIN
'====
'----------------
'PERFORM THE TEST
'================
QueryPerformanceCounter t1
sortmb #ri,#sz, &choosewhich
QueryPerformanceCounter t2
'------------
'PREPARE DATA
'============
dim as string r,tab=chr 9
r=check_sample (#rs,#ri,#sz)
dim n=[#sz]
dim as single t
t=(t2-t1)/fr
'------
'REPORT
'======
print r `
` str(n) ` strings
sorting time ` str(round(t*1000)) ` mSecs
per cycle: ` str(round(t*1e9/(n*log2(n)))) ` nSec
`
terminate
"
'msgbox 0,o2_view src
msgbox 0,sz+" words ready to sort"
o2_basic src
if len(o2_error) then
msgbox 0,"Error:"+$cr+o2_error
stop
end if
o2_exec
'------------
' SAVE RESULT
'============
stop
dim f as long
f=file_open ("t.txt","output")
for i=1 to e
a=ri(i)
file_LinePrint (f,str$(i)+$tab+str$(a)+$tab+rs(a))
next
file_close(f)
'msgbox 0,"okay"
MikeTrader
15-08-2009, 22:29
Thanks Charles. I don't have time to convert it today, but do you think that would be faster?
Charles Pegge
16-08-2009, 00:36
Hi Mike,
What you have already performs very well. Mine could problably run a bit faster but with the current processing power of today's average PC, sorts of up to 100k elements are fast enough to be barely noticeable. But if you land a contract to build the Califoria State Health Service Database :) then you could use other techniques like bunching the data into linked lists based on the first two letters then sorting each list independently. This would further boost performans by a factor of around 8 - 10x.
There's plenty you can do for special situations.
Charles
Mike Trader
28-08-2009, 22:57
Yes.
With that in mind this version of the INTEGER ARRAY sorting is probably better
SUB QSortLONG( BYVAL pArr AS LONG PTR, BYVAL nElem AS LONG, OPT BYVAL pTag AS DWORD PTR, BYVAL DescendFlag AS LONG )
LOCAL i, j, StkIx, First, Last AS LONG
LOCAL MidPt AS LONG '
IF nElem < 1 THEN EXIT SUB ' nothing to sort
i = 128 * (1+(Last\1000000)) ' 128 per 1m elements should be more than double what's needed
DIM QStack(i) AS LONG '
First = 0
Last = nElem
IF pTag = 0 THEN ' Create a Dummy array
DIM Tg(First TO Last) AS LONG
pTag = VARPTR(Tg(0)) ' ALL Zero Based Arrays from here on
END IF
DO
DO
i = (Last+First)\2 '
MidPt = @pArr[i] ' seek midpoint
i = First
j = Last '
IF DescendFlag = 0 THEN
DO '
WHILE @pArr[i] < MidPt
INCR i
WEND '
WHILE @pArr[j] > MidPt
DECR j
WEND '
IF i > j THEN EXIT DO '
IF i < j THEN SWAP @pArr[i], @pArr[j] : SWAP @pTag[i], @pTag[j] ' : INCR TotSwaps
INCR i
DECR j
LOOP WHILE i <= j
ELSE ' Descending
DO
WHILE @pArr[i] > MidPt
INCR i
WEND
WHILE @pArr[j] < MidPt
DECR j
WEND
IF i > j THEN EXIT DO
IF i < j THEN SWAP @pArr[i], @pArr[j] : SWAP @pTag[i], @pTag[j] ' : INCR TotSwaps
INCR i
DECR j
LOOP WHILE i <= j
END IF '
IF i < Last THEN ' Done
QStack(StkIx) = i ' Push i
QStack(StkIx + 1) = Last ' Push Last
StkIx = StkIx + 2 '
END IF
Last = j
LOOP WHILE First < Last
IF StkIx = 0 THEN EXIT DO
StkIx = StkIx - 2 '
First = QStack(StkIx) ' Pop First
Last = QStack(StkIx + 1) ' Pop Last
LOOP
END SUB