関数プログラミング実践入門 ──簡潔で、正しいコードを書くために (WEB+DB PRESS plus)を買って第六章読んだら 40 行くらいで読みやすい数独ソルバ書かれてて、自分で書いたらどれだけ長くて読みにくくなるのか試しに書いてみたら酷いことになった。

自分のヤバイコードと対比することでこの本の良書っぷりが更にわかって良かった。

なお、下記の実行結果は本当に解ける人いるの？　フィンランド人数学者が作った “世界一難しい数独” が発表されるを解いたもの。

$ ghc ./Sudoku/main.hs -odir ./Sudoku -O2
$ time ./Sudoku/main "8..........36......7..9.2...5...7.......457.....1...3...1....68..85...1..9....4.."
[["812753649943682175675491283154237896369845721287169534521974368438526917796318452"]]
./Sudoku/main   12.32s user 0.07s system 99% cpu 12.413 total

Sudoku/main.hs

import Sudoku.Solver (solve)
import System.Environment(getArgs)

main :: IO()
main = print . map solve =<< getArgs

Sudoku/solver.hs

module Sudoku.Solver where

import qualified Data.Map as Map
import Data.Function (on, fix)

import Data.List( (\\), groupBy, partition )

-- | 盤面
import Sudoku.Board( Board, readBoard, showBoard, uncertain, varid, update, updateBy )

-- | 座標
import Sudoku.Coord( Coord, constraints, coords )

-- | 対応
import Sudoku.Correspondence( Correspondence, fromList', inverse, nullOrLength1, subCorrespondence, toList', toMap )

-- | 数独を解く
solve :: String -> [String]
solve = map showBoard . solve' [] . (: []) . readBoard

-- | 複数の盤面を解く
solve' :: [Board] -> [Board] -> [Board]
solve' rs [] = rs
solve' rs (b:bs)
  -- | 解の条件を満たせば、解のリストに追加
  | varid b = solve' (b : rs) bs

  -- | 手番が進んだら、更に進める
  | b /= forward b = solve' rs $ forward b : bs

  -- | 手番を進められる余地はあるが、
  -- | どう進めていいかわからないなら、
  -- | 当てずっぽうで進める
  | uncertain b = solve' rs $ guess b ++ bs

  -- | 手立てがなければ、その盤面を捨てる
  | otherwise   = solve' rs bs

  -- | デバック用
  -- | otherwise   = solve' (b : rs) bs

-- | 当てずっぽうで手番を進める（総当り）
guess :: Board -> [Board]
guess b = map (\xs -> flip update b $ fromList' [(c, xs)]) [[i], is]
  where
    (c, i:is) = Map.findMax . Map.filter (not . nullOrLength1) $ toMap b

-- | 盤面を進める
forward :: Board -> Board
forward = foldl (.) id . map updateBy $ do
  toSub <- map subCorrespondence constraints
  return $ fix (\rec b -> if b /= g b then rec $ g b else b) . toSub
    where
      g = inverse . pigeonhole . inverse . pigeonhole

-- | 鳩ノ巣の原理で解候補を削る
pigeonhole :: (Ord a, Ord b) => Correspondence a b -> Correspondence a b
pigeonhole = fromList' . fromHole . pigeonhole' . toHole . toList'
  where
    toHole = map (\xs -> (map fst xs, snd $ head xs)) . groupBy ((==) `on` snd)
    fromHole = concatMap (\(xs, ys) -> zip xs $ repeat ys)
    pigeonhole' xs = (++ fixs) $ map f unfixs
      where
        f (ys, zs) = (ys, zs \\ concatMap snd fixs)
        (fixs, unfixs) = partition (\(ys, zs) -> length ys == length zs) xs

Sudoku/board.hs

module Sudoku.Board where

import qualified Data.Map as Map

import Data.Function (on)

-- | 座標
import Sudoku.Coord( Coord, constraints, coords)

-- | 対応
import qualified Sudoku.Correspondence as SC
import Sudoku.Correspondence( Correspondence, fromList, fromMap, image, images, nullOrLength1, oneToOne, subCorrespondence, toMap, toList', unique)

-- | 盤面 = 座標と解候補の対応
type Board = Correspondence Coord Int

-- | 文字列から盤面へ
readBoard :: String -> Board
readBoard str = fromList . concatMap flat . zip coords . map read' . take 81 $ str ++ repeat '.'
    where
      read' n = if n `elem` ['1'..'9'] then [read [n]] else [1..9]
      flat (x, xs) = zip (repeat x) xs

-- | 盤面から文字列へ
showBoard :: Board -> String
showBoard b = concatMap (\c -> show' $ image c b) coords
  where
    show' [n] = show n
    show' _   = "."

-- | 正当性 = 全ての近傍の位置と確定解が一対一対応している
varid :: Board -> Bool
varid b = all (oneToOne . flip subCorrespondence b) constraints

-- | 手番が進められる可能性
uncertain :: Board -> Bool
uncertain = not . all nullOrLength1 . images

-- | 別の盤面で元の盤面を更新
update :: Board -> Board -> Board
update sub b = fromMap $ Map.union (toMap sub) (toMap b)

-- | 盤面に関数を適用して更新
updateBy :: (Board -> Board) -> Board -> Board
updateBy f b = fromMap $ Map.union (toMap $ f b) (toMap b)

Sudoku/coord.hs

module Sudoku.Coord where

import Control.Monad (replicateM)

-- | 座標 = どのBlock(OutCoord)内のどの位置(InCoord)にあるか
data Coord = Coord OutCoord InCoord deriving (Read, Show, Eq, Ord)

-- | Blockの位置を表す座標
newtype OutCoord = OutCoord Coord2D deriving (Read, Show, Eq, Ord)

-- | Block内の座標
newtype InCoord = InCoord Coord2D deriving (Read, Show, Eq, Ord)

-- | 3 X 3 の２次元座標
data Coord2D = Coord2D { getX :: ABC
                       , getY :: ABC
                       } deriving (Read, Show, Eq, Ord)

-- | ３個の列挙子
data ABC = A | B | C deriving (Read, Show, Eq, Ord, Enum)

-- | 座標の作成
mkCoord :: ABC -> ABC -> ABC -> ABC -> Coord
mkCoord ox oy ix iy = Coord (OutCoord $ Coord2D ox oy) (InCoord $ Coord2D ix iy)

-- | 座標の分解
bkCoord :: Coord -> (ABC, ABC, ABC, ABC)
bkCoord (Coord (OutCoord o) (InCoord i)) = (getX o, getY o, getX i, getY i)

-- | A, B, C の長さ n の列
abcSequence :: Int -> [[ABC]]
abcSequence n = replicateM n [A, B, C]

-- | 全ての座標（左上から右下順）
coords :: [Coord]
coords = [mkCoord ox oy ix iy | [oy, iy, ox, ix] <- abcSequence 4]

-- | 行
row :: ABC -> ABC -> [Coord]
row ox ix = [mkCoord ox oy ix iy | [iy, oy] <- abcSequence 2]

-- | 列
column :: ABC -> ABC -> [Coord]
column oy iy = [mkCoord ox oy ix iy | [ix, ox] <- abcSequence 2]

-- | ブロック
block :: ABC -> ABC -> [Coord]
block ox oy = [mkCoord ox oy ix iy | [ix, iy] <- abcSequence 2]

-- | 全ての行
rows :: [[Coord]]
rows = [row ox ix | [ix, ox] <- abcSequence 2]

-- | 全ての列
columns :: [[Coord]]
columns = [column oy iy | [iy, oy] <- abcSequence 2]

-- | 全てのブロック
blocks :: [[Coord]]
blocks = [block ox oy | [ox, oy] <- abcSequence 2]

-- | 全ての行、列、ブロック
constraints :: [[Coord]]
constraints = concat [blocks, rows, columns]

Sudoku/correspondence.hs

module Sudoku.Correspondence where

import qualified Data.Map as Map
import Data.List (sort, groupBy)
import Data.Tuple (swap)
import Data.Maybe (fromMaybe)
import Data.Function (on)

-- | 対応
data Correspondence a b = Correspondence (Map.Map a [b]) deriving Eq

-- | Map から対応へ
fromMap :: Map.Map a [b] -> Correspondence a b
fromMap  = Correspondence

-- | 対応をMap へ
toMap :: Correspondence a b -> Map.Map a [b]
toMap (Correspondence m) = m

-- | ペアのリストから対応へ
fromList :: (Ord a, Ord b) => [(a, b)] -> Correspondence a b
fromList = fromList' . map f . groupBy ((==) `on` fst) . sort
  where
    f xs = (fst $ head xs, map snd xs)

-- | ペアのリストから対応へ
fromList' :: (Ord a, Ord b) => [(a, [b])] -> Correspondence a b
fromList' = fromMap . Map.fromList

-- | 対応からペアのリストへ
toList :: Correspondence a b -> [(a, b)]
toList = concatMap (\(x, ys) -> zip (repeat x) ys) . toList'

-- | 対応からペアのリストへ
toList' :: Correspondence a b -> [(a, [b])]
toList' = Map.toList .toMap

-- | 逆対応
inverse :: (Ord a, Ord b) => Correspondence a b -> Correspondence b a
inverse = fromList . map swap . toList

-- | 像
image :: Ord a => a -> Correspondence a b -> [b]
image x = fromMaybe [] . Map.lookup x . toMap

-- | 逆像
inverseImage :: (Ord a, Ord b) => b -> Correspondence a b -> [a]
inverseImage x = image x . inverse

-- | 全ての像
images :: Correspondence a b -> [[b]]
images = Map.elems . toMap

-- | 全ての逆像
inverseImages :: (Ord a, Ord b) => Correspondence a b -> [[a]]
inverseImages =  images . inverse

-- | 始集合（重複は除いていない）
initial :: (Ord a, Ord b) => Correspondence a b -> [a]
initial = concat . inverseImages

-- | 終集合（重複は除いていない）
final :: Correspondence a b -> [b]
final = concat . images

-- | 一意対応
unique :: Correspondence a b -> Bool
unique = all nullOrLength1 . images

-- | 一対一対応
oneToOne :: (Ord a, Ord b) => Correspondence a b -> Bool
oneToOne c = unique c && unique (inverse c)

-- | 部分対応
subCorrespondence :: Ord a => [a] -> Correspondence a b -> Correspondence a b
subCorrespondence xs c = fromMap . Map.fromList . zip xs $ map (`image` c) xs

-- | 空、または１要素のみ
nullOrLength1 :: [a] -> Bool
nullOrLength1 [ ] = True
nullOrLength1 [_] = True
nullOrLength1  _  = False