Project Euler Problem 096

import Data.List
import Data.Char
import Data.Ord
import Control.Monad
import System.IO.Unsafe

       
chunk :: Int -> [[Char]] -> [[Int]]
chunk n = unfoldr g where
  g [] = Nothing
  g l = Just (map digitToInt $ concat $ drop 2 $ take n l,drop n l)
d2n :: Num a => [a] -> a
d2n n = foldl ((+).(*10)) 0 n
  
-- box番号。左上,上,右上,中左,...に0..8を対応付ける
box :: Integral a => a -> a
box n = (3*(i`quot`3)+(j`quot`3)) where (i,j)=indexr n
index :: Num a => a -> a -> a
index i j = i*9+j
indexr :: Integral t => t -> (t, t)
indexr n = (raw n,col n)
raw :: Integral a => a -> a
raw n = n`quot`9
col :: Integral a => a -> a
col n = n`rem`9


boxs :: Int -> [t] -> [t]
boxs n b= [access i j b| i<-[l..(l+2)],j<-[r..(r+2)]] where (l,r)=(3*(n`quot`3),3*(n`rem`3))
raws :: Int -> [t] -> [t]
raws n b= [access (raw n) j b| j<-[0..8]]
cols :: Int -> [t] -> [t]
cols n b= [access i (col n) b| i<-[0..8]]
possible :: Int -> [Int] -> [Int]
possible n brd= n9 \\ (a++b++c) where (a,b,c)=(boxs (box n) brd,raws n brd,cols n brd)


next :: [Int] -> [Int]
next = findIndices (==0)
access :: Int -> Int -> [a] -> a
access i j b= b!!(index i j)
put :: Int -> a -> [a] -> [a]
put n v b= take n b ++ [v] ++ drop (n+1) b
n9 :: [Int]
n9 = [1..9]

-- 全解を求めるsolver
solve :: [Int] -> [[Int]]
solve board = imp [board]
  where
    imp b | all (/=0) (head b) = b
          | otherwise = imp [put p c bb|
                             bb<-b,
                             let ps = next bb,
                             let possibles = map (\x -> possible x bb) ps,
                             -- ここは1要素だけのとこは全部置くように改良してもいい
                             let list = filter ((/=[]).fst) $ zip possibles ps,
                             list /= [],
                             -- このminimumBy1個だけで十分早くなる
                             let (cs,p) = minimumBy (comparing (length . fst)) list,
                             c<-cs]

-- 解く
filedata :: String
filedata = unsafePerformIO $ readFile "096sudoku.txt"
probs :: [[Int]]
probs = (chunk 11 . words) filedata
ans1 :: Int
ans1 = sum $ map (d2n . take 3 . head . solve) probs
-- 24702
main :: IO ()
main = print ans1
                        

-- おまけ：2010年フィンランドの数学者による世界一難しいらしい数独
-- http://www.mirror.co.uk/news/weird-news/worlds-hardest-sudoku-can-you-242294
prob :: [Int]    
prob = [
  0, 0, 5, 3, 0, 0, 0, 0, 0,
  8, 0, 0, 0, 0, 0, 0, 2, 0,
  0, 7, 0, 0, 1, 0, 5, 0, 0,
  4, 0, 0, 0, 0, 5, 3, 0, 0,
  0, 1, 0, 0, 7, 0, 0, 0, 6,
  0, 0, 3, 2, 0, 0, 0, 8, 0,
  0, 6, 0, 5, 0, 0, 0, 0, 9,
  0, 0, 4, 0, 0, 0, 0, 3, 0,
  0, 0, 0, 0, 0, 9, 7, 0, 0]

-- 別解
-- 最初の解と全解の処理を型アノテーションで切り分けられるソルバ
type Board = [Int]    
solve' :: Board -> Maybe Board -- 一つ解が出ればいい場合はこちら
--solve' :: Board -> [Board] -- 全解を出す場合はこちら
--solve' :: MonadPlus m => Board -> m Board -- 一般的な型
solve' board = imp board
  where
    imp :: MonadPlus m => Board -> m Board
    imp b | all (/=0) b = return b
          | otherwise = msum [imp (put p c b)|
                              let ps = next b,
                              let possibles = map (\x -> possible x b) ps,
                              -- ここは1要素だけのとこは全部置くように改良してもいい
                              let list = filter ((/=[]).fst) $ zip possibles ps,
                              list /= [],
                              -- このminimumBy1個だけで十分早くなる
                              let (cs,p) = minimumBy (comparing (length . fst)) list,
                              c<-cs]