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 ;
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 ;
14 :: solutions ( puzzle random? -- solutions )
15 f puzzle random? [ indices [ f ] [ random? swap nth-or-lower ] if-empty ] [ index ] if
17 1 9 [a..b] 80 <iota> [ pos near ] filter [ puzzle nth ] map members diff
18 [ 1array puzzle pos cut-slice rest surround ] map >list [ random? solutions ] bind
19 ] [ puzzle list-monad return ] if* ;
21 : solution ( puzzle random? -- solution )
22 dupd solutions dup +nil+ = [ drop "Unsolvable" alert* ] [ nip car ] if ;
24 : hint ( puzzle -- puzzle' )
25 f over indices random [
26 [ >vector dup f solution ]
27 [ [ swap nth ] keep pick set-nth ] bi*
30 : create ( difficulty -- puzzle )
33 [ f swap [ length random ] keep set-nth ] curry times
40 81 [ "" ] replicate <basic> switch-models [ [ <basic> ] map 9 group [ 3 group ] map 3 group
41 [ [ [ <spacer> [ [ <model-field> ->% 2 [ string>number ] fmap ]
42 map <spacer> ] map concat ] <hbox> , ] map concat <spacer> ] map concat <product>
43 [ "Difficulty:" <label> , "1" <basic> <model-field> -> [ string>number 1 or 1 + 10 * ] fmap
44 "Generate" <model-border-btn> -> updates [ create ] fmap <spacer>
45 "Hint" <model-border-btn> -> "Solve" <model-border-btn> -> ] <hbox> ,
46 roll [ swap updates ] curry bi@
47 [ [ hint ] fmap ] [ [ f solution ] fmap ] bi* 3array merge [ [ [ number>string ] [ "" ] if* ] map ] fmap
50 ] <vbox> { 280 220 } >>pref-dim
51 "Sudoku Sleuth" open-window