    {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
    module Numeric.Algebra.Unital
      (
      -- * Unital Multiplication (Multiplicative monoid)
        Unital(..)
      , product
      -- * Unital Associative Algebra
      , UnitalAlgebra(..)
      -- * Unital Coassociative Coalgebra
      , CounitalCoalgebra(..)
      -- * Bialgebra
      , Bialgebra
      ) where

    import Numeric.Algebra.Class
    import Numeric.Natural.Internal
    import Data.Sequence (Seq)
    import qualified Data.Sequence as Seq
    import Data.Foldable hiding (product)
    import Data.Int
    import Data.Word
    import Prelude hiding ((*), foldr, product)

    infixr 8 `pow`

    class Multiplicative r => Unital r where
      one :: r
      pow :: Whole n => r -> n -> r
      pow _ 0 = one
      pow x0 y0 = f x0 y0 where
        f x y
          | even y = f (x * x) (y `quot` 2)
          | y == 1 = x
          | otherwise = g (x * x) ((y - 1) `quot` 2) x
        g x y z
          | even y = g (x * x) (y `quot` 2) z
          | y == 1 = x * z
          | otherwise = g (x * x) ((y - 1) `quot` 2) (x * z)
      productWith :: Foldable f => (a -> r) -> f a -> r
      productWith f = foldl' (\b a -> b * f a) one

    product :: (Foldable f, Unital r) => f r -> r
    product = productWith id

    instance Unital Bool where one = True
    instance Unital Integer where one = 1
    instance Unital Int where one = 1
    instance Unital Int8 where one = 1
    instance Unital Int16 where one = 1
    instance Unital Int32 where one = 1
    instance Unital Int64 where one = 1
    instance Unital Natural where one = 1
    instance Unital Word where one = 1
    instance Unital Word8 where one = 1
    instance Unital Word16 where one = 1
    instance Unital Word32 where one = 1
    instance Unital Word64 where one = 1
    instance Unital () where one = ()
    instance (Unital a, Unital b) => Unital (a,b) where
      one = (one,one)

    instance (Unital a, Unital b, Unital c) => Unital (a,b,c) where
      one = (one,one,one)

    instance (Unital a, Unital b, Unital c, Unital d) => Unital (a,b,c,d) where
      one = (one,one,one,one)

    instance (Unital a, Unital b, Unital c, Unital d, Unital e) => Unital (a,b,c,d,e) where
      one = (one,one,one,one,one)

    -- | An associative unital algebra over a semiring, built using a free module
    class Algebra r a => UnitalAlgebra r a where
      unit :: r -> a -> r

    instance (Unital r, UnitalAlgebra r a) => Unital (a -> r) where
      one = unit one

    instance Semiring r => UnitalAlgebra r () where
      unit r () = r

    -- incoherent
    -- instance UnitalAlgebra () a where unit _ _ = ()
    -- instance (UnitalAlgebra r a, UnitalAlgebra r b) => UnitalAlgebra (a -> r) b where unit f b a = unit (f a) b

    instance (UnitalAlgebra r a, UnitalAlgebra r b) => UnitalAlgebra r (a,b) where
      unit r (a,b) = unit r a * unit r b

    instance (UnitalAlgebra r a, UnitalAlgebra r b, UnitalAlgebra r c) => UnitalAlgebra r (a,b,c) where
      unit r (a,b,c) = unit r a * unit r b * unit r c

    instance (UnitalAlgebra r a, UnitalAlgebra r b, UnitalAlgebra r c, UnitalAlgebra r d) => UnitalAlgebra r (a,b,c,d) where
      unit r (a,b,c,d) = unit r a * unit r b * unit r c * unit r d

    instance (UnitalAlgebra r a, UnitalAlgebra r b, UnitalAlgebra r c, UnitalAlgebra r d, UnitalAlgebra r e) => UnitalAlgebra r (a,b,c,d,e) where
      unit r (a,b,c,d,e) = unit r a * unit r b * unit r c * unit r d * unit r e

    instance (Monoidal r, Semiring r) => UnitalAlgebra r [a] where
      unit r [] = r
      unit _ _ = zero

    instance (Monoidal r, Semiring r) => UnitalAlgebra r (Seq a) where
      unit r a | Seq.null a = r
               | otherwise = zero

    -- A coassociative counital coalgebra over a semiring, where the module is free
    class Coalgebra r c => CounitalCoalgebra r c where
      counit :: (c -> r) -> r

    instance (Unital r, UnitalAlgebra r m) => CounitalCoalgebra r (m -> r) where
      counit k = k one

    -- incoherent
    -- instance (UnitalAlgebra r a, CounitalCoalgebra r c) => CounitalCoalgebra (a -> r) c where counit k a = counit (`k` a)
    -- instance CounitalCoalgebra () a where counit _ = ()

    instance Semiring r => CounitalCoalgebra r () where
      counit f = f ()

    instance (CounitalCoalgebra r a, CounitalCoalgebra r b) => CounitalCoalgebra r (a, b) where
      counit k = counit $ \a -> counit $ \b -> k (a,b)

    instance (CounitalCoalgebra r a, CounitalCoalgebra r b, CounitalCoalgebra r c) => CounitalCoalgebra r (a, b, c) where
      counit k = counit $ \a -> counit $ \b -> counit $ \c -> k (a,b,c)

    instance (CounitalCoalgebra r a, CounitalCoalgebra r b, CounitalCoalgebra r c, CounitalCoalgebra r d) => CounitalCoalgebra r (a, b, c, d) where
      counit k = counit $ \a -> counit $ \b -> counit $ \c -> counit $ \d -> k (a,b,c,d)

    instance (CounitalCoalgebra r a, CounitalCoalgebra r b, CounitalCoalgebra r c, CounitalCoalgebra r d, CounitalCoalgebra r e) => CounitalCoalgebra r (a, b, c, d, e) where
      counit k = counit $ \a -> counit $ \b -> counit $ \c -> counit $ \d -> counit $ \e -> k (a,b,c,d,e)

    instance Semiring r => CounitalCoalgebra r [a] where
      counit k = k []

    instance Semiring r => CounitalCoalgebra r (Seq a) where
      counit k = k (Seq.empty)

    -- | A bialgebra is both a unital algebra and counital coalgebra
    -- where the `mult` and `unit` are compatible in some sense with
    -- the `comult` and `counit`. That is to say that
    -- 'mult' and 'unit' are a coalgebra homomorphisms or (equivalently) that
    -- 'comult' and 'counit' are an algebra homomorphisms.

    class (UnitalAlgebra r a, CounitalCoalgebra r a) => Bialgebra r a

    -- TODO
    -- instance (Unital r, Bialgebra r m) => Bialgebra r (m -> r)
    -- instance Bialgebra () c
    -- instance (UnitalAlgebra r b, Bialgebra r c) => Bialgebra (b -> r) c

    instance Semiring r => Bialgebra r ()
    instance (Bialgebra r a, Bialgebra r b) => Bialgebra r (a, b)
    instance (Bialgebra r a, Bialgebra r b, Bialgebra r c) => Bialgebra r (a, b, c)
    instance (Bialgebra r a, Bialgebra r b, Bialgebra r c, Bialgebra r d) => Bialgebra r (a, b, c, d)
    instance (Bialgebra r a, Bialgebra r b, Bialgebra r c, Bialgebra r d, Bialgebra r e) => Bialgebra r (a, b, c, d, e)

    instance (Monoidal r, Semiring r) => Bialgebra r [a]
    instance (Monoidal r, Semiring r) => Bialgebra r (Seq a)