Basicprogramming(.org) > General questions and discussions
Sudoku
Rick3137:
Nicely done. :) :) :)
B+:
Thanks Rick!
Here is a fully featured Sudoku App: game, solver and editor. Now make and save puzzles, save a game in progress and come back later to finish. Whatever you can do with mouse you can also do with keyboard and vice versa.
--- Code: ---' SB2 Sudoku Game Solver Editor.bas for SmallBASIC 0.12.11 (B+=MGA) 2018-01-20
' + A Solver that can do allot of logic to solve, but not all (yet!).
' + Puzzle and Make modes, Save and Load temp files, all editable: Temp Saved Puzzle.txt
' + Automatic save of solved puzzles: Temp Solved Puzzle.txt
' + Temp files created can be read and edited with Notepad
' Use OS file manager to save files long term under new names (and/or folders).
' + Anything you can do with mouse you can do with keyboard and vice versa.
' + ie 6 function Menu
'from: SB1 Sudoku Game.bas for SmallBASIC 0.12.11 (B+=MGA) 2018-01-17
' + more definitive levels of difficulty and design around them.
' + some edits of game posted 2018-01-17, better quit code with level
' + more debug code removed, whole sections rewritten.
'from: sudoku mod bplus.bas SmallBASIC 0.12.11 (B+=MGA) 2018-01-06
' add whole new makeGrid (maybe faster) and hideCells code (not so random)
'Sudoku Game from SB.bas SmallBASIC 0.12.9 (B+=MGA) 2018-01-04
' fix color at start so can see the grid!
' add solved function!!! and loop around when solved
' removed cell notes, to store in corners option
randomize
const TextSize = textwidth("9")
const CellSize = TextSize * 5
const xMinBoard = CellSize
const yMinBoard = CellSize
const xMaxBoard = xMinBoard + 9 * CellSize
const yMaxBoard = yMinBoard + 9 * CellSize
const xMidBoard = xMinBoard + (xMaxBoard - xMinBoard)/2
const yMidBoard = yMinBoard + (yMaxBoard - yMinBoard)/2
const xMinKeyPad = xMinBoard - .5 * CellSize
const xMaxKeyPad = xMinKeyPad + CellSize * 10
const yMinKeyPad = yMaxBoard + 10
const yMaxKeyPad = yMinKeyPad + CellSize
const screenWide = 11 * CellSize
const funcWide = screenWide / 6
const yMinFunc = yMaxKeyPad + CellSize
const yMaxFunc = yMinFunc + CellSize
'main loop sets up game puzzle,
'when solved it displays that fact and then sets up another puzzle
while 1
'globals
bx = 0 : by = 0 'current highlighted location on board
key = 1 'current key highlighted on keyPad, key = 0 clears cell
update = 1 'when to show game board
mode = "p" 'mode p for play, mode m for make puzzle
dim grid(8,8) '9 x 9 board
'0 value = cell blank, > 0 clues of puzzle, < 0 are guesses
getLevel 'level determines the number of cells removed from each box
makeGrid
hideCells
'game loop will continue to respond to mouse clicks until puzzle is solved
while solved() = 0
'cls screen display puzzle catch mouse and handle it
if update then showGrid
'handlekeypresses should have equivalent mouse actions!
k = inkey
if len(k) = 1 then
update = 1
if k = "h" then
hardSolve
elif k = "m" or k = "p"
mode = k
elif k = "m" then 'convert grid to all positive values
for rrow = 0 to 8
for ccol = 0 to 8
grid(ccol, rrow) = abs(grid(ccol, rrow))
next
next
elif k = "s"
savePZ(0)
elif k = "l"
loadPZ
elif instr("0123456789", k) then
handleNumber k
elif asc(k) = 27
cls : end
else
update = 0
end if
elseif len(k) = 2
update = 1
select case asc(right(k, 1))
case 9 : if by > 0 then by = by - 1 'up arrow
case 10 : if by < 8 then by = by + 1 'down arrow
case 4 : if bx > 0 then bx = bx - 1 'left arrow
case 5 : if bx < 8 then bx = bx + 1 'right arrow
case else : update = 0
end select
end if ' k was something
if pen(3) then ' caught a mouse down
mx = pen(4) : my = pen(5)
while pen(3) ' update position until release
mx = pen(4) : my = pen(5)
wend
'clicked inside Board
if xMinBoard <= mx and mx <= xMaxBoard and yMinBoard <= my and my <= yMaxBoard then
bx = int((mx - xMinBoard)/CellSize) : by = int((my-yMinBoard)/CellSize)
handleNumber key
fi
'clicked inside KeyPad
if xMinKeyPad <= mx and mx <= xMaxKeyPad and yMinKeyPad <= my and my <= yMaxKeyPad then
key = int((mx - xMinKeyPad) / CellSize)
update = 1
fi
'clicked inside Func menu: help solve, play mode, make mode, save file, load file, quit screen
if 0 <= mx and mx <= screenWide then
if yMinFunc < my and my < yMaxFunc then
update = 1
xf = mx / funcWide
if xf <= 1 then 'help solve
hardSolve
elif xf <= 2 'play mode
mode = "p"
elif xf <= 3 'make mode
mode = "m"
for rrow = 0 to 8
for ccol = 0 to 8
grid(ccol, rrow) = abs(grid(ccol, rrow))
next
next
elif xf <= 4 'save file
savePZ(0)
elif xf <= 5 'load file
loadPZ
elif xf <= 6 'exit
xit = 1 : exit loop
fi
fi
fi
fi 'if mouse clicked
delay 50 'save fan from running
wend
'did we exit inner game loop because puzzle solved, or quit or get another board?
IF xit THEN xit = 0 ELSE BEEP : savePZ(1) 'signals puzzle solved
wend
sub handleNumber(ky)
if grid(bx, by) < 1 or mode = "m" then 'don't change clues in puzzle mode
if ky = 0 then
grid(bx, by) = 0
else
if aok(ky, bx, by) then 'is this a bad idea = bad key?
if mode = "p" then grid(bx, by) = -ky else grid(bx, by) = ky
else
beep ' bad idea for puzzle mode and make mode
fi
fi
else
beep ' don't change clues!
fi
update = 1
end
func solved() 'has the puzzle been solved? assume solved = 0, exit func once proved
local n, found, col, row, box, cbox, rbox
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 func
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 func
next
'check boxes for n
for cell = 0 to 8
cbox = 3 * cell mod 3
rbox = 3 * int(cell / 3)
found = 0
for col = 0 to 2
for row = 0 to 2
if abs(grid(cbox+ col, rbox + row)) = n then found = 1: exit for
next
if found = 1 then exit for
next
if found = 0 then exit func
next
next
solved = 1 'good one!
end
' displays the game grid, mainly as Chris with more constants
sub showGrid()
local x, y, i, j, b, s
update = 0 'before we forget, turn off update global calls for this display
b = rgb(0, 0, 40) 'background color
color 15, b : cls
'title, level mode
if mode = "p" then s = " Puzzle Mode" else s = " Make Mode"
? : cp 1, "Sudoku Level " + level + s
'draw board line segments
i = xMinBoard
for x = 0 to 9
line i, yMinBoard, i, yMaxBoard, 13
i += CellSize
next x
j = yMinBoard
for y = 0 to 9
line xMinBoard, j, xMaxBoard, j, 13
j += CellSize
next y
'draw heavy 3x3 cell borders
rect xMinBoard + 1, yMinBoard + 1, xMaxBoard + 1, yMaxBoard + 1, 15
i = xMinBoard + CellSize * 3 + 1
line i, yMinBoard, i, yMaxBoard, 15
i = xMinBoard + CellSize * 6 + 1
line i, yMinBoard, i, yMaxBoard, 15
j = yMinBoard + CellSize * 3 + 1
line xMinBoard, j, xMaxBoard, j, 15
j = yMinBoard + CellSize * 6 + 1
line xMinBoard, j, xMaxBoard, j, 15
for y = 0 to 8
for x = 0 to 8
'highlite?
if x = bx and y = by then
color b, 10
rect xMinBoard + x*CellSize + 3, yMinBoard + y*CellSize + 3 step CellSize-5, CellSize-5, 10 filled
else
if grid(x, y) > 0 then color 9, b else color 7, b
end if
if grid(x,y) <> 0 then
at xMinBoard + x*CellSize + TextSize*2, yMinBoard + y*CellSize + TextSize + 4
? abs(grid(x, y))
fi
next
next
'show a keypad key with highlite
i = xMinKeyPad
for x = 0 to 9
if x = key then
rect i+3,yMinKeyPad+3 step CellSize-5, CellSize-5, 10 filled
color b, 10
else
color 11, b
fi
line i,yMinKeyPad,i,yMaxKeyPad,7
at i+(TextSize*2),yMinKeyPad+TextSize+4
? x
i += CellSize
next
rect xMinKeyPad, yMinKeyPad, xMaxKeyPad, yMaxKeyPad, 7
'function pad
'here's where mouse is looking
' if 0 <= mx and mx <= screenWide then
' if yMinFunc < my and my < yMaxFunc then
' xf = my / funcWide
color 11, 12
for i = 1 to 6
rect (i -1)*funcWide + 5, yMinFunc + 5, i * funcWide - 5, yMaxFunc - 5, 12 filled
at (i -1)*funcWide + 25, yMinFunc + 15
select case i
case 1 : ? "Help"
case 2 : ? "Play"
case 3 : ? "Make"
case 4 : ? "Save"
case 5 : ? "Load"
case 6 : ? "Exit""
end select
next
end
sub makeGrid
local n, cellBlock, i, cnt, startOver, temp, wait
'this version requires the assistance of loadCell sub routine
' debug by stepping through process with showGrid sub
repeat
dim grid(8, 8) : startOver = 0
for n = 1 to 9
temp = grid : cnt = 0
repeat
for box= 0 to 8
success = loadBox(n, box)
if success = 0 then
cnt = cnt + 1
if cnt >= 20 then startOver = 1 : exit for
grid = temp
exit for
fi
next
if startOver then exit loop
until success
if startOver then exit for
next
until startOver = 0
end
sub hideCells
local box, cBase, rBase, m, bx, by, dx, dy, dm
for box = 0 to 8
cBase = (box mod 3) * 3
rBase = int(box / 3) * 3
dx = int(rnd * 2) + 1 : dy = int(rnd * 2) + 1
if rnd < .5 then dm = -1 else dm = 1
bx = int(rnd * 3) : by = int(rnd * 3)
for m = 0 to level - 1
grid(cBase + ((bx + m * dx) mod 3) , rBase + (by + m * dy + int(m/3) * dm) mod 3) = 0
next
next
end
func aok(a, c, r) 'check to see if a is OK to place at (c, r)
local i, rr, cc, cbase, rbase
aok = 0
if grid(c, r) = 0 then 'check cell empty
for i = 0 to 8 'check row and column
if abs(grid(i, r)) = a or abs(grid(c, i)) = a then exit func
next
'cbase = int(c / 3) * 3 : rbase = int(r / 3) * 3
cbase = c - c mod 3 : rbase = r - r mod 3
for rr = 0 to 2
for cc = 0 to 2
if abs(grid(cbase + cc, rbase + rr)) = a then exit func
next
next
aok = 1
fi
end
func loadBox(n, box) 'this one uses aok function to help load boxes
local xoff, yoff, list, x, y, available, i, pointer, cell, r
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++ : list(3 * y + x) = 1
next
next
if available = 0 then
exit func
fi
dim cell(1 to available) : pointer = 1
for i = 0 to 8
if list(i) then cell(pointer) = i : pointer ++
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 * i) + 1
swap cell(i), cell(r)
next
fi
'load the first one listed
grid(xoff + (cell(1) mod 3), yoff + int(cell(1) / 3)) = n
loadBox = 1
end
func sweepChange()
'global grid, update
local n, c, r, only, nn, b1, b2, b3, b4, cbase, rbase, rr, cc
for n = 1 to 9
for r = 0 to 8
for c = 0 to 8
if aok(n, c, r) then
cbase = 3 * int(c / 3) : rbase = 3 * int(r /3) 'used in a couple of tests
'only n is good at c, r ?
only = 1
for nn = 1 to 9
if nn <> n then
if aok(nn, c, r) then only = 0 : exit for
'no other n works at
fi
next
if only then
grid(c, r) = -n : sweepChange = 1 : update = 1 : exit for
fi
fi 'if aok(n, c, r)
next c
next r
next n
end
sub hardSolve()
local continue
continue = boxCheck
while continue
showGrid
delay 1000
continue = boxCheck
if continue = 0 then continue = sweepChange() 'a 2nd solver method
wend
beep
end
sub savePZ(saveSolved)
local fName, r, s, c
showGrid
if saveSolved then fName = "Temp Solved Puzzle.txt" else fName = "Temp Saved Puzzle.txt"
open fName for output as #1
for r = 0 to 8
s = ""
for c = 0 to 8
s = s + right(" " + str(grid(c, r)), 3)
next
print #1, s;Chr(13) 'not 13 and 10 and not 10 so 13! yes!
next
close #1
color 9, 11
locate 26, 3 : ? " *** Puzzle saved to: " + fName + " *** "
delay 5500
end
sub loadPZ()
local fl, row, i, n
open "Temp Saved Puzzle.txt" for input as #1
for row = 0 to 8
input #1, fl
for i = 0 to 8
n = val(mid(fl, 3 * i + 1, 3))
grid(i, row) = n
next
next
close #1
end
func boxCheck() 'return 0 if no changes made, else return 1
local n, box, xoff, yoff, list, x, y, available, theCell
for n = 1 to 9
for box = 0 to 8
available = 0
xoff = 3 * (box MOD 3): yoff = 3 * INT(box / 3)
'save last free cells in box, if only one the
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 'count available
available++ : theCell = 3 * y + x
end if
next
next
'if there is only one place n works in box put it there!
if available = 1 then
boxCheck = 1 'flag a change
grid(xoff + (theCell mod 3), yoff + int(theCell / 3)) = -n
fi
next
next
end
sub getLevel 'isolated to work on independently
'get desired level of difficulty set
color 15, 0: cls
rect 0, 0, screenwide, yMaxFunc, 8
cp 2, "Sudoku Game, Solver and Editor by bplus"
cp 4, "While running a puzzle try pressing h key for help."
cp 5, "It will logically solve puzzle as far as it can,"
cp 6, "then beep to let you know it's finished."
cp 7, "(A double beep would mean it's finished and solved.)"
cp 9, "To begin, please enter a level of difficulty."
cp 10, "A level of 1 will hide 1 cell in every box,"
cp 11, "4 will hide 4 in every box."
cp 12, "Levels 1 to 3 are good for developing"
cp 13, "'flash card' automatic skills."
cp 14, "Levels 4, 5 and 6 are easy standard for:"
cp 15, "beginner, intermediate, and difficult puzzles."
cp 17, "Use level 9 to blank a puzzle and input your own."
lp 2, "press m for Make mode (enters pos values in grid)."
lp 2, "press p for Puzzle mode (enters neg values in grid)."
lp 2, "Press s for save, files to Temp Saved Puzzle.txt"
lp 2, "press l to load that puzzle up again."
cp 22, "When a puzzle is Solved it is automatically saved"
cp 23, "to Temp Solved Puzzle.txt"
cp 24, "Use your OS to manage these files."
color 14, 0
LOCATE 27, 1: INPUT "Now about the level? Enter 0 to 9 any else quits "; level
IF instr("0123456789", level) then level = val(level) else CLS: stop
'test robustness of algo for hiding should work to hiding 9 cells in box! YES!!!
end
sub cp(cpRow, text)
at (screenWide - txtw(text))/2, cpRow * txth(text)
? text
end
sub lp(spacer, text)
? space(spacer);text
end
--- End code ---
B+:
Oh hey!
Add this:
--- Code: ---sub ps(x, y, size, s) ' a sub to make translating to SmallBASIC from SdlBasic easier
'when this sub is used text size is altered for the rest of the run
local l
l.w = window() : l.w.setfont(size, "pt", 0, 0)
at x, y : ? s
l.w.setfont(18, "pt", 0, 0)
end
--- End code ---
to remake this:
--- Code: ---' displays the game grid, mainly as Chris with more constants
sub showGrid()
local x, y, i, j, b, s, cell, n, cs
update = 0 'before we forget, turn off update global calls for this display
b = rgb(0, 0, 40) 'background color
color 15, b : cls
'title, level mode
if mode = "p" then s = " Puzzle Mode" else s = " Make Mode"
? : cp 1, "Sudoku Level " + level + s
'draw board line segments
i = xMinBoard
for x = 0 to 9
line i, yMinBoard, i, yMaxBoard, 13
i += CellSize
next x
j = yMinBoard
for y = 0 to 9
line xMinBoard, j, xMaxBoard, j, 13
j += CellSize
next y
'draw heavy 3x3 cell borders
rect xMinBoard + 1, yMinBoard + 1, xMaxBoard + 1, yMaxBoard + 1, 15
i = xMinBoard + CellSize * 3 + 1
line i, yMinBoard, i, yMaxBoard, 15
i = xMinBoard + CellSize * 6 + 1
line i, yMinBoard, i, yMaxBoard, 15
j = yMinBoard + CellSize * 3 + 1
line xMinBoard, j, xMaxBoard, j, 15
j = yMinBoard + CellSize * 6 + 1
line xMinBoard, j, xMaxBoard, j, 15
for y = 0 to 8
for x = 0 to 8
'make a string of available candidates for cell
cs = ""
for n = 1 to 9
if aok(n, x, y) then cs = cs + str(n)
next
'highlite?
if x = bx and y = by then
color b, 10
rect xMinBoard + x*CellSize + 3, yMinBoard + y*CellSize + 3 step CellSize-5, CellSize-5, 10 filled
else
if grid(x, y) > 0 then color 9, b else color 7, b
end if
if grid(x,y) <> 0 then
ps xMinBoard + x*CellSize + TextSize*2, yMinBoard + y*CellSize + TextSize + 4, 26, abs(grid(x, y))
else
ps xMinBoard + x*CellSize + 3, yMinBoard + y*CellSize + 3, 12, cs
fi
next
next
'show a keypad key with highlite
i = xMinKeyPad
for x = 0 to 9
if x = key then
rect i+3,yMinKeyPad+3 step CellSize-5, CellSize-5, 10 filled
color b, 10
else
color 11, b
fi
line i,yMinKeyPad,i,yMaxKeyPad,7
at i+(TextSize*2),yMinKeyPad+TextSize+4
? x
i += CellSize
next
rect xMinKeyPad, yMinKeyPad, xMaxKeyPad, yMaxKeyPad, 7
'function pad
'here's where mouse is looking
' if 0 <= mx and mx <= screenWide then
' if yMinFunc < my and my < yMaxFunc then
' xf = my / funcWide
color 11, 12
for i = 1 to 6
rect (i -1)*funcWide + 5, yMinFunc + 5, i * funcWide - 5, yMaxFunc - 5, 12 filled
at (i -1)*funcWide + 25, yMinFunc + 15
select case i
case 1 : ? "Help"
case 2 : ? "Play"
case 3 : ? "Make"
case 4 : ? "Save"
case 5 : ? "Load"
case 6 : ? "Exit""
end select
next
end
--- End code ---
and get this! (note: the puzzle is NOT level 6 but an Intermediate I made, saved and loaded, copied from newspaper)
B+:
Sudoku Solver Starter in JB Mainwin:
--- Code: ---'Sudoku Solve Experiment.bas for JB v2.0 b 2018-01-21 (B+=MGA)
' experiment with another Solver after reading Sudoku.org.uk discussion with code in JS
'recursive Solver? who needs that? ;-)) I do! For Solvers that handle ambiguity.
'A solver starter... Level 4 OK, level 5 very shakey, level 6 doubt it!
'globals
global level
dim grid(8, 8), copy(8, 8), copy2(8, 8)
lastPuzzle = 3 '3 puzzles to read through data
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 it
result = CompleteGrid()
if 0 < result and result < 65 then
s$ = "solved in ";result;" rounds!"
else
if 0 > result then
s$ = "Puzzle failed to change after round ";-1 * result;"."
else
s$ = "Went full ";result - 1;" rounds and still incomplete! (not likely to see this report)"
end if
end if
'show off
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 "CompleteGrid function reports: ";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
scan
copy(r, c) = grid(r, c)
next
next
end sub
sub copyCopy
for r = 0 to 8
for c = 0 to 8
scan
grid(r, c) = copy(r, c)
next
next
end sub
sub copyGrid2
for r = 0 to 8
for c = 0 to 8
scan
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
scan
redim grid(8, 8) : startOver = 0
for n = 1 to 9
scan
call copyGrid
cnt = 0
do
scan
for box = 0 to 8
scan
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
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
'======== end of Grid Making stuff, Start of Solver stuff, aok(a, c, r) used with both!
function CompleteGrid() 'by trying to Solve it
for round = 1 to 65 '17 clues from 81 cells = 64 maximum rounds to make, add 1 for good measure
NoChange = 1 'no sense waiting in suspense if nothing is getting changed in puzzle
gridIsDone = 1
for n = 1 to 9
for r = 0 to 8
for c = 0 to 8
scan
if aok(n, c, r) then ' (c, r) is empty and n works there
gridIsDone = 0 'still a space left in grid
'is n the only number that works here in row?
only = 1 'only n works here
for nn = 1 to 9
scan
if nn <> n then
if aok(nn, c, r) then only = 0 : exit for
end if
next
if only then
grid(c, r) = -1 * n 'ID fill-ins with neg numbers to tell from clues
NoChange = 0
end if
end if 'Grid = 0
next
next
next
if gridIsDone then
CompleteGrid = round 'successful completion in round numbers
exit function
else
if NoChange then 'bug out!
CompleteGrid = -1 * round
exit function
end if
end if
next
CompleteGrid = round 'last round still failed to complete
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
--- End code ---
No lines or circles, no color,... just a large scrolling screen and brains! ;-))
B+:
Oh hey! This recursive Solver from JB forum kicks butt!
--- Code: ---'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
--- End code ---
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!
Navigation
[0] Message Index
[#] Next page
[*] Previous page
Go to full version