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
zur raschen Suche von Eintragungen in einer Liste for quick search of items in a list

Das Programm sucht und findet nur in einer bereits sortierten Liste, es macht einen Unterschied zwischen einem gefundenen Wort und der Position, an dem das gesuchte Wort einzuordnen wäre, wenn es nicht gefunden wird.

Das Programm sucht mittels eines binären Verfahrens, bei welchem die Anzahl der Suchschritte pro gesamter Liste statt durchschnittlich n/2 (n = Anzahl der Eintragungen) nur log2(n) ist. Man sieht daraus, daß die Zeitersparnis umso größer ist, je länger die Länge der Liste ist auch wenn ein Suchschritt nur 1 Mikrosekunde dauert, wenn man aber viele tausend Eintragungen sucht, kann das schon eine lange Suchzeit benötigen, z.B. bei einer Liste mit 65536 Eintragungen sind statt durchschnittlich 32768 nur 16 Suchschritte nötig, Voraussetzung ist aber, daß die Eintragungen bereits sortiert sein müssen.

In vbScript sind alle Variable variants, d.h. daß man schreiben kann:

x = 17: x = "asdf": x = 9    und das wird funktionieren oder man kann schreiben:

MyArray = Array(17,"asdf",9,"jklm")    oder man kann schreiben:

MyArray(2) = 17: MyArray(2) = "asdf": MyArray(2) = 26    etc.

Aber man kann nicht Elemente suchen oder sortieren in einer Liste, wenn nicht alle Elemente und das Suchwort von der derselben Type sind, entweder alle numeric oder alle stringtype. In diesem Programm ist das gewährleistet.

The program seeks and finds only in a sorted list, it makes a distinction between a found word and the position, at which the seeked word should be sorted in, if it cannot be found.

The program seeks by means of a binary procedure, by which there is the number of seeksteps per list instead of average n/2 (n = number of items) only log2(n). One sees from it, that there is the time-saving the more, the longer there is the list. Even if one seekstep needs only 1 Microsecond, but if one seeks several thousand times, that can take a long searchtime, for instance by a list of 65536 items there are instead of average 32768 only 16 searchsteps necessary, but the precondition is, that the items must be sorted before.

In vbScript all variables are variants, that means that you can write:

x = 17: x = "asdf": x = 9    and this will work or you can write:

MyArray = Array(17,"asdf",9,"jklm")    or you can write:

MyArray(2) = 17: MyArray(2) = "asdf": MyArray(2) = 26    etc.

But you cannot find or sort elements in a list, if not all elements and the seekword are of the same type, either all are numeric or all are stringtype. In this program this is warranted.

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
8. Aug. 2012 Aug 8th 2012

' QuickFind

Option Explicit

' Declarations of Constants and Variables

Const Up = 1, Down = -1, Numeric = 1, StringType = 2 ' Constants
Dim ListLength, UpPos, Pos, SortDirection, TypeOfVariable, TestCase, MsgBoxResponse ' Numerics
Dim Msg, Title ' Strings
Dim SeekWord, nr ' Variants
Dim WordFound  ' Booleans
Dim List, Result, SeekWordList, SeekWordListCopy ' Arrays

' User-Parameter-Definitions

ListLength = 30
SeekWordList = Array(0,150,155,320)

' Program

For TestCase = 1 To 6 ' Testprogram for all cases, which can occur
    Select Case TestCase
        Case 1: ReDim List(-1): UpPos = ListLength
        Case 2: ReDim List(ListLength): UpPos = UBound(List) + 1
        SortDirection = Up: TypeOfVariable = Numeric
        Case Else: ReDim List(ListLength): UpPos = UBound(List)
    End Select
    Select Case TestCase
        Case 3: SortDirection = Up: TypeOfVariable = Numeric
        Case 4: SortDirection = Down: TypeOfVariable = Numeric
        Case 5: SortDirection = Up: TypeOfVariable = StringType
        Case 6: SortDirection = Down: TypeOfVariable = StringType
    End Select
    List = LoadArrayWithContent(SortDirection, TypeOfVariable)

    SeekWordListCopy = CopyList(SeekWordList, TypeOfVariable)
    If TestCase < 3 Then ReDim Preserve SeekWordListCopy(0)

    For Each SeekWord In SeekWordListCopy
        Msg = "Lenght of generated list: " & UBound(List) & ",   Selected UpPos: " _
        & UpPos & vbCrLf & "Seeked Word: >" & SeekWord & "< " & vbCrLf

        ' ---------------  Code for Single Quickfind ----------------

        Result = QuickFind(SortDirection, List, UpPos, SeekWord)
        ' SortDirection can be Up (or Down), Up and Down are numeric constants
        ' UpPos = uppest position of search-elements within the list
        ' the lowest Position is zero

        ' Principle structure of evaluation

        Pos = Result(0): WordFound = Result(1)
        If Pos = -1 Then ' It did not work, WordFound irrelevant
            RunSomeProgramCode 1
        Else ' Pos found
            If WordFound Then
                RunSomeProgramCode 2
            Else
                RunSomeProgramCode 2
            End If
        End If

        ' ------------  End of Code for Single Quickfind ------------

        Title = "TestCase " & CStr(TestCase) & " of 6"
        If TestCase > 2 Then Title = Title & ",   SeekWord: " & SeekWord
        MsgBoxResponse = MsgBox (Msg,1,Title) ' Display Result
        If MsgBoxResponse = 2 Then Exit For
    Next: If MsgBoxResponse = 2 Then Exit For
Next

' End of Program

' Procedures

Function LoadArrayWithContent(SortDirection, TypeOfVariable)
    Dim i, TmpArray: ReDim TmpArray(UBound(List))
    For i = 0 To UBound(List)
        If SortDirection = Up Then nr = CStr(10*i+10)
        If SortDirection = Down Then nr = CStr(10*(UBound(List)-i)+10)
        If TypeOfVariable = Numeric Then TmpArray(i) = nr
        If TypeOfVariable = StringType Then
            While Len(nr)< 3
                nr = "0" & nr
            Wend: TmpArray(i) = "message-" & nr
        End If
    Next: LoadArrayWithContent = TmpArray
End Function

Function QuickFind(SortSortDirection, ByVal AnyArray, UpPos, SeekWord)
    ' Find a seeked word in an array acceleratedly by a search-algorithm
    '    with a binary stepped step-size
    ' Precondition is, that the content of the array must be sorted
    ' It makes the distinction between Word found and Pos found,
    '    where the word could be sorted in
    ' If word not found the Function returns Pos to sort in and
    '    CmpOp = -SortSortDirection (WordFound = False)
    ' Pos = 1 ... n in AnyArray(0 ... n-1) -> n maximal UBound(AnyArray) + 1
    ' Values for SortSortDirection "Up" = +1,  "Down" = -1 only allowed
    Dim n, k, Offset, SD, Pos, CmpOp: Pos = 0: CmpOp = 0: SD = SortSortDirection
    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(SeekWord, 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(SeekWord, 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

Sub RunSomeProgramCode(AnyTask)
    Select Case AnyTask
        Case 1
        Msg = Msg & "Pos: " & CStr(Pos) & _
        ", WordFound = " & WordFound & ", but WordFound irrelevant" & _
        vbCrLf & "no list extant or UpPos out of array"
        Case 2
        If WordFound Then ' Word found and Pos
            Msg = Msg & "Pos found, Word found "
        Else ' only Pos found to sort in
            Msg = Msg & "Pos found, Word not found -> next Pos, next Word"
        End If
        Msg = Msg & vbCrLf & "Pos: " & CStr(Pos) & ", Word: >"
        If Pos <= UBound(List) Then    Msg = Msg & List(Pos) ' Found Pos out of Array
        Msg = Msg & "<" & vbCrLf & "WordFound : """ & WordFound & """" & _
        vbCrLf & vbCrLf & Join(List,vbCrLf)
    End Select
End Sub

Function CopyList(SeekWordList, TypeOfVariable)
    Dim i, x, ListLen, TmpArray: ListLen= UBound(SeekWordList)
    ReDim TmpArray(ListLen)
    For i = 0 To ListLen: x = SeekWordList(i)
        If TypeOfVariable = Numeric Then TmpArray(i) = x
        If TypeOfVariable = StringType Then
            x = CStr(x)
            While Len(x) < 3
                x = "0" & x
            Wend: TmpArray(i) = "message-" & x
        End If
    Next: CopyList = TmpArray
End Function

' End of Procedures