[VB6 ] 迷宮程式的問題
應用所學寫了一隻程式
讓它可以自己產生迷宮 用亂數產生牆 用滑鼠點擊修改牆 清空牆 重新設定牆
等等功能
想問問各位前輩還有沒有可以優化的地方
BUG在請人玩了以後應該是沒有甚麼BUG了
另外inputbox不輸入東西按X會整個程式跳掉有辦法解決嗎@@
這是包裝好的程式:http://ppt.cc/!NPc
以下原始碼:
form1.frm
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public xd As Integer
Public yd As Integer
Const bound As Integer = 1500 '邊界值
Public num As Long '格子數
Public seed As Long '種子數
Dim map() As Obj
Private Sub Command1_Click()
ans
Command1.Enabled = False
End Sub
Private Sub Command2_Click()
seed = InputBox("請輸入障礙物數量")
Do While 1 > seed Or seed > num * num - 1
MsgBox "輸入有誤 數字限制在1~" & num * num - 1
seed = InputBox("請輸入障礙物數量")
Loop
ReDim map(num, num)
showMap
getRndMap seed
Command1.Enabled = True
End Sub
Private Sub Command3_Click()
num = InputBox("請輸入大小(1~200)")
Do While 1 > num Or num > 200
MsgBox "輸入有誤 數字限制在1~" & 200
num = InputBox("請輸入大小(1~200)")
Loop
seed = num * num * 0.3
xd = (Form1.ScaleWidth - bound * 2) / num
yd = (Form1.ScaleHeight - bound * 2) / num
ReDim map(num, num)
showMap
getRndMap seed
Command1.Enabled = True
End Sub
Private Sub Command4_Click()
ReDim map(num, num)
getRndMap seed
Command1.Enabled = True
End Sub
Private Sub Command5_Click()
Form2.Show
End Sub
Private Sub Command6_Click()
ReDim map(num, num)
Cls
showMap
Command1.Enabled = True
End Sub
Private Sub custom_Click()
If custom.Tag = 0 Then
custom.Caption = "停用自訂障礙"
custom.Tag = 1
Else
custom.Caption = "啟用自訂障礙"
custom.Tag = 0
End If
End Sub
Private Sub Form_Activate()
initNum
showMap
getRndMap seed
End Sub
Sub initNum()
seed = 20
num = 10
xd = (Form1.ScaleWidth - bound * 2) / num
yd = (Form1.ScaleHeight - bound * 2) / num
ReDim map(num, num)
End Sub
Sub showMap()
For cnt = 0 To num
Line (bound, bound + yd * cnt)-(bound + xd * num, bound + yd * cnt)
Line (bound + xd * cnt, bound)-(bound + xd * cnt, bound + yd * num)
Next
End Sub
Sub showObj(ByVal yoffset As Integer, ByVal xoffset As Integer, ByVal rgb_ As
Long)
'顯示物件 offset起始值0
Line (bound + xd * xoffset, bound + yd * yoffset)- _
(bound + xd * (xoffset + 1), bound + yd * (yoffset + 1)), rgb_, BF
Line (bound + xd * xoffset, bound + yd * yoffset)- _
(bound + xd * (xoffset + 1), bound + yd * (yoffset + 1)), RGB(0, 0, 0), B
End Sub
Function isWall(ByVal localSet As Long, ByVal nextSet As String) As Boolean
y = localSet \ num
x = localSet Mod num
Select Case nextSet
Case "r" 'right
If x = num - 1 Then isWall = True: Exit Function
If map(y, x + 1).wall = 1 Or map(y, x + 1).route = 1 Then isWall
= True: Exit Function
Case "l" 'left
If x = 0 Then isWall = True: Exit Function
If map(y, x - 1).wall = 1 Or map(y, x - 1).route = 1 Then isWall
= True: Exit Function
Case "t" 'top
If y = 0 Then isWall = True: Exit Function
If map(y - 1, x).wall = 1 Or map(y - 1, x).route = 1 Then isWall
= True: Exit Function
Case "b" 'bottom
If y = num - 1 Then isWall = True: Exit Function
If map(y + 1, x).wall = 1 Or map(y + 1, x).route = 1 Then isWall
= True: Exit Function
End Select
End Function
Sub getRndMap(ByVal seedNum As Long)
Randomize
Cls
totalN = num * num
ReDim numArr(totalN - 1) As Long
ReDim buff(seedNum) As Long
For i = LBound(numArr) To UBound(numArr)
numArr(i) = i
Next
For j = 0 To seedNum - 1
totalN = totalN - 1
tmpRnd = Int(Rnd * totalN + 1)
buff(j) = numArr(tmpRnd)
numArr(tmpRnd) = numArr(totalN)
Next
For k = LBound(buff) To UBound(buff) - 1
map(buff(k) \ num, buff(k) Mod num).wall = 1
showObj buff(k) \ num, buff(k) Mod num, RGB(0, 0, 255)
Next
showMap
End Sub
Sub ans()
Dim top As Long
Dim ptr As Long
tmp = num * num
ReDim stack(tmp) As Long
top = 0
ptr = 0
map(0, 0).route = 1
showObj 0, 0, RGB(0, 255, 100)
Do While ptr <> num * num - 1
If Not isWall(ptr, "r") Then
showObj (ptr \ num), (ptr Mod num), RGB(0, 255, 100)
map(ptr \ num, ptr Mod num).route = 1
stack(top) = ptr
top = top + 1
ptr = ptr + 1
ElseIf Not isWall(ptr, "b") Then
showObj (ptr \ num), (ptr Mod num), RGB(0, 255, 100)
map(ptr \ num, ptr Mod num).route = 1
stack(top) = ptr
top = top + 1
ptr = ptr + num
ElseIf Not isWall(ptr, "l") Then
showObj (ptr \ num), (ptr Mod num), RGB(0, 255, 100)
map(ptr \ num, ptr Mod num).route = 1
stack(top) = ptr
top = top + 1
ptr = ptr - 1
ElseIf Not isWall(ptr, "t") Then
showObj (ptr \ num), (ptr Mod num), RGB(0, 255, 100)
map(ptr \ num, ptr Mod num).route = 1
stack(top) = ptr
top = top + 1
ptr = ptr - num
ElseIf ptr = 0 Then '四面都是牆時檢查是否無解
MsgBox "無解": GoTo EXIT_LABEL
Else '走到死路 使用backtracking
showObj (ptr \ num), (ptr Mod num), Form1.BackColor
map(ptr \ num, ptr Mod num).route = 1
top = top - 1
ptr = stack(top)
map(ptr \ num, ptr Mod num).route = 0
End If
Loop
showObj num - 1, num - 1, RGB(0, 255, 100)
MsgBox "Find it"
EXIT_LABEL:
ReDim stack(tmp)
ReDim map(num, num)
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single,
y As Single)
If (x > bound And x < Form1.ScaleWidth - bound) And (y > bound And y <
Form1.ScaleHeight - bound) And custom.Tag = 1 Then
If map((y - bound) \ yd, (x - bound) \ xd).wall = 0 Then
map((y - bound) \ yd, (x - bound) \ xd).wall = 1
showObj (y - bound) \ yd, (x - bound) \ xd, RGB(0, 0, 255)
Else
map((y - bound) \ yd, (x - bound) \ xd).wall = 0
showObj (y - bound) \ yd, (x - bound) \ xd, Form1.BackColor
End If
End If
End Sub
Module1.bas
Type Obj
route As Integer
wall As Integer
End Type
--
※ 發信站: 批踢踢實業坊(ptt.cc)
◆ From: 123.240.28.247
→
04/30 23:23, , 1F
04/30 23:23, 1F
推
05/01 10:05, , 2F
05/01 10:05, 2F
→
05/01 11:45, , 3F
05/01 11:45, 3F
推
05/04 09:55, , 4F
05/04 09:55, 4F
→
05/04 09:55, , 5F
05/04 09:55, 5F
→
05/04 09:56, , 6F
05/04 09:56, 6F
→
05/10 20:30, , 7F
05/10 20:30, 7F