Visual Basic数独解算器和生成器（译文）

By robot-v1.0

本文链接 https://www.kyfws.com/games/visual-basic-sudoku-solver-and-generator-zh/

01月01日, 0001 - 15 分钟阅读 - 7246 个词 阅读量 0

Visual Basic数独解算器和生成器（译文）

原文地址：https://www.codeproject.com/Articles/228470/Visual-Basic-Sudoku-Solver-and-Generator

原文作者：ZiggyG

译文由本站 robot-v1.0 翻译

前言

Solver/generator for Sudoku puzzles.

数独难题的求解器/发生器.

介绍(Introduction)

我开始尝试使用VBA在Excel中开发Sudoku求解器.与Excel进行了几次交互后,我使用VS2005移到了Visual Basic.在完成了一个程序版本以处理9x9(经典)Sudokus之后,我还修改了代码以解决Samurai Sudoku(5个重叠的9x9网格).我想同时提供源代码和演示程序-因为在Visual Basic中没有太多可以学习的全功能求解器.(I started trying to develop a Sudoku solver in Excel using VBA. After a few interactions with Excel, I moved to Visual Basic using VS2005. After doing a version of the program to deal with 9x9 (classic) Sudokus, I also adapted the code to solve Samurai Sudoku (5 overlapping 9x9 grids). I wanted to provide both a source and demo - as there aren’t too many fully featured solvers I could find in Visual Basic to learn from.) 基于逻辑的求解器和UI可能花费了最多的工作-实际的蛮力求解器实际上非常容易编写代码.(The logic based solvers and the UI probably took the most work - the actual brute force solver was actually pretty quick to code.)

术语(Terminology)

本文不深入探讨数独的规则或如何解决数独难题的细节.如果您想为此使用背景,请使用搜索引擎.但是,基本原理是将数字1-9放置在行,列和子网格中,以便每行,列和子网格仅包含每个数字一次.但是,下面使用一些术语来解释代码.(This article doesn’t go in depth into the rules of Sudoku or the detail of how to solve Sudoku puzzles. Just use a search engine if you want background on this. However, the basic principle is that the numbers 1-9 are placed into the rows, columns, and subgrids so that every row, column, and subgrid only contain each digit once. Some terms however are used below to explain the code.)

细胞(Cell)-可以放置数字1-9的单个单元格.(- individual cell where digits 1-9 can be placed.)
线索/给予(Clues/givens)-在上面的第一张图片中,第二个和第三个单元格分别具有线索7和6.(- in the first image above, the second and third cells hold clues of 7 and 6, respectively.)
候选人/铅笔(Candidates/pencilmarks)-在上图中,第一个单元格包含三个候选项(2\3和9).尝试解决难题以跟踪各种候选人时,这一点很重要.(- in the image above, the first cell contains three candidates (2, 3, and 9). It is important when trying to solve a puzzle to keep track of the various candidates.)
行(Row)-一组9个单元,水平向下移动到屏幕上.(- a group of 9 cells going horizontally down the screen.)
列-由9个单元格组成的组在屏幕上垂直向下移动.(Column - a group of 9 cells going vertically down the screen.)
子网格(Subgrid)-以3x3分组的9个像元组.(- a group of 9 cells arranged in a 3x3 grouping.)
同行(Peers)-在9x9经典网格中,每个单元格可以"看到"多达20个其他单元格(行,列和子网格中的其他单元格).由于不能在行,单元格或子网格中重复数字的规则,因此,如果将数字作为单元格的解决方案,则可以将该数字作为候选从每个对等方中删除.武士数独的对等点有些不同,因为由于五个重叠的网格,某些单元的对等点数目会更多.(- in a 9x9 classic grid, each cell can ‘see’ up to 20 other cells (the other cells in the row, column, and subgrid). Due to the rule that no digit can be repeated in a row, cell, or subgrid, if you place a digit as the solution to a cell, that digit can be removed as a candidate from each of its peers. Peers for a Samurai Sudoku are a bit different, as some cells will have a greater number of peers due to the five overlapping grids.)

兴趣点(Points of Interest)

求解器将尝试使用逻辑步骤来解决难题,但也将采用蛮力算法来解决更难的难题.因此,它可以立即解决大多数经典的9x9数独难题,或者几秒钟之内解决大多数武士难题(取决于计算机).诚然,有些C ++求解器每秒可以解决数百或数千个难题.但是,我想要一些可以合理地解决难题的方法,而且还能够逐步解决难题,并说明为什么要采取特殊的解决步骤.(The solver will try to solve puzzles using logical steps, but will also resort to a brute force algorithm for tougher puzzles. Consequently, it can solve most classic 9x9 Sudoku puzzles pretty much instantly, or most Samurai puzzles within a couple of seconds (depending on the computer). Admittedly, there are C++ solvers that can solve hundreds or thousands of puzzles per second. However, I wanted something that would solve puzzles reasonably quickly, but also be able to step through puzzles and show why particular solving steps were taken.) 有一个自定义控件,该控件使用GDI +绘制线索和候选对象(铅笔标记).使用一堆单独的标签或类似标签太慢以至于无法刷新. UI仍然可能有点慢,无法使用Samurai拼图进行刷新,但是总体来说还不错.(There is a custom control which uses GDI+ to paint clues and candidates (pencilmarks). Using a bunch of individual labels or the like was far too slow to refresh. The UI can still be a little bit slow to refresh with Samurai puzzles, but is generally not too bad.) 与我见过的许多其他求解器不同,后者倾向于使用81(9)的二维数组来容纳每个像元的可能候选者,而该求解器使用长度为81的单个数组来容纳所有可能的候选者.使用公式2 ^(candidate-1)为每个候选人分配一个值,以为每个候选人提供一个唯一的比特值(尽管我已选择对此进行硬编码以最小化此计算的需要).因此,候选1 ＝位值1,候选2 ＝位值2,候选3 ＝位值4,候选4 ＝位值8,候选5 ＝位值16,依此类推.(Unlike a lot of other solvers I’ve seen, which tend to use a two dimensional array of 81(9) to hold possible candidates for each cell, this solver uses a single array of length 81 to hold all possible candidates. Each candidate is assigned a value using the formula 2 ^ (candidate-1) to come up with a unique bit value for each candidate (although I’ve chosen to hard code this to minimise the need for this calculation). Therefore, candidate 1=bit value 1, candidate 2=bit value 2, candidate 3=bit value 4, candidate 4=bit value 8, and candidate 5=bit value 16, and so forth.) 因此,如果单元格2具有候选值1\3和4作为可能的值,则可以将数组的值设置为:(So if cell 2 had candidates 1, 3, and 4 as possible values, you would set the value of the array to:)

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

而不是要做类似的事情:(rather than having to do something like:)

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

这种方法的优点是,许多基于逻辑的方法都可以解决Sudoku在子集上的工作,因此,如果您要检查单元格81是否只有候选项1和9可用,则进行简单检查以查看是否具有简单性(The advantage of this approach is that a lot of logic based approaches to solving Sudoku work on subsets, so if you wanted to check if cell 81 only has candidates 1 and 9 available, it is trivial to do a simple check to see if) _vsCandidateAvailableBits(81) = 257 (位值1 +位值256).((bit value 1 + bit value 256).) 实际的求解器本身被编码为一类,并使用深度优先搜索.它将继续搜索多个解决方案,或者可以将其设置为在找到一定数量的解决方案后退出.(The actual solver itself is coded as a class and uses a depth first search. It will keep searching for multiple solutions, or can be set to exit after a set number of solutions are found.)

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

要运行求解器,您需要调用(To run the solver, you need to call) solver._vsUnique() 测试一个独特的解决方案.(which tests for a unique solution.) 然后,您可以做类似的事情(You can then do things like) dim blnUnique as boolean = solver._vsUnique() 检查拼图是否有一个有效的解决方案.(to check see if a puzzle has a single valid solution or not.)

蛮力求解器(Brute force solver)

蛮力解算器位于其自己的类中.从根本上讲,这是一个迭代循环,通过尝试找到最佳猜测并找出不正确的猜测来寻找解决方案.(The brute force solver is held in its own class. It is basically an iterative loop that searches for a solution, by trying to find the best guess, and unwinding guesses if they are incorrect.) 首先要做的是加载开始游戏(一个包含81个字符的字符串(对于9x9 Sudoku)或五个由换行符分隔的81个字符的字符串(对于Samurai Sudoku).有效输入是字符1-9.用于起始线索以及句号或零字符来表示未填充/空的单元格.(The first task at hand is to load in the starting game (either a string holding 81 characters (for a 9x9 Sudoku) or five strings of 81 characters separated by line breaks (for a Samurai Sudoku). Valid input are the characters 1-9 for starting clues and either a full stop or zero characters to represent unfilled/empty cells.)

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

获得有效输入后,我们将调用一个函数,该函数将循环测试所有解决方案(尽管可以设置一个值((Once we have some valid input, we call a function that will loop to test for all solutions (although it is possible to set a value () intQuit )在找到所需数量的解决方案时退出).例如,如果您要确保拼图有效(例如,只有一个唯一的解决方案),则() to exit when a desired number of solutions have been found). For example, if you want to ensure a puzzle is valid (e.g., only has a single unique solution), then) intQuit 可以设置为" 2"(因此它将在找到两个解后退出).但是,在某些情况下(如下面进一步解释的那样),找到多个解决方案对于解决武士难题非常有用.(can be set to ‘2’ (so it will exit after finding two solutions). However, there can be instances (such as explained further below) where finding multiple solutions can be useful for solving Samurai puzzles.) 主要解决功能如下.(The main solving function is set out below.)

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

暴力求解器的关键部分是"向前看",以尝试选择下一个最佳的未填充单元,以尝试放置可用的候选对象.下面的功能旨在通过查找具有最少可用候选数的空单元格来实现此目的.如果有一个只有一个候选对象的单元格,则选择该单元格,因为这是最佳猜测.否则,目的是寻找候选数量最少的未填充单元(因为这会减少总体搜索空间/求解时间).作为另一种改进,如果存在多个未填充的单元格,每个单元格具有相同的候选数,则使用附加循环来确定这些单元格中哪个具有最高的对等体(基于所做的任何猜测将具有最高的机会)从谜题中删除其他候选人).可能还有其他方法可以尝试,因为找到最佳的下一步可能会提高求解速度.(A key part of the brute force solver is doing a ‘look ahead’ to try to pick the next best unfilled cell to try placing an available candidate. The function below aims to do this by looking for an empty cell with the minimum number of candidates available. If there is a cell with only a single candidate, this is selected, as this is an optimal guess. Otherwise, the intention is to look for an unfilled cell with the smallest number of candidates (as this reduces the overall search space/solving time). As an additional refinement, if there are multiple unfilled cells each with the same number of candidates, an additional loop is used to determine which of these cells has the highest number of peers (on the basis that any guess made will have the highest chance of removing further candidates from the puzzle). There may be other approaches that can be trialed, as finding the best possible next move is most likely to increase the solving speed.)

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

一旦选择了未填写的单元,下一步就是在该单元中找到下一个可用的候选者,如下所示:(Once an unfilled cell has been selected, the next step is to find the next available candidate in that cell, as detailed below:)

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

所需的其他主要项目分别是进行猜测和回溯猜测的功能.关键问题是跟踪猜测结果是从单元的对等方中删除了哪些候选对象.如果没有准确记录,就无法根据需要正确撤消猜测.(The other main items required are functions to make guesses and wind back guesses, respectively. A key issue is keep track of where candidates have been removed from the peers of a cell as the result of a guess. Without accurately recording this, it is not possible to properly undo guesses as required.)

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

蛮力-武士拼图(Bruteforce - Samurai Puzzles)

所有数独谜题都被认为是NP完全的.简而言之,随着网格尺寸的增加,寻找解决方案的潜在时间/计算工作也会随之增加.(All Sudoku puzzles are considered NP-complete. In short, as the size of the grid increases, so does the potential time/computational effort to find a solution.) 对于有五个重叠网格的武士难题,不幸的是,不仅要依次单独解决五个9x9网格中的每一个问题,因为通常情况下,很少或没有一个单独的网格具有唯一性解决方案-您通常需要将所有五个重叠的网格作为一个难题来解决.(For Samurai puzzles, where there are five overlapping grids, it is unfortunately not just a matter of individually solving each of the five 9x9 grids in turn, as it is usually the case that few or none of the individual grids taken in isolation have a unique solution - you usually need to solve all five overlapping grids as a single puzzle.) 但是,下面的代码用于帮助减少较难的武士难题的求解时间.基本上,它涉及测试以查看是否可以为单个9x9网格找到超过1个但少于100个的解决方案.显然,这并不总是可行的,因为单个网格通常有100多个解决方案.但是,如果解决方案少于100个,则检查解决方案的集合.如果找到的每个解决方案中出现一个完全相同的数字的空单元格,则我们可以放置该数字,因为这必须是该单元格的正确答案.(However, the code below is used to help reduce the solving time for harder Samurai puzzles. It basically involves testing to see if more than 1 but less than 100 solutions to an individual 9x9 grid can be found. Obviously, this won’t always work, as there are often more than 100 solutions for an individual grid. However, if there are less than 100 solutions, the collection of solutions is checked. If an empty cell has exactly the same digit appearing in each and every solution found, we can then place that digit as this must be the correct answer for that cell.)

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

产生难题(Generating Puzzles)

我想确保的另一件事是,我可以生成不同难度的数独难题.我最初只是尝试从填充的网格开始并随机删除数字…但这只是导致了许多简单的难题,但很少有难题.下面的代码似乎可以帮助您更好地生成拼图.下面的代码可用于在删除单元格线索时仍然导致一定的随机性,但存在一定数量的特定数字保留的约束(例如,它可能会删除7个数字" 8"的实例,并且数字" 3"的6个实例,下次它可能会删除数字" 2"的7个实例和数字" 4"的6个实例,依此类推.(Another thing I wanted to ensure was that I could generate Sudoku puzzles of different difficulties. I initially just tried starting with filled grids and randomly removing digits…but this simply resulted in lots of easy puzzles, but very few difficult ones. The code below seems to help give a better range of generated puzzles. The code below can be used to still result in a certain randomness in the deletion of clues from cells, but with the constraint that a certain number of a particular digit will remain (e.g., it might delete 7 instances of the digit ‘8’ and 6 instances of the digit ‘3’, and the next time it might delete 7 instances of the digit ‘2’ and 6 instances of the digit ‘4’, and so forth).)

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

后续步骤/改进(Next Steps/Improvements)

我写这篇文章主要是个人挑战.我想做的关键是提高蛮力解算器的速度,尤其是它可以更快地解决武士难题,并提高重绘速度,以便GDI自定义控件刷新得更快.我可能还会制作一个可以处理其他变体的版本(例如,数独拼图).(I wrote this mainly as a personal challenge. The key thing I’d like to do is improve the speed of the bruteforce solver, especially so it can solve Samurai puzzles much more quickly, and improve the redraw speed so the GDI custom controls refresh faster. I might also do a version that will deal with other variants (such as jigsaw Sudoku puzzles).)

样品申请(Sample Application)

该示例应用程序功能齐全,可让您输入,求解,优化和生成经典(9x9)数独谜题,并让您输入和求解武士难题.(The sample application is fully featured and lets you enter, solve, optmise, and generate classic (9x9) Sudoku puzzles and will let you enter and solve Samurai puzzles.)

许可

本文以及所有相关的源代码和文件均已获得The Code Project Open License (CPOL)的许可。

VB Windows Visual-Studio GDI+ VS2005 Dev 新闻翻译