Applicative-based Sudoku solver

Sudoku.hs

{-# 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]