I have successfully produced a Sudoku Solver in VB.NET using the backtracking method, and I want to be able to produce a Sudoku grid from this point that is humanly solvable with the numbers left behind alone. How do I produce a grid which will 100% of the time produce a grid that can be solved by a human and the numbers alone, with no guessing?
The grids algorithm is as follows:
- Draw grid
- Enter random numbers between 1 and 9 in a few random cells
- Solve the grid from these inputted numbers
- Create a grid from this solved grid that can be played by the user by emptying certain cells
I have tried just randomly removing numbers in random cells but this always produces an unsolvable (with the numbers and logic alone) grid.
Code:
<pre>Public Class Form1
Class sudoku_textbox
Inherits TextBox
Protected Overrides Sub OnKeyPress(e As KeyPressEventArgs)
If Char.IsDigit(e.KeyChar) Or e.KeyChar = " " Or e.KeyChar = ControlChars.Back Then
e.Handled = False
Else
e.Handled = True
End If
If e.KeyChar = "0" Then
e.KeyChar = ControlChars.Back
End If
End Sub
End Class
Dim cell(0 To 8, 0 To 8) As sudoku_textbox
Dim grid(0 To 8, 0 To 8) As String
Dim backtracking As Boolean = False
Dim RandomClass As New Random()
Dim RandomNumber As Integer
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
Dim xxtra As Integer
Dim yxtra As Integer
Dim limit As Integer = 0
For x As Integer = 0 To 8
For y As Integer = 0 To 8
cell(x, y) = New sudoku_textbox
cell(x, y).Text = ""
cell(x, y).Width = 20
cell(x, y).Height = 20
cell(x, y).MaxLength = 1
cell(x, y).TextAlign = HorizontalAlignment.Center
xxtra = 0
yxtra = 0
If x > 2 Then
xxtra = 4
End If
If x > 5 Then
xxtra = 8
End If
If y > 2 Then
yxtra = 4
End If
If y > 5 Then
yxtra = 8
End If
cell(x, y).Location = New Point(45 + x * 20 + xxtra, 15 + y * 20 + yxtra)
Me.Controls.Add(cell(x, y))
AddHandler cell(x, y).TextChanged, AddressOf cell_changed
Next
Next
For x As Integer = 0 To 8
For y As Integer = 0 To 8
RandomNumber = RandomClass.Next(1, 100)
If (RandomNumber < 10) And limit < 16 Then
cell(x, y).Text = RandomNumber
limit += 1
End If
If cell(x, y).ForeColor = Color.Red Then
cell(x, y).Text = ""
End If
Next
Next
BackTrackFunc()
CreatePuzzleFunc()
End Sub
Function BackTrackFunc()
backtracking = True
For x As Integer = 0 To 8
For y As Integer = 0 To 8
grid(x, y) = cell(x, y).Text
Next
Next
BackTrack(0, 0)
For x = 0 To 8
For y = 0 To 8
cell(x, y).Text = grid(x, y)
Next
Next
backtracking = False
End Function
Private Sub cell_changed()
If backtracking Then Return
For x As Integer = 0 To 8
For y As Integer = 0 To 8
grid(x, y) = cell(x, y).Text
cell(x, y).ForeColor = Color.Black
Next
Next
For x As Integer = 0 To 8
For y As Integer = 0 To 8
If check_rows(x, y) Then
If check_columns(x, y) Then
If Not check_box(x, y) Then
cell(x, y).ForeColor = Color.Red
End If
Else
cell(x, y).ForeColor = Color.Red
End If
Else
cell(x, y).ForeColor = Color.Red
End If
Next
Next
End Sub
Function check_rows(ByVal xSender, ByVal ySender) As Boolean
Dim noClash As Boolean = True
For x As Integer = 0 To 8
If grid(x, ySender) <> "" Then
If x <> xSender Then
If grid(x, ySender) = grid(xSender, ySender) Then
noClash = False
End If
End If
End If
Next
Return noClash
End Function
Function check_columns(ByVal xSender, ByVal ySender) As Boolean
Dim noClash As Boolean = True
For y As Integer = 0 To 8
If grid(xSender, y) <> "" Then
If y <> ySender Then
If grid(xSender, y) = grid(xSender, ySender) Then
noClash = False
End If
End If
End If
Next
Return noClash
End Function
Function check_box(ByVal xSender, ByVal ySender) As Boolean
Dim noClash As Boolean = True
Dim xStart As Integer
Dim yStart As Integer
If xSender < 3 Then
xStart = 0
ElseIf xSender < 6 Then
xStart = 3
Else
xStart = 6
End If
If ySender < 3 Then
yStart = 0
ElseIf ySender < 6 Then
yStart = 3
Else
yStart = 6
End If
For y As Integer = yStart To (yStart + 2)
For x As Integer = xStart To (xStart + 2)
If grid(x, y) <> "" Then
If Not (x = xSender And y = ySender) Then
If grid(x, y) = grid(xSender, ySender) Then
noClash = False
End If
End If
End If
Next
Next
Return noClash
End Function
Private Sub checkButton_Click(sender As Object, e As EventArgs) Handles checkButton.Click
Dim noRed As Boolean = True
For x As Integer = 0 To 8
For y As Integer = 0 To 8
If cell(x, y).ForeColor = Color.Red Or cell(x, y).Text = "" Then
noRed = False
End If
Next
Next
If noRed = True Then
MessageBox.Show("Well Done! You have completed the Sudoku successfully")
Else
MessageBox.Show("You have not completed the Sudoku successfully")
End If
End Sub
Function BackTrack(ByVal x As Integer, ByVal y As Integer) As Boolean
Dim number As Integer = 1
If grid(x, y) = "" Then
Do
grid(x, y) = CStr(number)
If check_rows(x, y) Then
If check_columns(x, y) Then
If check_box(x, y) Then
y = y + 1
If y = 9 Then
y = 0
x = x + 1
If x = 9 Then Return True
End If
If BackTrack(x, y) Then Return True
y = y - 1
If y < 0 Then
y = 8
x = x - 1
End If
End If
End If
End If
number += 1
Loop Until number = 10
grid(x, y) = ""
Return False
Else
y = y + 1
If y = 9 Then
y = 0
x = x + 1
If x = 9 Then Return True
End If
Return BackTrack(x, y)
End If
End Function
Function CreatePuzzleFunc()
End Function
End Class
Submit an article or tip