Applicative-based Sudoku solver
{-# LANGUAGE TypeOperators #-} | |
{-# LANGUAGE GeneralizedNewtypeDeriving #-} | |
import Control.Applicative | |
import Data.Char | |
import Data.List (intersperse) | |
import Data.Monoid hiding (All, Any) | |
import Data.Foldable hiding (all, any) | |
import Prelude hiding (all, any) | |
-- TODO | |
-- [ ] Parametrize by board size | |
-- Ex 1 | |
data Triple a = Tr a a a | |
deriving (Show, Eq) | |
instance Functor Triple where | |
fmap f (Tr a b c) = Tr (f a) (f b) (f c) | |
instance Foldable Triple where | |
foldMap f (Tr a b c) = mconcat [f a, f b, f c] | |
instance Applicative Triple where | |
pure a = Tr a a a | |
(Tr f g h) <*> (Tr a b c) = Tr (f a) (g b) (h c) | |
instance Traversable Triple where | |
traverse f (Tr a b c) = pure Tr <*> f a <*> f b <*> f c | |
-- Writing fmap in terms of pure and (<*>) | |
fmap' :: Applicative f => (a -> b) -> f a -> f b | |
fmap' f x = (pure f) <*> x | |
newtype I x = I { unI :: x } | |
deriving (Show, Eq) | |
-- Ex 2 | |
newtype (:.) f g x = Comp { comp :: f (g x) } | |
deriving (Show, Eq) | |
instance (Functor f, Functor g) => Functor (f :. g) where | |
fmap f (Comp x) = Comp $ fmap (fmap f) x | |
instance (Applicative f, Applicative g) => Applicative (f :. g) where | |
pure = Comp . pure . pure | |
Comp f <*> Comp x = Comp $ (fmap (<*>) f) <*> x | |
instance (Foldable f, Foldable g) => Foldable (f :. g) where | |
foldMap f (Comp x) = foldMap (foldMap f) x | |
instance (Traversable f, Traversable g) => Traversable (f :. g) where | |
traverse f (Comp x) = pure Comp <*> traverse (traverse f) x | |
type Zone = Triple :. Triple | |
type Board = Zone :. Zone | |
rows :: Board a -> Board a | |
rows = id | |
cols :: Board a -> Board a | |
cols = Comp . sequenceA . comp | |
-- Q Is there a cleaner way of doing this? | |
boxs :: Board a -> Board a | |
boxs = Comp . Comp . fmap (fmap Comp) . fmap sequenceA . fmap (fmap comp) . comp . comp | |
-- Ex 3 | |
newtype Parse x = Parser { parse :: String -> [(x, String)] } | |
deriving Monoid | |
instance Functor Parse where | |
fmap f p = Parser $ \s -> [(f x, s') | (x, s') <- parse p s] | |
instance Applicative Parse where | |
pure x = Parser $ \s -> [(x, s)] | |
f <*> x = Parser $ \s -> | |
[(f' x', s'') | (f', s') <- parse f s, (x', s'') <- parse x s'] | |
instance Alternative Parse where | |
empty = mempty | |
(<|>) = mappend | |
ch :: (Char -> Bool) -> Parse Char | |
ch p = Parser f | |
where | |
f [] = [] | |
f (s:xs) | p s = [(s, xs)] | |
f _ | otherwise = [] | |
-- Ex 4 | |
whitespace :: Parse Char | |
whitespace = ch (== ' ') | |
digit :: Parse Char | |
digit = ch $ flip elem $ ['0'..'9'] | |
then' :: Parse Char -> Parse String -> Parse String | |
then' p q = pure (:) <*> p <*> q | |
rep :: Parse Char -> Parse String | |
rep p = (then' p (rep p)) <|> pure "" | |
square :: Parse Int | |
square = pure digitToInt <*> (pure (flip const) <*> rep whitespace <*> digit) | |
-- Q Wow! How come that this works?! | |
board :: Parse (Board Int) | |
board = traverse (const square) (pure 0 :: Board Int) | |
-- Q How to use newline in string? | |
b :: String | |
b = mconcat $ intersperse " " | |
[ "0 0 0 0 0 0 6 8 0" | |
, "0 0 0 0 7 3 0 0 9" | |
, "3 0 9 0 0 0 0 4 5" | |
, "4 9 0 0 0 0 0 0 0" | |
, "8 0 3 0 5 0 9 0 2" | |
, "0 0 0 0 0 0 0 3 6" | |
, "9 6 0 0 0 0 3 0 8" | |
, "7 0 0 6 8 0 0 0 0" | |
, "0 2 8 0 0 0 0 0 0"] | |
-- Ex 5 | |
newtype K a x = K { unK :: a } | |
deriving Show | |
instance Monoid a => Functor (K a) where | |
-- Q Why doesn't this work `fmap _ = id`? | |
fmap _ (K a) = K a | |
instance Monoid a => Applicative (K a) where | |
pure _ = K mempty | |
(K a) <*> (K b) = K $ mappend a b | |
crush :: (Traversable f, Monoid b) => (a -> b) -> f a -> b | |
crush f t = unK $ traverse (K . f) t | |
newtype Any = Any { unAny :: Bool } deriving Show | |
newtype All = All { unAll :: Bool } deriving Show | |
instance Monoid Any where | |
mempty = Any False | |
mappend (Any x) (Any y) = Any $ x || y | |
instance Monoid All where | |
mempty = All True | |
mappend (All x) (All y) = All $ x && y | |
all :: Traversable t => (a -> Bool) -> t a -> Bool | |
all p = unAll . crush (All . p) | |
any :: Traversable t => (a -> Bool) -> t a -> Bool | |
any p = unAny . crush (Any . p) | |
duplicates :: (Traversable f, Eq a) => f a -> [a] | |
duplicates = fmap fst . filter ((> 1) . snd) . foldr count [] | |
count :: Eq a => a -> [(a, Int)] -> [(a, Int)] | |
count x [] = [(x, 1)] | |
count x ((x', c):xs) | x == x' = (x', c + 1):xs | |
| otherwise = (x', c):(count x xs) | |
complete :: Board Int -> Bool | |
complete = all (flip elem [1..9]) | |
ok :: Board Int -> Bool | |
ok t = all (\f -> null $ duplicates $ f t) [rows, cols, boxs] |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
This comment has been minimized.
fmap _ = K . unK
would work. The difference betweenk . unK
andid
is thatk . unK
has typeK a b -> K a c
, so it lets the phantom type change.id
has typea -> a
, so it won't let the phantom type change. Similarly, had you wrotefmap _ a = a
, it would have failed for the same reason asid
.