{-# 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