数独求解VB版

Attribute VB_Name = "Module1"
Private Type Stack
    row As Integer
    col As Integer
    cand As String
End Type
Private Const All As String = "123456789"
Private Problem As Variant
Private Found As Boolean
Private Ascend As Boolean
Private v As Variant
Private Filled As Dictionary
Private Grid(1 To 27) As String, k As Integer
Public Function RandomInteger(Min As Integer, Max As Integer, Optional Num) As Variant
    Dim i As Integer, arr() As Integer
    Dim dic As New Dictionary
    dic.RemoveAll
     If IsMissing(Num) Then Num = Max - Min + 1
    If Num > Max - Min + 1 Then Exit Function
    Do While dic.Count < Num
        Randomize
        i = Int(Rnd * (Max - Min + 1) + Min)
        If dic.Exists(i) = False Then dic.Add i, i
    Loop
    ReDim arr(0 To Num - 1) As Integer
    For i = 0 To UBound(arr)
        arr(i) = dic.Keys(i)
    Next i
    RandomInteger = arr
End Function

Public Function StringToMatrix(s As String) As Variant
    Dim Matrix(1 To 9, 1 To 9)
    Dim r As Integer, c As Integer, i As Integer
        s = Replace(s, " ", "")
        s = Replace(s, Chr(10), "")
        If Len(s) = 81 Then
            For r = 1 To 9
            For c = 1 To 9
                If Mid(s, (r - 1) * 9 + c, 1) Like "[1-9]" Then
                    Matrix(r, c) = Val(Mid(s, (r - 1) * 9 + c, 1))
                Else
                    Matrix(r, c) = ""
                End If
            Next c
            Next r
            StringToMatrix = Matrix
        End If
End Function

Public Function MatrixToString(Matrix As Variant, Optional Separator As String = "*", Optional Multiline As Boolean = False) As String
    Dim r As Integer, c As Integer
    Matrix = Matrix
    For r = LBound(Matrix, 1) To UBound(Matrix, 1)
    For c = LBound(Matrix, 2) To UBound(Matrix, 2)
        If Matrix(r, c) Like "[1-9]" Then
            MatrixToString = MatrixToString & Matrix(r, c)
        Else
            MatrixToString = MatrixToString & Separator
        End If
    Next c
        If Multiline And r < UBound(Matrix, 1) Then
            MatrixToString = MatrixToString & vbNewLine
        End If
    Next r
End Function

Private Function Candidate() As Variant
    Dim arr(1 To 9, 1 To 9) As String
    Dim r As Integer, c As Integer, i As Integer, j As Integer
    Dim ru As Integer, rd As Integer
    Dim cu As Integer, cd As Integer
    For r = 1 To 9
        For c = 1 To 9
            If Problem(r, c) Like "[1-9]" Then
                arr(r, c) = String(9, CStr(Problem(r, c)))
            Else
                arr(r, c) = All
                For i = 1 To 9
                    '行向候选数筛选
                    If Problem(r, i) Like "[1-9]" Then arr(r, c) = Replace(arr(r, c), Problem(r, i), "")
                Next i
                For j = 1 To 9
                    '列向候选数筛选
                    If Problem(j, c) Like "[1-9]" Then arr(r, c) = Replace(arr(r, c), Problem(j, c), "")
                Next j
                    '宫中候选数筛选
                Select Case r
                Case 1, 2, 3
                    rd = 1: ru = 3
                Case 4, 5, 6
                    rd = 4: ru = 6
                Case 7, 8, 9
                    rd = 7: ru = 9
                Case Else
                End Select
                
                Select Case c
                Case 1, 2, 3
                    cd = 1: cu = 3
                Case 4, 5, 6
                    cd = 4: cu = 6
                Case 7, 8, 9
                    cd = 7: cu = 9
                Case Else
                End Select
                
                For i = rd To ru
                    For j = cd To cu
                        If Problem(i, j) Like "[1-9]" Then arr(r, c) = Replace(arr(r, c), Problem(i, j), "")
                    Next j
                Next i
            End If
        Next c
    Next r
    Candidate = arr
End Function

Private Function CurrentStr() As Stack
    Dim r As Integer, c As Integer, i As Integer, j As Integer
    CurrentStr.cand = All
    v = Candidate()
    For r = 1 To 9
        For c = 1 To 9
            If Len(v(r, c)) < Len(CurrentStr.cand) Then
                CurrentStr.row = r
                CurrentStr.col = c
                CurrentStr.cand = v(r, c)
            End If
        Next c
    Next r
End Function

Private Function Implicit() As Boolean
    Dim r As Integer, c As Integer
    v = Candidate()
    For r = 1 To 9
        For c = 1 To 9
            If v(r, c) = "" Then
                Implicit = True
            Exit Function
            End If
        Next c
    Next r
    Implicit = False
End Function

Private Function IsComplete() As Boolean
    Dim r As Integer, c As Integer
    For r = 1 To 9
        For c = 1 To 9
            If Problem(r, c) = "" Then
                IsComplete = False
            Exit Function
            End If
        Next c
    Next r
    IsComplete = True
End Function

Public Function Unique(p As Variant) As Boolean
    Dim r As Integer, c As Integer
    Dim ASC, DESC
    Ascend = True
    ASC = SudokuSolver(p)
    Ascend = False
    DESC = SudokuSolver(p)
    For r = 1 To 9
        For c = 1 To 9
            If ASC(r, c) <> DESC(r, c) Or ASC(r, c) = "" Or DESC(r, c) = "" Then
                Exit Function
            End If
        Next c
    Next r
    Unique = True
End Function
Private Sub Initialize()
    Dim r As Integer, c As Integer, i As Integer, j As Integer
    Dim ru As Integer, rd As Integer
    Dim cu As Integer, cd As Integer
    Set Filled = New Dictionary
    For r = 1 To 9
    For c = 1 To 9
        If Problem(r, c) Like "[1-9]" Then
            Filled.Add r & c, ""
        End If
    Next c
    Next r
    For r = 1 To 9
    For c = 1 To 9
        If Problem(r, c) Like "[1-9]" = False Then
            Problem(r, c) = All
            For i = 1 To 9
                '行向候选数筛选
                If Problem(r, i) Like "[1-9]" And Filled.Exists(r & i) Then Problem(r, c) = Replace(Problem(r, c), Problem(r, i), "")
            Next i
            For j = 1 To 9
                '列向候选数筛选
                If Problem(j, c) Like "[1-9]" And Filled.Exists(j & c) Then Problem(r, c) = Replace(Problem(r, c), Problem(j, c), "")
            Next j
                '宫中候选数筛选
            Select Case r
            Case 1, 2, 3
                rd = 1: ru = 3
            Case 4, 5, 6
                rd = 4: ru = 6
            Case 7, 8, 9
                rd = 7: ru = 9
            Case Else
            End Select
            
            Select Case c
            Case 1, 2, 3
                cd = 1: cu = 3
            Case 4, 5, 6
                cd = 4: cu = 6
            Case 7, 8, 9
                cd = 7: cu = 9
            Case Else
            End Select
            
            For i = rd To ru
                For j = cd To cu
                    If Problem(i, j) Like "[1-9]" And Filled.Exists(i & j) Then Problem(r, c) = Replace(Problem(r, c), Problem(i, j), "")
                Next j
            Next i
        End If
    Next c
    Next r
    '以上初始化
End Sub
Public Function SudokuSolver(ByVal p As Variant) As Variant
    Dim dic(1 To 81) As Stack
    Dim r As Integer, c As Integer
    Dim i As Integer
    If IsArray(p) = False Then
        p = StringToMatrix(CStr(p))
    End If
    Problem = p
    Initialize
    Artificial
    For r = 1 To 9
        For c = 1 To 9
            If Problem(r, c) Like "[1-9]" = False Then
                Problem(r, c) = ""
            End If
        Next c
    Next r
    i = 1
    dic(i) = CurrentStr()
    Do Until IsComplete()
        Do Until dic(i).cand = ""
            Found = True
            If Ascend Then
                Problem(dic(i).row, dic(i).col) = Left(dic(i).cand, 1)
            Else
                Problem(dic(i).row, dic(i).col) = Right(dic(i).cand, 1)
            End If
            If Implicit() Then
                Problem(dic(i).row, dic(i).col) = ""
                If Ascend Then
                    dic(i).cand = Right(dic(i).cand, Len(dic(i).cand) - 1)
                Else
                    dic(i).cand = Left(dic(i).cand, Len(dic(i).cand) - 1)
                End If
            Else
                If Ascend Then
                    dic(i).cand = Right(dic(i).cand, Len(dic(i).cand) - 1)
                Else
                    dic(i).cand = Left(dic(i).cand, Len(dic(i).cand) - 1)
                End If
                i = i + 1
                dic(i) = CurrentStr()
                Exit Do
            End If
            Found = False
        Loop
        If Found = False Then
            Problem(dic(i).row, dic(i).col) = ""
            dic(i).cand = ""
            i = i - 1
            If i = 0 Then
                SudokuSolver = p
            Exit Function
            End If
        End If
        DoEvents
    Loop
    SudokuSolver = Problem
End Function

Public Function SudokuGenerator(RunTime As Single) As Variant
    Dim arr(1 To 9, 1 To 9)
    Dim v As Variant
    Dim dic As New Dictionary 'dic 用于记录曾经被抠过的坐标及数值
    Dim temp As Stack
    Dim t0 As Single
    Dim r As Integer, c As Integer
    v = RandomInteger(1, 9, 9)
    For r = 1 To 9
        arr(1, r) = v(r - 1)
    Next r
    v = arr
    v = SudokuSolver(v)
    t0 = Timer
    Do While Timer - t0 < RunTime
        With temp
            .row = RandomInteger(1, 9, 1)(0)
            .col = RandomInteger(1, 9, 1)(0)
            If v(.row, .col) = "" Or dic.Exists(.row * 10 + .col) Then
            Else
                .cand = v(.row, .col)
                v(.row, .col) = ""
                If Unique(v) Then
                Else
                    v(.row, .col) = .cand
                    dic.Add .row * 10 + .col, .cand
                End If
            End If
        End With
        DoEvents
    Loop
    SudokuGenerator = v
End Function

Private Function Count(Source As Variant, SubStr As Variant) As Integer
    Count = UBound(Split(Source, SubStr))
End Function

Private Sub UpdateGrid()
    Dim r As Integer, c As Integer, i As Integer, j As Integer
    Dim ru As Integer, rd As Integer
    Dim cu As Integer, cd As Integer
    Dim gr As Integer, gc As Integer
    Erase Grid
    For r = 1 To 9
    For c = 1 To 9
        If Filled.Exists(r & c) Then
            Grid(r) = Grid(r) & ","
        Else
            Grid(r) = Grid(r) & "," & Problem(r, c)
        End If
        If Filled.Exists(r & c) Then
            Grid(c + 9) = Grid(c + 9) & ","
        Else
            Grid(c + 9) = Grid(c + 9) & "," & Problem(r, c)
        End If
    Next c
    Next r
    For r = 1 To 3
    For c = 1 To 3
        For i = 1 To 3
        For j = 1 To 3
            gr = (r - 1) * 3 + i
            gc = (c - 1) * 3 + j
            If Filled.Exists(gr & gc) Then
                Grid((r - 1) * 3 + c + 18) = Grid((r - 1) * 3 + c + 18) & "," & ""
            Else
                Grid((r - 1) * 3 + c + 18) = Grid((r - 1) * 3 + c + 18) & "," & Problem(gr, gc)
            End If
        Next j
        Next i
    Next c
    Next r
    For i = 1 To 27
        Grid(i) = Grid(i) & ","
    Next i
End Sub

Sub Artificial()
    Dim r As Integer, c As Integer, i As Integer, j As Integer
    Dim ru As Integer, rd As Integer
    Dim cu As Integer, cd As Integer
    Dim gr As Integer, gc As Integer
    Dim m(1 To 3) As String
    Dim temp As String
    For r = 1 To 9
    For c = 1 To 9
        If Filled.Exists(r & c) = False And Problem(r, c) Like "[1-9]" Then
            Filled.Add r & c, ""
            '除去不相干候选数
            For j = 1 To 9
                If j <> c Then Problem(r, j) = Replace(Problem(r, j), Problem(r, c), "")
            Next j
            For i = 1 To 9
                If i <> r Then Problem(i, c) = Replace(Problem(i, c), Problem(r, c), "")
            Next i
            Select Case r
            Case 1, 2, 3
                rd = 1: ru = 3
            Case 4, 5, 6
                rd = 4: ru = 6
            Case 7, 8, 9
                rd = 7: ru = 9
            Case Else
            End Select
            
            Select Case c
            Case 1, 2, 3
                cd = 1: cu = 3
            Case 4, 5, 6
                cd = 4: cu = 6
            Case 7, 8, 9
                cd = 7: cu = 9
            Case Else
            End Select
            
            For i = rd To ru
                For j = cd To cu
                    If (r = i And c = j) = False Then Problem(i, j) = Replace(Problem(i, j), Problem(r, c), "")
                Next j
            Next i
            Artificial
            Exit Sub
        End If
    Next c
    Next r
    '1：以上显性唯一候选数
    UpdateGrid
    
    For k = 1 To 27
      For i = 1 To 9
        If Len(Grid(k)) - Len(Replace(Grid(k), i, "")) = 1 Then
            For j = 1 To 9
                If InStr(Split(Grid(k), ",")(j), i) > 0 Then
                    'k和j决定隐形唯一候选数发生位置
                    If k <= 9 Then
                        gr = k
                        gc = j
                    ElseIf k <= 18 Then
                        gr = j
                        gc = k - 9
                    Else
                        gr = ((k - 18 - 1) \ 3) * 3 + (j - 1) \ 3 + 1
                        gc = ((k - 18 - 1) Mod 3) * 3 + ((j - 1) Mod 3) + 1
                    End If
                    Problem(gr, gc) = i
                    Exit For
                End If
            Next j
            Artificial
            Exit Sub
        End If
      Next i
    Next k
    '2：以上隐性唯一候选数
    
    UpdateGrid
    For k = 1 To 27
        For i = 1 To 9
        For j = i + 1 To 9
            If Count(Grid(k), "," & i & j & ",") = 2 Then
            '数字 i  j 是显性数对
                temp = Grid(k)
                If k <= 9 Then
                    r = k
                    For c = 1 To 9
                        If Problem(r, c) <> i & j Then
                            Problem(r, c) = Replace(Problem(r, c), i, "")
                            Problem(r, c) = Replace(Problem(r, c), j, "")
                        End If
                    Next c
                ElseIf k <= 18 Then
                    c = k - 9
                    For r = 1 To 9
                        If Problem(r, c) <> i & j Then
                            Problem(r, c) = Replace(Problem(r, c), i, "")
                            Problem(r, c) = Replace(Problem(r, c), j, "")
                        End If
                    Next r
                Else
                    For r = ((k - 18 - 1) \ 3) * 3 + 1 To ((k - 18 - 1) \ 3) * 3 + 3
                        For c = ((k - 18 - 1) Mod 3) * 3 + 1 To ((k - 18 - 1) Mod 3) * 3 + 3
                            If Problem(r, c) <> i & j Then
                                Problem(r, c) = Replace(Problem(r, c), i, "")
                                Problem(r, c) = Replace(Problem(r, c), j, "")
                            End If
                        Next c
                    Next r
                End If
                UpdateGrid
                If Grid(k) <> temp Then
                    '避免死循环
                    Artificial
                    Exit Sub
                End If
            End If
        Next j
        Next i
    Next k
    '3：以上显性数对
    
    UpdateGrid
    For k = 1 To 27
        For i = 1 To 9
        For j = i + 1 To 9
            If Count(Grid(k), i) = 2 And Count(Grid(k), j) = 2 Then
                Erase m
                For r = 1 To 9
                   If Count(Split(Grid(k), ",")(r), i) = 1 Then
                        m(1) = m(1) & r
                   End If
                Next r
                For r = 1 To 9
                   If Count(Split(Grid(k), ",")(r), j) = 1 Then
                        m(2) = m(2) & r
                   End If
                Next r
                If m(1) = m(2) Then
                    '数字 i  j 是隐性数对
                    temp = Grid(k)
                    If k <= 9 Then
                        Problem(k, Left(m(1), 1)) = i & j
                        Problem(k, Right(m(1), 1)) = i & j
                    ElseIf k <= 18 Then
                        c = k - 9
                        Problem(Left(m(1), 1), c) = i & j
                        Problem(Right(m(1), 1), c) = i & j
                    Else
                        gr = ((k - 18 - 1) \ 3) * 3 + (Left(m(1), 1) - 1) \ 3 + 1
                        gc = ((k - 18 - 1) Mod 3) * 3 + ((Left(m(1), 1) - 1) Mod 3) + 1
                        Problem(gr, gc) = i & j
                        gr = ((k - 18 - 1) \ 3) * 3 + (Right(m(1), 1) - 1) \ 3 + 1
                        gc = ((k - 18 - 1) Mod 3) * 3 + ((Right(m(1), 1) - 1) Mod 3) + 1
                        Problem(gr, gc) = i & j
                    End If
                    UpdateGrid
                    If Grid(k) <> temp Then
                        '避免死循环
                        Artificial
                        Exit Sub
                    End If
                End If
            End If
        Next j
        Next i
    Next k
    '4:以上隐性数对
End Sub