    {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, TypeOperators #-}
    module Numeric.Algebra.Involutive
      (
      -- * Involution
        InvolutiveMultiplication(..)
      , InvolutiveSemiring
      -- * Involutive Algebras
      , InvolutiveAlgebra(..)
      , InvolutiveCoalgebra(..)
      , InvolutiveBialgebra
      -- * Trivial Involution
      , TriviallyInvolutive
      , TriviallyInvolutiveAlgebra
      , TriviallyInvolutiveCoalgebra
      , TriviallyInvolutiveBialgebra
      ) where

    import Numeric.Algebra.Class
    import Numeric.Algebra.Commutative
    import Numeric.Algebra.Unital
    import Data.Int
    import Data.Functor.Representable
    import Data.Functor.Representable.Trie
    import Data.Key
    import Data.Word
    import Numeric.Natural.Internal

    -- | An semigroup with involution
    --
    -- > adjoint a * adjoint b = adjoint (b * a)
    class Multiplicative r => InvolutiveMultiplication r where
      adjoint :: r -> r

    instance InvolutiveMultiplication Int where adjoint = id
    instance InvolutiveMultiplication Integer where adjoint = id
    instance InvolutiveMultiplication Int8 where adjoint = id
    instance InvolutiveMultiplication Int16 where adjoint = id
    instance InvolutiveMultiplication Int32 where adjoint = id
    instance InvolutiveMultiplication Int64 where adjoint = id
    instance InvolutiveMultiplication Bool where adjoint = id
    instance InvolutiveMultiplication Word where adjoint = id
    instance InvolutiveMultiplication Natural where adjoint = id
    instance InvolutiveMultiplication Word8 where adjoint = id
    instance InvolutiveMultiplication Word16 where adjoint = id
    instance InvolutiveMultiplication Word32 where adjoint = id
    instance InvolutiveMultiplication Word64 where adjoint = id
    instance InvolutiveMultiplication () where adjoint = id

    instance
      ( InvolutiveMultiplication a
      , InvolutiveMultiplication b
      ) => InvolutiveMultiplication (a,b) where
      adjoint (a,b) = (adjoint a, adjoint b)

    instance
      ( InvolutiveMultiplication a
      , InvolutiveMultiplication b
      , InvolutiveMultiplication c
      ) => InvolutiveMultiplication (a,b,c) where
      adjoint (a,b,c) = (adjoint a, adjoint b, adjoint c)

    instance
      ( InvolutiveMultiplication a
      , InvolutiveMultiplication b
      , InvolutiveMultiplication c
      , InvolutiveMultiplication d
      ) => InvolutiveMultiplication (a,b,c,d) where
      adjoint (a,b,c,d) = (adjoint a, adjoint b, adjoint c, adjoint d)

    instance
      ( InvolutiveMultiplication a
      , InvolutiveMultiplication b
      , InvolutiveMultiplication c
      , InvolutiveMultiplication d
      , InvolutiveMultiplication e
      ) => InvolutiveMultiplication (a,b,c,d,e) where
      adjoint (a,b,c,d,e) = (adjoint a, adjoint b, adjoint c, adjoint d, adjoint e)

    instance InvolutiveAlgebra r h => InvolutiveMultiplication (h -> r) where
      adjoint = inv

    instance (HasTrie h, InvolutiveAlgebra r h) => InvolutiveMultiplication (h :->: r) where
      adjoint = tabulate . inv . index

    -- | adjoint (x + y) = adjoint x + adjoint y
    class (Semiring r, InvolutiveMultiplication r) => InvolutiveSemiring r

    instance InvolutiveSemiring ()
    instance InvolutiveSemiring Bool
    instance InvolutiveSemiring Integer
    instance InvolutiveSemiring Int
    instance InvolutiveSemiring Int8
    instance InvolutiveSemiring Int16
    instance InvolutiveSemiring Int32
    instance InvolutiveSemiring Int64
    instance InvolutiveSemiring Natural
    instance InvolutiveSemiring Word
    instance InvolutiveSemiring Word8
    instance InvolutiveSemiring Word16
    instance InvolutiveSemiring Word32
    instance InvolutiveSemiring Word64

    instance ( InvolutiveSemiring a
             , InvolutiveSemiring b
             ) => InvolutiveSemiring (a, b)

    instance ( InvolutiveSemiring a
             , InvolutiveSemiring b
             , InvolutiveSemiring c
             ) => InvolutiveSemiring (a, b, c)

    instance ( InvolutiveSemiring a
             , InvolutiveSemiring b
             , InvolutiveSemiring c
             , InvolutiveSemiring d
             ) => InvolutiveSemiring (a, b, c, d)

    instance ( InvolutiveSemiring a
             , InvolutiveSemiring b
             , InvolutiveSemiring c
             , InvolutiveSemiring d
             , InvolutiveSemiring e
             ) => InvolutiveSemiring (a, b, c, d, e)

    -- |
    -- > adjoint = id
    class ( Commutative r
          , InvolutiveMultiplication r
          ) => TriviallyInvolutive r

    instance TriviallyInvolutive Bool
    instance TriviallyInvolutive Int
    instance TriviallyInvolutive Integer
    instance TriviallyInvolutive Int8
    instance TriviallyInvolutive Int16
    instance TriviallyInvolutive Int32
    instance TriviallyInvolutive Int64
    instance TriviallyInvolutive Word
    instance TriviallyInvolutive Natural
    instance TriviallyInvolutive Word8
    instance TriviallyInvolutive Word16
    instance TriviallyInvolutive Word32
    instance TriviallyInvolutive Word64
    instance TriviallyInvolutive ()

    instance ( TriviallyInvolutive a
             , TriviallyInvolutive b
             ) => TriviallyInvolutive (a,b)

    instance ( TriviallyInvolutive a
             , TriviallyInvolutive b
             , TriviallyInvolutive c
             ) => TriviallyInvolutive (a,b,c)

    instance ( TriviallyInvolutive a
             , TriviallyInvolutive b
             , TriviallyInvolutive c
             , TriviallyInvolutive d
             ) => TriviallyInvolutive (a,b,c,d)

    instance ( TriviallyInvolutive a
             , TriviallyInvolutive b
             , TriviallyInvolutive c
             , TriviallyInvolutive d
             , TriviallyInvolutive e
             ) => TriviallyInvolutive (a,b,c,d,e)

    instance ( TriviallyInvolutive r
             , TriviallyInvolutiveAlgebra r a
             ) => TriviallyInvolutive (a -> r)

    instance ( HasTrie a
             , TriviallyInvolutive r
             , TriviallyInvolutiveAlgebra r a
             ) => TriviallyInvolutive (a :->: r)

    -- inv is an associative algebra homomorphism
    class (InvolutiveSemiring r, Algebra r a) => InvolutiveAlgebra r a where
      inv :: (a -> r) -> a -> r

    instance InvolutiveSemiring r => InvolutiveAlgebra r () where
      inv = (adjoint .)

    instance
      ( InvolutiveAlgebra r a
      , InvolutiveAlgebra r b
      ) => InvolutiveAlgebra r (a, b) where
      inv f (a,b) =
        inv (\a' ->
        inv (\b' -> f (a',b')) b) a

    instance
      ( InvolutiveAlgebra r a
      , InvolutiveAlgebra r b
      , InvolutiveAlgebra r c
      ) => InvolutiveAlgebra r (a, b, c) where
      inv f (a,b,c) =
        inv (\a' ->
        inv (\b' ->
        inv (\c' -> f (a',b',c')) c) b) a

    instance
      ( InvolutiveAlgebra r a
      , InvolutiveAlgebra r b
      , InvolutiveAlgebra r c
      , InvolutiveAlgebra r d
      ) => InvolutiveAlgebra r (a, b, c, d) where
      inv f (a,b,c,d) =
        inv (\a' ->
        inv (\b' ->
        inv (\c' ->
        inv (\d' -> f (a',b',c',d')) d) c) b) a

    instance
      ( InvolutiveAlgebra r a
      , InvolutiveAlgebra r b
      , InvolutiveAlgebra r c
      , InvolutiveAlgebra r d
      , InvolutiveAlgebra r e
      ) => InvolutiveAlgebra r (a, b, c, d, e) where
      inv f (a,b,c,d,e) =
        inv (\a' ->
        inv (\b' ->
        inv (\c' ->
        inv (\d' ->
        inv (\e' -> f (a',b',c',d',e')) e) d) c) b) a

    class ( CommutativeAlgebra r a
          , TriviallyInvolutive r
          , InvolutiveAlgebra r a
          ) => TriviallyInvolutiveAlgebra r a

    instance ( TriviallyInvolutive r
             , InvolutiveSemiring r
             ) => TriviallyInvolutiveAlgebra r ()

    instance ( TriviallyInvolutiveAlgebra r a
             , TriviallyInvolutiveAlgebra r b
             ) => TriviallyInvolutiveAlgebra r (a, b) where

    instance (TriviallyInvolutiveAlgebra r a
             , TriviallyInvolutiveAlgebra r b
             , TriviallyInvolutiveAlgebra r c
             ) => TriviallyInvolutiveAlgebra r (a, b, c) where

    instance ( TriviallyInvolutiveAlgebra r a
             , TriviallyInvolutiveAlgebra r b
             , TriviallyInvolutiveAlgebra r c
             , TriviallyInvolutiveAlgebra r d
             ) => TriviallyInvolutiveAlgebra r (a, b, c, d)

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

    class ( InvolutiveSemiring r
          , Coalgebra r c
          ) => InvolutiveCoalgebra r c where
      coinv :: (c -> r) -> c -> r

    instance InvolutiveSemiring r => InvolutiveCoalgebra r () where
      coinv f c = adjoint (f c)

    instance
      ( InvolutiveCoalgebra r a
      , InvolutiveCoalgebra r b
      ) => InvolutiveCoalgebra r (a, b) where
      coinv f (a,b) =
        coinv (\a' ->
        coinv (\b' -> f (a',b')) b) a

    instance
      ( InvolutiveCoalgebra r a
      , InvolutiveCoalgebra r b
      , InvolutiveCoalgebra r c
      ) => InvolutiveCoalgebra r (a, b, c) where
      coinv f (a,b,c) =
        coinv (\a' ->
        coinv (\b' ->
        coinv (\c' -> f (a',b',c')) c) b) a

    instance
      ( InvolutiveCoalgebra r a
      , InvolutiveCoalgebra r b
      , InvolutiveCoalgebra r c
      , InvolutiveCoalgebra r d
      ) => InvolutiveCoalgebra r (a, b, c, d) where
      coinv f (a,b,c,d) =
        coinv (\a' ->
        coinv (\b' ->
        coinv (\c' ->
        coinv (\d' -> f (a',b',c',d')) d) c) b) a

    instance
      ( InvolutiveCoalgebra r a
      , InvolutiveCoalgebra r b
      , InvolutiveCoalgebra r c
      , InvolutiveCoalgebra r d
      , InvolutiveCoalgebra r e
      ) => InvolutiveCoalgebra r (a, b, c, d, e) where
      coinv f (a,b,c,d,e) =
        coinv (\a' ->
        coinv (\b' ->
        coinv (\c' ->
        coinv (\d' ->
        coinv (\e' -> f (a',b',c',d',e')) e) d) c) b) a

    class ( CocommutativeCoalgebra r a
          , TriviallyInvolutive r
          , InvolutiveCoalgebra r a
          ) => TriviallyInvolutiveCoalgebra r a

    instance ( TriviallyInvolutive r
             , InvolutiveSemiring r
             ) => TriviallyInvolutiveCoalgebra r ()

    instance ( TriviallyInvolutiveCoalgebra r a
             , TriviallyInvolutiveCoalgebra r b
             ) => TriviallyInvolutiveCoalgebra r (a, b)

    instance ( TriviallyInvolutiveCoalgebra r a
             , TriviallyInvolutiveCoalgebra r b
             , TriviallyInvolutiveCoalgebra r c
             ) => TriviallyInvolutiveCoalgebra r (a, b, c)

    instance ( TriviallyInvolutiveCoalgebra r a
             , TriviallyInvolutiveCoalgebra r b
             , TriviallyInvolutiveCoalgebra r c
             , TriviallyInvolutiveCoalgebra r d
             ) => TriviallyInvolutiveCoalgebra r (a, b, c, d)

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

    class ( Bialgebra r h
          , InvolutiveAlgebra r h
          , InvolutiveCoalgebra r h
          ) => InvolutiveBialgebra r h

    instance ( Bialgebra r h
             , InvolutiveAlgebra r h
             , InvolutiveCoalgebra r h
             ) => InvolutiveBialgebra r h

    class ( InvolutiveBialgebra r h
          , TriviallyInvolutiveAlgebra r h
          , TriviallyInvolutiveCoalgebra r h
          ) => TriviallyInvolutiveBialgebra r h

    instance ( InvolutiveBialgebra r h
             , TriviallyInvolutiveAlgebra r h
             , TriviallyInvolutiveCoalgebra r h
             ) => TriviallyInvolutiveBialgebra r h