Coment trier un tableau structuré sur deux champs...

[PAPIPP]

Bonjours à tous
J’ai comme l’impression d’avoir pollué le post sur http://www.purebasic.fr/french/viewtopi ... 0&start=15. avec mes vielles macros.
Je poste ici le prg optimisé et généralisé pour ceux qui sont sensés comprendre.
Voici le prg le plus optimisé et aussi le plus généralisé ou le plus banalisé que j'ai pu réaliser.

Il est utilisable dans un même prg principal pour travailler sur plusieurs structures de tables différentes

Dans ce PRG il y a 2 macros principales.
La première MAC_INITPROC(struct_) qui contient une procédure permet de modifier extérieurement le nom de la procédure et la structure du tableau avec lequel elle va travailler.
Ceci permet de réaliser plusieurs tris sur des tableaux de structures différentes.

La deuxième MAC_compare_(test_) simplifie la programmation car pour généraliser et banaliser une procédure de tri
il faut tenir compte du type de tri ascendant ou descendant.
En suite il faut tenir compte du type de champ sur lequel le tri est ordonné.
La combinatoire nous donne 2 ordres de tri et 11 types de champs sans compter dans le champ string les options :
#PB_Ascii : Format ASCII., #PB_UTF8 : Format UTF-8. #PB_Unicode: Format Unicode.
Qui ferait 13 types donc au total 13*2=26 possibilités de trier un tableau et donc 26 fois les instructions de la macro MAC_compare_(test_).
Ici j’ai pris par défaut le format ASCII ce qui limite à 22 possibilités de tri.
Vous pouvez ajouter les deux autres options pour vos besoins personnels.

Code : Tout sélectionner

Structure TEST
  Nom.s
  Champs1.i
  Champs2.d
EndStructure
Global maxt=200
Dim Tableau.Test(MAXT)
Structure TEST2
  Nom2.s
  Taille2.i
  date2.q
EndStructure
Dim Tableau2.Test2(MAXT)

;********************** Toutes le macros et la procedure TRIBULLE font un tout **********************
Macro MAC_compare_(test_)
  Repeat
    hasChanged=#False
    itemCount-1
    For i=0 To itemCount
      If Bool(test_)
        CopyMemory(TAB(i),*Mem,LongTerm)
        CopyMemory(TAB(i+1),TAB(i),LongTerm)
        CopyMemory(*Mem,TAB(i+1),LongTerm)
        hasChanged=#True
      EndIf 
    Next
  Until hasChanged=#False
EndMacro

Macro MAC_INITPROC(struct_)
  Procedure TRIBULLE#struct_(Array TAB.struct_(1),Offset,Type,ascdesc)
    Protected i,itemCount,hasChanged,LongTerm,*mem
    itemCount=ArraySize(TAB())
    LongTerm=TAB(1)-TAB(0)
    *mem=AllocateMemory(Longterm,#PB_Memory_NoClear)
    Select ascdesc
        ;********************************  cas du tri ascendant ******************************
      Case #PB_Sort_Ascending
        Select Type
          Case #PB_Byte    ; Le champ de la Structure est un octet (.b)
            MAC_compare_(PeekB(tab(i)+offset)>PeekB(TAB(i+1)+offset))
          Case #PB_Word    ; Le champ de la Structure est un word (.w)
            MAC_compare_( PeekW(tab(i)+offset)>PeekW(TAB(i+1)+offset))
          Case #PB_Long    ; Le champ de la Structure est un long (.l)
            MAC_compare_( PeekL(tab(i)+offset)>PeekL(TAB(i+1)+offset))
          Case #PB_String  ; Le champ de la Structure est un string (.s ou $)
                           ; Les strings fixe (fixed strings) ne sont pas supportées)
                           ;           Resultat$ = PeekS(*Memoire [, Longueur [, Format]])
                           ;           Format
                           ;           #PB_Ascii  : Format ASCII.
                           ;           #PB_UTF8   : Format UTF-8.
                           ;           #PB_Unicode: Format Unicode.
                           ;     Par défaut ascii
            MAC_compare_( PeekS(PeekL(tab(i)+offset))>PeekS(PeekL(tab(i+1)+offset)))
          Case #PB_Float    ; Le champ de la Structure est un flottant (.f)
            MAC_compare_( PeekF(tab(i)+offset)>PeekF(TAB(i+1)+offset))
          Case #PB_Double  ; Le champ de la Structure est un double (.d)
            MAC_compare_( PeekD(tab(i)+offset)>PeekD(TAB(i+1)+offset))
          Case #PB_Quad    ; Le champ de la Structure est un quad (.q)
            MAC_compare_( PeekQ(tab(i)+offset)>PeekQ(TAB(i+1)+offset))
          Case #PB_Character:; Le champ de la Structure est un caractère (.c)
            MAC_compare_( PeekC(tab(i)+offset)>PeekC(TAB(i+1)+offset))
          Case #PB_Integer ; Le champ de la Structure est un integer (.i)
            MAC_compare_(PeekI(tab(i)+offset)>PeekI(TAB(i+1)+offset))
          Case #PB_Ascii   ; Le champ de la Structure est un caractère ascii (.a)
            MAC_compare_( PeekA(tab(i)+offset)>PeekA(TAB(i+1)+offset))
          Case #PB_Unicode ; Le champ de la Structure est un caractère unicode (.u)
            MAC_compare_( PeekU(tab(i)+offset)>PeekU(TAB(i+1)+offset))
        EndSelect
        ;********************************  cas du tri descendant ******************************
      Case #PB_Sort_Descending
        Select Type
          Case #PB_Byte    ; Le champ de la Structure est un octet (.b)
            MAC_compare_( PeekB(tab(i)+offset)<PeekB(TAB(i+1)+offset))
          Case #PB_Word    ; Le champ de la Structure est un word (.w)
            MAC_compare_( PeekW(tab(i)+offset)<PeekW(TAB(i+1)+offset))
          Case #PB_Long    ; Le champ de la Structure est un long (.l)
            MAC_compare_( PeekL(tab(i)+offset)<PeekL(TAB(i+1)+offset))
          Case #PB_String  ; Le champ de la Structure est un string (.s ou $)
                           ; Les strings fixe (fixed strings) ne sont pas supportées)
                           ;           Resultat$ = PeekS(*Memoire [, Longueur [, Format]])
                           ;           Format
                           ;           #PB_Ascii  : Format ASCII.
                           ;           #PB_UTF8   : Format UTF-8.
                           ;           #PB_Unicode: Format Unicode.
                           ;     Par défaut ascii
            MAC_compare_( PeekS(PeekL(tab(i)+offset))<PeekS(PeekL(tab(i+1)+offset)))
          Case #PB_Float    ; Le champ de la Structure est un flottant (.f)
            MAC_compare_( PeekF(tab(i)+offset)<PeekF(TAB(i+1)+offset))
          Case #PB_Double  ; Le champ de la Structure est un double (.d)
            MAC_compare_( PeekD(tab(i)+offset)<PeekD(TAB(i+1)+offset))
          Case #PB_Quad    ; Le champ de la Structure est un quad (.q)
            MAC_compare_( PeekQ(tab(i)+offset)<PeekQ(TAB(i+1)+offset))
          Case #PB_Character:; Le champ de la Structure est un caractère (.c)
            MAC_compare_( PeekC(tab(i)+offset)<PeekC(TAB(i+1)+offset))
          Case #PB_Integer ; Le champ de la Structure est un integer (.i)
            MAC_compare_( PeekI(tab(i)+offset)<PeekI(TAB(i+1)+offset))
          Case #PB_Ascii   ; Le champ de la Structure est un caractère ascii (.a)
            MAC_compare_( PeekA(tab(i)+offset)<PeekA(TAB(i+1)+offset))
          Case #PB_Unicode ; Le champ de la Structure est un caractère unicode (.u)
            MAC_compare_( PeekU(tab(i)+offset)<PeekU(TAB(i+1)+offset))
        EndSelect
    EndSelect
  EndProcedure
EndMacro  

;********************** Fin de toutes les macros et de la procedure TRIBULLE **********************



Procedure RandomSign()
  ProcedureReturn Random(1)*2-1
EndProcedure


For I=0 To MAXT
  Tableau(I)\Champs1=Random(9,0)*RandomSign()
  Tableau(I)\Champs2=Random(1000,100)*RandomSign()
  tableau(i)\Nom="Dupond Pierre Jean Simon"+RSet(Str(Random(MAXt,0)),3,"0")
Next
; For I = 0 To MAXT
;   Debug RSet(Str(Tableau(I)\Champs1), 3, " ") + "=> " + RSet(Str(Tableau(I)\Champs2), 4, "0")+ "  "+tableau(I)\Nom
; Next
Debug "********************  Apès Tri"
MAC_INITproc(TEST) ; Donnez le nom de la structure au tableau de la procedure TRIBULLE donne comme nom de procédure TRIBULLEtest
                   ; TRIBULLE(tableau(),OffsetOf(test\Champs1),TypeOf(test\Champs1),#PB_Sort_Descending)
                   ; TRIBULLE(tableau(),OffsetOf(test\Champs1),TypeOf(test\Champs1),#PB_Sort_Ascending)
                   ; TRIBULLE(tableau(),OffsetOf(test\Nom),TypeOf(test\Nom),#PB_Sort_Ascending)
                   ; TRIBULLE(tableau(),OffsetOf(test\Nom),TypeOf(test\Nom),#PB_Sort_Descending)
                   ; TRIBULLE(tableau(),OffsetOf(test\Champs2),TypeOf(test\Champs2),#PB_Sort_Descending)
TRIBULLEtest(tableau(),OffsetOf(test\Champs2),TypeOf(test\Champs2),#PB_Sort_Ascending)
TRIBULLEtest(tableau(),OffsetOf(test\Champs1),TypeOf(test\Champs1),#PB_Sort_Ascending)
For I=0 To MAXT
  Debug RSet(Str(Tableau(I)\Champs1),3," ")+"=> "+RSet(Str(Tableau(I)\Champs2),4,"0")+"  "+tableau(I)\Nom
Next
Debug " ******************  Deuxième Procédure avec pour structure test2 *************** "
For I=0 To MAXT
  Tableau2(I)\Taille2=Random(220,120)
  Tableau2(I)\date2=Date(Random(2018,1970),Random(12,1),Random(28,1),0,0,0)
  tableau2(i)\Nom2="Dupond2 Pierre Jean Simon"+RSet(Str(Random(MAXt,0)),3,"0")
Next
MAC_INITproc(test2) ; Donnez le nom de la structure au tableau de la procedure TRIBULLE donne comme nom de procédure TRIBULLEtest2
TRIBULLEtest2(tableau2(),OffsetOf(test2\date2),TypeOf(test2\date2),#PB_Sort_Descending)
TRIBULLEtest2(tableau2(),OffsetOf(test2\Taille2),TypeOf(test2\Taille2),#PB_Sort_Ascending)
masque$="%yyyy/%mm/%dd"
For I=0 To MAXT
  Debug RSet(Str(Tableau2(I)\Taille2),4," ")+"=> "+ FormatDate(Masque$, Tableau2(I)\date2)+"  "+tableau2(I)\Nom2
Next

A+

[Demivec]

@PAPIPP: Voici ma méthode. Contrairement à la vôtre mienne est limitée à un seul type de tri de la chaîne. Cependant, il devrait être plus rapide.


(Traduit avec l'aide de Google)

Array_MultiFieldSort.pbi:

Code : Tout sélectionner

;Program: Multi-Field Sort for Structured Arrays.
;Programme: tri d'un tableau structuré sur plusieurs champs.
;Name:  Array_MultiFieldSort.pbi
;Author: Demivec
;Date: 3/12/2012
;Written for PureBasic v4.61, updated for v5.40b3

EnableExplicit

DeclareModule amf_sort
  EnableExplicit
  
  Enumeration   
    ;The standard equality functions return one of the following comparison results.
    ;Les fonctions d'égalité standard retournent l'un des résultats de comparaison suivants.
    #isNotEqualTo = 0
    #isEqualTo
  EndEnumeration
  
  Structure sortFieldSpecs
    offset.i
    type.i
    option.i
  EndStructure
  
  Prototype.i equalityFunction(*element_1, *element_2)
  
  Global Dim *equalityFunctionAdr(0)
  
  ;A multiSort procedure will be created that includes the structure name, i.e. multiSort_struc().
  ;The procedure multiSort will have parameters {arr.struc(), sortSpecs.sortFieldSpecs() [, rangeStart, rangeEnd]}.
  ; arr.struc() is an array of the structure specified when using the create macro.
  ; sortSpecs.sortFieldSpecs() is an array that specifies each field to sort, its offset, type, and
  ; method (methods uses the same values as PB's sort functions).
  ; rangeStart and rangeEnd are optional and if either of them is specified they both
  ; must be specified.
  ;Une procédure 'multiSort_struc' sera créé qui comprend le nom de la structure, i.e. multiSort_struc().
  ;La procédure, 'multiSort_struc', aura paramètres {arr.struc(), sortSpecs() [, rangeStart, rangeEnd]}.
  ; arr.struc() est un tableau de la structure spécifiée lors de l'utilisation de la créer macro.
  ; sortSpecs.sortFieldSpecs() est un tableau qui spécifie chaque champ pour trier, son décalage, le type et
  ; la méthode (méthodes utilise les mêmes valeurs que les fonctions de tri PB) 
  ; rangeStart et rangeEnd sont facultatives et si l'un d'entre eux est spécifié qu'ils fois
  ; doit être spécifié.

  Macro mcr_createMultiSort(struc)
    ;The procedure multiSort_struc() is created for use with a specific structure.
    ;The macro has to be called for each specific structure that needs to be sorted.
    ;La procédure multiSort_struc() est créé pour être utilisé avec une structure spécifique.
    ;La macro doit être appelée pour chaque structure spécifique qui doit être trié.
    Procedure subSort_#struc(Array x.struc(1), Array sortFieldSpecs.amf_sort::sortFieldSpecs(1), sortLevel, rangeStart, rangeEnd)
      Protected i, firstElement = rangeStart, prevSortLevel = sortLevel - 1
      Protected equalityFunc.amf_sort::equalityFunction = amf_sort::*equalityFunctionAdr(sortFieldSpecs(prevSortLevel)\type)
      
      For i = rangeStart + 1 To rangeEnd
        If equalityFunc(@x(firstElement) + sortFieldSpecs(prevSortLevel)\offset, @x(i) + sortFieldSpecs(prevSortLevel)\offset) <> amf_sort::#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.amf_sort::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.
  ;Cette macro auxiliaire permet de spécifier sur une seule ligne les options de tri pour un tableau de
  ;sortFieldSpecs à un index spécifié.
  Macro mcr_setSortSpec(arrName, index, _offset, _type, _option = #PB_Sort_Ascending)
    arrName(index)\offset = _offset
    arrName(index)\type = _type
    arrName(index)\option = _option
  EndMacro  
EndDeclareModule

Module amf_sort
  ;=================================================================================
  ; 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 the second element,
  ;          otherwise it returns '#isNotEqualTo'.
  ;
  ; Note: Each equality function can only operate on one data type.  Care should be
  ;       taken so that the correct function is used.  These functions are used by
  ;       the subSort() function.
  ;=================================================================================
  ; Description: Chacune des fonctions d'égalité compare deux éléments qui sont un
  ;              type de données standard PureBasic pour l'égalité et retourne un
  ;              résultat booléen. Les éléments sont à des adresses [*element_1] et [*element_2] 
  ;
  ; Retours: Retours '#isEqualTo' si le premier élément est égale à la deuxième élément,
  ;          sinon il retourne '#isNotEqualTo'. 
  ;
  ;Remarque: Chaque fonction de l'égalité ne peut fonctionner que sur un seul type. Il faut prendre soin
  ;          de sorte que la functin correct est utilisé. Ces fonctions sont utilisées
  ;          par la fonction subSort().
    ;=================================================================================
  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 data types.
    ;A line for each parameter-constant followed by the address of its equality function.
    ;Fonctions de l'égalité pour chacun des types d'éléments standard.
    ;Données doit être présent pour chacun des types de données standard de PB.
    ;Une ligne pour chaque paramètre-constant suivi de l'adresse de sa fonction d'égalité.
    Data.i 11 ;1 based count of equality functions
    Data.i #PB_Byte     , @_isEqual_byte()     
    Data.i #PB_Word     , @_isEqual_word()     
    Data.i #PB_Long     , @_isEqual_long()     
    Data.i #PB_Integer  , @_isEqual_Integer()
    Data.i #PB_Quad     , @_isEqual_quad()     
    Data.i #PB_Float    , @_isEqual_float()    
    Data.i #PB_Double   , @_isEqual_double()   
    Data.i #PB_Ascii    , @_isEqual_ascii()    
    Data.i #PB_Character, @_isEqual_character()
    Data.i #PB_Unicode  , @_isEqual_unicode()  
    Data.i #PB_String   , @_isEqual_string()   
  EndDataSection
  
  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()
  
EndModule

Code de démonstration:

Code : Tout sélectionner

;Demonstration code for sorting a Structured Array on multiple fields.
;Code de démonstration pour le tri d'un tableau structuré sur plusieurs champs.
;Author: Demivec
;Written for PureBasic v5.40b3
;Date: 9/8/2015

EnableExplicit

IncludeFile "Array_MultiFieldSort_Module.pbi"

Structure myOwn
  a.w
  b$
  c.i
  d$
EndStructure

Procedure display_myOwn(Array x.myOwn(1), header.s = "", footer.s = "")
  Protected i, tw = 16
  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

;create procedure multiSort_myOwn()
;créer procédure multiSort_myOwn()
amf_sort::mcr_createMultiSort(myOwn) 

;setup random data
;configuration des données aléatoires
Define i, entryCount = 10000
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.
;Maintenant pour certains poids lourds tri.

;Array size should be equal to (number of fields to be sorted) - 1
;Taille de tableau doit être égal au (nombre de champs à trier) - 1
Dim myOwn_sortSpecs.amf_sort::sortFieldSpecs(3)

;index 0 is primary key, index 1 is secondary key, and so forth
;index 0 est la clé primaire, l'index 1 est la clé secondaire, etc.
amf_sort::mcr_setSortSpec(myOwn_sortSpecs, 0, OffsetOf(myOwn\d$), TypeOf(myOwn\d$), #PB_Sort_Ascending)
amf_sort::mcr_setSortSpec(myOwn_sortSpecs, 1, OffsetOf(myOwn\b$), TypeOf(myOwn\b$), #PB_Sort_Descending)
amf_sort::mcr_setSortSpec(myOwn_sortSpecs, 2, OffsetOf(myOwn\a), TypeOf(myOwn\a), #PB_Sort_Descending)
amf_sort::mcr_setSortSpec(myOwn_sortSpecs, 3, OffsetOf(myOwn\c), TypeOf(myOwn\c), #PB_Sort_Ascending)

multiSort_myOwn(myOwn(), myOwn_sortSpecs())

Debug "================================================================="
;'A' and 'D' represent ascending and descending order
;'A' and 'D' représenter ordre croissant ou décroissant
display_myOwn(myOwn(), "-- Sort by: d$ A, b$ D, a.w D, c.i A --")

[Mesa]

Un certain said utilise une base de donnée intermédiaire.
http://www.purebasic.fr/english/viewtop ... 12&t=63585

son code ici

Code : Tout sélectionner

EnableExplicit

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)
								; comparing elements i and j on each field ---> res, dlt
								; res = -1   ==> i preceeds j
								; res = +1   ==> j preceeds i
								; dlt =  0   ==> continue testing additional fields
								; dlt <> 0   ==> no need to test additional fields
								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_Integer
														dlt = PeekI(*pi) - PeekI(*pj)
														If srt_asc
																If dlt <= 0 : res = -1 : Else : res = 1 : EndIf
														Else
																If dlt >= 0 : res = -1 : Else : res = 1 : EndIf
														EndIf
														
												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
														
														If srt_asc
																If dlt <= 0 : res = -1 : Else : res = 1 : EndIf
														Else
																If dlt >= 0 : res = -1 : Else : res = 1 : EndIf
														EndIf
										EndSelect
										
										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       ; 2nd block/half is present
								s1 = e2 + 1
						EndIf
						
				Wend
				; copying back from b to a
				*p = *a + (z * RangeStart)
				CopyMemory(*b, *p, n*z)
				k = k << 1 ; k * 2
		Wend
		FreeMemory(*b)
EndProcedure

;-------------------------------------
;--- TEST ---------------------------
;-------------------------------------
CompilerIf #PB_Compiler_IsMainFile

		Structure tst
				Index.i
				Txt1.s
				Txt2.s
				Int1.i
				Int2.i
		EndStructure
		
		; routines tailored to the tst-structure !
		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
		
		Procedure IsSorted_tst(Array before.tst(1), Array after.tst(1), List FldIdxs(), List Opts(), s,e)
				; uses SQL query (ORDER BY) for checking
				; for validation we pass the field-index in the list FldIdxs() - starting at 0
				Protected   db_Idx, db_Txt1.s, db_Txt2.s, db_Int1, db_Int2, db_Flt1.f
				Protected   i, srt_asc, no_case, err
				Protected   db, tbl, sql.s, upd.s
				
				UseSQLiteDatabase()
				db = OpenDatabase(#PB_Any, ":memory:", "", "")
				If db
						sql = "CREATE TABLE T ( Idx INTEGER, Txt1 TEXT, Txt2 TEXT, Int1 INTEGER, Int2 INTEGER );"
						If Not DatabaseUpdate(db, sql)
								MessageRequester("Error"," creating table...") : ProcedureReturn
						EndIf
						
						For i=s To e
								upd = "INSERT INTO T ( Idx, Txt1, Txt2, Int1, Int2 ) VALUES ( " + 
											"'" + Str(before(i)\Index) + "'" + " , " +
											"'" + before(i)\Txt1 + "'" + " , " +
											"'" + before(i)\Txt2 + "'" + " , " +
											"'" + Str(before(i)\Int1)  + "'" + " , " +
											"'" + Str(before(i)\Int2)  + "'" + " ); "
								
								If Not DatabaseUpdate(db,upd)
										MessageRequester("Error","inserting...") : ProcedureReturn
								EndIf
						Next
						
						; building the sort query
						sql = "SELECT * FROM T ORDER BY "
						ForEach FldIdxs()
								SelectElement(Opts(), ListIndex(FldIdxs()))
								
								srt_asc = Bool( (Opts() & #PB_Sort_Descending) = 0 )
								no_case = Bool( (Opts() & #PB_Sort_NoCase) = #PB_Sort_NoCase )
								
								If ListIndex(FldIdxs()) > 0 : sql + ", " : EndIf
								Select FldIdxs()
										Case 0 : sql + " Idx "
										Case 1 : sql + " Txt1 " : If no_case : sql + " COLLATE NOCASE " : EndIf
										Case 2 : sql + " Txt2 " : If no_case : sql + " COLLATE NOCASE " : EndIf
										Case 3 : sql + " Int1 "
										Case 4 : sql + " Int2 "
								EndSelect
								If srt_asc
										sql + "ASC"
								Else
										sql + "DESC"
								EndIf
						Next
						sql + ", Idx ASC ;"
						
						; checking now with after()
						If DatabaseQuery(db, sql)
								i=s
								While NextDatabaseRow(db)
										db_Idx  = GetDatabaseLong(db, DatabaseColumnIndex(db, "Idx"))
										db_Txt1 = GetDatabaseString(db, DatabaseColumnIndex(db, "Txt1"))
										db_Txt2 = GetDatabaseString(db, DatabaseColumnIndex(db, "Txt2"))
										db_Int1 = GetDatabaseLong(db, DatabaseColumnIndex(db, "Int1"))
										db_Int2 = GetDatabaseLong(db, DatabaseColumnIndex(db, "Int2"))
										
										If db_Idx  <> after(i)\Index : err+1 : EndIf
										If db_Txt1 <> after(i)\Txt1  : err+1 : EndIf
										If db_Txt2 <> after(i)\Txt2  : err+1 : EndIf
										If db_Int1 <> after(i)\Int1  : err+1 : EndIf
										If db_Int2 <> after(i)\Int2  : err+1 : EndIf
										
										i+1
										If err
												MessageRequester("Error", "IsSorted_tst - Array Not sorted")
												ProcedureReturn
										EndIf
								Wend
								FinishDatabaseQuery(db)
						EndIf
						CloseDatabase(db)
				EndIf
				
				MessageRequester("IsSorted_tst", "Array is sorted")
		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)
		Dim t2(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
		CopyArray(t(), t2())
		
		; before
		;debug_tst(t(), ss, ee)
		
		; adding sorting fields
		AddElement(Flds()) : Flds() = OffsetOf(tst\Txt1)
		AddElement(Typs()) : Typs() = TypeOf(tst\Txt1)
		AddElement(Opts()) : Opts() = #PB_Sort_Ascending | #PB_Sort_NoCase
		
		AddElement(Flds()) : Flds() = OffsetOf(tst\Int1)
		AddElement(Typs()) : Typs() = TypeOf(tst\Int1)
		AddElement(Opts()) : Opts() = #PB_Sort_Descending
		
		AddElement(Flds()) : Flds() = OffsetOf(tst\Int2)
		AddElement(Typs()) : Typs() = TypeOf(tst\Int2)
		AddElement(Opts()) : Opts() = #PB_Sort_Ascending
		
		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 " >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>  "
		;debug_tst(t(), ss, ee)
		
		; test if array is really sorted
		Define NewList Fld_Idx()
		
		AddElement(Fld_Idx()) : Fld_Idx() = 1   ; field Txt1
		AddElement(Fld_Idx()) : Fld_Idx() = 3   ; field Int1
		AddElement(Fld_Idx()) : Fld_Idx() = 4   ; field Int1
		AddElement(Fld_Idx()) : Fld_Idx() = 2   ; field Txt2
		t0 = ElapsedMilliseconds()
		IsSorted_tst(t2(), t(), Fld_Idx(), Opts(), ss, ee)
		t0 = ElapsedMilliseconds() - t0
		MessageRequester("checking-time", Str(t0))
		
CompilerEndIf