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 [..8] $repeat j
c = zip (repeat i) [..8]
b = [(i`div`3*3+k,j`div`3*3+l)|(k,l)<-range((,),(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  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 = []/=x&&length x == 1
unfeasible x = []==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((,),(8,8))) xs,y/=]
where a0 = listArray ((,),(8,8)) $replicate 81 [..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

とりあえず方針は

深さ優先探索

取りうる数の範囲が狭い場所から埋めていく

途中で、一意に定まる箇所が複数出てきたら、

全部一緒に埋めて実行可能性のチェック

という感じ。