# VBForums CodeBank > Codebank - Game Programming >  [VB6 & VB 5]Hex Grid Auto-Navigation

## technorobbo

Goes from Point A to Point B in a Hex Lattice and avoid obstacles.

1 form - paste code and run.



```
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.*

----------


## technorobbo

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*

----------


## rainbow2009

Thank you for providing us with the example code, and a brief explanation of the problem :wave: 
 :Alien Frog:  :Duck: 
pret auto

----------


## technorobbo

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.



```
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 regionsThink - Token using logic enum for flow controlFindPath - Stores beginning and end coords in RECT structureGameOn - boolean that keeps loop loopingLastPath - see next commentTailCount - 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 restoringDeadEnds  - tracks dead ends

*Making the Lattice*

PI = Atn(1) * 4 = best way to define PI in VBNumCoords = 6 - It' a hexhexrad = Me.ScaleWidth / 25  -  and it's 25 acrossINC = pi / 3  - the equivalent to 60 degreeslatX = Cos(INC) * hexrad  - convert 60 degrees to x and ylatY = Sin(INC) * hexrad   -  " "

Create regions in windows for hex:


```
ReDim hRgn(0 To Me.ScaleWidth / 50, 0 To Me.ScaleHeight / hexrad)
```

Draw hexes on screen - mostly brown and some green randomnly:


```
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



```
 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.


```
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. 



```
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


```
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


```
Const Index = 0
Const Dist = 1
```


Initialize the path history with current location


```
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.


```
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.


```
 
   '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.


```
   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.


```
       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.


```
 
            '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&#37; of the board - that seems to work good.


```
           '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 


```
 
   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!


```
    If Think = quit Or Think = Init Then DONE = True
Loop
End Sub
```

----------

