Oh hey! This recursive Solver from JB forum kicks butt!
'Sudoku Recursive Solve Experiment.bas for JB v2.0 b 2018-01-21 (B+=MGA)
' ============================================= check out
' Sukoku solver program
' version 2
' resolve sub written by cassiope01 on 18 Nov 2011
' modified very slightly by TyCamden on 19 Nov 2011
' modified more by me for testing code here
' === >>> works way way way better than my starter!
' It is very much like the JS code I was looking at.
global level
dim grid(8, 8), copy(8, 8), copy2(8, 8)
'3 puzzles to read through data easy, very hard and Intermediate with unique solutions
lastPuzzle = 3
while 1
scan
puzzle = puzzle + 1
if puzzle <= lastPuzzle then 'read in puzzle
read puzzleSource$
for row = 0 to 8
for col = 0 to 8
read digit
grid(col, row) = digit
copy2(col, row) = digit
next
next
else 'make up a puzzle now!
cls
call cp 5, "*** Puzzle Maker for Sudoku ***"
call cp 7, "To begin, please enter a level of difficulty."
call cp 9, "A level of 1 will hide 1 cell in every box,"
call cp 10, "4 will hide 4 in every box."
call cp 12, "Levels 1 to 3 are good for developing"
call cp 13, "'flash card' automatic skills."
call cp 15, "Levels 4, 5 and 6 are easy standard for:"
call cp 16, "beginner, intermediate, and difficult puzzles."
call cp 18, "Enter a level 0 to 9, any other to quits. "
locate 40, 19 : input " "; quit$
if quit$ <> "" then
if instr("0123456789", quit$) then level = val(quit$) else print : print space$(35);"Goodbye!" : end
else
print : print space$(35);"Goodbye!" : end
end if
puzzleSource$ = "Puzzle #";puzzle;" provided hot off the press by bplus code for puzzle making!."
call makeGrid
call hideCells
call copyGrid2
end if
'attempt to solve and test results independent of resolve
call resolve
s$ = "An independent test of the grid() array reports it "
if solved() then s$ = s$;"solved!" else s$ = s$;"NOT solved."
'report
cls
print puzzleSource$
for row = 0 to 8 'how far did we get?
for col = 0 to 8
locate col * 3 + 1, row + 3 : print right$(" ";copy2(col, row), 3);
locate col * 3 + 30, row + 3 : print right$(" ";grid(col, row), 3);
next
print
next
print : print s$
print : input "Press enter for next puzzle."; LookSee$
wend
' Puzzle Making ===================
function loadBox(n, box)
'this one uses aok function to help load boxes
xoff = 3 * (box mod 3) : yoff = 3 * int(box / 3)
'make a list of free cells in cellblock
dim list(8)
for y = 0 to 2 'make list of cells available
for x = 0 to 2 'find open cell in cellBlock first
if aok(n, xoff + x, yoff + y) then available = available + 1 : list(3 * y + x) = 1
next
next
if available = 0 then exit function
dim cell(available) : pointer = 1
for i = 0 to 8
if list(i) then cell(pointer) = i : pointer = pointer + 1
next
'OK our list has cells available to load, pick one randomly
if available > 1 then 'shuffle cells
for i = available to 2 step -1
r = int(rnd(0) * i) + 1
t = cell(i) : cell(i) = cell(r) : cell(r) = t
next
end if
'load the first one listed
grid(xoff + (cell(1) mod 3), yoff + int(cell(1) / 3)) = n
loadBox = 1 ' we are golden
end function
sub copyGrid
for r = 0 to 8
for c = 0 to 8
copy(r, c) = grid(r, c)
next
next
end sub
sub copyCopy
for r = 0 to 8
for c = 0 to 8
grid(r, c) = copy(r, c)
next
next
end sub
sub copyGrid2
for r = 0 to 8
for c = 0 to 8
copy2(r, c) = grid(r, c)
next
next
end sub
sub makeGrid
'this version requires the assistance of LoadBox function and subs copyGrid, copyCopy
do
redim grid(8, 8) : startOver = 0
for n = 1 to 9
call copyGrid
cnt = 0
do
for box = 0 to 8
success = loadBox(n, box)
if success = 0 then
cnt = cnt + 1
if cnt >= 20 then startOver = 1 : exit for
call copyCopy
exit for
end if
next
if startOver then exit do
loop until success
if startOver then exit for
next
loop until startOver = 0
end sub
sub hideCells
for box = 0 to 8
scan
cBase = (box mod 3) * 3
rBase = int(box / 3) * 3
dx = int(rnd(0) * 2) + 1 : dy = int(rnd(0) * 2) + 1
if rnd(0) < .5 then dm = -1 else dm = 1
bx = int(rnd(0) * 3) : by = int(rnd(0) * 3)
for m = 0 to level - 1
scan
grid(cBase + ((bx + m * dx) mod 3) , rBase + (by + m * dy + int(m/3) * dm) mod 3) = 0
next
next
end sub
' the following sub is reused over and over, making a grid and solving one and checking player's choices
' It is even used in the recursive sub written by cassiope01 on 18 Nov 2011
function aok(a, c, r) 'check to see if a is OK to place at (c, r)
if grid(c, r) = 0 then 'check cell empty
for i = 0 to 8 'check row and column for n
if abs(grid(i, r)) = a or abs(grid(c, i)) = a then exit function
next
cbase = c - c mod 3 : rbase = r - r mod 3 'check box for n
for rr = 0 to 2
for cc = 0 to 2
if abs(grid(cbase + cc, rbase + rr)) = a then exit function
next
next
aok = 1 'otherwise function will return 0 on exit
end if
end function
' = WOW this would be sweet if it works!
'change cell() to grid(), 0 to 8 not 1 to 9 for cells in grid()
'use aok() function in place of ok() as it does the same thing without string processing
sub resolve
for yy = 0 to 8
for xx = 0 to 8
scan 'added scan
if grid(xx,yy) = 0 then
for nb = 1 to 9
if aok(nb,xx,yy) then
nbre.tamp = grid(xx,yy)
grid(xx,yy) = nb
call resolve
scan
if grille.finie() then exit sub
grid(xx,yy) = nbre.tamp
end if
next
exit sub
end if
next
next
end sub
Function grille.finie() 'grid finished ?
grille.finie = 1
for yy = 0 to 8
for xx = 0 to 8
if grid(xx,yy) = 0 then
grille.finie = 0 :exit function
end if
next
next
end function
' check a grid is playable (or solved), independent check
function solved()
solved = 0 'n must be found in every column, row and 3x3 cell
for n = 1 to 9
'check columns for n
for col = 0 to 8
found = 0
for row = 0 to 8
if abs(grid(col, row)) = n then found = 1: exit for
next
if found = 0 then exit function
next
'check rows for n
for row = 0 to 8
found = 0
for col = 0 to 8
if abs(grid(col, row)) = n then found = 1: exit for
next
if found = 0 then exit function
next
'check 3x3 cells for n
for cell = 0 to 8
cellcol = cell mod 3
cellrow = int(cell / 3)
found = 0
for col = 0 to 2
for row = 0 to 2
if abs(grid(cellcol * 3 + col, cellrow * 3 + row)) = n then found = 1: exit for
next
if found = 1 then exit for
next
if found = 0 then exit function
next
next
solved = 1
end function
sub cp row, ps$
locate (80-len(ps$))/2, row : print ps$
end sub
data "puzzle test 1 from Sudoku.org.uk tutorial in JS using recursive technique"
' (which I couldn't get a proper translation to work!)
data 0, 0, 0, 7, 0, 8, 0, 3, 0
data 0, 0, 0, 2, 4, 0, 9, 1, 0
data 0, 0, 4, 0, 9, 0, 0, 7, 8
data 4, 0, 0, 3, 5, 0, 0, 0, 2
data 0, 0, 2, 1, 6, 4, 7, 0, 0
data 9, 0, 0, 0, 0, 0, 3, 0, 0
data 6, 4, 9, 0, 0, 1, 0, 2, 3
data 0, 0, 0, 9, 0, 0, 5, 0, 0
data 3, 7, 0, 0, 8, 0, 0, 0, 1
data "puzzle test 2 from PD 2018-01-19 Level 4 (Most difficult!)"
' OK THAT WAS TOO HARD! not a single cell resolved!
data 0, 9, 0, 4, 0, 2, 0, 0, 0
data 0, 4, 0, 0, 9, 0, 2, 0, 0
data 0, 3, 0, 0, 0, 8, 0, 7, 4
data 0, 0, 8, 0, 6, 0, 0, 0, 0
data 2, 0, 0, 9, 0, 1, 0, 0, 8
data 0, 0, 0, 0, 0, 0, 6, 0, 0
data 3, 7, 0, 8, 0, 0, 0, 2, 0
data 0, 0, 6, 0, 3, 0, 0, 8, 0
data 0, 0, 0, 5, 0, 9, 0, 3, 0
data "puzzle test 3 from PD 2018-01-18 Level Intermediate"
' well solver didn't get too far with that one either, but got a couple...
data 0, 0, 0, 0, 8, 0, 0, 0, 0
data 9, 5, 1, 0, 0, 0, 6, 0, 0
data 0, 0, 7, 5, 4, 0, 0, 9, 0
data 0, 0, 0, 0, 0, 0, 0, 2, 0
data 0, 0, 0, 0, 5, 4, 7, 0, 0
data 0, 9, 0, 2, 0, 0, 0, 0, 3
data 0, 0, 0, 0, 0, 0, 4, 8, 0
data 3, 0, 0, 0, 0, 0, 0, 0, 2
data 4, 0, 0, 7, 9, 0, 5, 0, 0
The less the clues the faster it "solves" or resolves the puzzle board.
Here is snap of the hardest puzzle I have recorded in data:
Update: Does not work well in SmallBASIC, stack overload errors after a certain level of recursion, QB64 solves puzzles instantly with it!
