Hello,
I'm using the BinarySearch algorithm to get the index of particular items in a sorted UDT array.
I want the index values of the first occurrence of three items in the UDT - column, row, objectType.
Only the first item I am after is correct.
(not coincidently I guess because this item is sorted first in the array)
Any guidance as to how to correct this?
Form1 Code:
Code:
Option Explicit
Private Sub Form_Load()
Command1.Caption = "Run"
End Sub
Private Sub Command1_Click()
Call LoadTestData01
Dim o As Long 'object counter
'-----------------------------------------------------------------------------------------
' Print obj for inspection (UNSORTED)
Debug.Print "----------------------------------------------------------------------------"
Debug.Print "obj() array UNSORTED"
Debug.Print "----------------------------------------------------------------------------"
Debug.Print "ndx Column Row ObjectType"
For o = 1 To UBound(obj)
Debug.Print "[" & o & "]", _
obj(o).Position.col, obj(o).Position.row, _
"|" & obj(o).objectType & "|"
Next o
'-----------------------------------------------------------------------------------------
' Sort obj array
Call HeapSortGridObject(obj)
'----------------------------------------------------------------------------------------
' Print obj for inspection (SORTED)
Debug.Print "----------------------------------------------------------------------------"
Debug.Print "obj() array SORTED"
Debug.Print "----------------------------------------------------------------------------"
Debug.Print "ndx Column Row ObjectType"
For o = 1 To UBound(obj)
Debug.Print "[" & o & "]", _
obj(o).Position.col, obj(o).Position.row, _
"|" & obj(o).objectType & "|"
Next o
'-----------------------------------------------------------------------------------------
'-----------------------------------------------------------------------------------------
' Get Indexes
Dim col As Long
Dim row As Long
Dim objectType As String
col = 31
row = 3
objectType = "Bar"
MsgBox "First occurrence of Column " & col & " at index " & _
BinarySearchForColumn(obj, col)
MsgBox "First occurrence of Row " & row & " at index " & _
BinarySearchForRow(obj, row)
MsgBox "First occurrence of objectType " & objectType & " at index " & _
BinarySearchForObjectType(obj, objectType)
'-------------------------------------------------------------------------------------------
End Sub
Private Sub LoadTestData01()
ReDim obj(1 To 7)
obj(1).Position.col = 322
obj(1).Position.row = 7
obj(1).objectType = "Note"
obj(2).Position.col = 17
obj(2).Position.row = 3
obj(2).objectType = "Bar"
obj(3).Position.col = 12
obj(3).Position.row = 15
obj(3).objectType = "Note"
obj(4).Position.col = 48
obj(4).Position.row = 12
obj(4).objectType = "Bar"
obj(5).Position.col = 19
obj(5).Position.row = 8
obj(5).objectType = "Note"
obj(6).Position.col = 19
obj(6).Position.row = 5
obj(6).objectType = "Note"
obj(7).Position.col = 31
obj(7).Position.row = 6
obj(7).objectType = "Note"
End Sub
Module1 Code:
Code:
Option Explicit
'-----------------------------------
Public Type GridPosition
col As Long
row As Long
End Type
'-----------------------------------
'-----------------------------------
Public Type GridObject
objectType As String * 32
Position As GridPosition
glyphNum As Long
End Type
Public obj() As GridObject
'-----------------------------------
Module2 Code:
Code:
Option Explicit
'-----------------------------------------------------------------------------------------------
' Heap Sort Routines
' HeapSort (SiftDown) set for: 1-base/ascending/3-item sort
Public Sub HeapSortGridObject(ByRef Items() As GridObject)
Dim last As Long
Dim Temp As GridObject
HeapifyGridObject Items, UBound(Items)
For last = UBound(Items) To 2 Step -1
Temp = Items(last)
Items(last) = Items(1)
Items(1) = Temp
SiftDownGridObject Items, 1, last - 1
Next
End Sub
Private Sub HeapifyGridObject(ByRef Items() As GridObject, _
ByVal count As Long)
Dim Start As Long
For Start = count \ 2 To 1 Step -1
SiftDownGridObject Items, Start, count
Next
End Sub
Private Sub SiftDownGridObject(ByRef Items() As GridObject, _
ByVal Start As Long, ByVal last As Long)
Dim Root As Long
Dim Child As Long
Dim Swap As Long
Dim Comp As Integer
Dim Temp As GridObject
'-------------------------------------------------------------------------------------------
'-------------------------------------------------------------------------------------------
' Sort on 3 fields (.Position.Col then .Position.Row then .objectType)
Root = Start
Do While Root * 2 <= last
Child = Root * 2
Swap = Root
Comp = Sgn(Items(Swap).Position.col - Items(Child).Position.col)
If Comp = 0 Then
Comp = Sgn(Items(Swap).Position.row - Items(Child).Position.row)
If Comp = 0 Then
Comp = Sgn(Items(Swap).objectType - Items(Child).objectType)
End If
End If
If Comp < 0 Then Swap = Child
If Child + 1 <= last Then
Comp = Sgn(Items(Swap).Position.col - Items(Child + 1).Position.col)
If Comp = 0 Then
Comp = Sgn(Items(Swap).Position.row - Items(Child + 1).Position.row)
If Comp = 0 Then
Comp = Sgn(Items(Swap).objectType - Items(Child + 1).objectType)
End If
End If
If Comp < 0 Then Swap = Child + 1
End If
If Swap <> Root Then
Temp = Items(Root)
Items(Root) = Items(Swap)
Items(Swap) = Temp
Root = Swap
Else
Exit Do
End If
Loop
'-------------------------------------------------------------------------------------------
End Sub
Module3 Code:
Code:
Option Explicit
Public Function BinarySearchForColumn(aSorted() As GridObject, key As Long) As Long
' (iterative) binary search algorithm (or half-interval search algorithm)
' finds position of a specified input value (search key) within an array sorted by key value
' algorithm modified to insert at leftmost position
' if the key value appears one or more times in the array
Dim minIndex As Long 'Integer
Dim maxIndex As Long 'Integer
Dim midIndex As Long 'Integer
minIndex = 1 '0
maxIndex = UBound(aSorted) - 1
Do While minIndex <= maxIndex
midIndex = Int((minIndex + maxIndex) / 2)
If key <= aSorted(midIndex).Position.col Then
maxIndex = midIndex - 1
Else
minIndex = midIndex + 1
End If
Loop
' key not found; insert at minIndex
BinarySearchForColumn = minIndex
End Function
Public Function BinarySearchForRow(aSorted() As GridObject, key As Long) As Long
' (iterative) binary search algorithm (or half-interval search algorithm)
' finds position of a specified input value (search key) within an array sorted by key value
' algorithm modified to insert at leftmost position
' if the key value appears one or more times in the array
Dim minIndex As Long 'Integer
Dim maxIndex As Long 'Integer
Dim midIndex As Long 'Integer
minIndex = 1 '0
maxIndex = UBound(aSorted) - 1
Do While minIndex <= maxIndex
midIndex = Int((minIndex + maxIndex) / 2)
If key <= aSorted(midIndex).Position.row Then
maxIndex = midIndex - 1
Else
minIndex = midIndex + 1
End If
Loop
' key not found; insert at minIndex
BinarySearchForRow = minIndex
End Function
Public Function BinarySearchForObjectType(aSorted() As GridObject, key As String) As Long
' (iterative) binary search algorithm (or half-interval search algorithm)
' finds position of a specified input value (search key) within an array sorted by key value
' algorithm modified to insert at leftmost position
' if the key value appears one or more times in the array
Dim minIndex As Long 'Integer
Dim maxIndex As Long 'Integer
Dim midIndex As Long 'Integer
minIndex = 1 '0
maxIndex = UBound(aSorted) - 1
Do While minIndex <= maxIndex
midIndex = Int((minIndex + maxIndex) / 2)
If key <= aSorted(midIndex).objectType Then
maxIndex = midIndex - 1
Else
minIndex = midIndex + 1
End If
Loop
' key not found; insert at minIndex
BinarySearchForObjectType = minIndex
End Function