无聊啊……于是，我想做一个随机地图。
但是我很懒，不想做。
但是身体很诚实。
这次是直接在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
执行结果
