{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-}
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.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)


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

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 ()
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 Int
instance TriviallyInvolutive Integer
instance TriviallyInvolutive Int8
instance TriviallyInvolutive Int16
instance TriviallyInvolutive Int32
instance TriviallyInvolutive Int64
instance TriviallyInvolutive Bool
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)

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

-- instance InvolutiveAlgebra () a where inv _ _ = ()
-- instance (Algebra r b, InvolutiveAlgebra r a) => InvolutiveAlgebra (b -> r) a where inv f c a = inv (`f` a) c

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

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

class (CommutativeAlgebra r a, 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)
instance TriviallyInvolutiveAlgebra r h => TriviallyInvolutive (h -> r)
-- instance TriviallyInvolutiveAlgebra () a 
-- instance (Algebra r b, TriviallyInvolutiveAlgebra r a) => TriviallyInvolutiveAlgebra (b -> r) a

class Coalgebra r c => InvolutiveCoalgebra r c where
  coinv :: (c -> r) -> c -> r
-- instance InvolutiveCoalgebra () c where coinv _ _ = ()
-- instance (Algebra r b, InvolutiveCoalgebra r c) => InvolutiveCoalgebra (b -> r) c where coinv f c a = coinv (`f` a) c
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
-- instance InvolutiveCoalgebra r h => Involutive (Covector r h)

class (CommutativeCoalgebra r a, InvolutiveCoalgebra r a) => TriviallyInvolutiveCoalgebra r a

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

instance (TriviallyInvolutiveCoalgebra r a, TriviallyInvolutiveCoalgebra r b) => TriviallyInvolutiveCoalgebra r (a, b) where
instance (TriviallyInvolutiveCoalgebra r a, TriviallyInvolutiveCoalgebra r b, TriviallyInvolutiveCoalgebra r c) => TriviallyInvolutiveCoalgebra r (a, b, c) where
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)

-- inv = coinv
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