extra/sudokus/sudokus.factor

   1 USING: accessors arrays combinators.short-circuit fry grouping
   2 kernel lists lists.lazy locals math math.functions math.parser
   3 models.combinators models.product monads random ranges sequences
   4 sets shuffle ui ui.gadgets.alerts ui.gadgets.controls
   5 ui.gadgets.labels ui.gadgets.layout vectors ;
   6 IN: sudokus
   7
   8 : row ( index -- row ) 1 + 9 / ceiling ;
   9 : col ( index -- col ) 9 mod 1 + ;
  10 : sq ( index -- square ) [ row ] [ col ] bi [ 3 / ceiling ] bi@ 2array ;
  11 : near ( a pos -- ? ) { [ [ row ] same? ] [ [ col ] same? ] [ [ sq ] same? ] } 2|| ;
  12 : nth-or-lower ( n seq -- elt ) [ length 1 - 2dup > [ nip ] [ drop ] if ] keep nth ;
  13
  14 :: solutions ( puzzle random? -- solutions )
  15     f puzzle random? [
  16         indices [ f ] [ random? swap nth-or-lower ] if-empty
  17     ] [ index ] if [| pos |
  18         1 9 [a..b] 80 <iota> [ pos near ] filter
  19         [ puzzle nth ] map members diff
  20         [ 1array puzzle pos cut-slice rest surround ] map >list
  21         [ random? solutions ] bind
  22     ] [ puzzle list-monad return ] if* ;
  23
  24 : solution ( puzzle random? -- solution )
  25     dupd solutions dup +nil+ = [ drop "Unsolvable" alert* ] [ nip car ] if ;
  26
  27 : hint ( puzzle -- puzzle' )
  28     f over indices random [
  29         [ >vector dup f solution ]
  30         [ [ swap nth ] keep pick set-nth ] bi*
  31     ] when* ;
  32
  33 : create ( difficulty -- puzzle )
  34     81 f <array>
  35     40 random solution [
  36         [ f swap [ length random ] keep set-nth ] curry times
  37     ] keep ;
  38
  39 : <sudoku-gadget> ( -- gadget )
  40     [
  41         [
  42             81 [ "" ] replicate <basic> switch-models [
  43                 [ <basic> ] map 9 group [ 3 group ] map 3 group
  44                 [
  45                     [
  46                         [
  47                             <spacer> [
  48                                 [ <model-field> ->% 2 [ string>number ] fmap ] map <spacer>
  49                             ] map concat
  50                         ] <hbox> ,
  51                     ] map concat <spacer>
  52                 ] map concat <product>
  53                 [
  54                     "Difficulty:" <label> , "1" <basic> <model-field> -> [ string>number 1 or 1 + 10 * ] fmap
  55                     "Generate" <model-border-btn> -> updates [ create ] fmap <spacer>
  56                     "Hint" <model-border-btn> -> "Solve" <model-border-btn> ->
  57                 ] <hbox> , roll [ swap updates ] curry bi@
  58                 [ [ hint ] fmap ] [ [ f solution ] fmap ] bi* 3array merge
  59                 [ [ [ number>string ] [ "" ] if* ] map ] fmap
  60            ] bind
  61         ] with-self ,
  62     ] <vbox> { 280 220 } >>pref-dim ;
  63
  64 MAIN-WINDOW: sudoku-main
  65     { { title "Sudoku Sleuth" } }
  66     <sudoku-gadget> >>gadgets ;