Here is my code! I've posted it in the Projects Thread already but...
[syntax="qbasic"]
DefInt A-Z
'$Dynamic
Declare Sub ClearScreen()
Declare Sub DrawScreen()
Declare Sub FindPath()
Declare Sub AddToOpen(x As Integer, y As Integer)
Declare Sub AddToClosed(x As Integer, y As Integer)
Declare Sub AddToPath(x As Integer, y As Integer)
Declare Function IsOnOpen(x As Integer, y As Integer)
Declare Function IsOnClosed(x As Integer, y As Integer)
const Ground = 0
const Hill = 2
const Water = 1
const Wall = 4
const Start = 6
const Finish = 5
const False = 0
const True = Not False
const GroundCost = 10
const HillCost = 25
const WaterCost = 50
Type SquareType
fScore As Integer
gScore As Integer
hScore As Integer
mType As Integer
pX As Integer
pY As Integer
End Type
Type PointType
x As Integer
y As Integer
End Type
cls
Screen 18
Open "board.brd" For Input As #1
Input #1, sWidth, sHeight
Dim Shared Map(sWidth, sHeight) As SquareType
Dim Shared OpenList() As PointType
Dim Shared ClosedList() As PointType
Dim Shared Path() As PointType
Dim Shared mStart As PointType
Dim Shared mFinish As PointType
Dim Shared comp As PointType
For y = 1 To sHeight
For x = 1 To sWidth
Input #1, Map(x,y).mType
If Map(x,y).mType = Finish Then
mFinish.x = x
mFinish.y = y
ElseIf Map(x,y).mType = Start Then
mStart.x = x
mStart.y = y
End If
Next x
Next y
Close #1
Print "Finding Path"
FindPath
Print "Path Found"
sleep
ClearScreen
DrawScreen
Sleep
End
Sub FindPath()
'A* pathfinding Algorithm
Dim c As PointType 'Current Square
Dim onFinish As Integer
c.x = mStart.x 'Set the current square to
c.y = mStart.y 'the start square coord.
Do While onFinish = False 'Do this while we have not found the Finish square
AddToClosed c.x, c.y 'Add the current square to the Closed list
For y = -1 to 1
For x = -1 to 1
If Not Map((c.x + x),(c.y+y)).mType = Wall Then 'If it is not a Wall square
If (IsOnClosed((c.x + x),(c.y + y))) = False Then 'If it is not on the Closed List
If (IsOnOpen((c.x + x),(c.y + y))) = False Then 'It is not on the Open list, add it
'Calculate F, G, and H scores
'G First
If Map((c.x + x),(c.y + y)).mType = Ground Then
Map((c.x + x),(c.y + y)).gScore = Map((c.x),(c.y)).gScore + GroundCost
ElseIF Map((c.x + x),(c.y + y)).mType = Hill Then
Map((c.x + x),(c.y + y)).gScore = Map((c.x),(c.y)).gScore + HillCost
ElseIf Map((c.x + x),(c.y + y)).mType = Water Then
Map((c.x + x),(c.y + y)).gScore = Map((c.x),(c.y)).gScore + WaterCost
End If
'Now H score using Manhattan distance
hx = 10 * (ABS(((c.x + x)-(mFinish.x))))
hy = 10 * (ABS(((c.y + y)-(mFinish.y))))
Map((c.x + x),(c.y + y)).hScore = hx + hy
'Finally, the F score
Map((c.x + x),(c.y + y)).fScore = Map((c.x + x),(c.y + y)).gScore + Map((c.x + x),(c.y + y)).hScore
'Make the current square the parent of this square
Map((c.x + x),(c.y + y)).pX = c.x
Map((c.x + x),(c.y + y)).pY = c.y
'Then add this square to the Open List
AddToOpen (c.x + x), (c.y + y)
'If it's the finish square, we've found the path!
If (c.x + x) = mFinish.x And (c.y + y) = mFinish.y Then
onFinish = True
End If
Else 'Then it is on the Open List. Check to see if this is the better route
If Map((c.x + x),(c.y + y)).mType = Ground Then
tempG = Map((c.x),(c.y)).gScore + GroundCost
ElseIF Map((c.x + x),(c.y + y)).mType = Hill Then
tempG = Map((c.x),(c.y)).gScore + HillCost
ElseIf Map((c.x + x),(c.y + y)).mType = Water Then
tempG = Map((c.x),(c.y)).gScore + WaterCost
End If
If tempG < Map((c.x + x),(c.y + y)).gScore Then 'This is the better route
'Make the current square the parent of this square
Map((c.x + x),(c.y + y)).pX = c.x
Map((c.x + x),(c.y + y)).pY = c.y
'Recalculate G and F scores
'G
Map((c.x + x),(c.y + y)).gScore = tempG
'F
Map((c.x + x),(c.y + y)).fScore = Map((c.x + x),(c.y + y)).gScore + Map((c.x + x),(c.y + y)).hScore
End If
End If
End If
End If
Next x
Next y
'Go through the Open List to find the lowest F score
curScore = 20000
For i = 1 to uBound(OpenList)
If IsOnClosed((OpenList(i).x),(OpenList(i).y)) = False Then
If Map((OpenList(i).x),(OpenList(i).y)).fScore <= curScore Then
c.x = OpenList(i).x
c.y = OpenList(i).y
curScore = Map((OpenList(i).x),(OpenList(i).y)).fScore
End If
End If
Next i
Loop
'We've found the target square.
Dim onStart As Integer
c.x = mFinish.x
c.y = mFinish.y
i = 1
Do While onStart = False
AddToPath c.x,c.y
If c.x = mStart.x And c.y = mStart.y Then
onStart = True
End If
x = c.x
y = c.y
c.x = Map(x,y).pX 'Make the Current Square the parent square
c.y = Map(x,y).pY
i = i + 1 'Increment i
Loop
End Sub
Sub AddToOpen(x As Integer, y As Integer)
Dim TempOpen(uBound(OpenList)) As PointType
For i = 1 to uBound(OpenList)
TempOpen(i).x = OpenList(i).x
TempOpen(i).y = OpenList(i).y
Next i
size = uBound(OpenList)
Redim OpenList(size+1) As PointType
For i = 1 to uBound(TempOpen)
OpenList(i).x = TempOpen(i).x
OpenList(i).y = TempOpen(i).y
Next i
OpenList(uBound(OpenList)).x = x
OpenList(uBound(OpenList)).y = y
End Sub
Sub AddToClosed(x As Integer, y As Integer)
Dim TempClosed(uBound(ClosedList)) As PointType
For i = 1 to uBound(ClosedList)
TempClosed(i).x = ClosedList(i).x
TempClosed(i).y = ClosedList(i).y
Next i
size = uBound(ClosedList)
Redim ClosedList(size+1) As PointType
For i = 1 to uBound(TempClosed)
ClosedList(i).x = TempClosed(i).x
ClosedList(i).y = TempClosed(i).y
Next i
ClosedList(uBound(ClosedList)).x = x
ClosedList(uBound(ClosedList)).y = y
End Sub
Sub AddToPath(x As Integer, y As Integer)
Dim TempPath(uBound(Path)) As PointType
For i = 1 to uBound(Path)
TempPath(i).x = Path(i).x
TempPath(i).y = Path(i).y
Next i
size = uBound(Path)
Redim Path(size+1) As PointType
For i = 1 to uBound(TempPath)
Path(i).x = TempPath(i).x
Path(i).y = TempPath(i).y
Next i
Path(uBound(Path)).x = x
Path(uBound(Path)).y = y
End Sub
Function IsOnOpen(x As Integer, y As Integer)
For i = 1 to uBound(OpenList)
If OpenList(i).x = x And OpenList(i).y = y Then
'It's on the open list
IsOnOpen = True
Exit For
End If
Next i
End Function
Function IsOnClosed(x As Integer, y As Integer)
For i = 1 to uBound(ClosedList)
If ClosedList(i).x = x And ClosedList(i).y = y Then
'It's on the closed list
IsOnClosed = True
Exit For
End If
Next i
End Function
Sub ClearScreen()
Line (0,0)-(319,199), 0, BF
End Sub
Sub DrawScreen()
For y = 1 to uBound(Map, 2)
For x = 1 to uBound(Map,1)
Square = Map(x,y).mType
Select Case Square
Case Ground: Line(x * 10, y * 10)-(x * 10 + 10, y * 10 + 10), 2, BF
Case Hill: Line(x * 10, y * 10)-(x * 10 + 10, y * 10 + 10), 21, BF
Case Water: Line(x * 10, y * 10)-(x * 10 + 10, y * 10 + 10), 33, BF
Case Wall: Line(x * 10, y * 10)-(x * 10 + 10, y * 10 + 10), 8, BF
Case Start: Line(x * 10, y * 10)-(x * 10 + 10, y * 10 + 10), 15, BF
Case Finish: Line(x * 10, y * 10)-(x * 10 + 10, y * 10 + 10), 4, BF
End Select
Next x
Next y
Dim ox, oy As Integer
ox = mFinish.x
oy = mFinish.y
For i = 1 To uBound(Path)
x = Path(i).x
y = Path(i).y
Line (ox * 10 + 5,oy * 10 + 5)-(x * 10 + 5,y * 10 + 5), 14
ox = x
oy = y
Next i
Locate 20,1
For i = 1 To uBound(Path)
Print Path(i).x;
Print ",";
Print Path(i).y;
Next i
End Sub
[/syntax]
You'll need to make a "board.brd" file to use it. Here is a sample board.
Code:
20,15
0,0,0,0,0,0,0,0,0,1,1,0,0,0,0,0,0,0,0,0
0,0,0,0,0,0,0,0,0,1,1,0,0,0,0,0,0,0,0,0
0,0,0,0,0,0,0,0,0,0,1,1,0,0,0,0,0,0,0,0
0,0,0,5,0,0,0,0,0,0,1,1,0,0,0,0,0,0,0,0
0,0,0,0,2,2,2,2,2,2,1,1,2,2,2,0,0,0,0,0
0,0,0,2,2,2,2,2,2,2,2,2,2,2,2,2,0,0,0,0
0,0,0,2,2,2,2,2,2,2,2,2,2,2,2,2,2,0,0,0
0,0,0,0,2,2,2,2,2,1,1,2,2,2,0,0,0,0,0,0
0,0,0,0,0,0,2,2,2,2,1,1,0,0,0,0,0,0,0,0
0,0,0,0,0,0,0,2,2,0,1,1,0,0,0,0,0,0,0,0
0,0,0,0,0,0,0,0,0,0,1,1,0,0,0,0,0,0,0,0
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
0,0,0,0,0,0,0,0,0,0,1,1,0,0,0,0,0,6,0,0
0,0,0,0,0,0,0,0,0,0,1,1,0,0,0,0,0,0,0,0
0,0,0,0,0,0,0,0,0,0,0,1,1,0,0,0,0,0,0,0