extra/sudoku/sudoku.factor

   1 ! Based on http://www.ffconsultancy.com/ocaml/sudoku/index.html
   2 USING: sequences namespaces kernel math math.parser io
   3 io.styles combinators columns ;
   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 : f>board ( m n -- ) f -rot >board ;
  15
  16 : row-any? ( n y -- ? ) row member? ;
  17 : col-any? ( n x -- ? ) board get swap <column> member? ;
  18 : cell-any? ( n x y i -- ? ) 3 /mod pair+ board> = ;
  19
  20 : box-any? ( n x y -- ? )
  21     [ 3 /i 3 * ] bi@
  22     9 [ [ 3dup ] dip cell-any? ] any?
  23     [ 3drop ] dip ;
  24
  25 DEFER: search
  26
  27 : assume ( n x y -- )
  28     [ >board ] 2keep [ [ 1+ ] dip search ] 2keep f>board ;
  29
  30 : attempt ( n x y -- )
  31     {
  32         { [ 3dup nip row-any? ] [ 3drop ] }
  33         { [ 3dup drop col-any? ] [ 3drop ] }
  34         { [ 3dup box-any? ] [ 3drop ] }
  35         [ assume ]
  36     } cond ;
  37
  38 : solve ( x y -- ) 9 [ 1+ 2over attempt ] each 2drop ;
  39
  40 : board. ( board -- )
  41     standard-table-style [
  42         [
  43             [
  44                 [
  45                     [
  46                         [
  47                             number>string write
  48                         ] [
  49                             "." write
  50                         ] if*
  51                     ] with-cell
  52                 ] each
  53             ] with-row
  54         ] each
  55     ] tabular-output ;
  56
  57 : solution. ( -- )
  58     solutions inc "Solution:" print board get board. ;
  59
  60 : search ( x y -- )
  61     {
  62         { [ over 9 = ] [ [ drop 0 ] dip 1+ search ] }
  63         { [ over 0 = over 9 = and ] [ 2drop solution. ] }
  64         { [ 2dup board> ] [ [ 1+ ] dip search ] }
  65         [ solve ]
  66     } cond ;
  67
  68 : sudoku ( board -- )
  69     [
  70         "Puzzle:" print dup board.
  71
  72         0 solutions set
  73         [ clone ] map board set
  74
  75         0 0 search
  76
  77         solutions get number>string write " solutions." print
  78     ] with-scope ;
  79
  80 : sudoku-demo ( -- )
  81     {
  82         { f f 1 f f 5 3 f f }
  83         { f 5 f 4 9 f f f f }
  84         { f f f 1 f 2 f 6 4 }
  85         { f f f f f f 7 5 f }
  86         { 6 f f f f f f f 1 }
  87         { f 3 5 f f f f f f }
  88         { 4 6 f 9 f 3 f f f }
  89         { f f f f 2 4 f 9 f }
  90         { f f 3 6 f f 1 f f }
  91     } sudoku ;
  92
  93 MAIN: sudoku-demo