Option Explicit On Option Strict On Imports System Imports System.IO Module Sudoku Dim MULTIPLE_VALUES As Integer = 1 Dim CORRECT As Integer = 2 Dim INCORRECT As Integer = 4 Dim DEBUG As Boolean = False Dim NeighborMap(80) As Hashtable ' 0 1 2 3 4 5 6 7 8 ' 9 10 11 12 13 14 15 16 17 ' 18 19 20 21 22 23 24 25 26 ' 27 28 29 30 31 32 33 34 35 ' 36 37 38 39 40 41 42 43 44 ' 45 46 47 48 49 50 51 52 53 ' 54 55 56 57 58 59 60 61 62 ' 63 64 65 66 67 68 69 70 71 ' 72 73 74 75 76 77 78 79 80 Private Sub constructNeighborMap() For i As Integer = 0 To 80 NeighborMap(i) = New Hashtable Next For i As Integer = 0 To 8 For j As Integer = 0 To 8 For k As Integer = 0 To 8 ' Horizontal neighbors If (j <> k AndAlso _ Not NeighborMap(9 * i + j).ContainsKey(9 * i + k)) Then NeighborMap(9 * i + j).Add(9 * i + k, True) End If ' Vertical neighbors If (9 * i <> 9 * k AndAlso _ Not NeighborMap(9 * i + j).ContainsKey(9 * k + j)) Then NeighborMap(9 * i + j).Add(9 * k + j, True) End If Next Next Next ' 3x3 square neighbors For Each i As Integer In New Integer(2) {0, 3, 6} For Each j As Integer In New Integer(2) {0, 27, 54} For k As Integer = 0 To 2 For Each l As Integer In New Integer(2) {0, 9, 18} For m As Integer = 0 To 2 For Each n As Integer In New Integer(2) {0, 9, 18} If (k + l <> m + n AndAlso _ Not NeighborMap(i + j + k + l).ContainsKey(i + j + m + n)) Then NeighborMap(i + j + k + l).Add(i + j + m + n, True) End If Next Next Next Next Next Next End Sub Private Function readPuzzle() As Hashtable() Dim vals() As String Dim data(80) As Integer Dim count As Integer Dim delimStr As String = " \t" Dim delimiter As Char() = delimStr.ToCharArray() Dim input As String = System.Console.In.ReadLine() Do While Not input Is Nothing input.Trim() vals = input.Split(delimiter) For Each v As String In vals If (v.Trim() <> "") Then Try data(count) = Integer.Parse(v.Trim()) If (data(count) < 0) OrElse (data(count) > 9) Then Throw New Exception("Invalid puzzle") End If count = count + 1 Catch Throw New Exception("Invalid puzzle") End Try End If Next input = System.Console.In.ReadLine() Loop If (count <> 81) Then Throw New Exception("Not enough values") End If Dim ret(80) As Hashtable For i As Integer = 0 To data.Length - 1 ret(i) = New Hashtable If (data(i) = 0) Then For j As Integer = 1 To 9 ret(i).Add(j, True) Next Else ret(i).Add(data(i), True) End If Next Return ret End Function Private Sub reduce(ByRef puzzle() As Hashtable) Dim keepReducing As Boolean = True Dim key As Object Dim en As System.Collections.IEnumerator Do While keepReducing keepReducing = False For index As Integer = 0 To puzzle.Length - 1 If (puzzle(index).Keys.Count = 1) Then en = puzzle(index).Keys.GetEnumerator en.MoveNext() key = en.Current For Each neighbor As Integer In (NeighborMap(index).Keys) If (puzzle(neighbor).ContainsKey(key)) Then puzzle(neighbor).Remove(key) keepReducing = True End If Next End If Next Loop End Sub Private Sub printPuzzle(ByVal puzzle() As Hashtable) Dim en As System.Collections.IEnumerator For index As Integer = 0 To puzzle.Length - 1 If (puzzle(index).Keys.Count = 1) Then en = puzzle(index).Keys.GetEnumerator en.MoveNext() System.Console.Write(en.Current.ToString & " ") ElseIf (puzzle(index).Keys.Count = 0) Then System.Console.Write("! ") Else System.Console.Write("* ") End If If ((index + 1) Mod 9 = 0) Then System.Console.WriteLine("") End If Next End Sub Private Function check(ByVal puzzle() As Hashtable) As Integer Dim result As Integer = CORRECT For index As Integer = 0 To puzzle.Length - 1 If (puzzle(index).Keys.Count > 1) Then result = MULTIPLE_VALUES ElseIf (puzzle(index).Keys.Count = 0) Then Return INCORRECT End If Next Return result End Function Private Function duplicate(ByVal puzzle() As Hashtable) As Hashtable() Dim ret(puzzle.Length - 1) As Hashtable For index As Integer = 0 To puzzle.Length - 1 ret(index) = New Hashtable For Each key As Integer In puzzle(index).Keys ret(index).Add(key, True) Next Next Return ret End Function Private lastGuessResult As Integer Private Function guess(ByVal puzzle() As Hashtable) As Hashtable() Dim en As System.Collections.IEnumerator ' DEBUG If (DEBUG) Then System.Console.WriteLine("BEFORE REDUCE:") printPuzzle(puzzle) System.Console.WriteLine("----") End If reduce(puzzle) ' DEBUG If (DEBUG) Then System.Console.WriteLine("AFTER REDUCE:") printPuzzle(puzzle) System.Console.WriteLine("----") End If ' If we don't have multiple values, return ' Immediately lastGuessResult = check(puzzle) If (lastGuessResult <> MULTIPLE_VALUES) Then Return puzzle End If ' There are more than one possible values ' Duplicate the puzzle Dim puzzleGuess() As Hashtable = duplicate(puzzle) ' Find an item that still has mutliple values Dim guessVals As System.Collections.ICollection Dim guessEnum As System.Collections.IEnumerator Dim guessVal As Integer For index As Integer = 0 To puzzleGuess.Length - 1 ' Without a sort, our guesses are in ' somewhat of a random order guessVals = puzzleGuess(index).Keys ' if we already know the correct value, ' don't make guesses. However, we want to keep ' testing if have made a guess at all If (guessVals.Count > 1) Then ' We break out of this loop through ' the use of return statements Do guessVals = puzzleGuess(index).Keys guessEnum = guessVals.GetEnumerator guessEnum.MoveNext() guessVal = Integer.Parse(guessEnum.Current.ToString) If (DEBUG) Then System.Console.WriteLine("Testing guess " & guessVal & " at " & index) End If puzzleGuess(index) = New Hashtable puzzleGuess(index).Add(guessVal, True) ' Recurse with the guess puzzleGuess = guess(puzzleGuess) If (lastGuessResult = CORRECT) Then Return puzzleGuess End If ' We should never get this result value from ' guess. While check can return MULTIPLE_VALUES ' guess can only reutrn CORRECT AND INCORRECT If (lastGuessResult = MULTIPLE_VALUES) Then Throw New Exception("Logical error is guess routine.") End If ' guess returned with INCORRECT ' reset puzzle without the ' value we just tested If (DEBUG) Then System.Console.WriteLine("Deleting " & guessVal & " at " & index) End If puzzle(index).Remove(guessVal) If (puzzle(index).Keys.Count = 0) Then ' We have tested everything in the index. ' The previous guess is not correct or ' the puzzle is insolvable. If (DEBUG) Then System.Console.WriteLine("No valid values at " & index) End If lastGuessResult = INCORRECT Return puzzle End If If (DEBUG) Then System.Console.Write("Remaining values at index:") For Each k As Object In puzzle(index).Keys System.Console.Write(" " & k.ToString) Next System.Console.WriteLine() End If puzzleGuess = duplicate(puzzle) Loop End If Next ' We really shouldn't reach this point. ' With recursion, every case should be covered above. lastGuessResult = INCORRECT Return puzzle End Function Sub Main() ' Create a global neighbor map. constructNeighborMap() ' Read in the puzzle from STDIN Dim puzzle() As Hashtable Try puzzle = readPuzzle() Catch e As Exception System.Console.WriteLine(e.ToString) Return End Try ' Find solution puzzle = guess(puzzle) If (lastGuessResult = INCORRECT) Then System.Console.WriteLine("Puzzle cannot be solved") End If ' Dump the puzzle printPuzzle(puzzle) End Sub End Module