Instantly share code, notes, and snippets.

Embed
What would you like to do?
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