JB Sudoku Starter Solver (mainwin no GUI)
#1
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

Mainwin in JB is just B&W console type program, all text, no color.


Attached Files Thumbnail(s)

B += x
Reply
#2
Post Circles from Chords :), I see I am now a "Posting Freak", yeah sure! ;-))


Oh hey! This recursive Solver kicks butt! Recommended at JB forum, I just got around to checking it out.

It is sweeeeet! and so simple too! I can use it for setting up puzzles by just giving it a blank grid "to solve"! ? !!!

Code:
'Sudoku Recursive Solve Experiment.bas for JB v2.0 b 2018-01-21 (B+=MGA)
' ============================================= check out
'  Sukoku solver program
'  version 2

'  written by cassiope01 on 18 Nov 2011
'  modified very slightly by TyCamden on 19 Nov 2011
' === >>> 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

Here is snap of most difficult puzzle, I've recorded:

Update: Doesn't work well with SmallBASIC, keep getting Stack Overload when recursion goes beyond some level...
But QB64 works well, even faster than JB! Puzzles are solved instantly!!!


Attached Files Thumbnail(s)

B += x
Reply