```-- 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)
-}
```