steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

gui-sudoku makes sudokus too

db4
Sam Anklesaria 2009-06-26 15:28:23 -05:00
parent 96fccd9c6c
commit 244ad93577
1 changed files with 21 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
extra/gui-sudoku/gui-sudoku.factor
View File

@ -1,32 +1,40 @@
USING: accessors arrays combinators.short-circuit grouping kernel lists USING: accessors arrays combinators.short-circuit grouping kernel lists
lists.lazy locals math math.functions math.parser math.ranges lists.lazy locals math math.functions math.parser math.ranges
models.product monads random sequences sets ui ui.frp.gadgets models.product monads random sequences sets ui ui.frp.gadgets
ui.frp.layout ui.frp.signals ui.gadgets.alerts vectors ; ui.frp.layout ui.frp.signals ui.gadgets.alerts vectors fry
ui.gadgets.labels memoize ;
IN: gui-sudoku IN: gui-sudoku
: row ( index -- row ) 1 + 9 / ceiling ; : row ( index -- row ) 1 + 9 / ceiling ;
: col ( index -- col ) 9 mod 1 + ; : col ( index -- col ) 9 mod 1 + ;
: sq ( index -- square ) [ row ] [ col ] bi [ 3 / ceiling ] bi@ 2array ; : sq ( index -- square ) [ row ] [ col ] bi [ 3 / ceiling ] bi@ 2array ;
: near ( a pos -- ? ) { [ [ row ] bi@ = ] [ [ col ] bi@ = ] [ [ sq ] bi@ = ] } 2|| ; : near ( a pos -- ? ) { [ [ row ] bi@ = ] [ [ col ] bi@ = ] [ [ sq ] bi@ = ] } 2|| ;
MEMO:: solutions ( puzzle -- solutions ) : nth-or-lower ( n seq -- elt ) [ length 1 - 2dup > [ nip ] [ drop ] if ] keep nth ;
f puzzle index
MEMO:: solutions ( puzzle random? -- solutions )
f puzzle random? [ indices [ f ] [ random? swap nth-or-lower ] if-empty ] [ index ] if
[ :> pos [ :> pos
1 9 [a,b] 80 iota [ pos near ] filter [ puzzle nth ] map prune diff 1 9 [a,b] 80 iota [ pos near ] filter [ puzzle nth ] map prune diff
[ 1array puzzle pos cut-slice rest surround ] map >list [ solutions ] bind [ 1array puzzle pos cut-slice rest surround ] map >list [ random? solutions ] bind
] [ puzzle list-monad return ] if* ; ] [ puzzle list-monad return ] if* ;
: solution ( puzzle -- solution ) dup solutions dup +nil+ = [ drop "Unsolvable" alert* ] [ nip car ] if ; : solution ( puzzle random? -- solution ) dupd solutions dup +nil+ = [ drop "Unsolvable" alert* ] [ nip car ] if \ solutions reset-memoized ;
: hint ( puzzle -- puzzle' ) [ [ f swap indices random dup ] [ solution ] bi nth ] keep swapd >vector [ set-nth ] keep ; : hint ( puzzle -- puzzle' ) [ [ f swap indices random dup ] [ f solution ] bi nth ] keep swapd >vector [ set-nth ] keep ;
: create ( difficulty -- puzzle ) 81 [ f ] replicate
40 random solution [ [ dup length random f spin set-nth ] curry times ] keep ;
: do-sudoku ( -- ) [ [ [ $ SUDOKU $ ] <vbox> { 280 220 } >>pref-dim : do-sudoku ( -- ) [ [
[ [
81 [ "" ] replicate <basic> <switch> [ SUDOKU [ <basic> ] map 9 group [ 3 group ] map 3 group 81 [ "" ] replicate <basic> <switch> [ [ <basic> ] map 9 group [ 3 group ] map 3 group
[ [ [ <spacer> [ [ <frp-field> ->% 2 [ string>number ] fmap ] [ [ [ <spacer> [ [ <frp-field> ->% 2 [ string>number ] fmap ]
map <spacer> ] map concat ] <hbox> , ] map concat <spacer> ] map concat <product> dup map <spacer> ] map concat ] <hbox> , ] map concat <spacer> ] map concat <product>
[ "Hint" <frp-border-button> -> "Solve" <frp-border-button> -> ] <hbox> , swapd [ <updates> ] 2bi@ [ "Difficulty:" <label> , "1" <basic> <frp-field> -> [ string>number 1 or 1 + 10 * ] fmap
[ [ hint ] fmap ] [ [ solution ] fmap ] bi* <2merge> [ [ [ number>string ] [ "" ] if* ] map ] fmap "Generate" <frp-border-button> -> <updates> [ create ] fmap <spacer>
"Hint" <frp-border-button> -> "Solve" <frp-border-button> -> ] <hbox> ,
roll [ swap <updates> ] curry bi@
[ [ hint ] fmap ] [ [ f solution ] fmap ] bi* 3array <merge> [ [ [ number>string ] [ "" ] if* ] map ] fmap
] bind ] bind
] with-self SUDOKU , ] with-self , ] <vbox> { 280 220 } >>pref-dim
] with-interface "Sudoku Sleuth" open-window ] with-ui ; "Sudoku Sleuth" open-window ] with-ui ;
MAIN: do-sudoku MAIN: do-sudoku