算法帖——用舞蹈鏈算法（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的那個），幾乎都在邊上，在當中的解少之又少

下面貼幾個解