Here is one routine that can sort a structured array on many fields, the sorting algorithm is Bottom-up iterative merge sort which is a stable sort . I have done many tests and it looks fine and fast enough (below is a test code as well). If you find bugs pls let me know
Code: Select all
Procedure MySortArray(AdressOfArray, SizeOfStructure, List FldOffset.i(), List FldOption.i(), List FldType.i(), RangeStart, RangeEnd)
; generic, multi-fields, bottom-up iterative, stable merge-sort
; usage: MySortArray(@Ary(0), SizeOf(ary_structre), Flds(), Opts(), Typs(), RangeStart, RangeEnd)
Protected n,i,j,m, k, s1,e1,s2,e2, z, srt_asc, tmp, mode, res, dlt
Protected *a, *b, *pi, *pj, *p, *q
Protected Fld_Adr, Fld_Opt, Fld_Typ, iFld, nFld, Dim FAdr(0), Dim FOpt(0), Dim FTyp(0)
n = RangeEnd - RangeStart + 1
If n <= 0 : ProcedureReturn : EndIf
If ListSize(FldOffset()) = 0 : ProcedureReturn : EndIf
*a = AdressOfArray
*b = AllocateMemory(n * SizeOfStructure)
z = SizeOfStructure
; converting lists into arrays, faster access (guarantee all 3 lists have same size)
nFld = ListSize(FldOffset()) - 1
Dim FAdr(nFld)
Dim FOpt(nFld)
Dim FTyp(nFld)
ForEach FldOffset()
FAdr(iFld) = FldOffset()
If SelectElement(FldOption(), ListIndex(FldOffset())) : FOpt(iFld) = FldOption() : EndIf
If SelectElement(FldType(), ListIndex(FldOffset())) : FTyp(iFld) = FldType() : EndIf
iFld + 1
Next
k = 1 ; at each run, k is the nbr of elements in each half
While k < n
s1 = RangeStart
While s1 <= RangeEnd
e1 = s1 + (k-1) : If e1 > RangeEnd : e1 = RangeEnd : EndIf
e2 = -1
s2 = e1 + 1
If s2 <= RangeEnd
e2 = s2 + (k-1) : If e2 > RangeEnd : e2 = RangeEnd : EndIf
EndIf
m = s1 - RangeStart : i = s1 : j = s2
While (i <= e1 And j <= e2)
For iFld = 0 To nFld
Fld_Adr = FAdr(iFld)
Fld_Opt = FOpt(iFld)
Fld_Typ = FTyp(iFld)
srt_asc = Bool( (Fld_Opt & #PB_Sort_Descending) = 0 )
*pi = AdressOfArray + (SizeOfStructure * i) + Fld_Adr
*pj = AdressOfArray + (SizeOfStructure * j) + Fld_Adr
Select Fld_Typ
Case #PB_Byte : dlt = PeekB(*pi) - PeekB(*pj)
Case #PB_Ascii : dlt = PeekA(*pi) - PeekA(*pj)
Case #PB_Character : dlt = PeekC(*pi) - PeekC(*pj)
Case #PB_Unicode : dlt = PeekU(*pi) - PeekU(*pj)
Case #PB_Long : dlt = PeekL(*pi) - PeekL(*pj)
Case #PB_Integer : dlt = PeekI(*pi) - PeekI(*pj)
Case #PB_Float : dlt = Sign(PeekF(*pi) - PeekF(*pj))
Case #PB_Quad : dlt = Sign(PeekQ(*pi) - PeekQ(*pj))
Case #PB_Double : dlt = Sign(PeekD(*pi) - PeekD(*pj))
Case #PB_String
mode = #PB_String_CaseSensitive
If (Fld_Opt & #PB_Sort_NoCase) : mode = #PB_String_NoCase : EndIf
tmp = CompareMemoryString(PeekI(*pi), PeekI(*pj), mode)
If tmp = #PB_String_Equal : dlt = 0 : EndIf
If tmp = #PB_String_Lower : dlt = -1 : EndIf
If tmp = #PB_String_Greater : dlt = 1 : EndIf
EndSelect
If srt_asc
If dlt <= 0 : res = -1 : Else : res = 1 : EndIf
Else
If dlt >= 0 : res = -1 : Else : res = 1 : EndIf
EndIf
If dlt <> 0 : Break : EndIf
Next
If res <= 0
*p = *a + (z * i) : *q = *b + (z * m) : CopyMemory(*p, *q, z) : i+1
Else
*p = *a + (z * j) : *q = *b + (z * m) : CopyMemory(*p, *q, z) : j+1
EndIf
m+1
Wend
If i <= e1
*p = *a + (z * i) : *q = *b + (z * m) : CopyMemory(*p, *q, (e1-i+1)*z)
m = m + (e1-i+1)
EndIf
If j <= e2
*p = *a + (z * j) : *q = *b + (z * m) : CopyMemory(*p, *q, (e2-j+1)*z)
m = m + (e2-j+1)
EndIf
s1 = e1+1
If e2 > 0 : s1 = e2 + 1 : EndIf
Wend
*p = *a + (z * RangeStart) : CopyMemory(*b, *p, n*z)
k = k << 1 ; k * 2
Wend
FreeMemory(*b)
EndProcedure
Code: Select all
;-------------------------------------
;--- TEST ---------------------------
;-------------------------------------
Structure tst
Index.i
Txt1.s
Txt2.s
Int1.i
Int2.i
EndStructure
Procedure Debug_tst(Array t.tst(1), ss,ee)
Protected i
Debug ">>>>>>>>>>>>>>>> ss = " +#TAB$+ Str(ss) +#TAB$+ " ee = " +#TAB$+ Str(ee)
Debug "Index" +#TAB$+ "txt1" +#TAB$+ "int1" +#TAB$+ "txt2" +#TAB$+ "int2"
For i=ss To ee
Debug Str(t(i)\Index) + #TAB$ +
t(i)\Txt1 + #TAB$ +
Str(t(i)\Int1) + #TAB$ +
t(i)\Txt2 + #TAB$ +
Str(t(i)\Int2)
Next
EndProcedure
Define i,t0,t1,t2, n, ss, ee
Define NewList Flds(), NewList Opts(), NewList Typs()
Dim t.tst(0)
Dim t2.tst(0)
n = 10000;00
ss = Random(n/2)
ee = Random(n, n/2)
Dim t(n)
For i=0 To n
t(i)\Index = i
t(i)\Txt1 = Chr(Random(128, 65)) + Chr(Random(128, 65)) + Chr(Random(128, 65)) ;"a" + RSet(Str(Random(999,0)), 3, "0")
t(i)\Txt2 = Chr(Random(90, 65)) + Chr(Random(122, 97))
t(i)\Int1 = Random(1000)
t(i)\Int2 = Random(10000, 100)
Next
; before
;debug_tst(t(), ss, ee)
; adding sorting fields: Txt1, Asc no-case
AddElement(Flds()) : Flds() = OffsetOf(tst\Txt1)
AddElement(Typs()) : Typs() = TypeOf(tst\Txt1)
AddElement(Opts()) : Opts() = #PB_Sort_Ascending | #PB_Sort_NoCase
; then field: Int1 Desc
AddElement(Flds()) : Flds() = OffsetOf(tst\Int1)
AddElement(Typs()) : Typs() = TypeOf(tst\Int1)
AddElement(Opts()) : Opts() = #PB_Sort_Descending
; then field: Int2 Asc
AddElement(Flds()) : Flds() = OffsetOf(tst\Int2)
AddElement(Typs()) : Typs() = TypeOf(tst\Int2)
AddElement(Opts()) : Opts() = #PB_Sort_Ascending
; then field: Txt2 Desc
AddElement(Flds()) : Flds() = OffsetOf(tst\Txt2)
AddElement(Typs()) : Typs() = TypeOf(tst\Txt2)
AddElement(Opts()) : Opts() = #PB_Sort_Descending ;| #PB_Sort_NoCase
; sorting
t0 = ElapsedMilliseconds()
MySortArray(@t(0), SizeOf(tst), Flds(), Opts(), Typs(), ss, ee)
t0 = ElapsedMilliseconds() - t0
MessageRequester("sorting-time", Str(t0))
; after
;Debug " >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> "
;debug_tst(t(), ss, ee)
http://www.purebasic.fr/english/viewtop ... 12&t=49396
Edit: added all native PB types to MySortArray() and removed the procedure IsSorted_tst(), it was only for validation