{-# language RankNTypes #-}
{-# language Safe #-}
-- |
-- Module       : Data.Group
-- Copyright    : (c) 2020-2021 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, 'Data.Group.Free.Internal.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.Semigroup(Semigroup(..))
import Data.Group
import Data.Group.Free
import qualified Data.Map.Strict as Map

-- | The Church-encoding of a 'FreeGroup'.
--
-- This datatype represents the "true" free group in Haskell 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.
--
-- While 'FreeGroup' et al are free in a strict language, and are more intuitive,
-- they are not associative wtih respect to bottoms. 'FG' and 'FA' however, are,
-- and should be preferred when working with possibly undefined data.
--
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 m. Group m => m -> m
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 m. Group m => m -> m
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 'Data.Group.Free.Internal.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. Abelian g => (a -> Integer -> g) -> g
runFA :: forall g. Abelian g => (a -> Integer -> g) -> g }

instance Semigroup (FA a) where
  (FA forall g. Abelian g => (a -> Integer -> g) -> g
g) <> :: FA a -> FA a -> FA a
<> (FA forall g. Abelian g => (a -> Integer -> g) -> g
g') = (forall g. Abelian g => (a -> Integer -> g) -> g) -> FA a
forall a. (forall g. Abelian g => (a -> Integer -> g) -> g) -> FA a
FA ((forall g. Abelian g => (a -> Integer -> g) -> g) -> FA a)
-> (forall g. Abelian g => (a -> Integer -> g) -> g) -> FA a
forall a b. (a -> b) -> a -> b
$ \a -> Integer -> g
k -> (a -> Integer -> g) -> g
forall g. Abelian g => (a -> Integer -> g) -> g
g a -> Integer -> g
k g -> g -> g
forall a. Semigroup a => a -> a -> a
<> (a -> Integer -> g) -> g
forall g. Abelian g => (a -> Integer -> g) -> g
g' a -> Integer -> g
k
  stimes :: b -> FA a -> FA a
stimes = b -> FA a -> FA a
forall a n. (Group a, Integral n) => n -> a -> a
gtimes

instance Monoid (FA a) where
  mempty :: FA a
mempty = (forall g. Abelian g => (a -> Integer -> g) -> g) -> FA a
forall a. (forall g. Abelian g => (a -> Integer -> g) -> g) -> FA a
FA ((forall g. Abelian g => (a -> Integer -> g) -> g) -> FA a)
-> (forall g. Abelian g => (a -> Integer -> g) -> g) -> FA a
forall a b. (a -> b) -> a -> b
$ g -> (a -> Integer -> 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 a
g = FA a -> Integer -> FA a
forall m x. (Group m, Integral x) => m -> x -> m
pow FA a
g (-Integer
1 :: Integer)

  {-
  Note: This implementation "optimizes" from the default implementation of
  'pow', or more natural

  > pow (FA g) n = FA $ \k -> gtimes n (g k)

  by delaying the call of 'gtimes' as late as possible.

  This is only possible because we expect 'Group g' to be an abelian group,
  which implies the following equation hold:

  > pow (x <> y) n = pow x n <> pow y n
  -}
  pow :: FA a -> x -> FA a
pow (FA forall g. Abelian g => (a -> Integer -> g) -> g
g) x
n
    | x
n x -> x -> Bool
forall a. Eq a => a -> a -> Bool
== x
0    = FA a
forall a. Monoid a => a
mempty
    | Bool
otherwise = (forall g. Abelian g => (a -> Integer -> g) -> g) -> FA a
forall a. (forall g. Abelian g => (a -> Integer -> g) -> g) -> FA a
FA ((forall g. Abelian g => (a -> Integer -> g) -> g) -> FA a)
-> (forall g. Abelian g => (a -> Integer -> g) -> g) -> FA a
forall a b. (a -> b) -> a -> b
$ \a -> Integer -> g
k -> (a -> Integer -> g) -> g
forall g. Abelian g => (a -> Integer -> g) -> g
g (\a
a Integer
i -> a -> Integer -> g
k a
a (x -> Integer
forall a. Integral a => a -> Integer
toInteger x
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
i))

instance Abelian (FA a)

instance Functor FA where
  fmap :: (a -> b) -> FA a -> FA b
fmap a -> b
f (FA forall g. Abelian g => (a -> Integer -> g) -> g
fa) = (forall g. Abelian g => (b -> Integer -> g) -> g) -> FA b
forall a. (forall g. Abelian g => (a -> Integer -> g) -> g) -> FA a
FA ((forall g. Abelian g => (b -> Integer -> g) -> g) -> FA b)
-> (forall g. Abelian g => (b -> Integer -> g) -> g) -> FA b
forall a b. (a -> b) -> a -> b
$ \b -> Integer -> g
k -> (a -> Integer -> g) -> g
forall g. Abelian g => (a -> Integer -> g) -> g
fa (b -> Integer -> g
k (b -> Integer -> g) -> (a -> b) -> a -> Integer -> 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. Abelian g => (a -> Integer -> g) -> g) -> FA a
forall a. (forall g. Abelian g => (a -> Integer -> g) -> g) -> FA a
FA ((forall g. Abelian g => (a -> Integer -> g) -> g) -> FA a)
-> (forall g. Abelian g => (a -> Integer -> g) -> g) -> FA a
forall a b. (a -> b) -> a -> b
$ \a -> Integer -> g
k -> a -> Integer -> g
k a
a Integer
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 a
fa >>= :: FA a -> (a -> FA b) -> FA b
>>= a -> FA b
f = FA (FA b) -> FA b
forall g. Abelian g => FA g -> g
interpretFA (FA (FA b) -> FA b) -> FA (FA b) -> FA b
forall a b. (a -> b) -> a -> b
$ (a -> FA b) -> FA a -> FA (FA b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> FA b
f FA a
fa

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 'Data.Group.Free.Internal.FreeAbelianGroup'.
--
interpretFA :: Abelian g => FA g -> g
interpretFA :: FA g -> g
interpretFA (FA forall g. Abelian g => (g -> Integer -> g) -> g
fa) = (g -> Integer -> g) -> g
forall g. Abelian g => (g -> Integer -> g) -> g
fa g -> Integer -> g
forall m x. (Group m, Integral x) => m -> x -> m
pow
{-# inline interpretFA #-}

-- | Convert a Church-encoded free abelian group to a concrete 'Data.Group.Free.Internal.FreeAbelianGroup'.
--
reifyFA :: Ord a => FA a -> FreeAbelianGroup a
reifyFA :: FA a -> FreeAbelianGroup a
reifyFA = FA (FreeAbelianGroup a) -> FreeAbelianGroup a
forall g. Abelian 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 'Data.Group.Free.Internal.FreeAbelianGroup' to a Church-encoded free abelian group.
--
reflectFA :: FreeAbelianGroup a -> FA a
reflectFA :: FreeAbelianGroup a -> FA a
reflectFA FreeAbelianGroup a
fa =
  let g :: Map a Integer
g = FreeAbelianGroup a -> Map a Integer
forall a. FreeAbelianGroup a -> Map a Integer
runFreeAbelianGroup FreeAbelianGroup a
fa
  in (forall g. Abelian g => (a -> Integer -> g) -> g) -> FA a
forall a. (forall g. Abelian g => (a -> Integer -> g) -> g) -> FA a
FA ((forall g. Abelian g => (a -> Integer -> g) -> g) -> FA a)
-> (forall g. Abelian g => (a -> Integer -> g) -> g) -> FA a
forall a b. (a -> b) -> a -> b
$ \a -> Integer -> g
k -> (a -> Integer -> g) -> Map a Integer -> g
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey a -> Integer -> g
k Map a Integer
g
{-# inline reflectFA #-}

-- | Forget the commutative structure of a Church-encoded free abelian group,
-- turning it into a standard free group.
forgetFA :: (Ord a) => FA a -> FG a
forgetFA :: FA a -> FG a
forgetFA FA a
fa = case FA a -> FreeAbelianGroup a
forall a. Ord a => FA a -> FreeAbelianGroup a
reifyFA FA a
fa of
  ~(FreeAbelianGroup Map a Integer
fa') -> (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
t -> (a -> Integer -> g) -> Map a Integer -> g
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey (\a
a Integer
n -> a -> g
t a
a g -> Integer -> g
forall m x. (Group m, Integral x) => m -> x -> m
`pow` Integer
n) Map a Integer
fa'
{-# inline forgetFA #-}