form1.frm

迷宫寻找出口 采用穷举法 实现

Private Function PushStack(Stack As MStack, CX As Byte, CY As Byte) As Boolean
On Error GoTo ErrHandle
    Stack.StackPos = Stack.StackPos + 1
    ReDim Preserve Stack.St(Stack.StackPos)
    Stack.St(Stack.StackPos).ExpX = CX
    Stack.St(Stack.StackPos).ExpY = CY
    Exit Function
ErrHandle:
    PushStack = False
End Function

'出栈
Private Function PopStack(Stack As MStack, ByRef CX As Byte, ByRef CY As Byte) As Boolean
On Error GoTo ErrHandle
    If Not IsStackEmpty(Stack) Then
        CX = Stack.St(Stack.StackPos).ExpX
        CY = Stack.St(Stack.StackPos).ExpY
        Stack.StackPos = Stack.StackPos - 1
        PopStack = True
    Else
        PopStack = False
    End If
    Exit Function
ErrHandle:
    PopStack = False
End Function

'判断栈是为空
Private Function IsStackEmpty(Stack As MStack) As Boolean
    IsStackEmpty = True
    If Stack.StackPos > 0 Then
        IsStackEmpty = False
    End If
End Function

Private Sub cmdAbout_Click()
    frmAbout.Show 1, Me
End Sub

Private Sub cmdCal_Click()
    Dim Dir As Byte      '搜索方向
    Dim CurX As Byte, CurY As Byte
    Dim ExpX As Byte, ExpY As Byte
    Dim CityDisX As Integer, CityDisY As Integer
    Dim Tim As Double
    Dim PicWid As Integer, CellWid As Integer
    
    CellWid = picMain.Width / N
    
    cmdCal.Enabled = False
    cmdInit.Enabled = False
    cmdCls.Enabled = False
    picMain.FillStyle = 0
    lblMsg.Caption = "正在计算……"
    
    Call ClsStack(MazeStack)
    Call ClsStack(ResultStack)
    Call PushStack(MazeStack, 1, 1)                       '将起点入栈
    
    '迷宫路径的搜索
    'Dir代表的方向
    '0-向下     1-向左
    '2-向上     3-向右
    Do While Not IsStackEmpty(MazeStack)
        Call PopStack(MazeStack, CurX, CurY)                '弹出当前搜索点
        Call PushStack(ResultStack, CurX, CurY)
        
        If chkShowSearch.Value Then
            Tim = Timer
            Do While Timer - Tim < 0.4 / CDbl(N)
                DoEvents
            Loop
            
            '绘制行进路线
            If chkShowSearch.Value Then
                picMain.FillColor = &H80C0FF
                picMain.Circle (CellWid * (CurX - 0.5), CellWid * (CurY - 0.5)), CellWid / 4, &H80C0FF
            End If
        End If
        
        CityDisX = N - CurX
        CityDisY = N - CurY
            
        ExpX = CurX: ExpY = CurY
            
        '向最接近终点的方向搜索一步
        If CityDisX > CityDisY Then
            ExpX = CurX + 1
        Else
            ExpY = CurY + 1
        End If
            
        If Maze(ExpX, ExpY) = 0 Then
            Call PushStack(MazeStack, ExpX, ExpY)
            Maze(ExpX, ExpY) = 2
        Else
            '判断是否到达终点
            If Maze(ExpX, ExpY) = 3 And ExpX <> 1 And ExpY <> 1 Then
                lblMsg.Caption = "找到出口拉！"
                
                Call PaintPath  '绘制搜索到的路径
                
                cmdInit.Enabled = True
                cmdCls.Enabled = True
                
                Exit Sub
            End If
                
            '第一步搜索失败后采用四方向搜索法
            For Dir = 0 To 3
                Select Case Dir
                    Case 0
                        ExpX = CurX
                        ExpY = CurY + 1
                    Case 1
                        ExpX = CurX + 1
                        ExpY = CurY
                    Case 2
                        ExpX = CurX
                        ExpY = CurY - 1
                    Case 3
                        ExpX = CurX - 1
                        ExpY = CurY
                End Select
                If Maze(ExpX, ExpY) = 0 Then
                    Call PushStack(MazeStack, ExpX, ExpY)
                    Maze(ExpX, ExpY) = 2
                    Exit For
                Else
                    '判断是否到达终点
                    If Maze(ExpX, ExpY) = 3 And ExpX <> 1 And ExpY <> 1 Then
                        lblMsg.Caption = "找到出口拉！"
                        
                        Call PaintPath  '绘制搜索到的路径
                        
                        cmdInit.Enabled = True
                        cmdCls.Enabled = True
    
                        Exit Sub
                    End If
                End If
            Next Dir
            If Dir = 4 Then
                '如果起点的四个方向都搜索过，则认为没有通路
                If CurX = 1 And CurY = 1 Then
                    lblMsg.Caption = "好像没有出口……"
                    Call ClsStack(MazeStack)
                    Call ClsStack(ResultStack)
                    
                    cmdInit.Enabled = True
                    cmdCls.Enabled = True
                    
                    Exit Sub
                End If
                
                '退回一步
                If chkShowSearch.Value Then
                    picMain.FillColor = &H808080
                    picMain.Circle (CellWid * (CurX - 0.5), CellWid * (CurY - 0.5)), CellWid / 4, &H808080
                End If
                
                Call ClsStack(MazeStack)
                Call PopStack(ResultStack, CurX, CurY)
                Call PopStack(ResultStack, CurX, CurY)
                Call PushStack(MazeStack, CurX, CurY)
                'picMain.Circle (CellWid * (CurX - 0.5), CellWid * (CurY - 0.5)), CellWid / 4, &H00E0E0E0&
            End If
        End If
    Loop
    
End Sub

Private Sub cmdCls_Click()
    Dim I As Integer, J As Integer
    
    '清除迷宫路径
    For J = 0 To N + 1
        For I = 0 To N + 1
            If Maze(I, J) = 2 Then Maze(I, J) = 0
        Next I
    Next J
    
    Call PaintGround
    Call PaintMaze
    
    lstRst.Clear
    lblMsg.Caption = "已清除！"
    cmdCal.Enabled = True
End Sub

Private Sub cmdErase_Click()
    PenState = False
    
    picMain.MouseIcon = LoadResPicture(2, vbResIcon)
    picMain.MousePointer = vbCustom
End Sub

Private Sub cmdInit_Click()
    N = txtCellNum.Text
    
    If N <= 3 Then
        N = 3
        txtCellNum.Text = 3
    End If
    
    If N >= 100 Then
        N = 100
        txtCellNum.Text = 100
    End If
    
    cmdCal.Enabled = True
    lstRst.Clear
    
    Call InitMaze
End Sub

Private Sub cmdPen_Click()
    PenState = True
    picMain.MouseIcon = LoadResPicture(1, vbResCursor)
    picMain.MousePointer = vbCustom
End Sub

Private Sub Form_Load()
    N = txtCellNum
    
    If N <= 3 Then
        N = 3
        txtCellNum = 3
    End If
    
    If N >= 50 Then
        N = 50
        txtCellNum = 50
    End If
        
    picMain.AutoRedraw = True
    MouIsDown = False
    PenState = True
    
    picMain.MouseIcon = LoadResPicture(1, vbResCursor)
    picMain.MousePointer = vbCustom
    
    Call InitMaze
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    If MsgBox("你真的要退出吗？", vbYesNo + vbInformation, "确认") = vbYes Then
        End
    Else
        Cancel = 1
    End If
End Sub

Private Sub picMain_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim PicWid As Integer
    Dim CellWid As Integer
    Dim PosX As Integer, PosY As Integer
    
    MouIsDown = True
    
    PicWid = picMain.Width
    CellWid = PicWid / N
    
    '判断x,y是否在起点或者终点内
    If X <= CellWid And Y <= CellWid Then Exit Sub
    If X >= CellWid * (N - 1) And Y >= CellWid * (N - 1) Then Exit Sub
    
    If cmdCal.Enabled Then
        '计算绘画位置
        PosX = CellWid * (X \ CellWid)
        PosY = CellWid * (Y \ CellWid)
        
        If PenState Then
            picMain.Line (PosX + 1, PosY + 1)-(PosX + CellWid - 1, PosY + CellWid - 1), &H8000&, BF
            Maze(X \ CellWid + 1, Y \ CellWid + 1) = 1  '在迷宫数组中设置“围墙”
        Else
            picMain.Line (PosX + 1, PosY + 1)-(PosX + CellWid - 1, PosY + CellWid - 1), picMain.BackColor, BF
            Maze(X \ CellWid + 1, Y \ CellWid + 1) = 0  '擦除在迷宫数组中的“围墙”
        End If
    End If
End Sub

Private Sub picMain_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim PosX As Integer, PosY As Integer
    Dim PicWid As Integer
    Dim CellWid As Integer
    
    PicWid = picMain.Width
    CellWid = PicWid / N
    
    '判断x,y是否在起点或者终点内
    If X <= CellWid And Y <= CellWid Then Exit Sub
    If X >= CellWid * (N - 1) And Y >= CellWid * (N - 1) Then Exit Sub
    
    If MouIsDown And cmdCal.Enabled Then
        If X >= 0 And X <= PicWid And Y >= 0 And Y <= PicWid Then   '判断鼠标是否在图片框之内，以免下标越界
            '计算绘画位置
            PosX = CellWid * (X \ CellWid)
            PosY = CellWid * (Y \ CellWid)
            
            If PenState Then
                picMain.Line (PosX + 1, PosY + 1)-(PosX + CellWid - 1, PosY + CellWid - 1), &H8000&, BF
                Maze(X \ CellWid + 1, Y \ CellWid + 1) = 1  '在迷宫数组中设置“围墙”
            Else
                picMain.Line (PosX + 1, PosY + 1)-(PosX + CellWid - 1, PosY + CellWid - 1), picMain.BackColor, BF
                Maze(X \ CellWid + 1, Y \ CellWid + 1) = 0  '擦除在迷宫数组中的“围墙”
            End If
        End If
    End If
End Sub

Private Sub picMain_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    MouIsDown = False
    Maze(1, 1) = 3
    Maze(N, N) = 3
    'Call PaintCellNum
End Sub