伤脑筋十二块的拼成长方形

henterwu · 发表于 2025-8-12 15:47

micch 发表于 2025-8-10 22:17
有做过2048的话，两个任意图形的拼接可以用2048的逻辑去处理，但是12个图形的拼接，就需要算法了，很复杂

如果按楼下的1/0逻辑来数字化图块（有为1，无为0）的话，每格的和为0表示空，和为2表示已重叠而跳出循环。最终目的视为把1填满5*12或6*10的格子。不知道12 block puzzle之类的解题逻辑是什么？这对VBA来说是不是太难太慢了。

micch · 发表于 2025-8-12 21:59

henterwu 发表于 2025-8-12 15:47
如果按楼下的1/0逻辑来数字化图块（有为1，无为0）的话，每格的和为0表示空，和为2表示已重叠而跳出循环 ...

算法和语言无关，vba也许不如其他语言，但是如果算法有了，那就vba能实现。

关键不是如何判断是否组成长方形，关键是两个形状拼接组合有好几种模式（每个形状有多重形态），再增加一个形状，那么拼接方式是几何式增长，增加到12个有太多的拼接方案，如果用暴力组合的方式不现实。

程序运算慢不慢，不分语言，vba实质上也不会比C就慢

yynrzwh · 发表于 2025-8-12 22:13

本帖最后由 yynrzwh 于 2025-8-12 22:15 编辑

仅算6*10，并取1个路径
例如：[1,1][2,1][5,1][8,2][7,1][6,4][10,4][11,2][3,3][9,4][4,3][12,4]
[1,1]中，前面的1表示第一种图形，后面的1表示第一种旋转方式。

十二块凑长方形.7z (25.21 KB, 下载次数: 9)

Dim n&, ar, spath$, rol&
Sub test2()
n = 12
ReDim ar(1 To n, 1 To 4)
getblock ar
ReDim res(1 To 6, 1 To 10) As Integer '6*10
ReDim u(1 To n) As Boolean
spath = "": rol = 0
dfs res, u, "", False
MsgBox spath
End Sub
Private Sub dfs(res, u, ss, flag)
pos = getpos(res)
x = pos(0): y = pos(1)
If x = 0 Then
' rol = rol + 1
' Cells(rol, "w") = ss
spath = ss
flag = True
Exit Sub
End If
For i = 1 To n
If Not u(i) Then
For j = 1 To 4
b = ar(i, j)
If IsArray(b) Then
tem = res
If istrue(x, y, b, tem) Then
u(i) = True
dfs tem, u, ss & "[" & i & "," & j & "]", flag
If flag Then Exit Sub
u(i) = False
End If
End If
Next
End If
Next
End Sub
Private Function istrue(x, y, b, tem) As Boolean
Dim r&, c&, k&
For i = 1 To UBound(b, 2)
If b(1, i) = 1 Then Exit For
k = k + 1
Next
si = x
sj = y - k
m1 = x + UBound(b) - 1
m2 = y + UBound(b, 2) - 1 - k
If m1 > UBound(tem) Or m2 > UBound(tem, 2) Or sj < 1 Then Exit Function
For i = si To m1
r = r + 1: c = 0
For j = sj To m2
c = c + 1
tem(i, j) = tem(i, j) + b(r, c)
If tem(i, j) > 1 Then Exit Function
Next
Next
istrue = True
End Function
Private Function getpos(br)
For i = 1 To UBound(br)
For j = 1 To UBound(br, 2)
If br(i, j) = 0 Then
getpos = Array(i, j)
Exit Function
End If
Next
Next
getpos = Array(0, 0)
End Function
Private Sub getblock(ar)
For i = 1 To 49
If Cells(i, 1) <> "" Then
r = r + 1: c = 0
For j = 3 To 20
If Cells(i, j) <> "" And Cells(i, j - 1) = "" Then
c = c + 1
ar(r, c) = Cells(i, j).CurrentRegion
End If
Next
End If
Next
End Sub

复制代码

micch · 发表于 2025-8-12 22:17

给孩子小时候买过这个，拼接组合，单纯的完成组合，其实开始可以随便拼，到最后几个的时候，如果发现完不成，可以退回到前面几步，换个方案，基本上多试几次就出结果了。

不过转化为代码，除了暴力循环组合，不知道有什么好的方法。

yynrzwh · 发表于 2025-8-12 22:29

AI的注释

' 声明变量
Dim n&, ar, spath$, rol&
' & 表示Long类型，$表示String类型
' n: 整数变量，用于定义数组大小
' ar: 变体数组，用于存储数据块
' spath: 字符串变量，用于存储路径结果
' rol: 整数变量，可能用于记录行数
' 主过程：测试程序入口
Sub test2()
n = 12 ' 设置n的值为12
ReDim ar(1 To n, 1 To 4) ' 重新定义ar数组的大小为12行4列
getblock ar ' 调用getblock过程，从工作表中获取数据块并存储到ar数组
' 重新定义结果数组res为6行10列的整数数组
ReDim res(1 To 6, 1 To 10) As Integer '6*10
' 重新定义布尔数组u为n个元素，用于标记数据块是否被使用
ReDim u(1 To n) As Boolean
spath = "": rol = 0 ' 初始化路径字符串和行数变量
' 调用深度优先搜索(DFS)过程，寻找合适的路径
dfs res, u, "", False
MsgBox spath ' 显示找到的路径结果
End Sub
' 深度优先搜索过程：用于寻找数据块的放置路径
' 参数说明：
' res: 结果数组，记录数据块的放置情况
' u: 布尔数组，标记数据块是否已使用
' ss: 字符串，记录当前路径
' flag: 布尔值，标记是否找到有效路径
Private Sub dfs(res, u, ss, flag)
pos = getpos(res) ' 获取结果数组中下一个需要填充的位置
x = pos(0): y = pos(1) ' 分解位置坐标(x行, y列)
' 如果x为0，表示已经找到一个完整的填充方案
If x = 0 Then
' rol = rol + 1
' Cells(rol, "w") = ss ' 注释：将路径写入工作表W列
spath = ss ' 保存当前路径
flag = True ' 设置找到路径的标记
Exit Sub ' 退出过程
End If
' 遍历所有数据块
For i = 1 To n
' 如果数据块i未被使用
If Not u(i) Then
' 遍历数据块i的4个方向/形态
For j = 1 To 4
b = ar(i, j) ' 获取数据块i的第j种形态
' 如果b是数组（有效的数据块）
If IsArray(b) Then
tem = res ' 复制当前结果数组到临时数组
' 检查数据块b是否可以放置在(x,y)位置
If istrue(x, y, b, tem) Then
u(i) = True ' 标记数据块i为已使用
' 递归调用dfs，继续寻找下一个位置
dfs tem, u, ss & "[" & i & "," & j & "]", flag
' 如果已经找到有效路径，退出所有循环
If flag Then Exit Sub
u(i) = False ' 回溯：取消数据块i的使用标记
End If
End If
Next
End If
Next
End Sub
' 检查数据块是否可以放置在指定位置的函数
' 参数：
' x,y: 放置位置的坐标
' b: 要放置的数据块
' tem: 临时结果数组
' 返回值：布尔值，True表示可以放置，False表示不能放置
Private Function istrue(x, y, b, tem) As Boolean
Dim r&, c&, k& ' 声明行、列、计数变量
' 计算数据块b的左侧空白格数量
For i = 1 To UBound(b, 2)
If b(1, i) = 1 Then Exit For ' 遇到第一个有效单元格时退出
k = k + 1 ' 累计空白格数量
Next
' 计算放置数据块后的起始和结束坐标
si = x ' 起始行
sj = y - k ' 起始列（考虑左侧空白）
m1 = x + UBound(b) - 1 ' 结束行
m2 = y + UBound(b, 2) - 1 - k ' 结束列
' 检查是否超出结果数组的边界
If m1 > UBound(tem) Or m2 > UBound(tem, 2) Or sj < 1 Then Exit Function
' 检查数据块放置后是否与已有数据重叠
For i = si To m1
r = r + 1: c = 0 ' 重置列计数器
For j = sj To m2
c = c + 1 ' 累加列索引
tem(i, j) = tem(i, j) + b(r, c) ' 模拟放置数据块
' 如果有重叠（单元格值大于1），则不能放置
If tem(i, j) > 1 Then Exit Function
Next
Next
istrue = True ' 所有检查通过，可以放置
End Function
' 获取结果数组中下一个需要填充的位置（第一个值为0的单元格）
Private Function getpos(br)
' 遍历结果数组
For i = 1 To UBound(br)
For j = 1 To UBound(br, 2)
If br(i, j) = 0 Then ' 找到值为0的单元格
getpos = Array(i, j) ' 返回该单元格的坐标
Exit Function ' 退出函数
End If
Next
Next
getpos = Array(0, 0) ' 如果所有单元格都已填充，返回(0,0)
End Function
' 从工作表中获取数据块并存储到ar数组
Private Sub getblock(ar)
Dim r&, c& ' 声明行、列计数器变量，用于ar数组的索引
' 遍历工作表第1列的前49行
For i = 1 To 49
' 如果当前行第1列有数据（表示这是一个数据块的起始行）
If Cells(i, 1) <> "" Then
r = r + 1: c = 0 ' 行计数器加1，重置列计数器
' 遍历第3列到第20列，寻找数据块
For j = 3 To 20
' 找到新的数据块（当前单元格有数据且前一个单元格无数据）
If Cells(i, j) <> "" And Cells(i, j - 1) = "" Then
c = c + 1 ' 列计数器加1
' 将当前单元格所在的连续数据区域作为一个数据块，存储到ar数组
ar(r, c) = Cells(i, j).CurrentRegion
End If
Next
End If
Next
End Sub

复制代码

这段代码看起来是一个用于解决类似拼图问题的程序：从工作表中读取多个数据块（可能是不同形状的），然后通过深度优先搜索 (DFS) 算法尝试将这些数据块填充到一个 6×10 的网格中，最终找到一种有效的组合方式并输出路径。

代码的核心逻辑是：

从工作表读取数据块到 ar 数组
使用 DFS 算法尝试所有可能的组合方式
通过 istrue 函数检查数据块是否可以放置在指定位置
找到有效组合后，将路径存储在 spath 变量并显示

这种算法常用于解决排列组合、路径搜索类问题，通过递归和回溯的方式探索所有可能的解。

yynrzwh · 发表于 2025-8-12 23:21

6*10有292种组合

henterwu · 发表于 2025-8-13 09:11

感谢各位！认真学习ing

henterwu · 发表于 2025-8-17 10:46

对yynrzwh老师分享的示例文件做了一些小修改。
1、增加的块的其他姿态的排列组合；
2、增加了5*12的排列计算；
3、对十二块的组合计算做了乱序处理（xr()），可使得每次结果都不同。

再次感谢老师的指导和帮助，运行速度稍慢。能否请老师看看能否优化。

henterwu · 发表于 2025-8-17 10:49

yynrzwh 发表于 2025-8-12 23:21
6*10有292种组合

感谢老师的指导帮助。

yynrzwh · 发表于 2025-8-19 09:22

henterwu 发表于 2025-8-17 10:46
对yynrzwh老师分享的示例文件做了一些小修改。
1、增加的块的其他姿态的排列组合；
2、增加了5*12的排列 ...

图形越多越慢。
BFS，DFS都是遍历，所以很慢，效率低。
要快就要剪枝，或者换其他算法。
目前没想到其他办法。

		自动登录	找回密码
密码			免费注册

[分享] 伤脑筋十二块的拼成长方形

评分

评分