JB Sudoku Starter Solver (mainwin no GUI) bplus B = B + ... Offline This member has written at least 1,268 posts and created at least 154 threads on this forum since joining inApr 2017. 01-22-2018, 05:34 AM This post was last modified: 01-22-2018, 05:40 AM by bplus.Edited 0 times 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 bplus B = B + ... Offline This member has written at least 1,268 posts and created at least 154 threads on this forum since joining inApr 2017. 01-22-2018, 11:24 AM This post was last modified: 01-22-2018, 03:26 PM by bplus.Edited 0 times 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 « Next Oldest | Next Newest » 