算法帖——用舞蹈鏈算法（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，而這個深綠色方塊又占用了第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的那個），幾乎都在邊上，在當中的解少之又少

下面貼幾個解