{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
module Examples.Sudoku where
import Props
import Data.Foldable
import Text.RawString.QQ (r)
import qualified Data.Set as S
import Data.List
txtToBoard :: [String] -> [[S.Set Int]]
txtToBoard = (fmap . fmap) possibilities
where
possibilities :: Char -> S.Set Int
possibilities '.' = S.fromList [1..9]
possibilities a = S.fromList [read [a]]
boardToText :: [[Int]] -> String
boardToText xs = unlines . fmap concat $ (fmap . fmap) show xs
easyBoard :: [[S.Set Int]]
easyBoard = txtToBoard . tail . lines $ [r|
..3.42.9.
.9..6.5..
5......1.
..17..285
..8...1..
329..87..
.3......1
..5.9..2.
.8.21.6..|]
hardestBoard :: [[S.Set Int]]
hardestBoard = txtToBoard . tail . lines $ [r|
8........
..36.....
.7..9.2..
.5...7...
....457..
...1...3.
..1....68
..85...1.
.9....4..|]
rowsOf :: [[a]] -> [[a]]
rowsOf = id
colsOf :: [[a]] -> [[a]]
colsOf = transpose
blocksOf :: [[a]] -> [[a]]
blocksOf = chunksOf 9 . concat . concat . fmap transpose . chunksOf 3 . transpose
where
chunksOf :: Int -> [a] -> [[a]]
chunksOf n = unfoldr go
where
go [] = Nothing
go xs = Just (take n xs, drop n xs)
linkBoardCells :: [[PVar S.Set Int]] -> Prop ()
linkBoardCells xs = do
let rows = rowsOf xs
let cols = colsOf xs
let blocks = blocksOf xs
for_ (rows <> cols <> blocks) $ \region -> do
let uniquePairings = [(a, b) | a <- region, b <- region, a /= b]
for_ uniquePairings $ \(a, b) -> constrain a b disj
where
disj :: Ord a => a -> S.Set a -> S.Set a
disj x xs = S.delete x xs
constrainBoard :: [[S.Set Int]]-> Prop [[PVar S.Set Int]]
constrainBoard board = do
vars <- (traverse . traverse) newPVar board
linkBoardCells vars
return vars
solvePuzzle :: [[S.Set Int]] -> IO ()
solvePuzzle puz = do
let Just results = solve (fmap . fmap) $ constrainBoard puz
putStrLn $ boardToText results
solveEasyPuzzle :: IO ()
solveEasyPuzzle = solvePuzzle easyBoard