1 ! Based on http://www.ffconsultancy.com/ocaml/sudoku/index.html
2 USING: columns combinators combinators.short-circuit generalizations io
3 io.styles kernel math math.parser namespaces sequences ;
9 : pair+ ( a b c d -- a+b c+d ) swapd [ + ] 2bi@ ;
11 : row ( n -- row ) board get nth ;
12 : board> ( m n -- x ) row nth ;
13 : >board ( row m n -- ) row set-nth ;
15 : row-any? ( n y -- ? ) row member? ;
16 : col-any? ( n x -- ? ) board get swap <column> member? ;
17 : cell-any? ( n x y i -- ? ) 3 /mod pair+ board> = ;
19 : box-any? ( n x y -- ? )
20 [ 3 /i 3 * ] bi@ 9 iota [ cell-any? ] 3 nwith any? ;
22 : board-any? ( n x y -- ? )
23 { [ nip row-any? ] [ drop col-any? ] [ box-any? ] } 3|| ;
28 [ >board ] [ [ 1 + ] dip search f ] [ >board ] 2tri ;
30 : attempt ( n x y -- )
31 3dup board-any? [ 3drop ] [ assume ] if ;
34 9 [ 1 + 2over attempt ] each-integer 2drop ;
37 [ [ number>string write ] [ "." write ] if* ] with-cell ;
40 [ [ cell. ] each ] with-row ;
43 standard-table-style [ [ row. ] each ] tabular-output nl ;
46 solutions inc "Solution:" print board get board. ;
50 { [ over 9 = ] [ [ drop 0 ] dip 1 + search ] }
51 { [ over 0 = over 9 = and ] [ 2drop solution. ] }
52 { [ 2dup board> ] [ [ 1 + ] dip search ] }
58 "Puzzle:" print dup board.
61 [ clone ] map board set
65 solutions get number>string write " solutions." print