```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
'
' 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
' <http://www.di-mgt.com.au>
' <http://www.di-mgt.com.au/contactmsg.php>
' <http://www.cryptosys.net>

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()

' Set up matrix
Call InitPuzzle

' Read the data into matrix
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
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
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
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

' 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
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

```