Here is some code I created for sorting a structured array on multiple fields. This code is needed because sorting an array in PB is not performed with a stable sort. The procedures I created below will allow you to sort on multiple fields at once (so to speak). It uses PureBasic's SortStructuredArray() function to do the main work but selectively calls it only over certain ranges and with selected parameters to accomplish the desired multi-field sort.
Because PB's SortStructuredArray() function requires a specific structured array parameter and not a pointer to an array I have written a macro that creates the needed procedures for an array of a specific structure. For instance to create the procedures to be used for arrays with the structure 'point' you would call the macro mcr_multiSort(point). This would create the procedure multiSort_point() that would be called with parameters as multiSort_point(a.point(), sortSpecs()).
The sortSpecs() array contains the details of the sorting for each field being sorted. Its dimensions must be one less than the number of fields being sorted. It is structured with the structure sortFieldSpecs which contains entries for the offset of the field, it's type, and the option for sorting. Each of those fields correspond to one of the parameters in PB's SortStructuredArray() function.
I've arranged the code as an include:
Code:
;Program: Multi-Field Sort for Structured Arrays.
;Name: Array_MultiFieldSort.pbi
;Author: Demivec
;Date: 3/12/2012
;Written for PureBasic v4.61
EnableExplicit
;-sort routines
Enumeration
;The standard equality functions return one of the following comparison
;results.
#isNotEqualTo = 0
#isEqualTo
EndEnumeration
;=================================================================================
; Description: Each of the equality functions compares two elements that are a
; PureBasic standard data type for equality and returns a boolean
; result. The elements are at addresses [*element_1] and [*element_2].
;
; Returns: Returns '#isEqualTo' if the first element is equal to
; element two, otherwise it returns '#isNotEqualTo'.
;
; Note: A given equality function can only operate on compatible data and so care
; must be taken in using the correct function. These functions are only
; used by the subSort() function.
;=================================================================================
Macro mcr_equality_standardTypes(type, subStructure)
Procedure _isEqual_#type(*element_1.type, *element_2.type)
If *element_1\subStructure = *element_2\subStructure
ProcedureReturn #isEqualTo
EndIf
ProcedureReturn #isNotEqualTo
EndProcedure
EndMacro
mcr_equality_standardTypes(byte, b)
mcr_equality_standardTypes(word, w)
mcr_equality_standardTypes(long, l)
mcr_equality_standardTypes(integer, i)
mcr_equality_standardTypes(quad, q)
mcr_equality_standardTypes(float, f)
mcr_equality_standardTypes(double, d)
mcr_equality_standardTypes(ascii, a)
mcr_equality_standardTypes(character, c)
mcr_equality_standardTypes(unicode, u)
mcr_equality_standardTypes(string, s)
DataSection
_standardEqualityFunctions:
;Equality functions for each of the standard element types.
;Data must be present for each of PB's standard sort compare types.
;A line for each parameter-constant followed by the address of its equality function.
Data.i 11 ;1 based count of equality functions
Data.i #PB_Sort_Byte , @_isEqual_byte()
Data.i #PB_Sort_Word , @_isEqual_word()
Data.i #PB_Sort_Long , @_isEqual_long()
Data.i #PB_Sort_integer , @_isEqual_Integer() ;same as either long or quad, technically this entry is an unnecessary duplicate
Data.i #PB_Sort_Quad , @_isEqual_quad()
Data.i #PB_Sort_Float , @_isEqual_float()
Data.i #PB_Sort_Double , @_isEqual_double()
Data.i #PB_Sort_Ascii , @_isEqual_ascii()
Data.i #PB_Sort_Character, @_isEqual_character()
Data.i #PB_Sort_Unicode , @_isEqual_unicode()
Data.i #PB_Sort_String , @_isEqual_string()
EndDataSection
Prototype.i equalityFunction(*element_1, *element_2)
Global Dim *equalityFunctionAdr(0)
Procedure setupEqualityFunctions()
Shared *equalityFunctionAdr()
Protected i, equalityFunctionCount, dataType
Restore _standardEqualityFunctions
Read.i equalityFunctionCount
For i = 1 To equalityFunctionCount
Read.i dataType
If dataType > ArraySize(*equalityFunctionAdr())
Redim *equalityFunctionAdr(dataType)
EndIf
Read.i *equalityFunctionAdr(dataType)
Next
EndProcedure
setupEqualityFunctions()
Structure sortFieldSpecs
offset.i
type.i
option.i
EndStructure
;The multiSort procedure created ends with the structure name i.e. multiSort_struc()
;The multiSort procedure has parameters {arr(), sortSpecs() [, rangeStart, rangeEnd]}.
;rangeStart and rangeEnd are optional and if either of them is specified they both
;must be specified.
Macro mcr_multiSort(struc)
;multiSort() and subSort() only are set up for use with the given structure
Procedure subSort_#struc(Array x.struc(1), Array sortFieldSpecs.sortFieldSpecs(1), sortLevel, rangeStart, rangeEnd)
Protected i, firstElement = rangeStart, prevSortLevel = sortLevel - 1
Protected equalityFunc.equalityFunction = *equalityFunctionAdr(sortFieldSpecs(prevSortLevel)\type)
For i = rangeStart + 1 To rangeEnd
If equalityFunc(@x(firstElement) + sortFieldSpecs(prevSortLevel)\offset, @x(i) + sortFieldSpecs(prevSortLevel)\offset) <> #isEqualTo
If i - firstElement > 1
SortStructuredArray(x(), sortFieldSpecs(sortLevel)\option, sortFieldSpecs(sortLevel)\offset, sortFieldSpecs(sortLevel)\type, firstElement, i - 1)
If sortLevel < ArraySize(sortFieldSpecs())
subSort_#struc(x(), sortFieldSpecs(), sortLevel + 1, firstElement, i - 1)
EndIf
EndIf
firstElement = i
EndIf
Next
If rangeEnd - firstElement > 0
SortStructuredArray(x(), sortFieldSpecs(sortLevel)\option, sortFieldSpecs(sortLevel)\offset, sortFieldSpecs(sortLevel)\type, firstElement, rangeEnd)
If sortLevel < ArraySize(sortFieldSpecs())
subSort_#struc(x(), sortFieldSpecs(), sortLevel + 1, firstElement, rangeEnd)
EndIf
EndIf
EndProcedure
Procedure multiSort_#struc(Array x.struc(1), Array sortFieldSpecs.sortFieldSpecs(1), rangeStart = -1, rangeEnd = -1)
If rangeStart = -1 Or rangeEnd = -1
rangeStart = 0: rangeEnd = ArraySize(x())
EndIf
SortStructuredArray(x(), sortFieldSpecs(0)\option, sortFieldSpecs(0)\offset, sortFieldSpecs(0)\type, rangeStart, rangeEnd)
If ArraySize(sortFieldSpecs()) > 0 And ArraySize(x()) > 1
subSort_#struc(x(), sortFieldSpecs(), 1, rangeStart, rangeEnd)
EndIf
EndProcedure
EndMacro
;This helper macro makes it possible to specify on one line the sort options for an array of
;sortFieldSpecs at a specified index.
Macro mcr_setSortSpec(arrName, index, _offset, _type, _option = #PB_Sort_Ascending)
arrName(index)\offset = _offset
arrName(index)\type = _type
arrName(index)\option = _option
EndMacro
The macro mcr_setSortSpec() is provided so that the sortSpecs for an index can be specified on a single line.
Here's some demonstration code that uses the include file:
Code:
;Demonstration code for Multi-Field Sort of a Structured Array.
;Author: Demivec
;Written for PureBasic v4.61
;Date: 3/7/2012
EnableExplicit
IncludeFile "Array_MultiFieldSort.pbi"
Structure myOwn
a.w
b$
c.i
d$
EndStructure
Procedure display_myOwn(Array x.myOwn(1), header.s = "", footer.s = "")
Protected i, tw = 8
Debug header
Debug LSet("a", tw) + LSet("b$", tw) + LSet("c", tw) + LSet("d$", tw)
Debug LSet("---", tw) + LSet("---", tw) + LSet("---", tw) + LSet("---", tw)
For i = 0 To ArraySize(x())
Debug LSet(Str(x(i)\a), tw) + LSet(x(i)\b$, tw) + LSet(Str(x(i)\c), tw) + LSet(x(i)\d$, tw)
Next
Debug footer
EndProcedure
;-sort routines
mcr_multiSort(myOwn) ;create procedure multiSort_myOwn()
;-setup random data
Define i, entryCount = 500000
Dim myOwn.myOwn(entryCount)
For i = 0 To entryCount
myOwn(i)\a = Random(10)
myOwn(i)\b$ = Chr(Random(10) + 65)
myOwn(i)\c = (Random(10) + 1) * 20000
myOwn(i)\d$ = Chr(Random(10) + 65)
Next
display_myOwn(myOwn(), "-- Before Sort --")
;now for some heavy duty sorting
Dim myOwn_sortSpecs.sortFieldSpecs(3) ;Array should be sized to be one less than the number of fields to be sorted
mcr_setSortSpec(myOwn_sortSpecs, 0, OffsetOf(myOwn\d$), #PB_Sort_String, #PB_Sort_Ascending)
mcr_setSortSpec(myOwn_sortSpecs, 1, OffsetOf(myOwn\b$), #PB_Sort_String, #PB_Sort_Descending)
mcr_setSortSpec(myOwn_sortSpecs, 2, OffsetOf(myOwn\a), #PB_Sort_Word, #PB_Sort_Descending)
mcr_setSortSpec(myOwn_sortSpecs, 3, OffsetOf(myOwn\c), #PB_Sort_integer, #PB_Sort_Ascending)
multiSort_myOwn(myOwn(), myOwn_sortSpecs())
display_myOwn(myOwn(), "-- Sort by: d$ A, b$ D, a.w D, c.i A --") ;'A' and 'D' represent ascending and descending order
To resort with different fields, options, or the number of fields just redimension the sorSpecs() array and fill it in with the new options.
@Edit: separated the previous code into an include file and demonstration code.
Created a procedure for the initialization code so that the variables used for setup could be kept local to the procedure, leaving only one global variable defined.
Modified the multiSort() procedure to allow an optional range to be specified.
@Edit: corrected a small bug that skipped sorts of only 2 elements if they occurred at the end of a sub-sort range. Made a very minor change to cleanup code.
Added a default option of #PB_Sort_Ascending for the mcr_setSortSpec() macro. Thanks for skywalk for reminding me of this possibility.
FAQ
Search
Register
Login
