VERSION 5.00
Begin VB.Form frmMain
BorderStyle = 1 'Fixed Single
Caption = "PathFinder Contest - Score: 0"
ClientHeight = 5985
ClientLeft = 45
ClientTop = 735
ClientWidth = 8040
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 5985
ScaleWidth = 8040
StartUpPosition = 2 'CenterScreen
Begin VB.PictureBox picEnd
AutoRedraw = -1 'True
BackColor = &H000000C0&
BorderStyle = 0 'None
Height = 375
Left = 120
ScaleHeight = 25
ScaleMode = 3 'Pixel
ScaleWidth = 25
TabIndex = 13
Top = 840
Visible = 0 'False
Width = 375
End
Begin VB.PictureBox picStart
AutoRedraw = -1 'True
BackColor = &H0000C000&
BorderStyle = 0 'None
Height = 375
Left = 120
ScaleHeight = 25
ScaleMode = 3 'Pixel
ScaleWidth = 25
TabIndex = 12
Top = 2280
Visible = 0 'False
Width = 375
End
Begin VB.PictureBox picPass
AutoRedraw = -1 'True
BackColor = &H00C0C0C0&
BorderStyle = 0 'None
Height = 375
Left = 120
ScaleHeight = 25
ScaleMode = 3 'Pixel
ScaleWidth = 25
TabIndex = 11
Top = 1560
Visible = 0 'False
Width = 375
End
Begin VB.PictureBox picBlock
AutoRedraw = -1 'True
BackColor = &H00606060&
BorderStyle = 0 'None
Height = 375
Left = 120
ScaleHeight = 25
ScaleMode = 3 'Pixel
ScaleWidth = 25
TabIndex = 10
Top = 480
Visible = 0 'False
Width = 375
End
Begin VB.PictureBox picDisplay
AutoRedraw = -1 'True
BackColor = &H00E0E0E0&
Height = 5175
Left = 120
ScaleHeight = 341
ScaleMode = 3 'Pixel
ScaleWidth = 485
TabIndex = 8
Top = 120
Width = 7335
Begin VB.PictureBox picPlayer
BackColor = &H00C00000&
BorderStyle = 0 'None
Height = 135
Left = 120
ScaleHeight = 9
ScaleMode = 3 'Pixel
ScaleWidth = 9
TabIndex = 9
Top = 120
Width = 135
End
End
Begin VB.HScrollBar ScrSpeed
Height = 255
Left = 1200
Max = 100
Min = 1
TabIndex = 6
Top = 5640
Value = 100
Width = 1815
End
Begin VB.PictureBox picPass3
AutoRedraw = -1 'True
BackColor = &H00C0FFFF&
BorderStyle = 0 'None
Height = 375
Left = 120
ScaleHeight = 25
ScaleMode = 3 'Pixel
ScaleWidth = 25
TabIndex = 5
Top = 1920
Visible = 0 'False
Width = 375
End
Begin VB.PictureBox picPass2
AutoRedraw = -1 'True
BackColor = &H00FFFFFF&
BorderStyle = 0 'None
Height = 375
Left = 120
ScaleHeight = 25
ScaleMode = 3 'Pixel
ScaleWidth = 25
TabIndex = 4
Top = 1200
Visible = 0 'False
Width = 375
End
Begin VB.PictureBox picBlock2
AutoRedraw = -1 'True
BackColor = &H00000000&
BorderStyle = 0 'None
Height = 375
Left = 120
ScaleHeight = 25
ScaleMode = 3 'Pixel
ScaleWidth = 25
TabIndex = 3
Top = 100
Visible = 0 'False
Width = 375
End
Begin VB.ComboBox cboMapList
Height = 315
ItemData = "frmMain.frx":0000
Left = 3240
List = "frmMain.frx":0002
Style = 2 'Dropdown List
TabIndex = 1
Top = 5580
Width = 1455
End
Begin VB.CommandButton cmdStart
Caption = "Start"
Enabled = 0 'False
Height = 255
Left = 120
TabIndex = 0
Top = 5640
Width = 975
End
Begin VB.Label LblSpeed
AutoSize = -1 'True
Caption = "Speed: 100"
Height = 195
Left = 1320
TabIndex = 7
Top = 5400
Width = 825
End
Begin VB.Label lblMaps
Caption = "Maps"
Height = 255
Left = 3240
TabIndex = 2
Top = 5355
Width = 495
End
Begin VB.Menu MenuMap
Caption = "Map"
Begin VB.Menu MenuInvert
Caption = "Rotate"
End
Begin VB.Menu MenuSwitch
Caption = "Switch Start and End Points"
End
Begin VB.Menu MenuMirrorH
Caption = "Mirror Horizontal"
End
Begin VB.Menu MenuMirrorV
Caption = "Mirror Vertical"
End
End
Begin VB.Menu MenuRun
Caption = "Run"
Begin VB.Menu MenuStop
Caption = "Don't Stop at End"
End
Begin VB.Menu MenuFitness
Caption = "Multiply Fitness by (TotalArea / OpenArea)"
Checked = -1 'True
End
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private MapWidth As Integer
Private MapHeight As Integer
Private MapData() As Byte
Private CurX As Integer
Private CurY As Integer
Private Score As Integer
Private Compeleted As Boolean
Private TotalArea As Long
Private AreaCovered As Long
Private MapCovered() As Boolean
Private Const m_clGridSize As Long = 9
Private Sub cboMapList_Click()
cmdLoadMap_Click
End Sub
Private Sub cmdLoadMap_Click()
Dim A As Long
Dim X As Integer
Dim Y As Integer
Dim FileContents As String
Dim i As Integer
'Load the files Contents...
' FS, adjustment to read the appropriate map from a combo box, saves changing of code
'FileContents = OpenFile(App.Path & "\Route1.txt")
FileContents = OpenFile(App.Path & "\" & cboMapList.List(cboMapList.ListIndex))
'Find out the dimensions of the map...
MapWidth = CInt(GetTextBetween(FileContents, "", "", , vbTextCompare))
MapHeight = CInt(GetTextBetween(FileContents, "", "", , vbTextCompare))
If MenuInvert.Checked Then
A = MapWidth
MapWidth = MapHeight
MapHeight = A
End If
'Resize the Progress window...
picDisplay.Width = (m_clGridSize * MapWidth + 5) * Screen.TwipsPerPixelX
picDisplay.Height = (m_clGridSize * MapHeight + 5) * Screen.TwipsPerPixelY
frmMain.Width = picDisplay.Width + 480 + 375
If frmMain.Width < 5000 Then frmMain.Width = 5000
frmMain.Height = picDisplay.Height + picDisplay.Top + 1400
cmdStart.Top = Me.ScaleHeight - 350
LblSpeed.Top = Me.ScaleHeight - 550
ScrSpeed.Top = Me.ScaleHeight - 350
lblMaps.Top = Me.ScaleHeight - 550
cboMapList.Top = Me.ScaleHeight - 350
'Remove the Width & Height Tags...
FileContents = Mid(FileContents, InStr(1, FileContents, "", vbTextCompare) + m_clGridSize)
TotalArea = 0
'Process the data...
ReDim MapData(0 To MapWidth - 1, 0 To MapHeight - 1)
ReDim MapCovered(0 To MapWidth - 1, 0 To MapHeight - 1)
i = 0
If MenuInvert.Checked Then
A = MapWidth
MapWidth = MapHeight
MapHeight = A
End If
For Y = 0 To MapHeight - 1
For X = 0 To MapWidth - 1
If MenuInvert.Checked Then
A = MapWidth
MapWidth = MapHeight
MapHeight = A
End If
If MenuInvert.Checked Then
A = Y
Y = X
X = A
End If
If MenuMirrorH.Checked Then
X = MapWidth - 1 - X
End If
If MenuMirrorV.Checked Then
Y = MapHeight - 1 - Y
End If
i = i + 1
MapData(X, Y) = CInt(Mid(FileContents, i, 1))
Select Case MapData(X, Y)
Case 1
BitBlt picDisplay.hDC, X * m_clGridSize, Y * m_clGridSize, m_clGridSize, m_clGridSize, picBlock.hDC, 0, 0, vbSrcCopy
Case 2
BitBlt picDisplay.hDC, X * m_clGridSize, Y * m_clGridSize, m_clGridSize, m_clGridSize, picPass.hDC, 0, 0, vbSrcCopy
TotalArea = TotalArea + 1
Case 3
If MenuSwitch.Checked Then
BitBlt picDisplay.hDC, X * m_clGridSize, Y * m_clGridSize, m_clGridSize, m_clGridSize, picEnd.hDC, 0, 0, vbSrcCopy
MapData(X, Y) = 4
Else
BitBlt picDisplay.hDC, X * m_clGridSize, Y * m_clGridSize, m_clGridSize, m_clGridSize, picStart.hDC, 0, 0, vbSrcCopy
'picPlayer.Left = 8 + x * m_clGridSize
'picPlayer.Top = 8 + y * m_clGridSize
picPlayer.Left = X * m_clGridSize
picPlayer.Top = Y * m_clGridSize
CurX = X
CurY = Y
End If
Case 4
If MenuSwitch.Checked Then
BitBlt picDisplay.hDC, X * m_clGridSize, Y * m_clGridSize, m_clGridSize, m_clGridSize, picStart.hDC, 0, 0, vbSrcCopy
'picPlayer.Left = 8 + x * m_clGridSize
'picPlayer.Top = 8 + y * m_clGridSize
picPlayer.Left = X * m_clGridSize
picPlayer.Top = Y * m_clGridSize
CurX = X
CurY = Y
MapData(X, Y) = 3
Else
BitBlt picDisplay.hDC, X * m_clGridSize, Y * m_clGridSize, m_clGridSize, m_clGridSize, picEnd.hDC, 0, 0, vbSrcCopy
End If
End Select
If MenuMirrorV.Checked Then
Y = MapHeight - 1 - Y
End If
If MenuMirrorH.Checked Then
X = MapWidth - 1 - X
End If
If MenuInvert.Checked Then
A = Y
Y = X
X = A
End If
If MenuInvert.Checked Then
A = MapWidth
MapWidth = MapHeight
MapHeight = A
End If
Next
Next
If MenuInvert.Checked Then
A = MapWidth
MapWidth = MapHeight
MapHeight = A
End If
Score = 0
picDisplay.Refresh
cmdStart.Enabled = True
End Sub
Private Function OpenFile(ByVal iFileName As String) As String
Dim FileContents As String
Dim ThisLine As String
Open iFileName For Input As #1
Do Until EOF(1)
Line Input #1, ThisLine
FileContents = FileContents & ThisLine 'No vbcrlf
Loop
Close #1
OpenFile = FileContents
End Function
Private Function GetTextBetween(ByVal InString As String, ByVal PreText As String, ByVal PostText As String, Optional ByVal Start As Integer = 1, Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As String
On Error Resume Next
Dim PrePos As Integer
Dim PostPos As Integer
Dim i As Integer
PrePos = InStr(Start, InString, PreText, Compare)
PostPos = InStr(Start, InString, PostText, Compare)
If PrePos = 0 Or PostPos = 0 Then
GetTextBetween = ""
Else
GetTextBetween = Mid(InString, PrePos + Len(PreText), PostPos - (PrePos + Len(PreText)))
End If
End Function
Private Sub ChkInvert_Click()
cmdLoadMap_Click
End Sub
Private Sub ChkSwitch_Click()
cmdLoadMap_Click
End Sub
Private Sub cmdStart_Click()
Dim A As Long
Dim B As Long
Dim MapData2() As Byte
' FS, adjustment to completed status
Compeleted = False
cmdLoadMap_Click
cmdStart.Enabled = False
MenuMap.Visible = False
cboMapList.Enabled = False
AreaCovered = 0
StartGame
If Compeleted Then
MsgBox "Completed with a score of " & Score & ".", vbInformation, "Finished"
End If
MenuMap.Visible = True
cmdStart.Enabled = True
cboMapList.Enabled = True
End Sub
'-------------------------------------------------------------------------------------------------------
'----------The Functions below here should be the only ones you use from your code----------------------
'-------------------------------------------------------------------------------------------------------
Public Sub LookAbout(ByRef North As Boolean, ByRef East As Boolean, ByRef South As Boolean, ByRef West As Boolean)
If CurY > 0 Then
North = Not (MapData(CurX, CurY - 1) = 1)
If North Then
If MapData(CurX, CurY - 1) <> 4 Then
BitBlt picDisplay.hDC, CurX * m_clGridSize, (CurY - 1) * m_clGridSize, m_clGridSize, m_clGridSize, picPass2.hDC, 0, 0, vbSrcCopy
End If
Else
BitBlt picDisplay.hDC, CurX * m_clGridSize, (CurY - 1) * m_clGridSize, m_clGridSize, m_clGridSize, picBlock2.hDC, 0, 0, vbSrcCopy
End If
Else
North = False
End If
If CurX < MapWidth - 1 Then
East = Not (MapData(CurX + 1, CurY) = 1)
If East Then
If MapData(CurX + 1, CurY) <> 4 Then
BitBlt picDisplay.hDC, (CurX + 1) * m_clGridSize, CurY * m_clGridSize, m_clGridSize, m_clGridSize, picPass2.hDC, 0, 0, vbSrcCopy
End If
Else
BitBlt picDisplay.hDC, (CurX + 1) * m_clGridSize, CurY * m_clGridSize, m_clGridSize, m_clGridSize, picBlock2.hDC, 0, 0, vbSrcCopy
End If
Else
East = False
End If
If CurY < MapHeight - 1 Then
South = Not (MapData(CurX, CurY + 1) = 1)
If South Then
If MapData(CurX, CurY + 1) <> 4 Then
BitBlt picDisplay.hDC, CurX * m_clGridSize, (CurY + 1) * m_clGridSize, m_clGridSize, m_clGridSize, picPass2.hDC, 0, 0, vbSrcCopy
End If
Else
BitBlt picDisplay.hDC, CurX * m_clGridSize, (CurY + 1) * m_clGridSize, m_clGridSize, m_clGridSize, picBlock2.hDC, 0, 0, vbSrcCopy
End If
Else
South = False
End If
If CurX > 0 Then
West = Not (MapData(CurX - 1, CurY) = 1)
If West Then
If MapData(CurX - 1, CurY) <> 4 Then
BitBlt picDisplay.hDC, (CurX - 1) * m_clGridSize, CurY * m_clGridSize, m_clGridSize, m_clGridSize, picPass2.hDC, 0, 0, vbSrcCopy
End If
Else
BitBlt picDisplay.hDC, (CurX - 1) * m_clGridSize, CurY * m_clGridSize, m_clGridSize, m_clGridSize, picBlock2.hDC, 0, 0, vbSrcCopy
End If
Else
West = False
End If
picDisplay.Refresh
Score = Score + 6
UpCaption "PathFinder Contest - Score: " & Score
DoEvents
End Sub
Public Function Look(ByVal Direction As Byte) As Boolean
Select Case Direction
Case 1 'North
If CurY > 0 Then
Look = Not (MapData(CurX, CurY - 1) = 1)
If Look Then
If MapData(CurX, CurY - 1) <> 4 Then
BitBlt picDisplay.hDC, CurX * m_clGridSize, (CurY - 1) * m_clGridSize, m_clGridSize, m_clGridSize, picPass2.hDC, 0, 0, vbSrcCopy
End If
Else
BitBlt picDisplay.hDC, CurX * m_clGridSize, (CurY - 1) * m_clGridSize, m_clGridSize, m_clGridSize, picBlock2.hDC, 0, 0, vbSrcCopy
End If
Else
Look = False
End If
Case 2 'East
If CurX < MapWidth - 1 Then
Look = Not (MapData(CurX + 1, CurY) = 1)
If Look Then
If MapData(CurX + 1, CurY) <> 4 Then
BitBlt picDisplay.hDC, (CurX + 1) * m_clGridSize, CurY * m_clGridSize, m_clGridSize, m_clGridSize, picPass2.hDC, 0, 0, vbSrcCopy
End If
Else
BitBlt picDisplay.hDC, (CurX + 1) * m_clGridSize, CurY * m_clGridSize, m_clGridSize, m_clGridSize, picBlock2.hDC, 0, 0, vbSrcCopy
End If
Else
Look = False
End If
Case 3 'South
If CurY < MapHeight - 1 Then
Look = Not (MapData(CurX, CurY + 1) = 1)
If Look Then
If MapData(CurX, CurY + 1) <> 4 Then
BitBlt picDisplay.hDC, CurX * m_clGridSize, (CurY + 1) * m_clGridSize, m_clGridSize, m_clGridSize, picPass2.hDC, 0, 0, vbSrcCopy
End If
Else
BitBlt picDisplay.hDC, CurX * m_clGridSize, (CurY + 1) * m_clGridSize, m_clGridSize, m_clGridSize, picBlock2.hDC, 0, 0, vbSrcCopy
End If
Else
Look = False
End If
Case 4 'West
If CurX > 0 Then
Look = Not (MapData(CurX - 1, CurY) = 1)
If Look Then
If MapData(CurX - 1, CurY) <> 4 Then
BitBlt picDisplay.hDC, (CurX - 1) * m_clGridSize, CurY * m_clGridSize, m_clGridSize, m_clGridSize, picPass2.hDC, 0, 0, vbSrcCopy
End If
Else
BitBlt picDisplay.hDC, (CurX - 1) * m_clGridSize, CurY * m_clGridSize, m_clGridSize, m_clGridSize, picBlock2.hDC, 0, 0, vbSrcCopy
End If
Else
Look = False
End If
End Select
picDisplay.Refresh
Score = Score + 2
UpCaption
DoEvents
End Function
'Returns True when the end is reached...
Public Function MovePlayer(ByVal Direction As Byte) As Boolean
Dim DirToMove As Byte
Dim sTimer As sTime
Dim TargetLeft As Integer
Dim TargetTop As Integer
TargetLeft = picPlayer.Left
TargetTop = picPlayer.Top
Select Case Direction
Case 1 'North
If CurY > 0 Then
If Not (MapData(CurX, CurY - 1) = 1) Then
DirToMove = 1
CurY = CurY - 1
TargetTop = TargetTop - m_clGridSize
End If
End If
Case 2 'East
If CurX < MapWidth - 1 Then
If Not (MapData(CurX + 1, CurY) = 1) Then
DirToMove = 2
CurX = CurX + 1
TargetLeft = TargetLeft + m_clGridSize
End If
End If
Case 3 'South
If CurY < MapHeight - 1 Then
If Not (MapData(CurX, CurY + 1) = 1) Then
DirToMove = 3
CurY = CurY + 1
TargetTop = TargetTop + m_clGridSize
End If
End If
Case 4 'West
If CurX > 0 Then
If Not (MapData(CurX - 1, CurY) = 1) Then
DirToMove = 4
CurX = CurX - 1
TargetLeft = TargetLeft - m_clGridSize
End If
End If
End Select
If MapCovered(CurX, CurY) = False Then
MapCovered(CurX, CurY) = True
AreaCovered = AreaCovered + 1
End If
If MapData(CurX, CurY) <> 3 Then
BitBlt picDisplay.hDC, CurX * m_clGridSize, CurY * m_clGridSize, m_clGridSize, m_clGridSize, picPass3.hDC, 0, 0, vbSrcCopy
End If
Score = Score + 3
UpCaption
DoEvents
If True Then
'Animate...
Set sTimer = New sTime
sTimer.Init
sTimer.StartTime
Do
Do
DoEvents
sTimer.StopTime
Loop While sTimer.RetTime < (0.06 / ScrSpeed.Value)
sTimer.StartTime
Select Case DirToMove
Case 0 'Don't Move
Case 1 'North
picPlayer.Move picPlayer.Left, picPlayer.Top - 1
Case 2 'East
picPlayer.Move picPlayer.Left + 1, picPlayer.Top
Case 3 'South
picPlayer.Move picPlayer.Left, picPlayer.Top + 1
Case 4 'West
picPlayer.Move picPlayer.Left - 1, picPlayer.Top
End Select
DoEvents
Loop Until picPlayer.Left = TargetLeft And picPlayer.Top = TargetTop
Else
' FS, disable animation
picPlayer.Move TargetLeft, TargetTop
End If
'Returns True if the end is reached...
If MapData(CurX, CurY) = 4 Then
Compeleted = True
If MenuStop.Checked = False Then
MovePlayer = True
End If
End If
End Function
Private Sub Form_Load()
Dim sMap As String
'FS, map loading routine
cboMapList.Clear
sMap = Dir(App.Path & "\*.txt")
Do While sMap <> ""
cboMapList.AddItem sMap
sMap = Dir
Loop
cboMapList.ListIndex = 0
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
End
End Sub
Private Sub MenuFitness_Click()
MenuFitness.Checked = Not MenuFitness.Checked
UpCaption
End Sub
Private Sub MenuInvert_Click()
MenuInvert.Checked = Not MenuInvert.Checked
cmdLoadMap_Click
End Sub
Private Sub MenuMirrorH_Click()
MenuMirrorH.Checked = Not MenuMirrorH.Checked
cmdLoadMap_Click
End Sub
Private Sub MenuMirrorV_Click()
MenuMirrorV.Checked = Not MenuMirrorV.Checked
cmdLoadMap_Click
End Sub
Private Sub MenuStop_Click()
MenuStop.Checked = Not MenuStop.Checked
End Sub
Private Sub MenuSwitch_Click()
MenuSwitch.Checked = Not MenuSwitch.Checked
cmdLoadMap_Click
End Sub
Private Sub ScrSpeed_Change()
LblSpeed.Caption = "Speed: " & ScrSpeed.Value
DoEvents
End Sub
Private Sub ScrSpeed_Scroll()
ScrSpeed_Change
End Sub
Private Sub UpCaption()
On Error Resume Next
If MenuFitness.Checked Then
frmMain.Caption = "Score: " & Score & ", Fit: " & Format(AreaCovered * 3 / Score * MapWidth * MapHeight / TotalArea, "00.0000%")
Else
frmMain.Caption = "Score: " & Score & ", Fit: " & Format(AreaCovered * 3 / Score, "00.0000%")
End If
End Sub