Thanks wilbert for pointing out the internal qsort() function.
Unfortunately, the qsort() function rearranges the indexes prior to calling the compare function so this won't work.
Your idea of comparing additional fields is good and valid, but it still forces specific custom compare_myStruc()'s to be hardcoded.
And, if there are no additional fields, we must make some up to indicate the duplicates...or go with our own stable sort. We are cursed with this unstable QuickSort algorithm and I want to know who adopted it so...ummm...QUICKLY?
ahem...optimized MergeSort please.
Anyway, here is the custom compare approach...
Code: Select all
EnableExplicit
ImportC ""
qsort(*arBaseIndex, nPts.i, SizeOfStruc, *CompareFn)
EndImport
Structure myABC ; Example Structure
a.i
b.d
c$
EndStructure
ProcedureC.i Compare_myABC(*a.myABC, *b.myABC)
; Custom Sort order: \a.i+, \b.d+, \c$+
Protected.i ri = *a\a - *b\a ; compare element values
If ri = 0 ; Make stable if identical
; Comparing element addresses fails because qsort() moves elements internally
; Use next desired field's values instead
ri = *a\b - *b\b
If ri = 0 ; Check next available field for desired order
ri = CompareMemoryString(@*a\c$, @*b\c$, #PB_String_NoCase)
EndIf
EndIf
ProcedureReturn ri
EndProcedure
ProcedureC.i Compare_myABC_BAD(*a.myABC, *b.myABC)
; Compare only \a.i+, but to maintain order of duplicates, check addresses
; Essentially, this eliminates 0 as a Return value.
Protected.i ri = *a\a - *b\a ; Compare Ascending Order, Descending -> *b\a - *a\a
If ri = 0 ; Make stable if identical
; Comparing element addresses fails because qsort() moves elements internally
; Use next desired field's values instead
ri = *a - *b
EndIf
ProcedureReturn ri
EndProcedure
;-{ TEST
Macro Debug_myABC(arStruc, nPts, hdr="", tw=4)
Debug hdr
Debug LSet("--", tw) + LSet("--", tw) + LSet("--", tw)
For i = 0 To nPts-1
Debug LSet(Str(arstruc(i)\a), tw) + LSet(Str(arstruc(i)\b), tw) + LSet(arstruc(i)\c$, tw)
Next
EndMacro
Define.i i, nPts, tw = 4
Define.s r$
Restore SortThis
Read.i nPts
Dim myL.myABC(nPts-1)
Dim myL1.myABC(nPts-1)
For i = 0 To nPts-1
Read.s r$: myL1(i)\a = Val(r$)
Read.s r$: myL1(i)\b = ValD(r$)
Read.s myL1(i)\c$
Next
CopyArray(myL1(),myL())
Debug "-- Before Sort --"
Debug_myABC(myL, nPts, LSet("a", tw) + LSet("b", tw) + LSet("c$", tw))
; Attempt to use the built-in PB SortStructuredArray() for \a, \b, \c$
SortStructuredArray(myL(), #PB_Sort_Ascending|#PB_Sort_NoCase, OffsetOf(myABC\c$), #PB_String)
SortStructuredArray(myL(), #PB_Sort_Ascending, OffsetOf(myABC\b), #PB_Double)
SortStructuredArray(myL(), #PB_Sort_Ascending, OffsetOf(myABC\a), #PB_Integer)
Debug "-- FAIL = PB SortStructuredArray() a+,b+,c$+ --"
Debug_myABC(myL, nPts, LSet("a", tw) + LSet("b", tw) + LSet("c$", tw))
CopyArray(myL1(),myL())
qsort(@myL(), nPts, SizeOf(myABC), @Compare_myABC_BAD())
Debug "-- FAIL = qsort() w/custom compare_myABC_BAD() a+ only --"
Debug_myABC(myL, nPts, LSet("a", tw) + LSet("b", tw) + LSet("c$", tw))
CopyArray(myL1(),myL())
qsort(@myL(), nPts, SizeOf(myABC), @Compare_myABC())
Debug "-- OK = qsort() w/custom compare_myABC() a+,b+,c$+ --"
Debug_myABC(myL, nPts, LSet("a", tw) + LSet("b", tw) + LSet("c$", tw))
;-}
DataSection
SortThis:
Data.i 12
; a, b, c$
Data.s "1", "9", "1"
Data.s "2", "2", "5"
Data.s "3", "1", "b"
Data.s "4", "1", "a"
Data.s "5", "3", "z"
Data.s "7", "3", "y"
Data.s "6", "3", "3"
Data.s "8", "3", "2"
Data.s "9", "3", "x"
Data.s "7", "5", "a" ;<- The problem of a 3rd sort appears when both Field1 and Field2 are duplicates
Data.s "7", "5", "W" ;<- Field1 = primary, Field2 = secondary, etc.
Data.s "7", "4", "x"
IWantThis:
Data.i 12
; a, b, c$
Data.s "1", "9", "1"
Data.s "2", "2", "5"
Data.s "3", "1", "b"
Data.s "4", "1", "a"
Data.s "5", "3", "z"
Data.s "6", "3", "3"
Data.s "7", "3", "y" ;<- b = 3 then 4
Data.s "7", "4", "x"
Data.s "7", "5", "a" ;<- c$ = a then W
Data.s "7", "5", "W"
Data.s "8", "3", "2"
Data.s "9", "3", "x"
IGetThis:
; -- FAIL = PB SortStructuredArray() a+,b+,c$+ --
; a b c$
; -- -- --
; 1 9 1
; 2 2 5
; 3 1 b
; 4 1 a
; 5 3 z
; 6 3 3
; 7 4 x ;<- FAIL b = 4 then 3
; 7 3 y
; 7 5 W ;<- FAIL c$ = W then a
; 7 5 a
; 8 3 2
; 9 3 x
EndDataSection
;-}