content: {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeFamilies, UndecidableInstances, DeriveDataTypeable #-}
  module Numeric.Coalgebra.Hyperbolic 
    ( Hyperbolic(..)
    , HyperBasis(..)
    , Hyper(..)
    ) where
  
  import Control.Applicative
  import Control.Monad.Reader.Class
  import Data.Data
  import Data.Distributive
  import Data.Functor.Bind
  import Data.Functor.Rep
  import Data.Foldable
  import Data.Ix
  import Data.Semigroup.Traversable
  import Data.Semigroup.Foldable
  import Data.Semigroup
  import Data.Traversable
  import Numeric.Algebra
  import Numeric.Coalgebra.Hyperbolic.Class
  import Prelude hiding ((-),(+),(*),negate,subtract, fromInteger, cosh, sinh)
  
  -- complex basis
  data HyperBasis = Cosh | Sinh deriving (Eq,Ord,Show,Read,Enum,Ix,Bounded,Data,Typeable)
  data Hyper a = Hyper a a deriving (Eq,Show,Read,Data,Typeable)
  
  instance Hyperbolic HyperBasis where
    cosh = Cosh
    sinh = Sinh
  
  instance Rig r => Hyperbolic (Hyper r) where
    cosh = Hyper one zero
    sinh = Hyper zero one
    
  instance Rig r => Hyperbolic (HyperBasis -> r) where
    cosh Sinh = zero
    cosh Cosh = one
    sinh Sinh = one
    sinh Cosh = zero
  
  
  instance Representable Hyper where
    type Rep Hyper = HyperBasis
    tabulate f = Hyper (f Cosh) (f Sinh)
    index (Hyper a _ ) Cosh = a
    index (Hyper _ b ) Sinh = b
  
  instance Distributive Hyper where
    distribute = distributeRep 
  
  instance Functor Hyper where
    fmap f (Hyper a b) = Hyper (f a) (f b)
  
  instance Apply Hyper where
    (<.>) = apRep
  
  instance Applicative Hyper where
    pure = pureRep
    (<*>) = apRep 
  
  instance Bind Hyper where
    (>>-) = bindRep
  
  instance Monad Hyper where
    return = pureRep
    (>>=) = bindRep
  
  instance MonadReader HyperBasis Hyper where
    ask = askRep
    local = localRep
  
  instance Foldable Hyper where
    foldMap f (Hyper a b) = f a `mappend` f b
  
  instance Traversable Hyper where
    traverse f (Hyper a b) = Hyper <$> f a <*> f b
  
  instance Foldable1 Hyper where
    foldMap1 f (Hyper a b) = f a <> f b
  
  instance Traversable1 Hyper where
    traverse1 f (Hyper a b) = Hyper <$> f a <.> f b
  
  instance Additive r => Additive (Hyper r) where
    (+) = addRep 
    sinnum1p = sinnum1pRep
  
  instance LeftModule r s => LeftModule r (Hyper s) where
    r .* Hyper a b = Hyper (r .* a) (r .* b)
  
  instance RightModule r s => RightModule r (Hyper s) where
    Hyper a b *. r = Hyper (a *. r) (b *. r)
  
  instance Monoidal r => Monoidal (Hyper r) where
    zero = zeroRep
    sinnum = sinnumRep
  
  instance Group r => Group (Hyper r) where
    (-) = minusRep
    negate = negateRep
    subtract = subtractRep
    times = timesRep
  
  instance Abelian r => Abelian (Hyper r)
  
  instance Idempotent r => Idempotent (Hyper r)
  
  instance Partitionable r => Partitionable (Hyper r) where
    partitionWith f (Hyper a b) = id =<<
      partitionWith (\a1 a2 -> 
      partitionWith (\b1 b2 -> f (Hyper a1 b1) (Hyper a2 b2)) b) a
  
  -- | the trivial diagonal algebra
  instance Semiring k => Algebra k HyperBasis where
    mult f = f' where
      fs = f Sinh Sinh
      fc = f Cosh Cosh
      f' Sinh = fs
      f' Cosh = fc
  
  instance Semiring k => UnitalAlgebra k HyperBasis where
    unit = const
  
  -- | the hyperbolic trigonometric coalgebra
  instance (Commutative k, Semiring k) => Coalgebra k HyperBasis where
    comult f = f' where
       fs = f Sinh
       fc = f Cosh
       f' Sinh Sinh = fc
       f' Sinh Cosh = fs 
       f' Cosh Sinh = fs
       f' Cosh Cosh = fc
  
  instance (Commutative k, Semiring k) => CounitalCoalgebra k HyperBasis where
    counit f = f Cosh
  
  instance (Commutative k, Semiring k) => Bialgebra k HyperBasis
  
  instance (Commutative k, Group k, InvolutiveSemiring k) => InvolutiveAlgebra k HyperBasis where
    inv f = f' where
      afc = adjoint (f Cosh)
      nfs = negate (f Sinh)
      f' Cosh = afc
      f' Sinh = nfs
  
  instance (Commutative k, Group k, InvolutiveSemiring k) => InvolutiveCoalgebra k HyperBasis where
    coinv = inv
  
  instance (Commutative k, Group k, InvolutiveSemiring k) => HopfAlgebra k HyperBasis where
    antipode = inv
  
  instance (Commutative k, Semiring k) => Multiplicative (Hyper k) where
    (*) = mulRep
  
  instance (Commutative k, Semiring k) => Commutative (Hyper k)
  
  instance (Commutative k, Semiring k) => Semiring (Hyper k)
  
  instance (Commutative k, Rig k) => Unital (Hyper k) where
    one = Hyper one zero
  
  instance (Commutative r, Rig r) => Rig (Hyper r) where
    fromNatural n = Hyper (fromNatural n) zero
  
  instance (Commutative r, Ring r) => Ring (Hyper r) where
    fromInteger n = Hyper (fromInteger n) zero
  
  instance (Commutative r, Semiring r) => LeftModule (Hyper r) (Hyper r) where (.*) = (*)
  instance (Commutative r, Semiring r) => RightModule (Hyper r) (Hyper r) where (*.) = (*)
  
  instance (Commutative r, Group r, InvolutiveSemiring r) => InvolutiveMultiplication (Hyper r) where
    adjoint (Hyper a b) = Hyper (adjoint a) (negate b)
  
  instance (Commutative r, Group r, InvolutiveSemiring r) => InvolutiveSemiring (Hyper r)
  