Logo Foltyn Presentation
Table of Contents Previous Page Next Page
Content-Symbol-Img
Ein Programm in der Programmiersprache A program in the programming language
vbScript
zum Sortieren mittels QuickFind, einem raschen Binärsuchverfahren zum Einsortieren for search by means of QuickFind, a quick binary seek-procedure for sorting in

Aus einem Stapel von unsortierten Elementen wird eines nach dem anderen genommen, in einem Stapel von sortierten Elementen die Position gesucht zum Einsortieren, dann werden alle restlichen Sortierten um eine Position hinaufgeschoben und das Element hinein platziert. Und das wiederholt, bis alle Unsortierten abgearbeitet sind.

Out of a pile of unsorted elements, one after another is taken, in a pile of sorted elements seeked the position for sorting in, then all remaining sorted displaced for one position upwards and the element placed in. And this repeated until all unsorted are worked off.

Das Programm ist getestet vor der Publikation, aber es kann keine Garantie gegeben werden, dass es fehlerfrei ist
The program ist tested before publication, but there can be given no guarantee, that it is free of errors
7. Aug. 2012 Aug 7th 2012

' Sort by Quickfind

Option Explicit

' Declaration of Constants and Arrays

Const Up = 1, Down = -1
Dim SortedList, List: ReDim List(30)

' Program (Demonstration of the Sort-Procedure)

List = CreateList(List, True) ' List with numeric elements
SortedList = SortByQuickFind(Up, List)
DisplayResult List, SortedList, "Up", True

SortedList = SortByQuickFind(Down, List)
DisplayResult List, SortedList, "Up", True

List = CreateList(List, False) ' List with not-numeric elements
SortedList = SortByQuickFind(Up, List)
DisplayResult List, SortedList, "Down", False

SortedList = SortByQuickFind(Down, List)
DisplayResult List, SortedList, "Down", False

' End of Program

' Procedures

Function CreateList(List, ListTypeNumeric)
    ' Load Array with content
    Dim i, nr: Randomize
    For i = 0 To UBound(List): nr = Int(100 * Rnd + 1)
        If ListTypeNumeric Then
            List(i) = nr
        Else
            nr = CStr(nr)
            While Len(nr)< 3
                nr = "0" & nr
            Wend: List(i) = "msg-" & nr
        End If
    Next: CreateList = List
End Function

Sub DisplayResult(List, SortedList, SortDir, Numeric)
    Dim i, TmpVar, DisplayList
    ReDim DisplayList(UBound(List))
    For i = 0 To UBound(List)
        If IsNumeric(List(i)) Then TmpVar = CStr(List(i)) Else TmpVar = List(i)
        TmpVar = TmpVar & Space(20-2*Len(TmpVar))'
        If IsNumeric(SortedList(i)) Then
            TmpVar = TmpVar & CStr(SortedList(i))
        Else
            TmpVar = TmpVar & SortedList(i)
        End If: DisplayList(i) = TmpVar
    Next
    MsgBox "Sortdirection " & SortDir & ", Numeric = " & Numeric & vbCrLf & _
    Join(DisplayList,vbCrLf) & "< end of data",,"Unsorted and Sorted"
End Sub

' Quick-Sort-Procedures

Function SortByQuickFind(SortDirection, ByVal AnyArray)
    ' Sorts Strings and Numerics
    ' SortDirection is without function, only handed over to QuickFind
    Dim FirstUnsorted, FoundPos, Pos, SeekedWord
    For FirstUnsorted = 1 To UBound(AnyArray)
        FoundPos = QuickFind(SortDirection, AnyArray, FirstUnsorted - 1, AnyArray(FirstUnsorted))(0)
        If FoundPos = -1 Then Exit For
        If FoundPos <> FirstUnsorted Then
            SeekedWord = AnyArray(FirstUnsorted)
            For Pos = FirstUnsorted - 1 To FoundPos Step -1
                AnyArray(Pos+1) = AnyArray(Pos)
            Next: AnyArray(FoundPos)= SeekedWord
        End If
    Next: SortByQuickFind = AnyArray
End Function

Function QuickFind(SortDirection, ByVal AnyArray, UpPos, SeekedWord)
    Dim n, k, Offset, SD, Pos, CmpOp: Pos = 0: CmpOp = 0: SD = SortDirection
    If UBound(AnyArray) > -1 And UpPos <= UBound(AnyArray) And Abs(SD) = 1 Then
        Pos = 1: n = UpPos + 1
        While Pos < n
            Pos = 2 * Pos
        Wend: If Pos > n Then Pos = Pos\2 ' Highest possible Power of 2 contained in n
        Offset = Pos
        Do: k = -1
            If Pos <= n Then
                CmpOp = Comp(SeekedWord, AnyArray(Pos-1))
                If CmpOp = 0 Then Exit Do
                If CmpOp = SD Then k = 1: If Pos = n Then Exit Do
            End If
            If Offset = 1 Then CmpOp = Comp(SeekedWord, AnyArray(Pos-1)): Exit Do
            Offset = Offset \ 2: Pos = Pos + k * Offset
        Loop: If CmpOp = SD Then CmpOp = -SD: Pos = Pos + 1
    End If: QuickFind = Array(Pos - 1, CmpOp = 0)
End Function

Function Comp(ByVal AnyVar1, ByVal AnyVar2)
    ' The vb-Script-Function StrComp() is not useful for numerics
    Comp = 0
    If IsNumeric(AnyVar1) And IsNumeric(AnyVar2) Then
        Comp = Sgn(AnyVar1 - AnyVar2)
    ElseIf IsNumeric(AnyVar1) <> IsNumeric(AnyVar2) Then ' must not occor
    else
        If AnyVar1 > AnyVar2 Then Comp = 1
        If AnyVar1 < AnyVar2 Then Comp = -1
    End if
End Function

' End of Procedures