VBA – A* search algorithm with Excel – Really?
Today, some hours ago I saw the implementation of the A* search algorithm with Java, made by a classmate (or colleague) of mine. It looks like this:
Thus, I have thought that for the reading of the Python Algorithm book, it may be a good idea to remember how algorithms were made 🙂 Thus, instead of using Python, which makes a lot of things easy, provides outstanding and easy to use lists, dictionaries and anything a VBA programmer may dream of, I have decided to make a tribute to the good old VBA.
Before continuing, I remember that I have not mentioned the Hack Bulgaria Conference in Sofia, so I have to fix this bug a little. If by any chance you are going to Sofia on 18.09.2015 then this is a must-see! 🙂
Back to the VBA. So, what did I do? At first I have started to go around the net to see whether someone has something similar. Nothing similar with VBA was found at the first page of the Google results, thus I have decided to dedicate my evening for this. (Actually two evenings, as far as at the end I have somehow deleted the code).
So, I have been able at the end to provide the following beautiful picture of the A* path finding:
So, how does it work? You “create” the obstacles in the path finder with simply selecting the cells, which you want to be obstacles. Then you start the macro, and it sets automatically the start and end points on the two corners (red is start, green is end). In order to set different dimensions for the labyrinth, you may adjust the two constant values for C_COLUMNS and C_ROWS.
I have decided not to use arrays, because I do not like the way Excel treats them (true story), thus the whole data for the “cost” of the possible achieving of the result, plus the “parent” cell were simply written in the excel file within the cell.
Thus, the visualization was better. 🙂 At the end, once the path was found, I simply went back, coloring the “parents” of the cell.
The code has really plenty of points for improvement:
- Its size can be really made 2-3 times less;
- I have to make the font colors in the same color as the background colors
- The A* implementation can be improved. It does not select the best path always, I am aware of it. This is because I am ignoring the rule, that the diagonal cells cost 14 units and the straight cells cost just 10. When I have time, I will fix it. Or not.
Pretty much that is it. And the funny moment now – as far as I was really tired yesterday, when I was writing this article, somehow I have forgotten to save the Excel as *.xlsm and I have lost the code. Thus, I have decided to recode it today 🙂 Yup, the only more insane thing than writing A* algorithm with Excel is writing it twice.
But now I have the code, plus 2-3 nice pictures. Here they are:
The start (walls are simply selection in Excel – you know, press control)
The A* is running
The End
So, pretty much that is all. Here comes the code of the app and the app itself (I would not download a script file from any internet site, thus think twice before doing so) and the GitHub code.
Option Explicit
Public Const C_COLUMNS = 60
Public Const C_ROWS = 20
Public cell_start As Range
Public cell_end As Range
Public Sub Main()
Dim cell_current As Range
Dim l_smallest_path As Long
Dim l_col As Long
Dim l_C_ROWS As Long
Call Reset
Set cell_current = cell_start
Do While True
If check_for_success(cell_current) Then Exit Do
Set cell_current = find_possible_smallest_path(cell_current)
cell_current.Style = "Input"
Loop
Do While True
cell_current.Style = "Accent2"
If check_for_success(cell_current, False) Then Exit Do
Set cell_current = Range(Split(cell_current, "*")(0))
Loop
Call AdvertiseHere
Set cell_start = Nothing
Set cell_end = Nothing
Set cell_current = Nothing
End Sub
Public Sub Reset()
Dim sName As String
Cells.Delete
Range(Cells(1, 1), Cells(C_ROWS, C_COLUMNS)).Name = "Playground"
Set cell_start = Cells(1, 1)
Set cell_end = Cells(C_ROWS, C_COLUMNS)
[playground].Style = "Neutral"
[playground].RowHeight = 14
[playground].ColumnWidth = 2.3
[playground].WrapText = True
Call MakeProblems
cell_start.Style = "Bad"
cell_end.Style = "Good"
End Sub
Public Sub AdvertiseHere()
Range(Cells(C_ROWS + 1, 1), Cells(C_ROWS + 1, C_COLUMNS)).Merge
Range(Cells(C_ROWS + 1, 1), Cells(C_ROWS + 1, C_COLUMNS)) = "Vitoshacademy.com!"
Range(Cells(C_ROWS + 1, 1), Cells(C_ROWS + 1, C_COLUMNS)).HorizontalAlignment = xlCenter
End Sub
Public Sub MakeProblems()
Selection.Style = "Accent1"
End Sub
Public Function check_for_success(ByRef cell_current As Range, Optional b_going_back As Boolean = True) As Boolean
Dim my_cell As Range
'3
If cell_current.Column < C_COLUMNS Then
Set my_cell = cell_current.Offset(0, 1)
check_for_success = ChangeCellData(my_cell, b_going_back, cell_current)
If check_for_success Then Exit Function
End If
'4.5
If cell_current.Column < C_COLUMNS And cell_current.Row < C_ROWS Then
Set my_cell = cell_current.Offset(1, 1)
check_for_success = ChangeCellData(my_cell, b_going_back, cell_current)
If check_for_success Then Exit Function
End If
'6
If cell_current.Row < C_ROWS Then
Set my_cell = cell_current.Offset(1, 0)
check_for_success = ChangeCellData(my_cell, b_going_back, cell_current)
If check_for_success Then Exit Function
End If
'7.5
If cell_current.Column > 1 And cell_current.Row < C_ROWS Then
Set my_cell = cell_current.Offset(1, -1)
check_for_success = ChangeCellData(my_cell, b_going_back, cell_current)
If check_for_success Then Exit Function
End If
'9
If cell_current.Column > 1 Then
Set my_cell = cell_current.Offset(0, -1)
check_for_success = ChangeCellData(my_cell, b_going_back, cell_current)
If check_for_success Then Exit Function
End If
'11.5
If cell_current.Column > 1 And cell_current.Row > 1 Then
Set my_cell = cell_current.Offset(-1, -1)
check_for_success = ChangeCellData(my_cell, b_going_back, cell_current)
If check_for_success Then Exit Function
End If
'12
If cell_current.Row > 1 Then
Set my_cell = cell_current.Offset(-1, 0)
check_for_success = ChangeCellData(my_cell, b_going_back, cell_current)
If check_for_success Then Exit Function
End If
'1.5
If cell_current.Column < C_COLUMNS And cell_current.Row > 1 Then
Set my_cell = cell_current.Offset(-1, 1)
check_for_success = ChangeCellData(my_cell, b_going_back, cell_current)
If check_for_success Then Exit Function
End If
Set my_cell = Nothing
End Function
Public Function ChangeCellData(ByRef my_cell As Range, ByRef b_going_back As Boolean, cell_current As Range) As Boolean
If my_cell.Style = IIf(b_going_back, "Good", "Bad") Then ChangeCellData = True
If my_cell.Style = "Neutral" Then
my_cell.Style = "Calculation"
my_cell = cell_current.Address & "*" & distance_to_success(my_cell)
End If
End Function
Public Sub ColorNeighbours(cell_current)
End Sub
Public Function distance_to_success(my_cell As Range) As Long
distance_to_success = Abs(my_cell.Row - cell_end.Row) + Abs(my_cell.Column - cell_end.Column)
End Function
Public Function find_possible_smallest_path(ByRef current_cell As Range) As Range
Dim my_cell As Range
Dim my_result_cell As Range
Dim l_result As Long
l_result = 1000000000
Set my_result_cell = Nothing
For Each my_cell In [playground]
If my_cell.Style = "Calculation" Then
If Split(my_cell, "*")(1) < l_result Then
l_result = Split(my_cell, "*")(1)
Set my_result_cell = my_cell
End If
End If
Next my_cell
Set find_possible_smallest_path = my_result_cell
Set my_result_cell = Nothing
End Function
Enjoy it! 🙂