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 --algo 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 --timer return res where thr = do res <- t return $! Just res timer = do threadDelay $ n * 1000 return Nothing