Binary Search Array Macro, First, Last, UDT, Object

[Theo Gottwald]

Updated array binary search macro.
Supports finding first or last instance.
The second version supports a custom compare callback.
It can also be used for binary search on a UDT or Object array.

Source: Powerbasic Forum

Code Select Expand

'BinarySearch.inc
#If Not %Def(%BinarySearch230812)
    %BinarySearch230812 = 1

    'Binary Search Macro
    'array must be sorted
    'macro must be on independent line of code to allow it to expand

    'return index if found
    'return one less than LBound(ARR) if not found

    'if IsTrue FINDFIRST then first instance found
    'if IsTrue FINDLAST then last instance found

    'Public domain, use at own risk. SDurham

    Macro Function BinarySearch(ARR,VALUE,FINDFIRST,FINDLAST)
        MacroTemp x, i, j, top, bot
        Register i As Long
        Register j As Long
        Local x, top, bot As Long
        top = UBound(ARR)
        bot = LBound(ARR)
        x = LBound(ARR) - 1
        While top >= bot
            i = (bot + top) \ 2
            If VALUE > ARR(i) Then
                bot = i + 1
            ElseIf VALUE < ARR(i) Then
                top = i - 1
            Else
                x = i
                If IsTrue FINDFIRST Then
                    For j = i - 1 To LBound(ARR) Step -1
                        If ARR(j) = VALUE Then
                            x = j
                        Else
                            Exit For
                        End If
                    Next i
                ElseIf IsTrue FINDLAST Then
                    For j = i + 1 To UBound(ARR)
                        If ARR(j) = VALUE Then
                            x = j
                        Else
                            Exit For
                        End If
                    Next j
                End If
                Exit Loop
            End If
        Wend
    End Macro = x

    'Binary search using compare callback.
    'Compare callback must be a macro, handles different data types.

    'Sample compare callback.
    'You can roll your on.
    'Can also act as a query by sorting a range of values to the beginning of the array.
    '   A < B : return < 0
    '   A = B : return = 0
    '   A > B : return > 0
    Macro Function CustomCompareCallback(A,B)
        MacroTemp result
        Local result As Long
        If A < B Then
            result = -1
        ElseIf A > B Then
            result = 1
        Else
            result = 0
        End If
    End Macro = result

    Macro Function BinarySearchUsing(ARR,VALUE,COMPARECALLBACK,FINDFIRST,FINDLAST)
        MacroTemp x, i, j, top, bot, compare
        Register i As Long
        Register j As Long
        Local x, top, bot, compare As Long
        top = UBound(ARR)
        bot = LBound(ARR)
        x = LBound(ARR) - 1
        While top >= bot
            i = (bot + top) \ 2
            compare = COMPARECALLBACK(VALUE, ARR(i))
            If compare > 0 Then
                bot = i + 1
            ElseIf compare < 0 Then
                top = i - 1
            Else
                x = i
                If IsTrue FINDFIRST Then
                    For j = i - 1 To LBound(ARR) Step -1
                        compare = COMPARECALLBACK(VALUE, ARR(j))
                        If compare = 0 Then
                            x = j
                        Else
                            Exit For
                        End If
                    Next i
                ElseIf IsTrue FINDLAST Then
                    For j = i + 1 To UBound(ARR)
                        compare = COMPARECALLBACK(VALUE, ARR(j))
                        If compare = 0 Then
                            x = j
                        Else
                            Exit For
                        End If
                    Next j
                End If
                Exit Loop
            End If
        Wend
    End Macro = x
#EndIf '%BinarySearch230812



Test-Code:

Code Select Expand

'BinarySearch.bas
#Option LargeMem32
#Compile Exe
#Dim All

#Include "BinarySearch.inc"

Function PBMain() As Long
    Register i As Long

    Local h&, outFile$, hprocess&
    h& = FreeFile
    outFile$ = Exe.Path$ + Exe.Name$ + ".txt"
    Kill outFile$
    Open outFile$ For Append As h&

    Randomize

    Local x As Long
    Local a() As Long
    ReDim a(-5 To 5)
    For i = -5 To 5
        a(i) = Rnd(1, 8)
    Next i
    Array Sort a()


    For i = -5 To 5
        Print# h&, "index "+Format$(i)+" = " + Format$(a(i))
    Next i


    Print# h&, ""
    Print# h&, "return one less than LBound(array) if not found, -6 "

    Print# h&, ""
    For i = 1 To 8
        'put macro in independent line so it can expand
        x = BinarySearch(a,i,0,0)
        Print# h&, "binary search for "+Format$(i)+" = " + Format$(x)
    Next i

    Print# h&, ""
    For i = 1 To 8
        x = BinarySearch(a,i,1,0)
        Print# h&, "first instance of "+Format$(i)+" = " + Format$(x)
    Next i

    Print# h&, ""
    For i = 1 To 8
        x = BinarySearch(a,i,0,1)
        Print# h&, "last instance of "+Format$(i)+" = " + Format$(x)
    Next i

    Print# h&, ""
    Print# h&, ""
    Print# h&, "Using custom compare callback."
    Print# h&, ""

    For i = -5 To 5
        a(i) = Rnd(1, 8)
    Next i
    Array Sort a()

    Print# h&, ""
    For i = -5 To 5
        Print# h&, "index "+Format$(i)+" = " + Format$(a(i))
    Next i

    Print# h&, ""
    For i = 1 To 8
        x = BinarySearchUsing(a,i,CustomCompareCallback,0,0)
        Print# h&, "binary search for "+Format$(i)+" = " + Format$(x)
    Next i

    Print# h&, ""
    For i = 1 To 8
        x = BinarySearchUsing(a,i,CustomCompareCallback,1,0)
        Print# h&, "first instance of "+Format$(i)+" = " + Format$(x)
    Next i

    Print# h&, ""
    For i = 1 To 8
        x = BinarySearchUsing(a,i,CustomCompareCallback,0,1)
        Print# h&, "last instance of "+Format$(i)+" = " + Format$(x)
    Next i

    Print# h&, ""
    Print# h&, ""

    Close h&
    Sleep 1
    hprocess& = Shell("notepad.exe " + outFile$, 1)
End Function�

More:

Code Select Expand

'UdtBinarySearch
#Option LargeMem32
#Compile Exe
#Dim All

#Include "BinarySearch.inc"

Type TestT
    X As Long
End Type

Macro Function TestCompareCallback(A,B)
    MacroTemp result
    Local result As Long
    If A.X < B.X Then
        result = -1
    ElseIf A.X > B.X Then
        result = 1
    Else
        result = 0
    End If
End Macro = result

Function PBMain() As Long
    Register i As Long

    Local h&, outFile$, hprocess&
    h& = FreeFile
    outFile$ = Exe.Path$ + Exe.Name$ + ".txt"
    Kill outFile$
    Open outFile$ For Append As h&

    Local t As TestT
    Local x As Long

    Local a() As TestT
    ReDim a(1 To 9)
    a(1).X = 1
    a(2).X = 1
    a(3).X = 2
    a(4).X = 4
    a(5).X = 4
    a(6).X = 4
    a(7).X = 5
    a(8).X = 5
    a(9).X = 5

    Print# h&, ""
    For i = 1 To 9
        Print# h&, "index "+Format$(i)+" = " + Format$(a(i).X)
    Next i

    Print# h&, ""
    Print# h&, "return one less than LBound(array) if not found, 0 "

    Print# h&, ""
    For i = 1 To 5
        t.X = i
        'put macro in independent line so it can expand
        x = BinarySearchUsing(a,t,TestCompareCallback,0,0)
        Print# h&, "binary search for "+Format$(t.X)+" = " + Format$(x)
    Next i

    Print# h&, ""
    For i = 1 To 5
        t.X = i
        x = BinarySearchUsing(a,t,TestCompareCallback,1,0)
        Print# h&, "first instance of "+Format$(t.X)+" = " + Format$(x)
    Next i

    Print# h&, ""
    For i = 1 To 5
        t.X = i
        x = BinarySearchUsing(a,t,TestCompareCallback,0,1)
        Print# h&, "last instance of "+Format$(t.X)+" = " + Format$(x)
    Next i

    Print# h&, ""
    Print# h&, ""

    Close h&
    Sleep 1
    hprocess& = Shell("notepad.exe " + outFile$, 1)
End Function�


More:

Code Select Expand

'ObjBinarySearch.bas
#Option LargeMem32
#Compile Exe
#Dim All

#Include "BinarySearch.inc"

Class TestC
    Instance X_ As Long
    Interface TestI : Inherit IUnknown
        Property Get X() As  Long
            Property = X_
        End Property
        Property Set X(ByVal value As Long)
            X_ = value
        End Property
    End Interface
End Class

Macro Function TestCompareCallback(A,B)
    MacroTemp result
    Local result As Long
    If IsObject(A) And IsObject(B) Then
        If A.X < B.X Then
            result = -1
        ElseIf A.X > B.X Then
            result = 1
        Else
            result = 0
        End If
    End If
End Macro = result

Function PBMain() As Long
    Register i As Long

    Local h&, outFile$, hprocess&
    h& = FreeFile
    outFile$ = Exe.Path$ + Exe.Name$ + ".txt"
    Kill outFile$
    Open outFile$ For Append As h&

    Local x As Long
    Local findObject As TestI : findObject = Class "TestC"

    Local a() As TestI
    Dim a(1 To 9)
    For i = 1 To 9
        a(i) = Class "TestC"
    Next i
    a(1).X = 1
    a(2).X = 1
    a(3).X = 2
    a(4).X = 2
    a(5).X = 4
    a(6).X = 4
    a(7).X = 4
    a(8).X = 5
    a(9).X = 5

    For i = 1 To 9
        Print# h&, "index "+Format$(i)+" = " + Format$(a(i).X)
    Next i

    Print# h&, ""
    Print# h&, "return one less than LBound(array) if not found, 0 "

    Print# h&, ""
    For i = 1 To 5
        findObject.X = i
        'put macro in independent line so it can expand
        x = BinarySearchUsing(a,findObject,TestCompareCallback,0,0)
        Print# h&, "binary search for "+Format$(findObject.X)+" = " + Format$(x)
    Next i

    Print# h&, ""
    For i = 1 To 5
        findObject.X = i
        x = BinarySearchUsing(a,findObject,TestCompareCallback,1,0)
        Print# h&, "first instance of  "+Format$(findObject.X)+" = " + Format$(x)
    Next i

    Print# h&, ""
    For i = 1 To 5
        findObject.X = i
        x = BinarySearchUsing(a,findObject,TestCompareCallback,0,1)
        Print# h&, "last instance of  "+Format$(findObject.X)+" = " + Format$(x)
    Next i

    Print# h&, ""
    Print# h&, ""

    Close h&
    Sleep 1
    hprocess& = Shell("notepad.exe " + outFile$, 1)
End Function�