haskell - How can I make this Sudoku algorithm get unstuck after the first fail? -
im playing around sudoku solver shown below. problem i'm having don't know how use backtracking solver go after fails first try. shown in last code snippet algorithm stops when hits first illegal solution , returns nothing. how can make go , try solution until finds one?
-- updates specific sudoku value @ specific position update :: sudoku -> pos -> maybe int -> sudoku -- returns blank possitions in sudoku blanks :: sudoku -> [pos] -- checks size correct 9x9 issudoku :: sudoku -> bool -- checks if legal sudoku, no number twise on line col or box isokay :: sudoku -> bool -- checks if there no empty cells in sudoku issolved :: sudoku -> bool solve :: sudoku -> maybe sudoku solve s | not $ issudoku s && isokay s = nothing | otherwise = solve' $ pure s solve' :: maybe sudoku -> maybe sudoku solve' nothing = nothing --there no solution solve' (just s) | issolved s = pure s -- found solution | otherwise = solve' newsud -- continue looking solution (p:_) = blanks s newsud = solvecell (candidates s p) solvecell [] = nothing solvecell (c:cs) | isokay $ update s p (pure c) = $ update s p (pure c) | otherwise = solvecell cs fails solving , ends stopping point.
just (sudoku {rows = [ [just 1,just 2,just 3,just 4,just 5,just 6,just 7,just 8,just 9], [just 4,just 5,just 6,just 1,just 2,just 3,just 8,just 7,nothing] [nothing,nothing,nothing,nothing,nothing,nothing,nothing,nothing,nothing], [nothing,nothing,nothing,nothing,nothing,nothing,nothing,nothing,nothing], [nothing,nothing,nothing,nothing,nothing,nothing,nothing,nothing,nothing], [nothing,nothing,nothing,nothing,nothing,nothing,nothing,nothing,nothing], [nothing,nothing,nothing,nothing,nothing,nothing,nothing,nothing,nothing], [nothing,nothing,nothing,nothing,nothing,nothing,nothing,nothing,nothing], [nothing,nothing,nothing,nothing,nothing,nothing,nothing,nothing,nothing]]})
i'm going simplify problem writing more generic code. writing more generic code easier because there fewer possibilities.
to search generically need 3 things: how tell when done type a -> bool, branches there search type a -> [a], , start search type a.
depth-first search generically
the strategy depth-first search, trying implement, simple. if done, return result found. otherwise find out branches can take here, , try searching each of them in order until 1 of them returns result. if there no branches can take here, we've failed find result.
import data.maybe depthfirstsearch :: (a -> bool) -> (a -> [a]) -> -> maybe depthfirstsearch done branches = go go x = if done x x else listtomaybe . catmaybes . map go . branches $ x a typical implementation of depth-first search, ours, uses call stack backtracking. depth-first search explores of possibilities resulting decision before exploring other possible decisions. since commits course of action , either solves problem or proves course of action unsolvable, state before committing each course of action can stored on stack. stack remembers state of computations before making call when call returns state restored. perfect match states need remember backtracking in depth first search.
the evaluation of listtomaybe . catmaybes . map go . branches driven lazy evaluation, left-most thing happens first. listtomaybe looking first solution, trying each possibility catmaybes . map go . branches in turn until finds one. catmaybes yielding results map go . branches, throwing out explored possibility resulted in nothing. map go making recursive call each branch demanded other functions.
depth-first search sudoku
to use depthfirstsearch sudoku problem, need provide done , branches functions. have done, it's issolved. need provide branches function finds legal moves position. first we'll find moves.
-- might have more clever candidates :: sudoku -> pos -> [int] candidates _ _ = [1..9] moves :: sudoku -> [sudoku] moves s = -- need consider putting numbers in 1 position, not putting numbers in positions p <- take 1 . blanks $ s c <- candidates s p return (update s p (just c)) the legal moves ones okay.
legalmoves :: sudoku -> [sudoku] legalmoves = filter isokay . moves this enough use depthfirstsearch
solve' :: sudoku -> maybe sudoku solve' = depthfirstsearch issolved legalmoves differences code
let's see how solve' above different solve'. both use same pieces - issolved, isokay, blanks, candidates, , update put them differently.
i'll re-write solve' above until looks close solve'. first we'll substitute depthfirstsearch , notice solve' = go , use guards instead of if ... ... else
solve' :: sudoku -> maybe sudoku solve' s | issolved s = s | otherwise = listtomaybe . catmaybes . map solve' . legalmoves $ s i'll substitute in legalmoves s
solve' :: sudoku -> maybe sudoku solve' s | issolved s = s | otherwise = listtomaybe . catmaybes . map solve' $ newsuds newsuds = filter isokay $ -- need consider single putting numbers in 1 position, not puutting numbers in positions p <- take 1 . blanks $ s c <- candidates s p return (update s p (just c)) then substitute listtomaybe . catmaybes . map solve'
solve' :: sudoku -> maybe sudoku solve' s | issolved s = s | otherwise = tryinturn newsuds newsuds = filter isokay $ -- need consider single putting numbers in 1 position, not puutting numbers in positions p <- take 1 . blanks $ s c <- candidates s p return (update s p (just c)) tryinturn [] = nothing tryinturn (s:ss) = case solve' s of (just solution) -> solution otherwise -> tryinturn ss we move update tryinturn, we'd have keep track of p somehow or assume did not issolved implies blanks not []. we'll latter, did.
solve' :: sudoku -> maybe sudoku solve' s | issolved s = s | otherwise = solvecell (candidates s p) (p:_) = blanks s solvecell [] = nothing solvecell (c:cs) | isokay $ update s p (just c) = case solve' (update s p (just c)) of (just solution) -> solution otherwise -> solvecell cs | otherwise = solvecell cs the big difference between version , version recursive call solve' happens once each candidate instead of once first okay candidate.
practical concerns
a depth-first sudoku solver going have lot of trouble dealing absolutely huge branching factor in sudoku. might tenable least restrictive move heuristic, sudoku choose make next move in position fewest okay candidates.
Comments
Post a Comment