问题的提出:如下图,用13块俄罗斯方块覆盖8*8的正方形。如何用计算机求解?

解决这类问题的方法不一而足,然而核心思想都是穷举法,不同的方法仅仅是对穷举法进行了优化
用13块不同形状的俄罗斯方块(每个方块只能使用一次)覆盖住棋盘,很容易就想到这是“精确覆盖问题”(13个俄罗斯方块完全覆盖住8*8的正方形)。而舞蹈链算法(Dancing Links)是比较好求解“精确覆盖问题”的算法,因为该算法在穷举的过程中,不再额外增加空间负担,状态的回溯也比较方便,能快捷的排除无效的穷举过程。有关舞蹈链算法(Dancing Links),在这里不再赘述,详情参看“跳跃的舞者,舞蹈链(Dancing Links)算法——求解精确覆盖问题”
用舞蹈链算法(Dancing Links)解决问题的核心是把问题转换为问题矩阵
很直观的,这样的矩阵一共有77列,其中第1-64列表示8*8正方形的每一个单元格,第65-77列代表方块的编号
这样求解出来的解就是正方形的每一个单元格都有方块填充,每个方块都被使用了一次
以上图为例,我把左下角的深绿色的方块定义为方块1,而这个深绿色方块又占用了第49、57、58、59、60单元格
那么这个深绿色的方块所构造的数据行就是如下表示
{0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,1,1,1,1,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0}
为了方便描述,我们把上面的行矩阵记作{49,57、58、59、60、65}
而我们要做的就是,构造出所有的数据行
先把如下图方块1的所有能在的位置做成数据行

则一共能有7行*5列=35种可能
同时,巧妙利用中心旋转的算法,分别得出旋转90度、180度、270度的位置可能
如下所示

旋转90度的图

旋转180度的图

旋转270度的图
这样一来,只需要遍历最先图的形状位置即可,其余旋转的形状的可以依次推导。
上面的形状还有一个如下图的,需要遍历

这样一来,这个形状1的所有位置就遍历完成了。
依次遍历13个形状,这样就生成了问题矩阵的所有行
代码如下:
Public
Class
clsTetris
Implements
I_Question
Private _Shapes
As
List(
Of
clsTetrisShape)
Private _Index()
As
Integer
Public
ReadOnly
Property Cols
As
Integer
Implements
I_Question.Cols
Get
Return 77
End
Get
End
Property
Public
Function ConvertFromDance(Answer()
As
Integer)
As
Object
Implements
I_Question.ConvertFromDance
Debug.Print(Answer.Length)
Dim tBmp
As
New
Bitmap(320, 320)
Dim tG
As
Graphics =
Graphics.FromImage(tBmp)
tG.Clear(
Color.White)
Dim I
As
Integer
For I = 0
To Answer.Length - 1
_Shapes(_Index(Answer(I) - 1)).DrawShape(tG)
Next
Return tBmp
End
Function
Public
ReadOnly
Property ExtraCols
As
Integer
Implements
I_Question.ExtraCols
Get
Return 77
End
Get
End
Property
Public
Sub ConvertToDance(Dance
As
clsDancingLinksImproveNoRecursive)
Implements
I_Question.ConvertToDance
_Shapes =
New
List(
Of
clsTetrisShape)
Dim I
As
Integer, J
As
Integer
Dim tShape
As
clsTetrisShape, tRotateShape
As
clsTetrisShape
Dim S
As
Integer
'Shape 1
For I = 0
To 6
For J = 0
To 4
S = I * 8 + J
tShape =
New
clsTetrisShape(1, S, S + 1, S + 2, S + 3, S + 8)
AppendAllShapes(Dance, tShape)
Next
Next
For I = 0
To 6
For J = 0
To 4
S = I * 8 + J
tShape =
New
clsTetrisShape(1, S, S + 8, S + 9, S + 10, S + 11)
AppendAllShapes(Dance, tShape)
Next
Next
'Shape 2
For I = 0
To 5
For J = 0
To 5
S = I * 8 + J
tShape =
New
clsTetrisShape(2, S, S + 1, S + 9, S + 10, S + 18)
AppendAllShapes(Dance, tShape)
Next
Next
'Shape3
For I = 0
To 5
For J = 0
To 5
S = I * 8 + J
tShape =
New
clsTetrisShape(3, S, S + 1, S + 9, S + 10, S + 17)
AppendAllShapes(Dance, tShape)
Next
Next
For I = 0
To 5
For J = 1
To 6
S = I * 8 + J
tShape =
New
clsTetrisShape(3, S, S + 1, S + 7, S + 8, S + 16)
AppendAllShapes(Dance, tShape)
Next
Next
'Shape 4
For I = 0
To 5
For J = 0
To 5
S = I * 8 + J
tShape =
New
clsTetrisShape(4, S, S + 1, S + 2, S + 8, S + 16)
AppendAllShapes(Dance, tShape)
Next
Next
'Shape5
For I = 0
To 6
For J = 0
To 4
S = I * 8 + J
tShape =
New
clsTetrisShape(5, S, S + 1, S + 2, S + 10, S + 11)
AppendAllShapes(Dance, tShape)
Next
Next
For I = 0
To 6
For J = 1
To 5
S = I * 8 + J
tShape =
New
clsTetrisShape(5, S, S + 1, S + 2, S + 7, S + 8)
AppendAllShapes(Dance, tShape)
Next
Next
'Shape6
For I = 0
To 5
For J = 0
To 5
S = I * 8 + J
tShape =
New
clsTetrisShape(6, S, S + 8, S + 9, S + 10, S + 18)
_Shapes.Add(tShape)
tRotateShape = tShape.Rotate90
_Shapes.Add(tRotateShape)
Next
Next
For I = 0
To 5
For J = 2
To 7
S = I * 8 + J
tShape =
New
clsTetrisShape(6, S, S + 6, S + 7, S + 8, S + 14)
_Shapes.Add(tShape)
tRotateShape = tShape.Rotate90
_Shapes.Add(tRotateShape)
Next
Next
'Shape 7
For I = 0
To 5
For J = 0
To 5
S = I * 8 + J
tShape =
New
clsTetrisShape(7, S, S + 1, S + 2, S + 9, S + 17)
AppendAllShapes(Dance, tShape)
Next
Next
'Shape 8
For I = 0
To 6
For J = 0
To 5
S = I * 8 + J
tShape =
New
clsTetrisShape(8, S, S + 1, S + 2, S + 8, S + 9)
AppendAllShapes(Dance, tShape)
Next
Next
For I = 0
To 6
For J = 0
To 5
S = I * 8 + J
tShape =
New
clsTetrisShape(8, S, S + 1, S + 2, S + 9, S + 10)
AppendAllShapes(Dance, tShape)
Next
Next
'Shape 9
For I = 0
To 6
For J = 0
To 4
S = I * 8 + J
tShape =
New
clsTetrisShape(9, S, S + 1, S + 2, S + 3, S + 9)
AppendAllShapes(Dance, tShape)
Next
Next
For I = 0
To 6
For J = 0
To 4
S = I * 8 + J
tShape =
New
clsTetrisShape(9, S, S + 1, S + 2, S + 3, S + 10)
AppendAllShapes(Dance, tShape)
Next
Next
'Shape 10
For I = 0
To 6
For J = 0
To 6
S = I * 8 + J
tShape =
New
clsTetrisShape(10, S, S + 1, S + 8, S + 9)
_Shapes.Add(tShape)
Next
Next
'Shape 11
For I = 0
To 5
For J = 1
To 6
S = I * 8 + J
tShape =
New
clsTetrisShape(11, S, S + 7, S + 8, S + 9, S + 16)
_Shapes.Add(tShape)
Next
Next
'Shape12
For I = 0
To 7
For J = 0
To 3
S = I * 8 + J
tShape =
New
clsTetrisShape(12, S, S + 1, S + 2, S + 3, S + 4)
_Shapes.Add(tShape)
tRotateShape = tShape.Rotate90
_Shapes.Add(tRotateShape)
Next
Next
'Shape 13
For I = 0
To 6
For J = 0
To 5
S = I * 8 + J
tShape =
New
clsTetrisShape(13, S, S + 1, S + 2, S + 8, S + 10)
AppendAllShapes(Dance, tShape)
Next
Next
ReDim _Index(_Shapes.Count - 1)
For I = 0
To _Shapes.Count - 1
_Index(I) = I
Next
Dim R
As
New
Random, tSwap
As
Integer
For I = _Shapes.Count - 1
To Int(_Shapes.Count / 3)
Step -1
J = R.Next(I)
tSwap = _Index(J)
_Index(J) = _Index(I)
_Index(I) = tSwap
Next
For I = 0
To _Shapes.Count - 1
Dance.AppendLine(_Shapes(_Index(I)).GetLineValue)
Next
End
Sub
Private
Sub AppendAllShapes(Dance
As
clsDancingLinksImproveNoRecursive, tShape
As
clsTetrisShape)
Dim tRotateShape
As
clsTetrisShape
_Shapes.Add(tShape)
tRotateShape = tShape.Rotate90
_Shapes.Add(tRotateShape)
tRotateShape = tShape.Rotate180
_Shapes.Add(tRotateShape)
tRotateShape = tShape.Rotate270
_Shapes.Add(tRotateShape)
End
Sub
Public
ReadOnly
Property IsRandomSolution
As
Boolean
Implements
I_Question.IsRandomSolution
Get
Return
False
End
Get
End
Property
End
Class
上面这个类实现了I_Question接口,代码如下:
Public
Interface
I_Question
ReadOnly
Property Cols
As
Integer
ReadOnly
Property ExtraCols
As
Integer
ReadOnly
Property IsRandomSolution
As
Boolean
Sub ConvertToDance(Dance
As
clsDancingLinksImproveNoRecursive)
Function ConvertFromDance(Answer()
As
Integer)
As
Object
End
Interface
几个参数解释一下
Cols:问题矩阵的数据列数
ExtraCols:问题矩阵必须覆盖的列数。大多数的情况下,和Cols相等,也就是所有列完全覆盖
IsRandomSolution:一个开关,指示求解过程中,是按照最少列优先求解(为False的时候)还是随机选择列求解(为True的时候),在列数比较少的情况下,可以为True,否则不建议使用True,为True的时候,如果存在多个解,每次求解有可能得出不同的解。
ConvertToDance:将数据转换为问题矩阵,并输入到指定的Dance类
ConvertFromDance:Dance类计算得出结果后,将结果返回给实现接口的类,让该类对结果进行相应的处理。
类clsTetris还内置了clsTetrisShape类,定义每个形状的编号、位置、并最终将每个形状绘制到指定的图上,如下:
Public
Class
clsTetrisShape
Private Poi()
As
Integer
Private ShapeType
As
Integer
Public
Sub
New(ShapeType
As
Integer,
ParamArray Poi()
As
Integer)
Me.ShapeType = ShapeType
Dim I
As
Integer
ReDim
Me.Poi(Poi.Length - 1)
For I = 0
To Poi.Length - 1
Me.Poi(I) = Poi(I)
Next
End
Sub
Public
Function GetLineValue()
As
Integer()
Dim Value(76)
As
Integer
Dim I
As
Integer
For I = 0
To 76
Value(I) = 0
Next
For I = 0
To Poi.Length - 1
Value(Poi(I)) = 1
Next
Value(63 + ShapeType) = 1
Return Value
End
Function
Public
Function Rotate90()
As
clsTetrisShape
Dim NewPoi(Poi.Length - 1)
As
Integer
Dim I
As
Integer, X
As
Integer, Y
As
Integer
For I = 0
To Poi.Length - 1
X = Int(Poi(I) / 8)
Y = Poi(I)
Mod 8
NewPoi(I) = Y * 8 + 7 - X
Next
Return
New
clsTetrisShape(ShapeType, NewPoi)
End
Function
Public
Function Rotate180()
As
clsTetrisShape
Dim NewPoi(Poi.Length - 1)
As
Integer
Dim I
As
Integer
For I = 0
To Poi.Length - 1
NewPoi(I) = 63 - Poi(I)
Next
Return
New
clsTetrisShape(ShapeType, NewPoi)
End
Function
Public
Function Rotate270()
As
clsTetrisShape
Dim NewPoi(Poi.Length - 1)
As
Integer
Dim I
As
Integer, X
As
Integer, Y
As
Integer
For I = 0
To Poi.Length - 1
X = Int(Poi(I) / 8)
Y = Poi(I)
Mod 8
NewPoi(I) = (7 - Y) * 8 + X
Next
Return
New
clsTetrisShape(ShapeType, NewPoi)
End
Function
Public
Sub DrawShape(G
As
Graphics)
Dim tBrush
As
SolidBrush
Select
Case ShapeType
Case 1
tBrush =
New
SolidBrush(
Color.FromArgb(84, 130, 53))
Case 2
tBrush =
New
SolidBrush(
Color.FromArgb(112, 48, 160))
Case 3
tBrush =
New
SolidBrush(
Color.FromArgb(166, 166, 166))
Case 4
tBrush =
New
SolidBrush(
Color.FromArgb(0, 176, 240))
Case 5
tBrush =
New
SolidBrush(
Color.FromArgb(0, 32, 96))
Case 6
tBrush =
New
SolidBrush(
Color.FromArgb(0, 0, 0))
Case 7
tBrush =
New
SolidBrush(
Color.FromArgb(192, 0, 0))
Case 8
tBrush =
New
SolidBrush(
Color.FromArgb(255, 217, 102))
Case 9
tBrush =
New
SolidBrush(
Color.FromArgb(0, 112, 192))
Case 10
tBrush =
New
SolidBrush(
Color.FromArgb(0, 176, 80))
Case 11
tBrush =
New
SolidBrush(
Color.FromArgb(255, 255, 0))
Case 12
tBrush =
New
SolidBrush(
Color.FromArgb(198, 89, 17))
Case 13
tBrush =
New
SolidBrush(
Color.FromArgb(146, 208, 80))
Case Else
tBrush =
New
SolidBrush(
Color.FromArgb(146, 208, 80))
End
Select
Dim I
As
Integer, X
As
Integer, Y
As
Integer
For I = 0
To Poi.Length - 1
X = Int(Poi(I) / 8)
Y = Poi(I)
Mod 8
G.FillRectangle(tBrush,
New
Rectangle(Y * 40, X * 40, 40, 40))
Next
End
Sub
End
Class
然后是贴出求解类
Public
Class
clsDancingCentre
Public
Shared
Function Dancing(Question
As
I_Question)
As
Object
Dim _Dance
As
New
clsDancingLinksImproveNoRecursive(Question.Cols, Question.ExtraCols)
Question.ConvertToDance(_Dance)
Return Question.ConvertFromDance(_Dance.Dance(Question.IsRandomSolution))
End
Function
End
Class
该类只有一个核心方法,定义一个舞蹈链算法(Dancing Links)类,并对该类和I_Question接口搭桥求解问题
在clsTetris类中,原本如果设置IsRandomSolution为True的话,那么求解过程非常缓慢(曾经1小时没有求出一个解出来),但如果设置为False的时候,每次求解是秒破,但是每次求解都是同一个结果。后来想到,交换问题矩阵的行,会影响求解的顺序,但不影响求解的结果。如果求解的结果是唯一的,那么矩阵的行交不交换都一样,但是如果求解的问题不是唯一的,那么改变问题矩阵的行,那么每次求解出来的解就有可能不同。故在clsTetris中,在最后把数据添加到Dance类的时候,是改变了添加顺序的,这样每次求解都是秒破,并且得出的结果也不一样。求解100个解,不到30秒。
最后贴出Dancing类,这才是舞蹈链算法(Dancing Links)的核心
Public
Class
clsDancingLinksImproveNoRecursive
Private Left()
As
Integer, Right()
As
Integer, Up()
As
Integer, Down()
As
Integer
Private Row()
As
Integer, Col()
As
Integer
Private _Head
As
Integer
Private _Rows
As
Integer, _Cols
As
Integer, _NodeCount
As
Integer
Private Count()
As
Integer
Private Ans()
As
Integer
Public
Sub
New(
ByVal Cols
As
Integer)
Me.New(Cols, Cols)
End
Sub
Public
Sub
New(
ByVal Cols
As
Integer, ExactCols
As
Integer)
ReDim Left(Cols), Right(Cols), Up(Cols), Down(Cols), Row(Cols), Col(Cols), Ans(Cols)
ReDim Count(Cols)
Dim I
As
Integer
Up(0) = 0
Down(0) = 0
Right(0) = 1
Left(0) = Cols
For I = 1
To Cols
Up(I) = I
Down(I) = I
Left(I) = I - 1
Right(I) = I + 1
Col(I) = I
Row(I) = 0
Count(I) = 0
Next
Right(Cols) = 0
_Rows = 0
_Cols = Cols
_NodeCount = Cols
_Head = 0
Dim N
As
Integer = Right(ExactCols)
Right(ExactCols) = _Head
Left(_Head) = ExactCols
Left(N) = _Cols
Right(_Cols) = N
End
Sub
Public
Sub AppendLine(
ByVal
ParamArray Value()
As
Integer)
Dim V
As
New
List(
Of
Integer)
Dim I
As
Integer
For I = 0
To Value.Length - 1
If Value(I) <> 0
Then V.Add(I + 1)
Next
AppendLineByIndex(V.ToArray)
End
Sub
Public
Sub AppendLine(Line
As
String)
Dim V
As
New
List(
Of
Integer)
Dim I
As
Integer
For I = 0
To Line.Length - 1
If Line.Substring(I, 1) <>
"0"
Then V.Add(I + 1)
Next
AppendLineByIndex(V.ToArray)
End
Sub
Public
Sub AppendLineByIndex(
ByVal
ParamArray Index()
As
Integer)
If Index.Length = 0
Then
Exit Sub
_Rows += 1
Dim I
As
Integer, K
As
Integer = 0
ReDim
Preserve Left(_NodeCount + Index.Length)
ReDim
Preserve Right(_NodeCount + Index.Length)
ReDim
Preserve Up(_NodeCount + Index.Length)
ReDim
Preserve Down(_NodeCount + Index.Length)
ReDim
Preserve Row(_NodeCount + Index.Length)
ReDim
Preserve Col(_NodeCount + Index.Length)
ReDim
Preserve Ans(_Rows)
For I = 0
To Index.Length - 1
_NodeCount += 1
If I = 0
Then
Left(_NodeCount) = _NodeCount
Right(_NodeCount) = _NodeCount
Else
Left(_NodeCount) = _NodeCount - 1
Right(_NodeCount) = Right(_NodeCount - 1)
Left(Right(_NodeCount - 1)) = _NodeCount
Right(_NodeCount - 1) = _NodeCount
End
If
Down(_NodeCount) = Index(I)
Up(_NodeCount) = Up(Index(I))
Down(Up(Index(I))) = _NodeCount
Up(Index(I)) = _NodeCount
Row(_NodeCount) = _Rows
Col(_NodeCount) = Index(I)
Count(Index(I)) += 1
Next
End
Sub
Public
Function Dance(
Optional Random
As
Boolean =
False)
As
Integer()
Dim P
As
Integer, C1
As
Integer
Dim I
As
Integer, J
As
Integer
Dim K
As
Integer = 0
Dim R
As
New
Random
Do
If (Right(_Head) = _Head)
Then
ReDim
Preserve Ans(K - 1)
For I = 0
To Ans.Length - 1
Ans(I) = Row(Ans(I))
Next
Return Ans
End
If
P = Right(_Head)
C1 = P
If Random =
False
Then
Do
While P <> _Head
If Count(P) < Count(C1)
Then C1 = P
P = Right(P)
Loop
Else
I = R.Next(_Cols)
For J = 1
To I
P = Right(P)
Next
If P = _Head
Then P = Right(_Head)
C1 = P
End
If
RemoveCol(C1)
I = Down(C1)
Do
While I = C1
ResumeCol(C1)
K -= 1
If K < 0
Then
Return
Nothing
C1 = Col(Ans(K))
I = Ans(K)
J = Left(I)
Do
While J <> I
ResumeCol(Col(J))
J = Left(J)
Loop
I = Down(I)
Loop
Ans(K) = I
J = Right(I)
Do
While J <> I
RemoveCol(Col(J))
J = Right(J)
Loop
K += 1
Loop
End
Function
Private
Sub RemoveCol(
ByVal ColIndex
As
Integer)
Left(Right(ColIndex)) = Left(ColIndex)
Right(Left(ColIndex)) = Right(ColIndex)
Dim I
As
Integer, J
As
Integer
I = Down(ColIndex)
Do
While I <> ColIndex
J = Right(I)
Do
While J <> I
Up(Down(J)) = Up(J)
Down(Up(J)) = Down(J)
Count(Col(J)) -= 1
J = Right(J)
Loop
I = Down(I)
Loop
End
Sub
Private
Sub ResumeCol(
ByVal ColIndex
As
Integer)
Left(Right(ColIndex)) = ColIndex
Right(Left(ColIndex)) = ColIndex
Dim I
As
Integer, J
As
Integer
I = Up(ColIndex)
Do
While (I <> ColIndex)
J = Right(I)
Do
While J <> I
Up(Down(J)) = J
Down(Up(J)) = J
Count(Col(J)) += 1
J = Right(J)
Loop
I = Up(I)
Loop
End
Sub
End
Class
注:
求解了1000个解,发现很有趣的一个现象,就是长条(1*5的那个),几乎都在边上,在当中的解少之又少
下面贴几个解








本文转自万仓一黍博客园博客,原文链接:http://www.cnblogs.com/grenet/p/7903680.html,如需转载请自行联系原作者