Instantly share code, notes, and snippets.

# danoneata/Sudoku.hs Last active Jan 3, 2019

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]
to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.