Sudoku - generating a puzzle

[JuggaloBrotha]

I'm a little stuck. I have a class that I'll be using to generate an entire sudoku puzzle in which right now it's almost completely working, it'll generate a board but there's always an error with it (usually 2 to 10 cells will still have a zero in it because there isn't an available number to be filled in)

Currently here's what I'm doing: I have a 9x9 array of type Integer and I have a 9x9 array of type List(Of Integer) and each element in the list array has the numbers 1 through 9. To fill the 9x9 Integer array I simply start with position 0,0 and work to 8,8 randomly picking a number from the List then a sub will go through and remove that number from the current column, the current row and the current mini-grid.

This is why there's random cells that still have a 0 (zero) in them, it's because there isn't a number available for that cell because of the cells that came before it and this is where I'm stuck.

Here's the code:

Option Explicit On
Option Strict On

Friend Class SudokuBoard

    Private WithEvents bw As New System.ComponentModel.BackgroundWorker
    Private m_TheBoard(8I, 8I) As Integer
    Private m_Numbers(8, 8) As List(Of Integer)

    Friend Event BoardGenerated(ByVal TheBoard(,) As Integer)

#Region " Constructors "
    Friend Sub New()
        Me.GenerateBoard()
    End Sub
#End Region
#Region " GenerateBoard "
    Friend Sub GenerateBoard()
        Call Me.ClearBoard()
        Me.bw.RunWorkerAsync()
    End Sub

    Private Sub bw_DoWork(ByVal sender As Object, ByVal e As System.ComponentModel.DoWorkEventArgs) Handles bw.DoWork
        Dim Rand As New Random
        'Dim Index As Integer

        For x As Integer = 0I To 8I
            For y As Integer = 0I To 8I
                m_Numbers(x, y) = New List(Of Integer)
                m_Numbers(x, y).AddRange(New Integer() {1, 2, 3, 4, 5, 6, 7, 8, 9})
            Next y
        Next x

        For x As Integer = 0I To 8I
            For y As Integer = 0I To 8I
                Select Case m_Numbers(x, y).Count
                    Case 0
                        'No available numbers
                    Case 1
                        'Try
                        m_TheBoard(x, y) = m_Numbers(x, y)(0I)
                        'Catch
                        'End Try
                    Case Is > 1
                        'Try
                        'Index = Rand.Next(0I, m_Numbers(x, y).Count)
                        m_TheBoard(x, y) = m_Numbers(x, y)(Rand.Next(0I, m_Numbers(x, y).Count))
                        'Catch
                        'End Try
                End Select
                RemoveUsedValue(x, y)
            Next y
        Next x
    End Sub

    Private Sub bw_RunWorkerCompleted(ByVal sender As Object, ByVal e As System.ComponentModel.RunWorkerCompletedEventArgs) Handles bw.RunWorkerCompleted
        Dim Copy(8, 8) As Integer
        For x As Integer = 0I To 8I
            For y As Integer = 0I To 8I
                Copy(x, y) = m_TheBoard(x, y)
            Next y
        Next x
        RaiseEvent BoardGenerated(Copy)
    End Sub
#End Region
#Region " Friend Methods "
    Friend Sub ClearBoard()
        For x As Integer = 0I To 8I
            For y As Integer = 0I To 8I
                Me.SetNumber(x, y)
            Next y
        Next x
    End Sub

    Friend Sub SetNumber(ByVal Row As Integer, ByVal Col As Integer)
        m_TheBoard(Row, Col) = 0I
    End Sub
#End Region
#Region " RemoveUsedValue "
    Private Sub RemoveUsedValue(ByVal Row As Integer, ByVal Col As Integer)
        Dim CurrNumber As Integer = m_TheBoard(Row, Col)
        For i As Integer = 0I To 8I
            m_Numbers(Row, i).Remove(CurrNumber)
        Next i
        For i As Integer = 0I To 8I
            m_Numbers(i, Col).Remove(CurrNumber)
        Next i
        Select Case Get3x3(Row, Col)
            Case "A1"
                'A1, A2, A3
                'B1, B2, B3
                'C1, C2, C3
                m_Numbers(0, 0).Remove(CurrNumber)
                m_Numbers(0, 1).Remove(CurrNumber)
                m_Numbers(0, 2).Remove(CurrNumber)
                m_Numbers(1, 0).Remove(CurrNumber)
                m_Numbers(1, 1).Remove(CurrNumber)
                m_Numbers(1, 2).Remove(CurrNumber)
                m_Numbers(2, 0).Remove(CurrNumber)
                m_Numbers(2, 1).Remove(CurrNumber)
                m_Numbers(2, 2).Remove(CurrNumber)
            Case "A2"
                'A4, A5, A6
                'B4, B5, B6
                'C4, C5, C6
                m_Numbers(0, 3).Remove(CurrNumber)
                m_Numbers(0, 4).Remove(CurrNumber)
                m_Numbers(0, 5).Remove(CurrNumber)
                m_Numbers(1, 3).Remove(CurrNumber)
                m_Numbers(1, 4).Remove(CurrNumber)
                m_Numbers(1, 5).Remove(CurrNumber)
                m_Numbers(2, 3).Remove(CurrNumber)
                m_Numbers(2, 4).Remove(CurrNumber)
                m_Numbers(2, 5).Remove(CurrNumber)
            Case "A3"
                'A7, A8, A9
                'B7, B8, B9
                'C7, C8, C9
                m_Numbers(0, 6).Remove(CurrNumber)
                m_Numbers(0, 7).Remove(CurrNumber)
                m_Numbers(0, 8).Remove(CurrNumber)
                m_Numbers(1, 6).Remove(CurrNumber)
                m_Numbers(1, 7).Remove(CurrNumber)
                m_Numbers(1, 8).Remove(CurrNumber)
                m_Numbers(2, 6).Remove(CurrNumber)
                m_Numbers(2, 7).Remove(CurrNumber)
                m_Numbers(2, 8).Remove(CurrNumber)
            Case "B1"
                'D1, D2, D3
                'E1, E2, E3
                'F1, F2, F3
                m_Numbers(3, 0).Remove(CurrNumber)
                m_Numbers(3, 1).Remove(CurrNumber)
                m_Numbers(3, 2).Remove(CurrNumber)
                m_Numbers(4, 0).Remove(CurrNumber)
                m_Numbers(4, 1).Remove(CurrNumber)
                m_Numbers(4, 2).Remove(CurrNumber)
                m_Numbers(5, 0).Remove(CurrNumber)
                m_Numbers(5, 1).Remove(CurrNumber)
                m_Numbers(5, 2).Remove(CurrNumber)
            Case "B2"
                'D4, D5, D6
                'E4, E5, E6
                'F4, F5, F6
                m_Numbers(3, 3).Remove(CurrNumber)
                m_Numbers(3, 4).Remove(CurrNumber)
                m_Numbers(3, 5).Remove(CurrNumber)
                m_Numbers(4, 3).Remove(CurrNumber)
                m_Numbers(4, 4).Remove(CurrNumber)
                m_Numbers(4, 5).Remove(CurrNumber)
                m_Numbers(5, 3).Remove(CurrNumber)
                m_Numbers(5, 4).Remove(CurrNumber)
                m_Numbers(5, 5).Remove(CurrNumber)
            Case "B3"
                'D7, D8, D9
                'E7, E8, E9
                'F7, F8, F9
                m_Numbers(3, 6).Remove(CurrNumber)
                m_Numbers(3, 7).Remove(CurrNumber)
                m_Numbers(3, 8).Remove(CurrNumber)
                m_Numbers(4, 6).Remove(CurrNumber)
                m_Numbers(4, 7).Remove(CurrNumber)
                m_Numbers(4, 8).Remove(CurrNumber)
                m_Numbers(5, 6).Remove(CurrNumber)
                m_Numbers(5, 7).Remove(CurrNumber)
                m_Numbers(5, 8).Remove(CurrNumber)
            Case "C1"
                'G1, G2, G3
                'H1, H2, H3
                'I1, I2, I3
                m_Numbers(6, 0).Remove(CurrNumber)
                m_Numbers(6, 1).Remove(CurrNumber)
                m_Numbers(6, 2).Remove(CurrNumber)
                m_Numbers(7, 0).Remove(CurrNumber)
                m_Numbers(7, 1).Remove(CurrNumber)
                m_Numbers(7, 2).Remove(CurrNumber)
                m_Numbers(8, 0).Remove(CurrNumber)
                m_Numbers(8, 1).Remove(CurrNumber)
                m_Numbers(8, 2).Remove(CurrNumber)
            Case "C2"
                'G4, G5, G6
                'H4, H5, H6
                'I4, I5, I6
                m_Numbers(6, 3).Remove(CurrNumber)
                m_Numbers(6, 4).Remove(CurrNumber)
                m_Numbers(6, 5).Remove(CurrNumber)
                m_Numbers(7, 3).Remove(CurrNumber)
                m_Numbers(7, 4).Remove(CurrNumber)
                m_Numbers(7, 5).Remove(CurrNumber)
                m_Numbers(8, 3).Remove(CurrNumber)
                m_Numbers(8, 4).Remove(CurrNumber)
                m_Numbers(8, 5).Remove(CurrNumber)
            Case "C3"
                'G7, G8, G9
                'h7, H8, H9
                'I7, I8, I9
                m_Numbers(6, 6).Remove(CurrNumber)
                m_Numbers(6, 7).Remove(CurrNumber)
                m_Numbers(6, 8).Remove(CurrNumber)
                m_Numbers(7, 6).Remove(CurrNumber)
                m_Numbers(7, 7).Remove(CurrNumber)
                m_Numbers(7, 8).Remove(CurrNumber)
                m_Numbers(8, 6).Remove(CurrNumber)
                m_Numbers(8, 7).Remove(CurrNumber)
                m_Numbers(8, 8).Remove(CurrNumber)
        End Select
    End Sub
#End Region
#Region " Get3x3 "
    Private Function Get3x3(ByVal x As Integer, ByVal y As Integer) As String
        Dim X_Val As Char, Y_Val As Integer
        Select Case x
            Case 0, 1, 2 : X_Val = "A"c
            Case 3, 4, 5 : X_Val = "B"c
            Case 6, 7, 8 : X_Val = "C"c
        End Select
        Select Case y
            Case 0, 1, 2 : Y_Val = 1
            Case 3, 4, 5 : Y_Val = 2
            Case 6, 7, 8 : Y_Val = 3
        End Select
        Return X_Val & Y_Val
    End Function
#End Region
End Class

 

[InertiaM]

in a month or so when i get the free time i may start to make one myself and if i can get the logic down i'll share it here

Posted on 11th August 2005 - blimey Juggalo, you HAVE been busy

Dont you just need to keep repeating GenerateBoard, until you dont have any 0s in the board? You've then got a valid Sudoku

    Private Sub bw_DoWork(ByVal sender As Object, ByVal e As System.ComponentModel.DoWorkEventArgs) Handles bw.DoWork
        Dim ValidSudoku As Boolean = False

        Do Until ValidSudoku = True

            'clear values
            For x As Integer = 0I To 8I
                For y As Integer = 0I To 8I
                    m_TheBoard(x, y) = 0I
                Next y
            Next x

            Dim Rand As New Random
            'Dim Index As Integer

            For x As Integer = 0I To 8I
                For y As Integer = 0I To 8I
                    m_Numbers(x, y) = New List(Of Integer)
                    m_Numbers(x, y).AddRange(New Integer() {1, 2, 3, 4, 5, 6, 7, 8, 9})
                Next y
            Next x

            For x As Integer = 0I To 8I
                For y As Integer = 0I To 8I
                    Select Case m_Numbers(x, y).Count
                        Case 0
                            'No available numbers
                        Case 1
                            'Try
                            m_TheBoard(x, y) = m_Numbers(x, y)(0I)
                            'Catch
                            'End Try
                        Case Is > 1
                            'Try
                            'Index = Rand.Next(0I, m_Numbers(x, y).Count)
                            m_TheBoard(x, y) = m_Numbers(x, y)(Rand.Next(0I, m_Numbers(x, y).Count))
                            'Catch
                            'End Try
                    End Select
                    RemoveUsedValue(x, y)
                Next y
            Next x


            'assume its a valid sudoku
            ValidSudoku = True

            'check values
            For i As Integer = 0 To 8
                For j As Integer = 0 To 8
                    If m_TheBoard(i, j) = 0I Then
                        ValidSudoku = False
                        Exit For
                    End If
                Next
            Next

        Loop

    End Sub

You may want to put in some logic to fail after a certain number of attempts if a valid Sudoku isnt found.

 

[InertiaM]

A slightly improved version

    Private Sub bw_DoWork(ByVal sender As Object, ByVal e As System.ComponentModel.DoWorkEventArgs) Handles bw.DoWork
        Dim ValidSudoku As Boolean = False

        Do Until ValidSudoku = True

            'clear values
            For x As Integer = 0I To 8I
                For y As Integer = 0I To 8I
                    m_TheBoard(x, y) = 0I
                Next y
            Next x

            Dim Rand As New Random
            'Dim Index As Integer

            For x As Integer = 0I To 8I
                For y As Integer = 0I To 8I
                    m_Numbers(x, y) = New List(Of Integer)
                    m_Numbers(x, y).AddRange(New Integer() {1, 2, 3, 4, 5, 6, 7, 8, 9})
                Next y
            Next x

            'assume its a valid sudoku
            ValidSudoku = True

            For x As Integer = 0I To 8I
                For y As Integer = 0I To 8I
                    Select Case m_Numbers(x, y).Count
                        Case 0
                            'No available numbers
                            ValidSudoku = False
                            Exit For
                        Case 1
                            'Try
                            m_TheBoard(x, y) = m_Numbers(x, y)(0I)
                            'Catch
                            'End Try
                        Case Is > 1
                            'Try
                            'Index = Rand.Next(0I, m_Numbers(x, y).Count)
                            m_TheBoard(x, y) = m_Numbers(x, y)(Rand.Next(0I, m_Numbers(x, y).Count))
                            'Catch
                            'End Try
                    End Select
                    RemoveUsedValue(x, y)
                Next y
            Next x

        Loop

    End Sub

 

[InertiaM]

This makes it a little faster

    Private Sub RemoveUsedValue(ByVal Row As Integer, ByVal Col As Integer)
        Dim CurrNumber As Integer = m_TheBoard(Row, Col)
        For i As Integer = Col To 8I
            m_Numbers(Row, i).Remove(CurrNumber)
        Next i
        For i As Integer = Row To 8I
            m_Numbers(i, Col).Remove(CurrNumber)
        Next i

        m_Numbers(((Row \ 3) * 3) + 0, ((Col \ 3) * 3) + 0).Remove(CurrNumber)
        m_Numbers(((Row \ 3) * 3) + 0, ((Col \ 3) * 3) + 1).Remove(CurrNumber)
        m_Numbers(((Row \ 3) * 3) + 0, ((Col \ 3) * 3) + 2).Remove(CurrNumber)
        m_Numbers(((Row \ 3) * 3) + 1, ((Col \ 3) * 3) + 0).Remove(CurrNumber)
        m_Numbers(((Row \ 3) * 3) + 1, ((Col \ 3) * 3) + 1).Remove(CurrNumber)
        m_Numbers(((Row \ 3) * 3) + 1, ((Col \ 3) * 3) + 2).Remove(CurrNumber)
        m_Numbers(((Row \ 3) * 3) + 2, ((Col \ 3) * 3) + 0).Remove(CurrNumber)
        m_Numbers(((Row \ 3) * 3) + 2, ((Col \ 3) * 3) + 1).Remove(CurrNumber)
        m_Numbers(((Row \ 3) * 3) + 2, ((Col \ 3) * 3) + 2).Remove(CurrNumber)

    End Sub

 

[JohnH]

Another performance tip is to check the whole board for each value to find which cell is most "needy", ie has least available numbers, and fill that first. Because apart from the basic row/column/section rules this cell is most limiting for any other cell for finding a valid solution in the end. Using such implementation I get average 1.5 attempts for each valid solution and only 2-3ms avg time generating it. (with usually hundreds of attempts and 15ms avg time with the above straight forward way). Example:

Function createFullboard() As Boolean
    reset()
    'try fill a board
    Dim fillcount As Integer = 0
    Do Until fillcount = 81
        'find cell with least available options
        Dim lowestAvailable As Integer = 10
        Dim cellref As Point = Point.Empty
        For x As Integer = 0 To 8
            For y As Integer = 0 To 8
                If Board(x, y) = 0 Then 'only include empty cells in search
                    Dim availCount As Integer = Numbers(x, y).Count
                    If availCount = 0 Then
                        Return False  'hit a dead end
                    ElseIf availCount < lowestAvailable Then
                        lowestAvailable = availCount
                        cellref = New Point(x, y)
                    End If
                End If
            Next
        Next
        'fill that cell           
        Dim available As List(Of Integer) = Numbers(cellref.X, cellref.Y)
        If available.Count = 1 Then
            Board(cellref.X, cellref.Y) = available(0)
        Else              
            Board(cellref.X, cellref.Y) = available(r.Next(0, available.Count))
        End If
        removeAvailable(cellref.X, cellref.Y)
        fillcount += 1            
    Loop
    Return True 'valid solution
End Function

createFullboard function must of course be called in loop until True (which happens on avg 1-2 calls).

Reset and removeAvailable and that stuff, like yours but pasted for reference:

Private r As New Random
Private Board(8, 8) As Integer
Private Numbers(8, 8) As List(Of Integer)

Private Sub reset()
    For x As Integer = 0 To 8
        For y As Integer = 0 To 8
            Numbers(x, y) = New List(Of Integer)
            Numbers(x, y).AddRange(New Integer() {1, 2, 3, 4, 5, 6, 7, 8, 9})
            Board(x, y) = 0
        Next y
    Next x
End Sub

Private Sub removeAvailable(ByVal x As Integer, ByVal y As Integer)
    Dim value As Integer = Board(x, y)
    'remove from column and row
    For xx As Integer = 0 To 8
        Numbers(xx, y).Remove(value)
    Next
    For yy As Integer = 0 To 8
        Numbers(x, yy).Remove(value)
    Next
    'remove from one of the 3x3 sections
    Dim xxx As Integer = x \ 3 * 3
    Dim yyy As Integer = y \ 3 * 3
    For xx As Integer = xxx To xxx + 2
        For yy As Integer = yyy To yyy + 2
            Numbers(xx, yy).Remove(value)
        Next
    Next
End Sub

Btw, the algorithm can also be used to brute force solve given puzzles. I gave it some tries and it usually solves normal level in 1-2 attempts and expert levels usually in 3-10 attempts.

 

[JuggaloBrotha]

Thanks for the tips guys. Yesterday I reached a point where I knew what the end result I wanted was but the current code I had simply wouldn't provide it, but I was at a loss as to where I should be changing the code.

And yes InertiaM, I have been very busy, the whole reason I started this game 2 days ago was because I ran into that thread on a search for something else.

 

[JuggaloBrotha]

This makes it a little faster

    Private Sub RemoveUsedValue(ByVal Row As Integer, ByVal Col As Integer)
        Dim CurrNumber As Integer = m_TheBoard(Row, Col)
        For i As Integer = Col To 8I
            m_Numbers(Row, i).Remove(CurrNumber)
        Next i
        For i As Integer = Row To 8I
            m_Numbers(i, Col).Remove(CurrNumber)
        Next i

        m_Numbers(((Row \ 3) * 3) + 0, ((Col \ 3) * 3) + 0).Remove(CurrNumber)
        m_Numbers(((Row \ 3) * 3) + 0, ((Col \ 3) * 3) + 1).Remove(CurrNumber)
        m_Numbers(((Row \ 3) * 3) + 0, ((Col \ 3) * 3) + 2).Remove(CurrNumber)
        m_Numbers(((Row \ 3) * 3) + 1, ((Col \ 3) * 3) + 0).Remove(CurrNumber)
        m_Numbers(((Row \ 3) * 3) + 1, ((Col \ 3) * 3) + 1).Remove(CurrNumber)
        m_Numbers(((Row \ 3) * 3) + 1, ((Col \ 3) * 3) + 2).Remove(CurrNumber)
        m_Numbers(((Row \ 3) * 3) + 2, ((Col \ 3) * 3) + 0).Remove(CurrNumber)
        m_Numbers(((Row \ 3) * 3) + 2, ((Col \ 3) * 3) + 1).Remove(CurrNumber)
        m_Numbers(((Row \ 3) * 3) + 2, ((Col \ 3) * 3) + 2).Remove(CurrNumber)

    End Sub

I'm just curious to why you're dividing row by 3 then multiplying it by 3 (you're also doing it for Col too)

mathematically this should be the same as what you've got:

        m_Numbers(Row, Col).Remove(CurrNumber)
        m_Numbers(Row, Col + 1).Remove(CurrNumber)
        m_Numbers(Row, Col + 2).Remove(CurrNumber)
        m_Numbers(Row + 1, Col).Remove(CurrNumber)
        m_Numbers(Row + 1, Col + 1).Remove(CurrNumber)
        m_Numbers(Row + 1, Col + 2).Remove(CurrNumber)
        m_Numbers(Row + 2, Col).Remove(CurrNumber)
        m_Numbers(Row + 2, Col + 1).Remove(CurrNumber)
        m_Numbers(Row + 2, Col + 2).Remove(CurrNumber)

 

[InertiaM]

"4 \ 3" is "4 div 3" which is 1

 

[JuggaloBrotha]

"4 \ 3" is "4 div 3" which is 1

SonofA.... I didn't even notice that it's integer division "\", I thought it was regular division "/" man I'm off my game today