65.9K
CodeProject 正在变化。 阅读更多。
Home

Visual Basic 数独求解器和生成器

starIconstarIconstarIconstarIcon
emptyStarIcon
starIcon

4.79/5 (18投票s)

2011 年 8 月 3 日

CPOL

8分钟阅读

viewsIcon

85084

downloadIcon

9892

数独游戏的求解器/生成器。

引言

我最初尝试使用 VBA 在 Excel 中开发数独求解器。与 Excel 交互了几次后,我改用 VS2005 的 Visual Basic。在完成了一个处理 9x9(经典)数独的版本后,我还将代码改编为解决武士数独(5 个重叠的 9x9 网格)。我想同时提供源代码和演示,因为我发现 Visual Basic 中可以学习的完全功能的求解器并不多。

基于逻辑的求解器和用户界面可能花费了最多的工作——实际的蛮力求解器实际上编写得很快。

UI.jpg

术语

本文不深入探讨数独的规则或解决数独谜题的详细方法。如果您想了解背景知识,请使用搜索引擎。但是,基本原则是将数字 1-9 放入行、列和子网格中,以便每行、每列和每个子网格只包含一个数字。然而,下面使用了一些术语来解释代码。

  • 单元格 - 可以放置数字 1-9 的单个单元格。
  • 线索/已知数 - 在上面的第一个图像中,第二个和第三个单元格分别包含数字 7 和 6。
  • 候选数/铅笔标记 - 在上面的图像中,第一个单元格包含三个候选数(2、3 和 9)。在尝试解决谜题时,跟踪各种候选数非常重要。
  • - 一组 9 个单元格,从屏幕向下水平排列。
  • - 一组 9 个单元格,从屏幕向下垂直排列。
  • 子网格 - 一组 9 个单元格,排列成 3x3 的分组。
  • 邻居 - 在 9x9 的经典网格中,每个单元格可以“看到”多达 20 个其他单元格(同一行、同一列和同一子网格中的其他单元格)。由于一行、一列或一个子网格中不能重复数字的规则,如果您将一个数字作为某个单元格的解,则该数字可以从其每个邻居的候选数中移除。武士数独的邻居有点不同,因为由于五个重叠的网格,一些单元格将具有更多的邻居。

关注点

求解器将尝试使用逻辑步骤来求解谜题,但也会采用蛮力算法来解决更难的谜题。因此,它几乎可以立即解决大多数经典的 9x9 数独谜题,或者在几秒钟内解决大多数武士数独谜题(取决于计算机)。诚然,有一些 C++ 求解器每秒可以解决数百或数千个谜题。但是,我想要一些能够合理快速地解决谜题,同时又能逐步展示解决谜题的原因的方法。

有一个自定义控件使用 GDI+ 来绘制线索和候选数(铅笔标记)。使用大量单独的标签或其他控件刷新速度太慢。对于武士数独,刷新速度仍然可能有点慢,但通常还可以。

与我见过的许多其他求解器不同,它们倾向于使用 81(9) 的二维数组来存储每个单元格的可能候选数,这个求解器使用长度为 81 的单个数组来存储所有可能的候选数。每个候选数都使用 2 ^ (candidate-1) 的公式赋予一个值,以生成每个候选数的唯一位值(尽管我选择硬编码此值以尽量减少此计算的需要)。因此,候选数 1 = 位值 1,候选数 2 = 位值 2,候选数 3 = 位值 4,候选数 4 = 位值 8,依此类推,候选数 5 = 位值 16。

所以,如果单元格 2 有候选数 1、3 和 4 作为可能的值,您将设置数组的值为

_vsCandidateAvailableBits(2) = 13 (bit values 1+4+8)

而不是必须做类似的事情

_vsCandidateAvailableBits(2,1) = True
_vsCandidateAvailableBits(2,3) = True
_vsCandidateAvailableBits(2,4) = True

这种方法的优点是,许多基于逻辑的数独解法都基于子集,所以如果您想检查单元格 81 是否只可用候选数 1 和 9,那么只需做一个简单的检查就能知道 _vsCandidateAvailableBits(81) = 257(位值 1 + 位值 256)。

实际的求解器本身被编码为一个类,并使用深度优先搜索。它将继续搜索多个解,或者可以设置为在找到指定数量的解后退出。

Dim solver As New clsSudokuSolver
' will exit if more than the entered number of solutions are found. 
solver.intQuit = intSolverQuit
solver.blnClassic = True ' or can set to false if solving a samurai puzzle
solver.strGrid = strGame ' input puzzle string 
solver.vsSolvers = My.Settings._DefaultSolvers ' solving methods

要运行求解器,您需要调用 solver._vsUnique() 来测试是否有唯一解。

然后您可以执行类似 dim blnUnique as boolean = solver._vsUnique() 的操作来检查一个谜题是否只有一个有效解。

蛮力求解器

蛮力求解器存在于自己的类中。它基本上是一个迭代循环,通过尝试找到最佳猜测来搜索解,并在猜测不正确时回溯。

首要任务是加载初始游戏(可以是包含 81 个字符的字符串(用于 9x9 数独)或五个用换行符分隔的 81 个字符的字符串(用于武士数独))。有效输入是起始线索的字符 1-9,以及句点或零字符,用于表示未填充/空的单元格。

Private Function _load(ByVal strGrid As String, Optional ByVal _
                 StrCandidates As String = "") As Boolean
    '---load puzzle---'
    _vsSteps = 1
    vsTried = 0
    ReDim _vsUnsolvedCells(0)
    Dim i As Integer
    Dim intCellOffset As Integer
    Dim strClues As String = ""
    Dim g As Integer
    Dim j As Integer
    Dim intBit As Integer
    Dim blnCandidates As Boolean = False
    Dim arrCandidates() As String = Split(StrCandidates, arrDivider)
    If arrCandidates.Length >= 81 Then blnCandidates = True
    _u = -1
    _vsCandidateCount(0) = -1
    For i = 1 To _vsCandidateCount.Length - 1
        _vsCandidateAvailableBits(i) = 511
        _vsStoreCandidateBits(i) = 0
        _vsCandidateCount(i) = -1
        If blnClassic = False Then
            If Not blnIgnoreSamurai(i) Then _vsCandidateCount(i) = 9
        Else
            _vsCandidateCount(i) = 9
        End If
        _vsLastGuess(i) = 0
        _vsCandidatePtr(i) = 1
        _vsSolution(i - 1) = 0
        _vsPeers(i) = 0
    Next

    strGrid = Trim(strGrid)
    Dim midStr As String = ""
    Dim ptr As Integer
    Dim arrayPeers(0) As String
    Dim intValue As Integer
    Dim nextGuess As Integer = 0
    Dim nextCandidate As Integer = 0
    _vsUnsolvedCells(0) = New List(Of Integer)
    Dim intMaxGrid As Integer = 5
    If blnClassic Then intMaxGrid = 1
    For g = 1 To intMaxGrid
        For i = 1 To 81
            Select Case blnClassic
                Case True
                    midStr = Mid(strGrid, i, 1)
                    intCellOffset = i
                Case False
                    midStr = Mid(strGrid, i + (81 * (g - 1)), 1)
                    intCellOffset = intSamuraiOffset(i, g)
            End Select
            Select Case Asc(midStr)
                Case 46, 48
                    '---blank---
                    If (blnClassic Or Not blnIgnoreSamurai(intCellOffset)) _
                        AndAlso _vsUnsolvedCells(0).IndexOf(intCellOffset) = -1 Then
                        _u += 1
                        _vsUnsolvedCells(0).Add(intCellOffset)
                        If blnCandidates = True Then
                            '---insert known candidates---
                            _vsCandidateAvailableBits(intCellOffset) = _
                              arrCandidates(intCellOffset - 1)
                            _vsCandidateCount(intCellOffset) = _
                              intCountBits(arrCandidates(intCellOffset - 1))
                        End If
                    End If
                Case 49 To 57
                    '---numeric 1 to 9---
                    intValue = CInt(midStr)
                    intBit = intGetBit(intValue)
                    If _vsSolution(intCellOffset - 1) = 0 Then
                        _vsSolution(intCellOffset - 1) = intValue
                        _vsCandidateCount(intCellOffset) = -1
                        If blnCandidates = False Then
                            Select Case blnClassic
                                Case True
                                    arrayPeers = arrPeers(intCellOffset)
                                Case False
                                    arrayPeers = ArrSamuraiPeers(intCellOffset)
                            End Select
                            '---remove value from peers---
                            For j = 0 To UBound(arrayPeers)
                                ptr = arrayPeers(j)
                                If _vsCandidateAvailableBits(ptr) And intBit Then
                                    _vsCandidateAvailableBits(ptr) -= intBit
                                    _vsCandidateCount(ptr) -= 1
                                End If
                            Next
                        End If
                    End If
                Case Else
                    'Debug.Print("exiting due to invalid" & _ 
                    ' "character " & Asc(midStr))
                    _load = False
                    Exit Function
            End Select
            strClues += midStr
        Next
        If Not blnClassic Then strClues += vbCrLf
    Next
    _load = True
    strFormatClues = strClues
End Function

一旦有了有效的输入,我们就调用一个函数来循环测试所有解(尽管可以设置一个值(intQuit)在找到所需的解数时退出)。例如,如果您想确保一个谜题是有效的(例如,只有一个唯一解),那么 intQuit 可以设置为“2”(这样它在找到两个解后就会退出)。但是,在某些情况下(如下文所述),找到多个解对于解决武士数独可能很有用。

主要的求解函数设置如下。

Private Function _vsbackTrack(ByVal strGrid As String, _
        ByRef StrSolution As String, Optional ByVal _
        StrCandidates As String = "") As Boolean 
    Dim intMax As Integer = 0
    Dim intSolutionMax As Integer = 0
    ReDim Solutions(0) ' array to hold solutions to the puzzle 
    Dim i As Integer 
    Dim j As Integer 
    Dim intSolutions As Integer ' counts number of puzzle solutions 
    Dim testPeers(0) As String 
    Dim tempPeers As String 
    Dim nextGuess As Integer = 0
    Dim nextCandidate As Integer = 0
    Select Case blnClassic
    ' sets up maximum length of arrays depending
    ' on whether it is a 9x9 or samurai puzzle
        Case True
            intMax = 81
            intSolutionMax = 80
        Case False
            intMax = 441
            intSolutionMax = 440
    End Select
    ReDim _vsSolution(intSolutionMax)
    ReDim _vsPeers(intMax)
    ReDim _vsCandidateCount(intMax)
    ReDim _vsCandidateAvailableBits(intMax)
    ReDim _vsCandidatePtr(intMax)
    ReDim _vsLastGuess(intMax)
    ReDim _vsStoreCandidateBits(intMax)
    ReDim _vsRemovePeers(intMax)

    If Not _load(strGrid:=strGrid, StrCandidates:=StrCandidates) Then
        ' input puzzle failed to load properly, so exit
        intCountSolutions = intSolutions
        Exit Function
    End If

    '---NOTE: Code for logic based solving methods is usually called here---'
    '---But removed for purposes of explaining the brute force solver---'
    '---END NOTE---'

    _vsUnsolvedCells(0).Sort() '---order an array list of empty/unsolved cells---'

    '---NOTE: Some specific code removed here for dealing with samurai puzzles---'
    '---This is discussed separately below---'
    '---END NOTE---'

    '---setup peer array. This is intended to save processing time by---'
    '---having the 'peers' for each empty cell pre-loaded, rather than needing---'
    '---to recalculate peers throughout the iterative puzzle solving process---'
    For i = 0 To _u
        tempPeers = ""
        Select Case blnClassic
            '---this code retrieves a hard coded list of 'peers' (other cells---'
            '---that share a row, column or subgrid with the empty cell---'
            Case True
                testPeers = arrPeers(_vsUnsolvedCells(0).Item(i))
            Case False
                testPeers = ArrSamuraiPeers(_vsUnsolvedCells(0).Item(i))
        End Select
        For j = 0 To UBound(testPeers)
            '---Check to see if each peer is unsolved or not. 
            '---If the peer is empty/unsolved, then add it to a string---'
            If _vsUnsolvedCells(0).IndexOf(CInt(testPeers(j))) > -1 Then
                If tempPeers = "" Then
                    tempPeers = testPeers(j)
                Else
                    tempPeers += "," & testPeers(j)
                End If
            End If
        Next
        _vsPeers(_vsUnsolvedCells(0).Item(i)) = tempPeers 
        '---save the list of peers for each empty cell---'
    Next
    '---end setup peer array---'

    If _u = -1 Then
        '---puzzle already solved by logic---'
        Exit Function
    End If

    While _vsSteps <= _u + 1 AndAlso _vsSteps > 0
        '---look for the next unfilled cell. The routine intFindCell looks---' 
        '---for the next empty cell containing only one candidate---'
        '---or failing that, the unfilled cell with the lowest number of---'
        '---candidates which will result in the maximum number of possible---'
        '---eliminations. There may be room for improvement/experimentation in 
        '---terms of picking the next cell to test---'
        If nextGuess = 0 Then nextGuess = intFindCell()
        If nextGuess > 0 Then
            '---we have an empty cell, so select the next candidate---' 
            '---to test in this cell---'
            nextCandidate = IntNextCandidate(nextGuess)
            If nextCandidate > 0 Then
                vsTried += 1
                MakeGuess(nextGuess, nextCandidate)
                nextGuess = 0
            Else
                If _vsSteps <= 1 Then
                    '---we've reached the end of the search
                    '---there are no more steps to try---'
                    Select Case intSolutions
                        Case 0
                            '---invalid puzzle (no solution)---'
                            _vsbackTrack = False
                            intCountSolutions = 0
                            Exit Function
                        Case 1
                            '---single solution---'
                            _vsbackTrack = True
                            intCountSolutions = 1
                            Exit Function
                        Case Else
                            '---multiple solutions---'
                            _vsbackTrack = False
                            intCountSolutions = intSolutions
                            Exit Function
                    End Select
                Else
                    '---need to go back...no remaining candidates for this cell---'
                    UndoGuess(nextGuess)
                End If
            End If
        Else
            If _vsSteps = 0 Then
                _vsbackTrack = False
                '---invalid puzzle---'
                intCountSolutions = intSolutions
                Exit Function
            Else
                '---cannot go further...so need to go back---'
                UndoGuess()
            End If
        End If

        If _vsSteps > _u + 1 Then
            '---we have filled all the unfilled cells with a solution---'
            '---so increase array size and add next solution to solution array---'
            intSolutions += 1
            ReDim Preserve Solutions(intSolutions - 1)
            Select Case blnClassic
                Case True
                    StrSolution = strWriteSolution(intGrid:=1)
                Case False
                    StrSolution = strWriteSolution()
            End Select
            Solutions(intSolutions - 1) = StrSolution

            If intSolutions = intQuit Then
                '---quit if number of solutions exceeds a given number---'
                _vsbackTrack = False
                intCountSolutions = intSolutions
                Exit Function
            End If

            '---solution found so backtrack---'
            UndoGuess()
        End If
    End While
End Function

蛮力求解器的关键部分是进行“超前观察”,尝试挑选下一个最佳的未填充单元格来放置可用候选数。下面的函数旨在通过寻找具有最少可用候选数的空单元格来完成此操作。如果存在只有一个候选数的单元格,则选择该单元格,因为这是最佳猜测。否则,目标是寻找具有最小候选数的未填充单元格(这可以减少整体搜索空间/求解时间)。作为额外的改进,如果存在多个未填充单元格,每个单元格具有相同数量的候选数,则使用一个额外的循环来确定这些单元格中哪个具有最多的邻居(基于这样的假设:任何猜测都会有最大的机会从谜题中消除更多候选数)。可能有其他方法可以尝试,因为找到最佳的下一步操作最有可能提高求解速度。

Private Function intFindCell() As Integer
    Dim i As Integer
    Dim j As Integer
    Dim ptr As Integer
    Dim ptr2 As Integer
    Dim arrPeers() As String
    Dim intCell As Integer
    Dim intCount As Integer
    Dim intPeerCount As Integer

    For i = 0 To 9
        '---iterate array that holds number of candidates for each cell---' 
        '---starting from lowest possible candidates to highest---' 
        ptr = Array.IndexOf(_vsCandidateCount, i)
        If ptr > -1 Then
            intFindCell = ptr
            If i = 0 Then
                intFindCell = 0
            End If
            If i = 1 Then Exit Function

            While ptr2 > -1
                ptr2 = Array.IndexOf(_vsCandidateCount, i, ptr2)
                If ptr2 > -1 Then
                    arrPeers = Split(_vsPeers(ptr2), arrDivider)
                    intPeerCount = 0
                    For j = 0 To UBound(arrPeers)
                        If arrPeers(j) <> "" AndAlso _
                               _vsUnsolvedCells(0).IndexOf(arrPeers(j)) > -1 Then
                            intPeerCount += 1
                        End If
                    Next
                    If intPeerCount >= intCount Then
                    '---look for unfilled cell with largest number of peers---'
                        intCount = intPeerCount
                        intCell = ptr2
                    End If
                    ptr2 += 1
                End If
            End While
            intFindCell = intCell
            Exit For
        End If
    Next
End Function

一旦选择了未填充单元格,下一步就是找到该单元格中的下一个可用候选数,如下面所述

Private Function IntNextCandidate(ByVal intCell As Integer, _
                 Optional ByVal blnLookup As Boolean = False) As Integer
    Dim c As Integer
    Dim intBit As Integer
    For c = _vsCandidatePtr(intCell) To 9
        intBit = intGetBit(c)
        If _vsCandidateAvailableBits(intCell) And intBit Then
            IntNextCandidate = c
            If blnLookup = False Then _vsCandidatePtr(intCell) = c + 1
            '---increment the value for _vsCandidatePtr---' 
            '---by incrementing _vsCandidatePtr it is faster to loop---' 
            '---through and find the next available candidate to be tested---' 
            Exit Function
        End If
    Next
End Function

所需的其他主要项目是分别用于进行猜测和回溯猜测的函数。一个关键问题是如何跟踪由于猜测而从单元格的邻居中删除了哪些候选数。如果不准确记录这一点,就无法像需要的那样正确地撤销猜测。

Private Function MakeGuess(ByVal intCell As Integer, _
           ByVal intCandidate As Integer) As Boolean
    Dim arrayPeers() As String
    Dim j As Integer
    Dim ptr As Integer
    Dim intBit As Integer
    _vsSolution(intCell - 1) = intCandidate
    _vsCandidateCount(intCell) = -1
    _vsLastGuess(_vsSteps) = intCell
    '----remove from unsolved cells list---
    _vsUnsolvedCells(0).Remove(intCell)
    setCandidates(intCell, intCandidate)
    _vsSteps += 1
    arrayPeers = Split(_vsPeers(intCell), ",")
    '---remove value from peers---
    _vsRemovePeers(intCell) = New List(Of Integer)
    intBit = intGetBit(intCandidate)
    For j = 0 To UBound(arrayPeers)
        ptr = arrayPeers(j)
        If _vsSolution(ptr - 1) = 0 AndAlso _
                 (_vsCandidateAvailableBits(ptr) And intBit) Then
            _vsCandidateAvailableBits(ptr) -= intBit
            _vsCandidateCount(ptr) -= 1
            _vsRemovePeers(intCell).Add(ptr)
            If _vsCandidateCount(ptr) = 0 Then Exit Function
        End If
    Next
End Function
Private Function UndoGuess(Optional ByRef nextGuess As Integer = 0) As Boolean
    Dim intCell As Integer = 0
    Dim intCandidate As Integer = 0
    Dim blnLoop As Boolean = True
    _vsCandidatePtr(nextGuess) = 1
    _vsSteps -= 1
    If _vsSteps = 0 Then Exit Function
    intCell = _vsLastGuess(_vsSteps)
    intCandidate = _vsSolution(intCell - 1)
    '---restore to unsolved list---
    _vsUnsolvedCells(0).Add(intCell)
    '---sort unsolved cells---
    _vsUnsolvedCells(0).Sort()
    Dim j As Integer
    Dim i As Integer = 1
    Dim c As Integer
    Dim tC As Integer
    Dim intBit As Integer = intGetBit(intCandidate)
    Dim lbit As Integer = 0
    '---restore candidates in this cell---
    If intCell > 0 Then
        If Not (_vsStoreCandidateBits(intCell) And intBit) Then
            _vsStoreCandidateBits(intCell) += intBit
        End If
    End If
    lbit = _vsStoreCandidateBits(intCell)
    _vsCandidateAvailableBits(intCell) = 0
    For c = 1 To 9
        intBit = intGetBit(c)
        If lbit And intBit Then
            _vsCandidateAvailableBits(intCell) += intBit
            tC += 1
        End If
    Next

    nextGuess = intCell
    _vsSolution(intCell - 1) = 0
    _vsCandidateCount(intCell) = tC

    If intCell = 0 Then
        '---no valid solution found---
        Exit Function
    End If

    '---restore value to peers---
    Dim pCell As Integer
    For j = 0 To _vsRemovePeers(intCell).Count - 1
        pCell = _vsRemovePeers(intCell).Item(j)
        _vsCandidateAvailableBits(pCell) += intGetBit(intCandidate)
        _vsCandidateCount(pCell) += 1
    Next
    '---end restore values to peers---
End Function

蛮力 - 武士数独

所有数独谜题都被认为是 NP 完全问题。简而言之,随着网格大小的增加,找到解所需的时间/计算量也会增加。

对于武士数独,其中有五个重叠的网格,不幸的是,不能仅仅逐个解决这五个 9x9 的网格,因为通常情况下,单独考虑的每个网格的唯一解很少或根本没有——您通常需要将所有五个重叠的网格作为一个单独的谜题来解决。

但是,下面的代码用于帮助缩短更难的武士数独的求解时间。它基本上涉及测试是否可以找到一个 9x9 网格的多于 1 个但少于 100 个解。显然,这并不总是奏效,因为单个网格的解通常超过 100 个。但是,如果解少于 100 个,则会检查解的集合。如果一个空单元格在找到的每个解中都恰好出现相同的数字,那么我们就可以将该数字放入其中,因为这一定是该单元格的正确答案。

If _u > -1 Then
    If Not blnClassic Then
        Dim g As Integer
        For g = 1 To 5
            Dim Solver As New clsSudokuSolver
            Solver.blnClassic = True
            Solver.strGrid = strWriteSolution(intGrid:=g)
            Solver.vsSolvers = My.Settings._UniqueSolvers
            Solver.intQuit = 100
            Solver._vsUnique()
            If Solver.intCountSolutions > 1 _
                   AndAlso Solver.intCountSolutions < Solver.intQuit Then
                Dim s As Integer
                Dim c As Integer
                Dim m(81) As Integer
                Dim chk(81) As Boolean
                Dim chr As String
                Dim intChr As Integer
                For c = 1 To 81
                    chk(c) = True
                Next
                For s = 0 To UBound(Solver.Solutions)
                    If Array.IndexOf(chk, True) = -1 Then Exit For
                    For c = 1 To 81
                        chr = Mid(Solver.Solutions(s), c, 1)
                        intChr = CInt(chr)
                        If m(c) = 0 Then
                            m(c) = intChr
                        Else
                            If intChr <> m(c) Then
                                chk(c) = False
                                m(c) = -1
                            End If
                        End If
                    Next
                Next
                Dim strRevised As String = ""
                Dim blnRevised As Boolean
                Dim ptr As Integer
                Dim arrayPeers() As String
                Dim intBit As Integer
                For c = 1 To 81
                    chr = Mid(Solver.strGrid, c, 1)
                    If chr = "." Then
                        '---unique value across all solutions---
                        '---and not found in starting grid---
                        If m(c) > 0 Then
                            strRevised += CStr(m(c))
                            blnRevised = True
                            '---place solution---
                            ptr = intSamuraiOffset(c, g)
                            If _vsSolution(ptr - 1) = 0 Then
                                _vsSolution(ptr - 1) = m(c)
                                _vsCandidateCount(ptr) = -1
                                _vsUnsolvedCells(0).Remove(ptr)
                                arrayPeers = ArrSamuraiPeers(ptr)
                                intBit = intGetBit(m(c))
                                'remove value from peers
                                For j = 0 To UBound(arrayPeers)
                                    If _vsSolution(arrayPeers(j) - 1) = 0 _
                                      AndAlso (_vsCandidateAvailableBits(arrayPeers(j)) _
                                      And intBit) Then
                                        _vsCandidateAvailableBits(arrayPeers(j)) -= intBit
                                        _vsCandidateCount(arrayPeers(j)) -= 1
                                    End If
                                Next
                                _u -= 1
                            End If
                            '--end place solution---
                        Else
                            strRevised += chr
                        End If
                    Else
                        strRevised += chr
                    End If
                Next
                If blnRevised Then
                    blnRevised = False
                End If
            End If
        Next
    End If
End If

生成谜题

我想确保我能够生成不同难度的数独谜题。我最初只是尝试从填好的网格开始,然后随机删除数字……但这只会产生很多简单的谜题,但很少有困难的。下面的代码似乎有助于生成更广泛的谜题。下面的代码可用于在删除单元格中的线索时产生一定的随机性,但约束条件是特定数字的数量会保持不变(例如,它可能会删除 7 个数字 '8' 和 6 个数字 '3',下次可能会删除 7 个数字 '2' 和 6 个数字 '4',依此类推)。

Function RemoveCellsNoSymmetry(ByVal strGrid As String) As String
    Dim fp As Integer
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim p As Integer
    Dim r As Integer
    Dim r2 As Integer
    Dim intRemoved As Integer
    Dim strGeneratorSeed As String = "0122211000"
    Dim randomArr() As String = _
        Split(GenerateRandomStr(arrDivider), arrDivider)
    Dim randomArr2() As String
    Dim ptr As Integer
    Dim arrGame(0) As Integer
    Dim arrPos(0) As Integer
    Dim midStr As String = ""
    strGrid = Replace(strGrid, vbCrLf, "")
    ReDim arrGame(81)

    '---load game into array---
    For p = 1 To 81
        midStr = Mid(strGrid, p, 1)
        ptr = p
        If midStr <> "" AndAlso CInt(midStr) > 0 Then
            arrGame(ptr) = CInt(midStr)
        End If
    Next
    '---finish load game into array---

    For i = 0 To 9
        r = Mid(strGeneratorSeed, i + 1, 1)
        For j = 1 To CInt(r)
            Debug.Print(randomArr(k) & " will be found " & i & _
                  " times so delete " & 9 - i & " instances")
            '---start delete---'
            fp = -1
            For p = 1 To 81
                If arrGame(p) = randomArr(k) Then
                    fp += 1
                    ReDim Preserve arrPos(fp)
                    '---save all positions where digit found---'
                    arrPos(fp) = p
                End If
            Next

            '---randomly remove from array of cell positions---' 
            intRemoved = 0
            randomArr2 = Split(GenerateRandomStr(arrDivider), arrDivider)
            For r2 = 0 To UBound(randomArr2)
                If intRemoved >= (9 - i) Then Exit For
                arrGame(arrPos(randomArr2(r2) - 1)) = 0
                intRemoved += 1
            Next
            '---end delete---
            k += 1
        Next
    Next

    RemoveCellsNoSymmetry = ""
    For p = 1 To 81
        ptr = p
        If arrGame(ptr) <> "0" Then
            RemoveCellsNoSymmetry += CStr(arrGame(ptr))
        Else
            RemoveCellsNoSymmetry += "."
        End If
    Next

End Function

下一步/改进

我写这个主要是为了个人挑战。我想做到的关键是提高蛮力求解器的速度,特别是让它能够更快地解决武士数独,并提高重绘速度,使 GDI 自定义控件刷新得更快。我也可能会做一个版本来处理其他变体(例如,拼图数独)。

示例应用

示例应用程序功能齐全,可让您输入、求解、优化和生成经典的(9x9)数独谜题,并允许您输入和求解武士数独。

© . All rights reserved.