Skip to content

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]
@josephcsible

This comment has been minimized.

Copy link

josephcsible commented Sep 11, 2019

Q Why doesn't this work fmap _ = id?

fmap _ = K . unK would work. The difference between k . unK and id is that k . unK has type K a b -> K a c, so it lets the phantom type change. id has type a -> a, so it won't let the phantom type change. Similarly, had you wrote fmap _ a = a, it would have failed for the same reason as id.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.