VBA随机地牢生成

无聊啊……于是，我想做一个随机地图。

但是我很懒，不想做。

但是身体很诚实。

这次是直接在Excel中制作的地图，但是，VB的执行效率很慢，我代码的效率也很慢，导致，一旦地图长宽稍大，就会出现好几分钟才能出现结果的效果。

而且，不能忍的是，随机崩溃！我至今没有找到原因在哪。

以下是VBA的代码

Sheet1全局

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Locked = True Then
        Cancel = True
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
'    Dim temp_coord As New Coord
'    Set temp_coord = world_map.tile_obj(Target.Column, Target.Row)
'    Call cell_ctrl.Change_cell(temp_coord.x, temp_coord.y, temp_coord.coord_type)
End Sub

类模块Cell_controller

Public Enum ENUM_CELL_COLOR
    BLACK = 1
    WHITE = 2
    RED = 3
    GREEN = 4
    BLUE = 5
    YELLOW = 6
    PINK = 7
    LIGHT_BLUE = 8
    DEEP_RED = 9
    DEEP_GREEN = 10
    DEEP_BLUE = 11
    DEEP_YELLOW = 12
    DEEP_PINK = 13
    DEEP_CYAN = 14
    LIGHT_GRAY = 15
    DEEP_GRAY = 16
End Enum

'声明延时函数
Private Declare PtrSafe Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)

Private is_change_style As Boolean
Private m_description As String

Private Sub Class_Initialize()
    ActiveWorkbook.Unprotect
    Application.ScreenUpdating = True
    is_change_style = False
    scroll_select(Nothing) = False
End Sub

'2. 将地图显示出来
Public Function Show_map()
    'Set m_map = para_map
    Sheet1.Rows.Clear

    If Not is_change_style Then
        Call Init_style(1)
    End If

    Dim grid_x As Integer
    Dim grid_y As Integer
    For grid_x = 1 To world_map.map_width Step 1
        For grid_y = 1 To world_map.map_height Step 1
            Call Change_cell(grid_x, grid_y, world_map.tile(grid_x, grid_y))
            DoEvents
        Next
    Next
End Function

'1. 更改表格整体样式，尽量让表格以正方形显示
Public Function Init_style(cell_size As Byte)
With Sheet1:
    If cell_size = 0 Then
        MsgBox "Cell Size Error!"
        Exit Function
    End If

    ActiveWorkbook.Styles("Normal").Font.name = "宋体"
    ActiveWorkbook.Styles("Normal").Font.Size = 12
    ActiveWorkbook.Styles("Normal").Font.Bold = False
    ActiveWorkbook.Styles("Normal").Font.Italic = False

    Application.ScreenUpdating = False
    'H=3.5+6*W, 宋体 12
    'For i = 1 To world_map.map_width
        .Rows.RowHeight = (1.88 * cell_size) * 6 + 3.72
        .Rows.HorizontalAlignment = xlCenter
        .Rows.VerticalAlignment = xlCenter
        'DoEvents
    'Next

    'For j = 1 To world_map.map_height
        .Columns.ColumnWidth = 1.88 * cell_size
        'DoEvents
    'Next

    Application.ScreenUpdating = True
    is_change_style = True
End With
End Function

'修改根据地板类型设定单元格的样式
Public Function Change_cell(x As Integer, y As Integer, val As ENUM_COORD_TYPE)
    With Sheet1:
        'Excel中，二维坐标的顺序为: 先纵y，后横x
        .Cells(y, x).Value = val

        Dim color_index As Byte
        Select Case val
            Case WALL:
                color_index = LIGHT_GRAY
            Case GROUND:
                color_index = WHITE
            Case GREEN_ENEMY:
                color_index = GREEN
            Case RED_ENEMY:
                color_index = RED
            Case BLUE_ENEMY:
                color_index = BLUE
            'TODO: Other Color Index.
            Case Else:
                MsgBox "val Error! ((y, x) is (" & x & ", " & y & "))"
        End Select

        .Cells(y, x).Interior.ColorIndex = color_index
    End With
End Function

'单元格的闪烁效果
'一般情况下，此函数要被循环调用。
'为了效率问题，避免在循环中申请内存，所以传入一个 temp_coord 临时变量用于循环
'
'coords: 设定那些坐标块需要被闪烁
'flick_rate_ms: 闪烁速率，毫秒为单位
'flick_color: 闪烁颜色
'temp_coord: 用于循环的临时变量
'
'CHECKIT: 此函数中的两个Sleep函数很有可能不符合要求，因为Sleep的过程中，无法进行其它过程的执行，除非多线程。可能需要利用空转DoEvents的方式来达到延时目的。
'CHECKIT: 此函数暂未经过测试
Public Function Cells_flick(ByRef coords As Object_vector, flick_rate_ms As Integer, flick_color As ENUM_CELL_COLOR, ByRef temp_coord As Coord)
    Dim i As Long
    With Sheet1
        For i = 1 To coords.arraysize Step 1
            Set temp_coord = coords.element(i)
            .Cells(temp_coord.y, temp_coord.x).Interior.ColorIndex = flick_color
        Next
    End With

    DoEvents
    Call Sleep(flick_rate_ms)

    For i = 1 To coords.arraysize Step 1
        Set temp_coord = coords.element(i)
        Call Cell_style_undo(temp_coord)
    Next

    DoEvents
    Call Sleep(flick_rate_ms)
End Function

'还原单元格的原本样式
'以内存中world_map的地板类型为标准
'CHECKIT: 此函数未经过测试
Private Function Cell_style_undo(ByRef each_coord As Coord)
    Call Change_cell(each_coord.x, each_coord.y, world_map.tile(each_coord.x, each_coord.y))    '此处并没有修改内存中的Map
End Function

'CHECKIT: 此函数未经过测试
Public Function Cell_move(ByVal src_pos As Coord, ByRef offset_coord As Coord)
    Dim r1 As Range
    Dim r2 As Range
    Set r1 = Sheet1.Cells(src_pos.y, src_pos.x)
    Set r2 = Sheet1.Cells(src_pos.y + offset_coord.y, src_pos.x + offset_coord.x)
    Call r1.Copy(r2)
    Call Cell_style_undo(src_pos)
End Function

'为一个单元格添加批注
Public Property Let description(ByRef where_cell As Coord, desc As String)
    Sheet1.Cells(where_cell.y, where_cell.x).AddComment Text:=desc
End Property

'选定某个单元格
Public Function Select_cell(ByRef where_cell As Coord)
    Sheet1.Cells(where_cell.y, where_cell.x).Select
    scroll_select(where_cell) = True
End Function

'锁定单元格的选择
Public Property Let scroll_select(ByRef where_cell As Coord, is_scroll As Boolean)
    If is_scroll Then
        Sheet1.ScrollArea = Cells(where_cell.y, where_cell.x).Address(False, False)
    Else
        Sheet1.ScrollArea = ""
    End If
End Property

'保护单元格
Public Property Let locked_cell(ByRef where_cell As Coord, is_lock As Boolean)
    Dim locked_cell As Range
    Set locked_cell = Cells(where_cell.y, where_cell.x)
    If is_lock Then
        'locked_cell.Locked = True
        ActiveSheet.Protect
    Else
        'locked_cell.Locked = False
        ActiveSheet.Unprotect
    End If
End Property

类模块Coord

Public Enum ENUM_COORD_TYPE
    NONE = -1
    GROUND = 0
    WALL = 1
    GREEN_ENEMY = 2
    RED_ENEMY = 4
    BLUE_ENEMY = 8
End Enum

Private m_x As Integer
Private m_y As Integer
Private m_coord_type As ENUM_COORD_TYPE    '坐标类型

Private Sub Class_Initialize()
    m_x = -1
    m_y = -1
    m_coord_type = NONE
End Sub

Private Sub Class_Terminate()
    m_x = -1
    m_y = -1
    m_coord_type = NONE
End Sub

Public Property Get x() As Integer
    x = m_x
End Property

Public Property Let x(para_x As Integer)
    m_x = para_x
End Property

Public Property Get y() As Integer
    y = m_y
End Property

Public Property Let y(para_y As Integer)
    m_y = para_y
End Property

Public Property Get coord_type() As ENUM_COORD_TYPE
    coord_type = m_coord_type
End Property

Public Property Let coord_type(para_type As ENUM_COORD_TYPE)
    m_coord_type = para_type
End Property

Public Function Is_Equal(ByRef other_coord As Coord) As Boolean
    If other_coord.x <> m_x Or other_coord.y <> m_y Or other_coord.coord_type <> m_coord_type Then
        Is_Equal = False
    Else
        Is_Equal = True
    End If
End Function

类模块Graphs_Generator

Private Enum GRAPHS_TYPE
    GRAPH_NONE = -1
    GRAPH_LINE = 0
    GRAPH_CIRCLE = 1
    GRAPH_COMMON = 2
    GRAPH_RHOMBUS = 3
    '... and so on
End Enum

Private m_coords As Object_vector
Private m_graph_type As GRAPHS_TYPE

Private Sub Class_Initialize()
    Set m_coords = New Object_vector
    m_coords.element_type = "Coord"
    m_graph_type = GRAPH_NONE
End Sub

Private Sub Class_Terminate()
    Set m_coords = Nothing
    m_graph_type = GRAPH_NONE
End Sub

Public Property Get coords() As Object_vector
    Set coords = m_coords
End Property

Public Function Get_line(ByRef coord_start As Coord, ByRef coord_end As Coord) As Object_vector
    Dim edge_max_x As Integer
    Dim edge_max_y As Integer
    edge_max_x = world_map.map_width
    edge_max_y = world_map.map_height

    '两点组成的向量
    Dim dx As Integer
    Dim dy As Integer
    dx = coord_end.x - coord_start.x
    dy = coord_end.y - coord_start.y

    '我先要知道dx, dy哪个才是最长的
    Dim dx_is_longer As Boolean
    Dim longer As Integer
    Dim shorter As Integer

    longer = dx
    shorter = dy
    dx_is_longer = True

    If Abs(dy) > Abs(dx) Then
        longer = dy
        shorter = dx
        dx_is_longer = False
    End If

    '最长的那个正负值
    Dim each_point_step As Integer
    each_point_step = IIf(longer > 0, 1, -1)

'    '最短的那个正负值
'    Dim each_short_step As Integer
'    each_short_step = IIf(short > 0, 1, -1)

    '斜率
    Dim slope As Double
    'slope = CDbl(Abs(shorter) / Abs(longer))
    slope = CDbl(shorter / longer)

    Dim temp_coord As New Coord
    Dim i As Integer
    '按longer循环，否则会出现“断链”情况
    For i = 0 To longer Step each_point_step
        temp_coord.coord_type = GROUND

        'longer上的点每前进一格，shorter上的点就前进slope格(0 <= slope <= 1)
        If dx_is_longer Then
            temp_coord.x = i
            temp_coord.y = Fix(i * slope)
            'temp_coord.y = each_short_step * Abs(i) * slope
        Else
            temp_coord.y = i
            temp_coord.x = Fix(i * slope)
            'temp_coord.x = each_short_step * Abs(i) * slope
        End If

        '应用在实际坐标系中
        temp_coord.x = coord_start.x + temp_coord.x
        temp_coord.y = coord_start.y + temp_coord.y
        If temp_coord.x > 1 And temp_coord.x < edge_max_x And temp_coord.y > 1 And temp_coord.y < edge_max_y Then
            Call m_coords.Push(temp_coord)
        End If
        Set temp_coord = Nothing
    Next
    m_graph_type = GRAPH_LINE
    Set Get_line = m_coords
End Function

'画圆
Public Function Get_circle(ByRef coord_center As Coord, radius As Integer) As Object_vector
    Dim edge_max_x As Integer
    Dim edge_max_y As Integer
    edge_max_x = world_map.map_width
    edge_max_y = world_map.map_height

    Dim res_circle_coords As New Object_vector

    Dim temp_coord As New Coord
    Dim grid_x As Integer
    Dim grid_y As Integer
    For grid_x = coord_center.x - radius To coord_center.x + radius Step 1
        For grid_y = coord_center.y - radius To coord_center.y + radius Step 1
            If (grid_x > 1 And grid_x < edge_max_x And grid_y > 1 And grid_y < edge_max_y) And ((grid_x - coord_center.x) * (grid_x - coord_center.x) + (grid_y - coord_center.y) * (grid_y - coord_center.y) <= radius * radius) Then
                temp_coord.x = grid_x
                temp_coord.y = grid_y
                temp_coord.coord_type = GROUND
                Call res_circle_coords.Push(temp_coord)

                Set temp_coord = Nothing
            End If
        Next
    Next
    m_graph_type = GRAPH_CIRCLE
    Set Get_circle = res_circle_coords
    Set m_coords = res_circle_coords

    Set res_circle_coords = Nothing
End Function

'画菱形
Public Function Get_rhombus(ByRef center_coord As Coord, radius As Integer) As Object_vector
    Dim edge_max_x As Integer
    Dim edge_max_y As Integer
    edge_max_x = world_map.map_width
    edge_max_y = world_map.map_height

    'y = -2|x - r| + 2r - 1
    'y = |x - r| + 1
    Dim res_coords As New Object_vector

    Dim total_coord_count As Long
    total_coord_count = 2 * radius * radius - 2 * radius + 1
    res_coords.arraysize = total_coord_count

    Dim i As Integer
    Dim j As Integer
    Dim x As Integer
    Dim y As Integer
    Dim temp_coord As Coord
    For i = 1 To (2 * radius - 1) Step 1
        For j = 1 To (2 * radius - 2 * Abs(i - radius) - 1) Step 1
            x = j + Abs(i - radius) + center_coord.x - radius
            y = i + center_coord.y - radius
            Set temp_coord = New Coord
            temp_coord.x = x
            temp_coord.y = y

            If (x > 1 And x < edge_max_x And y > 1 And y < edge_max_y) Then
                Call res_coords.Push(temp_coord)
            End If

            Set temp_coord = Nothing
        Next
    Next
    m_graph_type = GRAPH_RHOMBUS
    Set m_coords = res_coords
    Set Get_rhombus = res_coords
End Function

'最小成本生成树，Kruskal算法
'每条线的两个端点使用ID方式
'第一个ID始终不大于第二个ID
Public Function Get_min_cost_tree(lines As Object_vector, points_count As Integer) As Object_vector
    If lines.element_type <> "Shortest_distance" Then
        Exit Function
    End If

    '邻接矩阵
    Dim adjacency_matrix() As Integer
    ReDim adjacency_matrix(1 To points_count, 1 To points_count) As Integer

    Dim res_lines As New Object_vector
    res_lines.element_type = "Shortest_distance"

    Dim each_line As New Shortest_distance
    Dim i As Integer
    i = 1
    '生成边
    '一共 points_count 个点，则最小生成树存在 points_count - 1 条边
    While i < points_count
        Set each_line = Find_shortest_distance(lines)
        If Not Find_ring(each_line, points_count, adjacency_matrix) Then
            Call res_lines.Push(each_line)
            i = i + 1
            adjacency_matrix(each_line.room1_id, each_line.room2_id) = 1
            adjacency_matrix(each_line.room2_id, each_line.room1_id) = 1
        End If
        Set each_line = Nothing
    Wend
    m_graph_type = GRAPH_COMMON
    Set Get_min_cost_tree = res_lines
    Set res_lines = Nothing
End Function

'寻找最短的那条边
Private Function Find_shortest_distance(ByRef lines As Object_vector)
    Dim shortest As Long
    shortest = &H7FFFFFFF
    Dim shortest_group As New Shortest_distance

    Dim shortest_group_index As Long
    Dim i As Long
    For i = 1 To lines.arraysize Step 1
        If shortest > lines.element(i).distance Then
            shortest = lines.element(i).distance
            Set shortest_group = lines.element(i)
            shortest_group_index = i
        End If
    Next
    Set Find_shortest_distance = shortest_group
    Set shortest_group = Nothing
    Call lines.Delete(CLng(shortest_group_index))
End Function

'判断新加入的边是否构成了环
Public Function Find_ring(new_line As Shortest_distance, points_count As Integer, matrix() As Integer) As Boolean
    matrix(new_line.room1_id, new_line.room2_id) = 1
    matrix(new_line.room2_id, new_line.room1_id) = 1

    '每个顶点的度
    Dim ranges() As Integer
    ReDim ranges(1 To points_count) As Integer

    Dim is_found_1_range_point As Boolean
    Dim is_found_morethan2_range_point As Boolean

    '获取每个顶点的度
    Dim i As Integer
    Dim j As Integer
    For i = 1 To points_count Step 1
        For j = 1 To points_count Step 1
            ranges(i) = ranges(i) + matrix(i, j)
        Next
        If ranges(i) = 1 Then
            is_found_1_range_point = True
        End If
    Next

    '将每个度为1的点，和与它相连的点，降度
    While is_found_1_range_point = True
        is_found_1_range_point = False
        For i = 1 To points_count Step 1
            If ranges(i) = 1 Then
                is_found_1_range_point = True
                For j = 1 To points_count Step 1
                    If matrix(i, j) = 1 Then
                        ranges(i) = ranges(i) - 1
                        ranges(j) = ranges(j) - 1
                    End If
                Next
            End If
        Next
    Wend

    '是否存在度不小于2的点
    For i = 1 To points_count Step 1
        If ranges(i) >= 2 Then
            Find_ring = True
            matrix(new_line.room1_id, new_line.room2_id) = 0
            matrix(new_line.room2_id, new_line.room1_id) = 0
            Exit Function
        End If
    Next
    Find_ring = False
End Function

Private Function Find_line(lines As Object_vector, found_line As Shortest_distance) As Boolean
    Dim i As Long
    For i = 1 To lines.arraysize Step 1
        Set each_line = lines.element(i)

        '无向图
        If (found_line.room1_id = each_line.room1_id And found_line.room2_id = each_line.room2_id) Or (found_line.room1_id = each_line.room2_id And found_line.room2_id = each_line.room1_id) Then
            Find_line = True
            Exit Function
        End If

        Set each_line = Nothing
    Next
    Find_line = False
End Function

'A*寻路算法
Public Function Find_way(ByRef coord_start As Coord, ByRef coord_end As Coord) As Object_vector
    Dim here_coord As New Coord
    Dim next_coord As New Coord
    Dim queue_coord As New Object_vector
    Dim map_flag() As Long
    ReDim map_flag(1 To world_map.map_width, 1 To world_map.map_height)
    'Call queue_coord.Push(coord_start)
    Set here_coord = coord_start
    map_flag(coord_start.x, coord_start.y) = 1

    '设置能够行走的方向
    Dim offset(1 To 4) As New Coord
    Dim temp_coord As Coord
    Dim i As Byte
    For i = 1 To 4 Step 1
        Set temp_coord = New Coord
        Select Case i
            Case 1
                temp_coord.x = 0
                temp_coord.y = 1
            Case 2
                temp_coord.x = 1
                temp_coord.y = 0
            Case 3
                temp_coord.x = 0
                temp_coord.y = -1
            Case 4
                temp_coord.x = -1
                temp_coord.y = 0
        End Select
        Set offset(i) = temp_coord
        Set temp_coord = Nothing
    Next

    '标记行走步数
    Dim nbr_coord As Coord
    Do
        For i = 1 To 4 Step 1
            Set nbr_coord = New Coord
            '开始逐个遍历 here_coord 的四个相邻坐标
            nbr_coord.x = here_coord.x + offset(i).x
            nbr_coord.y = here_coord.y + offset(i).y

            If Not world_map.Is_map_edge(nbr_coord.x, nbr_coord.y) Then
                If map_flag(nbr_coord.x, nbr_coord.y) = 0 And world_map.tile(nbr_coord.x, nbr_coord.y) = GROUND Then
                    map_flag(nbr_coord.x, nbr_coord.y) = map_flag(here_coord.x, here_coord.y) + 1
                    If nbr_coord.x = coord_end.x And nbr_coord.y = coord_end.y Then
                        GoTo Finish
                    End If

                    Call queue_coord.Push(nbr_coord)
                End If
            End If
            DoEvents
        Next

        If nbr_coord.x = coord_end.x And coord_end.y = nbr_coord.y Then
Finish:
            Exit Do
        End If

        'Set here_coord = Nothing

        If queue_coord.Is_empty Then
            Set Find_way = Nothing
            Exit Function
        End If

        Set here_coord = queue_coord.element(1)
        Call queue_coord.Delete(1)
    Loop While True

    '记录路径
    Dim path As New Object_vector
    Set here_coord = coord_end
    Dim flag As Long
    flag = map_flag(coord_end.x, coord_end.y)
    Call path.Push(world_map.tile_obj(here_coord.x, here_coord.y))
    Do
        flag = flag - 1
        Set nbr_coord = New Coord
        For i = 1 To 4 Step 1
            nbr_coord.x = here_coord.x + offset(i).x
            nbr_coord.y = here_coord.y + offset(i).y
            If map_flag(nbr_coord.x, nbr_coord.y) = flag Then
                Call path.Insert(1, nbr_coord)

                GoTo Next_step
            End If
        Next
Next_step:
        Set here_coord = nbr_coord
        Set nbr_coord = Nothing
    Loop While flag > 1

    Set Find_way = path
End Function

类模块Map

'地图类，用于生成地图
'其中，平滑地图及清除小房间算法借鉴于Unity官方

Option Explicit

Private m_map As Object_vector
Private m_width As Integer
Private m_height As Integer

Private m_rooms As Object_vector
Private m_active_rooms As Object_vector
Private m_random_fill_percent As Byte

Private Sub Class_Initialize()
    ActiveWorkbook.Unprotect
    Application.ScreenUpdating = False

    Set m_map = New Object_vector
    m_map.element_type = "Coord"

    Set m_rooms = New Object_vector
    m_rooms.element_type = "Object_vector"  'm_rooms.element.element_type is "Coord"

    Set m_active_rooms = New Object_vector
    m_active_rooms.element_type = "Room"

    m_width = 0
    m_height = 0
End Sub

Private Sub Class_Terminate()
    Set m_map = Nothing
    Set m_rooms = Nothing
    Set m_active_rooms = Nothing
End Sub

'根据指定的索引值返回横坐标x
Private Property Get coord_x(array_index As Long) As Integer
    Dim res As Integer
    res = array_index Mod m_width

    coord_x = IIf(res = 0, m_width, res)
End Property

'根据指定的索引值返回纵坐标y
Private Property Get coord_y(array_index As Long) As Integer
    coord_y = -(Int(-(array_index / m_width)))
End Property

'根据指定的坐标(x, y)返回索引值
Private Property Get coord_index(x As Integer, y As Integer) As Long
    coord_index = (y - 1) * CLng(m_width) + x
End Property

'检查坐标是否合法
Private Function Check_coord(x As Integer, y As Integer) As Boolean
    Dim check_coord_x As Boolean
    Dim check_coord_y As Boolean
    check_coord_x = True
    check_coord_y = True

    If x < 1 Or x > m_width Then
        check_coord_x = False
        MsgBox ("Map::Check_coord: Error Coord X! x/width is: " & x & "/" & m_width)
    End If

    If y < 1 Or y > m_height Then
        check_coord_y = False
        MsgBox ("Map::Check_coord: Error Coord Y! y/height is: " & y & "/" & m_height)
    End If

    Check_coord = check_coord_x And check_coord_y
End Function

'为map中每个坐标申请空间
Private Function Init_map(width As Integer, height As Integer)
    m_width = width
    m_height = height
    Dim map_tile_count As Long
    map_tile_count = CLng(m_width) * m_height

    m_map.arraysize = map_tile_count

    Dim i As Long
    Dim each_tile As Coord
    For i = 1 To map_tile_count Step 1
        Set each_tile = New Coord
        each_tile.x = coord_x(i)
        each_tile.y = coord_y(i)
        'each_tile.coord_type = NONE

        Call m_map.Insert(i, each_tile)
        Set each_tile = Nothing
        DoEvents
    Next

End Function
'根据指定坐标(x, y)获得地板类型
Public Property Get tile(x As Integer, y As Integer) As ENUM_COORD_TYPE
    If Not Check_coord(x, y) Then
        Exit Property
    End If
    tile = m_map.element(coord_index(x, y)).coord_type
End Property

'根据指定坐标(x, y)修改该坐标的地板类型
Public Property Let tile(x As Integer, y As Integer, tile_type As ENUM_COORD_TYPE)
    If Not Check_coord(x, y) Then
        Exit Property
    End If
    m_map.element(coord_index(x, y)).coord_type = tile_type
End Property

Public Property Get tile_obj(x As Integer, y As Integer) As Coord
    If Not Check_coord(x, y) Then
        Exit Property
    End If
    Set tile_obj = m_map.element(coord_index(x, y))
End Property

Public Property Get map_width() As Integer
    map_width = m_width
End Property

Public Property Get map_height() As Integer
    map_height = m_height
End Property

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'0.生成地图
Public Function Generate_map(width As Integer, height As Integer, random_fill_percent As Byte)
    If random_fill_percent < 0 Or random_fill_percent > 100 Then
        MsgBox ("random_fill_percent Error! random_fill_percent is " & random_fill_percent & "/[0, 100].")
        Exit Function
    End If
    m_random_fill_percent = random_fill_percent

    Call Init_map(width, height)
    Call Random_fill_map(random_fill_percent)
    Call Smooth_map
    Call Get_rooms
    Call Erase_little_room(50, True)
    Call Connect_room

    Set m_rooms = Nothing
    Set m_active_rooms = Nothing
End Function

'1.将地图随机填充
Private Function Random_fill_map(random_fill_percent As Byte)
    Randomize
    Dim grid_x As Integer
    Dim grid_y As Integer
    For grid_x = 1 To m_width Step 1
        For grid_y = 1 To m_height Step 1
            If Is_map_edge(grid_x, grid_y) Then
                tile(grid_x, grid_y) = WALL
            Else
                tile(grid_x, grid_y) = IIf((Int(Rnd * 100 + 1) > random_fill_percent), WALL, GROUND)
            End If
            DoEvents
        Next
    Next

End Function

'2.平滑地图，生成地图概括
Private Function Smooth_map()
    Dim surr_walls As Byte

    Dim grid_x As Integer
    Dim grid_y As Integer
    For grid_x = 1 To m_width Step 1
        For grid_y = 1 To m_height Step 1
            '不遍历地图边缘的坐标
            If Is_map_edge(grid_x, grid_y) Then
                GoTo Next_loop
            End If

            '当前坐标周围的墙壁数量最多8块:[0,8]
            surr_walls = Get_surrounding_wall_count(grid_x, grid_y)
            '若当前坐标周围的墙壁(WALL)数量小于4块，则认为这是一块空地(GROUND)
            If surr_walls < 4 Then
                tile(grid_x, grid_y) = GROUND
            End If
            '若当前坐标周围的墙壁(WALL)数量大于4块，则认为这是一块墙壁(WALL)
            If surr_walls > 4 Then
                tile(grid_x, grid_y) = WALL
            End If
            DoEvents
Next_loop:
        Next
    Next

End Function

'根据指定坐标(x, y)获得周围的WALL数量
Private Function Get_surrounding_wall_count(x As Integer, y As Integer) As Byte
    Dim walls As Byte
    walls = 0

    Dim nbour_x As Integer
    Dim nbour_y As Integer
    For nbour_x = x - 1 To x + 1 Step 1
'        '不必判断坐标是否合法，因为此函数的使用场合都不会遍历地图边缘
'        '若坐标不处于地图边缘，则它周围的8块坐标一定合法
'        If nbour_x < 1 Or nbour_x > m_width Then
'            GoTo continue_next_x
'        End If

        For nbour_y = y - 1 To y + 1 Step 1
'            If nbour_y < 1 Or nbour_y > m_height Then
'                GoTo continue_next_y
'            End If

            If Is_map_edge(nbour_x, nbour_y) Then
                walls = walls + 1
            Else
                If nbour_x <> x Or nbour_y <> y Then
                    walls = walls + Int(tile(nbour_x, nbour_y))
                End If
            End If
'continue_next_y:
        Next
'continue_next_x:
    Next

    Get_surrounding_wall_count = walls

End Function

'3. 获得房间列表
Private Function Get_rooms()
    Dim temp_tile_type As ENUM_COORD_TYPE
    Dim map_flags() As Byte
    ReDim map_flags(1 To m_width, 1 To m_height) As Byte

    Dim grid_x As Integer
    Dim grid_y As Integer
    Dim one_room As New Object_vector
'    For grid_x = 2 To m_width - 1 Step 1   '不遍历地图边缘
'        For grid_y = 2 To m_height - 1 Step 1    '下面的代码虽然多了一些执行步...
'           If map_flags(grid_x, grid_y) = 0 Then    '但是好理解
    Dim room_tile_index As Long
    For grid_x = 1 To m_width Step 1
        For grid_y = 1 To m_height Step 1
            If (Not Is_map_edge(grid_x, grid_y)) And (map_flags(grid_x, grid_y) = 0) Then     '不遍历地图边缘 和 处理过的房间
                Set one_room = Get_region(grid_x, grid_y)
                Call m_rooms.Push(one_room)

                For room_tile_index = 1 To one_room.arraysize Step 1
                    map_flags(one_room.element(room_tile_index).x, one_room.element(room_tile_index).y) = 1
                Next
            End If
            DoEvents
        Next
    Next
'    Set Get_rooms = m_rooms     'DEBUG: test
    Set one_room = Nothing

End Function

'3.1.获得一片区域
Private Function Get_region(start_x As Integer, start_y As Integer) As Object_vector
    Dim queue As New Object_vector  '只许使用 {queue.Push(obj);} 和 {queue.element(1); Delete(1);}. 队列, 处理被循环元素
    Dim temp_tile_type As ENUM_COORD_TYPE   '获得区域的地板类型
    Dim map_flags() As Byte     '标识。被处理过的元素设置为1，否则为0。默认所有Byte类型的标识为0。
    ReDim map_flags(1 To m_width, 1 To m_height) As Byte
    Dim res_coords As New Object_vector

    '初始，将参数中的坐标元素压入队列，准备处理
    Dim start_tile As New Coord
    start_tile.x = start_x
    start_tile.y = start_y
    start_tile.coord_type = tile(start_x, start_y)
    Call queue.Push(start_tile)

    Call res_coords.Push(start_tile)

    map_flags(start_x, start_y) = 1
    temp_tile_type = start_tile.coord_type

    Dim temp_coord As New Coord
    While Not queue.Is_empty
        '处理队列中的元素
        Set temp_coord = queue.element(1)
        Call queue.Delete(1)
        '对队列中的每个元素进行十字搜索
        Dim grid_x As Integer
        Dim grid_y As Integer
        For grid_x = temp_coord.x - 1 To temp_coord.x + 1 Step 1
            For grid_y = temp_coord.y - 1 To temp_coord.y + 1 Step 1
                If Is_map_edge(grid_x, grid_y) Then
                    'map_flags(grid_x, grid_y) = 1
                    GoTo Next_grid  'continue;
                End If
                '十字搜索
                If (grid_x = temp_coord.x Or grid_y = temp_coord.y) And (map_flags(grid_x, grid_y) = 0) Then
                    map_flags(grid_x, grid_y) = 1
                    If temp_tile_type = tile(grid_x, grid_y) Then
                        '地板类型与参数的地板类型相同，则加入队列，下次处理
                        Call res_coords.Push(m_map.element(coord_index(grid_x, grid_y)))
                        Call queue.Push(m_map.element(coord_index(grid_x, grid_y)))
                        'Sheet1.Cells(grid_y, grid_x).Interior.ColorIndex = 8 'Light Blue   'test code: show region
                    End If
                End If
                DoEvents
Next_grid:
            Next
        Next
        Set temp_coord = Nothing
    Wend
    Set Get_region = res_coords
    Set queue = Nothing
    Set start_tile = Nothing

End Function

'4. 再次平滑地图
'4.1 擦除小房间
'4.2 得到可活动的房间 m_active_rooms
Private Function Erase_little_room(little_room_size As Integer, is_dependon_random_fill_percent As Boolean)
    If m_rooms.Is_empty Then
        MsgBox "Rooms is empty! Call function Map::Get_rooms()."
        Exit Function
    End If

    If is_dependon_random_fill_percent Then
        little_room_size = Int(m_random_fill_percent / 2)
    End If

    '遍历m_rooms
    Dim rooms_count As Integer
    rooms_count = m_rooms.arraysize

    Dim room_type As ENUM_COORD_TYPE
    Dim each_room As New Object_vector
    Dim active_room As New Room
    Dim each_room_index As Integer
    For each_room_index = 1 To rooms_count Step 1

        'Set each_room = New Object_vector
        Set each_room = m_rooms.element(CLng(each_room_index))

        room_type = each_room.element(1).coord_type
        Select Case room_type
            '地板是可活动的
            Case GROUND:
                '这不是一个小房间
                If Not Erase_room(each_room, little_room_size) Then
                    '那么，应该将它加入到可活动房间列表 m_active_rooms 中
                    active_room.tiles = each_room
                    active_room.room_edge = Set_room_edge(active_room)
                    Call m_active_rooms.Push(active_room)
                    Set active_room = Nothing
                End If
            Case WALL:
                Call Erase_room(each_room, little_room_size)
            Case Else:
                'CHECK IT: ?? 如果地板类型除了以上两种，这说明是出错了。那么我应该做点儿什么？
        End Select
        Set each_room = Nothing
        DoEvents
    Next

End Function

'寻找房间边缘(边缘的类型与房间类型相同)(妈蛋程序结构设计失误，这个函数不应该在这儿的)
'这里的地图边缘并不是十分精准，因为，如果一个可活动的房间中存在一个已经被擦除过的小房间, 则会造成失误
'但不会影响最后的计算结果。因为房间边缘主要用于设置房间通路，即使边缘存在于房间*，也不会让*的点去与其它房间的边缘向连接，
'因为只有真正的边缘和边缘靠的更近
'正因为这样，也会导致房间列表中的每个房间的地板会包含不完全情况。但同样不影响计算。
Private Function Set_room_edge(ByRef para_room As Room) As Object_vector
    Dim temp_tile As New Coord
    Set Set_room_edge = New Object_vector
    Dim i As Long
    For i = 1 To para_room.room_size Step 1
        Set temp_tile = para_room.tiles.element(i)  'm_tiles.element(i)

        If Get_surrounding_wall_count(temp_tile.x, temp_tile.y) > 0 Then
            Call Set_room_edge.Push(temp_tile)
        End If
        DoEvents
    Next
    Set temp_tile = Nothing
End Function

'4.1 擦除小房间
Private Function Erase_room(ByRef one_room As Object_vector, erase_room_size_min As Integer) As Boolean
    If (Not one_room.Is_empty) And (one_room.arraysize < erase_room_size_min) Then

        Dim tile_type As ENUM_COORD_TYPE
        tile_type = one_room.element(1).coord_type

        '执行擦除
        Dim each_tile_index As Long
        For each_tile_index = 1 To one_room.arraysize Step 1
            tile(one_room.element(each_tile_index).x, one_room.element(each_tile_index).y) = IIf(tile_type <> NONE And tile_type = GROUND, WALL, GROUND)
            DoEvents
        Next

        '如果这是一个小房间，则返回True
        Erase_room = True
    Else
        '如果这不是一个小房间，则返回False
        Erase_room = False
    End If

End Function

'5.创建房间通路
Public Function Connect_room()
    Dim distance_rooms As New Object_vector
    Set distance_rooms = Get_shortest_distance_all_room

    Dim graph_creater As New Graphs_Generator

    Dim passage As New Object_vector
    Set passage = graph_creater.Get_min_cost_tree(distance_rooms, m_active_rooms.arraysize)

    Dim coord1 As New Coord
    Dim coord2 As New Coord
    Dim i As Integer
    For i = 1 To passage.arraysize Step 1
        Set coord1 = passage.element(CLng(i)).shortest_coord1
        Set coord2 = passage.element(CLng(i)).shortest_coord2

        Call Draw_passage(coord1, coord2)

        Set coord2 = Nothing
        Set coord1 = Nothing
    Next
End Function

'5.3 绘制两点之间的通路
Private Function Draw_passage(ByRef coord1 As Coord, ByRef coord2 As Coord)
    Dim graph As New Graphs_Generator
    Dim coords_line As New Object_vector
    Dim coords_circle As New Object_vector

    Set coords_line = graph.Get_line(coord1, coord2)
    Dim coord_center As New Coord

    Dim grid_count As Integer
    For grid_count = 1 To coords_line.arraysize Step 1
        Set coords_circle = graph.Get_circle(coords_line.element(CLng(grid_count)), 2)

        Dim circle_grid_count As Integer
        For circle_grid_count = 1 To coords_circle.arraysize Step 1
            tile(coords_circle.element(CLng(circle_grid_count)).x, coords_circle.element(CLng(circle_grid_count)).y) = GROUND

            DoEvents
        Next

        Set coords_circle = Nothing
    Next
    Set graph = Nothing
    Set coords_line = Nothing
End Function

'5.1.获得所有房间之间的最短距离
Public Function Get_shortest_distance_all_room() As Object_vector
    Dim room_a As New Room
    Dim room_b As New Room

    Dim active_room_count As Integer

    Dim rooms_distance As New Object_vector
    Dim distance As New Shortest_distance

    active_room_count = m_active_rooms.arraysize

    Dim a As Integer
    Dim b As Integer
    For a = 1 To active_room_count Step 1
        Set room_a = m_active_rooms.element(CLng(a))

        For b = a + 1 To active_room_count Step 1
            If a <> b Then
                Set room_b = m_active_rooms.element(CLng(b))

                Set distance = Get_shortest_distance(room_a, room_b)
                distance.room1_id = a
                distance.room2_id = b

                Call rooms_distance.Push(distance)

                Set distance = Nothing
                Set room_b = Nothing
            End If
            DoEvents
        Next
        Set room_a = Nothing
    Next
    Set Get_shortest_distance_all_room = rooms_distance
End Function

'5.2.获得两个房间的最短距离
Private Function Get_shortest_distance(ByRef room_a As Room, ByRef room_b As Room) As Shortest_distance
    Dim shortest_dis As Long
    shortest_dis = &H7FFFFFFF

    Dim res_distance As New Shortest_distance
    Dim shortest_tile_A As New Coord
    Dim shortest_tile_B As New Coord

    Dim edge_tiles_count_a As Long
    Dim edge_tiles_count_b As Long

    Dim temp_distance As Long
    For edge_tiles_count_a = 1 To room_a.room_edge.arraysize Step 1
        Set shortest_tile_A = room_a.room_edge.element(edge_tiles_count_a)

        For edge_tiles_count_b = 1 To room_b.room_edge.arraysize Step 1
            Set shortest_tile_B = room_b.room_edge.element(edge_tiles_count_b)

            temp_distance = CLng((shortest_tile_A.x - shortest_tile_B.x)) * (shortest_tile_A.x - shortest_tile_B.x) + CLng((shortest_tile_A.y - shortest_tile_B.y)) * (shortest_tile_A.y - shortest_tile_B.y)
            If temp_distance < shortest_dis Then
                shortest_dis = temp_distance
                Set res_distance.shortest_coord1 = shortest_tile_A
                Set res_distance.shortest_coord2 = shortest_tile_B
                res_distance.distance = shortest_dis
            End If

            Set shortest_tile_B = Nothing
        Next

        Set shortest_tile_A = Nothing
    Next
    Set Get_shortest_distance = res_distance
    Set res_distance = Nothing
End Function

'判断指定坐标(x, y)是否是地图边缘
Public Function Is_map_edge(x As Integer, y As Integer) As Boolean
    Is_map_edge = Not (x > 1 And x < m_width And y > 1 And y < m_height)
End Function

类模块Object_vector

'1.可变空间数组，数组中的值类型为对象类型
'2.只能存储相同类型的对象
'3.数组中的值传递方式为引用传递
'4.有可能造成环形依赖
''''''''''''''''''''''''''''''''''''''''''''''

Option Explicit

Private m_datas() As Object   '存储的数据
Private m_length As Long      '数据元素数量
Private m_useable_length As Long  '可用空间长度
Private m_element_type As String  '对象类型
Private Const ex_space_coe As Double = 0.5  '可用空间扩张系数
Private Const init_space As Integer = 10    '默认初始空间

'初始化空间为 10
Private Sub Class_Initialize()
    ReDim m_datas(1 To init_space)
    Dim i As Integer
    For i = 1 To init_space Step 1
        '无论何时，对象之间赋值需要 Set 关键字
        Set m_datas(i) = Nothing
    Next
    m_length = 0
    m_useable_length = init_space
    m_element_type = ""
End Sub

Private Sub Class_Terminate()
    'Erase m_datas
    Call Clean
    ReDim m_datas(0)
End Sub

Public Property Get element_type() As String
    element_type = m_element_type
End Property

Public Property Let element_type(ele_type As String)
    If m_element_type = "" Then
        m_element_type = ele_type
    Else
        'TODO: Not modfity value "m_element_type"
    End If
End Property

'获取数组长度
Public Property Get arraysize() As Long
    arraysize = m_length
End Property

'重设可用空间大小
Public Property Let arraysize(new_size As Long)
    ReDim Preserve m_datas(1 To new_size)
    m_useable_length = new_size
    If m_length > m_useable_length Then
        m_length = m_useable_length
    End If
End Property

'获得索引为 index 的数据元素
Public Property Get element(index As Long) As Object
    If True = Check_index(index) Then
        Set element = m_datas(index)
    Else
        MsgBox ("Get_element: Index Error!")
        Exit Property
    End If
End Property

'将索引为 index 的数据元素设置为 element_data
Public Property Let element(index As Long, ByRef element_data As Object)
    If Not Check_type(m_element_type, element_data) Then
        MsgBox ("Let element: Object Type Error!")
        Exit Property
    End If

    If True = Check_index(index) Then
        Set m_datas(index) = element_data
    Else
        MsgBox ("Let_element: Index Error!")
        Exit Property
    End If
End Property

Public Function Insert(index As Long, ByRef element_data As Object)
    '数组中只能存储相同类型的对象
    If (m_element_type = "") Then
        m_element_type = TypeName(element_data)
    Else
        If Not Check_type(m_element_type, element_data) Then
            MsgBox ("Insert: Object Type Error!")
            Exit Function
        End If
    End If

    '一旦可用空间不足，则将可用空间扩大0.5倍
    If m_length = m_useable_length Then
        arraysize = m_useable_length + Int(m_useable_length * ex_space_coe)
    End If

    '如果 index 为 -1，在末尾插入
    index = Switch_index(index)

    'index 值非法
    If index < 1 Or index > m_length + 1 Then
        MsgBox ("Insert: Index Error!")
        Exit Function
    Else
        'index 后的数据向后移位
        Dim i As Long
        For i = m_length To index Step -1
            'MsgBox ("move: " & i) 'It is used for test
            Set m_datas(i + 1) = m_datas(i)
        Next

        '在index的位置插入值
        Set m_datas(index) = element_data

        '数组长度 +1，可用空间不变
        m_length = m_length + 1

    End If

End Function

'删除元素
Public Function Delete(index As Long)
    'index 值非法
    If Not Check_index(index) Then
        MsgBox ("Delete: Index Error!" & "(index is " & index & ")")
        Exit Function
    '开始删除元素
    Else
        '释放元素
        Set m_datas(index) = Nothing

        'index 之后的元素向前移动 1
        Dim i As Long
        For i = index + 1 To m_length Step 1
            Set m_datas(i - 1) = m_datas(i)
        Next
        Set m_datas(m_length) = Nothing
        '元素数量 -1
        m_length = m_length - 1
    End If

End Function

'清除所有数据
Public Function Clean()
    Dim i As Long
    For i = 1 To m_length
        Set m_datas(i) = Nothing
    Next
    m_length = 0
End Function

'弹出数组最后一个元素并返回
Public Function Pop() As Object
    Set Pop = m_datas(m_length)
    Call Delete(m_length)
End Function

'将元素压入末尾
Public Function Push(ByRef element As Object)
    Call Insert(m_length + 1, element)
End Function

'类似于将“=”重载
Public Property Let datas(ByRef para_datas As Object_vector)
    '检查数组中的元素类型是否为 “Object_vector”
    If Not Check_type("Object_vector", para_datas) Then
        MsgBox ("Let datas: Object Type Error!")
        Exit Property
    End If

    '清除所有数据准备被赋值
    Call Clean

    '获取右值(para_datas)的元素数量
    Dim new_length As Long
    new_length = para_datas.arraysize

    '重设可用空间
    If new_length < init_space Then
        arraysize = init_space
    Else
        arraysize = new_length + Int(new_length * ex_space_coe)
    End If
    m_element_type = para_datas.element_type

    '将右值的每个元素赋值给左值
    Dim i As Long
    For i = 1 To new_length Step 1
        Set m_datas(i) = para_datas.element(i)
        m_length = m_length + 1
    Next

End Property

'是否为空
Public Function Is_empty() As Boolean
    If m_length = 0 Then
        Is_empty = True
    Else
        Is_empty = False
    End If
End Function

'检查输入的索引值
Private Function Check_index(index As Long) As Boolean
    Check_index = (index >= 1 And index <= m_length)
End Function

'检查元素类型
Private Function Check_type(type_name As String, obj As Object) As Boolean
    Check_type = (type_name = TypeName(obj))
End Function

'若index为 -1 ，则认为 index 是末尾元素索引+1
Private Function Switch_index(index As Long) As Long
    Switch_index = IIf(index = -1, m_length + 1, index)
End Function

类模块Room

Private m_edge As Object_vector
Private m_tiles As Object_vector
Private m_type As ENUM_COORD_TYPE
Private m_size As Long

Private Sub Class_Initialize()
    Set m_tiles = New Object_vector
    Set m_edge = New Object_vector

    m_tiles.element_type = "Coord"
    m_edge.element_type = "Coord"

    m_type = NONE
    m_size = 0
End Sub

Private Sub Class_Terminate()
    Set m_tiles = Nothing
    Set m_edge = Nothing
End Sub

'获得房间的大小(地板数量)
Public Property Get room_size() As Long
    room_size = m_size
End Property

'获得房间类型(房间内所有地板有且仅有的类型)
Public Property Get room_type() As ENUM_COORD_TYPE
    room_type = m_type
End Property

'更改房间类型
Public Property Let room_type(new_type As ENUM_COORD_TYPE)
    '房间类型为NONE、并且房间地板数量为0时，以参数new_type为准
    If m_type = NONE And m_size = 0 Then
        m_type = new_type
    '如果房间不为空，则以房间的第一个地板的类型为标准
    ElseIf m_size > 0 Then
        m_type = m_tiles.element(1).coord_type
    End If
End Property

'获得房间的所有地板
Public Property Get tiles() As Object_vector
    Set tiles = m_tiles
End Property

'类似于“=”重载：将房间的所有地板更改为参数other_tiles
Public Property Let tiles(ByRef other_tiles As Object_vector)
    'm_tiles.datas = other_tiles     '有疑问：为什么这句和下一句的结果是相同的？既然是引用传递，那么若释放other_tiles，则m_tiles中的元素也应该不存在啊？
    Set m_tiles = other_tiles      '但实际上(应用这句代码而不是上一句)，即使释放了other_tiles，m_tiles中的元素却被正常赋值了。
    m_size = other_tiles.arraysize
    If other_tiles.arraysize <> 0 Then
        m_type = other_tiles.element(1).coord_type
    End If
End Property

Public Property Let room_edge(ByRef para_room_edge As Object_vector)
    'm_edge.datas = para_room_edge
    Set m_edge = para_room_edge
End Property

Public Property Get room_edge() As Object_vector
    Set room_edge = m_edge
End Property

'在房间中寻找一块地板
'FIXME: 复杂度过高
Private Function Find_tile(ByRef tile_is_found As Coord) As Boolean
    Dim i As Long
    Dim temp_tile As Coord
    For i = 1 To m_size Step 1
        temp_tile = m_tiles.element(i)
        If tile_is_found.x = temp_tile.x And tile_is_found.y = temp_tile.y Then
            Find_tile = True
            Exit For
        End If
    Next
    Find_tile = False
End Function

'寻找房间边缘(边缘的类型与房间类型相同)(无参数)
'KILL: 复杂度过高，不使用
Private Function Set_room_edge_noarg()
    Dim i As Long
    For i = 1 To m_size Step 1
        Dim temp_tile As Coord
        Dim surr_tile As New Coord
        Set temp_tile = m_tiles.element(i)
        Dim w As Integer
        Dim h As Integer

        For w = temp_tile.x - 1 To temp_tile.x + 1 Step 1
            For h = temp_tile.y - 1 To temp_tile.y + 1 Step 1
                If w <> temp_tile.x Or h <> temp_tile.y Then
                    surr_tile.x = w
                    surr_tile.y = h
                    If Not Find_tile(surr_tile) Then
                        Call m_edge.Push(temp_tile)
                        GoTo Next_tile
                    End If
                End If
            Next
        Next
Next_tile:
    Next
End Function

'两个房间是否是同一个房间
Public Function Is_Equal(ByRef other_room As Room) As Boolean
    If m_size > 0 Then
        '两个房间如果大小不同，则不认为是同一个房间
        If m_size <> other_room.room_size Then
            GoTo Lable_Not_Equal
        End If

        Dim one_tile As Coord
        Dim other_tile As Coord
        Set one_tile = m_tiles.element(1)
        Set other_tile = other_room.tiles().element(1)
        '因为任意两个房间不存在相交情况
        '所以如果两个房间的第一块地板是相同(坐标与地板类型都相同)的，则认为这两个房间为同一个房间
        If Not one_tile.Is_Equal(other_tile) Then
            GoTo Lable_Not_Equal
        End If
Lable_Is_Equal:
        Is_Equal = True
    Else
Lable_Not_Equal:
        Is_Equal = False
    End If
End Function

类模块Shortest_distance

'（命名失误）线段类，用来定义一条线段

Public room1_id As Integer
Public room2_id As Integer
Public distance As Long
Public shortest_coord1 As Coord
Public shortest_coord2 As Coord

Private Sub Class_Initialize()
    room1_id = 0
    room2_id = 0
    distance = 0
    Set shortest_coord1 = New Coord
    Set shortest_coord2 = New Coord
End Sub

Private Sub Class_Terminate()
    room1_id = 0
    room2_id = 0
    distance = 0
    Set shortest_coord1 = Nothing
    Set shortest_coord2 = Nothing
End Sub

测试主函数test

Option Explicit

Public world_map As New Map
Public cell_ctrl As New Cell_controller

Sub test()
    Const width As Integer = 400
    Const height As Integer = 240
    Const random_percent As Integer = 50

    Call world_map.Generate_map(width, height, random_percent)

    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'    Dim gg As New Graphs_Generator
'    Dim coord1 As New Coord
'    Dim coord2 As New Coord
'    Dim ran1 As Integer
'    Dim ran2 As Integer

'    '随机取起点
'    While coord1.coord_type <> GROUND
'        ran1 = Int(Rnd * world_map.map_width + 1)
'        ran2 = Int(Rnd * world_map.map_height + 1)
'        coord1.x = ran1
'        coord1.y = ran2
'        coord1.coord_type = world_map.tile(ran1, ran2)
'    Wend
'    '随机取终点
'    While coord2.coord_type <> GROUND
'        ran1 = Int(Rnd * world_map.map_width + 1)
'        ran2 = Int(Rnd * world_map.map_height + 1)
'        coord2.x = ran1
'        coord2.y = ran2
'        coord2.coord_type = world_map.tile(ran1, ran2)
'    Wend
'
    '测试Map::Generate_map函数
    Application.EnableEvents = False
    Call cell_ctrl.Show_map
    Application.EnableEvents = True

End Sub

执行结果