Author Topic: Sudoku  (Read 652 times)

B+

  • Sr. Member
  • ****
  • Posts: 498
    • View Profile
Sudoku
« on: 11. January 2018, 17:54:51 »
Hi,

I am studying Sudoku Game and probably will revisit Solvers eventually, at these sites:

Just Basic: http://justbasic.conforums.com/index.cgi?board=code&action=display&num=1515342883

SmallBASIC: https://smallbasic.sourceforge.io/?q=node/1773

QB64: http://www.qb64.net/forum/index.php?topic=14672.0

and here The Joyful Programmer > The QB64 Edition:
http://qb64.thejoyfulprogrammer.com/showthread.php?tid=1207&pid=5720&rndtime=15156870881901289581#pid5720

My main interest is perfecting THE GAME algorithms, board making and cell hiding such that when you hide the cells you don't create a board that can be solved more than one way.

I've already learned you can make a legit board for a game but it is trivial to solve, as discussed or illustrated in above links.

I have devised code that will create non trivial boards but need an algo to hide the cells but keep solution unique, ie only one solution set. Is there one? 

Could I understand how it is put together and works? ;-))

Rick3137

  • Full Member
  • ***
  • Posts: 112
    • View Profile
    • Rick's Programs
Re: Sudoku
« Reply #1 on: 11. January 2018, 18:14:57 »
 Hello Mark:
 
  I went through this years ago, and found a nice easy solution.
  I start from a solved game, from any source, that works correctly.

  I then look at the numbers in the solution, and substitute new numbers for old ones.
  For instance; All 1's become 9's. All 2's become 4's, All 9's become 3's etc.
  Instant new game.
http://rb23.yolasite.com  Ricks Programs
http://rb27.synthasite.com   Sight and Sound

B+

  • Sr. Member
  • ****
  • Posts: 498
    • View Profile
Re: Sudoku
« Reply #2 on: 11. January 2018, 18:54:48 »
Hi Rick,

Good to see you are still alive and kicking!

Yes! I have started with 6 base board solutions and shuffled columns and rows within boxes and then shuffled vertical or horizontal blocks of boxes and then randomly changed all the numbers as one does with code a = s, b = y, c = f, ....

This leaves a board who's solution is too easy to find because permutation of the same 3 sets of numbers are repeated in every box eg

one box is
148
923
576

so all the other boxes are variations

481
392
657

814
239
765

all you need to see is 18x   and you know x = 4
all you need to see is x4y   and you know x or y = 8 and the other is 4

This is for every box in the puzzle...

hmm... but maybe if you had a better, more random puzzle to start with... yes that would be better!

B+

  • Sr. Member
  • ****
  • Posts: 498
    • View Profile
Re: Sudoku
« Reply #3 on: 14. January 2018, 15:59:51 »
I am pleased to announce that last night I found the formula / recipe to distribute the hidden cells homogeneously throughout the puzzle grid that guarantees leaving each box row, col with a cell which guarantees each cell and row of the whole grid has a 3 cells not hidden (in the hardest level of play that leaves only 3 cells per box.).

My conjecture is that such an arrangement is most likely to keep a puzzle to the original solution devised at the start (which I will explore when I start playing with Solvers again).

Code: [Select]
' Make #3 Board Test Hiding.bas SmallBASIC 0.12.11 (B+=MGA) 2018-01-12

'from make #2 Board Maker, now test hiding cells
'aha! I have defined levels well for myself at least!

randomize
dim grid(8, 8) 'global access to use between calls to functions using them

while 1
  cls
  'get desired level of difficulty set
  locate 6, 27 : ? "Welcome to the game called Sudoku!"
  locate 7, 20 : ? "To begin, please enter a level of difficulty."
  locate 9, 10 : ? "A level of 1 will hide 1 cell in every box, 4 will hide 4 in every box."
  locate 11, 10 : ? "Levels 1 to 3 are good for developing 'flash card' automatic skills."
  locate 12, 10 : ? "Levels 4, 5 and 6 are your standard but on easy side for:"
  locate 13, 10 : ? "beginner, intermediate, and difficult puzzles."
  locate 15, 10  : input "Enter 1 for very easy up to 6 for very hard! any else quits ";level
  if level < 0 or level > 10 then end
  'test robustness of algo for hiding should work to hiding 9 cells in box! YES!!!

    'test grids have solutions for Sudoku Game
  'while 1
  tCount = 0 : tStartOver = 0
  makeGrid
  showGrid
  ? : ? "Grid solve-able ? answer: ";solved()
  ? "Total cellBlock redo's ";tCount
  ? "      Total StartOvers ";tStartOver
  input "OK press enter to see the Hide...";more
  hideCells
  showGrid
  print "That was level ";level
  input "Press enter for another set, any else quits ";more
  if len(more) then end
wend

sub hideCells
  'global level
  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
    bx = int(rnd*3) : by = int(rnd*3)
    dx = int(rnd*2) + 1 : dy = int(rnd*2) + 1
    if rnd <.5 then dm = -1 else dm = 1
    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

'this will either put the number in the grid's cellBlock or return 0 for failure
func loadCell(n, cellBlock)
  local xoff, yoff, xstop, ystop, list, x, y
  local xx, yy, available, i, pointer, cell, r
  local wait

  'grid
  ' 0 1 2  3 4 5  6 7 8
  '
  'cell block numbers
  ' 0 1 2
  ' 3 4 5
  ' 6 7 8

  select case cellBlock
    case 0 : xoff = 0 : yoff = 0 : xstop = 0 : ystop = 0
    case 1 : xoff = 3 : yoff = 0 : xstop = 2 : ystop = 0
    case 2 : xoff = 6 : yoff = 0 : xstop = 5 : ystop = 0

    case 3 : xoff = 0 : yoff = 3 : xstop = 0 : ystop = 2
    case 4 : xoff = 3 : yoff = 3 : xstop = 2 : ystop = 2
    case 5 : xoff = 6 : yoff = 3 : xstop = 5 : ystop = 2

    case 6 : xoff = 0 : yoff = 6 : xstop = 0 : ystop = 5
    case 7 : xoff = 3 : yoff = 6 : xstop = 2 : ystop = 5
    case 8 : xoff = 6 : yoff = 6 : xstop = 5 : ystop = 5
  end select
  'filling the cells in order so all the ones before n are done
  '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 grid(xoff + x, yoff + y) = 0 then 'open

        bad = 0
        'check rows and columns before this cell block
        for yy = 0 to ystop 'rows
          if grid(xoff + x,  yy) = n  then
            bad = 1
            exit for
          fi
        next
        if bad = 0 then
          for xx = 0 to xstop
            if grid(xx, yoff + y) = n then
              bad = 1
              exit for
            fi
          next
        fi
        if bad = 0 then available++ : list(3*y + x) = 1
      end if

    next
  next

  '? : ? "Number of Cells available ";available
  'for i = 0 to 8 : ? list(i); : next : ?
  'input "OK, press enter... ";wait
  'delay 20

  if available = 0 then
    '? "error: no cells available for: "; n;" in cellBlock ";cellBlock : delay 1500
    loadCell = 0
    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
  loadCell = 1
end

'the master sub for which loadCell function was designed
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 cellBlock  = 0 to 8
          success = loadCell(n, cellBlock)
          if success = 0 then
            cnt = cnt + 1
            tCount++
            if cnt >= 20 then startOver = 1 : tStartOver++ : exit for
            grid = temp
            exit for
          fi
          'showGrid
          'input  " OK, press enter..."; wait
          'delay 200
        next
        if startOver then exit loop
      until success
      if startOver then exit for
    next
  until startOver = 0
end

sub showGrid
  local r, c
  cls
  for r = 0 to 8
    for c = 0 to 8
      locate int(r/3) + r + 2 , int(c/3) * 2 + (c + 2) * 3,  : ? grid(c, r)
    next
  next
  ?
end

' add solved function
func solved()
  local n, col, row, cell, cellrow, cellcol, found
  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 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 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 FUNC
    NEXT
  NEXT
  solved = 1
end


4 days to get a dozen lines of code, sheeze!
« Last Edit: 14. January 2018, 19:21:57 by B+ »

B+

  • Sr. Member
  • ****
  • Posts: 498
    • View Profile
Re: Sudoku
« Reply #4 on: 17. January 2018, 20:54:40 »
And here is my most recent update of the Sudoku Game in SmallBASIC version 0.12.11
This uses not so random hiding of cells and levels of play are decided by how many cells per box to remove ie, 0 would display a solved puzzle, 9 would display a board with 0 clues left; easy, intermediate and difficult would be levels: 4, 5 and 6.

Code: [Select]
' SB1 Sudoku Game.bas SmallBASIC 0.12.11 (B+=MGA) 2018-01-17
' some edits of game posted 2018-01-17, better quit code with level
' more debug code removed

'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

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

'main loop sets up game puzzle,
'when solved it flashes that fact and then sets up another puzzle
while 1
  'get desired level of difficulty set
  cls
  LOCATE 5, 5: PRINT "Welcome to SB version of Sudoku Game by bplus"
  LOCATE 9, 5: PRINT "To begin, please enter a level of difficulty."
  LOCATE 10, 8: PRINT "A level of 1 will hide 1 cell in every box,"
  LOCATE 12, 14: PRINT "4 will hide 4 in every box."
  LOCATE 14, 9: PRINT "Levels 1 to 3 are good for developing"
  LOCATE 15, 12: PRINT "'flash card' automatic skills."
  LOCATE 17, 9: PRINT "Levels 4, 5 and 6 are easy standard for:"
  LOCATE 18, 5: PRINT "beginner, intermediate, and difficult puzzles."
  LOCATE 22, 12: INPUT "Enter 0 to 9 any else quits "; level
  IF instr("0123456789", level) then level = val(level) else CLS: END
  'test robustness of algo for hiding should work to hiding 9 cells in box! YES!!!
  '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
  dim grid(8,8)    '9x9 board positive values come from puzzle creation
  '0 and negative values are cells blanked out to make puzzle

  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
    if pen(3) then
      mx = pen(4) : my = pen(5)
      while pen(3)
        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)
        if grid(bx, by) < 1 then
          if key = 0 then grid(bx, by) = 0 else grid(bx, by) = -key
        fi
        update = 1
      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
      if xMidBoard - 3 * CellSize <= mx and mx <= xMidBoard + 3 * CellSize then
        if yMaxKeyPad + CellSize <= my and my <= yMaxKeyPad + 2 * CellSize then xit = 1 : exit loop
      fi
    fi
    delay 50  'save fan from running
  wend
  IF xit THEN
    xit = 0
  ELSE
    BEEP
    t = TIMER
    WHILE (TIMER - t < 6)
      showGrid
      DELAY 900
      COLOR 15, 0
      CLS
      at xMidBoard - 7 * TextSize, yMidBoard - .5 * TextSize : ? "Puzzle solved!"
      DELAY 300
    WEND
  END IF
wend

' add solved function
func solved()
  local n, col, row, cell, cellrow, cellcol, found
  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 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 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 FUNC
    NEXT
  NEXT
  solved = 1
end

' displays the game grid, mainly as Chris with more constants
sub showGrid()
  update = 0 'global calls for this display
  local x, y, i, j, b
  b = rgb(0, 0, 40)
  color 15, b : cls
  locate 1, 21 : ? "Sudoku Level ";level
  rect xMidBoard - 3 * CellSize, yMaxKeyPad + CellSize, xMidBoard + 3 * CellSize, yMaxKeyPad + 2 * CellSize, 12 filled
  at xMidBoard - 2 * TextSize, yMaxKeyPad + CellSize + TextSize + 4
  color 7, 12
  ? "EXIT"
  'draw 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
end

func loadCell(n, cellBlock)
  local xoff, yoff, xstop, ystop, list, x, y
  local xx, yy, available, i, pointer, cell, r
 
  xoff = 3 * (cellBlock MOD 3): yoff = 3 * INT(cellBlock / 3)
  IF xoff > 0 THEN xstop = xoff - 1 ELSE xstop = 0
  IF yoff > 0 THEN ystop = yoff - 1 ELSE ystop = 0
  'filling the cells in order so all the ones before n are done
  '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 grid(xoff + x, yoff + y) = 0 then 'open
        bad = 0
        'check rows and columns before this cell block
        for yy = 0 to ystop 'rows
          if grid(xoff + x,  yy) = n  then
            bad = 1
            exit for
          fi
        next
        if bad = 0 then
          for xx = 0 to xstop
            if grid(xx, yoff + y) = n then
              bad = 1
              exit for
            fi
          next
        fi
        if bad = 0 then available++ : list(3*y + x) = 1
      end if
    next
  next
  if available = 0 then
    loadCell = 0
    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
  loadCell = 1
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 i = 1 to 9
          cellBlock = val(mid("013246578", i , 1))
          success = loadCell(n, cellBlock)
          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 copyGrid, success, box, cBase, rBase, m, bx, by, dx, dy, dm, test, r, c, i, cnt
  copyGrid = grid
  while success = 0
    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
    showGrid
    dim test(9)
    for box = 0 to 8
      cBase = (box mod 3) * 3
      rBase = int(box / 3) * 3
      for r = 0 to 2
        for c = 0 to 2
          test(grid(cBase + c, rBase + r)) = 1
        next
      next
    next
    success = 1
    for i = 1 to 9
      if test(i) = 0 then success = 0
    next
    if success = 0 then
      cnt = cnt + 1
      if cnt > 20 then
        success = 1 : beep 'when all numbers aren't there
      else
        grid = copyGrid
      fi
    fi
  wend
end

« Last Edit: 17. January 2018, 20:58:16 by B+ »

Rick3137

  • Full Member
  • ***
  • Posts: 112
    • View Profile
    • Rick's Programs
Re: Sudoku
« Reply #5 on: 19. January 2018, 16:35:50 »
 Nicely done.  :) :) :)
http://rb23.yolasite.com  Ricks Programs
http://rb27.synthasite.com   Sight and Sound

B+

  • Sr. Member
  • ****
  • Posts: 498
    • View Profile
Re: Sudoku
« Reply #6 on: 21. January 2018, 01:41:34 »
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: [Select]
' 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

B+

  • Sr. Member
  • ****
  • Posts: 498
    • View Profile
Re: Sudoku
« Reply #7 on: 21. January 2018, 09:18:23 »
Oh hey!

Add this:
Code: [Select]
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

to remake this:
Code: [Select]
' 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

and get this! (note: the puzzle is NOT level 6 but an Intermediate I made, saved and loaded, copied from newspaper)
« Last Edit: 21. January 2018, 09:21:38 by B+ »

B+

  • Sr. Member
  • ****
  • Posts: 498
    • View Profile
Re: Sudoku
« Reply #8 on: 21. January 2018, 20:36:43 »
Sudoku Solver Starter in JB Mainwin:
Code: [Select]
'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



No lines or circles, no color,...   just a large scrolling screen and brains!  ;-))
« Last Edit: 21. January 2018, 20:46:08 by B+ »

B+

  • Sr. Member
  • ****
  • Posts: 498
    • View Profile
Re: Sudoku
« Reply #9 on: 22. January 2018, 03:23:26 »
Oh hey! This recursive Solver from JB forum kicks butt!
Code: [Select]
'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!
« Last Edit: 22. January 2018, 06:29:52 by B+ »

B+

  • Sr. Member
  • ****
  • Posts: 498
    • View Profile
Re: Sudoku
« Reply #10 on: 24. January 2018, 03:35:29 »
OK here is fully featured Sudoku App with nice recursive solver, outstanding Help that can be toggled on/off, what you can do with keyboard you can do with mouse and vice versa (except get level in opening screen).

Well here are a couple of screen shots:

B+

  • Sr. Member
  • ****
  • Posts: 498
    • View Profile
Re: Sudoku
« Reply #11 on: 24. January 2018, 03:38:13 »
Oh but we need to see the important ones with Help and Fill (Solve):

B+

  • Sr. Member
  • ****
  • Posts: 498
    • View Profile
Re: Sudoku
« Reply #12 on: 24. January 2018, 03:40:16 »
Oh the QB64 v1.1 20171106/82 source file:
« Last Edit: 24. January 2018, 22:08:20 by B+ »

B+

  • Sr. Member
  • ****
  • Posts: 498
    • View Profile
Re: Sudoku
« Reply #13 on: 24. January 2018, 22:07:32 »
Oops! number key press was not being entered into grid as negative thus causing the numbers to act as clues and not guesses.

Fixed in QB3_1 Sudoku App.zip in post above.