日本経済新聞2014年10月11日ナンプレソルバー

numplace.hs

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

http://ideone.com/GFENZj