extra/sudoku/sudoku.factor

   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 ;
   4 IN: sudoku
   5
   6 SYMBOL: solutions
   7 SYMBOL: board
   8
   9 : pair+ ( a b c d -- a+b c+d ) swapd [ + ] 2bi@ ;
  10
  11 : row ( n -- row ) board get nth ;
  12 : board> ( m n -- x ) row nth ;
  13 : >board ( row m n -- ) row set-nth ;
  14
  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> = ;
  18
  19 : box-any? ( n x y -- ? )
  20     [ 3 /i 3 * ] bi@ 9 <iota> [ cell-any? ] 3 nwith any? ;
  21
  22 : board-any? ( n x y -- ? )
  23     { [ nip row-any? ] [ drop col-any? ] [ box-any? ] } 3|| ;
  24
  25 DEFER: search
  26
  27 : assume ( n x y -- )
  28     [ >board ] [ [ 1 + ] dip search f ] [ >board ] 2tri ;
  29
  30 : attempt ( n x y -- )
  31     3dup board-any? [ 3drop ] [ assume ] if ;
  32
  33 : solve ( x y -- )
  34     9 [ 1 + 2over attempt ] each-integer 2drop ;
  35
  36 : cell. ( cell -- )
  37     [ [ number>string write ] [ "." write ] if* ] with-cell ;
  38
  39 : row. ( row -- )
  40     [ [ cell. ] each ] with-row ;
  41
  42 : board. ( board -- )
  43     standard-table-style [ [ row. ] each ] tabular-output nl ;
  44
  45 : solution. ( -- )
  46     solutions inc "Solution:" print board get board. ;
  47
  48 : search ( x y -- )
  49     {
  50         { [ over 9 = ] [ [ drop 0 ] dip 1 + search ] }
  51         { [ over 0 = over 9 = and ] [ 2drop solution. ] }
  52         { [ 2dup board> ] [ [ 1 + ] dip search ] }
  53         [ solve ]
  54     } cond ;
  55
  56 : sudoku ( board -- )
  57     [
  58         "Puzzle:" print dup board.
  59
  60         0 solutions set
  61         [ clone ] map board set
  62
  63         0 0 search
  64
  65         solutions get number>string write " solutions." print
  66     ] with-scope ;
  67
  68 : sudoku-demo ( -- )
  69     {
  70         { f f 1 f f 5 3 f f }
  71         { f 5 f 4 9 f f f f }
  72         { f f f 1 f 2 f 6 4 }
  73         { f f f f f f 7 5 f }
  74         { 6 f f f f f f f 1 }
  75         { f 3 5 f f f f f f }
  76         { 4 6 f 9 f 3 f f f }
  77         { f f f f 2 4 f 9 f }
  78         { f f 3 6 f f 1 f f }
  79     } sudoku ;
  80
  81 MAIN: sudoku-demo