/unmaintained/sudokus/sudokus.factor

http://github.com/abeaumont/factor · Factor · 40 lines · 35 code · 5 blank · 0 comment · 10 complexity · 74c4597da2836c8b5cff1535b0c349ab MD5 · raw file

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