content: {-# LANGUAGE FlexibleInstances
             , MultiParamTypeClasses
             , TypeFamilies
             , UndecidableInstances
             , DeriveDataTypeable
             , TypeOperators #-}
  module Numeric.Coalgebra.Quaternion
    ( Distinguished(..)
    , Complicated(..)
    , Hamiltonian(..)
    , QuaternionBasis'(..)
    , Quaternion'(..)
    , complicate'
    , vectorPart'
    , scalarPart'
    ) where
  
  import Control.Applicative
  import Control.Monad.Reader.Class
  import Data.Ix hiding (index)
  import Data.Data
  import Data.Distributive
  import Data.Functor.Bind
  import Data.Functor.Rep
  import Data.Foldable
  import Data.Traversable
  import Data.Semigroup.Traversable
  import Data.Semigroup.Foldable
  import Data.Semigroup
  import Numeric.Algebra
  import Numeric.Algebra.Distinguished.Class
  import Numeric.Algebra.Complex.Class
  import Numeric.Algebra.Quaternion.Class
  import Prelude hiding ((-),(+),(*),negate,subtract, fromInteger)
  
  instance Distinguished QuaternionBasis' where
    e = E'
  
  instance Complicated QuaternionBasis' where
    i = I'
  
  instance Hamiltonian QuaternionBasis' where
    j = J'
    k = K'
  
  instance Rig r => Distinguished (Quaternion' r) where
    e = Quaternion' one zero zero zero
  
  instance Rig r => Complicated (Quaternion' r) where
    i = Quaternion' zero one zero zero
  
  instance Rig r => Hamiltonian (Quaternion' r) where
    j = Quaternion' zero zero one zero
    k = Quaternion' one zero zero one
  
  instance Rig r => Distinguished (QuaternionBasis' -> r) where
    e E' = one
    e _ = zero
  
  instance Rig r => Complicated (QuaternionBasis' -> r) where
    i I' = one
    i _ = zero
  
  instance Rig r => Hamiltonian (QuaternionBasis' -> r) where
    j J' = one
    j _ = zero
  
    k K' = one
    k _ = zero
  
  -- quaternion basis
  data QuaternionBasis' = E' | I' | J' | K' deriving (Eq,Ord,Enum,Read,Show,Bounded,Ix,Data,Typeable)
  
  data Quaternion' a = Quaternion' a a a a deriving (Eq,Show,Read,Data,Typeable)
  
  instance Representable Quaternion' where
    type Rep Quaternion' = QuaternionBasis'
    tabulate f = Quaternion' (f E') (f I') (f J') (f K')
    index (Quaternion' a _ _ _) E' = a
    index (Quaternion' _ b _ _) I' = b
    index (Quaternion' _ _ c _) J' = c
    index (Quaternion' _ _ _ d) K' = d
  
  instance Distributive Quaternion' where
    distribute = distributeRep
  
  instance Functor Quaternion' where
    fmap = fmapRep
  
  instance Apply Quaternion' where
    (<.>) = apRep
  
  instance Applicative Quaternion' where
    pure = pureRep
    (<*>) = apRep
  
  instance Bind Quaternion' where
    (>>-) = bindRep
  
  instance Monad Quaternion' where
    return = pureRep
    (>>=) = bindRep
  
  instance MonadReader QuaternionBasis' Quaternion' where
    ask = askRep
    local = localRep
  
  instance Foldable Quaternion' where
    foldMap f (Quaternion' a b c d) =
      f a `mappend` f b `mappend` f c `mappend` f d
  
  instance Traversable Quaternion' where
    traverse f (Quaternion' a b c d) =
      Quaternion' <$> f a <*> f b <*> f c <*> f d
  
  instance Foldable1 Quaternion' where
    foldMap1 f (Quaternion' a b c d) =
      f a <> f b <> f c <> f d
  
  instance Traversable1 Quaternion' where
    traverse1 f (Quaternion' a b c d) =
      Quaternion' <$> f a <.> f b <.> f c <.> f d
  
  instance Additive r => Additive (Quaternion' r) where
    (+) = addRep
    sinnum1p = sinnum1pRep
  
  instance LeftModule r s => LeftModule r (Quaternion' s) where
    r .* Quaternion' a b c d =
      Quaternion' (r .* a) (r .* b) (r .* c) (r .* d)
  
  instance RightModule r s => RightModule r (Quaternion' s) where
    Quaternion' a b c d *. r =
      Quaternion' (a *. r) (b *. r) (c *. r) (d *. r)
  
  instance Monoidal r => Monoidal (Quaternion' r) where
    zero = zeroRep
    sinnum = sinnumRep
  
  instance Group r => Group (Quaternion' r) where
    (-) = minusRep
    negate = negateRep
    subtract = subtractRep
    times = timesRep
  
  instance Abelian r => Abelian (Quaternion' r)
  
  instance Idempotent r => Idempotent (Quaternion' r)
  
  instance Partitionable r => Partitionable (Quaternion' r) where
    partitionWith f (Quaternion' a b c d) = id =<<
      partitionWith (\a1 a2 -> id =<<
      partitionWith (\b1 b2 -> id =<<
      partitionWith (\c1 c2 ->
      partitionWith (\d1 d2 -> f (Quaternion' a1 b1 c1 d1)
                                 (Quaternion' a2 b2 c2 d2)
                    ) d) c) b) a
  
  -- | the trivial diagonal algebra
  instance (TriviallyInvolutive r, Semiring r) => Algebra r QuaternionBasis' where
    mult f = f' where
      fe = f E' E'
      fi = f I' I'
      fj = f J' J'
      fk = f K' K'
      f' E' = fe
      f' I' = fi
      f' J' = fj
      f' K' = fk
  
  instance (TriviallyInvolutive r, Semiring r) => UnitalAlgebra r QuaternionBasis' where
    unit = const
  
  
  -- | dual quaternion comultiplication
  instance (TriviallyInvolutive r, Rng r) => Coalgebra r QuaternionBasis' where
    comult f = f' where
      fe = f E'
      fi = f I'
      fj = f J'
      fk = f K'
      fe' = negate fe
      fi' = negate fi
      fj' = negate fj
      fk' = negate fk
      f' E' E' = fe
      f' E' I' = fi
      f' E' J' = fj
      f' E' K' = fk
      f' I' E' = fi
      f' I' I' = fe'
      f' I' J' = fk
      f' I' K' = fj'
      f' J' E' = fj
      f' J' I' = fk'
      f' J' J' = fe'
      f' J' K' = fi
      f' K' E' = fk
      f' K' I' = fj
      f' K' J' = fi'
      f' K' K' = fe'
  
  instance (TriviallyInvolutive r, Rng r) => CounitalCoalgebra r QuaternionBasis' where
    counit f = f E'
  
  instance (TriviallyInvolutive r, Rng r)  => Bialgebra r QuaternionBasis'
  
  instance (TriviallyInvolutive r, InvolutiveSemiring r, Rng r)  => InvolutiveAlgebra r QuaternionBasis' where
    inv f E' = f E'
    inv f b = negate (f b)
  
  instance (TriviallyInvolutive r, InvolutiveSemiring r, Rng r) => InvolutiveCoalgebra r QuaternionBasis' where
    coinv = inv
  
  instance (TriviallyInvolutive r, InvolutiveSemiring r, Rng r) => HopfAlgebra r QuaternionBasis' where
    antipode = inv
  
  instance (TriviallyInvolutive r, Semiring r) => Multiplicative (Quaternion' r) where
    (*) = mulRep
  
  instance (TriviallyInvolutive r, Semiring r) => Semiring (Quaternion' r)
  
  instance (TriviallyInvolutive r, Ring r) => Unital (Quaternion' r) where
    one = oneRep
  
  instance (TriviallyInvolutive r, Ring r) => Rig (Quaternion' r) where
    fromNatural n = Quaternion' (fromNatural n) zero zero zero
  
  instance (TriviallyInvolutive r, Ring r) => Ring (Quaternion' r) where
    fromInteger n = Quaternion' (fromInteger n) zero zero zero
  
  instance ( TriviallyInvolutive r, Rng r) => LeftModule (Quaternion' r) (Quaternion' r) where
    (.*) = (*)
  instance (TriviallyInvolutive r, Rng r) => RightModule (Quaternion' r) (Quaternion' r) where
    (*.) = (*)
  
  instance (TriviallyInvolutive r, Rng r) => InvolutiveMultiplication (Quaternion' r) where
    -- without trivial involution, multiplication fails associativity, and we'd need to
    -- support weaker multiplicative properties like Alternative and PowerAssociative
    adjoint (Quaternion' a b c d) = Quaternion' a (negate b) (negate c) (negate d)
  
  -- | Cayley-Dickson quaternion isomorphism (one way)
  complicate' :: Complicated c => QuaternionBasis' -> (c , c)
  complicate' E' = (e, e)
  complicate' I' = (i, e)
  complicate' J' = (e, i)
  complicate' K' = (i, i)
  
  scalarPart' :: (Representable f, Rep f ~ QuaternionBasis') => f r -> r
  scalarPart' f = index f E'
  
  vectorPart' :: (Representable f, Rep f ~ QuaternionBasis') => f r -> (r,r,r)
  vectorPart' f = (index f I', index f J', index f K')
  
  instance (TriviallyInvolutive r, Rng r) => Quadrance r (Quaternion' r) where
    quadrance n = scalarPart' (adjoint n * n)
  
  instance (TriviallyInvolutive r, Ring r, Division r) => Division (Quaternion' r) where
    recip q@(Quaternion' a b c d) = Quaternion' (qq \\ a) (qq \\ b) (qq \\ c) (qq \\ d)
      where qq = quadrance q
  