Option Explicit ' This code tries to solve 9x9 Su Doku problems. ' ' Copyright (C) 2004 David Ireland ' ' This program is free software; you can redistribute it and/or ' modify it under the terms of the GNU General Public License ' as published by the Free Software Foundation; either version 2 ' of the License, or (at your option) any later version. ' ' This program is distributed in the hope that it will be useful, ' but WITHOUT ANY WARRANTY; without even the implied warranty of ' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ' GNU General Public License for more details. ' ' You should have received a copy of the GNU General Public License ' along with this program; if not, write to the Free Software ' Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ' ' ' Contact: David Ireland, DI Management Services Pty Ltd ' ' ' Const ncSIZE As Integer = 9 Const ncINDEXLEN As Integer = ncSIZE * ncSIZE Type udtSQUARE Value As Integer ' 0=not set, else value 1..9 Possibles(ncSIZE) As Integer ' 1=possible, 0=not possible GuessLevel As Integer ' 0=firm, else level of guess 1,2,3,... Given As Boolean ' True if given in problem nRow As Integer ' For fast lookup. Set by InitPuzzle nCol As Integer ' ditto nBox As Integer ' ditto End Type ' Store matrix in a linear array, 1-based so just ignore (0). Public Squares(ncSIZE * ncSIZE) As udtSQUARE ' Global level at which we're guessing (0=firm) Private mnGuessLevel As Integer ' Indexes to guesses we've already tried (hopefully not too many) Const ncGUESSEDMAX As Integer = 12 ' arbitrary number Private Guessed(ncGUESSEDMAX) As Integer ' Difficulty level Public mnDifficulty As Integer Public Function DoPuzzle() Dim BadIndex As Integer ' Set up matrix Call InitPuzzle ' Read the data into matrix BadIndex = ReadInput() If BadIndex <> 0 Then MsgBox "Invalid input data. Problem with (" & GetRow(BadIndex) & "," & GetCol(BadIndex) & ")", vbCritical Exit Function End If Debug.Print "At start, Missing values =" & MissingValues() ' Try solving without a guess Call TrySolve If MissingValues() > 0 Then ' Now we'll have to guess, possibly recursively Call TryGuess End If If MissingValues() = 0 Then MsgBox "We have found a solution. Problem difficulty level=" & mnDifficulty FillInResults Else If vbOK = MsgBox("Sorry, couldn't solve. Do you want the known values filled in?", vbOKCancel) Then FillInResults End If End If End Function Public Function TryGuess() As Boolean ' Try a guess. Recursive function. Dim GuessIndex As Integer Dim i As Integer Dim nValue As Integer Dim nMaxGuesses As Integer Dim GuessPossibles(ncSIZE) As Integer Dim TrialIndex As Integer TryGuess = False mnDifficulty = mnDifficulty + 1 ' Increment the current guess level so we can backtrack if nec mnGuessLevel = mnGuessLevel + 1 Debug.Print "GUESS LEVEL = " & mnGuessLevel ' All we do from now on will be provisional... ' Check limit so we don't go on forever If mnGuessLevel > ncGUESSEDMAX Then MsgBox "Tried too many guesses!", vbExclamation Exit Function End If ' Pick a square with the lowest # possibilites ' excluding any prior guesses GuessIndex = FindMinPossibles() ' Remember so we don't try again Guessed(mnGuessLevel) = GuessIndex nMaxGuesses = CountPossibles(GuessIndex) ' Remember the details of this pivotal square For i = 1 To ncSIZE GuessPossibles(i) = Squares(GuessIndex).Possibles(i) Next Debug.Print "Guessing for square (" & GetRow(GuessIndex) & "," & GetCol(GuessIndex) & ")" Debug.Print nMaxGuesses & " possible values" ' Fill in with the next guess; work through all possibles For TrialIndex = 1 To nMaxGuesses nValue = TheNthPossible(GuessIndex, TrialIndex) Debug.Print "Guessing value=" & nValue If nValue <= 0 Then MsgBox "Run out of guesses!" Exit Function End If Call SetSquare(nValue, GuessIndex) If TrySolve() Then ' We are done Exit For Else Debug.Print "Guess FAILED." Call UndoGuess(mnGuessLevel) Debug.Print "After UndoGuess: Missing values=" & MissingValues() End If Next Debug.Print "END TryGuess. Missing Values=" & MissingValues() ' If we're not there yet, we try another (recursive) guess at the next level If MissingValues() > 0 Then Call TryGuess End If End Function Public Function UndoGuess(ByVal ThisLevel As Integer) ' Undo all guesses at this level ' And redo all Possibles because they're wrong Dim Index As Integer Dim i As Integer Dim nOldLevel As Integer For Index = 1 To ncINDEXLEN If Squares(Index).GuessLevel = ThisLevel Then Squares(Index).Value = 0 End If For i = 1 To ncSIZE Squares(Index).Possibles(i) = 1 Next Next ' To reset all the Possibles, use SetSquare to reset the known squares ' But temporarily change guess level to zero while we do that nOldLevel = mnGuessLevel mnGuessLevel = 0 For Index = 1 To ncINDEXLEN If Squares(Index).Value > 0 Then Call SetSquare(Squares(Index).Value, Index) End If Next mnGuessLevel = nOldLevel Debug.Print "Undone guess at level " & mnGuessLevel End Function Public Function TrySolve() As Boolean ' Try and solve with a definite answer ' Returns True if solved Dim iRound As Integer Dim done As Boolean Dim nPrevious As Integer mnDifficulty = mnDifficulty + 1 iRound = 0 nPrevious = 0 done = False Do Until done Or nPrevious = MissingValues() ' Remember previous count so we can stop nPrevious = MissingValues() ' This first go can solve the simpler problems outright Do While SetKnownValues() iRound = iRound + 1 Debug.Print "Completed round " & iRound & ". Missing values =" & MissingValues() Loop If MissingValues() = 0 Then Debug.Print "Solved on First Go!" done = True Exit Do End If ' Now try harder mnDifficulty = mnDifficulty + 1 Do While TryEachBox() Debug.Print "Tried each box. Missing values =" & MissingValues() Do While SetKnownValues() iRound = iRound + 1 Debug.Print "Completed round " & iRound & ". Missing values =" & MissingValues() Loop Loop If MissingValues() = 0 Then done = True Exit Do End If Do While TryEachRow() Debug.Print "Tried each row. Missing values =" & MissingValues() Do While SetKnownValues() iRound = iRound + 1 Debug.Print "Completed round " & iRound & ". Missing values =" & MissingValues() Loop Loop If MissingValues() = 0 Then done = True Exit Do End If Do While TryEachCol() Debug.Print "Tried each col. Missing values =" & MissingValues() Do While SetKnownValues() iRound = iRound + 1 Debug.Print "Completed round " & iRound & ". Missing values =" & MissingValues() Loop Loop If MissingValues() = 0 Then done = True Exit Do End If Loop ' Until done TrySolve = (MissingValues() = 0) End Function Public Function AlreadyGuessed(ThisIndex As Integer) As Boolean ' Returns True if we've already guessed a value for this index ' at a lower level (i.e. mnGuessLevel has already been incremented) Dim i As Integer For i = 1 To mnGuessLevel - 1 If Guessed(i) = ThisIndex Then AlreadyGuessed = True Exit For End If Next End Function Public Function FindMinPossibles() As Integer ' Returns index to an unsolved square with lowest # possibilities ' excluding any prior guesses at lower levels Dim Index As Integer Dim nMin As Integer Dim nMinIndex As Integer nMin = ncSIZE + 1 For Index = 1 To ncINDEXLEN If Squares(Index).Value = 0 And CountPossibles(Index) < nMin Then If Not AlreadyGuessed(Index) Then nMin = CountPossibles(Index) nMinIndex = Index End If End If Next FindMinPossibles = nMinIndex End Function Public Function TryEachBox() As Boolean ' Try all candidates for each box until we find something new ' If find a new one, stop, set the value and return True ' If no luck, return False Dim iBox As Integer Dim iValue As Integer Dim n As Integer Dim nFoundAt As Integer TryEachBox = False For iBox = 1 To ncSIZE For iValue = 1 To ncSIZE n = PossiblesInBox(iValue, iBox, nFoundAt) If n = 1 Then ' Check this is not already set If Squares(nFoundAt).Value = 0 Then ' Hooray! We have solved this square Call SetSquare(iValue, nFoundAt) ' Do not go any further now TryEachBox = True Exit Function End If End If Next Next End Function Public Function TryEachRow() As Boolean ' Try all candidates for each row until we find something new ' If find a new one, stop, set the value and return True ' If no luck, return False Dim iRow As Integer Dim iValue As Integer Dim n As Integer Dim nFoundAt As Integer TryEachRow = False For iRow = 1 To ncSIZE For iValue = 1 To ncSIZE n = PossiblesInRow(iValue, iRow, nFoundAt) If n = 1 Then ' Check this is not already set If Squares(nFoundAt).Value = 0 Then ' Hooray! We have solved this square Call SetSquare(iValue, nFoundAt) ' Do not go any further now TryEachRow = True Exit Function End If End If Next Next End Function Public Function TryEachCol() As Boolean ' Try all candidates for each col until we find something new ' If find a new one, stop, set the value and return True ' If no luck, return False Dim iCol As Integer Dim iValue As Integer Dim n As Integer Dim nFoundAt As Integer TryEachCol = False For iCol = 1 To ncSIZE For iValue = 1 To ncSIZE n = PossiblesInCol(iValue, iCol, nFoundAt) If n = 1 Then ' Check this is not already set If Squares(nFoundAt).Value = 0 Then ' Hooray! We have solved this square Call SetSquare(iValue, nFoundAt) ' Do not go any further now TryEachCol = True Exit Function End If End If Next Next End Function Public Function PossiblesInBox(ThisValue As Integer, nBox As Integer, ByRef FoundAt As Integer) ' Returns no of possibles for This Value in this box ' And sets FoundAt to be the index where we last found a possible for this value Dim Index As Integer Dim n As Integer n = 0 FoundAt = 0 For Index = 1 To ncINDEXLEN If Squares(Index).nBox = nBox Then If Squares(Index).Possibles(ThisValue) > 0 Then n = n + 1 FoundAt = Index End If End If Next PossiblesInBox = n End Function Public Function PossiblesInRow(ThisValue As Integer, nRow As Integer, ByRef FoundAt As Integer) ' Returns no of possibles for This Value in this row ' And sets FoundAt to be the index where we last found a possible for this value Dim Index As Integer Dim n As Integer n = 0 FoundAt = 0 For Index = 1 To ncINDEXLEN If Squares(Index).nRow = nRow Then If Squares(Index).Possibles(ThisValue) > 0 Then n = n + 1 FoundAt = Index End If End If Next PossiblesInRow = n End Function Public Function PossiblesInCol(ThisValue As Integer, nCol As Integer, ByRef FoundAt As Integer) ' Returns no of possibles for This Value in this col ' And sets FoundAt to be the index where we last found a possible for this value Dim Index As Integer Dim n As Integer n = 0 FoundAt = 0 For Index = 1 To ncINDEXLEN If Squares(Index).nCol = nCol Then If Squares(Index).Possibles(ThisValue) > 0 Then n = n + 1 FoundAt = Index End If End If Next PossiblesInCol = n End Function Public Function MissingValues() As Integer ' Returns number of squares not set. If zero we have a full solution. Dim Index As Integer Dim n As Integer n = 0 For Index = 1 To ncINDEXLEN If Squares(Index).Value = 0 Then n = n + 1 End If Next MissingValues = n End Function Public Function SetKnownValues() As Boolean ' See if simple elimination of possibles yields us any solutions ' Returns True if made a change or False if no change on this pass Dim Index As Integer Dim iValue As Integer Dim bChanged As Boolean bChanged = False For Index = 1 To ncINDEXLEN If CountPossibles(Index) = 1 And Squares(Index).Value = 0 Then ' Found another answer iValue = ThePossible(Index) Debug.Print "Found Value(" & GetRow(Index) & "," & GetCol(Index) & ")=" & iValue ' Set the value (and remove more possibles) Call SetSquare(iValue, Index) bChanged = True End If Next Debug.Print "SetKnownValues: " & IIf(bChanged, "FOUND MORE...", "NO CHANGES this round") SetKnownValues = bChanged End Function Public Function CountPossibles(Index As Integer) As Integer ' Count no of values that are possible for this square ' If one, we have the solution ' If zero, we have an error Dim i As Integer Dim n As Integer n = 0 For i = 1 To ncSIZE n = n + Squares(Index).Possibles(i) Next CountPossibles = n End Function Public Function ThePossible(Index As Integer) As Integer ' Assumes only one possible value Dim i As Integer For i = 1 To ncSIZE If Squares(Index).Possibles(i) = 1 Then ThePossible = i Exit For End If Next End Function Public Function TheNthPossible(Index As Integer, n_th As Integer) As Integer ' Finds the nth possible value for this square (1-based) Dim i As Integer Dim nValue As Integer Dim n As Integer n = n_th For i = 1 To ncSIZE If Squares(Index).Possibles(i) = 1 Then n = n - 1 If n = 0 Then nValue = i Exit For End If End If Next TheNthPossible = nValue End Function Public Function IsDataOK() As Integer ' Returns zero if data is OK, else index of first error Dim Index As Integer IsDataOK = 0 ' Innocent until proven guilty For Index = 1 To ncINDEXLEN If Squares(Index).Value > ncSIZE Or Squares(Index).Value < 0 Or CountPossibles(Index) <= 0 Then IsDataOK = Index Exit For End If Next End Function Public Function SetSquare(iValue As Integer, ThisIndex As Integer) As Boolean ' Set the square value and eliminate all possibles in same row, col and box Dim i As Integer Squares(ThisIndex).Value = iValue Squares(ThisIndex).GuessLevel = mnGuessLevel For i = 1 To ncINDEXLEN If Squares(i).nRow = Squares(ThisIndex).nRow Then Squares(i).Possibles(iValue) = 0 End If If Squares(i).nCol = Squares(ThisIndex).nCol Then Squares(i).Possibles(iValue) = 0 End If If Squares(i).nBox = Squares(ThisIndex).nBox Then Squares(i).Possibles(iValue) = 0 End If Next ' And make sure this square's Possibles are set properly For i = 1 To ncSIZE Squares(ThisIndex).Possibles(i) = 0 Next Squares(ThisIndex).Possibles(iValue) = 1 SetSquare = True End Function Public Function SetSquareRC(iValue As Integer, iRow As Integer, iCol As Integer, Optional IsGiven As Boolean) As Boolean ' Set square value given (row,col). Optionally set the Given tag. Dim Index As Integer Index = GetIndex(iRow, iCol) Squares(Index).Given = IsGiven SetSquareRC = SetSquare(iValue, Index) End Function Public Function FillInResults() Dim rng As Range Dim iRow As Integer, iCol As Integer Dim iValue As Integer Dim Index As Integer Set rng = Range("Puzzle") For iRow = 1 To ncSIZE For iCol = 1 To ncSIZE Index = GetIndex(iRow, iCol) If Squares(Index).Given Then ' Just reformat to show it was a given rng(iRow, iCol).Interior.ColorIndex = 6 rng(iRow, iCol).Font.Bold = True ElseIf Squares(Index).Value > 0 Then ' Found a solution rng(iRow, iCol).Value = Squares(Index).Value rng(iRow, iCol).Interior.ColorIndex = xlNone rng(iRow, iCol).Font.Bold = False End If Next Next End Function Public Function ClearGrid() Dim rng As Range Dim iRow As Integer, iCol As Integer Dim iValue As Integer Dim Index As Integer Set rng = Range("Puzzle") For iRow = 1 To ncSIZE For iCol = 1 To ncSIZE Index = GetIndex(iRow, iCol) rng(iRow, iCol).Value = "" rng(iRow, iCol).Interior.ColorIndex = xlNone rng(iRow, iCol).Font.Bold = False Next Next End Function Public Function ReadInput() As Integer ' 0 if OK else index of square with problem Dim rng As Range Dim wkb As Workbook Dim iRow As Integer, iCol As Integer Dim iValue As Integer Set wkb = ActiveWorkbook Set rng = Range("Puzzle") For iRow = 1 To ncSIZE For iCol = 1 To ncSIZE iValue = Val(rng.Item(iRow, iCol)) If iValue > 0 Then ' Store given value in array If Not SetSquareRC(iValue, iRow, iCol, True) Then MsgBox "Invalid input at (" & iRow & "," & iCol & ")!" Exit Function End If End If Next Next ReadInput = IsDataOK() End Function Public Function InitPuzzle() ' Initialise the Squares matrix Dim iRow As Integer, iCol As Integer Dim Index As Integer Dim i As Integer ' Init all values For Index = 1 To ncINDEXLEN Squares(Index).Given = False Squares(Index).GuessLevel = 0 Squares(Index).Value = 0 Next For i = 1 To ncGUESSEDMAX Guessed(i) = 0 Next ' Set all possibles to 1 For Index = 1 To ncINDEXLEN For i = 1 To ncSIZE Squares(Index).Possibles(i) = 1 Next Next ' Set global guess level mnGuessLevel = 0 mnDifficulty = 0 ' Initialise the row, col and box numbers ' to speed up lookups ' (These could be done with constants, but this is easier) ' Stored row x column, base-1 For iCol = 1 To 9 For iRow = 1 To 9 Index = GetIndex(iRow, iCol) Squares(Index).nRow = iRow Squares(Index).nCol = iCol Next Next ' Set box numbers 1..9 ' (there's surely a simpler algorithm but this works...) For iRow = 1 To 3 For iCol = 1 To 3 Index = GetIndex(iRow, iCol) Squares(Index).nBox = 1 Next For iCol = 4 To 6 Index = GetIndex(iRow, iCol) Squares(Index).nBox = 2 Next For iCol = 7 To 9 Index = GetIndex(iRow, iCol) Squares(Index).nBox = 3 Next Next For iRow = 4 To 6 For iCol = 1 To 3 Index = GetIndex(iRow, iCol) Squares(Index).nBox = 4 Next For iCol = 4 To 6 Index = GetIndex(iRow, iCol) Squares(Index).nBox = 5 Next For iCol = 7 To 9 Index = GetIndex(iRow, iCol) Squares(Index).nBox = 6 Next Next For iRow = 7 To 9 For iCol = 1 To 3 Index = GetIndex(iRow, iCol) Squares(Index).nBox = 7 Next For iCol = 4 To 6 Index = GetIndex(iRow, iCol) Squares(Index).nBox = 8 Next For iCol = 7 To 9 Index = GetIndex(iRow, iCol) Squares(Index).nBox = 9 Next Next End Function Public Function GetIndex(iRow As Integer, iCol As Integer) As Integer ' Given (iRow, iCol) return value of index (1..81) GetIndex = (iRow - 1) * ncSIZE + iCol End Function Public Function GetRow(iIndex As Integer) As Integer GetRow = ((iIndex - 1) \ ncSIZE) + 1 End Function Public Function GetCol(iIndex As Integer) As Integer GetCol = ((iIndex - 1) Mod ncSIZE) + 1 End Function Public Function GetBox(iIndex As Integer) As Integer Dim nRow As Integer, nCol As Integer Dim nBand As Integer Dim nStack As Integer nRow = GetRow(iIndex) nCol = GetCol(iIndex) nBand = (nRow - 1) \ 3 + 1 nStack = (nCol - 1) \ 3 + 1 GetBox = (nBand - 1) * 3 + nStack End Function Public Function InThisRow(TheValue As Integer, TheIndex As Integer) As Boolean Dim Index As Integer Dim nRow As Integer InThisRow = False nRow = GetRow(TheIndex) For Index = 1 To ncINDEXLEN If Squares(Index).nRow = nRow Then If Squares(Index).Value = TheValue Then InThisRow = True Exit For End If End If Next End Function Public Function InThisCol(TheValue As Integer, TheIndex As Integer) As Boolean Dim Index As Integer Dim nCol As Integer InThisCol = False nCol = GetCol(TheIndex) For Index = 1 To ncINDEXLEN If Squares(Index).nCol = nCol Then If Squares(Index).Value = TheValue Then InThisCol = True Exit For End If End If Next End Function Public Function InThisBox(TheValue As Integer, TheIndex As Integer) As Boolean Dim Index As Integer Dim nBox As Integer InThisBox = False nBox = GetBox(TheIndex) For Index = 1 To ncINDEXLEN If Squares(Index).nBox = nBox Then If Squares(Index).Value = TheValue Then InThisBox = True Exit For End If End If Next End Function Sub Button1_Click() DoPuzzle End Sub Sub Button3_Click() ClearGrid End Sub