Problem 96 (Haskellで数独を解く）

http://projecteuler.net/index.php?section=problems&id=96

数独を解く問題。やっと速く動くようになった。
まったく、バグが大変だった。

import Data.List
import Data.Char
import Data.Ord
import Data.Array.IArray
import Control.Monad

type Sudoku = Array (Int,Int) [Int]

sieve :: Sudoku -> ((Int,Int),Int) -> Sudoku
sieve a ((i,j),n) = accum (flip delete) a [(ix,n)|ix<-r++c++b,ix/=(i,j)] // [((i,j),[n])]
  where r = zip [0..8] $repeat j
        c = zip (repeat i) [0..8]
        b = [(i`div`3*3+k,j`div`3*3+l)|(k,l)<-range((0,0),(2,2))]

unfilled :: Sudoku -> [((Int,Int),[Int])]
unfilled = sortBy(comparing $ length.snd).map delZero.filter((/=1).length.snd).assocs
    where delZero (x,ys) = (x,delete 0 ys)


solve ::[Sudoku] -> Sudoku
solve (a:as) | all finish $elems  a  = a -- finish
             | any unfeasible $ elems a = solve as -- unfeasible
             | unique /= [] = solve$fillUni a : as -- fill unique numbers
             | otherwise = solve$guess a ++as -- guess number 
    where finish x = [0]/=x&&length x == 1
          unfeasible x = [0]==x||[]==x
          fillUni a = foldl sieve a [(ix,n)|(ix,[n])<-unique]
          guess a =[sieve a (ix,n) |(ix,n)<-unpack.head$nonUni]
          unpack (x,ys) = zip (repeat x) $  ys
          (unique,nonUni) = break ((>1).length.snd) . unfilled  $ a

ini ::[Int] -> Sudoku
ini xs = foldl sieve a0 $ [(ix,y)|(ix,y)<-zip (range((0,0),(8,8))) xs,y/=0]
    where a0 = listArray ((0,0),(8,8)) $replicate 81 [0..9]

getGrids = map (concatMap $ map digitToInt).take 50.map (take 9.tail).iterate (drop 10).lines

main = do
 f <- liftM getGrids . readFile  $ "sudoku.txt"
 xs <- mapM (return.map intToDigit.concat.take 3.elems.solve.return.ini) f
 print.sum.map read$xs

とりあえず方針は
深さ優先探索
取りうる数の範囲が狭い場所から埋めていく
途中で、一意に定まる箇所が複数出てきたら、
全部一緒に埋めて実行可能性のチェック
という感じ。