Created
October 15, 2014 03:55
-
-
Save tonosaman/25bcba40e3aa6443e490 to your computer and use it in GitHub Desktop.
日本経済新聞2014年10月11日ナンプレソルバー
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
import Control.Applicative | |
import Data.Array (Array,array,assocs,(//),(!)) | |
import Data.Maybe (isJust,listToMaybe) | |
import Data.List (sortBy,transpose,nub,(\\)) | |
import Data.Ord (comparing) | |
import Debug.Trace | |
type Loc = (Int, Int) | |
type Mesh = Array Loc (Maybe Int) | |
ans :: [Int] | |
ans = [1..9] | |
block_side :: Int | |
block_side = 3 | |
paper :: Mesh | |
paper = array ((1,1),(length ans,length ans)) [(l, Nothing) | l <- (,) <$> ans <*> ans] | |
main :: IO () | |
main = case solve problem of | |
Nothing -> print "can't solve it." | |
Just m -> mapM_ print $ showMesh m | |
where | |
problem = paper // [ | |
((1, 2), Just 5), ((1, 4), Just 7), ((1, 9), Just 1) | |
, ((2, 4), Just 3), ((2, 5), Just 2) | |
, ((3, 2), Just 8), ((3, 4), Just 6), ((3, 5), Just 9), ((3, 9), Just 4) | |
, ((4, 1), Just 2), ((4, 3), Just 9), ((4, 5), Just 1), ((4, 7), Just 3) | |
, ((5, 2), Just 6), ((5, 3), Just 3), ((5, 7), Just 1), ((5, 8), Just 4) | |
, ((6, 3), Just 7), ((6, 5), Just 5), ((6, 7), Just 6), ((6, 9), Just 2) | |
, ((7, 1), Just 1), ((7, 5), Just 3), ((7, 6), Just 9), ((7, 8), Just 7) | |
, ((8, 5), Just 6), ((8, 6), Just 4) | |
, ((9, 1), Just 4), ((9, 6), Just 7), ((9, 8), Just 2) | |
] | |
solve :: Mesh -> Maybe Mesh | |
solve m | |
| completed m = Just m | |
| otherwise = listToMaybe [s | Just s <- map solve progress] | |
where | |
completed = (all $ isJust . snd) . assocs | |
empties = [l | (l, Nothing) <- assocs m] | |
easy_to_head = sortBy . comparing $ length . snd | |
filling = easy_to_head $ zip empties $ map (candidates m) empties | |
progress = progress' -- `debugMesh` m | |
progress' = [m // [(loc, Just x)] | (loc, xs) <- filling, x <- xs] | |
candidates :: Mesh -> Loc -> [Int] | |
candidates m (x,y) = let | |
block_range l = map (+ 3 * div (l - 1) block_side) [1 .. block_side] | |
block = (,) <$> block_range x <*> block_range y | |
row = (,) <$> [x] <*> ans | |
col = (,) <$> ans <*> [y] | |
fixedVals ls = [ n | Just n <- [m ! l | l <- ls]] | |
constraint = fixedVals . nub $ block ++ row ++ col | |
in ans \\ constraint | |
chunk :: Int -> [a] -> [[a]] | |
chunk _ [] = [] | |
chunk n list = first : (chunk n rest) where (first,rest) = splitAt n list | |
showMesh :: Mesh -> [[String]] | |
showMesh m = transpose $ chunk (length ans) [maybe " " show x | (_, x) <- assocs m] | |
debugMesh :: a -> Mesh -> a | |
debugMesh f m = foldr traceShow (trace "----" f) $ showMesh m | |
debug :: Show a => c -> a -> c | |
debug = flip traceShow |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
http://ideone.com/GFENZj