{-# language RankNTypes #-}
{-# language Safe #-}
-- |
-- Module       : Data.Group
-- Copyright    : (c) 2020 Reed Mullanix, Emily Pillmore
-- License      : BSD-style
--
-- Maintainer   : Reed Mullanix <reedmullanix@gmail.com>,
--                Emily Pillmore <emilypi@cohomolo.gy>
--
-- Stability    : stable
-- Portability  : non-portable
--
-- This module provides definitions for Church-encoded
-- 'FreeGroup's, 'FreeAbelianGroup's, along with useful combinators.
--
module Data.Group.Free.Church
( -- * Church-encoded free groups
  FG(..)
  -- ** Church-encoded free group combinators
, interpretFG
, reifyFG
, reflectFG
, presentFG
  -- * Church-encoded free abelian groups
, FA(..)
  -- ** Church-encoded free abelian group combinators
, forgetFA
, interpretFA
, reifyFA
, reflectFA
) where

import Control.Applicative
import Control.Monad

import Data.Group
import Data.Group.Free
import qualified Data.Map.Strict as Map

-- | The Church-encoding of a 'FreeGroup'.
--
-- This datatype represents the free group on some @a@-valued
-- generators. For more information on why this encoding is preferred,
-- see Dan Doel's <http://comonad.com/reader/2015/free-monoids-in-haskell/ article> in
-- the Comonad Reader.
--
newtype FG a = FG { FG a -> forall g. Group g => (a -> g) -> g
runFG :: forall g. (Group g) => (a -> g) -> g }

instance Semigroup (FG a) where
  (FG forall g. Group g => (a -> g) -> g
g) <> :: FG a -> FG a -> FG a
<> (FG forall g. Group g => (a -> g) -> g
g') = (forall g. Group g => (a -> g) -> g) -> FG a
forall a. (forall g. Group g => (a -> g) -> g) -> FG a
FG ((forall g. Group g => (a -> g) -> g) -> FG a)
-> (forall g. Group g => (a -> g) -> g) -> FG a
forall a b. (a -> b) -> a -> b
$ \a -> g
k -> (a -> g) -> g
forall g. Group g => (a -> g) -> g
g a -> g
k g -> g -> g
forall a. Semigroup a => a -> a -> a
<> (a -> g) -> g
forall g. Group g => (a -> g) -> g
g' a -> g
k

instance Monoid (FG a) where
  mempty :: FG a
mempty = (forall g. Group g => (a -> g) -> g) -> FG a
forall a. (forall g. Group g => (a -> g) -> g) -> FG a
FG ((forall g. Group g => (a -> g) -> g) -> FG a)
-> (forall g. Group g => (a -> g) -> g) -> FG a
forall a b. (a -> b) -> a -> b
$ g -> (a -> g) -> g
forall a b. a -> b -> a
const g
forall a. Monoid a => a
mempty

instance Group (FG a) where
  invert :: FG a -> FG a
invert (FG forall g. Group g => (a -> g) -> g
g) = (forall g. Group g => (a -> g) -> g) -> FG a
forall a. (forall g. Group g => (a -> g) -> g) -> FG a
FG (g -> g
forall a. Group a => a -> a
invert (g -> g) -> ((a -> g) -> g) -> (a -> g) -> g
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> g) -> g
forall g. Group g => (a -> g) -> g
g)

instance Functor FG where
  fmap :: (a -> b) -> FG a -> FG b
fmap a -> b
f (FG forall g. Group g => (a -> g) -> g
fa) = (forall g. Group g => (b -> g) -> g) -> FG b
forall a. (forall g. Group g => (a -> g) -> g) -> FG a
FG ((forall g. Group g => (b -> g) -> g) -> FG b)
-> (forall g. Group g => (b -> g) -> g) -> FG b
forall a b. (a -> b) -> a -> b
$ \b -> g
k -> (a -> g) -> g
forall g. Group g => (a -> g) -> g
fa (b -> g
k (b -> g) -> (a -> b) -> a -> g
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

instance Applicative FG where
  pure :: a -> FG a
pure a
a = (forall g. Group g => (a -> g) -> g) -> FG a
forall a. (forall g. Group g => (a -> g) -> g) -> FG a
FG ((a -> g) -> a -> g
forall a b. (a -> b) -> a -> b
$ a
a)
  <*> :: FG (a -> b) -> FG a -> FG b
(<*>) = FG (a -> b) -> FG a -> FG b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad FG where
  return :: a -> FG a
return = a -> FG a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  (FG forall g. Group g => (a -> g) -> g
fg) >>= :: FG a -> (a -> FG b) -> FG b
>>= a -> FG b
f = (forall g. Group g => (b -> g) -> g) -> FG b
forall a. (forall g. Group g => (a -> g) -> g) -> FG a
FG ((forall g. Group g => (b -> g) -> g) -> FG b)
-> (forall g. Group g => (b -> g) -> g) -> FG b
forall a b. (a -> b) -> a -> b
$ \b -> g
k -> (a -> g) -> g
forall g. Group g => (a -> g) -> g
fg (\a
a -> (FG b -> forall g. Group g => (b -> g) -> g
forall a. FG a -> forall g. Group g => (a -> g) -> g
runFG (FG b -> forall g. Group g => (b -> g) -> g)
-> FG b -> forall g. Group g => (b -> g) -> g
forall a b. (a -> b) -> a -> b
$ a -> FG b
f a
a) b -> g
k)

instance Alternative FG where
  empty :: FG a
empty = FG a
forall a. Monoid a => a
mempty
  <|> :: FG a -> FG a -> FG a
(<|>) = FG a -> FG a -> FG a
forall a. Semigroup a => a -> a -> a
(<>)

-- | Interpret a Church-encoded free group as a concrete 'FreeGroup'.
--
interpretFG :: Group g => FG g -> g
interpretFG :: FG g -> g
interpretFG (FG forall g. Group g => (g -> g) -> g
fg) = (g -> g) -> g
forall g. Group g => (g -> g) -> g
fg g -> g
forall a. a -> a
id
{-# inline interpretFG #-}

-- | Convert a Church-encoded free group to a concrete 'FreeGroup'.
--
reifyFG :: FG a -> FreeGroup a
reifyFG :: FG a -> FreeGroup a
reifyFG FG a
fg = FG (FreeGroup a) -> FreeGroup a
forall g. Group g => FG g -> g
interpretFG (FG (FreeGroup a) -> FreeGroup a)
-> FG (FreeGroup a) -> FreeGroup a
forall a b. (a -> b) -> a -> b
$ (a -> FreeGroup a) -> FG a -> FG (FreeGroup a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> FreeGroup a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FG a
fg
{-# inline reifyFG #-}

-- | Convert a concrete 'FreeGroup' to a Church-encoded free group.
--
reflectFG :: FreeGroup a -> FG a
reflectFG :: FreeGroup a -> FG a
reflectFG (FreeGroup [Either a a]
fg) = (forall g. Group g => (a -> g) -> g) -> FG a
forall a. (forall g. Group g => (a -> g) -> g) -> FG a
FG ((forall g. Group g => (a -> g) -> g) -> FG a)
-> (forall g. Group g => (a -> g) -> g) -> FG a
forall a b. (a -> b) -> a -> b
$ \a -> g
k -> (Either a a -> g) -> [Either a a] -> g
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((a -> g) -> Either a a -> g
forall p t. Group p => (t -> p) -> Either t t -> p
go a -> g
k) [Either a a]
fg
  where
    go :: (t -> p) -> Either t t -> p
go t -> p
k (Left t
a) = p -> p
forall a. Group a => a -> a
invert (t -> p
k t
a)
    go t -> p
k (Right t
a) = t -> p
k t
a
{-# inline reflectFG #-}

-- | Present a 'Group' as a 'FG' modulo relations.
--
presentFG :: Group g => FG g -> (FG g -> g) -> g
presentFG :: FG g -> (FG g -> g) -> g
presentFG = ((FG g -> g) -> FG g -> g) -> FG g -> (FG g -> g) -> g
forall a b c. (a -> b -> c) -> b -> a -> c
flip (FG g -> g) -> FG g -> g
forall a b. (a -> b) -> a -> b
($)
{-# inline presentFG #-}

----------------------------------------
-- Free Abelian Groups

-- | The Church-encoding of a 'FreeAbelianGroup'.
--
-- This datatype represents the free group on some @a@-valued
-- generators, along with their exponents in the group.
--
newtype FA a = FA { FA a -> forall g. Group g => (a -> Int -> g) -> g
runFA :: forall g. (Group g) => (a -> Int -> g) -> g }

instance Semigroup (FA a) where
  (FA forall g. Group g => (a -> Int -> g) -> g
g) <> :: FA a -> FA a -> FA a
<> (FA forall g. Group g => (a -> Int -> g) -> g
g') = (forall g. Group g => (a -> Int -> g) -> g) -> FA a
forall a. (forall g. Group g => (a -> Int -> g) -> g) -> FA a
FA ((forall g. Group g => (a -> Int -> g) -> g) -> FA a)
-> (forall g. Group g => (a -> Int -> g) -> g) -> FA a
forall a b. (a -> b) -> a -> b
$ \a -> Int -> g
k -> (a -> Int -> g) -> g
forall g. Group g => (a -> Int -> g) -> g
g a -> Int -> g
k g -> g -> g
forall a. Semigroup a => a -> a -> a
<> (a -> Int -> g) -> g
forall g. Group g => (a -> Int -> g) -> g
g' a -> Int -> g
k

instance Monoid (FA a) where
  mempty :: FA a
mempty = (forall g. Group g => (a -> Int -> g) -> g) -> FA a
forall a. (forall g. Group g => (a -> Int -> g) -> g) -> FA a
FA ((forall g. Group g => (a -> Int -> g) -> g) -> FA a)
-> (forall g. Group g => (a -> Int -> g) -> g) -> FA a
forall a b. (a -> b) -> a -> b
$ g -> (a -> Int -> g) -> g
forall a b. a -> b -> a
const g
forall a. Monoid a => a
mempty

instance Group (FA a) where
  invert :: FA a -> FA a
invert (FA forall g. Group g => (a -> Int -> g) -> g
g) = (forall g. Group g => (a -> Int -> g) -> g) -> FA a
forall a. (forall g. Group g => (a -> Int -> g) -> g) -> FA a
FA (g -> g
forall a. Group a => a -> a
invert (g -> g) -> ((a -> Int -> g) -> g) -> (a -> Int -> g) -> g
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Int -> g) -> g
forall g. Group g => (a -> Int -> g) -> g
g)

instance Functor FA where
  fmap :: (a -> b) -> FA a -> FA b
fmap a -> b
f (FA forall g. Group g => (a -> Int -> g) -> g
fa) = (forall g. Group g => (b -> Int -> g) -> g) -> FA b
forall a. (forall g. Group g => (a -> Int -> g) -> g) -> FA a
FA ((forall g. Group g => (b -> Int -> g) -> g) -> FA b)
-> (forall g. Group g => (b -> Int -> g) -> g) -> FA b
forall a b. (a -> b) -> a -> b
$ \b -> Int -> g
k -> (a -> Int -> g) -> g
forall g. Group g => (a -> Int -> g) -> g
fa (b -> Int -> g
k (b -> Int -> g) -> (a -> b) -> a -> Int -> g
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

instance Applicative FA where
  pure :: a -> FA a
pure a
a = (forall g. Group g => (a -> Int -> g) -> g) -> FA a
forall a. (forall g. Group g => (a -> Int -> g) -> g) -> FA a
FA ((forall g. Group g => (a -> Int -> g) -> g) -> FA a)
-> (forall g. Group g => (a -> Int -> g) -> g) -> FA a
forall a b. (a -> b) -> a -> b
$ \a -> Int -> g
k -> a -> Int -> g
k a
a Int
1
  <*> :: FA (a -> b) -> FA a -> FA b
(<*>) = FA (a -> b) -> FA a -> FA b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad FA where
  return :: a -> FA a
return = a -> FA a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  (FA forall g. Group g => (a -> Int -> g) -> g
fa) >>= :: FA a -> (a -> FA b) -> FA b
>>= a -> FA b
f = (forall g. Group g => (b -> Int -> g) -> g) -> FA b
forall a. (forall g. Group g => (a -> Int -> g) -> g) -> FA a
FA ((forall g. Group g => (b -> Int -> g) -> g) -> FA b)
-> (forall g. Group g => (b -> Int -> g) -> g) -> FA b
forall a b. (a -> b) -> a -> b
$ \b -> Int -> g
k -> (a -> Int -> g) -> g
forall g. Group g => (a -> Int -> g) -> g
fa (\a
a Int
n -> Int -> g -> g
forall a n. (Group a, Integral n) => n -> a -> a
gtimes Int
n (g -> g) -> g -> g
forall a b. (a -> b) -> a -> b
$ (FA b -> forall g. Group g => (b -> Int -> g) -> g
forall a. FA a -> forall g. Group g => (a -> Int -> g) -> g
runFA (FA b -> forall g. Group g => (b -> Int -> g) -> g)
-> FA b -> forall g. Group g => (b -> Int -> g) -> g
forall a b. (a -> b) -> a -> b
$ a -> FA b
f a
a) b -> Int -> g
k)

instance Alternative FA where
  empty :: FA a
empty = FA a
forall a. Monoid a => a
mempty
  <|> :: FA a -> FA a -> FA a
(<|>) = FA a -> FA a -> FA a
forall a. Semigroup a => a -> a -> a
(<>)

-- | Interpret a Church-encoded free abelian group as a concrete 'FreeAbelianGroup'.
--
interpretFA :: Group g => FA g -> g
interpretFA :: FA g -> g
interpretFA (FA forall g. Group g => (g -> Int -> g) -> g
fa) = (g -> Int -> g) -> g
forall g. Group g => (g -> Int -> g) -> g
fa ((Int -> g -> g) -> g -> Int -> g
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> g -> g
forall a n. (Group a, Integral n) => n -> a -> a
gtimes)
{-# inline interpretFA #-}

-- | Convert a Church-encoded free abelian group to a concrete 'FreeAbelianGroup'.
--
reifyFA :: Ord a => FA a -> FreeAbelianGroup a
reifyFA :: FA a -> FreeAbelianGroup a
reifyFA = FA (FreeAbelianGroup a) -> FreeAbelianGroup a
forall g. Group g => FA g -> g
interpretFA (FA (FreeAbelianGroup a) -> FreeAbelianGroup a)
-> (FA a -> FA (FreeAbelianGroup a)) -> FA a -> FreeAbelianGroup a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> FreeAbelianGroup a) -> FA a -> FA (FreeAbelianGroup a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> FreeAbelianGroup a
forall a. a -> FreeAbelianGroup a
singleton
{-# inline reifyFA #-}

-- | Convert a concrete 'FreeAbelianGroup' to a Church-encoded free abelian group.
--
reflectFA :: Ord a => FreeAbelianGroup a -> FA a
reflectFA :: FreeAbelianGroup a -> FA a
reflectFA (FreeAbelianGroup Map a Int
fa) = (forall g. Group g => (a -> Int -> g) -> g) -> FA a
forall a. (forall g. Group g => (a -> Int -> g) -> g) -> FA a
FA ((forall g. Group g => (a -> Int -> g) -> g) -> FA a)
-> (forall g. Group g => (a -> Int -> g) -> g) -> FA a
forall a b. (a -> b) -> a -> b
$ \a -> Int -> g
k -> (a -> Int -> g) -> Map a Int -> g
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey a -> Int -> g
k Map a Int
fa
{-# inline reflectFA #-}

-- | Forget the commutative structure of a Church-encoded free abelian group,
-- turning it into a standard free group.
--
forgetFA :: Group a => FA a -> FG a
forgetFA :: FA a -> FG a
forgetFA FA a
fa = (forall g. Group g => (a -> g) -> g) -> FG a
forall a. (forall g. Group g => (a -> g) -> g) -> FG a
FG ((a -> g) -> a -> g
forall a b. (a -> b) -> a -> b
$ FA a -> a
forall g. Group g => FA g -> g
interpretFA FA a
fa)
{-# inline forgetFA #-}