Rubrik: Allgemein | VB-Versionen: VB6 | 15.05.08 |
Sortieralgorithmen im Vergleich Mit diesem Workshop stellen wir Ihnen 9 verschiedene Algorithmen für das Sortieren von Array-Inhalten vor und vergleichen die benötigte Zeit bei 5.000 Array-Elementen. | ||
Autor: Norbert Grimm | Bewertung: | Views: 19.683 |
Bevor wir Ihnen die einzelnen Sortierverfahren näher vorstellen, hier zunächst schon einmal vorab das Testergebnis:
|
Faktor: x-fache der ShellZeit (bez.5000 Elemente), die Shell-Methode ist der schnellste Algorithmus.
Hilfsfunktion zum Tauschen zweier Variablen
' SWAP : QuickBasic 4.5 ' : nachprogrammiert Private Function XSwap(vSortDat0 As Variant, vSortDat1 As Variant) As Integer Dim Ret As Long Dim Vorher As Variant ' Fehlerroutine On Error GoTo Err_XSwap Vorher = vSortDat1 vSortDat1 = vSortDat0 vSortDat0 = Vorher Exit_XSwap: XSwap = Ret Exit Function Err_XSwap: With Err Ret = .Number .Clear End With Resume Exit_XSwap End Function
ShellSort
Shellsort ist ein von Donald L. Shell im Jahre 1959 entwickeltes Sortierverfahren, das auf dem Sortierverfahren des direkten Einfügens (Insertionsort) basiert.
Insertionsort: (engl. insertion – das Einfügen, sort – sortieren) ist ein einfaches stabiles Sortierverfahren. Es ist weit weniger effizient als andere anspruchsvollere Sortierverfahren. Dafür hat es jedoch folgende Vorteile: Es ist einfach zu implementieren, effizient bei (ziemlich) kleinen Eingabemengen, effizient bei Eingabemengen, die schon vorsortiert sind, stabil (d.h. die Reihenfolge von schon sortierten Elementen ändert sich nicht) und minimal im Speicherverbrauch, da der Algorithmus ortsfest arbeitet. Der Algorithmus entnimmt der unsortierten Eingabefolge ein beliebiges (z.B. das erste) Element und fügt es an richtiger Stelle in die (anfangs leere) Ausgabefolge ein. Geht man hierbei in der Reihenfolge der ursprünglichen Folge vor, so ist das Verfahren stabil. Wird auf einem Array gearbeitet, so müssen die Elemente hinter dem neu eingefügten Element verschoben werden. Dies ist die eigentlich aufwändige Operation von Insertionsort, da das Finden der richtigen Einfügeposition über eine binäre Suche vergleichsweise effizient erfolgen kann.
' ============================================================================== ' Beschreibung : ' ' Die Prozedur ShellSort ist ähnlich zu der Prozedur BubbleSort. ShellSort ' startet jedoch damit, daß sie weit auseinanderliegende Elemente vergleicht ' (getrennt durch den Wert der Variablen Offset, der zu Beginn die Hälfte des ' Abstandes zwischen dem ersten und letzten Element ist) und anschließend ' Elemente vergleicht, die näher zusammenliegen (wenn Offset eins ist, ist ' die letzte Iteration dieser Prozedur gleich der Prozedur BubbleSort). ' ============================================================================== ' ' Funktion : ShellSort ' ' Parameter : vArray ' : vArray(1 to x, 1) ' : 2-dimensionales Variant_Array ' vArray(x, 0) : Position, SatzNr ' vArray(x, 1) : zu sort.Begriff ' ' Bearbeitet : Norbert.Grimm ' Function ShellSort(ByRef vArray() As Variant) As Long Dim I As Long Dim UB As Long Dim L As Long Dim Limit As Long Dim MaxZeile As Long Dim OffSet As Long Dim Tauschen As Long Dim Ret As Long Dim Min As Long Dim min0 As Variant Dim min1 As Variant ' Fehlerroutine On Error GoTo Err_ShellSort UB = UBound(vArray) ' vArray(x, 0) : Position, SatzNr ' vArray(x, 1) : zu sort.Begriff ' ' Setze den Vergleichsoffset auf die Hälfte der Satzzahl in vArray(x,1): MaxZeile = UB OffSet = MaxZeile \ 2 ' Ganzzahl_Division (Rundung nach unten) Do While OffSet > 0 ' Wiederhole, bis Offset null wird. Limit = MaxZeile - OffSet Do Tauschen = 0 ' Nimm an, daß bei diesem Offset nicht ' getauscht wird. ' Vergleiche die Elemente und vertausche diejenigen, die nicht ' in der richtigen Reihenfolge liegen: ' For I = 1 To Limit ' Min = I + OffSet ' Verwende absteigende Schleife (2-3 fach schneller als mit ' aufsteigender Logik) For I = Limit To 1 Step -1 Min = I + OffSet If vArray(I, 1) > vArray(Min, 1) Then min0 = vArray(Min, 0) ' Formulierung ist min1 = vArray(Min, 1) ' schneller als XSWAP vArray(Min, 0) = vArray(I, 0) vArray(Min, 1) = vArray(I, 1) vArray(I, 0) = min0 vArray(I, 1) = min1 Tauschen = I End If Next I ' Sortiere im nächsten Schritt nur bis dahin, wo der letzte ' Tausch durchgeführt wurde: Limit = Tauschen - OffSet Loop While Tauschen ' Kein Tausch beim letzten Offset, versuche es mit dem halbierten ' Offset: OffSet = OffSet \ 2 Loop Exit_ShellSort: ShellSort = Ret Exit Function Err_ShellSort: With Err Ret = .Number .Clear End With Resume Exit_ShellSort End Function
HeapSort
Die Prozedur HeapSort funktioniert, indem sie zwei andere Prozeduren aufruft - FilternAufw und FilternAbw. FilternAufw wandelt SortDatFeld in einen "heap" um, dessen Eigenschaften das unten
gezeigte Diagramm verdeutlicht:
' vArray(1,1) ' / \ ' vArray(2,1) vArray(3,1) ' / \ / \ ' vArray(4,1) vArray(5,1) vArray(6,1) vArray(7,1) ' / \ / \ / \ / \ ' ... ... ... ... ... ... ... ...
wobei jeder "Eltern-Knoten" größer ist als jeder seiner "Kind-Knoten"; zum Beispiel ist vArray(1,1)) größer als vArray(2,1) oder vArray(3,1), vArray(3,1) ist größer als vArray(6,1) oder
vArray(7,1) und so weiter.
Nachdem die erste FOR...NEXT-Schleife in HeapSort beendet ist, befindet sich das größte Element daher in vArray(1,1).
Die zweite FOR...NEXT-Schleife in HeapSort vertauscht das Element in (vArray(X,1) mit dem Element in MaxZeile, bildet den Heap erneut (mit FilternAbw) für MaxZeile - 1, vertauscht
anschließend das Element in (vArray(X,1) mit dem Element in MaxZeile - 1, bildet den Heap erneut für MaxZeile - 2 und fährt in dieser Art und Weise fort, bis das Datenfeld sortiert ist.
Function HeapSort(ByRef vArray() As Variant) As Long Dim I As Long Dim MaxZeile As Long Dim Ret As Long ' Fehlerroutine On Error GoTo Err_HS MaxZeile = UBound(vArray) For I = 2 To MaxZeile FilternAufw I, vArray Next I For I = MaxZeile To 2 Step -1 XSwap vArray(1, 0), vArray(I, 0) XSwap vArray(1, 1), vArray(I, 1) FilternAbw I - 1, vArray Next I Exit_HS: HeapSort = Ret Exit Function Err_HS: With Err Ret = .Number .Clear End With Resume Exit_HS End Function
' ============================== FilternAufw ================================= ' Die Prozedur FilternAufw überträgt die Elemente von 1 bis MaxEbene in ' SortDatFeld in einen "heap" (siehe das Diagramm in der Prozedur HeapSort). ' ============================================================================ ' Private Function FilternAufw(ByVal MaxEbene As Long, ByRef vArray As Variant) As Long Dim I As Long Dim Eltern As Long Dim Ret As Long ' Fehlerroutine On Error GoTo Err_Aufw I = MaxEbene ' Bewege den Wert in vArray(MaxEbene,1) solange durch den Heap nach ' oben, bis er seinen richtigen Knoten erreicht hat (das heiát, bis der ' Wert größer als irgendeiner seiner Kind-Knoten ist, oder er 1, die ' Spitze des Heaps, erreicht hat): Do Until I = 1 Eltern = I \ 2 ' Lies den Index des Eltern-Knotens. ' Der Wert des aktuellen Knotens ist noch größer als der Wert seines ' Eltern-Knotens, also vertausche diese beiden Datenfeldelemente: If vArray(I, 1) > vArray(Eltern, 1) Then XSwap vArray(Eltern, 0), vArray(I, 0) XSwap vArray(Eltern, 1), vArray(I, 1) I = Eltern ' Andernfalls hat das Element in dem Heap seine richtige Position ' erreicht, also verlasse diese Prozedur: Else Exit Do End If Loop Exit_Aufw: FilternAufw = Ret Exit Function Err_Aufw: With Err Ret = .Number .Clear End With Resume Exit_Aufw End Function
' ============================ FilternAbw ================================= ' Die Prozedur FilternAbw erzeugt mit den Elementen aus [vArray] von ' 1 bis MaxEbene erneut einen "Heap" (siehe das Diagramm in der Prozedur ' HeapSort). ' ============================================================================ ' Private Function FilternAbw(ByVal MaxEbene As Long, ByRef vArray As Variant) As Long Dim I As Long Dim Kind As Long Dim Ret As Long ' Fehlerroutine On Error GoTo Err_Abw I = 1 ' Bewege den Wert in vArray(x,1) im Heap solange nach unten, bis ' dieser seinen richtigen Knoten erreicht hat (das heißt, bis der Wert ' kleiner als sein Eltern-Knoten ist, oder bis er MaxEbene, die unterste ' Ebene des aktuellen Heaps, erreicht hat): Do Kind = 2 * I ' Ermittle den Index für den Kind-Knoten. ' Verlasse die Prozedur, wenn unterste Ebene des Heaps erreicht ist: If Kind > MaxEbene Then Exit Do ' Falls es zwei Kind-Knoten gibt, finde heraus, welcher der größere ist: If Kind + 1 <= MaxEbene Then If vArray(Kind + 1, 1) > vArray(Kind, 1) Then Kind = Kind + 1 End If End If ' Bewege den Wert nach unten, solange er noch nicht größer als ' irgendeines seiner Kinder ist: If vArray(I, 1) < vArray(Kind, 1) Then XSwap vArray(I, 0), vArray(Kind, 0) XSwap vArray(I, 1), vArray(Kind, 1) I = Kind ' Andernfalls ist [vArray] erneut als Heap von 1 bis MaxEbene ' aufgebaut, also beende: Else Exit Do End If Loop Exit_Abw: FilternAbw = Ret Exit Function Err_Abw: With Err Ret = .Number .Clear End With Resume Exit_Abw End Function
QuickSort
Der "QuickSort"-Algorithmus funktioniert, indem er ein zufälliges "Pivot"-Element aus [vArray] herausnimmt, anschließend jedes Element, das größer ist, auf eine Seite des Pivot-Elementes bewegt,
und jedes Element, das kleiner ist, auf die andere Seite bewegt. QuickSort wird dann mit den beiden Unterabteilungen, die von dem Pivot-Element erzeugt wurden, rekursiv aufgerufen. Nachdem die
Anzahl der Elemente in einer Unterabteilung einmal zwei erreicht hat, enden die rekursiven Aufrufe, und das Datenfeld ist sortiert.
Function QuickSort(ByRef vArray() As Variant, _ Optional ByVal Klein As Long, Optional ByVal Gross As Long) As Long Dim I As Long Dim J As Long Dim K As Long Dim L As Long Dim Ret As Long Dim UB As Long Dim ZI As Long Dim TS As Variant ' Fehlerroutine On Error GoTo Err_QS If Klein = 0 Then Klein = LBound(vArray) If Gross = 0 Then Gross = UBound(vArray) If Klein < Gross Then ' Nur zwei Elemente in dieser Unterabteilung; vertausche diese, wenn ' sie nicht in der richtigen Reihenfolge vorliegen und beende ' anschließend die rekursiven Aufrufe: If Gross - Klein = 1 Then If vArray(Klein, 1) > vArray(Gross, 1) Then XSwap vArray(Klein, 0), vArray(Gross, 0) XSwap vArray(Klein, 1), vArray(Gross, 1) End If Else ' Nimm ein zufälliges Pivot-Element heraus, bewege dieses dann an ' das Ende: ZI = ZufInt(Klein, Gross) XSwap vArray(Gross, 0), vArray(ZI, 0) XSwap vArray(Gross, 1), vArray(ZI, 1) TS = vArray(Gross, 1) Do ' Hinbewegung von beiden Seiten auf das Pivot-Element zu: I = Klein J = Gross Do While (vArray(I, 1) <= TS) I = I + 1 If (I > J) Then I = I - 1 Exit Do End If Loop Do While (vArray(J, 1) >= TS) J = J - 1 If (J < I) Then J = J + 1 Exit Do End If Loop ' Wird das Pivot-Element nicht erreicht, bedeutet dies, daß ' zwei Elemente auf einer Seite nicht in der richtigen Reihenfolge ' vorliegen, also vertausche diese Elemente: If I < J Then XSwap vArray(I, 0), vArray(J, 0) XSwap vArray(I, 1), vArray(J, 1) End If Loop While I < J ' Bewege das Pivot-Element zurück auf seinen richtigen Platz in ' dem Datenfeld: XSwap vArray(I, 0), vArray(Gross, 0) XSwap vArray(I, 1), vArray(Gross, 1) ' Rufe die Prozedur QuickSort rekursiv auf (übergib die kleinere ' Unterabteilung zuerst, um weniger Stapelplatz zu verwenden): If (I - Klein) < (Gross - I) Then QuickSort vArray, Klein, I - 1 QuickSort vArray, I + 1, Gross Else QuickSort vArray, I + 1, Gross QuickSort vArray, Klein, I - 1 End If End If End If Exit_QS: QuickSort = Ret Exit Function Err_QS: With Err Ret = .Number .Clear End With Resume Exit_QS End Function
Private Function ZufInt(ByVal Untere As Integer, ByVal Obere As Integer) As Integer Dim A As Integer ' Fehlerroutine On Error GoTo Err_Zuf A = Int(Rnd * (Obere - Untere + 1)) + Untere If A <= 0 Then ' A = 1 End If ZufInt = A Exit_Zuf: Exit Function Err_Zuf: Err.Clear Resume Exit_Zuf End Function
AustauschSort
Der Algorithmus "Sortieren durch Austauschen" vergleicht jedes Element in [vArray] - beginnend mit dem ersten Element - mit jedem folgenden Element. Wenn eines der nachfolgenden Elemente
kleiner ist als das aktuelle Element, wird es mit dem aktuellen Element getauscht, und der Ablauf wird mit dem nächsten Element in [vArray] wiederholt.
Function AusTauschSort(ByRef vArray() As Variant) As Long Dim I As Long Dim J As Long Dim K As Long Dim L As Long Dim Min As Long Dim Max As Long Dim Ret As Long Dim UB As Long ' Fehlerroutine On Error GoTo Err_ATS UB = UBound(vArray) Max = UB For I = 1 To Max Min = I For J = I + 1 To Max If vArray(J, 1) < vArray(Min, 1) Then Min = J End If Next J ' Es ist eine Zeile gefunden, die kleiner als die aktuelle Zeile ' ist, also vertausche diese beiden Datenfeldelemente: If Min > I Then XSwap vArray(I, 0), vArray(Min, 0) XSwap vArray(I, 1), vArray(Min, 1) End If Next I Exit_ATS: AusTauschSort = Ret Exit Function Err_ATS: With Err Ret = .Number .Clear End With Resume Exit_ATS End Function
AustauschSort_1
Diese Funktion ist doppelt zu schnell wie AutauschSort.
Function AusTauschSort_1(ByRef vArray() As Variant) As Long Dim I As Long Dim J As Long Dim K As Long Dim L As Long Dim Min As Long Dim Max As Long Dim Ret As Long Dim UB As Long Dim min0 As Variant Dim min1 As Variant ' Fehlerroutine On Error GoTo Err_ATS UB = UBound(vArray) Max = UB For I = 1 To Max Min = I For J = Max To (I + 1) Step -1 ' absteigende Schleife If vArray(J, 1) < vArray(Min, 1) Then Min = J Exit For ' wenn 1.Element gefunden End If ' Exit Schleife Next J ' Es ist eine Zeile gefunden, die kleiner als die aktuelle Zeile ' ist, also vertausche diese beiden Datenfeldelemente: If Min > I Then ' XSwap vArray(I, 0), vArray(Min, 0) ' XSwap vArray(I, 1), vArray(Min, 1) min0 = vArray(Min, 0) ' Formulierung ist min1 = vArray(Min, 1) ' schneller als XSWAP vArray(Min, 0) = vArray(I, 0) vArray(Min, 1) = vArray(I, 1) vArray(I, 0) = min0 vArray(I, 1) = min1 End If Next I Exit_ATS: AusTauschSort_1 = Ret Exit Function Err_ATS: With Err Ret = .Number .Clear End With Resume Exit_ATS End Function
VB_SortData
Um große Datenmengen zu sortieren, z.B. aus Dateien, Tabellen, usw., wird der zu sortierende Begriff(Element o. Spaltenwert) mit seiner Position(Stellung) in einem 2-dimensionalen varArray
an diese Funktion übergeben. Die Funktion sortiert den Begriff(vArray(X,1) und gibt quasi die Position(vArray(X,0) zurück.
' Algorithmus: abgewandeltes Austauschverfahren ' : sortiert aufsteigend (>) ' Function VB_SortData(ByRef vArray() As Variant) As Long Dim A As Variant Dim B As Variant Dim C As Long Dim I As Long Dim J As Long Dim K As Long Dim L As Long Dim Ret As Long Dim UB As Long Dim Z As Long Dim Min As Long Dim min0 As Variant Dim min1 As Variant Dim LX() As Variant ' Fehlerroutine On Error GoTo Err_SD UB = UBound(vArray) L = UB ReDim LX(1 To L, 1) ' dimensionieren, temp.Array For I = 1 To L ' einlesen LX(I, 0) = vArray(I, 0) ' Position, SatzNr LX(I, 1) = vArray(I, 1) ' zu sort.Begriff Next I ' #Sort For I = 1 To L Min = I A = LX(I, 1) ' zu sort.Begriff For J = L To (I + 1) Step -1 B = LX(J, 1) ' tausche wenn B < A If B < A Then Min = J Exit For ' nur bei absteigender Schleife End If Next J If Min > I Then min0 = LX(Min, 0) min1 = LX(Min, 1) LX(Min, 0) = LX(I, 0) LX(Min, 1) = LX(I, 1) LX(I, 0) = min0 LX(I, 1) = min1 End If Next I For I = 1 To L ' rückschreiben vArray(I, 0) = LX(I, 0) vArray(I, 1) = LX(I, 1) Next I ' #Sort Exit_SD: Erase LX VB_SortData = Ret Exit Function Err_SD: With Err Ret = .Number .Clear End With Resume Exit_SD End Function
EinfügeSort
Die Prozedur EinfuegeSort vergleicht nacheinander den Wert jedes Elementes in [vArray] mit den Werten aller vorhergehenden Elemente. Nachdem die Prozedur die entsprechende Position für das
neue Element gefunden hat, fügt es das Element an seinem neuen Platz ein und bewegt alle anderen Elemente um eine Position nach unten.
Function EinfuegeSort(ByRef vArray() As Variant) As Long Dim I As Long Dim J As Long Dim U As Long Dim Ret As Long Dim V0 As Variant Dim V1 As Variant ' Fehlerroutine On Error GoTo Err_Einf U = UBound(vArray) For I = 2 To U ' ursprüngliche Werte speichern V0 = vArray(I, 0) V1 = vArray(I, 1) For J = I To 2 Step -1 ' Solange die Länge des J-1sten Elementes größer als die Länge des ' ursprünglichen Elementes in vArray(I,1) ist, fahre fort, ' die Datenfeldelemente nach unten zu verschieben: If vArray(J - 1, 1) > V1 Then vArray(J, 0) = vArray(J - 1, 0) vArray(J, 1) = vArray(J - 1, 1) ' Andernfalls beende die FOR...NEXT-Schleife: Else Exit For End If Next J ' Füge den ursprünglichen Wert von vArray(i,0), vArray(i,1) in vArray(J, 0) = V0 vArray(J, 1) = V1 Next I Exit_Einf: EinfuegeSort = Ret Exit Function Err_Einf: With Err Ret = .Number .Clear End With Resume Exit_Einf End Function
BubbleSort
Der "BubbleSort"-Algorithmus durchläuft [vArray], vergleicht aufeinanderfolgende Elemente und vertauscht Paare, die nicht in der richtigen Reihenfolge vorliegen. Er fährt damit fort, bis keine
Paare mehr getauscht wurden.
Function BubbleSort(ByRef vArray() As Variant) As Long Dim I As Long Dim L As Long Dim UB As Long Dim Limit As Long Dim MaxZeile As Long Dim OffSet As Long Dim Tauschen As Long Dim Ret As Long Dim Min As Long Dim min0 As Variant Dim min1 As Variant Dim LX() As Variant ' Fehlerroutine On Error GoTo Err_Bubble UB = UBound(vArray) L = UB ReDim LX(1 To L, 1) ' dimensionieren, temp.Array For I = 1 To L 'einlesen LX(I, 0) = vArray(I, 0) ' Position, SatzNr LX(I, 1) = vArray(I, 1) ' zu sort.Begriff Next I MaxZeile = L Limit = MaxZeile Do Tauschen = 0 For I = 1 To (Limit - 1) ' Zwei aufeinanderfolgende Elemente liegen nicht in der ' richtigen Reihenfolge vor, also tausche deren Werte. Min = I + 1 If LX(I, 1) > LX(Min, 1) Then min0 = LX(Min, 0) min1 = LX(Min, 1) LX(Min, 0) = LX(I, 0) LX(Min, 1) = LX(I, 1) LX(I, 0) = min0 LX(I, 1) = min1 Tauschen = I End If Next I ' Sortiere im nächsten Schritt nur bis dahin, wo der ' letzte Tausch vorgenommen wurde: Limit = Tauschen Loop While Tauschen For I = 1 To L ' rückschreiben vArray(I, 0) = LX(I, 0) vArray(I, 1) = LX(I, 1) Next I Exit_Bubble: Erase LX BubbleSort = Ret Exit Function Err_Bubble: With Err Ret = .Number .Clear End With Resume Exit_Bubble End Function
VB_QuickSort
Function VB_QuickSort(ByRef vArray() As Variant, _ Optional ByVal LB As Long, Optional ByVal UB As Long) Dim P1 As Long Dim P2 As Long Dim PQ As Long Dim Ret As Long Dim TS As Variant Dim vTmp0 As Variant Dim vTmp1 As Variant ' Fehlerroutine On Error GoTo Err_VB_Quick If LB = 0 Then LB = LBound(vArray) If UB = 0 Then UB = UBound(vArray) P1 = LB P2 = UB PQ = (P1 + P2) \ 2 TS = vArray(PQ, 1) Do Do While (vArray(P1, 1) < TS) P1 = P1 + 1 Loop Do While (vArray(P2, 1) > TS) P2 = P2 - 1 Loop If P1 <= P2 Then vTmp0 = vArray(P1, 0) vTmp1 = vArray(P1, 1) vArray(P1, 0) = vArray(P2, 0) vArray(P1, 1) = vArray(P2, 1) vArray(P2, 0) = vTmp0 vArray(P2, 1) = vTmp1 P1 = P1 + 1 P2 = P2 - 1 End If Loop Until (P1 > P2) ' Rufe die Prozedur VB_QuickSort rekursiv auf If LB < P2 Then VB_QuickSort vArray, LB, P2 End If If P1 < UB Then VB_QuickSort vArray, P1, UB End If Exit_VB_Quick: VB_QuickSort = Ret Exit Function Err_VB_Quick: With Err Ret = .Number .Clear End With Resume Exit_VB_Quick End Function