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

Simple Sudoku solving code

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

  • Simple Sudoku solving code

    ' compact sudoku solving code
    '
    ' sudoku is quite popular these days.
    'http://en.wikipedia.org/wiki/sudoku
    '
    ' i am mainly interested in the programming aspect.
    '
    ' recently i came across this very compact and highly interesting code in perl
    ' for solving sudoku puzzles.
    '
    ' [quote]
    'perl sudoku solver in three lines:
    'http://www.ecclestoad.co.uk/blog/200...explained.html
    '
    Code:
    ' use integer;@a=split//,<>;sub r{for$i(0..80){next if$a[$i];my%t=map{$_/9
    ' ==$i/9| |$_%9==$i%9| |$_/27==$i/27&&$_%9/3==$i%9/3?$a[$_]:0=>1}0..80;r($a[
    ' $i]=$_)for grep{!$t{$_}}1..9;return$a[$i]=0}die@a}r
    '</font>
    '
    ' i was quite intrigued by this simple code made by using this
    ' high level programming language.
    '
    ' just for fun i produced the following code in powerbasic based on
    ' the perl code above.
    '
    ' the display can be improved. this i will leave to you.
    ' i just wanted to demonstrate how any solvable sudoku puzzle can be solved
    ' using this simple brute force backtracking recursive code. although the code
    ' is quite fast, there may still be room for improvement.
    ' thanks to edmund von der burg for his perl code (see link above).
    '
    ' april 10, 2006
    '
    ' best regards
    '
    ' erik
    '
    ' p.s. previous discussion leading to this code can be seen here:
    ' http://www.powerbasic.com/support/pb...ad.php?t=21942
    Code:
    #compile exe
    #dim all
    '
    #include "win32api.inc"
    '
    %idd_dialog1  =  101
    %idc_textbox1 = 1001
    %idc_button1  = 1002
    %idc_button2  = 1003
    '
    ' this is the compact perl sudoku solving code by edmund von der burg
    ' translated to pb with some additions
    function r(byref a() as long) as long
       local i as long, j as long, k as long, s as long
       dim t(1 to 9) as long
       for i = 0 to 80
          if isfalse a(i) then                                          ' cell i is empty
             reset t()
             for s = 0 to 80
                 if istrue a(s) then                                    ' number present in cell s (this if statement was added april 12)
                    if istrue (s\9 = i\9) _                             ' s in same row as i ?
                    or _                                                ' or
                    (s mod 9 = i mod 9) _                               ' s in same column as i ?
                    or _                                                ' or
                    ((s\27 = i\27) and ((s mod 9)\3 = (i mod 9)\3)) _   ' s in same block as i ?
                    then t(a(s)) = a(s)                                 ' if yes, then record this used number
                 end if
             next
             for k = 1 to 9                                             ' test unused numbers
                 if isfalse t(k) then
                     a(i)=k : if istrue r(a()) then goto nex            ' this number was useful and was set in this cell
                 end if
             next
             a(i)= 0 : function = 0 : exit function                     ' could not set a number here - then exit this recursion
          end if
       nex:
       next
       function = 1
    end function
    '
    function showdialog1(byval hparent as dword) as long
        local lrslt as long, hdlg as long
        dialog new hparent, "sudoku - compact 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, "&start solving", 8, 230, 64, 14
        control add button,  hdlg, %idc_button2, "e&xit", 220, 230, 64, 14
        control add textbox, hdlg, %idc_textbox1, "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
    '
    callback function showdialog1proc()
        static s as string, i as long
        static tx as string
        dim a(0 to 80) as static long
        select case as long cbmsg
            case %wm_initdialog
                    ' s="000000060007300900008900000071000000000000008800050604010200090200004000069000070" ' very difficult puzzle - takes some minutes to solve. be patient!
                    ' s="090700860031005020806000000007050006000307000500010700000000109020600350054008070" ' difficult
                    ' 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 sudokus.
                   tx = " sudoku puzzle:" + $crlf+" "
                   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
                   replace "0" with "-" in tx
                   control set text cbhndl, %idc_textbox1, tx
            case %wm_command
                select case as long cbctl
                    case %idc_textbox1
    
                    case %idc_button1 ' start
                        if cbctlmsg = %bn_clicked or cbctlmsg = 1 then
                            mouseptr 11
                            r(a())
                            mouseptr 1
                            tx=tx+" solution:"+$crlf+" "
                            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
                            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 select
        end select
    end function
    '
    function pbmain()
        showdialog1 %hwnd_desktop
    end function



    [this message has been edited by erik christensen (edited april 12, 2006).]

  • #2
    Erik,
    your code looks very intersting.
    Do you have a PB/CC version of it by any chance?
    Regards,
    Gert.
    Gert Voland

    Comment


    • #3
      No, sorry, but it should not be too difficult to transform it to
      PB/CC. Just the interphase should be different. The solving routine
      FUNCTION R should be unchanged. Good luck with the transformation.

      Best regards,

      Erik


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

      Comment


      • #4
        There is a PBCC version in the PROGRAMMING section that has been
        donated.



        ------------------
        John
        support AT scriptbasic DOT org

        Comment


        • #5
          What am I doing wrong ?

          What am I doing wrong ?
          I think I have translated correctly but the result is not right?
          Tried to print and follow the values but can't find fault.
          Could it be that the recursive call that bothered ? In that case, I do not know how I was going around this?
          Can someone give me a tip or explanation?

          Thanks in advance

          Code:
          #COMPILE EXE
          #DIM ALL
          '
          #INCLUDE "win32api.inc"
          '
          %idd_dialog1  =  101
          %idc_textbox1 = 1001
          %idc_button1  = 1002
          %idc_button2  = 1003
          
          %start_grid   = 3000
          %start_vari   = 4000
          
          FUNCTION ra(hndl AS LONG ) AS LONG
             LOCAL i, j,k,q,s,w AS LONG
             LOCAL sTmp, Tmp AS STRING
             LOCAL iTmp,jTmp,kTmp AS LONG
          
              WHILE i <= 80
                CONTROL GET TEXT hndl, %start_grid+i TO sTmp :iTmp = VAL(sTmp)
                  IF iTmp = 0 THEN                                          ' cell i is empty
          
                      FOR q=1 TO 9 : CONTROL SET TEXT HNDL,%start_vari+q, "0" : NEXT
                      DIALOG DOEVENTS
          
                      WHILE s <=80
                           CONTROL GET TEXT hndl, %start_grid+s TO sTmp :jTmp = VAL(sTmp)
                           IF jTmp > 0 THEN
                                  IF ISTRUE (s\9 = i\9) _                             ' s in same row as i ?
                                  OR _                                                ' or
                                  (s MOD 9 = i MOD 9) _                               ' s in same column as i ?
                                  OR _                                                ' or
                                  ((s\27 = i\27) AND ((s MOD 9)\3 = (i MOD 9)\3)) _   ' s in same block as i ?
                                  THEN
                                       CONTROL SET TEXT hndl, %start_vari+jTmp, TRIM$(jTmp)
                                       DIALOG DOEVENTS
                                       tmp="" : FOR w=1 TO 9: CONTROL GET TEXT hndl, %start_vari+w TO sTmp: tmp += "|" & sTmp: NEXT
                                       PRINT#3,i,s,%start_vari+jTmp, TRIM$(jTmp), tmp
                                  END IF
                           END IF
                          s=s+1
                       WEND
                       k=1
                       WHILE k <= 9
                           CONTROL GET TEXT hndl, %start_vari+k TO sTmp :kTmp = VAL(sTmp)
          
                           tmp="" : FOR w=1 TO 9: CONTROL GET TEXT hndl, %start_vari+w TO sTmp: tmp += "|" & sTmp: NEXT
                           print#3, STR$(i) & "|" & STR$(s) &"|" & "|" & str$(k) &"|" & STR$(kTmp) &" > " & tmp
                                                                      ' test unused numbers
                           IF kTmp = 0 THEN
                               CONTROL SET TEXT hndl, %start_grid+i, TRIM$(k)
                               DIALOG DOEVENTS
                               IF ISTRUE ra(hndl) THEN GOTO nex            ' this number was useful and was set in this cell
                           END IF
                          k=k+1
                       WEND
                       ' could not set a number here - then exit this recursion
                       CONTROL SET TEXT hndl, %start_grid+i, "0"  :FUNCTION = 0 :EXIT FUNCTION
                       DIALOG DOEVENTS
                                         
                  END IF
             nex:
                 i = i +1
             WEND   ' i
             FUNCTION = 1
          END FUNCTION
          '
          FUNCTION showdialog1(BYVAL hparent AS DWORD) AS LONG
              LOCAL lrslt AS LONG, hdlg AS LONG
              DIALOG NEW hparent, "sudoku - compact 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, "&start solving", 8, 230, 64, 14
              CONTROL ADD BUTTON,  hdlg, %idc_button2, "e&xit", 220, 230, 64, 14
              CONTROL ADD TEXTBOX, hdlg, %idc_textbox1, "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
          '
          CALLBACK FUNCTION showdialog1proc()
              STATIC s, tx AS STRING
              LOCAL hdlg, x, y, i AS LONG
          
              SELECT CASE AS LONG CBMSG
                  CASE %WM_INITDIALOG
                          ' s="000000060007300900008900000071000000000000008800050604010200090200004000069000070" ' very difficult puzzle - takes some minutes to solve. be patient!
                          ' s="090700860031005020806000000007050006000307000500010700000000109020600350054008070" ' difficult
                          ' s="019300000000094205030200009090000601040050090806000070600009010504830000000007420"
                          ' s="050030006080600047600085000000500038005000100790008000000320004420006080500070010"
                          ' s="000047500024609783000000064060090007940703016100080050450000000671204390008370000"
                          ' s="000100090900004010000039407403000120000050000026000308605470000080300006040005000"
                            s="100000000000000000000000000000000000000000000000000000000000000000000000000000000"
                           ' s="000000000000000000000000000000000000000000000000000000000000000000000000000000000"  ' can fill a blank board. this can potentially - with some random function built-in - be used to construct sudokus.
                         tx = "" + $CRLF+" "
                         ' Setup box for value
                         FOR i = 0 TO 80
                             x= (i MOD 9 )* 14
                             IF (i MOD 9 )=0 THEN y += + 15
                             CONTROL ADD TEXTBOX, CBHNDL, %start_grid+i, MID$(s, i+1, 1), x+10, y+1, 12, 12
                         NEXT
                         ' setup used/unused numbers 
                         FOR i=1 TO 9
                            CONTROL ADD TEXTBOX, CBHNDL,%start_vari+i, "0", i*14+ 130, 15,12,12
                         NEXT
                         tx = tx +$CRLF
                         REPLACE "0" WITH "-" IN tx
                         CONTROL SET TEXT CBHNDL, %idc_textbox1, tx
                  CASE %WM_COMMAND
                      SELECT CASE AS LONG CBCTL
                          CASE %idc_textbox1
          
                          CASE %idc_button1 ' start
                              IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN
                                 
                                  OPEN "ut_while.txt" FOR OUTPUT AS #3
                                     ra( cbhndl )                    
                                  CLOSE#3
                                  ? "DONE"
                              END IF
                          CASE %idc_button2 ' exit
                              IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN DIALOG END CBHNDL
                      END SELECT
              END SELECT
          END FUNCTION
          '
          FUNCTION PBMAIN()
              showdialog1 %HWND_DESKTOP
          END FUNCTION

          Comment


          • #6
            Janne,

            It could be that the stack is too small. A large number of recursions will be necessary in this program - and this demands a large stack.

            At the beginning of the program you can insert this metastatement:

            #STACK num_expr

            Try using: #STACK 1000000 - or may be an even larger number.

            See also the discussion at this link: http://www.powerbasic.com/support/pb...ad.php?t=21942

            Best regards

            Erik

            http://ecstep.com/
            http://sudoku-instructions.com/
            http://know-facts.com/about-nutrition.html


            P.S. I should add that the code is slow - because it uses a brute force method applying a very large number of recursions. The only virtue of the source code is that it is short.

            Here is another much more elegant and very fast source code, which I think you will like: https://powerbasic.com/support/pbfor...ad.php?t=24890

            Erik
            Last edited by Erik Christensen; 28 Sep 2015, 10:13 AM.

            Comment


            • #7
              Hello Erik,
              Thanks for your tips, unfortunately it did not help to increase the stack.
              The reason was to try to understand, because it looks like simple and so extremely small.

              Thanks again
              Janne

              Comment


              • #8
                Erik's SUDOKU code in PBCC6.04 and with a realtime display of solution development

                ...and added iteration count for each puzzle in his code.

                Code:
                ' Erik Christensen's Simple Sudoku solving code modified for PBCC6.04  and with a realtime window showing solution development
                #compile exe
                #break on
                #dim all
                #include "win32api.inc"
                
                function pbmain()
                   global s as string, i as long
                   global tx as string
                   dim a(0 to 80) as static long
                   dim  L AS LONG, K as long
                   global TLLY as long, LIN AS LONG
                
                '   s="000000060007300900008900000071000000000000008800050604010200090200004000069000070" ' very difficult puzzle - takes some minutes to solve. be patient!
                '                                                                                         17,988,796 recursive iterations !
                   s="090700860031005020806000000007050006000307000500010700000000109020600350054008070" ' difficult... 10,924 iterations
                '   s="019300000000094205030200009090000601040050090806000070600009010504830000000007420"  ' 256 iterations
                '   s="050030006080600047600085000000500038005000100790008000000320004420006080500070010"  ' 8,079 iterations
                '   s="000047500024609783000000064060090007940703016100080050450000000671204390008370000"  ' 73 iterations
                '   s="000100090900004010000039407403000120000050000026000308605470000080300006040005000"  ' 9,597 iterations
                '   s="000000000000000000000000000000000000000000000000000000000000000000000000000000000"  ' can fill a blank board. this can potentially - with some random function built-in - be used to construct sudokus.
                
                '   s="000400900300000800009050001000005206004200000073040000067001000500700000080602300"   ' 27,581
                
                   for i = 0 to 80
                      a(i)=val(mid$(s, i+1, 1))
                   next i
                
                   tx = " sudoku puzzle:" + $crlf+" "
                   GOSUB PRNTIT
                   LIN = CURSORY + 1
                
                   r(a())
                
                   locate lin, 1
                   tx=" solution:"+$crlf+" "
                   GOSUB PRNTIT
                ?  ">>>"; TLLY; "<<<";
                   waitkey$
                   exit function
                
                PRNTIT:
                   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              only 24 lines available in the IDE box
                   replace "0" with "-" in tx
                   K = 1
                   DO
                      L = INSTR(K, tx, $crlf)
                      IF L = 0 THEN EXIT DO
                      IF K <> 1 THEN ?
                      ? MID$(tx, K, L - K);
                      K = L + 2
                   LOOP WHILE K < LEN(tx)
                RETURN
                end function
                
                function r(byref a() as long) as long
                  local i as long, j as long, k as long, s as long, n as long
                  dim t(1 to 9) as long
                  dim  L AS LONG
                  global TLLY as long, LIN as long
                        GOTO rMAIN
                '*****
                PRNTITr:
                   locate lin, 1
                   tx=" solution:"+$crlf+" "
                   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
                   replace "0" with "-" in tx
                   K = 1:
                   DO:
                      L = INSTR(K, tx, $crlf):
                      IF L = 0 THEN EXIT DO:
                      IF K <> 1 THEN ?
                      ? MID$(tx, K, L - K);
                      K = L + 2:
                   LOOP WHILE K < LEN(tx)
                   ?  ">>>"; TLLY; "<<<";
                RETURN
                
                '*****
                rMAIN:
                         INCR TLLY
                '   IF (TLLY MOD 10000) = 1 THEN
                '   IF (TLLY MOD 10) = 1 THEN
                      GOSUB PRNTITr
                      SLEEP 100
                '   END IF
                
                   for i = 0 to 80                 ' scan to 1st or next empty cell
                      if isfalse a(i) then                                        ' cell i is empty
                         reset t()
                
                         for s = 0 to 80           ' scan for occupied cell
                            if istrue a(s) then                                   ' cell s is occupied
                               if istrue (s\9 = i\9) _                            ' s in same row as i ?
                                or _                                                ' or
                               (s mod 9 = i mod 9) _                              ' s in same column as i ?
                                or _                                                ' or
                               ((s\27 = i\27) and ((s mod 9)\3 = (i mod 9)\3)) _  ' s in same block as i ?
                                then t(a(s)) = a(s)                                 ' if yes, then record this used number
                            end if
                         next
                
                         for k = 1 to 9                                             ' test unused numbers
                            if isfalse t(k) then
                               a(i)=k            'INSERT SINGLE NUMBER IN SUDOKU
                                if istrue r(a()) then goto nex            ' set this unused number in this cell
                '                         ^^^^^  <<<<<< recursion w/ each new iinsertion  <<<<<<<<<
                            end if
                         next
                         a(i)= 0 : function = 0 : exit function           ' could not set a number here - then exit this recursion
                      end if
                nex:
                
                   next
                   function = 1
                end function

                Comment


                • #9
                  Erik,
                  Thanks for the code. I don't recall that I put a "Solve" in my gbSudoku app. When I get some time I'll take a closer look at your code!

                  Comment


                  • #10
                    Rudy, thanks for calculating the number of recursions needed for the few sudoku puzzles in the program. The monstrously high number of recursive calls needed for the most difficult puzzle shows the inadequacy of the method - even though it is simple.

                    Gary, you are welcome.

                    Comment

                    Working...
                    X