[VB6 & VB 5]Hex Grid Auto-Navigation-VBForums
Results 1 to 4 of 4

Thread: [VB6 & VB 5]Hex Grid Auto-Navigation

  1. #1

    Thread Starter
    Fanatic Member technorobbo's Avatar
    Join Date
    Dec 2008
    Location
    Chicago
    Posts
    864

    [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.
    Have Fun,

    TR
    _____________________________
    Check out my Alpha DogFighter2D Game Demo and Source code. Direct Download:http://home.comcast.net/~technorobbo/Alpha.zip or Read about it in the forum:http://www.vbforums.com/showthread.php?t=551700. Now in 3D!!! http://home.comcast.net/~technorobbo/AlPha3D.zip or read about it in the forum: http://www.vbforums.com/showthread.php?goto=newpost&t=552560 and IChessChat3D internet chess game

  2. #2

    Thread Starter
    Fanatic Member technorobbo's Avatar
    Join Date
    Dec 2008
    Location
    Chicago
    Posts
    864

    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.
    Have Fun,

    TR
    _____________________________
    Check out my Alpha DogFighter2D Game Demo and Source code. Direct Download:http://home.comcast.net/~technorobbo/Alpha.zip or Read about it in the forum:http://www.vbforums.com/showthread.php?t=551700. Now in 3D!!! http://home.comcast.net/~technorobbo/AlPha3D.zip or read about it in the forum: http://www.vbforums.com/showthread.php?goto=newpost&t=552560 and IChessChat3D internet chess game

  3. #3
    New Member
    Join Date
    May 2009
    Posts
    1

    Thumbs up Re: [VB6 & VB 5]Hex Grid Auto-Navigation

    Thank you for providing us with the example code, and a brief explanation of the problem

    pret auto

  4. #4

    Thread Starter
    Fanatic Member technorobbo's Avatar
    Join Date
    Dec 2008
    Location
    Chicago
    Posts
    864

    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&#37; 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
    Have Fun,

    TR
    _____________________________
    Check out my Alpha DogFighter2D Game Demo and Source code. Direct Download:http://home.comcast.net/~technorobbo/Alpha.zip or Read about it in the forum:http://www.vbforums.com/showthread.php?t=551700. Now in 3D!!! http://home.comcast.net/~technorobbo/AlPha3D.zip or read about it in the forum: http://www.vbforums.com/showthread.php?goto=newpost&t=552560 and IChessChat3D internet chess game

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Featured


Click Here to Expand Forum to Full Width

Survey posted by VBForums.