-- |
-- Module       : Data.Group.Free.Product
-- 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 the 'FreeProduct' of two groups,
-- along with useful combinators.
--
module Data.Group.Free.Product
( FreeProduct(..)
, simplify
, coproduct
, injl
, injr
) where

import Data.Bifunctor
import Data.Group
import Data.Group.Order

import Data.Sequence (Seq(..))
import qualified Data.Sequence as Seq


-- -------------------------------------------------------------------- --
-- Free products

-- | The free product on two alphabets
--
-- __Note:__ This does not perform simplification upon multiplication or construction.
-- To do this, one should use 'simplify'.
--
newtype FreeProduct g h = FreeProduct { runFreeProduct :: Seq (Either g h) }
  deriving (Show, Eq, Ord)

instance Functor (FreeProduct g) where
  fmap f = FreeProduct . fmap (fmap f) . runFreeProduct

instance Bifunctor FreeProduct where
  bimap f g = FreeProduct . fmap (bimap f g) . runFreeProduct

-- | /O(n)/ Simplifies a word in a 'FreeProduct'.
-- This means that we get rid of any identity elements, and perform multiplication of neighboring @g@s and @h@s.
--
simplify :: (Eq g, Eq h, Monoid g, Monoid h) => FreeProduct g h -> FreeProduct g h
simplify (FreeProduct fp) = FreeProduct $ go fp
  where
    go (Left IdentityElem :<| ghs) = go ghs
    go (Right IdentityElem :<| ghs) = go ghs
    go (Left g :<| Left g' :<| ghs) = go $ Left (g <> g') :<| ghs
    go (Right h :<| Right h' :<| ghs) = go $ Right (h <> h') :<| ghs
    go (gh :<| ghs) = gh :<| go ghs
    go Empty = Empty

instance Semigroup (FreeProduct g h) where
  FreeProduct ghs <> FreeProduct ghs' = FreeProduct $ ghs <> ghs'

instance Monoid (FreeProduct g h) where
  mempty = FreeProduct Seq.empty

instance (Group g, Group h) => Group (FreeProduct g h) where
  invert (FreeProduct ghs) = FreeProduct $ bimap invert invert <$> Seq.reverse ghs

instance (GroupOrder g, GroupOrder h) => GroupOrder (FreeProduct g h) where
  -- TODO: It performs simplify each time @order@ is called.
  --   Once "auto-simplify" is implemented, this
  --   call of simplify should be removed.
  order = go . runFreeProduct . simplify
    where
      go Seq.Empty         = Finite 1
      go (x :<| Seq.Empty) = either order order x
      go (Left g :<| (ghs :|> Left g'))
        | g <> g' == mempty = go ghs
      go (Right h :<| (ghs :|> Right h'))
        | h <> h' == mempty = go ghs
      go _ = Infinite

-- | Left injection of an alphabet @a@ into a free product.
--
injl :: a -> FreeProduct a b
injl a = FreeProduct $ Seq.singleton (Left a)

-- | Right injection of an alphabet @b@ into a free product.
--
injr :: b -> FreeProduct a b
injr b = FreeProduct $ Seq.singleton (Right b)

-- | The 'FreeProduct' of two 'Monoid's is a coproduct in the category of monoids (and by extension, the category of groups).
--
coproduct :: Monoid m => (a -> m) -> (b -> m) -> FreeProduct a b -> m
coproduct gi hi (FreeProduct ghs) = foldMap (either gi hi) ghs