数独ソルバ

import Data.List
import Data.List.Split

-- 数独を解く
solveSudoku matrix
  | matrix /= solved = solveSudoku solved
  | solved /= backtracked = solveSudoku backtracked
  | otherwise = matrix
  where
    solved      = solveSudokuDirectly matrix
    backtracked = solveSudokuByBacktracking solved

solveSudokuDirectly matrix
  | matrix == solved = matrix
  | otherwise = solveSudokuDirectly solved
  where
    solvedHorizontal = map solveSudoku1Line matrix
    solvedVertical   = transpose . map solveSudoku1Line . transpose $ solvedHorizontal
    solved3x3Box     = boxToRow . map solveSudoku1Line . boxToRow $ solvedVertical
    solved           = solved3x3Box

-- 3x3のボックスの内容が順序を保ったまま1行になるように行列を組み替える
boxToRow = structureMatrix . map transpose . sliceMatrix
  where
    sliceMatrix = map (map (chunksOf 3)) . (chunksOf 3)
    structureMatrix = concat . map (map concat)

-- 数独の1列を解く
-- 候補のリストのリストcellsを受け取り、列内で確定できる分を確定する
-- 1イテレーション回すだけなので、解ききるとは限らない
-- 例：
-- solveSudoku1Line [[1],[2,3],[3],[4,6],[4,5,6,7,8],[6,9],[7,8,9],[7,8,9],[9]]
--   = [[1],[2],[3],[4,6],[5],[6],[7,8],[7,8],[9]]
solveSudoku1Line cells = map ((fixCell occurredOnce) . (removeIfUnfixed fixedElems)) cells
  where 
    fixedElems   = uniqueElems cells
    occurredOnce = uniqueElems (groupElems cells)
    uniqueElems  = map head . filter ((1==).(length))
    groupElems   = group . sort . concat

-- cell内にxsと重複する内容が1つだけあったらcellの内容をそれに置き換える
-- xsと重複する要素が2個あったら空リストを返す（バックトラック時の矛盾検出用）
fixCell xs cell
  | length dups == 1 = dups
  | length dups >= 2 = []
  | otherwise = cell
  where dups = intersect xs cell

-- cell内にxsと重複する内容があり、cellが1要素でなければ、重複する要素を除去する
removeIfUnfixed xs cell
  | length cell == 1 = cell
  | otherwise = deleteFirstsBy (==) cell xs

-- バックトラッキングを使って数独を解く
-- 1マスの値を確定させてみて矛盾が見つからないものだけ残す
solveSudokuByBacktracking matrix = zipWith (backtrackingOnRow matrix) [0..8] matrix
  where
    backtrackingOnRow matrix i cells = zipWith (backtrackingOnCell matrix i) [0..8] cells
    backtrackingOnCell _ _ _ [] = []
    backtrackingOnCell _ _ _ cell@(x:[]) = cell
    backtrackingOnCell matrix i j cell = filter (isPossibleValue matrix i j) cell

-- 数独の行列のi行j列がnだとして、矛盾がないか調べる
-- i,j は0スタート
isPossibleValue :: [[[Int]]] -> Int -> Int -> Int -> Bool
isPossibleValue matrix i j n = dropWhile ([]/=) (concat solved) == []
  where
    solved = solveSudokuDirectly candMatrix
    candMatrix = adjustAtIndex (replaceAtIndex j [n]) i matrix
    adjustAtIndex f n ls = a ++ (f b:c) where (a, (b:c)) = splitAt n ls
    replaceAtIndex n item ls = a ++ (item:b) where (a, (_:b)) = splitAt n ls