Sudoku: Difference between revisions
Content deleted Content added
Added PicoLisp |
Forth version added |
||
Line 292: | Line 292: | ||
foreach(row;puzzle) writefln("%s",row); |
foreach(row;puzzle) writefln("%s",row); |
||
}</lang> |
}</lang> |
||
=={{header|Forth}}== |
|||
{{works with|4tH|3.60.0}} |
|||
<lang forth>\ 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 |
|||
\ Modifier: David N. Williams |
|||
\ Email: robspyke_nospam@iprimus_no_spam.com.au |
|||
\ (delete the obvious) |
|||
\ 4tH version: 2005,2008 J.L. Bezemer |
|||
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</lang> |
|||
=={{header|Fortran}}== |
=={{header|Fortran}}== |
||
{{works with|Fortran|90 and later}} |
{{works with|Fortran|90 and later}} |
||
Line 422: | Line 801: | ||
|6 9 5|4 1 7|3 8 2| |
|6 9 5|4 1 7|3 8 2| |
||
+-----+-----+-----+ |
+-----+-----+-----+ |
||
=={{header|Haskell}}== |
=={{header|Haskell}}== |
||
Visit the Haskell wiki [http://haskell.org/haskellwiki/Sudoku Sudoku] |
Visit the Haskell wiki [http://haskell.org/haskellwiki/Sudoku Sudoku] |