Tipp-Upload: VB 5/6 0088: flexibler Sortieren mit OOP und Interfaces

von OlimilO

Hinweis zum Tippvorschlag

Dieser Vorschlag wurde noch nicht auf Sinn und Inhalt überprüft und die Zip-Datei wurde noch nicht auf schädlichen Inhalt hin untersucht.
Bitte haben Sie ein wenig Geduld, bis die Freigabe erfolgt.

Über den Tipp

Dieser Tippvorschlag ist noch unbewertet.

Der Vorschlag ist in den folgenden Kategorien zu finden:

Mathematik
Sonstiges

Dem Tippvorschlag wurden folgende Schlüsselwörter zugeordnet:
Sortieren OOP Interfaces, Heapsort, QuickSort

Der Vorschlag wurde erstellt am: 31.08.2007 11:25.
Die letzte Aktualisierung erfolgte am 31.08.2007 11:46.

Zurück zur Übersicht

Beschreibung

Fast genauso wie in Helge Rex's Tutorial über Interfaces, wird hier gezeigt wie man mit OOP flexibleren Code im Zusammenhang mit altbekannten Sortierverfahren bekommt. Um dem Beispiel etwas Sinn zu verleihen, kann man gleichzeitig die Arbeit der Sortierverfahren QuickSort und HeapSort verfolgen, da eine ganz einfache Animation eingebaut wurde.
Siehe auch die Tipps:
* "Arrays benutzerdef. Typen beliebig sortieren mit QuickSort"
* "Arrays benutzerdef. Typen nach bel. Reihenfolge sortieren mit HeapSort"

Schwierigkeitsgrad

Schwierigkeitsgrad 1

Verwendete API-Aufrufe:

RtlMoveMemory, RtlZeroMemory, Sleep, VarPtr (ArrPtr)

Download:

Download des Beispielprojektes [6,79 KB]

' Dieser Source stammt von http://www.activevb.de
' und kann frei verwendet werden. Für eventuelle Schäden
' wird nicht gehaftet.

' Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
' Ansonsten viel Spaß und Erfolg mit diesem Source!

' ------------- Anfang Projektdatei Projekt1.vbp -------------

' --------- Anfang Formular "Form1" alias Form1.frm  ---------

' Steuerelement: Kombinationsliste "CmbSorters"
' Steuerelement: Kontrollkästchen-Steuerelement "ChkDescending"
' Steuerelement: Schaltfläche "BtnSort"
' Steuerelement: Schaltfläche "BtnUndoSort"
' Steuerelement: Listen-Steuerelement "List1"

Option Explicit

Private WithEvents mLngArr As LongArray

Private mSavedLngArr As LongArray

Private Sub Form_Load()

    Set mLngArr = New LongArray
    Randomize

    Call mLngArr.SetLength(25)
    Call mLngArr.RandomizeMe(10)

    Set mSavedLngArr = mLngArr.Clone

    Call mLngArr.ToListBox(List1)
    Call FillCmbSorters

End Sub

Private Sub FillCmbSorters()

    With CmbSorters
        .AddItem "QuickSort"
        .AddItem "HeapSort"
        .ListIndex = 0
    End With

End Sub

Private Sub BtnSort_Click()

    Dim s As ISorter: Set s = GetSorter

    If Not s Is Nothing Then

        Call mLngArr.Sort(GetSortDirection, s)
        Call mLngArr.ToListBox(List1)

    End If

End Sub

Private Sub BtnUndoSort_Click()

    Call mSavedLngArr.CopyTo(mLngArr)
    Call mLngArr.ToListBox(List1)

End Sub

Private Function GetSortDirection() As SortDirection

    GetSortDirection = IIf (ChkDescending.Value = vbChecked, SortDirection_Descending, _
        SortDirection_Ascending)

End Function

Private Function GetSorter() As ISorter

    Select Case CmbSorters.ListIndex

    Case 0: Set GetSorter = New_QuickSorter(mLngArr, mLngArr)
    Case 1: Set GetSorter = New_HeapSorter(mLngArr, mLngArr)

    End Select

End Function

Private Sub mLngArr_BeforeSwap(ByVal i1 As Long, ByVal i2 As Long)

    List1.Selected(i1) = True
    List1.Selected(i2) = True

    Call Sleep(100)

End Sub

Private Sub mLngArr_AfterSwap(ByVal i1 As Long, ByVal i2 As Long)

    List1.Selected(i1) = False
    List1.Selected(i2) = False

    Call mLngArr.ToListBox(List1)
    Call Sleep(500)

End Sub

' ---------- Ende Formular "Form1" alias Form1.frm  ----------

' --- Anfang Modul "ModConstructors" alias ModConstructors.bas ---

Option Explicit

' QuickSorter
Public Function New_QuickSorter(aCmp As IComparable, _
                                aSwp As ISwappable) As QuickSorter

    Set New_QuickSorter = New QuickSorter

    Call New_QuickSorter.NewC(aCmp, aSwp)

End Function

' HeapSorter
Public Function New_HeapSorter(aCmp As IComparable, _
                                aSwp As ISwappable) As HeapSorter

    Set New_HeapSorter = New HeapSorter

    Call New_HeapSorter.NewC(aCmp, aSwp)

End Function

' --- Ende Modul "ModConstructors" alias ModConstructors.bas ---

' ------- Anfang Modul "ModSystem" alias ModSystem.bas -------

Option Explicit

Public Enum SortDirection
    SortDirection_Ascending = 0
    SortDirection_Descending = 1
End Enum

Public Declare Sub Sleep Lib "kernel32" ( _
                   ByVal dwMilliSecs As Long)

Public Declare Function ArrPtr Lib "msvbvm60" _
                        Alias "VarPtr" ( _
                        ByRef pArr() As Any) As Long

Public Declare Sub RtlMoveMemory Lib "kernel32" ( _
                   ByRef pDst As Long, _
                   ByRef pSrc As Long, _
                   ByVal bLen As Long)

Public Declare Sub RtlZeroMemory Lib "kernel32" ( _
                   ByRef pDst As Long, _
                   ByVal bLen As Long)

' Math
Public Function MaxL(Val1 As Long, Val2 As Long) As Long

    If Val1 > Val2 Then MaxL = Val1 Else MaxL = Val2

End Function

' String
Public Function PadRight(StrVal As String, _
                         ByVal totalWidth As Long, _
                         Optional ByVal paddingChar As String) As String

    ' der String wird mit der angegebenen Länge zurückgegeben, der
    ' String wird nach links gerückt, und rechts mit PadChar aufgefüllt
    ' ist PadChar nicht angegeben, so wird mit LSet der String in
    ' Spaces eingefügt.
    If Len(paddingChar) Then

        If Len(StrVal) <= totalWidth Then PadRight = StrVal & String$(totalWidth - Len( _
            StrVal), paddingChar)

    Else
        PadRight = Space$(totalWidth)
        LSet PadRight = StrVal
    End If

End Function

Public Function PadLeft(StrVal As String, _
                        ByVal totalWidth As Long, _
                        Optional ByVal paddingChar As String) As String

    ' der String wird mit der angegebenen Länge zurückgegeben, der
    ' String wird nach rechts gerückt, und links mit PadChar aufgefüllt
    ' ist PadChar nicht angegeben, so wird mit RSet der String in
    ' Spaces eingefügt.
    If Len(paddingChar) Then

        If Len(StrVal) <= totalWidth Then PadLeft = String$(totalWidth - Len(StrVal), _
            paddingChar) & StrVal

    Else
        PadLeft = Space$(totalWidth)
        RSet PadLeft = StrVal
    End If

End Function

' Achtung diese Prozeduren nicht mit String-Arrays verwenden!
Public Property Let pArr(ByVal pDst As Long, ByVal pSrc As Long)

    Call RtlMoveMemory(ByVal pDst, ByVal pSrc, ByVal 4)

End Property

Public Property Get pArr(ByVal pDst As Long) As Long

    Call RtlMoveMemory(ByVal VarPtr(pArr), ByVal pDst, ByVal 4)

End Property

Public Sub ZeroArrPtr(ByVal pDstArr As Long)

    Call RtlZeroMemory(ByVal pDstArr, ByVal 4)

End Sub

' -------- Ende Modul "ModSystem" alias ModSystem.bas --------

' ---- Anfang Klasse "IComparable" alias IComparable.cls  ----

Option Explicit

Public Function Compare(ByVal i1 As Long, ByVal i2 As Long) As Long

End Function

' ----- Ende Klasse "IComparable" alias IComparable.cls  -----

' ----- Anfang Klasse "ISwappable" alias ISwappable.cls  -----

Option Explicit

Public Sub Swap(ByVal i1 As Long, ByVal i2 As Long)

End Sub

' ------ Ende Klasse "ISwappable" alias ISwappable.cls  ------

' ------ Anfang Klasse "LongArray" alias LongArray.cls  ------

Option Explicit

Implements IComparable
Implements ISwappable

Private mLngArr() As Long
Private mSD As SortDirection

Public Event BeforeSwap(ByVal i1 As Long, ByVal i2 As Long)
Public Event AfterSwap(ByVal i1 As Long, ByVal i2 As Long)

Public Sub SetLength(ByVal Length As Long)

    ReDim mLngArr(0 To Length - 1)

End Sub

Public Sub RandomizeMe(Optional r As Long)

    Dim i As Long
    Dim n As Long: n = UBound(mLngArr)

    If r = 0 Then r = n

    For i = 0 To n
        mLngArr(i) = r * Rnd
    Next

End Sub

Public Property Get pArray() As Long

    pArray = ArrPtr(mLngArr)

End Property

Public Sub ToListBox(aLB As ListBox)

    aLB.Clear

    Dim i As Long

    For i = LBound(mLngArr) To UBound(mLngArr)

        Call aLB.AddItem(String$(mLngArr(i), "*"))

    Next

End Sub

Public Sub Sort(ByVal aSD As SortDirection, Sorter As ISorter)

    mSD = aSD

    Call Sorter.Sort(LBound(mLngArr), UBound(mLngArr))

End Sub

Public Function Clone() As LongArray

    Set Clone = New LongArray

    ' Der Typ des Arrays ist nur hier in der Klasse selber bekannt
    Dim LArr() As Long

    LArr = mLngArr
    pArr(Clone.pArray) = ArrPtr(LArr)

    Call ZeroArrPtr(ArrPtr(LArr))

End Function

Public Sub CopyTo(aLngArr As LongArray)

    Dim LArr() As Long

    pArr(ArrPtr(LArr)) = aLngArr.pArray
    LArr = mLngArr

    Call ZeroArrPtr(ArrPtr(LArr))

End Sub

Private Function IComparable_Compare(ByVal i1 As Long, _
                                     ByVal i2 As Long) As Long

    If mLngArr(i1) > mLngArr(i2) Then
        IComparable_Compare = 1
    ElseIf mLngArr(i1) < mLngArr(i2) Then
        IComparable_Compare = -1
    End If

    If IComparable_Compare <> 0 Then
        If mSD = SortDirection_Descending Then
            IComparable_Compare = -1 * IComparable_Compare
        End If
    End If

End Function

Private Sub ISwappable_Swap(ByVal i1 As Long, _
                            ByVal i2 As Long)

    Dim ltemp As Long

    RaiseEvent BeforeSwap(i1, i2)

    DoEvents

    ltemp = mLngArr(i1)
    mLngArr(i1) = mLngArr(i2)
    mLngArr(i2) = ltemp
    RaiseEvent AfterSwap(i1, i2)

    DoEvents

End Sub

' ------- Ende Klasse "LongArray" alias LongArray.cls  -------

' -------- Anfang Klasse "ISorter" alias ISorter.cls  --------

Option Explicit

Public Sub Sort(ByVal i1 As Long, ByVal i2 As Long)

End Sub

' --------- Ende Klasse "ISorter" alias ISorter.cls  ---------

' ---- Anfang Klasse "QuickSorter" alias QuickSorter.cls  ----

Option Explicit

Implements ISorter

' Diese Sortierklasse ist unabhängig von den Daten die
' sortert werden sollen, da die Datenrelevanten Methoden
' Compare und Swap aus dem Sortierverfahren ausgelagert
' wurden
Private mCmp As IComparable
Private mSwp As ISwappable

Public Sub NewC(aCmp As IComparable, aSwp As ISwappable)

    Set mCmp = aCmp
    Set mSwp = aSwp

End Sub

Public Sub Sort(ByVal i1 As Long, ByVal i2 As Long)

    Call QuickSort(i1, i2)

End Sub

Private Sub ISorter_Sort(ByVal i1 As Long, ByVal i2 As Long)

    Call QuickSort(i1, i2)

End Sub

' Die Rekursive datenunabhängige Methode QuickSort
Private Sub QuickSort(ByVal i1 As Long, ByVal i2 As Long)

    Dim t As Long

    If i2 > i1 Then
        t = divide(i1, i2)

        Call QuickSort(i1, t - 1)
        Call QuickSort(t + 1, i2)

    End If

End Sub

Private Function divide(ByVal i1 As Long, ByVal i2 As Long) As Long

    Dim i As Long, j As Long, p As Long
    i = i1 - 1
    j = i2
    p = j

    Do
        Do
            i = i + 1
        Loop While (mCmp.Compare(i, p) < 0)

        Do
            j = j - 1
        Loop While ((i1 < j) And (mCmp.Compare(p, j) < 0))

        If i < j Then Call mSwp.Swap(i, j)
    Loop While (i < j)

    Call mSwp.Swap(i, p)

    divide = i

End Function

' ----- Ende Klasse "QuickSorter" alias QuickSorter.cls  -----

' ----- Anfang Klasse "HeapSorter" alias HeapSorter.cls  -----

Option Explicit

Implements ISorter

' Diese Sortierklasse ist unabhängig von den Daten die
' sortert werden sollen, da die Datenrelevanten Methoden
' Compare und Swap aus dem Sortierverfahren ausgelagert
' wurden
Private mCmp As IComparable
Private mSwp As ISwappable
Private mI1  As Long

Public Sub NewC(aCmp As IComparable, aSwp As ISwappable)

    Set mCmp = aCmp
    Set mSwp = aSwp

End Sub

Public Sub Sort(ByVal i1 As Long, ByVal i2 As Long)

    Call HeapSort(i1, i2)

End Sub

Private Sub ISorter_Sort(ByVal i1 As Long, ByVal i2 As Long)

    Call HeapSort(i1, i2)

End Sub

Private Sub HeapSort(ByVal i1 As Long, ByVal i2 As Long)

    mI1 = i1

    Dim n As Long
    n = i2 - i1 + 1

    ' Debug.Print "BuildHeap"
    Call BuildHeap(n)

    ' Debug.Print "SortHeap"
    Dim i As Long

    For i = n - 1 To 0 Step -1

        Call XSwap(i, 0)
        Call DownHeap(0, i)

    Next

End Sub

Private Sub BuildHeap(ByVal n As Long)

    Dim i As Long

    For i = n / 2 - 1 To 0 Step -1

        Call DownHeap(i, n)

    Next

End Sub

Private Sub DownHeap(ByVal i As Long, ByVal n As Long)

    Debug.Print "  DownHeap"

    Dim w As Long

    While (i <= (n / 2) - 1)
        w = ((i + 1) * 2) - 1

        If w + 1 <= n - 1 Then
            If XComp(w, w + 1) < 0 Then
                w = w + 1
            End If
        End If

        If XComp(i, w) < 0 Then

            Call XSwap(i, w)

            i = w
        Else

            Exit Sub

        End If

    Wend

End Sub

Private Function XComp(ByVal i1 As Long, ByVal i2 As Long) As Long

    XComp = mCmp.Compare(mI1 + i1, mI1 + i2)

End Function

Private Sub XSwap(ByVal i1 As Long, ByVal i2 As Long)

    Call mSwp.Swap(mI1 + i1, mI1 + i2)

End Sub

' ------ Ende Klasse "HeapSorter" alias HeapSorter.cls  ------

' -------------- Ende Projektdatei Projekt1.vbp --------------

Diskussion

Diese Funktion ermöglicht es, Fragen, die die Veröffentlichung des Tipps betreffen, zu klären, oder Anregungen und Verbesserungsvorschläge einzubringen. Nach der Veröffentlichung des Tipps werden diese Beiträge nicht weiter verlinkt. Allgemeine Fragen zum Inhalt sollten daher hier nicht geklärt werden.

Um eine Diskussion eröffnen zu können, müssen sie angemeldet sein.