! Based on http://www.ffconsultancy.com/ocaml/sudoku/index.html
USING: sequences namespaces kernel math math.parser io
-io.styles combinators ;
+io.styles combinators columns ;
IN: sudoku
SYMBOL: solutions
SYMBOL: board
-: pair+ swapd + >r + r> ;
+: pair+ ( a b c d -- a+b c+d ) swapd [ + ] 2bi@ ;
-: row board get nth ;
-: board> row nth ;
-: >board row set-nth ;
-: f>board f -rot >board ;
+: row ( n -- row ) board get nth ;
+: board> ( m n -- x ) row nth ;
+: >board ( row m n -- ) row set-nth ;
+: f>board ( m n -- ) f -rot >board ;
-: row-contains? ( n y -- ? ) row member? ;
-: col-contains? ( n x -- ? ) board get swap <column> member? ;
-: cell-contains? ( n x y i -- ? ) 3 /mod pair+ board> = ;
+: row-any? ( n y -- ? ) row member? ;
+: col-any? ( n x -- ? ) board get swap <column> member? ;
+: cell-any? ( n x y i -- ? ) 3 /mod pair+ board> = ;
-: box-contains? ( n x y -- ? )
+: box-any? ( n x y -- ? )
[ 3 /i 3 * ] bi@
- 9 [ >r 3dup r> cell-contains? ] contains?
- >r 3drop r> ;
+ 9 [ [ 3dup ] dip cell-any? ] any?
+ [ 3drop ] dip ;
DEFER: search
: assume ( n x y -- )
- [ >board ] 2keep [ >r 1+ r> search ] 2keep f>board ;
+ [ >board ] 2keep [ [ 1 + ] dip search ] 2keep f>board ;
: attempt ( n x y -- )
{
- { [ 3dup nip row-contains? ] [ 3drop ] }
- { [ 3dup drop col-contains? ] [ 3drop ] }
- { [ 3dup box-contains? ] [ 3drop ] }
+ { [ 3dup nip row-any? ] [ 3drop ] }
+ { [ 3dup drop col-any? ] [ 3drop ] }
+ { [ 3dup box-any? ] [ 3drop ] }
[ assume ]
} cond ;
-: solve ( x y -- ) 9 [ 1+ 2over attempt ] each 2drop ;
+: solve ( x y -- ) 9 [ 1 + 2over attempt ] each 2drop ;
: board. ( board -- )
standard-table-style [
: search ( x y -- )
{
- { [ over 9 = ] [ >r drop 0 r> 1+ search ] }
+ { [ over 9 = ] [ [ drop 0 ] dip 1 + search ] }
{ [ over 0 = over 9 = and ] [ 2drop solution. ] }
- { [ 2dup board> ] [ >r 1+ r> search ] }
+ { [ 2dup board> ] [ [ 1 + ] dip search ] }
[ solve ]
} cond ;