-
Apr 17th, 2009, 08:17 PM
#1
Thread Starter
Fanatic Member
[VB6 & VB 5]Hex Grid Auto-Navigation
Goes from Point A to Point B in a Hex Lattice and avoid obstacles.
1 form - paste code and run.
Code:
Option Explicit
Private Type COORD
x As Long
y As Long
End Type
Private Declare Function GetTickCount& Lib "kernel32" ()
Private Declare Function GetRgnBox Lib "gdi32" (ByVal hRgn As Long, lpRect As RECT) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function PtInRegion Lib "gdi32" (ByVal hRgn As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As Any, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Private Declare Function Polygon Lib "gdi32" (ByVal hdc As Long, lpPoint As Any, ByVal nCount As Long) As Long
Private Declare Function FillRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long, ByVal hbrush As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Const ALTERNATE = 1
Const WINDING = 2
Const BLACKBRUSH = 4
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Enum Logic
Origin = 1
Target = 2
Victory = 3
Idle = 4
Init = 5
quit = 6
Defeat = 7
Lattice = 8
End Enum
Dim hRgn() As Long, Think As Logic, FindPath As RECT, GameOn As Boolean
Dim LastPath() As Boolean, TailCount As Integer, Tailend As COORD
Dim DeadEnds() As Boolean
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyEscape Then Think = quit
If KeyCode = vbKeyR Then Think = Init
If KeyCode = vbKeyL Then Think = Lattice
End Sub
Private Sub Form_Load()
Randomize
Me.KeyPreview = True
Me.WindowState = vbMaximized
Me.ScaleMode = vbPixels
Me.FillStyle = 0
Me.Show
DoEvents
Me.AutoRedraw = True
MakeLattice
Me.Refresh
Me.AutoRedraw = False
Think = Init
GameOn = True
GameLoop
Unload Me
End Sub
Private Sub MakeLattice()
Dim poly(1 To 6) As COORD, NumCoords As Long
Dim pi As Double, i As Double, j As Integer, latX As Double, x As Integer
Dim hexrad As Double, INC As Double, latY As Double, y As Integer
pi = Atn(1) * 4
NumCoords = 6
'PRECOMP
hexrad = Me.ScaleWidth / 40
INC = pi / 3
latX = Cos(INC) * hexrad
latY = Sin(INC) * hexrad
ReDim hRgn(0 To Me.ScaleWidth / (hexrad + latX * 0.75), 0 To Me.ScaleHeight / (hexrad + latY * 0.75))
For y = 0 To UBound(hRgn, 2) 'Me.ScaleHeight / hexrad
For x = 0 To UBound(hRgn, 1) 'Me.ScaleWidth / 50
For j = 1 To 6
i = j * INC
poly(j).x = Cos(i) * hexrad + latX * x + hexrad * x
poly(j).y = Sin(i) * hexrad + latY * (x And 1) + y * latY * 2
Next
Me.FillColor = Choose(Int(Rnd() * 4) + 1, RGB(192, 192, 0), _
RGB(64, 255, 64), RGB(192, 192, 0), RGB(192, 192, 0))
Polygon Me.hdc, poly(1), NumCoords
hRgn(x, y) = CreatePolygonRgn(poly(1), NumCoords, ALTERNATE)
Next
Next
End Sub
Sub DeleteLattice()
Dim x As Integer, y As Integer
For y = 0 To UBound(hRgn, 2)
For x = 0 To UBound(hRgn, 1)
DeleteObject hRgn(x, y)
Next
Next
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim x1 As Integer, y1 As Integer, found As Boolean
Dim fx As Integer, fy As Integer, hbrush As Long
If Think = Idle Or Think = Origin Then
If GetPixel(Me.hdc, x, y) <> RGB(192, 192, 0) Then Exit Sub
found = False
For y1 = 0 To UBound(hRgn, 2)
For x1 = 0 To UBound(hRgn, 1)
If PtInRegion(hRgn(x1, y1), x, y) <> 0 Then
found = True
fy = y1
fx = x1
Exit For
End If
If found Then Exit For
Next
Next
If Think = Idle Then
FindPath.Left = fx
FindPath.Top = fy
Me.Cls
hbrush = CreateSolidBrush(RGB(255, 0, 0))
FillRgn Me.hdc, hRgn(fx, fy), hbrush
DeleteObject hbrush
Think = Origin
Me.Caption = "Origin Set"
ElseIf Think = Origin Then
FindPath.Right = fx
FindPath.Bottom = fy
Think = Target
Me.Caption = "Destination Set, Navigating - Press R to reset."
End If
End If
End Sub
Sub GameLoop()
Do While GameOn
Select Case Think
Case Origin
DoEvents
Case Target
plotpath
DoEvents
Case Victory
MsgBox "I'm There."
Me.Caption = "Found Target!!!!!"
Think = Idle
Case Idle
DoEvents
Case Init
Me.Cls
Me.Caption = "Pick a Starting Brown Hex - Or L to for new lattice"
Think = Idle
Case quit
GameOn = False
Case Defeat
MsgBox "stuck"
Me.Caption = "I'm Lost"
Think = Idle
Case Lattice
DoEvents
DeleteLattice
Me.AutoRedraw = True
MakeLattice
Me.Refresh
Me.AutoRedraw = False
Think = Init
End Select
Loop
End Sub
Function CheckBlock(ByVal x1 As Integer, ByVal y1 As Integer) As Boolean
Dim box As RECT, color As Long
If x1 < 0 Or x1 > UBound(hRgn, 1) Then
CheckBlock = False
Exit Function
ElseIf y1 < 0 Or y1 > UBound(hRgn, 2) Then
CheckBlock = False
Exit Function
ElseIf DeadEnds(x1, y1) Then
CheckBlock = False
Exit Function
ElseIf LastPath(x1, y1) Then
CheckBlock = False
Exit Function
End If
GetRgnBox hRgn(x1, y1), box
color = GetPixel(Me.hdc, (box.Left + box.Right) / 2, (box.Top + box.Bottom) / 2)
If color = RGB(192, 192, 0) Then
CheckBlock = True
Else
CheckBlock = False
End If
End Function
Sub plotpath()
Dim DONE As Boolean, PlotX As Integer, Ploty As Integer
Dim hbrush As Long, pause As Long, x1 As Integer, y1 As Integer
Dim x As Single, OE As Integer, i As Integer, lost As Boolean
Dim Sort(1 To 6, 0 To 1) As Single, sTmp As COORD, tmp As Single
Const Index = 0
Const Dist = 1
Erase LastPath
ReDim LastPath(0 To UBound(hRgn, 1), 0 To UBound(hRgn, 2))
Erase DeadEnds
ReDim DeadEnds(0 To UBound(hRgn, 1), 0 To UBound(hRgn, 2))
LastPath(FindPath.Left, FindPath.Top) = True
TailCount = 0
Tailend.x = FindPath.Left
Tailend.y = FindPath.Top
Do While Not DONE
'sell the drama -LET'S SLOW IT DOWN
pause = GetTickCount + 50
While pause > GetTickCount
DoEvents
Wend
'get bearings
PlotX = Sgn(FindPath.Right - FindPath.Left)
Ploty = Sgn(FindPath.Bottom - FindPath.Top)
OE = FindPath.Left And 1
'think
'Check Arrive
If PlotX = 0 And Ploty = 0 Then
Think = Victory
DONE = True
Else
lost = True
For i = 1 To 6
If CheckBlock(NPair(OE, i).x + FindPath.Left, _
NPair(OE, i).y + FindPath.Top) Then
sTmp.x = FindPath.Left + NPair(OE, i).x
sTmp.y = FindPath.Top + NPair(OE, i).y
x = Sqr((FindPath.Right - sTmp.x) ^ 2 + (FindPath.Bottom - sTmp.y) ^ 2)
Sort(i, Index) = i
Sort(i, Dist) = x
lost = False
Else
Sort(i, Index) = i
Sort(i, Dist) = 65535
End If
Next
If lost Then
Erase LastPath
ReDim LastPath(0 To UBound(hRgn, 1), 0 To UBound(hRgn, 2))
LastPath(FindPath.Left, FindPath.Top) = True
DeadEnds(FindPath.Left, FindPath.Top) = True
Else
'sort
i = 1
While i < 7
If i = 1 Then
i = i + 1
ElseIf Sort(i - 1, Dist) <= Sort(i, Dist) Then
i = i + 1
Else
tmp = Sort(i, Dist): Sort(i, Dist) = Sort(i - 1, Dist): Sort(i - 1, Dist) = tmp
tmp = Sort(i, Index): Sort(i, Index) = Sort(i - 1, Index): Sort(i - 1, Index) = tmp
i = i - 1
End If
Wend
'use closest
FindPath.Left = FindPath.Left + NPair(OE, Sort(1, Index)).x
FindPath.Top = FindPath.Top + NPair(OE, Sort(1, Index)).y
LastPath(FindPath.Left, FindPath.Top) = True
TailCount = (TailCount + 1) Mod 100
If TailCount = 0 Then
LastPath(Tailend.x, Tailend.y) = False
Tailend.x = FindPath.Right
Tailend.y = FindPath.Bottom
End If
End If
End If
If Not DONE Then
Me.Cls
hbrush = CreateSolidBrush(RGB(255, 0, 0))
x1 = FindPath.Left
y1 = FindPath.Top
FillRgn Me.hdc, hRgn(x1, y1), hbrush
DeleteObject hbrush
End If
If Think = quit Or Think = Init Then DONE = True
Loop
End Sub
Private Function NPair(OE As Integer, ByVal nav As Integer) As COORD
'LATTICE lOGIC
NPair.x = Choose(nav, -1, 0, -1, 1, 0, 1)
NPair.y = Choose(nav, -1 + OE, -1, 0 + OE, -1 + OE, 1, 0 + OE)
End Function
Private Sub Form_Unload(Cancel As Integer)
GameOn = False
DeleteLattice
End Sub
Post Edit - fixed some transposed numbers on the logic table.
Last edited by technorobbo; Apr 22nd, 2009 at 08:28 PM.
-
Apr 18th, 2009, 12:24 PM
#2
Thread Starter
Fanatic Member
Re: [VB6 & VB 5]Hex Grid Auto-Navigation
Code Reposted. If the AI is in a bottleneck that requires it to go 180 degrees, it shift it's logic to find a solution.
Refined algorithm to travel shortest distance
Last edited by technorobbo; Apr 19th, 2009 at 11:23 AM.
-
May 7th, 2009, 07:28 PM
#3
New Member
-
May 7th, 2009, 07:52 PM
#4
Thread Starter
Fanatic Member
Re: [VB6 & VB 5]Hex Grid Auto-Navigation
For those of you wondering "What explanation?" I had posted and explanation in this thread http://www.vbforums.com/showthread.p...41#post3499741
But here it is so you don't have to look it up:
how the algorithm works:
Declarations:
Standard API declares for RECT's and Regions, Poly's and Fill are used and supporting types and constants. The only custom declaration is the Enum for the loop logic.
Code:
Enum Logic
Origin = 1
Target = 2
Victory = 3
Idle = 4
Init = 5
quit = 6
Defeat = 7
Lattice = 8
End Enum
This is a mini scritpting system that controls the sequence of events.
The Variables
- hRgn() - All hexes are defined as regions
- Think - Token using logic enum for flow control
- FindPath - Stores beginning and end coords in RECT structure
- GameOn - boolean that keeps loop looping
- LastPath - see next comment
- TailCount - keeps track of last 100 locations for backing out of dead ends and stops endless loops - increase this for larger grids!
- Tailend stores end of path for restoring
- DeadEnds - tracks dead ends
Making the Lattice
- PI = Atn(1) * 4 = best way to define PI in VB
- NumCoords = 6 - It' a hex
- hexrad = Me.ScaleWidth / 25 - and it's 25 across
- INC = pi / 3 - the equivalent to 60 degrees
- latX = Cos(INC) * hexrad - convert 60 degrees to x and y
- latY = Sin(INC) * hexrad - " "
Create regions in windows for hex:
Code:
ReDim hRgn(0 To Me.ScaleWidth / 50, 0 To Me.ScaleHeight / hexrad)
Draw hexes on screen - mostly brown and some green randomnly:
Code:
For y = 0 To Me.ScaleHeight / hexrad
For x = 0 To Me.ScaleWidth / 50
For j = 1 To 6
i = j * INC
poly(j).x = Cos(i) * hexrad + latX * x + hexrad * x
poly(j).y = Sin(i) * hexrad + latY * (x And 1) + y * latY * 2
Next
Me.FillColor = Choose(Int(Rnd() * 4) + 1, RGB(192, 192, 0), _
RGB(64, 255, 64), RGB(192, 192, 0), RGB(192, 192, 0))
Polygon Me.hdc, poly(1), NumCoords
hRgn(x, y) = CreatePolygonRgn(poly(1), NumCoords, ALTERNATE)
Next
Next
The y axis wobble is created by offsetting the 60 degrees for even and odd hexes in this part of the routine
Code:
latY * (x And 1) + y
*Note that regions have to be deleted before redraing the Lattice.
Navigation Algorithm
There are 2 Key routines that support the path finding logic:
1. The Cartesian 2 hex translation - I believe in precomputing as much as possible for speed. OE is the odd even bit used to translate the y axis wobble.
Code:
Private Function NPair(OE As Integer, ByVal nav As Integer) As COORD
'LATTICE lOGIC
NPair.x = Choose(nav, -1, 0, -1, 1, 0, 1)
NPair.y = Choose(nav, -1 + OE, -1, 0 + OE, -1 + OE, 1, 0 + OE)
End Function
2. Check block colors for collision- yes it's an archaic throwback to the commodore 64 but it works. Using GetRgnBox and finding the center pixel color. I am also checking check for boundaries. If your filling your hexes with graphics and not colors - keep refence array for this type of collision detection.
Note that the LastPath and borders are also checked.
Code:
Function CheckBlock(ByVal x1 As Integer, ByVal y1 As Integer) As Boolean
Dim box As RECT, color As Long
If x1 < 0 Or x1 > UBound(hRgn, 1) Then
CheckBlock = False
Exit Function
ElseIf y1 < 0 Or y1 > UBound(hRgn, 2) Then
CheckBlock = False
Exit Function
ElseIf DeadEnds(x1, y1) Then
CheckBlock = False
Exit Function
ElseIf LastPath(x1, y1) Then
CheckBlock = False
Exit Function
End If
GetRgnBox hRgn(x1, y1), box
color = GetPixel(Me.hdc, (box.Left + box.Right) / 2, (box.Top + box.Bottom) / 2)
If color = RGB(192, 192, 0) Then
CheckBlock = True
Else
CheckBlock = False
End If
End Function
Now for the main AI routine PlotPath. I'm going to explain it little by little since it is kind of complex
Necessary Evils:
Note we're setting up to sort and paint
Code:
Sub plotpath()
Dim DONE As Boolean, PlotX As Integer, Ploty As Integer
Dim hbrush As Long, pause As Long, x1 As Integer, y1 As Integer
Dim x As Single, OE As Integer, i As Integer, lost As Boolean
Dim Sort(1 To 6, 0 To 1) As Single, sTmp As COORD, tmp As Single
Contstants for sorting array
Code:
Const Index = 0
Const Dist = 1
Initialize the path history with current location
Code:
Erase LastPath
ReDim LastPath(0 To UBound(hRgn, 1), 0 To UBound(hRgn, 2))
Erase DeadEnds
ReDim DeadEnds(0 To UBound(hRgn, 1), 0 To UBound(hRgn, 2))
LastPath(FindPath.Left, FindPath.Top) = True
TailCount = 0
Tailend.x = FindPath.Left
Tailend.y = FindPath.Top
start pathfinding loop and set up a drawing delay that's easy on the eyes.
Code:
Do While Not DONE
'sell the drama -LET'S SLOW IT DOWN
pause = GetTickCount + 50
While pause > GetTickCount
DoEvents
Wend
check if your at your destination - you can also use abs()
set the flag and end the loop if you are.
Code:
'get bearings
PlotX = Sgn(FindPath.Right - FindPath.Left)
Ploty = Sgn(FindPath.Bottom - FindPath.Top)
OE = FindPath.Left And 1
'think
'Check Arrive
If PlotX = 0 And Ploty = 0 Then
Think = Victory
DONE = True
If your not start the logic as if your lost - which you are.
Scan all hexes around your current location and use the Pythagorean theorem to determine their distance to the destination. If the hex you check is out of bound store a really far distance.
I all hexes are out of bounds the lost flag remains true. If you do have a spot to move to then it becomes false.
Code:
Else
lost = True
For i = 1 To 6
If CheckBlock(NPair(OE, i).x + FindPath.Left, _
NPair(OE, i).y + FindPath.Top) Then
sTmp.x = FindPath.Left + NPair(OE, i).x
sTmp.y = FindPath.Top + NPair(OE, i).y
x = Sqr((FindPath.Right - sTmp.x) ^ 2 + (FindPath.Bottom - sTmp.y) ^ 2)
Sort(i, Index) = i
Sort(i, Dist) = x
lost = False
Else
Sort(i, Index) = i
Sort(i, Dist) = 65535
End If
Next
Are we lost??? If we are that means we've hit a dead end so clear the path history mark your current location, that way you will back out of the dead end. Keep Track of dead ends, but don't erase them.
Code:
If lost Then
Erase LastPath
ReDim LastPath(0 To UBound(hRgn, 1), 0 To UBound(hRgn, 2))
LastPath(FindPath.Left, FindPath.Top) = True
DeadEnds(FindPath.Left, FindPath.Top) = True
Else
Not lost - sort the hexes around you to see which is closest to your destination cause that's where your going.
Code:
'sort
i = 1
While i < 7
If i = 1 Then
i = i + 1
ElseIf Sort(i - 1, Dist) <= Sort(i, Dist) Then
i = i + 1
Else
tmp = Sort(i, Dist): Sort(i, Dist) = Sort(i - 1, Dist): Sort(i - 1, Dist) = tmp
tmp = Sort(i, Index): Sort(i, Index) = Sort(i - 1, Index): Sort(i - 1, Index) = tmp
i = i - 1
End If
Wend
Now go there! Don't forget your path history. I've limit it to 100 but you can make it bigger for bigger boards with larger bottlenecks and dead ends. I used 15% of the board - that seems to work good.
Code:
'use closest
FindPath.Left = FindPath.Left + NPair(OE, Sort(1, Index)).x
FindPath.Top = FindPath.Top + NPair(OE, Sort(1, Index)).y
LastPath(FindPath.Left, FindPath.Top) = True
TailCount = (TailCount + 1) Mod 100
If TailCount = 0 Then
LastPath(Tailend.x, Tailend.y) = False
Tailend.x = FindPath.Right
Tailend.y = FindPath.Bottom
End If
End If
End If
Draw the graphics - its time
Code:
If Not DONE Then
Me.Cls
hbrush = CreateSolidBrush(RGB(255, 0, 0))
x1 = FindPath.Left
y1 = FindPath.Top
FillRgn Me.hdc, hRgn(x1, y1), hbrush
DeleteObject hbrush
End If
Viola! Loop 'til your there or you want to escape!
Code:
If Think = quit Or Think = Init Then DONE = True
Loop
End Sub
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|