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
Reply With Quote