Алгоритм решения Судоку

import System.Environment(getArgs)
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Concurrent.Chan
 
 
import Data.Array.Diff
import Data.List(iterate,findIndices,sortBy,(\\),delete)
import qualified Data.IntSet as Set
import Control.Monad.State
import Data.Tree
 
type CellVars = Set.IntSet
type Pole = Array (Int,Int) CellVars
 
empty_pole = listArray ((1,1),(puzzle_size,puzzle_size)) (repeat Set.empty)
 
puzzle_size = 9
diap = [1..puzzle_size]
block_diap = [1..3]
 
resolve_conflict :: State [CellVars] Bool
resolve_conflict = do
  cells <- get
  let definite = findIndices (\c -> Set.size c == 1) cells
      double = findIndices (\c -> Set.size c == 2) cells
      pairs = [(x,y) | x <- double, y <- double, x < y, cells !! x == cells !! y]
  seqWhileM $ map drop_conflicting definite ++ map drop_conflicting_pairs pairs
    
drop_conflicting :: Int -> State [CellVars] Bool
drop_conflicting ind = do
  cells <- get 
  let (prev,cur:next) = splitAt ind cells
      drop_cur = map ( `Set.difference` cur)
      new_cells = drop_cur prev ++ cur : drop_cur next 
  put new_cells
  return $! all (not . Set.null) new_cells
 
drop_conflicting_pairs :: (Int,Int) -> State [CellVars] Bool
drop_conflicting_pairs (x,y) = do
    cells <- get
    let (part1,el1:next) = splitAt x cells
        (part2,el2:part3) = splitAt (y-x-1) next
        pair = cells !! x
        drop_pair = map ( `Set.difference` pair)
        new_cells = drop_pair part1 ++ el1 : drop_pair part2 ++ el2 : drop_pair part3
    put new_cells 
    return $! all (not . Set.null) new_cells
 
resolve_conflicts :: State [CellVars] Bool
resolve_conflicts = stabilize resolve_conflict 
 
-- applies an action until result stop changing or it returns false
stabilize act = do
  old <- get
  flag <- act
  new <- get
  if old == new then return flag
   else if flag then stabilize act
         else return False
    
stabilize_pole :: State Pole Bool
stabilize_pole = stabilize resolve_pole
 
 
seqWhileM :: Monad m => [m Bool] -> m Bool
seqWhileM (x:xs) = do r <- x
                      if r then seqWhileM xs
                       else return False
  
seqWhileM [] = return True
 
resolve_pole :: State Pole Bool
resolve_pole = do
    seqWhileM $ map resolve_row diap ++
                map resolve_col diap ++ 
                map resolve_block [(x,y) | x <- block_diap, y <- block_diap]
 
resolve_row :: Int -> State Pole Bool
resolve_row row_num = let
    coords = zip (repeat row_num) diap
    in resolve_coords coords
 
resolve_col :: Int -> State Pole Bool
resolve_col col_num = let
    coords = zip diap (repeat col_num)
    in resolve_coords coords
 
resolve_block :: (Int,Int) -> State Pole Bool
resolve_block (bx,by) = let
    diap_x = [bx*3-2 .. bx*3]
    diap_y = [by*3-2 .. by*3]
    coords = [(x,y) | x <- diap_x, y <- diap_y]
    in resolve_coords coords
 
get_list :: Pole -> [(Int,Int)] -> [CellVars]
get_list pole coords = map (pole !) coords
 
resolve_coords :: [(Int,Int)] -> State Pole Bool
resolve_coords coords = do
  pole <- get
  let (not_empty, new_cells) = runState resolve_conflicts (get_list pole coords)
      new_pole = pole // (zip coords new_cells)
  put new_pole
  return $! not_empty 
  
build_tree :: Pole -> Tree Pole
build_tree root = unfoldTree build_node root
 
build_node :: Pole -> (Pole, [Pole])
build_node pole = let
    (not_empty, stable_pole) = runState stabilize_pole pole
    cells = assocs stable_pole
    possible_forks = sortBy (compareBy num_vars) . 
                     filter ( (>= 2) . num_vars) $ cells
    (coord,vars) = head possible_forks
    pole_vars = map (\x -> pole // [(coord,Set.singleton x)]) $ Set.elems vars
    in if not_empty 
       then if null possible_forks 
             then (stable_pole, [])
             else (stable_pole, pole_vars)
       else (empty_pole,[])
 where num_vars = Set.size . snd
 
       
compareBy f a b = compare (f a) (f b)
 
find_solutions :: Pole -> [Pole]
find_solutions pole = filter (all (\a -> Set.size a == 1) . elems) $ flatten $ build_tree pole  
 
-- interface
 
time = 49000
 
type EncodedPole = String
main = do
  inp <- getContents
  let (n:puzzles) = lines inp
      indexed = zip [1..(read n)] puzzles
      ranged = map (\(i,p) -> (i, read_pole p)) . sortBy (compare_by (est_difficulty . snd) ) $ indexed
      
  sols_chan <- newChan
  succ_flag <- newEmptyMVar
  forkIO (processor ranged sols_chan succ_flag)
  timeout time (takeMVar succ_flag >> return ())
  
  sols <- read_whole_chan sols_chan 
  let tasks = elems $ (listArray (1,read n) (repeat Nothing) :: Array Int (Maybe EncodedPole)) // sols
 
  mapM_ print_sol tasks
 
compare_by f a b = compare (f a) (f b)
est_difficulty = length . filter (== '.')
 
 
processor :: [(Int,Pole)] -> Chan (Int,Maybe EncodedPole) -> MVar () -> IO ()
processor [] _ flag = putMVar flag ()
processor ((k,p):rest) c flag = do
  let sol = case find_solutions p of
              (s:ss) -> s
              [] -> error "no solutions"
      enc_sol = show_pole sol
  length enc_sol `seq` writeChan c (k,Just enc_sol)
  processor rest c flag
 
read_whole_chan :: Chan a -> IO [a]
read_whole_chan c = do
  e <- isEmptyChan c
  if e then return []
   else do a <- readChan c
           rst <- read_whole_chan c
           return (a:rst)
 
print_sol :: Maybe EncodedPole -> IO ()
print_sol Nothing = putStrLn "N"
print_sol (Just p) = do
  putStrLn "Y"
  putStrLn p
 
read_pole :: String -> Pole 
read_pole s = listArray ((1,1),(puzzle_size,puzzle_size)) . map read_cell $ s
 
show_pole :: Pole -> String
show_pole s = concatMap (show . head . Set.elems) $ elems s
 
read_cell '.' = Set.fromList diap
read_cell d = Set.fromList [read [d]]
 
par_io :: IO a -> IO a -> IO a
par_io t1 t2 = do c <- newEmptyMVar :: IO (MVar a)
                  id1 <- forkIO $ wrapper c t1
                  id2 <- forkIO $ wrapper c t2
                  res <- takeMVar c
                  killThread id1
                  killThread id2
                  return res
    where wrapper :: MVar a -> IO a -> IO ()
          wrapper mvar io = do res <- io
                               putMVar mvar res
 
timeout :: Int -> IO a -> IO (Maybe a)
timeout n t = do res <- par_io timer thr 
                 return res
    where thr = do res <- t
                   return $! Just res
          timer = do threadDelay $ n * 1000
                     return Nothing