Triple.hs

{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE LambdaCase #-}

-- https://stackoverflow.com/questions/10239630/where-to-find-programming-exercises-for-applicative-functors/10242673
-- https://github.com/pigworker/WhatRTypes4/blob/master/Types4.hs
--
module Triple where

import Control.Applicative
import Data.Char

-- (1)
data Triple a =
  Tr a a a
  deriving (Show)

newtype I x =
  I
    { unI :: x
    }
  deriving (Show)

instance Functor Triple where
  fmap f (Tr x y z) = Tr (f x) (f y) (f z)

instance Applicative Triple where
  pure x = Tr x x x
  (Tr f g h) <*> (Tr x y z) = Tr (f x) (g y) (h z)

instance Foldable Triple where
  foldr f z (Tr a1 a2 a3) = f a1 (f a2 (f a3 z))
  foldMap f (Tr a1 a2 a3) = mappend (f a1) (mappend (f a2) (f a3))
  null Tr {} = False

instance Traversable Triple where
  traverse f (Tr a1 a2 a3) = liftA3 Tr (f a1) (f a2) (f a3)

-- (2)

-- Cf, Data.Functor.Compose, which provides a standard version of right-to-left composition of functors.

newtype (f :. g) x =
  Comp
    { comp :: f (g x)
    }
  deriving (Show)

instance (Functor f, Functor g) => Functor (f :. g) where
  fmap f (Comp x) = Comp (fmap (fmap f) x)

instance (Foldable f, Foldable g) => Foldable (f :. g) where
  foldMap f (Comp t) = foldMap (foldMap f) t

instance (Traversable f, Traversable g) => Traversable (f :. g) where
  traverse f (Comp t) = Comp <$> traverse (traverse f) t

instance (Applicative f, Applicative g) => Applicative (f :. g) where
  pure x = Comp (pure (pure x))
  Comp f <*> Comp x = Comp (pure (<*>) <*> f <*> x)

instance (Alternative f, Applicative g) => Alternative (f :. g) where
  empty = Comp empty
  Comp x <|> Comp y = Comp (x <|> y)

type Zone = Triple :. Triple

type Board = Zone :. Zone

type Cell = Maybe Int

czone :: Zone Char
czone = Comp (Tr (Tr 'a' 'b' 'c') (Tr 'd' 'e' 'f') (Tr 'g' 'h' 'i'))

newly :: (f1 (g1 x1) -> f2 (g2 x2)) -> (:.) f1 g1 x1 -> (:.) f2 g2 x2
newly f = Comp . f . comp

rows :: Board a -> Board a
rows = id

cols :: Board a -> Board a
cols = Comp . sequenceA . comp

boxes :: Board a -> Board a
--boxBoard = newly (fmap Comp . newly (fmap sequenceA) . fmap comp)
boxes = Comp . fmap Comp . Comp . fmap sequenceA . comp . fmap comp . comp

-- (3)
newtype Parse x =
  Parser
    { parse :: String -> [(x, String)]
    }

instance Semigroup (Parse a) where
  Parser p <> Parser q =
    Parser $ \s ->
      case p s of
        [] -> q s
        r -> r

instance Monoid (Parse a) where
  mempty = Parser $ const []

instance Functor Parse where
  fmap f (Parser pa) = Parser $ \s -> [(f x, s') | (x, s') <- pa s]

instance Applicative Parse where
  pure x = Parser $ \s -> [(x, s)]
  Parser af <*> Parser aa =
    Parser $ \s -> [(f a, s'') | (f, s') <- af s, (a, s'') <- aa s']

instance Monad Parse where
  return x = Parser $ \s -> return (x, s)
  Parser pa >>= k =
    Parser $ \s -> do
      (x, s') <- pa s
      parse (k x) s'

instance Alternative Parse where
  empty = mempty
  (<|>) = mappend

ch :: (Char -> Bool) -> Parse Char
ch p =
  Parser $ \case
    c:s
      | p c -> [(c, s)]
    _ -> []

spaces :: Parse String
spaces = many (ch isSpace)

-- (4)
square :: Parse Int
square = pure digitToInt <*> (spaces *> ch isDigit)

board :: Parse (Board Int)
board = sequenceA (pure square)

tryThis :: String
tryThis =
  unlines
    [ "000230600"
    , "100000007"
    , "040005180"
    , "500000900"
    , "007306800"
    , "004000005"
    , "086700050"
    , "400000009"
    , "003062000"
    ]

-- (5)

-- Cf, Data.Functor.Const

newtype K a x =
  K
    { unK :: a
    }
  deriving (Show)

instance Monoid a => Functor (K a) where
  fmap _ (K x) = K x

instance Monoid a => Applicative (K a) where
  pure _ = K mempty
  (K f) <*> (K s) = K (f `mappend` s)
  
  --  liftA2 _ (K x) (K y) = K (x `mappend` y)
  --  (<*>) = coerce (mappend :: m -> m -> m)
  -- This version guarantees that mappend for Const a b will have the same arity
  -- as the one for a; it won't create a closure to raise the arity to 2.

-- For a monoidal applicative functor, traversal accumulates values. 
-- This function performs that accumulation, given an argument that assigns a value to each element
crush :: (Traversable f, Monoid b) => (a -> b) -> f a -> b
crush f = unK . traverse (K . f)
-- crush is just foldMap

-- The special case reduce (named crush, in Meertens’ version,
-- but with an additional monoidal constraint) applies when the elements are their own values:
reduce :: (Traversable t, Monoid o) => t o -> o
reduce = crush id

flatten :: (Traversable f) => f a -> [a]
flatten = crush (: [])

-- Cf, Data.Foldable versions

newtype Any =
  Any
    { unAny :: Bool
    }
  deriving (Show)

newtype All =
  All
    { unAll :: Bool
    }
  deriving (Show)

instance Semigroup Any where
  (Any x) <> (Any y) = Any $ x || y

instance Monoid Any where
  mempty = Any False

instance Semigroup All where
  (All x) <> (All y) = All $ x && y

instance Monoid All where
  mempty = All True

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)

-- (6)
elem :: (Eq a, Traversable t) => a -> t a -> Bool
elem = Triple.any . (==)

picks :: [x] -> [(x, [x])]
picks [] = []
picks (x:xs) = (x, xs) : [(y, x : ys) | (y, ys) <- picks xs]

-- NB: The duplicates are not unique
duplicates :: (Traversable f, Eq a) => f a -> [a]
duplicates = map fst . filter (uncurry Triple.elem) . picks . flatten

complete :: Board Int -> Bool
complete = Triple.all (`Triple.elem` [1 .. 9])

ok :: Board Int -> Bool
ok t = Triple.all (\f -> null $ duplicates $ f t) [rows, cols, boxes]