( Title: Sudoku Solver File: sudoku.fs Author: Robert Spykerman Modifier: David N. Williams Version modified: 1900 01092005 License: ? Last revision: November 18, 2005 This source adds a word PUZZLE to input complete puzzles. It includes input stream and string extension words to support that, plus a definition of ((. See the example at the end. ANS Forth compatible except for case dependence. Modifications by dnw: 16Nov05 * Started coding. 17Nov05 * Released. 18Nov08 * Fixed some typos in comments. * Inserted ?CR in SKIP-PAST to make it and (( work across lines in interactive mode as well. ) \ ---------------------- \ Input Stream and (( \ ---------------------- : parse-area@ ( -- unparsed.s ) ( Leave the parse area portion of the input buffer as a string. Factored from Bernd Paysan's version of Frederick Warren's $>, comp.lang.forth, March, 2000. Named by Michael Gassanenko. "parse-area-fetch" ) source ( &inbuf #inbuf) >in @ ( #parsed) /string ; : parse-area! ( unparsed.s -- ) ( The unparsed.s string is assumed to lie at the end of the input buffer, in particular, if it is empty, its address is just after the end of the input buffer. Advance the input stream so that unparsed.s is the parse area. Named by Michael Gassanenko. "parse-area-store" ) ( addr len) source nip ( #tib) swap - >in ! ( addr) drop ; : ?cr ( -- ) source-id 0= IF cr THEN ; : skip-past ( s -- flag ) ( Advance the input stream to just after the next occurrence of the string and leave true, if found, skipping line ends. If the input is from a file and the string is not found before it ends, leave the input stream positioned there and leave false. If the input is from the terminal, execute the equivalent of CR at the end of each line where the string is not found. ) ( s) 2>r BEGIN parse-area@ 2r@ ( area.s s) search ( area.s false | &found #rem true) 0= WHILE \ not found ( area.s) 2drop ?cr refill 0= IF \ end of file ( s) 2r> 2drop false EXIT THEN REPEAT ( &found #rem) 2r> nip ( #s) /string parse-area! true ; : (( ( -- ) s" ))" skip-past drop ; IMMEDIATE (( Newsgroup: comp.lang.forth From: robert spykerman Date: Thu, 01 Sep 2005 18:53:01 +1000 Local: Thurs, Sep 1 2005 3:53 am Subject: Re: Sudoku puzzle solver A BETTER SOLVER ENGINE... Improved solving engine - uses a bit of intelligence as well as recursion, thanks to all of you, who suggested a more intelligent approach. The new solver finds a grid-position most likely to yield a good guess by looking at the number sets first, instead of just blindly thumping numbers in from start to end. 458 calls to solver versus 250,000+ initially... Win32forth hesitated a couple of seconds on the old one. Now it doesn't. Wow... Marcel, I haven't figured out your code yet, does yours do it in a similar way? )) \ ------------- SAMPLE RUN ( full source comes after) (( PUZZLE 0 9 0 ! 0 0 4 ! 0 0 7 0 0 0 ! 0 0 7 ! 9 0 0 8 0 0 ! 0 0 0 ! 0 0 0 ------+-------+------ 4 0 5 ! 8 0 0 ! 0 0 0 3 0 0 ! 0 0 0 ! 0 0 2 0 0 0 ! 0 0 9 ! 7 0 6 ------+-------+------ 0 0 0 ! 0 0 0 ! 0 0 4 0 0 3 ! 5 0 0 ! 0 0 0 2 0 0 ! 6 0 0 ! 0 8 0 \ OLD solver: solveit Solution Found 5 9 1 ! 2 8 4 ! 3 6 7 6 4 2 ! 3 5 7 ! 9 1 8 8 3 7 ! 9 6 1 ! 4 2 5 ------+-------+------ 4 7 5 ! 8 2 6 ! 1 9 3 3 6 9 ! 7 1 5 ! 8 4 2 1 2 8 ! 4 3 9 ! 7 5 6 ------+-------+------ 7 5 6 ! 1 9 8 ! 2 3 4 9 8 3 ! 5 4 2 ! 6 7 1 2 1 4 ! 6 7 3 ! 5 8 9 Elapsed Time: 547 msec Depth : 61 Calls : 254393 ok \ NEW solver: solveit Solution Found 5 9 1 ! 2 8 4 ! 3 6 7 6 4 2 ! 3 5 7 ! 9 1 8 8 3 7 ! 9 6 1 ! 4 2 5 ------+-------+------ 4 7 5 ! 8 2 6 ! 1 9 3 3 6 9 ! 7 1 5 ! 8 4 2 1 2 8 ! 4 3 9 ! 7 5 6 ------+-------+------ 7 5 6 ! 1 9 8 ! 2 3 4 9 8 3 ! 5 4 2 ! 6 7 1 2 1 4 ! 6 7 3 ! 5 8 9 Elapsed Time: 15 msec Depth : 61 Calls : 458 )) \ ------------- SOURCE \ Sudoku Solver in Forth. \ No special extensions were used. \ Tested on in win32forth, VFX and Swift (evaluation). \ No locals were harmed during this experiment. \ \ Version: 1900 01092005 - Robert Spykerman \ email: robspyke_nospam@iprimus_no_spam.com.au \ (delete the obvious) \ \ Input added 17Nov2005 by David N. Williams \ --------------------- \ Variables \ --------------------- create sudokugrid 81 chars allot \ PUZZLE fills this in create sudoku_row 9 cells allot create sudoku_col 9 cells allot create sudoku_box 9 cells allot 1024 allot \ just to be sure there is no cache issue. \ --------------------- \ Logic \ --------------------- \ Basically : \ Grid is parsed. All numbers are put into sets, which are \ implemented as bitmaps (sudoku_row, sudoku_col, sudoku_box) \ which represent sets of numbers in each row, column, box. \ only one specific instance of a number can exist in a \ particular set. \ \ SOLVER is recursively called \ SOLVER looks for the next best guess using FINDNEXTSPACE \ tries this trail down... if fails, backtracks... and tries \ again. \ \ Grid Related : xy 9 * + ; \ x y -- offset ; : getrow 9 / ; : getcol 9 mod ; : getbox dup getrow 3 / 3 * swap getcol 3 / + ; \ Puts and gets numbers from/to grid only : setnumber sudokugrid + c! ; \ n position -- : getnumber sudokugrid + c@ ; \ : getnumber sudokugrid swap + c@ ; : cleargrid sudokugrid 81 + sudokugrid do 0 i c! loop ; \ : cleargrid sudokugrid 81 0 do dup i + 0 swap c! loop drop ; \ -------------- \ Set related: sets are sudoku_row, sudoku_col, sudoku_box \ ie x y -- ; adds x into bitmap y : addbits_row cells sudoku_row + dup @ rot 1 swap lshift or swap ! ; : addbits_col cells sudoku_col + dup @ rot 1 swap lshift or swap ! ; : addbits_box cells sudoku_box + dup @ rot 1 swap lshift or swap ! ; \ : addbits_row 1 rot lshift swap cells sudoku_row + dup @ rot or swap ! ; \ : addbits_col 1 rot lshift swap cells sudoku_col + dup @ rot or swap ! ; \ : addbits_box 1 rot lshift swap cells sudoku_box + dup @ rot or swap ! ; \ ie x y -- ; remove number x from bitmap y : removebits_row cells sudoku_row + dup @ rot 1 swap lshift invert and swap ! ; : removebits_col cells sudoku_col + dup @ rot 1 swap lshift invert and swap ! ; : removebits_box cells sudoku_box + dup @ rot 1 swap lshift invert and swap ! ; \ : removebits_row 1 rot lshift swap cells sudoku_row + dup @ rot invert and swap ! ; \ : removebits_col 1 rot lshift swap cells sudoku_col + dup @ rot invert and swap ! ; \ : removebits_box 1 rot lshift swap cells sudoku_box + dup @ rot invert and swap ! ; \ clears all bitsmaps to 0 : clearbitmaps 9 0 do i cells 0 over sudoku_row + ! 0 over sudoku_col + ! 0 swap sudoku_box + ! loop ; \ Adds number to grid and sets : addnumber \ number position -- 2dup setnumber 2dup getrow addbits_row 2dup getcol addbits_col getbox addbits_box ; \ Remove number from grid, and sets : removenumber \ position -- dup getnumber swap 2dup getrow removebits_row 2dup getcol removebits_col 2dup getbox removebits_box nip 0 swap setnumber ; \ gets bitmap at position, ie \ position -- bitmap : getrow_bits getrow cells sudoku_row + @ ; : getcol_bits getcol cells sudoku_col + @ ; : getbox_bits getbox cells sudoku_box + @ ; \ position -- composite bitmap (or'ed) : getbits dup >r getrow_bits r@ getcol_bits r> getbox_bits or or \ dup getrow_bits \ over getcol_bits \ rot getbox_bits or or ; \ algorithm from c.l.f circa 1995 ? Will Baden : countbits ( number -- bits ) [ HEX ] DUP 55555555 AND SWAP 1 RSHIFT 55555555 AND + DUP 33333333 AND SWAP 2 RSHIFT 33333333 AND + DUP 0F0F0F0F AND SWAP 4 RSHIFT 0F0F0F0F AND + [ DECIMAL ] 255 MOD ; \ Try tests a number in a said position of grid \ Returns true if it's possible, else false. : try \ number position -- true/false getbits 1 rot lshift and 0= \ over 1 swap lshift \ over getbits and 0= rot rot 2drop ; \ -------------- : parsegrid \ Parses Grid to fill sets.. Run before solver. sudokugrid \ to ensure all numbers are parsed into sets/bitmaps 81 0 do dup i + c@ dup if dup i try if i addnumber else unloop drop drop FALSE exit then else drop then loop drop TRUE ; \ Morespaces? manually checks for spaces ... \ Obviously this can be optimised to a count var, done initially \ Any additions/subtractions made to the grid could decrement \ a 'spaces' variable. : morespaces? 0 sudokugrid 81 + sudokugrid do i c@ 0= if 1+ then loop ; \ 0 81 0 do sudokugrid i + c@ 0= if 1+ then loop ; : findnextmove \ -- n ; n = index next item, if -1 finished -1 10 \ index prev_possibilities -- \ err... yeah... local variables, kind of 81 0 do i sudokugrid + c@ 0= IF i getbits countbits 9 swap - \ get bitmap and see how many possibilities \ stack diagram: \ index prev_possibilities new_possiblities -- 2dup > if \ if new_possibilities < prev_possibilities nip nip i swap \ new_index new_possibilies -- else \ else prev_possibilities < new possibilities, so: drop \ new_index new_possibilies -- then THEN loop drop ; \ findnextmove returns index of best next guess OR returns -1 \ if no more guesses. You then have to check to see if there are \ spaces left on the board unoccupied. If this is the case, you \ need to back up the recursion and try again. : solver findnextmove dup 0< if morespaces? if drop false exit else drop true exit then then 10 1 do i over try if i over addnumber recurse if drop unloop TRUE EXIT else dup removenumber then then loop drop FALSE ; \ SOLVER : startsolving clearbitmaps \ reparse bitmaps and reparse grid parsegrid \ just in case.. solver AND ; \ --------------------- \ Display Grid \ --------------------- \ \ Prints grid nicely \ : .sudokugrid CR CR sudokugrid 81 0 do dup i + c@ . ." " i 1+ dup 3 mod 0= if dup 9 mod 0= if CR dup 27 mod 0= if dup 81 < if ." ------+-------+------" CR then then else ." ! " then then drop loop drop CR ; \ --------------------- \ Higher Level Words \ --------------------- : checkifoccupied \ offset -- t/f sudokugrid + c@ ; : add \ n x y -- xy 2dup dup checkifoccupied if dup removenumber then try if addnumber .sudokugrid else CR ." Not a valid move. " CR 2drop then ; : rm xy removenumber .sudokugrid ; : clearit cleargrid clearbitmaps .sudokugrid ; : solveit CR CR startsolving if ." Solution Found " CR .sudokugrid else ." No Solution Found " CR CR then ; : showit .sudokugrid ; \ Print help menu : help CR ." Type clearit ; to clear grid " CR ." 1-9 x y add ; to add 1-9 to grid at x y (0 based) " CR ." x y rm ; to remove number at x y " CR ." showit ; redisplay grid " CR ." solveit ; to solve " CR ." help ; for help " CR ." puzzle ; make a new puzzle from the next" CR ." ; 81 whitespace delimited digits" CR CR ; \ ---------------------- \ Full Puzzle Input \ ---------------------- (( This section added by David N. Williams. It might be a bit shorter with a different implementation of PARSE-NAME, e.g., the reference implementation mentioned here: http://www.complang.tuwien.ac.at/forth/ansforth/parse-name.html But we have found the factors used to define it below generally useful. )) : bl-skip ( addr len -- addr+i len-i ) \ Wil Baden BEGIN dup WHILE over c@ bl <= WHILE 1 /string REPEAT THEN ; : bl-scan ( addr len -- addr+i len-i ) \ Wil Baden BEGIN dup WHILE over c@ bl > WHILE 1 /string REPEAT THEN ; : sfirst-word ( s -- word.s ) (( Leave the first word in the string s = [addr len]. If there is none, word.s = [addr+len,0]. )) bl-skip 2dup bl-scan nip - ; : safter ( s s' -- after.s) (( Assume s' to be a substring of s. Leave after.s, the substring of s that follows s'. The calculation is after.s = [addr'+len',len-len'-addr'+addr]. )) + rot rot + ( addr'+len' addr+len) over - ; : sparse-word ( s -- after.s word.s ) (( Leave word.s as a substring of s, the first word token in s. Leave after.s as the substring of s following word.s, skipping the first of any leading white-space characters, in line with the ANS Forth notion of parsing. If after.s is empty, its address is just after the end of s. If word.s is empty, its address is also just after the end of s. )) 2dup sfirst-word 2dup 2>r safter ( after.len) dup IF 1 /string THEN 2r> ; : parse-name ( -- word.s ) parse-area@ sparse-word 2swap parse-area! ; : next-word ( -- word.s ) \ Wil Baden (( Parse the next word from the input stream across lines. If word.s is empty, at most white-space was found. A parsing implementation of Wil Baden's word with CR's when lines are entered interactively at the terminal. )) BEGIN parse-name dup IF EXIT THEN ?cr refill WHILE 2drop REPEAT ; : is-digit-s ( addr len -- digit flag ) (( Leave true and the value if the input string is a single decimal digit, else leave false with digit undefined. Based on Wil Baden's IS-DIGIT. )) 1 = IF c@ [char] 0 - dup 10 u< ELSE false THEN ; : puzzle ( "digit_1...digit_81}" -- ) sudokugrid 81 0 DO next-word is-digit-s 0= ABORT" ***Illegal or missing decimal digit!" over c! char+ LOOP ( &sudokugrid) drop ; \ --------------------- \ Execution starts here \ --------------------- puzzle 0 9 0 0 0 4 0 0 7 0 0 0 0 0 7 9 0 0 8 0 0 0 0 0 0 0 0 4 0 5 8 0 0 0 0 0 3 0 0 0 0 0 0 0 2 0 0 0 0 0 9 7 0 6 0 0 0 0 0 0 0 0 4 0 0 3 5 0 0 0 0 0 2 0 0 6 0 0 0 8 0 : godoit CR clearbitmaps parsegrid if CR ." Grid in source valid. " else CR ." Warning: Grid in source invalid. " then .sudokugrid help ; godoit \ ------------- END SOURCE