@Roe5685 - actually, my string compare is not showing speed improvement over the combsort4 I posted. What I've done is create a natural sort, ie. "2" is not greater than "10"
Code: Select all
' sort macro v0.99 (2014 March 28) by dafhi
' Usage:
' 1. sort(arr,.field3) ' member
' 2. sort(arr,) ' plain
' -------- SORT CODE BEGINS AFTER LINE 610 --------
' ----------------------------------------------- '
' Less / More string compare functions by dafhi '
' '
' Ver 0.11 - 2012 July 14 '
' ----------------------------------------------- '
/' Basics:
1. dir sort - recognizes symbols \ and /
2. "Junk" sorts to end
A. empty strings
B. Robert < R.
'/
Const CHUNKTYPE_NUMBER = 0
Const CHUNKTYPE_LETTER = 1
Const CHUNKTYPE_OTHER = 2
#Ifndef FALSE
Const FALSE = 0
Const TRUE = not FALSE
#endif
#Macro DimVars(FT_1,FT_2)
dim as any ptr _any = @A
Dim As UInteger Ptr lpStr = _any
Dim As UInteger lena = lpStr[1]
_any = @B: lpStr = _any
Dim As UInteger lenb = lpStr[1]
if lena = 0 then
if lenb > 0 then return FT_2
Return FALSE
elseif lenb = 0 then
Return FT_1
end if
Dim As Integer posa
Dim As Integer posb
dim as uinteger lena_M = lena - 1
dim as uinteger lenb_M = lenb - 1
Dim As Integer posa_st
Dim As Integer posb_st
dim as integer delt_a
dim as integer delt_b
dim as integer asc_A
dim as integer asc_B
dim as integer typ_A
dim as integer typ_B
dim as integer lrh_A
dim as integer lrh_B
#EndMacro
#Macro BreakCommon(FT_1,FT_2)
If posa > lena_M Then
If posb > lenb_M Then
If lena_M > lenb_M Then
Return FT_2
ElseIf lenb_M > lena_M Then
Return FT_1
Else
Return FALSE
EndIf
Else
Return FT_1
EndIf
ElseIf posb > lenb_M Then
Return FT_2
EndIf
#EndMacro
#Macro EarlyBreak(FT_1,FT_2)
If posa > lena_M Then
If posb > lenb_M Then
If lena_M > lenb_M Then
Return FT_2
ElseIf lenb_M > lena_M Then
Return FT_1
Else
Return FALSE
EndIf
else
Return FT_2
EndIf
ElseIf posb > lenb_M Then
Return FT_1
EndIf
#EndMacro
'' ---------
' Common
' ----------
#Macro AscRemap_Common(str_,pos_,lenm,asc_)
asc_ = str_[pos_]
if asc_ = 46 Then
if pos_ < lenm then
If NumFollows(@str_[pos_]) Then
else
asc_ = 255
end if
else
asc_ = 255
end If
#EndMacro
#Macro SelCase(pVar)
Select Case pVar: Case
#EndMacro
#Macro Handle_Common()
delt_a = lena_M - posa
delt_b = lenb_M - posb
if delt_a < delt_b then
#EndMacro
#Macro Handle_Common_PosSt()
posa_st = posa
posb_st = posb
Handle_Common()
#EndMacro
#Macro Space_VS(FT_1,FT_2, str_1,pos_1, str_2,pos_2, lenm_1,lenm_2)
SelCase( str_1[pos_1] ) 32,92 ''space, backslash (for dir sort)
SelCase( str_2[pos_2] ) 32,92
Case Else
If pos_2 <= lenm_2 Then Return FT_1
End Select
Case Else
SelCase( str_2[pos_2] ) 32,92
If pos_1 <= lenm_1 Then Return FT_2
End Select
End Select
/' equivalent, w/o backslash
If str_1[pos_1] = 32 Then
If str_2[pos_2] <> 32 Then
If pos_2 <= lenm_2 Then Return FT_1
EndIf
ElseIf str_2[pos_2] = 32 Then
If pos_1 <= lenm_1 Then Return FT_2
EndIf
'/
#EndMacro
#Macro SkipChar(str_,pos_,lenm,charval)
For pos_ = pos_ to lenm
if str_[pos_] <> charval then
exit for
end if
next
#EndMacro
#Macro Skip_Space_BackSlash(str_,pos_,lenm)
For pos_ = pos_ to lenm
SelCase( str_[pos_] ) 32, 92
Case Else
exit for
End Select
next
#EndMacro
'' ----------
' Asc Other
' -----------
Function asc_other(ByVal pAsc as integer) as integer
select case pAsc
case 48 to 57, 65 to 90, 97 to 122,32,92''space,backslash
Return FALSE
end select
Return TRUE
end function
#Macro AscRemapOther(str_,pos_,lenm,asc_)
AscRemap_Common(str_,pos_,lenm,asc_)
elseif asc_other(asc_) then
asc_ = 255
end if
#EndMacro
#Macro Other_Loop(FT_1,FT_2,dlt_1,str_1,pos_1,lenm_1,asc_1,str_2,pos_2,lenm_2,asc_2)
for pos_1 = pos_1 to pos_1 + dlt_1
AscRemapOther(str_1,pos_1,lenm_1,asc_1)
AscRemapOther(str_2,pos_2,lenm_2,asc_2)
if asc_1 = 255 then
if asc_2 <> 255 then
Return FT_2
end if
elseif asc_2 = 255 then
Return FT_1
Else
Exit for
end if
pos_2 += 1
next
#EndMacro
#Macro Other_Chunk(FT_1,FT_2)
Handle_Common_PosSt()
'' posa closest to end
Other_Loop( FT_1,FT_2, delt_a, A,posa,lena_M,asc_A,B,posb,lenb_M,asc_B )
''posa went past end pos, A is smaller
if posa = lena then Return FT_1
elseif delt_b < delt_a then
'' posb closest to end
Other_Loop( FT_2,FT_1, delt_b, B,posb,lenb_M,asc_B, A,posa,lena_M,asc_A)
''posb went past end pos, B is smaller
if posb = lenb then Return FT_2
else
'' posa and posb equidistant to end pos
Other_Loop( FT_1,FT_2, delt_a, A,posa,lena_M,asc_A, B,posb,lenb_M,asc_B )
end if
#EndMacro
'' ------------------
' Asc Numeric
' -------------------
function NumFollows(ByVal lpUByt as ubyte ptr) as integer
lpUByt += 1
if *lpUByt > 57 then return false
if *lpUByt < 48 then return false
return TRUE
end Function
Function asc_non_numeric(ByVal pAsc As UInteger) As Integer
If pAsc > 57 Then Return TRUE ''57 is "9"
If pAsc < 48 Then Return TRUE ''48 is "0"
Return FALSE
End Function
Function asc_numeric(ByVal pAsc As UInteger) As Integer
If pAsc > 57 Then Return FALSE ''57 is "9"
If pAsc < 48 Then Return FALSE ''48 is "0"
Return TRUE
End Function
Function asc_1_To_9(ByVal pAsc As UInteger) As Integer
If pAsc > 57 Then Return FALSE ''57 is "9"
If pAsc < 49 Then Return FALSE ''48 is "0"
Return TRUE
End Function
#Macro SeekNonNumeric(str_,pos_st,pos_,delt_,lenm)
pos_st = pos_
for pos_ = pos_ to lenm
if str_[pos_] < 48 then exit for
if str_[pos_] > 57 then exit for
next
delt_ = pos_ - pos_st
#EndMacro
'' ---------
' Alphabet
' ----------
Function UCase_is_a_letter(ByRef pAsc As Integer) As Integer
If pAsc > 96 Then '' 97 a
If pAsc < 123 Then '' 122 z
pAsc -= 32
EndIf
EndIf
If pAsc < 65 Then Return FALSE '' A 65
If pAsc > 90 Then Return FALSE '' Z 90
Return TRUE
End Function
#Macro Make_UCase(str_,pos_,asc_)
asc_=str_[pos_]
If asc_ > 96 Then
If asc_ < 123 Then
asc_ -= 32
EndIf
EndIf
#EndMacro
#Macro Letters_Loop(FT_1,FT_2,dlt_1,asc_1,str_1,pos_1,len_1,asc_2,str_2,pos_2,len_2)
Make_UCase(str_1,pos_1,asc_1)
Make_UCase(str_2,pos_2,asc_2)
If asc_1 < asc_2 Then
Return FT_1
ElseIf asc_2 < asc_1 Then
Return FT_2
EndIf
pos_1 += 1
pos_2 += 1
for pos_1 = pos_1 to pos_1 + dlt_1 - 1
Make_UCase(str_1,pos_1,asc_1)
Make_UCase(str_2,pos_2,asc_2)
SelCase( asc_1 ) 65 to 90
SelCase( asc_2 ) 65 to 90
If asc_1 < asc_2 Then
Return FT_1
ElseIf asc_2 < asc_1 Then
Return FT_2
EndIf
Case 48 To 57, 32, 92 ''space, backslash (dir sorting)
Return FT_2
Case 46
Exit For
Case Else
Return FT_1
End Select
case 48 To 57
SelCase( asc_2 ) 48 To 57, 46
Exit For
Case 32, 92 ''space, backslash (dir sort)
Return FT_2
Case Else
Return FT_1
End Select
Case 32, 92 ''space, backslash (dir sort)
SelCase( asc_2 ) 65 to 90, 48 To 57, 46
Return FT_1
Case Else
Exit For
End Select
Case 46
Exit For
Case Else
SelCase( asc_2 ) 65 to 90, 48 To 57, 32, 92 ''space,backslash
Return FT_2
Case Else
Exit For
End Select
End Select
pos_2 += 1
Next
If asc_1 = 46 Then
SelCase( asc_2 ) 32, 92 ''space,backslash
If NumFollows( @str_1[pos_1] ) Then
Else
Return FT_2
EndIf
End Select
/' equivalent, w/o backslash
If asc_2 = 32 Then
If NumFollows( @str_1[pos_1] ) Then
Else
Return FT_2
EndIf
EndIf
'/
ElseIf asc_2 = 46 Then
SelCase( asc_1 ) 32, 92 ''space,backslash
If NumFollows( @str_2[pos_2] ) Then
Else
Return FT_1
EndIf
End Select
/' equivalent, w/o backslash
If asc_1 = 32 Then
If NumFollows( @str_2[pos_2] ) Then
Else
Return FT_1
EndIf
EndIf
'/
EndIf
#EndMacro
#Macro Letters_Chunk(FT_1,FT_2)
Handle_Common_PosSt()
'' posa closest to end
Letters_Loop(FT_1,FT_2, delt_a, _
asc_A,A,posa,lena, asc_B,B,posb,lenb)
''posa went past end pos, A is smaller
if posa = lena then Return FT_1
elseif delt_b < delt_a then
'' posb closest to end
Letters_Loop(FT_2,FT_1, delt_b, _
asc_B,B,posb,lenb, asc_A,A,posa,lena)
''posb went past end pos, B is smaller
if posb = lenb then Return FT_2
else
'' posa and posb equidistant to end pos
Letters_Loop(FT_1,FT_2, delt_a, _
asc_A,A,posa,lena, asc_B,B,posb,lenb)
end If
#EndMacro
#Macro LHS_(FT_1,FT_2)
SkipChar( A, posa, lena_m, 48 )
SkipChar( B, posb, lenb_m, 48 )
SeekNonNumeric(A,posa_st,posa,delt_a,lena_M)
SeekNonNumeric(B,posb_st,posb,delt_b,lenb_M)
if delt_a < delt_b then
return FT_1
elseif delt_b < delt_a then
return FT_2
End If
delt_A -= 1
DigitLoop(FT_1,FT_2, A,posa_st,posa,delt_A, B,posb_st,posb)
#EndMacro
#Macro RHS_Inscription(str_,pos_st,pos_,lenm_,lrh_)
lrh_ = 1
If str_[pos_] = 46 Then
Pos_ += 1
pos_st = pos_
SkipChar( str_, pos_, lenm_, 48 )
If asc_numeric( str_[pos_] ) Then
lrh_ = 1
Else
lrh_ = 0
EndIf
pos_ = pos_st
Else
lrh_ = 0
EndIf
#EndMacro
#Macro DigitLoop(FT_1,FT_2, str_1,pos_st1,pos_1,delt_1, str_2,pos_st2,pos_2)
pos_2 = pos_st2
for pos_1 = pos_st1 to pos_st1 + delt_1
if str_1[pos_1] < str_2[pos_2] then
return FT_1
elseif str_2[pos_2] < str_1[pos_1] then
return FT_2
end if
pos_2 += 1
Next
#EndMacro
#Macro RHS_Digits(FT_1,FT_2, str_1,pos_st1,pos_1,lenm_1,delt_1, str_2,pos_st2,pos_2,lenm_2,delt_2)
delt_1 -= 1
delt_2 += pos_st2 - 1
DigitLoop(FT_1,FT_2, str_1,pos_st1,pos_1,delt_1, str_2,pos_st2,pos_2)
For pos_2 = pos_2 To delt_2
If asc_1_To_9( str_2[pos_2] ) Then Return FT_1
Next
Space_VS(FT_1,FT_2, str_1,pos_1, str_2,pos_2, lenm_1,lenm_2)
#EndMacro
#Macro RHS_(FT_1,FT_2)
RHS_Inscription(A,posa_st,posa,lena_M,lrh_A)
RHS_Inscription(B,posb_st,posb,lenb_M,lrh_B)
If lrh_A < lrh_B Then
Return FT_1
ElseIf lrh_B < lrh_A Then
Return FT_2
EndIf
SeekNonNumeric(A,posa_st,posa,delt_a,lena_M)
SeekNonNumeric(B,posb_st,posb,delt_b,lenb_M)
If delt_A < delt_B Then
RHS_Digits(FT_1,FT_2, A,posa_st,posa,lena_m,delt_A, B,posb_st,posb,lenb_M,delt_B)
ElseIf delt_B < delt_A Then
RHS_Digits(FT_2,FT_1, B,posb_st,posb,lenb_m,delt_B, A,posa_st,posa,lena_M,delt_A)
Else
delt_A -= 1
DigitLoop(FT_1,FT_2, A,posa_st,posa,delt_A, B,posb_st,posb)
Space_VS(FT_1,FT_2, A,posa, B,posb, lenA_m,lenb_m)
EndIf
#EndMacro
#Macro CompareNums(FT_1,FT_2)
LHS_(FT_1,FT_2)
RHS_(FT_1,FT_2)
#EndMacro
#Macro ChunkType(str_,pos_st,pos_,lenm_,asc_,typ_)
pos_st = pos_
SkipChar(str_,pos_,lenm_,48)
if pos_ > pos_st Then
If asc_non_numeric( str_[Pos_] ) Then
asc_ = pos_ - 1
If str_[asc_] = 48 Then
pos_ = asc_
EndIf
End If
end if
asc_ = str_[pos_]
If pos_ > lenm_ Then
typ_ = -1
elseIf UCase_is_a_letter(asc_) Then
typ_ = CHUNKTYPE_LETTER
elseif asc_numeric(asc_) Then
typ_ = CHUNKTYPE_NUMBER
If str_[pos_] = 48 Then
If pos_ < lenm_ Then
asc_ = pos_ + 1
If str_[asc_] = 46 Then
pos_ = asc_
EndIf
EndIf
End If
Else
typ_ = CHUNKTYPE_OTHER
if asc_ = 46 then '' decimal point
If pos_ < lenm_ Then
if NumFollows(@str_[pos_]) Then typ_ = CHUNKTYPE_NUMBER
ElseIf Pos_ > 0 Then
If asc_numeric(str_[pos_-1]) Then typ_ = CHUNKTYPE_NUMBER
End If
end if
end if
#EndMacro
#Macro CompareChunks(FT_1,FT_2)
if typ_A < typ_B then
Return FT_1
elseif typ_B < typ_A then
Return FT_2
Else
If typ_A = CHUNKTYPE_NUMBER Then
CompareNums(FT_1,FT_2)
ElseIf typ_A = CHUNKTYPE_LETTER then
Letters_Chunk(FT_1,FT_2)
else
Other_Chunk(FT_1,FT_2)
end if
end If
BreakCommon(FT_1,FT_2)
#EndMacro
#Macro LessMore(FALS_TRU_1,FALS_TRU_2)
DimVars(FALS_TRU_1,FALS_TRU_2)
SkipChar(A,posa,lena_M,32)
SkipChar(B,posb,lenb_M,32)
EarlyBreak(FALS_TRU_1,FALS_TRU_2)
ChunkType(A,posa_st,posa,lena_M,asc_A,typ_A)
ChunkType(B,posb_st,posb,lenb_M,asc_B,typ_B)
CompareChunks(FALS_TRU_1,FALS_TRU_2)
Do
Skip_Space_BackSlash(A,posa,lena_M)
Skip_Space_BackSlash(B,posb,lenb_M)
ChunkType(A,posa_st,posa,lena_M,asc_A,typ_A)
ChunkType(B,posb_st,posb,lenb_M,asc_B,typ_B)
CompareChunks(FALS_TRU_1,FALS_TRU_2)
Loop
Return FALSE
#EndMacro
Function Less(ByRef A As String, ByRef B As String) As Integer
LessMore(TRUE,FALSE)
End Function
Function More(ByRef A As String, ByRef B As String) As Integer
LessMore(FALSE,TRUE)
End Function
' '
' Less / More '
' -------------------- '
' ============================
' S O R T S
' ============================
#Macro zInsertionSortString(A,lSt,lEnd,dot)
I = lSt
For J = I + 1 To lEnd
if more( a(i)dot, a(j)dot ) then
SwapV = A(J)
SwapVcomp = A(J)dot
dim as integer K = I
A(J) = A(K)
For I = I - 1 To lSt Step -1
'If A(I)dot <= SwapVcomp Then Exit For
if not more( a(i)dot, SwapVcomp ) then exit for
A(K) = A(I)
K = I
Next
A(K) = SwapV
End If
I = J
Next
#EndMacro
#Macro zQuickCommonString(A,pSt,pEnd,dot)
Exit Do
Else
I = pSt
J = pEnd
SwapVcomp = A((I + J) \ 2)dot
Do
While Less(A(I)dot, SwapVcomp)
I = I + 1
Wend
While Less(SwapVcomp, A(J)dot)
J = J - 1
Wend
If I > J Then Exit Do
If More(A(I)dot, A(J)dot) Then Swap A(I), A(J)
I = I + 1
J = J - 1
Loop While I <= J
If I < pEnd Then
lStack(StackPtr) = I
lStack(StackPtr + 1) = pEnd
StackPtr = StackPtr + 2
End If
pEnd = J
End If
Loop While pSt < pEnd
If StackPtr = 0 Then Exit Do
StackPtr = StackPtr - 2
pSt = lStack(StackPtr)
pEnd = lStack(StackPtr + 1)
Loop
#EndMacro
' ======== numeric --------
#Macro zInsertionSort(A,lSt,lEnd,dot)
I = lSt
For J = I + 1 To lEnd
If A(I)dot > A(J)dot Then
SwapV = A(J)
SwapVcomp = A(J)dot
dim as integer K = I
A(J) = A(K)
For I = I - 1 To lSt Step -1
If A(I)dot <= SwapVcomp Then Exit For
A(K) = A(I)
K = I
Next
A(K) = SwapV
End If
I = J
Next
#EndMacro
#Macro zQuickCommon(A,pSt,pEnd,dot)
Exit Do
Else
I = pSt
J = pEnd
SwapVcomp = A((I + J) \ 2)dot
Do
While A(I)dot < SwapVcomp
I = I + 1
Wend
While SwapVcomp < A(J)dot
J = J - 1
Wend
If I > J Then Exit Do
If A(I)dot > A(J)dot Then Swap A(I), A(J)
I = I + 1
J = J - 1
Loop While I <= J
If I < pEnd Then
lStack(StackPtr) = I
lStack(StackPtr + 1) = pEnd
StackPtr = StackPtr + 2
End If
pEnd = J
End If
Loop While pSt < pEnd
If StackPtr = 0 Then Exit Do
StackPtr = StackPtr - 2
pSt = lStack(StackPtr)
pEnd = lStack(StackPtr + 1)
Loop
#EndMacro
'========================================================
#Macro QS_StrNum_Common(a)
Dim As Integer UB = ubound(a)
If UB > 0 Then
Dim As Integer I,J,lSt,StackPtr,lStack(UB \ 2 + 10)
Const QS_INSERTSORT_THRESHOLD = 13
'Standard QuickSort Routine
'http://www.freebasic-portal.de/porticula/sort-testbas-schnellste-routinen-513.html
Do
Do
If UB - lSt < QS_INSERTSORT_THRESHOLD Then ''Tests show 13 optimal for many cases
#EndMacro
#Macro sort(a,dot)
Scope
dim as TypeOf(a) SwapV
dim as TypeOf(a(0)dot) SwapVcomp
#if typeof(SwapVcomp) = typeof(string)
QS_StrNum_Common(a)
zInsertionSortString(A, lSt, UB,dot)
zQuickCommonString(A,lSt,UB,dot)
end if
#else
QS_StrNum_Common(A)
zInsertionSort(A, lSt, UB, dot)
zQuickCommon(A,lSt,UB,dot)
end if
#EndIf
End Scope
#EndMacro
'=== End of SORT ===
' ==============================================
type anytype
as integer field1
as double field2
as string field3
end type
' ======= Print Result =======
function MinBound(a as double, b as double) as integer
if a < b then return a
return b
end function
function MaxBound(a as double, b as double) as integer
if a > b then return a
return b
end function
sub printbits(k() as anytype)
for n as integer=0 to MinBound( 4, ubound(k) )
print k(n).field1,k(n).field2,k(n).field3
next n
print " ..."
for n as integer= MaxBound(0, ubound(k)-4) to ubound(k)
print k(n).field1,k(n).field2,k(n).field3
next n
print
print "_____________________________"
print
print
end sub
Sub Main
dim as integer array_size = 20
dim as integer ub = array_size - 1
dim as anytype x(0 to ub)
#define Intrange(f,l) Int(Rnd*((l+1)-(f))+(f))
for n as integer=0 to ub
with x(n)
.field1=rnd*1000
.field2=rnd*1000-rnd*1000
.field3=chr(IntRange(65,90))+chr(IntRange(65,90))
end with
next n
print
print " field1"," field2"," field3"
print
sort(x,.field1)
printbits x()
sort(x,.field2)
printbits x()
sort(x,.field3)
printbits x()
sleep
End Sub
Main