include lib/interprt.4th include lib/istype.4th include lib/argopen.4th \ --------------------- \ Variables \ --------------------- 81 string sudokugrid 9 array sudoku_row 9 array sudoku_col 9 array sudoku_box \ ------------- \ 4tH interface \ ------------- : >grid ( n2 a1 n1 -- n3) rot dup >r 9 chars * sudokugrid + dup >r swap 0 do ( a1 a2) over i chars + c@ dup is-digit ( a1 a2 c f) if [char] 0 - over c! char+ else drop then loop ( a1 a2) nip r> - 9 / r> + ( n3) ; 0 s" 090004007" >grid s" 000007900" >grid s" 800000000" >grid s" 405800000" >grid s" 300000002" >grid s" 000009706" >grid s" 000000004" >grid s" 003500000" >grid s" 200600080" >grid drop \ --------------------- \ 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@ ; : cleargrid sudokugrid 81 bounds do 0 i c! loop ; \ -------------- \ 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 ! ; \ 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 ! ; \ 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 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= ; \ -------------- : 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 bounds do 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 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 CR ; \ --------------------- \ Execution starts here \ --------------------- : godoit clearbitmaps parsegrid if CR ." Grid valid!" else CR ." Warning: grid invalid!" then .sudokugrid help ; \ ------------- \ 4tH interface \ ------------- : read-sudoku input 1 arg-open 0 begin dup 9 < while refill while 0 parse >grid repeat drop close ; : bye quit ; create wordlist \ dictionary ," clearit" ' clearit , ," add" ' add , ," rm" ' rm , ," showit" ' showit , ," solveit" ' solveit , ," quit" ' bye , ," exit" ' bye , ," bye" ' bye , ," q" ' bye , ," help" ' help , NULL , wordlist to dictionary :noname ." Unknown command '" type ." '" cr ; is NotFound \ sudoku interpreter : sudoku argn 1 > if read-sudoku then godoit begin ." OK" cr refill drop ['] interpret catch if ." Error" cr then again ; sudoku