Text Only | Text with Attachments

QB64.org Forum

Active Forums => Programs => Topic started by: qbguy on April 17, 2019, 07:15:16 pm

Title: Sudoku solver
Post by: qbguy on April 17, 2019, 07:15:16 pm
Code: QB64: [Select]
  1. DECLARE SUB UPDATEBOARD ()
  2. DEFINT A-Z
  3. CONST RANK = 3
  4. CONST RANK2 = 9
  5. CONST EDITOR = "notepad"
  6. CONST FILE = "steps.txt"
  7. CONST NUMBERS = "123456789"
  8.  
  9. DIM SHARED BLOCK(1 TO RANK2, 1 TO RANK2, 1 TO RANK2)
  10. DIM SHARED PART(1 TO RANK2, 1 TO RANK2)
  11. OPEN FILE FOR OUTPUT AS #1
  13.  
  15.   PRINT "Which character would you like to use to represent blank (empty squares)? ";
  16.   LINE INPUT BLANK$
  17.   BLANK$ = LEFT$(LTRIM$(RTRIM$(BLANK$)), 1)
  18.   IF BLANK$ = "" THEN BLANK$ = " "
  19. LOOP UNTIL INSTR(NUMBERS, BLANK$) = 0
  21. PRINT "Enter your puzzle in plain text form.  Only numbers (1-9) and blanks have"
  22. PRINT "significance. All other characters are ignored.  This means that the puzzle"
  23. PRINT "may be input all on one line or with line breaks, spaces, and ASCII art to"
  24. PRINT "mark block boundaries or beautify your input."
  26. NUMLEFT = 81
  27. I = 1
  28. J = 0
  31.   FOR N = 1 TO LEN(LINE$)
  32.     X$ = MID$(LINE$, N, 1)
  33.     IF X$ = BLANK$ OR INSTR(NUMBERS, X$) THEN
  34.       J = J + 1
  35.       IF J > 9 THEN J = 1: I = I + 1
  36.       PART(I, J) = INSTR(NUMBERS, X$)
  37.       NUMLEFT = NUMLEFT - 1
  38.     END IF
  39.   NEXT
  40. LOOP UNTIL NUMLEFT = 0
  41. FOR ROW = 1 TO RANK2
  42.   FOR COL = 1 TO RANK2
  43.     FOR I = 1 TO RANK2
  44.       IF PART(ROW, COL) = 0 THEN
  45.         BLOCK(ROW, COL, I) = I
  46.       END IF
  47.     NEXT
  48.   NEXT
  50.  
  51. CALL UPDATEBOARD
  53. FOR ROW = 1 TO RANK2
  54.     FOR VALL = 1 TO RANK2
  55.       COUNT = 0
  56.       FOR I = 1 TO RANK2
  57.         IF BLOCK(ROW, I, VALL) = VALL THEN COUNT = COUNT + 1
  58.       NEXT
  59.       IF COUNT = 1 THEN
  60.         FOR COL = 1 TO RANK2
  61.           IF PART(ROW, COL) <> 0 THEN GOTO 2
  62.           IF BLOCK(ROW, COL, VALL) = VALL THEN
  63.               PART(ROW, COL) = VALL
  64.               PRINT #1, "Only one instance of"; VALL; "in row"; ROW; "-- inserting at column"; COL
  65.               FOR I = 1 TO RANK2
  66.                 BLOCK(ROW, COL, I) = 0
  67.               NEXT
  68.               CALL UPDATEBOARD
  69.               GOTO 4
  70.           END IF
  71. 2       NEXT
  72.       ELSE
  73.         BLK = -1
  74.         FOR COL = 1 TO RANK2
  75.           OLDBLK = BLK
  76.           IF BLOCK(ROW, COL, VALL) = VALL THEN BLK = INT((COL - 1) / RANK)
  77.           IF OLDBLK >= 0 AND BLK <> OLDBLK THEN GOTO 3
  78.         NEXT
  79.         IF BLK = -1 THEN GOTO 3
  80.         FOR I = INT((ROW - 1) / RANK) * RANK + 1 TO INT((ROW - 1) / RANK) * RANK + RANK
  81.           FOR J = BLK * RANK + 1 TO BLK * RANK + RANK
  82.             IF I <> ROW AND BLOCK(I, J, VALL) <> 0 THEN
  83.               BLOCK(I, J, VALL) = 0
  84.               PRINT #1, "Eliminating"; VALL; "from"; I; J; "because it must be in row"; ROW; "in same block"
  85.             END IF
  86.           NEXT
  87.         NEXT
  88.       END IF
  89. 3   NEXT
  91. FOR COL = 1 TO RANK2
  92.     FOR VALL = 1 TO RANK2
  93.       COUNT = 0
  94.       FOR I = 1 TO RANK2
  95.         IF BLOCK(I, COL, VALL) = VALL THEN COUNT = COUNT + 1
  96.       NEXT
  97.       IF COUNT = 1 THEN
  98.         FOR ROW = 1 TO RANK2
  99.           IF PART(ROW, COL) <> 0 THEN GOTO 5
  100.           IF BLOCK(ROW, COL, VALL) = VALL THEN
  101.             PART(ROW, COL) = VALL
  102.             PRINT #1, "Only one instance of"; VALL; "in column"; COL; "-- inserting at row"; ROW
  103.             FOR I = 1 TO RANK2
  104.               BLOCK(ROW, COL, I) = 0
  105.             NEXT
  106.             CALL UPDATEBOARD
  107.             GOTO 7
  108.           END IF
  109. 5       NEXT
  110.       ELSE
  111.         BLK = -1
  112.         FOR ROW = 1 TO RANK2
  113.           OLDBLK = BLK
  114.           IF BLOCK(ROW, COL, VALL) = VALL THEN BLK = INT((ROW - 1) / RANK)
  115.           IF OLDBLK >= 0 AND BLK <> OLDBLK THEN GOTO 6
  116.         NEXT
  117.         IF BLK = -1 THEN GOTO 6
  118.         FOR I = BLK * RANK + 1 TO BLK * RANK + RANK
  119.           FOR J = INT((COL - 1) / RANK) * RANK + 1 TO INT((COL - 1) / RANK) * RANK + RANK
  120.             IF J <> COL AND BLOCK(I, J, VALL) <> 0 THEN
  121.               BLOCK(I, J, VALL) = 0
  122.               PRINT #1, "Eliminating"; VALL; "from"; I; J; "because is must be in col"; COL; "in same block"
  123.             END IF
  124.           NEXT
  125.         NEXT
  126.       END IF
  127. 6    NEXT
  129. FOR I = 0 TO RANK - 1
  130.   FOR J = 0 TO RANK - 1
  131.     FOR VALL = 1 TO RANK2
  132.       COUNT = 0
  133.       FOR K = I * RANK + 1 TO I * RANK + RANK
  134.         FOR L = J * RANK + 1 TO J * RANK + RANK
  135.           IF BLOCK(K, L, VALL) = VALL THEN COUNT = COUNT + 1
  136.         NEXT
  137.       NEXT
  138.       IF COUNT <> 1 THEN GOTO 9
  139.       FOR K = I * RANK + 1 TO I * RANK + RANK
  140.         FOR L = J * RANK + 1 TO J * RANK + RANK
  141.           IF PART(K, L) <> 0 THEN GOTO 8
  142.           IF BLOCK(K, L, VALL) = VALL THEN
  143.             PART(K, L) = VALL
  144.             PRINT #1, "Only one instance of"; VALL; "in box -- inserting at row"; K; "column"; L
  145.             FOR M = 1 TO RANK2
  146.               BLOCK(K, L, M) = 0
  147.             NEXT
  148.             CALL UPDATEBOARD
  149.             GOTO 9
  150.           END IF
  151. 8       NEXT
  152.       NEXT
  153. 9   NEXT
  154. 10  NEXT
  156. FOR ROW = 1 TO RANK2
  157.   FOR COL = 1 TO RANK2
  158.     IF PART(ROW, COL) <> 0 THEN GOTO 11
  159.     COUNT = 0
  160.     FOR VALL = 1 TO RANK2
  161.       IF BLOCK(ROW, COL, VALL) = VALL THEN COUNT = COUNT + 1
  162.     NEXT
  163.     IF COUNT = 1 THEN
  164.       FOR VALL = 1 TO RANK2
  165.         IF BLOCK(ROW, COL, VALL) = VALL THEN
  166.           PRINT #1, "Only"; VALL; "may be legally inserted at"; ROW; "column"; COL
  167.           PART(ROW, COL) = VALL
  168.           FOR I = 1 TO RANK2
  169.             BLOCK(ROW, COL, I) = 0
  170.           NEXT
  171.           CALL UPDATEBOARD
  172.           EXIT FOR
  173.         END IF
  174.       NEXT
  175.     ELSEIF COUNT = 2 THEN
  176.       FOR COL2 = 1 TO RANK2
  177.         EXACT = -1
  178.         FOR J = 1 TO RANK2
  179.           IF BLOCK(ROW, COL2, J) <> BLOCK(ROW, COL, J) OR COL2 = COL THEN EXACT = 0: EXIT FOR
  180.         NEXT
  181.         IF EXACT THEN
  182.           FOR I = 1 TO RANK2
  183.             IF (I <> COL) AND (I <> COL2) THEN
  184.               FOR J = 1 TO RANK2
  185.                 IF BLOCK(ROW, I, J) = BLOCK(ROW, COL, J) AND BLOCK(ROW, I, J) <> 0 THEN
  186.                   PRINT #1, "Eliminating "; J; "from"; ROW; I; "b/c naked pair at"; ROW; COL; "and"; ROW; COL2
  187.                   BLOCK(ROW, I, J) = 0
  188.                 END IF
  189.               NEXT
  190.             END IF
  191.           NEXT
  192.           EXIT FOR
  193.         END IF
  194.       NEXT
  195.       FOR ROW2 = 1 TO RANK2
  196.         EXACT = -1
  197.         FOR J = 1 TO RANK2
  198.           IF BLOCK(ROW2, COL, J) <> BLOCK(ROW, COL, J) OR ROW2 = ROW THEN EXACT = 0: EXIT FOR
  199.         NEXT
  200.         IF EXACT THEN
  201.           FOR I = 1 TO RANK2
  202.             IF (I <> ROW) AND (I <> ROW2) THEN
  203.               FOR J = 1 TO RANK2
  204.                 IF BLOCK(I, COL, J) = BLOCK(ROW, COL, J) AND BLOCK(I, COL, J) <> 0 THEN
  205.                   BLOCK(I, COL, J) = 0
  206.                   PRINT #1, "Eliminating "; J; "from"; I; COL; "b/c naked pair at"; ROW; COL; "and"; ROW2; COL
  207.                 END IF
  208.               NEXT
  209.             END IF
  210.           NEXT
  211.           EXIT FOR
  212.         END IF
  213.       NEXT
  214.       FOR I = INT((ROW - 1) / RANK) * RANK + 1 TO INT((ROW - 1) / RANK) * RANK + RANK
  215.         FOR J = INT((COL - 1) / RANK) * RANK + 1 TO INT((COL - 1) / RANK) * RANK + RANK
  216.           EXACT = -1
  217.           FOR K = 1 TO RANK2
  218.             IF (BLOCK(I, J, K) <> BLOCK(ROW, COL, K)) OR (I = ROW AND J = COL) THEN EXACT = 0: EXIT FOR
  219.           NEXT
  220.           IF EXACT THEN
  221.             FOR M = INT((ROW - 1) / RANK) * RANK + 1 TO INT((ROW - 1) / RANK) * RANK + RANK
  222.               FOR N = INT((COL - 1) / RANK) * RANK + 1 TO INT((COL - 1) / RANK) * RANK + RANK
  223.                 IF ((M <> ROW OR N <> COL) AND (M <> I OR N <> J)) THEN
  224.                   FOR K = 1 TO RANK2
  225.                     IF BLOCK(ROW, COL, K) = BLOCK(M, N, K) AND BLOCK(M, N, K) <> 0 THEN
  226.                       BLOCK(M, N, K) = 0
  227.                       PRINT #1, "Eliminating "; K; "from"; M; N; "b/c naked pair at"; ROW; COL; "and"; I; J
  228.                     END IF
  229.                   NEXT
  230.                 END IF
  231.               NEXT
  232.             NEXT
  233.           GOTO 11
  234.           END IF
  235.         NEXT
  236.       NEXT
  237.     ELSE
  238.       GOTO 11
  239.     END IF
  240. 11 NEXT
  242. OLDSUM = SUM
  243. SUM = 0
  244. SOLVED = -1
  245. FOR I = 1 TO RANK2
  246.   FOR J = 1 TO RANK2
  247.     FOR K = 1 TO RANK2
  248.       IF PART(I, J) = 0 THEN SOLVED = 0
  249.       SUM = SUM + BLOCK(I, J, K)
  250.     NEXT
  251.   NEXT
  253. IF SOLVED THEN
  254.   PRINT "Solution Found!"
  255.   PRINT #1, "Solution Found!"
  256.   EXIT DO
  257. ELSEIF SUM = OLDSUM THEN
  258.   PRINT "I seem to be stuck. Work so far:"
  259.   EXIT DO
  262. FOR I = 1 TO RANK2
  263.   FOR J = 1 TO RANK2
  264.     PRINT PART(I, J);
  265.     PRINT #1, PART(I, J);
  266.   NEXT
  268.   PRINT #1, ""
  272. PRINT "Press ESCAPE to quit or any other key to see the steps"
  273. PRINT "used to reach this point."
  274. NULL$ = INPUT$(1)
  275. IF NULL$ = CHR$(27) THEN
  278.   SHELL EDITOR + CHR$(32) + FILE
  280.  
  281. SUB UPDATEBOARD
  282. FOR ROW = 1 TO RANK2
  283.   FOR COL = 1 TO RANK2
  284.     IF PART(ROW, COL) = 0 THEN GOTO 1
  285.     FOR I = 1 TO RANK2
  286.       IF BLOCK(ROW, I, PART(ROW, COL)) = PART(ROW, COL) THEN
  287.         BLOCK(ROW, I, PART(ROW, COL)) = 0
  288.       END IF
  289.       IF BLOCK(I, COL, PART(ROW, COL)) = PART(ROW, COL) THEN
  290.         BLOCK(I, COL, PART(ROW, COL)) = 0
  291.       END IF
  292.     NEXT
  293.     FOR I = INT((ROW - 1) / RANK) * RANK + 1 TO INT((ROW - 1) / RANK) * RANK + RANK
  294.       FOR J = INT((COL - 1) / RANK) * RANK + 1 TO INT((COL - 1) / RANK) * RANK + RANK
  295.         IF BLOCK(I, J, PART(ROW, COL)) = PART(ROW, COL) THEN
  296.           BLOCK(I, J, PART(ROW, COL)) = 0
  297.         END IF
  298.       NEXT
  299.     NEXT
  303.  
Title: Re: Sudoku solver
Post by: bplus on May 02, 2019, 11:02:18 am
Hi qbguy,

Thanks to your post here. I have reviewed my own Sudoku App and took/am taking Sudoku Lessons from Sudoku Guy.


And thanks to that, I have a more enjoyable Sudoku app reworked where you can pencil in numbers to solve puzzles yourself:
http://qb64.freeforums.net/thread/109/sudoku-app
Title: Re: Sudoku solver
Post by: jack on May 02, 2019, 12:00:44 pm
here's a way to solve a sudoku game in under 60 seconds
Title: Re: Sudoku solver
Post by: bplus on May 02, 2019, 01:09:35 pm
HA! LOL the magic of the hand drawn button!

Here is key to solving a Sudoku in under 60 lines:
Code: QB64: [Select]
  1. ' resolve sub written by cassiope01 on 18 Nov 2011,
  2. ' modified very slightly by TyCamden on 19 Nov 2011,
  3. ' modified more by me for testing code at JB in mainwin code:
  4. ' use aok() function in place of ok() as it does
  5. ' the same thing without string processing.
  6.  
  7. ' Now modified by me more, to use in SB but too many stack
  8. ' overflow errors in SB, try QB64, Oh yeah!!! Nice...
  9. SUB resolve ()
  10.     FOR r = 0 TO 8
  11.         FOR c = 0 TO 8
  12.             IF grid(c, r) = 0 THEN
  13.                 FOR n = 1 TO 9
  14.                     IF aok(n, c, r) THEN
  15.                         temp = grid(c, r)
  16.                         grid(c, r) = -n
  17.                         resolve
  18.                         IF complete THEN EXIT SUB
  19.                         grid(c, r) = temp
  20.                     END IF
  21.                 NEXT
  22.                 EXIT SUB
  23.             END IF
  24.         NEXT
  25.     NEXT
  27.  
  28. FUNCTION aok (a, c, r) 'check to see if a is OK to place at (c, r)
  29.     aok = 0
  30.     IF grid(c, r) = 0 THEN 'check cell empty
  31.         FOR i = 0 TO 8 'check row and column
  32.             IF ABS(grid(i, r)) = a OR ABS(grid(c, i)) = a THEN EXIT FUNCTION
  33.         NEXT
  34.         cbase = INT(c / 3) * 3: rbase = INT(r / 3) * 3
  35.         FOR rr = 0 TO 2
  36.             FOR cc = 0 TO 2
  37.                 IF ABS(grid(cbase + cc, rbase + rr)) = a THEN EXIT FUNCTION
  38.             NEXT
  39.         NEXT
  40.         aok = 1
  41.     END IF
  43.  
  44. 'for resolve
  45. FUNCTION complete () 'grid finished ?
  46.     FOR r = 0 TO 8
  47.         FOR c = 0 TO 8
  48.             IF grid(c, r) = 0 THEN EXIT FUNCTION
  49.         NEXT
  50.     NEXT
  51.     complete = 1
  53.  
Title: Re: Sudoku solver
Post by: TempodiBasic on May 05, 2019, 05:49:32 am
Hi QbGuy
Cool

I have given a change to your code testing the results... and just after the enter of the last line of input I've got immediately the solution of the sudoku... (see screenshot)!

I must admit that I am not a great solver of Sudoku, it may be because I have not learned the theory but I know only the basic rule:
in the same square AND in the same row AND in the same column there is one number (symbol) for each of the 9 numbers (symbols).

As soon as I'll go deeper in your code to see the solving path that you have used... and I have seen also the post of Jack, I'll go also there.

FEEDBACK:
1. low profile of interface, can it be included in an InForm interface?
2. Is it possible to load the scheme to solve from a file?
3. can be useful a timestamp and count of move/steps done to solve (like in Hanoi Tower) ?  [ This attachment cannot be displayed inline in 'Print Page' view ]  

Thanks to share
Title: Re: Sudoku solver
Post by: TempodiBasic on May 05, 2019, 05:58:43 am
@JACLK
Quote
here's a way to solve a sudoku game in under 60 seconds
ROLF

PS in smiling I wrong your nickname LOL
Title: Re: Sudoku solver
Post by: TempodiBasic on May 05, 2019, 06:27:56 am
@Bplus

Thanks for
1. the theory 
Quote
Thanks to your post here. I have reviewed my own Sudoku App and took/am taking Sudoku Lessons from Sudoku Guy.


2. the program
see screenshot
  [ This attachment cannot be displayed inline in 'Print Page' view ]  

cool and fine!


FEEDBACK
1. I was fighting for a time to enter a my own puzzle, then I put 0 for each cell and then I input the new puzzle
 1.1 LOL I haven't read well all Help screen so after done this and screenshot I have learned about choice 9 for blank puzzle
  1.2 nice the feature that you cannot do a wrong input in  Editor mode. If the number that you are putting is wrong for position it
       will not be put in that cell
  1.3  hateful feature in Editor mode (make) if I input a wrong number to change it I must before put 0 and then I can put another
        number
2. very fine mouse support.
3. fine feedback are in loading saving solving!
     3.1 it lacks of message in wrong operation of user like my dummies actions talked above! :-)
  [ This attachment cannot be displayed inline in 'Print Page' view ]  
Title: Re: Sudoku solver
Post by: bplus on May 05, 2019, 09:29:06 am
Quote
  1.3  hateful feature in Editor mode (make) if I input a wrong number to change it I must before put 0 and then I can put another
        number

Hi TempodiBasic,

Thanks for feedback! I have noticed problem with changing a number as well and want it to work like the cell notes (right click on cell for number in keypad or shift + number from upper row (US keyboard at least) to toggle number into/out of cell notes. Don't need to clear it first with 0 as you said.

I revised allot of stuff since "Workheet" post. Now you can toggle ON/OFF an overlay of a transparent solution to see how you are progressing with the code calculated solution (which may or may not be unique). Here is your puzzle input and check of solution.
 


Here is your puzzle after first sweeps as taught by Sudoku Guy:
 


Almost done:
 



Title: Re: Sudoku solver
Post by: bplus on May 05, 2019, 10:19:37 am
Here is a Quick Solver.

Enter your puzzle into your favorite text editor, save file as: Quick Solve This Sudoku.txt,
in same folder as the Sudoku Quick Solve.exe

Code: QB64: [Select]
  1. _TITLE "Sudoku Quick Solve" 'B+ started 2019-05-05
  2.  
  3. '          use your favorite editor and make a text file called - Quick Solve This Sudoku.txt
  4. '        use any non number symbol for spaces or 0 (no commas), and type 9 rows of nine numbers and space symbols
  5. '
  6. '            run this program in same folder and it will append the solution if there is one
  7.  
  8. DIM SHARED grid(8, 8) AS INTEGER
  9. OPEN "Quick Solve This Sudoku.txt" FOR INPUT AS #1
  10. FOR row = 0 TO 8
  11.     INPUT #1, fline$
  12.     'PRINT fline$
  13.     FOR col = 0 TO 8
  14.         grid(col, row) = VAL(MID$(fline$, col + 1, 1))
  15.         PRINT grid(col, row);
  16.     NEXT
  17.     PRINT
  20. resolve
  21. OPEN "Quick Solve This Sudoku.txt" FOR APPEND AS #1
  22. PRINT #1, " "
  23. PRINT #1, STRING$(27, "+")
  25. FOR row = 0 TO 8
  26.     'PRINT fline$
  27.     FOR col = 0 TO 8
  28.         PRINT #1, ABS(grid(col, row));
  29.         PRINT grid(col, row);
  30.     NEXT
  31.     PRINT #1, " "
  32.     PRINT
  35. PRINT "File ready"
  36.  
  37. ' resolve sub written by cassiope01 on 18 Nov 2011,
  38. ' modified very slightly by TyCamden on 19 Nov 2011,
  39. ' modified more by me for testing code at JB in mainwin code:
  40. ' use aok() function in place of ok() as it does
  41. ' the same thing without string processing.
  42.  
  43. ' Now modified by me more, to use in SB but too many stack
  44. ' overflow errors in SB, try QB64, Oh yeah!!! Nice...
  45. SUB resolve ()
  46.     FOR r = 0 TO 8
  47.         FOR c = 0 TO 8
  48.             IF grid(c, r) = 0 THEN
  49.                 FOR n = 1 TO 9
  50.                     IF aok(n, c, r) THEN
  51.                         temp = grid(c, r)
  52.                         grid(c, r) = -n
  53.                         resolve
  54.                         IF complete THEN EXIT SUB
  55.                         grid(c, r) = temp
  56.                     END IF
  57.                 NEXT
  58.                 EXIT SUB
  59.             END IF
  60.         NEXT
  61.     NEXT
  63.  
  64. FUNCTION aok (a, c, r) 'check to see if a is OK to place at (c, r)
  65.     aok = 0
  66.     IF grid(c, r) = 0 THEN 'check cell empty
  67.         FOR i = 0 TO 8 'check row and column
  68.             IF ABS(grid(i, r)) = a OR ABS(grid(c, i)) = a THEN EXIT FUNCTION
  69.         NEXT
  70.         cbase = INT(c / 3) * 3: rbase = INT(r / 3) * 3
  71.         FOR rr = 0 TO 2
  72.             FOR cc = 0 TO 2
  73.                 IF ABS(grid(cbase + cc, rbase + rr)) = a THEN EXIT FUNCTION
  74.             NEXT
  75.         NEXT
  76.         aok = 1
  77.     END IF
  79.  
  80. 'for resolve
  81. FUNCTION complete () 'grid finished ?
  82.     FOR r = 0 TO 8
  83.         FOR c = 0 TO 8
  84.             IF grid(c, r) = 0 THEN EXIT FUNCTION
  85.         NEXT
  86.     NEXT
  87.     complete = 1
  89.  
  90.  
  91.  

Here is TempodiBasic's puzzle:
Quote
530070000
600195000
098000060
800060003
400803001
700020006
060000280
000419005
000000079

And file after run:
Quote
530070000
600195000
098000060
800060003
400803001
700020006
060000280
000419005
000000079
+++++++++++++++++++++++++++
 5  3  4  6  7  8  9  1  2 
 6  7  2  1  9  5  3  4  8 
 1  9  8  3  4  2  5  6  7 
 8  5  9  7  6  1  4  2  3 
 4  2  6  8  5  3  7  9  1 
 7  1  3  9  2  4  8  5  6 
 9  6  1  5  3  7  2  8  4 
 2  8  7  4  1  9  6  3  5 
 3  4  5  2  8  6  1  7  9 

Title: Re: Sudoku solver
Post by: bplus on May 07, 2019, 03:49:04 pm
Here is the Quick Solver modified to see if more than one solution is possible. It performs 36 tests alternating the place to start filling (from top left corner of puzzle or from bottom right corner of puzzle) and alternating the start number to try the fill attempt. Although it does not attempt to find every possible solution, it should be able to tell if a solution is unique or not.

Code: QB64: [Select]
  1. _TITLE "Sudoku Unique Solution Test" 'B+ started 2019-05-06
  2. '
  3. '  Check to see if a Sudoku puzzle has a unique soln or more than 1.
  4. '
  5. '        Use your favorite editor and make a text file called - Check Unique Sudoku.txt
  6. '        Use any non number symbol for spaces (no commas),
  7. '        and type 9 rows of nine numbers and space symbols for the puzzle.
  8. '
  9. '        Run this program in same folder and it will append the solution(s) found.
  10. '
  11.  
  12. SCREEN _NEWIMAGE(840, 600, 32) 'wide enough to display solution in a string * 81
  14. DIM SHARED grid(8, 8) AS INTEGER, gridCopy(8, 8) AS INTEGER
  15. DIM solns$(1 TO 9 * 4) ' try 36 tests, might have different solution for each
  16. SI = 0 'soln index
  17.  
  18. 'get the puzzle to check from file
  19. IF _FILEEXISTS("Check Unique Sudoku.txt") THEN
  20.     OPEN "Check Unique Sudoku.txt" FOR INPUT AS #1
  21.     FOR row = 0 TO 8
  22.         INPUT #1, fline$
  23.         'PRINT fline$
  24.         FOR col = 0 TO 8
  25.             grid(col, row) = VAL(MID$(fline$, col + 1, 1))
  26.             gridCopy(col, row) = grid(col, row) 'make copy
  27.             PRINT grid(col, row);
  28.         NEXT
  29.         PRINT
  30.     NEXT
  31.     CLOSE #1
  33.     PRINT "Can't find: Check Unique Sudoku.txt file."
  35.  
  36. PRINT: PRINT "Solution(s) found:"
  37.  
  38. 'get solution(s)
  39.  
  40. 'resolve2 fills in a puzzle from the top left corner
  41. FOR ns = 1 TO 9
  42.     resolve2 ns 'this sould solve everytime no matter where start N
  43.     GOSUB addSoln 'restore grid to pretest conditions
  44.     FOR r = 0 TO 8
  45.         FOR c = 0 TO 8
  46.             grid(c, r) = gridCopy(c, r)
  47.         NEXT
  48.     NEXT
  50.  
  51. ' now try fill in numbers in reverse order
  52. FOR ns = 9 TO 1 STEP -1 'resolve 2 fills in a puzzle from the top left corner
  53.     resolve2 ns 'this sould solve everytime no matter where start N
  54.     GOSUB addSoln 'restore grid to pretest conditions
  55.     FOR r = 0 TO 8
  56.         FOR c = 0 TO 8
  57.             grid(c, r) = gridCopy(c, r)
  58.         NEXT
  59.     NEXT
  61.  
  62. 'resolve3 fills in Sudoku puzzle from the bottom right corner
  63. FOR ns = 1 TO 9
  64.     resolve3 ns 'work the grid from the other end
  65.     GOSUB addSoln
  66.     'restore grid to pretest conditions
  67.     FOR r = 0 TO 8
  68.         FOR c = 0 TO 8
  69.             grid(c, r) = gridCopy(c, r)
  70.         NEXT
  71.     NEXT
  73.  
  74. FOR ns = 9 TO 1 STEP -1
  75.     resolve3 ns 'work the grid from the other end
  76.     GOSUB addSoln
  77.     'restore grid to pretest conditions
  78.     FOR r = 0 TO 8
  79.         FOR c = 0 TO 8
  80.             grid(c, r) = gridCopy(c, r)
  81.         NEXT
  82.     NEXT
  84.  
  85. ' OK file results
  86. OPEN "Check Unique Sudoku.txt" FOR APPEND AS #1
  87. PRINT #1, " "
  88. FOR i = 1 TO SI
  89.     PRINT #1, STRING$(18, "+")
  90.     FOR r = 0 TO 8
  91.         s$ = ""
  92.         FOR c = 0 TO 8
  93.             s$ = s$ + MID$(solns$(i), r * 9 + c + 1, 1) + " "
  94.         NEXT
  95.         PRINT #1, s$
  96.     NEXT
  99.  
  100. PRINT: PRINT "Done checking puzzle, file updated with solutions found."
  102.  
  103. addSoln:
  104. 'string the soln
  105. b$ = ""
  106. FOR row = 0 TO 8
  107.     'PRINT fline$
  108.     FOR col = 0 TO 8
  109.         b$ = b$ + _TRIM$(STR$(ABS(grid(col, row))))
  110.     NEXT
  112. 'check if we have a copy already
  113. bIsCopy = 0
  114. FOR index = 1 TO SI
  115.     IF b$ = solns$(index) THEN bIsCopy = 1: EXIT FOR
  117. IF bIsCopy = 0 THEN
  118.     PRINT b$
  119.     SI = SI + 1
  120.     solns$(SI) = b$
  123.  
  124. SUB resolve2 (startN)
  125.     FOR r = 0 TO 8
  126.         FOR c = 0 TO 8
  127.             IF grid(c, r) = 0 THEN
  128.                 FOR nMod = startN TO startN + 8
  129.                     IF nMod > 9 THEN n = nMod - 9 ELSE n = nMod
  130.                     IF aok(n, c, r) THEN
  131.                         temp = grid(c, r)
  132.                         grid(c, r) = -n
  133.                         resolve2 startN
  134.                         IF complete THEN EXIT SUB
  135.                         grid(c, r) = temp
  136.                     END IF
  137.                 NEXT
  138.                 EXIT SUB
  139.             END IF
  140.         NEXT
  141.     NEXT
  143.  
  144. SUB resolve3 (startN)
  145.     FOR r = 8 TO 0 STEP -1
  146.         FOR c = 8 TO 0 STEP -1
  147.             IF grid(c, r) = 0 THEN
  148.                 FOR nMod = startN TO startN + 8
  149.                     IF nMod > 9 THEN n = nMod - 9 ELSE n = nMod
  150.                     IF aok(n, c, r) THEN
  151.                         temp = grid(c, r)
  152.                         grid(c, r) = -n
  153.                         resolve3 startN
  154.                         IF complete THEN EXIT SUB
  155.                         grid(c, r) = temp
  156.                     END IF
  157.                 NEXT
  158.                 EXIT SUB
  159.             END IF
  160.         NEXT
  161.     NEXT
  163.  
  164. FUNCTION aok (a, c, r) 'check to see if a is OK to place at (c, r)
  165.     aok = 0
  166.     IF grid(c, r) = 0 THEN 'check cell empty
  167.         FOR i = 0 TO 8 'check row and column
  168.             IF ABS(grid(i, r)) = a OR ABS(grid(c, i)) = a THEN EXIT FUNCTION
  169.         NEXT
  170.         cbase = INT(c / 3) * 3: rbase = INT(r / 3) * 3
  171.         FOR rr = 0 TO 2
  172.             FOR cc = 0 TO 2
  173.                 IF ABS(grid(cbase + cc, rbase + rr)) = a THEN EXIT FUNCTION
  174.             NEXT
  175.         NEXT
  176.         aok = 1
  177.     END IF
  179.  
  180. FUNCTION complete () 'grid finished ?
  181.     FOR r = 0 TO 8
  182.         FOR c = 0 TO 8
  183.             IF grid(c, r) = 0 THEN EXIT FUNCTION
  184.         NEXT
  185.     NEXT
  186.     complete = 1
  188.  
  189.  
  190.  

Here is results of puzzle that had multiple solutions (made from older version of Sudoku App that just systematically hid x amount of cells in each block:
Quote
500400070
009030200
010002004
050060020
600500700
007004005
080001007
001300050
200090400
++++++++++++++++++
5 2 3 4 8 6 1 7 9
7 4 9 1 3 5 2 8 6
8 1 6 9 7 2 5 3 4
4 5 8 7 6 3 9 2 1
6 3 2 5 1 9 7 4 8
1 9 7 8 2 4 3 6 5
3 8 4 2 5 1 6 9 7
9 6 1 3 4 7 8 5 2
2 7 5 6 9 8 4 1 3
++++++++++++++++++
5 2 3 4 8 6 9 7 1
7 4 9 1 3 5 2 8 6
8 1 6 9 7 2 5 3 4
4 5 8 7 6 3 1 2 9
6 3 2 5 1 9 7 4 8
1 9 7 8 2 4 3 6 5
3 8 4 2 5 1 6 9 7
9 6 1 3 4 7 8 5 2
2 7 5 6 9 8 4 1 3
++++++++++++++++++
5 3 2 4 8 6 9 7 1
7 4 9 1 3 5 2 8 6
8 1 6 9 7 2 5 3 4
3 5 4 7 6 9 1 2 8
6 2 8 5 1 3 7 4 9
1 9 7 8 2 4 3 6 5
4 8 3 2 5 1 6 9 7
9 6 1 3 4 7 8 5 2
2 7 5 6 9 8 4 1 3
++++++++++++++++++
5 6 2 4 8 9 1 7 3
7 4 9 1 3 5 2 6 8
8 1 3 6 7 2 5 9 4
1 5 4 7 6 8 3 2 9
6 9 8 5 2 3 7 4 1
3 2 7 9 1 4 6 8 5
4 8 6 2 5 1 9 3 7
9 7 1 3 4 6 8 5 2
2 3 5 8 9 7 4 1 6
++++++++++++++++++
5 2 6 4 8 9 1 7 3
7 4 9 1 3 5 2 8 6
3 1 8 6 7 2 5 9 4
1 5 4 7 6 8 3 2 9
6 9 2 5 1 3 7 4 8
8 3 7 9 2 4 6 1 5
4 8 3 2 5 1 9 6 7
9 6 1 3 4 7 8 5 2
2 7 5 8 9 6 4 3 1
++++++++++++++++++
5 3 2 4 8 6 1 7 9
7 4 9 1 3 5 2 8 6
8 1 6 9 7 2 5 3 4
1 5 4 7 6 9 3 2 8
6 9 8 5 2 3 7 4 1
3 2 7 8 1 4 6 9 5
4 8 3 2 5 1 9 6 7
9 6 1 3 4 7 8 5 2
2 7 5 6 9 8 4 1 3
++++++++++++++++++
5 6 2 4 8 9 1 7 3
7 4 9 1 3 5 2 8 6
8 1 3 6 7 2 5 9 4
1 5 4 8 6 7 3 2 9
6 9 8 5 2 3 7 4 1
3 2 7 9 1 4 8 6 5
4 8 6 2 5 1 9 3 7
9 7 1 3 4 8 6 5 2
2 3 5 7 9 6 4 1 8


And here is a puzzle copied from a Sudoku book that has one solution:
Quote
000001350
564039000
071000900
040120003
023040570
800063020
002000730
000450618
058300000
++++++++++++++++++
2 8 9 6 7 1 3 5 4
5 6 4 2 3 9 1 8 7
3 7 1 5 8 4 9 6 2
7 4 6 1 2 5 8 9 3
1 2 3 9 4 8 5 7 6
8 9 5 7 6 3 4 2 1
4 1 2 8 9 6 7 3 5
9 3 7 4 5 2 6 1 8
6 5 8 3 1 7 2 4 9


And here is an encouraging sign, I just tested a Level 8 puzzle created by my latest version of Sudoku App. Level 8 leaves in this case 25 clues and hiding 56 cells and still generates a puzzle with a single solution (at least by my test with code here).

Now the question is, is it solvable? I am too unskilled at Sudoku to tell. ;-))
 


PS, yeah I know, I can remove 3 redundant blocks of code with one GOSUB for restoring the grid back to gridCopy. :)
Title: Re: Sudoku solver
Post by: bplus on May 07, 2019, 04:30:42 pm
 2 in a row! Anyone want to give it a shot? :)
  [ This attachment cannot be displayed inline in 'Print Page' view ]  
Text Only | Text with Attachments