算法帖——用舞蹈链算法（Dancing Links）求解俄罗斯方块覆盖问题

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

 

 

解决这类问题的方法不一而足，然而核心思想都是穷举法，不一样的方法仅仅是对穷举法进行了优化

 

用13块不一样形状的俄罗斯方块（每一个方块只能使用一次）覆盖住棋盘，很容易就想到这是“精确覆盖问题”（13个俄罗斯方块彻底覆盖住8*8的正方形）。而舞蹈链算法（Dancing Links）是比较好求解“精确覆盖问题”的算法，由于该算法在穷举的过程当中，再也不额外增长空间负担，状态的回溯也比较方便，能快捷的排除无效的穷举过程。有关舞蹈链算法（Dancing Links），在这里再也不赘述，详情参看“跳跃的舞者，舞蹈链（Dancing Links）算法——求解精确覆盖问题”

 

用舞蹈链算法（Dancing Links）解决问题的核心是把问题转换为问题矩阵

 

很直观的，这样的矩阵一共有77列，其中第1-64列表示8*8正方形的每个单元格，第65-77列表明方块的编号

这样求解出来的解就是正方形的每个单元格都有方块填充，每一个方块都被使用了一次

 

以上图为例，我把左下角的深绿色的方块定义为方块1，而这个深绿色方块又占用了第4九、5七、5八、5九、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，5七、5八、5九、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的那个），几乎都在边上，在当中的解少之又少

下面贴几个解