XProfan

' (Teil-)Sortieren von Arrays
' ---------------------------
' QuickSort_Long Long_Array&[], min&, max&
' QuickSort_Str String_Array&[], min&, max&, CaseSense%
'    Wenn CaseSense ungleich Null ist, dann werden
'    die Strings als Lower$()-Werte verglichen.
' Teil-Sortieren von Listen
' -------------------------
' QuickSort_List ListHandle&, min&, max&, CaseSense%, IsNum%
'    Wenn ListHandle& = 0, dann Listbox-Liste.
'    Wenn IsNum ungleich Null ist, dann werden
'    die Werte mittels Val() verglichen -- sonst... --
'       Wenn CaseSense ungleich Null ist, dann werden
'       die Strings als Lower$()-Werte verglichen.
'=================================================
'=================================================
' (Teil-)Sortieren von Arrays
' ---------------------------
' QuickSort_Long Long_Array&[], min&, max&

Proc QuickSort_Long

    Parameters Arr&[], Low&, High&
    Declare i&, j&, hilf&, mitte&
    i& = Low&
    j& = High&
    mitte& = Arr&[@Int((Low& + High&) / 2)]

    While i& <= j&

        While Arr&[i&] < mitte&

            Inc i&

        EndWhile

        While Arr&[j&] > mitte&

            Dec j&

        EndWhile

        If i& <= j&

            hilf& = Arr&[i&]
            Arr&[i&] = Arr&[j&]
            Arr&[j&] = hilf&
            Inc i&
            Dec j&

        EndIf

    EndWhile

    If Low& < j&

        QuickSort_Long Arr&[], Low&, j&

    EndIf

    If i& < High&

        QuickSort_Long Arr&[], i&, High&

    EndIf

EndProc

' (Teil-)Sortieren von Arrays
' ---------------------------
' QuickSort_Str String_Array&[], min&, max&, CaseSense%
'    Wenn CaseSense ungleich Null ist, dann werden
'    die Strings als Lower$()-Werte verglichen.

Proc QuickSort_Str

    Parameters Arr$[], Low&, High&, CaseSense%
    Declare i&, j&, hilf$, mitte$

    Proc QS_GetStr$

        Parameters Wert$
        Return If( CaseSense% <> 0, Lower$(Wert$), Wert$ )

    EndProc

    i& = Low&
    j& = High&
    mitte$ = QS_GetStr$(Arr$[@Int((Low& + High&) / 2)])

    While i& <= j&

        While QS_GetStr$(Arr$[i&]) < mitte$

            Inc i&

        EndWhile

        While QS_GetStr$(Arr$[j&]) > mitte$

            Dec j&

        EndWhile

        If i& <= j&

            hilf$ = Arr$[i&]
            Arr$[i&] = Arr$[j&]
            Arr$[j&] = hilf$
            Inc i&
            Dec j&

        EndIf

    EndWhile

    If Low& < j&

        QuickSort_Str Arr$[], Low&, j&, CaseSense%

    EndIf

    If i& < High&

        QuickSort_Str Arr$[], i&, High&, CaseSense%

    EndIf

EndProc

' Teil-Sortieren von Listen
' -------------------------
' QuickSort_List ListHandle&, min&, max&, CaseSense%, IsNum%
'    Wenn ListHandle& = 0, dann Listbox-Liste.
'    Wenn IsNum ungleich Null ist, dann werden
'    die Werte mittels Val() verglichen -- sonst... --
'       Wenn CaseSense ungleich Null ist, dann werden
'       die Strings als Lower$()-Werte verglichen.

Proc QuickSort_List

    Parameters ListHandle&, Low&, High&, CaseSense%, IsNum%
    Declare i&, j&, hilfS$, mitteS$, hilfL&, mitteL&, tmp$

    Proc QS_Get

        Parameters Idx&, Ori%

        If Ori%

            Return GetString$(ListHandle&, Idx&)

        Else

            If IsNum%

                Return Val(GetString$(ListHandle&, Idx&))

            Else

                ' noch ein Sortiertrick - die Umlaute umsetzen
                tmp$ = GetString$(ListHandle&, Idx&)
                tmp$ = Translate$(tmp$,"Ä","Ae")
                tmp$ = Translate$(tmp$,"Ö","Oe")
                tmp$ = Translate$(tmp$,"Ü","Ue")
                tmp$ = Translate$(tmp$,"ä","ae")
                tmp$ = Translate$(tmp$,"ö","oe")
                tmp$ = Translate$(tmp$,"ü","ue")
                tmp$ = Translate$(tmp$,"ß","ss")
                Return If( CaseSense% <> 0, Lower$(tmp$), tmp$ )

            EndIf

        EndIf

    EndProc

    Proc QS_Put

        Parameters Idx&, Wert$
        ReplaceString(ListHandle&, Idx&, Wert$)

    EndProc

    i& = Low&
    j& = High&

    If IsNum%

        mitteL& = QS_Get(@Int((Low& + High&) / 2), 0)

    Else

        mitteS$ = QS_Get(@Int((Low& + High&) / 2), 0)

    EndIf

    While i& <= j&

        If IsNum%

            While QS_Get(i&,0) < mitteL&

                Inc i&

            EndWhile

            While QS_Get(j&,0) > mitteL&

                Dec j&

            EndWhile

        Else

            While QS_Get(i&,0) < mitteS$

                Inc i&

            EndWhile

            While QS_Get(j&,0) > mitteS$

                Dec j&

            EndWhile

        EndIf

        If i& <= j&

            hilfS$ = QS_Get(i&,1)
            QS_Put(i&, QS_Get(j&,1))
            QS_Put(j&, hilfS$)
            Inc i&
            Dec j&

        EndIf

    EndWhile

    If Low& < j&

        QuickSort_List ListHandle&, Low&, j&, CaseSense%, IsNum%

    EndIf

    If i& < High&

        QuickSort_List ListHandle&, i&, High&, CaseSense%, IsNum%

    EndIf

EndProc

'=================================================
' TEST TEST TEST TEST TEST TEST TEST TEST
cls
declare s$[], n&[]
print "Der Sortierbereich ist in Klammern angegeben:\n"
print " aus: Zitrone,Orange,Banane,Apfel   (0..3)\n"
print "wird:";
s$[] = explode("Zitrone,Orange,Banane,Apfel", ",")
QuickSort_Str s$[], 0, 3, 0

WhileLoop 0, SizeOf(s$[]) - 1

    Print " ";s$[&Loop];

EndWhile

Print "."
waitkey
print "\n\n aus: Zitrone,Orange,Banane,Apfel   (1..2)\n"
print "wird:";
s$[] = explode("Zitrone,Orange,Banane,Apfel", ",")
QuickSort_Str s$[], 1, 2, 0

WhileLoop 0, SizeOf(s$[]) - 1

    Case &Loop = 1 : Color 12,15
    Case &Loop = 3 : Color  0,15
    Print " ";s$[&Loop];

EndWhile

Print "."
waitkey
print "\n...jetzt LongInt...\n"
print " aus: 37;81;19;7;12;24;80   (0..6)\n"
print "wird:";
n&[0]=37:n&[1]=81:n&[2]=19:n&[3]=7:n&[4]=12:n&[5]=24:n&[6]=80
QuickSort_Long n&[], 0, 6

WhileLoop 0, SizeOf(n&[]) - 1

    Print " ";n&[&Loop];

EndWhile

Print "."
waitkey
print "\n\n aus: 37;81;19;7;12;24;80   (2..4)\n"
print "wird:";
n&[0]=37:n&[1]=81:n&[2]=19:n&[3]=7:n&[4]=12:n&[5]=24:n&[6]=80
QuickSort_Long n&[], 2, 4

WhileLoop 0, SizeOf(n&[]) - 1

    Case &Loop = 2 : Color 12,15
    Case &Loop = 5 : Color  0,15
    Print " ";n&[&Loop];

EndWhile

Print "."
waitkey
cls
print "\n...jetzt Listenbereich (3..7), danach Gesamt...\n"
print " aus: Emil,Dora,Cäsar,Berta,Ärger,Anton,Xaver,Franz,Friedrich,Helga,Otto,Paul\n"
print "wird:";
declare hliste&
hListe& = 0' Listbox-Liste
ClearList hListe&
MoveStrToList("Emil,Dora,Cäsar,Berta,Ärger,Anton,Xaver,Franz,Friedrich,Helga,Otto,Paul", ",")
QuickSort_List hListe&, 3, 7, 1, 0

WhileLoop 0, GetCount(hListe&) - 1

    Case &Loop = 3 : Color 12,15
    Case &Loop = 8 : Color  0,15
    Print " ";GetString$(hListe&, &Loop);

EndWhile

Print "."
waitkey
print "\n\n aus: Emil,Dora,Cäsar,Berta,Ärger,Anton,Xaver,Franz,Friedrich,Helga,Otto,Paul\n"
print "wird:";
ClearList hListe&
MoveStrToList("Emil,Dora,Cäsar,Berta,Ärger,Anton,Xaver,Franz,Friedrich,Helga,Otto,Paul", ",")
QuickSort_List hListe&, 0, (GetCount(hListe&) - 1), 1, 0

WhileLoop 0, GetCount(hListe&) - 1

    Print " ";GetString$(hListe&, &Loop=s2>);

EndWhile

Print "."
waitkey
End