-- Copyright (c) 2010, David Amos. All rights reserved.

{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, NoMonomorphismRestriction #-}


module Math.Algebras.Quaternions where

import Math.Algebra.Field.Base
import Math.Algebras.VectorSpace
import Math.Algebras.TensorProduct
import Math.Algebras.Structures


-- QUATERNIONS

data HBasis = One | I | J | K deriving (Eq,Ord)

type Quaternion k = Vect k HBasis

instance Show HBasis where
    show One = "1"
    show I = "i"
    show J = "j"
    show K = "k"

instance (Num k) => Algebra k HBasis where
    unit x = x *> return One
    mult = linear mult'
         where mult' (One,b) = return b
               mult' (b,One) = return b
               mult' (I,I) = unit (-1)
               mult' (J,J) = unit (-1)
               mult' (K,K) = unit (-1)
               mult' (I,J) = return K
               mult' (J,I) = -1 *> return K
               mult' (J,K) = return I
               mult' (K,J) = -1 *> return I
               mult' (K,I) = return J
               mult' (I,K) = -1 *> return J

i,j,k :: Num k => Quaternion k
i = return I
j = return J
k = return K


one',i',j',k' :: Num k => Vect k (Dual HBasis)
one' = return (Dual One)
i' = return (Dual I)
j' = return (Dual J)
k' = return (Dual K)

-- Coalgebra structure on the dual vector space to the quaternions
-- The comult is the transpose of mult
instance Num k => Coalgebra k (Dual HBasis) where
    counit = unwrap . linear counit'
        where counit' (Dual One) = return ()
              counit' _ = zero
    comult = linear comult'
        where comult' (Dual One) = return (Dual One, Dual One) <+>
                  (-1) *> ( return (Dual I, Dual I) <+> return (Dual J, Dual J) <+> return (Dual K, Dual K) )
              comult' (Dual I) = return (Dual One, Dual I) <+> return (Dual I, Dual One) <+>
                  return (Dual J, Dual K) <+> (-1) *> return (Dual K, Dual J)
              comult' (Dual J) = return (Dual One, Dual J) <+> return (Dual J, Dual One) <+>
                  return (Dual K, Dual I) <+> (-1) *> return (Dual I, Dual K)
              comult' (Dual K) = return (Dual One, Dual K) <+> return (Dual K, Dual One) <+>
                  return (Dual I, Dual J) <+> (-1) *> return (Dual J, Dual I)

{-
-- Of course, we can define this coalgebra structure on the quaternions themselves
-- However, it is not compatible with the algebra structure: we don't get a bialgebra
instance Num k => Coalgebra k HBasis where
    counit = unwrap . linear counit'
        where counit' One = return ()
              counit' _ = zero
    comult = linear comult'
        where comult' One = return (One,One) <+> (-1) *> ( return (I,I) <+> return (J,J) <+> return (K,K) )
              comult' I = return (One,I) <+> return (I,One) <+> return (J,K) <+> (-1) *> return (K,J)
              comult' J = return (One,J) <+> return (J,One) <+> return (K,I) <+> (-1) *> return (I,K)
              comult' K = return (One,K) <+> return (K,One) <+> return (I,J) <+> (-1) *> return (J,I)
-}

{-
-- Set coalgebra instance
instance Num k => Coalgebra k HBasis where
    counit (V ts) = sum [x | (m,x) <- ts] -- trace
    comult = fmap (\m -> T m m)           -- diagonal
-}

{-
instance Num k => Coalgebra k HBasis where
    counit (V ts) = sum [x | (One,x) <- ts]
    comult = linear cm
        where cm m = if m == One then return (m,m) else return (m,One) <+> return (One,m)
-}