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 (https://forum.powerbasic.com/forum/user-to-user-discussions/source-code/825729-binary-search-array-macro-first-last-udt-object)
'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:
'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:
'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:
'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�