無聊啊……於是，我想做一個隨機地圖。
但是我很懶，不想做。
但是身體很誠實。

這次是直接在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

執行結果