Today I stumbled on an program I had written years ago. During a hot summer I used to spend my time solving Sudoku puzzles at the beach - which is quite fun if you are in a must-not-work mode. Of course, very soon I found myself on my laptop, writing a program for creating and solving Sudoku puzzles. The algorithm for the creation of new puzzles is interesting, although probably not the most efficient, and maybe someone else has thought it before me. In any case, I am sharing:
Algorithm description
Instead of using a brute-force method, it is possible to modify an existing solved Sudoku puzzle so that it remains valid. It turns out that any cell can be swapped with another one (in the same 3 x 3 matrix, of course), as long as the corresponding modifications are made along their rows or columns.
Any valid configuration can be used as seed (i.e. initial puzzle). For instance, we may want to use this one:
1 2 3 | 4 5 6 | 7 8 9
4 5 6 | 7 8 9 | 1 2 3
7 8 9 | 1 2 3 | 4 5 6
-----------------------
3 1 2 | 6 4 5 | 9 7 8
6 4 5 | 9 7 8 | 3 1 2
9 7 8 | 3 1 2 | 6 4 5
-----------------------
2 3 1 | 5 6 4 | 8 9 7
5 6 4 | 8 9 7 | 2 3 1
8 9 7 | 2 3 1 | 5 6 4
Suppose we want to swap the top-left cell ("1") with the one below it ("4"):
4 2 3 | 4 5 6 | 7 8 9
1 5 6 | 7 8 9 | 1 2 3
7 8 9 | 1 2 3 | 4 5 6
-----------------------
3 1 2 | 6 4 5 | 9 7 8
6 4 5 | 9 7 8 | 3 1 2
9 7 8 | 3 1 2 | 6 4 5
-----------------------
2 3 1 | 5 6 4 | 8 9 7
5 6 4 | 8 9 7 | 2 3 1
8 9 7 | 2 3 1 | 5 6 4
The new puzzle is invalid. For instance, there are two fours ("4") in the first row. We locate the other instance of "4" in the first row, and swap it with its counterpart in the second row:
4 2 3 | 7 5 6 | 7 8 9
1 5 6 | 4 8 9 | 1 2 3
7 8 9 | 1 2 3 | 4 5 6
-----------------------
3 1 2 | 6 4 5 | 9 7 8
6 4 5 | 9 7 8 | 3 1 2
9 7 8 | 3 1 2 | 6 4 5
-----------------------
2 3 1 | 5 6 4 | 8 9 7
5 6 4 | 8 9 7 | 2 3 1
8 9 7 | 2 3 1 | 5 6 4
We fixed the "4"'s, but now there are two "7"'s in the first row. We locate the other instance of "7" in the first row, which is located in the seventh column, and swap it with its counterpart in the second row:
4 2 3 | 7 5 6 | 1 8 9
1 5 6 | 4 8 9 | 7 2 3
7 8 9 | 1 2 3 | 4 5 6
-----------------------
3 1 2 | 6 4 5 | 9 7 8
6 4 5 | 9 7 8 | 3 1 2
9 7 8 | 3 1 2 | 6 4 5
-----------------------
2 3 1 | 5 6 4 | 8 9 7
5 6 4 | 8 9 7 | 2 3 1
8 9 7 | 2 3 1 | 5 6 4
It turns out that this counterpart ("1") is the same as the cell we originally swapped. This is the termination criterion, as the current state is a valid Sudoku puzzle.
Here the vb.net code:
Option Strict On
Option Explicit On
Option Infer Off
Imports System
''' <summary>
''' Sudoku grid generator using the cycle-swap algorithm described by
''' A. Charalampakis: pick a cell, swap it with another cell in the same
''' block along a row or column, then repair the resulting conflicts by
''' following the swap cycle until it closes. Every intermediate grid is
''' invalid; the grid is valid again exactly when the cycle closes.
'''
''' Produces a *solved* grid. Carving clues out of it (and checking that
''' the puzzle has a unique solution) is a separate step.
''' </summary>
Public Module SudokuGenerator
' Not thread-safe. On .NET 6+ use Random.Shared instead.
Private ReadOnly Rng As New Random()
' Any valid solution works as a seed.
Private ReadOnly SeedGrid As Integer(,) = New Integer(,) {
{1, 2, 3, 4, 5, 6, 7, 8, 9},
{4, 5, 6, 7, 8, 9, 1, 2, 3},
{7, 8, 9, 1, 2, 3, 4, 5, 6},
{3, 1, 2, 6, 4, 5, 9, 7, 8},
{6, 4, 5, 9, 7, 8, 3, 1, 2},
{9, 7, 8, 3, 1, 2, 6, 4, 5},
{2, 3, 1, 5, 6, 4, 8, 9, 7},
{5, 6, 4, 8, 9, 7, 2, 3, 1},
{8, 9, 7, 2, 3, 1, 5, 6, 4}
}
''' <summary>
''' Returns a new valid, fully solved 9x9 grid (0-based indices, values 1-9).
''' </summary>
''' <param name="passes">
''' How many times every cell is visited. 5 gives plenty of mixing;
''' 2 is already hard to distinguish from 5 statistically.
''' </param>
Public Function CreateSolvedGrid(Optional ByVal passes As Integer = 5) As Integer(,)
If passes < 1 Then Throw New ArgumentOutOfRangeException(NameOf(passes))
Dim grid As Integer(,) = DirectCast(SeedGrid.Clone(), Integer(,))
Dim order(80) As Integer
For i As Integer = 0 To 80
order(i) = i
Next
For pass As Integer = 1 To passes
Shuffle(order)
For Each index As Integer In order
Dim row As Integer = index \ 9
Dim col As Integer = index Mod 9
If Rng.Next(2) = 0 Then
CycleSwapAcrossColumns(grid, row, col, OtherIndexInBlock(col))
Else
CycleSwapAcrossRows(grid, row, OtherIndexInBlock(row), col)
End If
Next
Next
Return ApplySymmetries(grid)
End Function
''' <summary>
''' Swaps cells between two columns of the same stack, walking down the
''' swap cycle row by row until the value that left the first column
''' comes back to it.
''' </summary>
Private Sub CycleSwapAcrossColumns(ByVal grid As Integer(,), ByVal row As Integer,
ByVal colA As Integer, ByVal colB As Integer)
Dim target As Integer = grid(row, colA)
Dim r As Integer = row
Do
Dim moved As Integer = grid(r, colB)
grid(r, colB) = grid(r, colA)
grid(r, colA) = moved
If moved = target Then Exit Do
r = FindInColumn(grid, colA, moved, r)
Loop
End Sub
''' <summary>Mirror image of <see cref="CycleSwapAcrossColumns"/>.</summary>
Private Sub CycleSwapAcrossRows(ByVal grid As Integer(,), ByVal rowA As Integer,
ByVal rowB As Integer, ByVal col As Integer)
Dim target As Integer = grid(rowA, col)
Dim c As Integer = col
Do
Dim moved As Integer = grid(rowB, c)
grid(rowB, c) = grid(rowA, c)
grid(rowA, c) = moved
If moved = target Then Exit Do
c = FindInRow(grid, rowA, moved, c)
Loop
End Sub
Private Function FindInColumn(ByVal grid As Integer(,), ByVal col As Integer,
ByVal value As Integer, ByVal excludeRow As Integer) As Integer
For r As Integer = 0 To 8
If r <> excludeRow AndAlso grid(r, col) = value Then Return r
Next
Throw New InvalidOperationException("Seed grid is not a valid Sudoku solution.")
End Function
Private Function FindInRow(ByVal grid As Integer(,), ByVal row As Integer,
ByVal value As Integer, ByVal excludeCol As Integer) As Integer
For c As Integer = 0 To 8
If c <> excludeCol AndAlso grid(row, c) = value Then Return c
Next
Throw New InvalidOperationException("Seed grid is not a valid Sudoku solution.")
End Function
''' <summary>
''' Picks one of the other two indices in the same block of three,
''' with equal probability. Replaces the original Select Case ladder.
''' </summary>
Private Function OtherIndexInBlock(ByVal index As Integer) As Integer
Dim blockStart As Integer = index - (index Mod 3)
Return blockStart + ((index - blockStart + Rng.Next(1, 3)) Mod 3)
End Function
''' <summary>
''' Cheap extra diversity: relabel the digits, permute rows within bands
''' and bands among themselves (same for columns), optionally transpose.
''' All of these preserve validity by construction.
''' </summary>
Private Function ApplySymmetries(ByVal grid As Integer(,)) As Integer(,)
Dim labels(8) As Integer
For i As Integer = 0 To 8
labels(i) = i + 1
Next
Shuffle(labels)
Dim rowOrder As Integer() = BlockwisePermutation()
Dim colOrder As Integer() = BlockwisePermutation()
Dim transpose As Boolean = (Rng.Next(2) = 0)
Dim result(8, 8) As Integer
For r As Integer = 0 To 8
For c As Integer = 0 To 8
Dim value As Integer = labels(grid(rowOrder(r), colOrder(c)) - 1)
If transpose Then
result(c, r) = value
Else
result(r, c) = value
End If
Next
Next
Return result
End Function
Private Function BlockwisePermutation() As Integer()
Dim blocks As Integer() = {0, 1, 2}
Shuffle(blocks)
Dim result(8) As Integer
Dim k As Integer = 0
For Each block As Integer In blocks
Dim inner As Integer() = {0, 1, 2}
Shuffle(inner)
For Each offset As Integer In inner
result(k) = block * 3 + offset
k += 1
Next
Next
Return result
End Function
''' <summary>Unbiased Fisher-Yates shuffle, in place.</summary>
Private Sub Shuffle(ByVal items As Integer())
For i As Integer = items.Length - 1 To 1 Step -1
Dim j As Integer = Rng.Next(i + 1)
Dim temp As Integer = items(i)
items(i) = items(j)
items(j) = temp
Next
End Sub
''' <summary>Sanity check: every row, column and box holds 1-9 exactly once.</summary>
Public Function IsValidSolution(ByVal grid As Integer(,)) As Boolean
If grid Is Nothing Then Return False
If grid.GetLength(0) <> 9 OrElse grid.GetLength(1) <> 9 Then Return False
Const Full As Integer = &H3FE ' bits 1..9 set
For i As Integer = 0 To 8
Dim rowMask As Integer = 0
Dim colMask As Integer = 0
Dim boxMask As Integer = 0
Dim boxRow As Integer = (i \ 3) * 3
Dim boxCol As Integer = (i Mod 3) * 3
For j As Integer = 0 To 8
Dim a As Integer = grid(i, j)
Dim b As Integer = grid(j, i)
Dim d As Integer = grid(boxRow + (j \ 3), boxCol + (j Mod 3))
If a < 1 OrElse a > 9 OrElse b < 1 OrElse b > 9 OrElse d < 1 OrElse d > 9 Then Return False
rowMask = rowMask Or (1 << a)
colMask = colMask Or (1 << b)
boxMask = boxMask Or (1 << d)
Next
If rowMask <> Full OrElse colMask <> Full OrElse boxMask <> Full Then Return False
Next
Return True
End Function
''' <summary>Formats a grid for display, with block separators.</summary>
Public Function ToText(ByVal grid As Integer(,)) As String
Dim sb As New Text.StringBuilder()
For r As Integer = 0 To 8
If r > 0 AndAlso r Mod 3 = 0 Then sb.AppendLine("------+-------+------")
For c As Integer = 0 To 8
If c > 0 AndAlso c Mod 3 = 0 Then sb.Append(" | ")
sb.Append(grid(r, c).ToString())
If c < 8 AndAlso (c + 1) Mod 3 <> 0 Then sb.Append(" "c)
Next
sb.AppendLine()
Next
Return sb.ToString()
End Function
End Module