Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

Fast Sudoku Solver - solves any solvable Sudoku puzzle

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • Fast Sudoku Solver - solves any solvable Sudoku puzzle

    ' Fast Sudoku Solver - solves any solvable Sudoku puzzle
    '
    ' Sudoku is a popular game these days:
    ' http://en.wikipedia.org/wiki/Sudoku
    '
    ' Sudoku can be represented as an exact cover matrix problem:
    ' http://en.wikipedia.org/wiki/Exact_cover
    ' An exact cover is a set of rows such that every column has a 1 in exactly one of the rows
    ' in the set.
    ' The exact cover problem is known to be NP-complete. In computational complexity theory,
    ' NP ("Non-deterministic Polynomial time") is the set of decision problems solvable in polynomial
    ' time on a non-deterministic Turing machine.
    ' http://en.wikipedia.org/wiki/List_of...plete_problems
    '
    ' Donald Knuth has proposed Algorithm X as a recursive, nondeterministic, depth-first,
    ' brute-force algorithm that finds all solutions to the exact cover problem:
    ' http://en.wikipedia.org/wiki/Algorithm_X
    '
    ' Donald Knuth also proposed the Dancing Links method, commonly known as DLX, as the technique
    ' to efficiently implement his Algorithm X. The goal is to choose a subset of the rows in the matrix
    ' so that the digit 1 appears in each column exactly once.
    ' http://en.wikipedia.org/wiki/Dancing_Links
    '
    ' His source code in C is available here:
    ' http://www-cs-staff.stanford.edu/~uno/programs/gdance.w
    ' It applies a circular doubly-linked list of nodes - a very elegant technique.
    '
    ' The present program applies another elegant technique to solve the exact cover problem, based
    ' on a code in C by Guenter Stertenbrink (sterten@aol.com) made public in these links:
    ' http://www.setbb.com/phpbb/viewtopic...&mforum=sudoku
    ' http://magictour.free.fr/suexco.txt
    '
    ' I thank Guenter Stertenbrink for his elegant and efficient code.
    '
    ' Best regards,
    '
    ' Erik Christensen -------------- April 16, 2006
    Code:
    #COMPILE EXE
    #DIM ALL
    #INCLUDE "WIN32API.INC"
    
    %IDD_DIALOG1  =  101
    %IDC_TEXTBOX1 = 1001
    %IDC_BUTTON1  = 1002
    %IDC_BUTTON2  = 1003
    '
    GLOBAL tx AS STRING
    GLOBAL hDlg AS LONG
    '
    DECLARE CALLBACK FUNCTION ShowDIALOG1Proc()
    DECLARE FUNCTION ShowDIALOG1(BYVAL hParent AS DWORD) AS LONG
    '
    FUNCTION PBMAIN()
        ShowDIALOG1 %HWND_DESKTOP
    END FUNCTION
    '
    SUB textt(BYREF B() AS LONG, BYREF tx AS STRING)
        STATIC s AS STRING, i AS LONG
        STATIC a AS LONG, k AS LONG, x AS LONG, y AS LONG
        DIM A(0 TO 80) AS LONG
        tx=tx+" Solution:"+$CRLF+" "
        k = -1
        FOR x = 1 TO 9
            FOR y = 1 TO 9
                INCR k
                A(k)= B(y,x)
            NEXT
        NEXT
        FOR i = 0 TO 80
            IF (i+1) MOD 3 = 0 AND (i+1) MOD 9 <> 0 THEN tx=tx+LTRIM$(STR$(A(i)))+" | " ELSE tx=tx+LTRIM$(STR$(A(i)))+"   "
            IF (i+1) MOD 9 = 0 THEN tx=tx+$CRLF+" "
            IF i = 26 OR i = 53 THEN tx=tx+STRING$(33,"-")+$CRLF+" "
        NEXT
        tx = tx +$CRLF
    END SUB
    
    SUB solve1(BYREF A() AS LONG, BYREF tx AS STRING)
        ' Based on the C code by Guenter Stertenbrink
        ' *******************************************
        ' Thanks very much for making your fine code available!
        ' *****************************************************
        ' Version 1 in this link: http://magictour.free.fr/suexco.txt 
        ' ***********************************************************
        '
        ' Explanation:
        ' For a standard sudoku we have a binary matrix A(729,324).
        ' Each row stands for a placement of one of the 9 symbols
        ' into one of the 81 cells. The columns stand for the constraints
        ' which must be met:
        ' (let Row,Column,Block,Cell with capital letters be those from
        ' the sudoku-board)
        '
        ' exactly one placement per Cell
        ' exactly one placement per Symbol and Column
        ' exactly one placement per Symbol and Row
        ' exactly one placement per Symbol and Block
        ' The rows (placements) are denoted e.g. "r1c2s3" or short "123"
        ' for: place Symbol 3 into Row 1,Column 2 .
        ' The columns (constraints) are denoted e.g. "b1s2"
        ' for Symbol 2 into Block 1 .
        '
        ' So the row representing the placement of symbol s into
        ' cell x,y has a one in columns:
        '
        ' cell(x,y)     = x*9-9+y
        ' block(x,y,s)  = (3*(x-1)\3+(y-1)\3)*9+s+81
        ' row(x,s)      = x*9-9+s+81*2
        ' column(y,s)   = y*9-9+s+81*3
        '
        ' Other encodings are possible. We use an encoding based on 1..9 which
        ' relates better to common sudoku notations rather than a system based
        ' on 0..8 which could be better for addressing the cells and blocks.
    
        ' We have a binary nRows*nCols matrix whose rows are indexed with r and columns with c.
        ' At step i a row and column is chosen from that matrix and an entry
        ' into the sudoku-matrix A(,) is computed from them.
        '
        ' A(1..9,1..9) contains the sudoku-grid. A(x,y)=0 if the cell (x,y) is empty.
        ' Rows(c) is the number of rows matching column c in the binary exact cover matrix.
        ' Row(c,i) , i=1..Rows(c) is the index of the i-th row, which matches column c.
        ' Cols(r) is the number of columns matching row r in the binary exact cover matrix.
        ' Col(r,i) , i=1..Cols(c) is the index of the i-th column, which matches row r.
        ' Ur(r) is zero, if row r has not yet been marked forbidden.
        ' Uc(c) is zero, if column c has not yet been marked forbidden.
        ' C(i) is the column chosen at step i.
        ' II(i) is the row chosen at step i.
        ' Node(i) counts how often A(,) was filled with i new entries in the process.
        '
        DIM Rows(1 TO 324) AS LONG, Cols(1 TO 729) AS LONG, Row(1 TO 324, 1 TO 9) AS LONG, _
            Col(1 TO 729, 1 TO 4) AS LONG, Ur(1 TO 729) AS LONG, Uc(1 TO 324) AS LONG
        DIM C(1 TO 81) AS LONG, II(1 TO 81) AS LONG, Node(1 TO 81) AS LONG
        LOCAL i, j, k, r, c, d, nRows, nCols, x, y, s  AS LONG
        nRows = 729 : nCols = 324
        LOCAL imax AS LONG, imin AS LONG, clues AS LONG, match AS LONG
                ' Generate the basic binary exact-cover-matrix,
                ' that is, not the matrix itself but the rows and columns
        r = 0
        FOR x=1 TO 9
            FOR y=1 TO 9
                FOR s=1 TO 9
                    INCR r
                    Cols(r) = 4
                    Col(r,1) = x * 9-9+y
                    Col(r,2) = (3 *((x - 1) \ 3) + (y - 1) \ 3) *9+s + 81
                    Col(r,3) = x * 9-9+s + 81 * 2
                    Col(r,4) = y * 9-9+s + 81 * 3
                NEXT
            NEXT
        NEXT
        FOR c=1 TO nCols
            Rows(c) = 0
        NEXT
        FOR r=1 TO nRows
            FOR c=1 TO Cols(r)
                x = Col(r,c)
                INCR Rows(x)
                Row(x,Rows(x)) = r
            NEXT
        NEXT
                ' Do the initial markings required by the given clues
        FOR i=1 TO nRows
            Ur(i) = 0
        NEXT
        FOR i=1 TO nCols
            Uc(i) = 0
        NEXT
        clues=0
        FOR x=1 TO 9
            FOR y=1 TO 9
                IF ISTRUE A(x,y) THEN
                    INCR clues
                    r = x * 81-81+y * 9-9+A(x,y)
                    FOR j=1 TO Cols(r)
                        d = Col(r,j)
                        INCR Uc(d)
                        FOR k=1 TO Rows(d)
                            INCR Ur(Row(d,k))
                        NEXT
                    NEXT
                END IF
            NEXT
        NEXT
                ' Backtrack through all subsets of the rows
        i = 0
      m2:       ' Next level. Compute the next entry
        INCR i
        IF i>81 THEN i = 81
        II(i) = 0
                ' Find the column c=C(i) with fewest matching rows, if empty column
                ' is found, then backtrack
        imin = nRows + 1
        FOR c=1 TO nCols
            IF (Uc(c) = 0) THEN
                match = 0
                FOR r=1 TO Rows(c)
                    IF (Ur(Row(c,r)) = 0) THEN INCR match
                NEXT
                IF (match < imin) THEN imin = match : C(i) = c
            END IF
        NEXT
        IF (imin = 0 OR imin > nRows) THEN GOTO m4
      m3:       ' Walk through all unmarked rows r matching column c=C(i)
        c = C(i)
        INCR II(i)
        IF (II(i) > Rows(c)) THEN GOTO m4
        r = Row(c,II(i))
        IF ISTRUE (Ur(r)) THEN GOTO m3
        x = (r - 1) \ 81+1
        y = ((r - 1) MOD 81) \ 9+1
        s = (r - 1) MOD 9+1
        A(x,y) = s
        IF (clues + i = 81) THEN textt(A(), tx) : EXIT SUB
                ' Delete all columns which match row r and all rows which match
                ' any of these columns
        FOR j=1 TO Cols(r)
            d = Col(r,j)
            INCR Uc(d)
            FOR k=1 TO Rows(d)
                INCR Ur(Row(d,k))
            NEXT
        NEXT
                ' Entry was made, matrix was updated, goto the next level
        INCR Node(i)
        GOTO m2
      m4:       ' Backtrack. Goto previous level, take back the last move
                ' restore the data as they were before that move and make the next
                ' available move at that level
        DECR i
        IF i<1 THEN i = 1
        c = C(i)
        r = Row(c,II(i))
        FOR j=1 TO Cols(r)
            d = Col(r,j)
            DECR Uc(d)
            FOR k=1 TO Rows(d)
                DECR Ur(Row(d,k))
            NEXT
        NEXT
        IF (i > 0) THEN GOTO m3
        tx = tx + "solutions"+ STR$(Node(81-clues))
    END SUB
    '
    CALLBACK FUNCTION ShowDIALOG1Proc()
        STATIC s AS STRING, i AS LONG
        STATIC a AS LONG, k AS LONG, x AS LONG, y AS LONG
        DIM A(0 TO 80) AS STATIC LONG
        DIM B(0 TO 10, 0 TO 10) AS STATIC LONG
        SELECT CASE AS LONG CBMSG
            CASE %WM_INITDIALOG
                      s="450000031800549007009103400790010026500090008006802700600030002070020050082000190"
                    ' s="041305290600010004059070630170080026002090800030000070800259007490000062020706080"
                    ' s="000000000300706005046000310000000000004030700800945006079603420030000080010000060"
                    ' s="000000000703000501506324907050401090090706030000000000005010600009050300000209000"
                    ' s="700406003006000700030000010300509002000802000020000090063000820008090300001060400"
                    ' s="600385004003000200000070000015000340004507600000030000058604710700000005060000080"
                    ' s="005010800400060003070493050700000009032000410001000500000000000150000047007604900"
                    ' s="080106050000090000029000460050403070400602005007000100300000002041000380000305000"
                    ' s="047806520100702009200305004700020001500030007020080060003000900000401000000060000"
                    ' s="009518000000000700000340050001009007060000504040800906070094001003000070000783400"
                    ' s=".2.4..6..5...8..........1...1.2....4....37....6.......3.8....7....1.....7........" ' one person's top 5
                    ' s="....3.5...4.7...........2...6.....7.....1..4.2...5......81...6.5.....3.....4....." ' one person's top 5
                    ' s=".2.5..7..6...9..........1...1.4....2....83....7.......3.9....8....1.....8........" ' one person's top 5
                    ' s="5......1....4..2...8.2......2....6......3..7.....1....1.3....5....6..4..7........" ' one person's top 5
                    ' s="3...8.......7....51..............36...2..4....7...........6.13..452...........8.." ' one person's top 5
                    ' s="400000805030000000000700000020000060000080400000010000000603070500200000104000000" ' top 4
                    ' s="520006000000000701300000000000400800600000050000000000041800000000030020008700000" ' top 4
                    ' s="600000803040700000000000000000504070300200000106000000020000050000080600000010000" ' top 4
                    ' s="480300000000000071020000000705000060000200800000000000001076000300000400000050000" ' top 4
                    ' s="700000400020070080003008009000500300060020090001007006000300900030040060009001005" ' toughest known sudoku
                    ' s="000000060007300900008900000071000000000000008800050604010200090200004000069000070" ' very difficult puzzle
                    ' s="019300000000094205030200009090000601040050090806000070600009010504830000000007420"
                    ' s="050030006080600047600085000000500038005000100790008000000320004420006080500070010"
                    ' s="000047500024609783000000064060090007940703016100080050450000000671204390008370000"
                    ' s="000100090900004010000039407403000120000050000026000308605470000080300006040005000"
                    ' s="000000000000000000000000000000000000000000000000000000000000000000000000000000000"  ' can fill a blank board. This can potentially - with some random function built-in - be used to construct Sudoku's.
                    tx = " Sudoku puzzle:" + $CRLF+" "
                    k = 0
                    FOR x = 1 TO 9
                        FOR y = 1 TO 9
                            INCR k
                            B(y,x)= VAL(MID$(s, k, 1))
                        NEXT
                    NEXT
                    REPLACE ANY "0" WITH "." IN s
                    FOR i = 0 TO 80
                       A(i)=VAL(MID$(s, i+1, 1))
                       IF (i+1) MOD 3 = 0 AND (i+1) MOD 9 <> 0 THEN tx=tx+ MID$(s, i+1, 1)+" | " ELSE tx=tx+ MID$(s, i+1, 1)+"   "
                       IF (i+1) MOD 9 = 0 THEN tx=tx+$CRLF+" "
                       IF i = 26 OR i = 53 THEN tx=tx+STRING$(33,"-")+$CRLF+" "
                    NEXT
                    tx = tx +$CRLF
                    CONTROL SET TEXT CBHNDL, %IDC_TEXTBOX1, tx
            CASE %WM_COMMAND
                SELECT CASE AS LONG CBCTL
                    CASE %IDC_TEXTBOX1
    
                    CASE %IDC_BUTTON1 ' solve
                        IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN
                            k=0
                            FOR x = 1 TO 9
                                FOR y = 1 TO 9
                                    IF B(y,x) > 0 THEN INCR k
                                NEXT
                            NEXT
                            IF k<81 THEN solve1(B(), tx)
                            CONTROL SET TEXT CBHNDL, %IDC_TEXTBOX1, tx
                        END IF
                    CASE %IDC_BUTTON2 ' exit
                        IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN
                            DIALOG END CBHNDL
                        END IF
                END SELECT
        END SELECT
    END FUNCTION
    '
    FUNCTION ShowDIALOG1(BYVAL hParent AS DWORD) AS LONG
        LOCAL lRslt AS LONG
        DIALOG NEW hParent, "Sudoku - Fast Code Solver", 70, 70, 292, 248, %WS_OVERLAPPED OR _
            %WS_BORDER OR %WS_DLGFRAME OR %WS_SYSMENU OR %WS_CLIPSIBLINGS OR _
            %WS_VISIBLE OR %DS_MODALFRAME OR %DS_3DLOOK OR %DS_NOFAILCREATE OR _
            %DS_SETFONT, %WS_EX_CONTROLPARENT OR %WS_EX_LEFT OR _
            %WS_EX_LTRREADING OR %WS_EX_RIGHTSCROLLBAR, TO hDlg
        CONTROL ADD BUTTON,  hDlg, %IDC_BUTTON1, "&Solve", 8, 230, 64, 14
        CONTROL ADD BUTTON,  hDlg, %IDC_BUTTON2, "E&xit", 220, 230, 64, 14
        CONTROL ADD TEXTBOX, hDlg, %IDC_TEXTBOX1, "", 8, 10, 274, 214, _
            %WS_CHILD OR %WS_VISIBLE OR %WS_TABSTOP OR %WS_VSCROLL OR %ES_LEFT _
            OR %ES_MULTILINE, %WS_EX_CLIENTEDGE OR _
            %WS_EX_LEFT OR %WS_EX_LTRREADING OR %WS_EX_RIGHTSCROLLBAR
        CONTROL SEND hDlg, %IDC_TEXTBOX1, %WM_SETFONT, GetStockObject(%ANSI_FIXED_FONT), %TRUE
        DIALOG SHOW MODAL hDlg, CALL ShowDIALOG1Proc TO lRslt
        FUNCTION = lRslt
    END FUNCTION
    [This message has been edited by Erik Christensen (edited April 17, 2006).]

  • #2
    Nice work - it is very fast. Two little bugs though:

    FOR i=0 TO nRows
    Ur(i) = 0
    NEXT
    FOR i=0 TO nCols
    Uc(i) = 0
    NEXT

    These loops should both start with 1 or the associated arrays
    should be 0-based.

    -Ian

    ------------------
    [SIZE="1"]Reprinted with correections.[/SIZE]

    Comment


    • #3
      Yes, thanks. This and some other issues are now corrected. Erik

      ------------------


      [This message has been edited by Erik Christensen (edited April 17, 2006).]

      Comment

      Working...
      X