algebra 0.6.0 → 0.7.0

raw patch · 22 files changed

+1831/−590 lines, 22 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Numeric/Additive/Group.hs +10/−2
• Numeric/Algebra.hs +5/−0
• Numeric/Algebra/Complex.hs +61/−24
• Numeric/Algebra/Complex/Class.hs +13/−0
• Numeric/Algebra/Distinguished/Class.hs +12/−0
• Numeric/Algebra/Dual.hs +224/−0
• Numeric/Algebra/Dual/Class.hs +12/−0
• Numeric/Algebra/Geometric.hs +0/−215
• Numeric/Algebra/Hyperbolic.hs +128/−111
• Numeric/Algebra/Quaternion.hs +68/−26
• Numeric/Algebra/Quaternion/Class.hs +14/−0
• Numeric/Algebra/Trigonometric.hs +0/−206
• Numeric/Coalgebra/Dual.hs +227/−0
• Numeric/Coalgebra/Geometric.hs +212/−0
• Numeric/Coalgebra/Hyperbolic.hs +212/−0
• Numeric/Coalgebra/Hyperbolic/Class.hs +14/−0
• Numeric/Coalgebra/Quaternion.hs +317/−0
• Numeric/Coalgebra/Trigonometric.hs +250/−0
• Numeric/Coalgebra/Trigonometric/Class.hs +14/−0
• Numeric/Field/Class.hs +10/−0
• Numeric/Ring/Division.hs +10/−0
• algebra.cabal +18/−6

@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeOperators #-} module Numeric.Additive.Group   ( -- * Additive Groups     Group(..)@@ -6,7 +6,9 @@  import Data.Int import Data.Word-import Prelude hiding ((*), (+), (-), negate, subtract)+import Data.Key+import Data.Functor.Representable.Trie+import Prelude hiding ((*), (+), (-), negate, subtract,zipWith) import qualified Prelude import Numeric.Additive.Class import Numeric.Algebra.Class@@ -42,6 +44,12 @@   negate f x = negate (f x)   subtract f g x = subtract (f x) (g x)   times n f e = times n (f e)++instance (HasTrie e, Group r) => Group (e :->: r) where+  (-) = zipWith (-)+  negate = fmap negate+  subtract = zipWith subtract+  times = fmap . times  instance Group Integer where   (-) = (Prelude.-)

@@ -52,6 +52,9 @@   , Rig(..)   -- * Rings   , Ring(..)+  -- ** Division Rings+  , DivisionRing+  , Field    -- * Modules   , LeftModule(..)@@ -160,3 +163,5 @@ import Numeric.Rig.Ordered import Numeric.Rng.Class import Numeric.Ring.Class+import Numeric.Ring.Division+import Numeric.Field.Class

@@ -1,8 +1,17 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeFamilies, UndecidableInstances, DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses+           , FlexibleInstances+           , TypeFamilies+           , UndecidableInstances+           , DeriveDataTypeable+           , TypeOperators #-} module Numeric.Algebra.Complex-  ( Complicated(..)+  ( Distinguished(..)+  , Complicated(..)   , ComplexBasis(..)   , Complex(..)+  , realPart+  , imagPart+  , uncomplicate   ) where  import Control.Applicative@@ -13,40 +22,53 @@ import Data.Functor.Representable import Data.Functor.Representable.Trie import Data.Foldable-import Data.Ix+import Data.Ix hiding (index) import Data.Key import Data.Monoid import Data.Semigroup.Traversable import Data.Semigroup.Foldable import Data.Traversable import Numeric.Algebra-import Prelude hiding ((-),(+),(*),negate,subtract, fromInteger)+import Numeric.Algebra.Distinguished.Class+import Numeric.Algebra.Complex.Class+import Numeric.Algebra.Quaternion.Class+import Prelude hiding ((-),(+),(*),negate,subtract, fromInteger,recip)  -- complex basis data ComplexBasis = E | I deriving (Eq,Ord,Show,Read,Enum,Ix,Bounded,Data,Typeable) data Complex a = Complex a a deriving (Eq,Show,Read,Data,Typeable) -class Complicated r where-  e :: r-  i :: r+realPart :: (Representable f, Key f ~ ComplexBasis) => f a -> a+realPart f = index f E  -instance Complicated ComplexBasis where+imagPart :: (Representable f, Key f ~ ComplexBasis) => f a -> a+imagPart f = index f I++instance Distinguished ComplexBasis where   e = E+  +instance Complicated ComplexBasis where   i = I -instance Rig r => Complicated (Complex r) where+instance Rig r => Distinguished (Complex r) where   e = Complex one zero++instance Rig r => Complicated (Complex r) where   i = Complex zero one-  -instance Rig r => Complicated (ComplexBasis -> r) where++instance Rig r => Distinguished (ComplexBasis -> r) where   e E = one   e _ = zero+  +instance Rig r => Complicated (ComplexBasis -> r) where   i I = one   i _ = zero  -instance Complicated a => Complicated (Covector r a) where-  e = return e-  i = return i+instance Rig r => Distinguished (ComplexBasis :->: r) where+  e = Trie e+  +instance Rig r => Complicated (ComplexBasis :->: r) where+  i = Trie i  type instance Key Complex = ComplexBasis @@ -166,23 +188,23 @@   unit x E = x   unit _ _ = zero +-- the trivial coalgebra instance Rng k => Coalgebra k ComplexBasis where-  comult f = f' where -    fe = f E-    fi = f I-    f' E E = fe-    f' E I = fi-    f' I E = fi-    f' I I = negate fe+  comult f E E = f E+  comult f I I = f I+  comult _ _ _ = zero  instance Rng k => CounitalCoalgebra k ComplexBasis where-  counit f = f E+  counit f = f E + f I  instance Rng k => Bialgebra k ComplexBasis   instance (InvolutiveSemiring k, Rng k) => InvolutiveAlgebra k ComplexBasis where-  inv f E = f E-  inv f b = negate (f b)+  inv f = f' where+    afe = adjoint (f E)+    nfi = negate (f I)+    f' E = afe+    f' I = nfi  instance (InvolutiveSemiring k, Rng k) => InvolutiveCoalgebra k ComplexBasis where   coinv = inv@@ -213,3 +235,18 @@   adjoint (Complex a b) = Complex (adjoint a) (negate b)  instance (Commutative r, Rng r, InvolutiveSemiring r) => InvolutiveSemiring (Complex r)++instance (Commutative r, Rng r, InvolutiveSemiring r) => Quadrance r (Complex r) where+  quadrance n = realPart $ adjoint n * n++instance (Commutative r, InvolutiveSemiring r, DivisionRing r) => Division (Complex r) where+  recip q@(Complex a b) = Complex (qq \\ a) (qq \\ b)+    where qq = quadrance q++-- | half of the Cayley-Dickson quaternion isomorphism +uncomplicate :: Hamiltonian q => ComplexBasis -> ComplexBasis -> q+uncomplicate E E = e+uncomplicate I E = i+uncomplicate E I = j+uncomplicate I I = k+

@@ -0,0 +1,13 @@+module Numeric.Algebra.Complex.Class+  ( Complicated(..)+  ) where++import Numeric.Algebra.Distinguished.Class+import Numeric.Covector+import Prelude (return)++class Distinguished r => Complicated r where+  i :: r++instance Complicated a => Complicated (Covector r a) where+  i = return i

@@ -0,0 +1,12 @@+module Numeric.Algebra.Distinguished.Class+  ( Distinguished(..)+  ) where++import Numeric.Covector++-- a basis with a distinguished point+class Distinguished t where+  e :: t++instance Distinguished a => Distinguished (Covector r a) where+  e = return e

@@ -0,0 +1,224 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeFamilies, UndecidableInstances, DeriveDataTypeable #-}+module Numeric.Algebra.Dual+  ( Distinguished(..)+  , Infinitesimal(..)+  , DualBasis(..)+  , Dual(..)+  ) where++import Control.Applicative+import Control.Monad.Reader.Class+import Data.Data+import Data.Distributive+import Data.Functor.Bind+import Data.Functor.Representable+import Data.Functor.Representable.Trie+import Data.Foldable+import Data.Ix+import Data.Key hiding (Dual)+import Data.Monoid hiding (Dual)+import Data.Semigroup.Traversable+import Data.Semigroup.Foldable+import Data.Traversable+import Numeric.Algebra+import Numeric.Algebra.Distinguished.Class+import Numeric.Algebra.Dual.Class+import Prelude hiding ((-),(+),(*),negate,subtract, fromInteger,recip)++-- | dual number basis, D^2 = 0. D /= 0.+data DualBasis = E | D deriving (Eq,Ord,Show,Read,Enum,Ix,Bounded,Data,Typeable)+data Dual a = Dual a a deriving (Eq,Show,Read,Data,Typeable)++instance Distinguished DualBasis where+  e = E++instance Infinitesimal DualBasis where+  d = D++instance Rig r => Distinguished (Dual r) where+  e = Dual one zero++instance Rig r => Infinitesimal (Dual r) where+  d = Dual zero one+  +instance Rig r => Distinguished (DualBasis -> r) where+  e E = one+  e _ = zero++instance Rig r => Infinitesimal (DualBasis -> r) where+  d D = one+  d _       = zero ++type instance Key Dual = DualBasis++instance Representable Dual where+  tabulate f = Dual (f E) (f D)++instance Indexable Dual where+  index (Dual a _ ) E = a+  index (Dual _ b ) D = b++instance Lookup Dual where+  lookup = lookupDefault++instance Adjustable Dual where+  adjust f E (Dual a b) = Dual (f a) b+  adjust f D (Dual a b) = Dual a (f b)++instance Distributive Dual where+  distribute = distributeRep ++instance Functor Dual where+  fmap f (Dual a b) = Dual (f a) (f b)++instance Zip Dual where+  zipWith f (Dual a1 b1) (Dual a2 b2) = Dual (f a1 a2) (f b1 b2)++instance ZipWithKey Dual where+  zipWithKey f (Dual a1 b1) (Dual a2 b2) = Dual (f E a1 a2) (f D b1 b2)++instance Keyed Dual where+  mapWithKey = mapWithKeyRep++instance Apply Dual where+  (<.>) = apRep++instance Applicative Dual where+  pure = pureRep+  (<*>) = apRep ++instance Bind Dual where+  (>>-) = bindRep++instance Monad Dual where+  return = pureRep+  (>>=) = bindRep++instance MonadReader DualBasis Dual where+  ask = askRep+  local = localRep++instance Foldable Dual where+  foldMap f (Dual a b) = f a `mappend` f b++instance FoldableWithKey Dual where+  foldMapWithKey f (Dual a b) = f E a `mappend` f D b++instance Traversable Dual where+  traverse f (Dual a b) = Dual <$> f a <*> f b++instance TraversableWithKey Dual where+  traverseWithKey f (Dual a b) = Dual <$> f E a <*> f D b++instance Foldable1 Dual where+  foldMap1 f (Dual a b) = f a <> f b++instance FoldableWithKey1 Dual where+  foldMapWithKey1 f (Dual a b) = f E a <> f D b++instance Traversable1 Dual where+  traverse1 f (Dual a b) = Dual <$> f a <.> f b++instance TraversableWithKey1 Dual where+  traverseWithKey1 f (Dual a b) = Dual <$> f E a <.> f D b++instance HasTrie DualBasis where+  type BaseTrie DualBasis = Dual+  embedKey = id+  projectKey = id++instance Additive r => Additive (Dual r) where+  (+) = addRep +  replicate1p = replicate1pRep++instance LeftModule r s => LeftModule r (Dual s) where+  r .* Dual a b = Dual (r .* a) (r .* b)++instance RightModule r s => RightModule r (Dual s) where+  Dual a b *. r = Dual (a *. r) (b *. r)++instance Monoidal r => Monoidal (Dual r) where+  zero = zeroRep+  replicate = replicateRep++instance Group r => Group (Dual r) where+  (-) = minusRep+  negate = negateRep+  subtract = subtractRep+  times = timesRep++instance Abelian r => Abelian (Dual r)++instance Idempotent r => Idempotent (Dual r)++instance Partitionable r => Partitionable (Dual r) where+  partitionWith f (Dual a b) = id =<<+    partitionWith (\a1 a2 -> +    partitionWith (\b1 b2 -> f (Dual a1 b1) (Dual a2 b2)) b) a++instance Rng k => Algebra k DualBasis where+  mult f = f' where+    fe = f E E+    fd = f E D + f D E+    f' E = fe+    f' D = fd++instance Rng k => UnitalAlgebra k DualBasis where+  unit x E = x+  unit _ _ = zero++-- the trivial coalgebra+instance Rng k => Coalgebra k DualBasis where+  comult f E E = f E+  comult f D D = f D+  comult _ _ _ = zero++instance Rng k => CounitalCoalgebra k DualBasis where+  counit f = f E + f D++instance Rng k => Bialgebra k DualBasis ++instance (InvolutiveSemiring k, Rng k) => InvolutiveAlgebra k DualBasis where+  inv f = f' where+    afe = adjoint (f E)+    nfd = negate (f D)+    f' E = afe+    f' D = nfd++instance (InvolutiveSemiring k, Rng k) => InvolutiveCoalgebra k DualBasis where+  coinv = inv++instance (InvolutiveSemiring k, Rng k) => HopfAlgebra k DualBasis where+  antipode = inv++instance (Commutative r, Rng r) => Multiplicative (Dual r) where+  (*) = mulRep++instance (TriviallyInvolutive r, Rng r) => Commutative (Dual r)++instance (Commutative r, Rng r) => Semiring (Dual r)++instance (Commutative r, Ring r) => Unital (Dual r) where+  one = oneRep++instance (Commutative r, Ring r) => Rig (Dual r) where+  fromNatural n = Dual (fromNatural n) zero++instance (Commutative r, Ring r) => Ring (Dual r) where+  fromInteger n = Dual (fromInteger n) zero++instance (Commutative r, Rng r) => LeftModule (Dual r) (Dual r) where (.*) = (*)+instance (Commutative r, Rng r) => RightModule (Dual r) (Dual r) where (*.) = (*)++instance (Commutative r, Rng r, InvolutiveSemiring r) => InvolutiveMultiplication (Dual r) where+  adjoint (Dual a b) = Dual (adjoint a) (negate b)++instance (Commutative r, Rng r, InvolutiveSemiring r) => InvolutiveSemiring (Dual r)++instance (Commutative r, Rng r, InvolutiveSemiring r) => Quadrance r (Dual r) where+  quadrance n = case adjoint n * n of+    Dual a _ -> a++instance (Commutative r, InvolutiveSemiring r, DivisionRing r) => Division (Dual r) where+  recip q@(Dual a b) = Dual (qq \\ a) (qq \\ b)+    where qq = quadrance q

@@ -0,0 +1,12 @@+module Numeric.Algebra.Dual.Class+  ( Infinitesimal(..)+  ) where++import Numeric.Algebra.Distinguished.Class+import Numeric.Covector++class Distinguished t => Infinitesimal t where+  d :: t++instance Infinitesimal a => Infinitesimal (Covector r a) where+  d = return d

@@ -1,215 +0,0 @@-{-# LANGUAGE -    MultiParamTypeClasses, -    GeneralizedNewtypeDeriving, -    BangPatterns,-    TypeOperators,-    DeriveDataTypeable,-    FlexibleInstances,-    TypeFamilies,-    UndecidableInstances,-    ScopedTypeVariables #-}--module Numeric.Algebra.Geometric-  ( -  -- * Geometric algebra primitives-    Blade(..)-  , Multivector-  , Comultivector-  -- * Operations over an eigenbasis-  , Eigenbasis(..)-  , Eigenmetric(..)-  -- * Grade-  , grade-  , filterGrade-  -- * Inversions-  , reverse-  , gradeInversion-  , cliffordConjugate-  -- * Products-  , geometric-  , outer-  -- * Inner products-  , contractL-  , contractR-  , hestenes-  , dot-  , liftProduct-  ) where--import Control.Monad (mfilter)-import Data.Bits-import Data.Functor.Representable.Trie-import Data.Word-import Data.Data-import Data.Ix-import Data.Array.Unboxed-import Numeric.Algebra-import Prelude hiding ((-),(*),(+),negate,reverse)---- a basis vector for a simple geometric algebra with the euclidean inner product-newtype Blade m = Blade { runBlade :: Word64 } deriving -  ( Eq,Ord,Num,Bits,Enum,Ix,Bounded,Show,Read,Real,Integral-  , Additive,Abelian,LeftModule Natural,RightModule Natural,Monoidal-  , Multiplicative,Unital,Commutative-  , Semiring,Rig-  , DecidableZero,DecidableAssociates,DecidableUnits-  )--instance HasTrie (Blade m) where-  type BaseTrie (Blade m) = BaseTrie Word64-  embedKey = embedKey . runBlade-  projectKey = Blade . projectKey---- A metric space over an eigenbasis-class Eigenbasis m where-  euclidean     :: proxy m -> Bool-  antiEuclidean :: proxy m -> Bool-  v             :: m -> Blade m-  e             :: Int -> m---- assuming n /= 0, find the index of the least significant set bit in a basis blade-lsb :: Blade m -> Int-lsb n = fromIntegral $ ix ! shiftR ((n .&. (-n)) * 0x07EDD5E59A4E28C2) 58-  where -    -- a 64 bit deBruijn multiplication table-    ix :: UArray (Blade m) Word8-    ix = listArray (0, 63) -      [ 63,  0, 58,  1, 59, 47, 53,  2-      , 60, 39, 48, 27, 54, 33, 42,  3-      , 61, 51, 37, 40, 49, 18, 28, 20-      , 55, 30, 34, 11, 43, 14, 22,  4-      , 62, 57, 46, 52, 38, 26, 32, 41-      , 50, 36, 17, 19, 29, 10, 13, 21-      , 56, 45, 25, 31, 35, 16,  9, 12-      , 44, 24, 15,  8, 23,  7,  6,  5-      ]--class (Ring r, Eigenbasis m) => Eigenmetric r m where-  metric :: m -> r--type Comultivector r m = Covector r (Blade m)--type Multivector r m = Blade m :->: r---- Euclidean basis, we can work with basis vectors for euclidean spaces of up to 64 dimensions without --- expanding the representation of our basis vectors-newtype Euclidean = Euclidean Int deriving -  ( Eq,Ord,Show,Read,Num,Ix,Enum,Real,Integral-  , Data,Typeable-  , Additive,LeftModule Natural,RightModule Natural,Monoidal,Abelian,LeftModule Integer,RightModule Integer,Group-  , Multiplicative,TriviallyInvolutive,InvolutiveMultiplication,InvolutiveSemiring,Unital,Commutative-  , Semiring,Rig,Ring-  )--instance HasTrie Euclidean where-  type BaseTrie Euclidean = BaseTrie Int-  embedKey (Euclidean i) = embedKey i-  projectKey = Euclidean . projectKey--instance Eigenbasis Euclidean where-  euclidean _ = True-  antiEuclidean _ = False-  v n = shiftL 1 (fromIntegral n)-  e = fromIntegral--instance Ring r => Eigenmetric r Euclidean where-  metric _ = one--grade :: Blade m -> Int-grade = fromIntegral . count 5 . count 4 . count 3 . count 2 . count 1 . count 0 where -  count c x = (x .&. mask) + (shiftR x p .&. mask) where -    p = shiftL 1 c-    mask = (-1) `div` (shiftL 1 p + 1)--m1powTimes :: (Bits n, Group r) => n -> r -> r-m1powTimes n r -  | (n .&. 1) == 0 = r-  | otherwise      = negate r--reorder :: Group r => Blade m -> Blade m -> r -> r-reorder a0 b = m1powTimes $ go 0 (shiftR a0 1)-  where-    go !acc 0 = acc-    go acc a = go (acc + grade (a .&. b)) (shiftR a 1)---- <A>_k-filterGrade :: Monoidal r => Blade m -> Int -> Covector r (Blade m)-filterGrade b k | grade b == k = zero-                | otherwise    = return b--instance Eigenmetric r m => Coalgebra r (Blade m) where-  comult f n m = scale (n .&. m) $ reorder n m $ f $ xor n m where-    scale b-      | euclidean n = id-      | otherwise   = (go one b *)-    go :: Eigenmetric r m => r -> Blade m -> r-    go acc 0 = acc-    go acc n' | b <- lsb n'-              , m' <- metric (e b :: m)-              = go (acc*m') (clearBit n' b)--instance Eigenmetric r m => CounitalCoalgebra r (Blade m) where-  counit f = f (Blade zero)---- instance Group r => InvertibleModule r Blade where-  --- reversion (A~) is an involution for the outer product-reverse :: Group r => Blade m -> Comultivector r m-reverse b = shiftR (g * (g - 1)) 1 `m1powTimes` return b where-  g = grade b--cliffordConjugate :: Group r => Blade m -> Comultivector r m-cliffordConjugate b = shiftR (g * (g + 1)) 1 `m1powTimes` return b where-  g = grade b---- A^-gradeInversion :: Group r => Blade m -> Comultivector r m-gradeInversion b = grade b `m1powTimes` return b--geometric :: Eigenmetric r m => Blade m -> Blade m -> Comultivector r m  -geometric = multM--outer :: Eigenmetric r m => Blade m -> Blade m -> Comultivector r m-outer m n | m .&. n == 0 = geometric m n -          | otherwise    = zero---- A _| B--- grade (A _| B) = grade B - grade A-contractL :: Eigenmetric r m => Blade m -> Blade m -> Comultivector r m -contractL a b -  | ga Prelude.> gb   = zero-  | otherwise = mfilter (\r -> grade r == gb - ga) (geometric a b)-  where-    ga = grade a-    gb = grade b---- A |_ B--- grade (A |_ B) = grade A - grade B-contractR :: Eigenmetric r m => Blade m -> Blade m -> Comultivector r m-contractR a b -  | ga Prelude.< gb   = zero-  | otherwise = mfilter (\r -> grade r == ga - gb) (geometric a b)-  where-    ga = grade a-    gb = grade b---- the modified Hestenes' product-dot :: Eigenmetric r m => Blade m -> Blade m -> Comultivector r m-dot a b = mfilter (\r -> grade r == abs(grade a - grade b)) (geometric a b)---- Hestenes' inner product--- if 0 /= grade a <= grade b then --- dot a b = hestenes a b = leftContract a b-hestenes :: Eigenmetric r m => Blade m -> Blade m -> Comultivector r m-hestenes a b-  | ga == 0 || gb == 0 = zero-  | otherwise = mfilter (\r -> grade r == abs(ga - gb)) (geometric a b)-  where-    ga = grade a-    gb = grade b--liftProduct :: (Blade m -> Blade m -> Comultivector r m) -> Comultivector r m -> Comultivector r m -> Comultivector r m-liftProduct f ma mb = do-  a <- ma-  b <- mb-  f a b

@@ -1,8 +1,8 @@ {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeFamilies, UndecidableInstances, DeriveDataTypeable #-}-module Numeric.Algebra.Hyperbolic +module Numeric.Algebra.Hyperbolic   ( Hyperbolic(..)-  , HyperBasis(..)-  , Hyper(..)+  , HyperBasis'(..)+  , Hyper'(..)   ) where  import Control.Applicative@@ -20,186 +20,203 @@ import Data.Semigroup.Foldable import Data.Traversable import Numeric.Algebra+import Numeric.Coalgebra.Hyperbolic.Class import Prelude hiding ((-),(+),(*),negate,subtract, fromInteger) --- complex basis-data HyperBasis = S | C deriving (Eq,Ord,Show,Read,Enum,Ix,Bounded,Data,Typeable)-data Hyper a = Hyper a a deriving (Eq,Show,Read,Data,Typeable)--class Hyperbolic r where-  s :: r-  c :: r+-- the dual hyperbolic 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-  s = S-  c = C+instance Hyperbolic HyperBasis' where+  cosh = Cosh'+  sinh = Sinh' -instance Rig r => Hyperbolic (Hyper r) where-  s = Hyper one zero-  c = Hyper zero one+instance Rig r => Hyperbolic (Hyper' r) where+  cosh = Hyper' one zero+  sinh = Hyper' zero one   -instance Rig r => Hyperbolic (HyperBasis -> r) where-  s S = one-  s C = zero-  c S = zero-  c C = one--instance Hyperbolic a => Hyperbolic (Covector r a) where-  s = return s-  c = return c+instance Rig r => Hyperbolic (HyperBasis' -> r) where+  cosh Sinh' = zero+  cosh Cosh' = one+  sinh Sinh' = one+  sinh Cosh' = zero -type instance Key Hyper = HyperBasis+type instance Key Hyper' = HyperBasis' -instance Representable Hyper where-  tabulate f = Hyper (f S) (f C)+instance Representable Hyper' where+  tabulate f = Hyper' (f Cosh') (f Sinh') -instance Indexable Hyper where-  index (Hyper a _ ) S = a-  index (Hyper _ b ) C = b+instance Indexable Hyper' where+  index (Hyper' a _ ) Cosh' = a+  index (Hyper' _ b ) Sinh' = b -instance Lookup Hyper where+instance Lookup Hyper' where   lookup = lookupDefault -instance Adjustable Hyper where-  adjust f S (Hyper a b) = Hyper (f a) b-  adjust f C (Hyper a b) = Hyper a (f b)+instance Adjustable Hyper' where+  adjust f Cosh' (Hyper' a b) = Hyper' (f a) b+  adjust f Sinh' (Hyper' a b) = Hyper' a (f b) -instance Distributive Hyper where+instance Distributive Hyper' where   distribute = distributeRep  -instance Functor Hyper where-  fmap f (Hyper a b) = Hyper (f a) (f b)+instance Functor Hyper' where+  fmap f (Hyper' a b) = Hyper' (f a) (f b) -instance Zip Hyper where-  zipWith f (Hyper a1 b1) (Hyper a2 b2) = Hyper (f a1 a2) (f b1 b2)+instance Zip Hyper' where+  zipWith f (Hyper' a1 b1) (Hyper' a2 b2) = Hyper' (f a1 a2) (f b1 b2) -instance ZipWithKey Hyper where-  zipWithKey f (Hyper a1 b1) (Hyper a2 b2) = Hyper (f S a1 a2) (f C b1 b2)+instance ZipWithKey Hyper' where+  zipWithKey f (Hyper' a1 b1) (Hyper' a2 b2) = Hyper' (f Cosh' a1 a2) (f Sinh' b1 b2) -instance Keyed Hyper where+instance Keyed Hyper' where   mapWithKey = mapWithKeyRep -instance Apply Hyper where+instance Apply Hyper' where   (<.>) = apRep -instance Applicative Hyper where+instance Applicative Hyper' where   pure = pureRep   (<*>) = apRep  -instance Bind Hyper where+instance Bind Hyper' where   (>>-) = bindRep -instance Monad Hyper where+instance Monad Hyper' where   return = pureRep   (>>=) = bindRep -instance MonadReader HyperBasis Hyper where+instance MonadReader HyperBasis' Hyper' where   ask = askRep   local = localRep -instance Foldable Hyper where-  foldMap f (Hyper a b) = f a `mappend` f b+instance Foldable Hyper' where+  foldMap f (Hyper' a b) = f a `mappend` f b -instance FoldableWithKey Hyper where-  foldMapWithKey f (Hyper a b) = f S a `mappend` f C b+instance FoldableWithKey Hyper' where+  foldMapWithKey f (Hyper' a b) = f Cosh' a `mappend` f Sinh' b -instance Traversable Hyper where-  traverse f (Hyper a b) = Hyper <$> f a <*> f b+instance Traversable Hyper' where+  traverse f (Hyper' a b) = Hyper' <$> f a <*> f b -instance TraversableWithKey Hyper where-  traverseWithKey f (Hyper a b) = Hyper <$> f S a <*> f C b+instance TraversableWithKey Hyper' where+  traverseWithKey f (Hyper' a b) = Hyper' <$> f Cosh' a <*> f Sinh' b -instance Foldable1 Hyper where-  foldMap1 f (Hyper a b) = f a <> f b+instance Foldable1 Hyper' where+  foldMap1 f (Hyper' a b) = f a <> f b -instance FoldableWithKey1 Hyper where-  foldMapWithKey1 f (Hyper a b) = f S a <> f C b+instance FoldableWithKey1 Hyper' where+  foldMapWithKey1 f (Hyper' a b) = f Cosh' a <> f Sinh' b -instance Traversable1 Hyper where-  traverse1 f (Hyper a b) = Hyper <$> f a <.> f b+instance Traversable1 Hyper' where+  traverse1 f (Hyper' a b) = Hyper' <$> f a <.> f b -instance TraversableWithKey1 Hyper where-  traverseWithKey1 f (Hyper a b) = Hyper <$> f S a <.> f C b+instance TraversableWithKey1 Hyper' where+  traverseWithKey1 f (Hyper' a b) = Hyper' <$> f Cosh' a <.> f Sinh' b -instance HasTrie HyperBasis where-  type BaseTrie HyperBasis = Hyper+instance HasTrie HyperBasis' where+  type BaseTrie HyperBasis' = Hyper'   embedKey = id   projectKey = id -instance Additive r => Additive (Hyper r) where+instance Additive r => Additive (Hyper' r) where   (+) = addRep    replicate1p = replicate1pRep -instance LeftModule r s => LeftModule r (Hyper s) where-  r .* Hyper a b = Hyper (r .* a) (r .* b)+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 RightModule r s => RightModule r (Hyper' s) where+  Hyper' a b *. r = Hyper' (a *. r) (b *. r) -instance Monoidal r => Monoidal (Hyper r) where+instance Monoidal r => Monoidal (Hyper' r) where   zero = zeroRep   replicate = replicateRep -instance Group r => Group (Hyper r) where+instance Group r => Group (Hyper' r) where   (-) = minusRep   negate = negateRep   subtract = subtractRep   times = timesRep -instance Abelian r => Abelian (Hyper r)+instance Abelian r => Abelian (Hyper' r) -instance Idempotent r => Idempotent (Hyper r)+instance Idempotent r => Idempotent (Hyper' r) -instance Partitionable r => Partitionable (Hyper r) where-  partitionWith f (Hyper a b) = id =<<+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+    partitionWith (\b1 b2 -> f (Hyper' a1 b1) (Hyper' a2 b2)) b) a --- the dual, hyperbolic trigonometric algebra-instance (Commutative k, Semiring k) => Algebra k HyperBasis where+-- the dual hyperbolic trigonometric algebra+instance (Commutative k, Semiring k) => Algebra k HyperBasis' where   mult f = f' where-    fs = f S C + f C S-    fc = f C C + f S S-    f' S = fs-    f' C = fc+    fs = f Sinh' Cosh' + f Cosh' Sinh'+    fc = f Cosh' Cosh' + f Sinh' Sinh'+    f' Sinh' = fs+    f' Cosh' = fc -instance (Commutative k, Monoidal k, Semiring k) => UnitalAlgebra k HyperBasis where-  unit _ S = zero-  unit x C = x+instance (Commutative k, Monoidal k, Semiring k) => UnitalAlgebra k HyperBasis' where+  unit _ Sinh' = zero+  unit x Cosh' = x --- the actual hyperbolic trigonometric coalgebra-instance (Commutative k, Semiring k) => Coalgebra k HyperBasis where+-- the diagonal coalgebra+instance (Commutative k, Monoidal k, Semiring k) => Coalgebra k HyperBasis' where   comult f = f' where-     fs = f S-     fc = f C-     f' S S = fc-     f' S C = fs -     f' C S = fs-     f' C C = fc+     fs = f Sinh'+     fc = f Cosh'+     f' Sinh' Sinh' = fs+     f' Sinh' Cosh' = zero+     f' Cosh' Sinh' = zero+     f' Cosh' Cosh' = fc -instance (Commutative k, Semiring k) => CounitalCoalgebra k HyperBasis where-  counit f = f C+instance (Commutative k, Monoidal k, Semiring k) => CounitalCoalgebra k HyperBasis' where+  counit f = f Cosh' + f Sinh' -instance (Commutative k, Semiring k) => Multiplicative (Hyper k) where+instance (Commutative k, Monoidal 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) => Commutative (Hyper' k) -instance (Commutative k, Semiring k) => Semiring (Hyper k)+instance (Commutative k, Semiring k) => Semiring (Hyper' k) -instance (Commutative k, Rig k) => Unital (Hyper k) where-  one = Hyper zero one+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 zero (fromNatural n)+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 zero (fromInteger n)+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, Semiring r) => LeftModule (Hyper' r) (Hyper' r) where (.*) = (*)+instance (Commutative r, Semiring r) => RightModule (Hyper' r) (Hyper' r) where (*.) = (*) -instance (Commutative r, Semiring r, InvolutiveMultiplication r) => InvolutiveMultiplication (Hyper r) where-  adjoint (Hyper a b) = Hyper (adjoint a) (adjoint b)+instance (Commutative r, InvolutiveSemiring r, Rng r) => InvolutiveMultiplication (Hyper' r) where+  adjoint (Hyper' a b) = Hyper' (adjoint a) (negate b) -instance (Commutative r, InvolutiveSemiring r) => InvolutiveSemiring (Hyper r)+instance (Commutative r, InvolutiveSemiring r, Rng r) => InvolutiveSemiring (Hyper' r)++instance (Commutative r, InvolutiveSemiring r, Rng r) => Quadrance r (Hyper' r) where+  quadrance n = case adjoint n * n of+    Hyper' a _ -> a++instance (Commutative r, InvolutiveSemiring r, DivisionRing r) => Division (Hyper' r) where+  recip q@(Hyper' a b) = Hyper' (qq \\ a) (qq \\ b)+    where qq = quadrance q+

@@ -1,16 +1,23 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeFamilies, UndecidableInstances, DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances+           , MultiParamTypeClasses+           , TypeFamilies+           , UndecidableInstances+           , DeriveDataTypeable+           , TypeOperators #-} module Numeric.Algebra.Quaternion -  ( Complicated(..)+  ( Distinguished(..)+  , Complicated(..)   , Hamiltonian(..)   , QuaternionBasis(..)   , Quaternion(..)   , complicate-  , uncomplicate+  , vectorPart+  , scalarPart   ) where  import Control.Applicative import Control.Monad.Reader.Class-import Data.Ix+import Data.Ix hiding (index) import Data.Key import Data.Data import Data.Distributive@@ -23,34 +30,47 @@ import Data.Semigroup.Traversable import Data.Semigroup.Foldable import Numeric.Algebra-import Numeric.Algebra.Complex (ComplexBasis, Complicated(..))+import Numeric.Algebra.Distinguished.Class+import Numeric.Algebra.Complex.Class+import Numeric.Algebra.Quaternion.Class import qualified Numeric.Algebra.Complex as Complex import Prelude hiding ((-),(+),(*),negate,subtract, fromInteger) -class Complicated t => Hamiltonian t where-  j :: t-  k :: t+instance Distinguished QuaternionBasis where+  e = E  instance Complicated QuaternionBasis where-  e = E   i = I  instance Hamiltonian QuaternionBasis where   j = J   k = K -instance Rig r => Complicated (Quaternion r) where+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 => Complicated (QuaternionBasis -> r) where+instance Rig r => Distinguished (QuaternionBasis :->: r) where+  e = Trie e++instance Rig r => Complicated (QuaternionBasis :->: r) where+  i = Trie i++instance Rig r => Hamiltonian (QuaternionBasis :->: r) where+  j = Trie j+  k = Trie k++instance Rig r => Distinguished (QuaternionBasis -> r) where   e E = one    e _ = zero +instance Rig r => Complicated (QuaternionBasis -> r) where   i I = one   i _ = zero   @@ -61,10 +81,6 @@   k K = one   k _ = zero -instance Hamiltonian a => Hamiltonian (Covector r a) where-  j = return j-  k = return k- -- quaternion basis data QuaternionBasis = E | I | J | K deriving (Eq,Ord,Enum,Read,Show,Bounded,Ix,Data,Typeable) @@ -197,6 +213,7 @@                                (Quaternion a2 b2 c2 d2)                   ) d) c) b) a +-- | the quaternion algebra instance (TriviallyInvolutive r, Rng r) => Algebra r QuaternionBasis where   mult f = f' where     fe = f E E - (f I I + f J J + f K K)@@ -212,12 +229,30 @@   unit x E = x    unit _ _ = zero +-- | the trivial diagonal coalgebra 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+    f' E E = fe+    f' I I = fi+    f' J J = fj+    f' K K = fk+    f' _ _ = zero++instance (TriviallyInvolutive r, Rng r) => CounitalCoalgebra r QuaternionBasis where+  counit f = f E + f I + f J + f K++{-+-- 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@@ -241,6 +276,7 @@  instance (TriviallyInvolutive r, Rng r) => CounitalCoalgebra r QuaternionBasis where   counit f = f E+-}  instance (TriviallyInvolutive r, Rng r)  => Bialgebra r QuaternionBasis  @@ -279,15 +315,21 @@   adjoint (Quaternion a b c d) = Quaternion a (negate b) (negate c) (negate d)  -- | Cayley-Dickson quaternion isomorphism (one way)-complicate :: QuaternionBasis -> (ComplexBasis, ComplexBasis)-complicate E = (Complex.E, Complex.E)-complicate I = (Complex.I, Complex.E)-complicate J = (Complex.E, Complex.I)-complicate K = (Complex.I, Complex.I)+complicate :: Complicated c => QuaternionBasis -> (c,c)+complicate E = (e, e)+complicate I = (i, e) +complicate J = (e, i)+complicate K = (i, i) --- | Cayley-Dickson quaternion isomorphism (the other half)-uncomplicate :: ComplexBasis -> ComplexBasis -> QuaternionBasis-uncomplicate Complex.E Complex.E = E-uncomplicate Complex.I Complex.E = I-uncomplicate Complex.E Complex.I = J-uncomplicate Complex.I Complex.I = K+scalarPart :: (Representable f, Key f ~ QuaternionBasis) => f r -> r+scalarPart f = index f E++vectorPart :: (Representable f, Key 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

@@ -0,0 +1,14 @@+module Numeric.Algebra.Quaternion.Class+  ( Hamiltonian(..)+  ) where++import Numeric.Algebra.Complex.Class+import Numeric.Covector++class Complicated t => Hamiltonian t where+  j :: t+  k :: t++instance Hamiltonian a => Hamiltonian (Covector r a) where+  j = return j+  k = return k

@@ -1,206 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeFamilies, UndecidableInstances, DeriveDataTypeable #-}-module Numeric.Algebra.Trigonometric -  ( Trigonometric(..)-  , TrigBasis(..)-  , Trig(..)-  ) where--import Control.Applicative-import Control.Monad.Reader.Class-import Data.Data-import Data.Distributive-import Data.Functor.Bind-import Data.Functor.Representable-import Data.Functor.Representable.Trie-import Data.Foldable-import Data.Ix-import Data.Key-import Data.Monoid-import Data.Semigroup.Traversable-import Data.Semigroup.Foldable-import Data.Traversable-import Numeric.Algebra-import Prelude hiding ((-),(+),(*),negate,subtract, fromInteger)---- complex basis-data TrigBasis = S | C deriving (Eq,Ord,Show,Read,Enum,Ix,Bounded,Data,Typeable)-data Trig a = Trig a a deriving (Eq,Show,Read,Data,Typeable)--class Trigonometric r where-  s :: r-  c :: r--instance Trigonometric TrigBasis where-  s = S-  c = C--instance Rig r => Trigonometric (Trig r) where-  s = Trig one zero-  c = Trig zero one-  -instance Rig r => Trigonometric (TrigBasis -> r) where-  s S = one-  s C = zero-  c S = zero-  c C = one--instance Trigonometric a => Trigonometric (Covector r a) where-  s = return s-  c = return c--type instance Key Trig = TrigBasis--instance Representable Trig where-  tabulate f = Trig (f S) (f C)--instance Indexable Trig where-  index (Trig a _ ) S = a-  index (Trig _ b ) C = b--instance Lookup Trig where-  lookup = lookupDefault--instance Adjustable Trig where-  adjust f S (Trig a b) = Trig (f a) b-  adjust f C (Trig a b) = Trig a (f b)--instance Distributive Trig where-  distribute = distributeRep --instance Functor Trig where-  fmap f (Trig a b) = Trig (f a) (f b)--instance Zip Trig where-  zipWith f (Trig a1 b1) (Trig a2 b2) = Trig (f a1 a2) (f b1 b2)--instance ZipWithKey Trig where-  zipWithKey f (Trig a1 b1) (Trig a2 b2) = Trig (f S a1 a2) (f C b1 b2)--instance Keyed Trig where-  mapWithKey = mapWithKeyRep--instance Apply Trig where-  (<.>) = apRep--instance Applicative Trig where-  pure = pureRep-  (<*>) = apRep --instance Bind Trig where-  (>>-) = bindRep--instance Monad Trig where-  return = pureRep-  (>>=) = bindRep--instance MonadReader TrigBasis Trig where-  ask = askRep-  local = localRep--instance Foldable Trig where-  foldMap f (Trig a b) = f a `mappend` f b--instance FoldableWithKey Trig where-  foldMapWithKey f (Trig a b) = f S a `mappend` f C b--instance Traversable Trig where-  traverse f (Trig a b) = Trig <$> f a <*> f b--instance TraversableWithKey Trig where-  traverseWithKey f (Trig a b) = Trig <$> f S a <*> f C b--instance Foldable1 Trig where-  foldMap1 f (Trig a b) = f a <> f b--instance FoldableWithKey1 Trig where-  foldMapWithKey1 f (Trig a b) = f S a <> f C b--instance Traversable1 Trig where-  traverse1 f (Trig a b) = Trig <$> f a <.> f b--instance TraversableWithKey1 Trig where-  traverseWithKey1 f (Trig a b) = Trig <$> f S a <.> f C b--instance HasTrie TrigBasis where-  type BaseTrie TrigBasis = Trig-  embedKey = id-  projectKey = id--instance Additive r => Additive (Trig r) where-  (+) = addRep -  replicate1p = replicate1pRep--instance LeftModule r s => LeftModule r (Trig s) where-  r .* Trig a b = Trig (r .* a) (r .* b)--instance RightModule r s => RightModule r (Trig s) where-  Trig a b *. r = Trig (a *. r) (b *. r)--instance Monoidal r => Monoidal (Trig r) where-  zero = zeroRep-  replicate = replicateRep--instance Group r => Group (Trig r) where-  (-) = minusRep-  negate = negateRep-  subtract = subtractRep-  times = timesRep--instance Abelian r => Abelian (Trig r)--instance Idempotent r => Idempotent (Trig r)--instance Partitionable r => Partitionable (Trig r) where-  partitionWith f (Trig a b) = id =<<-    partitionWith (\a1 a2 -> -    partitionWith (\b1 b2 -> f (Trig a1 b1) (Trig a2 b2)) b) a---- the dual, trigonometric algebra-instance (Commutative k, Rng k) => Algebra k TrigBasis where-  mult f = f' where-    fs = f S C + f C S-    fc = f C C - f S S-    f' S = fs-    f' C = fc--instance (Commutative k, Rng k) => UnitalAlgebra k TrigBasis where-  unit _ S = zero-  unit x C = x---- the actual trigonometric coalgebra-instance (Commutative k, Rng k) => Coalgebra k TrigBasis where-  comult f = f' where-     fs = f S-     fc = f C-     fc' = negate fc-     f' S S = fc'-     f' S C = fs -     f' C S = fs-     f' C C = fc--instance (Commutative k, Rng k) => CounitalCoalgebra k TrigBasis where-  counit f = f C--instance (Commutative k, Rng k) => Multiplicative (Trig k) where-  (*) = mulRep--instance (Commutative k, Rng k) => Commutative (Trig k)--instance (Commutative k, Rng k) => Semiring (Trig k)--instance (Commutative k, Ring k) => Unital (Trig k) where-  one = Trig zero one--instance (Commutative r, Ring r) => Rig (Trig r) where-  fromNatural n = Trig zero (fromNatural n)--instance (Commutative r, Ring r) => Ring (Trig r) where-  fromInteger n = Trig zero (fromInteger n)--instance (Commutative r, Rng r) => LeftModule (Trig r) (Trig r) where (.*) = (*)-instance (Commutative r, Rng r) => RightModule (Trig r) (Trig r) where (*.) = (*)--instance (Commutative r, Rng r, InvolutiveMultiplication r) => InvolutiveMultiplication (Trig r) where-  adjoint (Trig a b) = Trig (adjoint a) (adjoint b)--instance (Commutative r, Rng r, InvolutiveSemiring r) => InvolutiveSemiring (Trig r)

@@ -0,0 +1,227 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeFamilies, UndecidableInstances, DeriveDataTypeable #-}+module Numeric.Coalgebra.Dual+  ( Distinguished(..)+  , Infinitesimal(..)+  , DualBasis'(..)+  , Dual'(..)+  ) where++import Control.Applicative+import Control.Monad.Reader.Class+import Data.Data+import Data.Distributive+import Data.Functor.Bind+import Data.Functor.Representable+import Data.Functor.Representable.Trie+import Data.Foldable+import Data.Ix+import Data.Key+import Data.Monoid+import Data.Semigroup.Traversable+import Data.Semigroup.Foldable+import Data.Traversable+import Numeric.Algebra+import Numeric.Algebra.Distinguished.Class+import Numeric.Algebra.Dual.Class+import Prelude hiding ((-),(+),(*),negate,subtract, fromInteger,recip)++-- | dual number basis, D^2 = 0. D /= 0.+data DualBasis' = E | D deriving (Eq,Ord,Show,Read,Enum,Ix,Bounded,Data,Typeable)+data Dual' a = Dual' a a deriving (Eq,Show,Read,Data,Typeable)++instance Distinguished DualBasis' where+  e = E++instance Infinitesimal DualBasis' where+  d = D++instance Rig r => Distinguished (Dual' r) where+  e = Dual' one zero++instance Rig r => Infinitesimal (Dual' r) where+  d = Dual' zero one+  +instance Rig r => Distinguished (DualBasis' -> r) where+  e E = one+  e _ = zero++instance Rig r => Infinitesimal (DualBasis' -> r) where+  d D = one+  d _       = zero ++type instance Key Dual' = DualBasis'++instance Representable Dual' where+  tabulate f = Dual' (f E) (f D)++instance Indexable Dual' where+  index (Dual' a _ ) E = a+  index (Dual' _ b ) D = b++instance Lookup Dual' where+  lookup = lookupDefault++instance Adjustable Dual' where+  adjust f E (Dual' a b) = Dual' (f a) b+  adjust f D (Dual' a b) = Dual' a (f b)++instance Distributive Dual' where+  distribute = distributeRep ++instance Functor Dual' where+  fmap f (Dual' a b) = Dual' (f a) (f b)++instance Zip Dual' where+  zipWith f (Dual' a1 b1) (Dual' a2 b2) = Dual' (f a1 a2) (f b1 b2)++instance ZipWithKey Dual' where+  zipWithKey f (Dual' a1 b1) (Dual' a2 b2) = Dual' (f E a1 a2) (f D b1 b2)++instance Keyed Dual' where+  mapWithKey = mapWithKeyRep++instance Apply Dual' where+  (<.>) = apRep++instance Applicative Dual' where+  pure = pureRep+  (<*>) = apRep ++instance Bind Dual' where+  (>>-) = bindRep++instance Monad Dual' where+  return = pureRep+  (>>=) = bindRep++instance MonadReader DualBasis' Dual' where+  ask = askRep+  local = localRep++instance Foldable Dual' where+  foldMap f (Dual' a b) = f a `mappend` f b++instance FoldableWithKey Dual' where+  foldMapWithKey f (Dual' a b) = f E a `mappend` f D b++instance Traversable Dual' where+  traverse f (Dual' a b) = Dual' <$> f a <*> f b++instance TraversableWithKey Dual' where+  traverseWithKey f (Dual' a b) = Dual' <$> f E a <*> f D b++instance Foldable1 Dual' where+  foldMap1 f (Dual' a b) = f a <> f b++instance FoldableWithKey1 Dual' where+  foldMapWithKey1 f (Dual' a b) = f E a <> f D b++instance Traversable1 Dual' where+  traverse1 f (Dual' a b) = Dual' <$> f a <.> f b++instance TraversableWithKey1 Dual' where+  traverseWithKey1 f (Dual' a b) = Dual' <$> f E a <.> f D b++instance HasTrie DualBasis' where+  type BaseTrie DualBasis' = Dual'+  embedKey = id+  projectKey = id++instance Additive r => Additive (Dual' r) where+  (+) = addRep +  replicate1p = replicate1pRep++instance LeftModule r s => LeftModule r (Dual' s) where+  r .* Dual' a b = Dual' (r .* a) (r .* b)++instance RightModule r s => RightModule r (Dual' s) where+  Dual' a b *. r = Dual' (a *. r) (b *. r)++instance Monoidal r => Monoidal (Dual' r) where+  zero = zeroRep+  replicate = replicateRep++instance Group r => Group (Dual' r) where+  (-) = minusRep+  negate = negateRep+  subtract = subtractRep+  times = timesRep++instance Abelian r => Abelian (Dual' r)++instance Idempotent r => Idempotent (Dual' r)++instance Partitionable r => Partitionable (Dual' r) where+  partitionWith f (Dual' a b) = id =<<+    partitionWith (\a1 a2 -> +    partitionWith (\b1 b2 -> f (Dual' a1 b1) (Dual' a2 b2)) b) a++instance Semiring k => Algebra k DualBasis' where+  mult f = f' where+    fe = f E E+    fd = f D D+    f' E = fe+    f' D = fd++instance Semiring k => UnitalAlgebra k DualBasis' where+  unit = const++-- the trivial coalgebra+instance Rng k => Coalgebra k DualBasis' where+  comult f = f' where+     fe = f E+     fd = f D+     f' E E = fe+     f' E D = fd+     f' D E = fd+     f' D D = zero++instance Rng k => CounitalCoalgebra k DualBasis' where+  counit f = f E++instance Rng k => Bialgebra k DualBasis' ++instance (InvolutiveSemiring k, Rng k) => InvolutiveAlgebra k DualBasis' where+  inv f = f' where+    afe = adjoint (f E)+    nfd = negate (f D)+    f' E = afe+    f' D = nfd++instance (InvolutiveSemiring k, Rng k) => InvolutiveCoalgebra k DualBasis' where+  coinv = inv++instance (InvolutiveSemiring k, Rng k) => HopfAlgebra k DualBasis' where+  antipode = inv++instance (Commutative r, Rng r) => Multiplicative (Dual' r) where+  (*) = mulRep++instance (TriviallyInvolutive r, Rng r) => Commutative (Dual' r)++instance (Commutative r, Rng r) => Semiring (Dual' r)++instance (Commutative r, Ring r) => Unital (Dual' r) where+  one = oneRep++instance (Commutative r, Ring r) => Rig (Dual' r) where+  fromNatural n = Dual' (fromNatural n) zero++instance (Commutative r, Ring r) => Ring (Dual' r) where+  fromInteger n = Dual' (fromInteger n) zero++instance (Commutative r, Rng r) => LeftModule (Dual' r) (Dual' r) where (.*) = (*)+instance (Commutative r, Rng r) => RightModule (Dual' r) (Dual' r) where (*.) = (*)++instance (Commutative r, Rng r, InvolutiveSemiring r) => InvolutiveMultiplication (Dual' r) where+  adjoint (Dual' a b) = Dual' (adjoint a) (negate b)++instance (Commutative r, Rng r, InvolutiveSemiring r) => InvolutiveSemiring (Dual' r)++instance (Commutative r, Rng r, InvolutiveSemiring r) => Quadrance r (Dual' r) where+  quadrance n = case adjoint n * n of+    Dual' a _ -> a++instance (Commutative r, InvolutiveSemiring r, DivisionRing r) => Division (Dual' r) where+  recip q@(Dual' a b) = Dual' (qq \\ a) (qq \\ b)+    where qq = quadrance q

@@ -0,0 +1,212 @@+{-# LANGUAGE +    MultiParamTypeClasses, +    GeneralizedNewtypeDeriving, +    BangPatterns,+    TypeOperators,+    DeriveDataTypeable,+    FlexibleInstances,+    TypeFamilies,+    UndecidableInstances,+    ScopedTypeVariables #-}++module Numeric.Coalgebra.Geometric+  ( +  -- * Geometric coalgebra primitives+    BasisCoblade(..)+  , Comultivector+  -- * Operations over an eigenbasis+  , Eigenbasis(..)+  , Eigenmetric(..)+  -- * Grade+  , grade+  , filterGrade+  -- * Inversions+  , reverse+  , gradeInversion+  , cliffordConjugate+  -- * Products+  , geometric+  , outer+  -- * Inner products+  , contractL+  , contractR+  , hestenes+  , dot+  , liftProduct+  ) where++import Control.Monad (mfilter)+import Data.Bits+import Data.Functor.Representable.Trie+import Data.Word+import Data.Data+import Data.Ix+import Data.Array.Unboxed+import Numeric.Algebra+import Prelude hiding ((-),(*),(+),negate,reverse)++-- a basis vector for a simple geometric coalgebra with the Euclidean inner product+newtype BasisCoblade m = BasisCoblade { runBasisCoblade :: Word64 } deriving +  ( Eq,Ord,Num,Bits,Enum,Ix,Bounded,Show,Read,Real,Integral+  , Additive,Abelian,LeftModule Natural,RightModule Natural,Monoidal+  , Multiplicative,Unital,Commutative+  , Semiring,Rig+  , DecidableZero,DecidableAssociates,DecidableUnits+  )++instance HasTrie (BasisCoblade m) where+  type BaseTrie (BasisCoblade m) = BaseTrie Word64+  embedKey = embedKey . runBasisCoblade+  projectKey = BasisCoblade . projectKey++-- A metric space over an eigenbasis+class Eigenbasis m where+  euclidean     :: proxy m -> Bool+  antiEuclidean :: proxy m -> Bool+  v             :: m -> BasisCoblade m+  e             :: Int -> m++-- assuming n /= 0, find the index of the least significant set bit in a basis blade+lsb :: BasisCoblade m -> Int+lsb n = fromIntegral $ ix ! shiftR ((n .&. (-n)) * 0x07EDD5E59A4E28C2) 58+  where +    -- a 64 bit deBruijn multiplication table+    ix :: UArray (BasisCoblade m) Word8+    ix = listArray (0, 63) +      [ 63,  0, 58,  1, 59, 47, 53,  2+      , 60, 39, 48, 27, 54, 33, 42,  3+      , 61, 51, 37, 40, 49, 18, 28, 20+      , 55, 30, 34, 11, 43, 14, 22,  4+      , 62, 57, 46, 52, 38, 26, 32, 41+      , 50, 36, 17, 19, 29, 10, 13, 21+      , 56, 45, 25, 31, 35, 16,  9, 12+      , 44, 24, 15,  8, 23,  7,  6,  5+      ]++class (Ring r, Eigenbasis m) => Eigenmetric r m where+  metric :: m -> r++type Comultivector r m = Covector r (BasisCoblade m)++-- Euclidean basis, we can work with basis vectors for euclidean spaces of up to 64 dimensions without +-- expanding the representation of our basis vectors+newtype Euclidean = Euclidean Int deriving +  ( Eq,Ord,Show,Read,Num,Ix,Enum,Real,Integral+  , Data,Typeable+  , Additive,LeftModule Natural,RightModule Natural,Monoidal,Abelian,LeftModule Integer,RightModule Integer,Group+  , Multiplicative,TriviallyInvolutive,InvolutiveMultiplication,InvolutiveSemiring,Unital,Commutative+  , Semiring,Rig,Ring+  )++instance HasTrie Euclidean where+  type BaseTrie Euclidean = BaseTrie Int+  embedKey (Euclidean i) = embedKey i+  projectKey = Euclidean . projectKey++instance Eigenbasis Euclidean where+  euclidean _ = True+  antiEuclidean _ = False+  v n = shiftL 1 (fromIntegral n)+  e = fromIntegral++instance Ring r => Eigenmetric r Euclidean where+  metric _ = one++grade :: BasisCoblade m -> Int+grade = fromIntegral . count 5 . count 4 . count 3 . count 2 . count 1 . count 0 where +  count c x = (x .&. mask) + (shiftR x p .&. mask) where +    p = shiftL 1 c+    mask = (-1) `div` (shiftL 1 p + 1)++m1powTimes :: (Bits n, Group r) => n -> r -> r+m1powTimes n r +  | (n .&. 1) == 0 = r+  | otherwise      = negate r++reorder :: Group r => BasisCoblade m -> BasisCoblade m -> r -> r+reorder a0 b = m1powTimes $ go 0 (shiftR a0 1)+  where+    go !acc 0 = acc+    go acc a = go (acc + grade (a .&. b)) (shiftR a 1)++-- <A>_k+filterGrade :: Monoidal r => BasisCoblade m -> Int -> Comultivector r m+filterGrade b k | grade b == k = zero+                | otherwise    = return b++instance Eigenmetric r m => Coalgebra r (BasisCoblade m) where+  comult f n m = scale (n .&. m) $ reorder n m $ f $ xor n m where+    scale b+      | euclidean n = id+      | otherwise   = (go one b *)+    go :: Eigenmetric r m => r -> BasisCoblade m -> r+    go acc 0 = acc+    go acc n' | b <- lsb n'+              , m' <- metric (e b :: m)+              = go (acc*m') (clearBit n' b)++instance Eigenmetric r m => CounitalCoalgebra r (BasisCoblade m) where+  counit f = f (BasisCoblade zero)++-- instance Group r => InvertibleModule r BasisCoblade where+  +-- reversion (A~) is an involution for the outer product+reverse :: Group r => BasisCoblade m -> Comultivector r m+reverse b = shiftR (g * (g - 1)) 1 `m1powTimes` return b where+  g = grade b++cliffordConjugate :: Group r => BasisCoblade m -> Comultivector r m+cliffordConjugate b = shiftR (g * (g + 1)) 1 `m1powTimes` return b where+  g = grade b++-- A^+gradeInversion :: Group r => BasisCoblade m -> Comultivector r m+gradeInversion b = grade b `m1powTimes` return b++geometric :: Eigenmetric r m => BasisCoblade m -> BasisCoblade m -> Comultivector r m  +geometric = multM++outer :: Eigenmetric r m => BasisCoblade m -> BasisCoblade m -> Comultivector r m+outer m n | m .&. n == 0 = geometric m n +          | otherwise    = zero++-- A _| B+-- grade (A _| B) = grade B - grade A+contractL :: Eigenmetric r m => BasisCoblade m -> BasisCoblade m -> Comultivector r m +contractL a b +  | ga Prelude.> gb   = zero+  | otherwise = mfilter (\r -> grade r == gb - ga) (geometric a b)+  where+    ga = grade a+    gb = grade b++-- A |_ B+-- grade (A |_ B) = grade A - grade B+contractR :: Eigenmetric r m => BasisCoblade m -> BasisCoblade m -> Comultivector r m+contractR a b +  | ga Prelude.< gb   = zero+  | otherwise = mfilter (\r -> grade r == ga - gb) (geometric a b)+  where+    ga = grade a+    gb = grade b++-- the modified Hestenes' product+dot :: Eigenmetric r m => BasisCoblade m -> BasisCoblade m -> Comultivector r m+dot a b = mfilter (\r -> grade r == abs(grade a - grade b)) (geometric a b)++-- Hestenes' inner product+-- if 0 /= grade a <= grade b then +-- dot a b = hestenes a b = leftContract a b+hestenes :: Eigenmetric r m => BasisCoblade m -> BasisCoblade m -> Comultivector r m+hestenes a b+  | ga == 0 || gb == 0 = zero+  | otherwise = mfilter (\r -> grade r == abs(ga - gb)) (geometric a b)+  where+    ga = grade a+    gb = grade b++liftProduct :: (BasisCoblade m -> BasisCoblade m -> Comultivector r m) -> Comultivector r m -> Comultivector r m -> Comultivector r m+liftProduct f ma mb = do+  a <- ma+  b <- mb+  f a b

@@ -0,0 +1,212 @@+{-# 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.Representable+import Data.Functor.Representable.Trie+import Data.Foldable+import Data.Ix+import Data.Key+import Data.Monoid+import Data.Semigroup.Traversable+import Data.Semigroup.Foldable+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++type instance Key Hyper = HyperBasis++instance Representable Hyper where+  tabulate f = Hyper (f Cosh) (f Sinh)++instance Indexable Hyper where+  index (Hyper a _ ) Cosh = a+  index (Hyper _ b ) Sinh = b++instance Lookup Hyper where+  lookup = lookupDefault++instance Adjustable Hyper where+  adjust f Cosh (Hyper a b) = Hyper (f a) b+  adjust f Sinh (Hyper a b) = Hyper a (f b)++instance Distributive Hyper where+  distribute = distributeRep ++instance Functor Hyper where+  fmap f (Hyper a b) = Hyper (f a) (f b)++instance Zip Hyper where+  zipWith f (Hyper a1 b1) (Hyper a2 b2) = Hyper (f a1 a2) (f b1 b2)++instance ZipWithKey Hyper where+  zipWithKey f (Hyper a1 b1) (Hyper a2 b2) = Hyper (f Cosh a1 a2) (f Sinh b1 b2)++instance Keyed Hyper where+  mapWithKey = mapWithKeyRep++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 FoldableWithKey Hyper where+  foldMapWithKey f (Hyper a b) = f Cosh a `mappend` f Sinh b++instance Traversable Hyper where+  traverse f (Hyper a b) = Hyper <$> f a <*> f b++instance TraversableWithKey Hyper where+  traverseWithKey f (Hyper a b) = Hyper <$> f Cosh a <*> f Sinh b++instance Foldable1 Hyper where+  foldMap1 f (Hyper a b) = f a <> f b++instance FoldableWithKey1 Hyper where+  foldMapWithKey1 f (Hyper a b) = f Cosh a <> f Sinh b++instance Traversable1 Hyper where+  traverse1 f (Hyper a b) = Hyper <$> f a <.> f b++instance TraversableWithKey1 Hyper where+  traverseWithKey1 f (Hyper a b) = Hyper <$> f Cosh a <.> f Sinh b++instance HasTrie HyperBasis where+  type BaseTrie HyperBasis = Hyper+  embedKey = id+  projectKey = id++instance Additive r => Additive (Hyper r) where+  (+) = addRep +  replicate1p = replicate1pRep++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+  replicate = replicateRep++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)

@@ -0,0 +1,14 @@+module Numeric.Coalgebra.Hyperbolic.Class+  ( Hyperbolic(..)+  ) where++import Prelude (return)+import Numeric.Covector++class Hyperbolic r where+  cosh :: r+  sinh :: r++instance Hyperbolic a => Hyperbolic (Covector r a) where+  cosh = return cosh+  sinh = return sinh

@@ -0,0 +1,317 @@+{-# 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.Key+import Data.Data+import Data.Distributive+import Data.Functor.Bind+import Data.Functor.Representable+import Data.Functor.Representable.Trie+import Data.Foldable+import Data.Traversable+import Data.Monoid+import Data.Semigroup.Traversable+import Data.Semigroup.Foldable+import Numeric.Algebra+import Numeric.Algebra.Distinguished.Class+import Numeric.Algebra.Complex.Class+import Numeric.Algebra.Quaternion.Class+import qualified Numeric.Algebra.Complex as Complex+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 = Trie e++instance Rig r => Complicated (QuaternionBasis' :->: r) where+  i = Trie i++instance Rig r => Hamiltonian (QuaternionBasis' :->: r) where+  j = Trie j+  k = Trie k++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)++type instance Key Quaternion' = QuaternionBasis'++instance Representable Quaternion' where+  tabulate f = Quaternion' (f E') (f I') (f J') (f K')++instance Indexable Quaternion' where+  index (Quaternion' a _ _ _) E' = a+  index (Quaternion' _ b _ _) I' = b+  index (Quaternion' _ _ c _) J' = c+  index (Quaternion' _ _ _ d) K' = d++instance Lookup Quaternion' where+  lookup = lookupDefault++instance Adjustable Quaternion' where+  adjust f E' (Quaternion' a b c d) = Quaternion' (f a) b c d+  adjust f I' (Quaternion' a b c d) = Quaternion' a (f b) c d+  adjust f J' (Quaternion' a b c d) = Quaternion' a b (f c) d+  adjust f K' (Quaternion' a b c d) = Quaternion' a b c (f d)++instance Distributive Quaternion' where+  distribute = distributeRep ++instance Functor Quaternion' where+  fmap = fmapRep++instance Zip Quaternion' where+  zipWith f (Quaternion' a1 b1 c1 d1) (Quaternion' a2 b2 c2 d2) = +    Quaternion' (f a1 a2) (f b1 b2) (f c1 c2) (f d1 d2)++instance ZipWithKey Quaternion' where+  zipWithKey f (Quaternion' a1 b1 c1 d1) (Quaternion' a2 b2 c2 d2) = +    Quaternion' (f E' a1 a2) (f I' b1 b2) (f J' c1 c2) (f K' d1 d2)++instance Keyed Quaternion' where+  mapWithKey = mapWithKeyRep++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 FoldableWithKey Quaternion' where+  foldMapWithKey f (Quaternion' a b c d) = +    f E' a `mappend` f I' b `mappend` f J' c `mappend` f K' d++instance Traversable Quaternion' where+  traverse f (Quaternion' a b c d) = +    Quaternion' <$> f a <*> f b <*> f c <*> f d++instance TraversableWithKey Quaternion' where+  traverseWithKey f (Quaternion' a b c d) = +    Quaternion' <$> f E' a <*> f I' b <*> f J' c <*> f K' d++instance Foldable1 Quaternion' where+  foldMap1 f (Quaternion' a b c d) = +    f a <> f b <> f c <> f d++instance FoldableWithKey1 Quaternion' where+  foldMapWithKey1 f (Quaternion' a b c d) = +    f E' a <> f I' b <> f J' c <> f K' d++instance Traversable1 Quaternion' where+  traverse1 f (Quaternion' a b c d) = +    Quaternion' <$> f a <.> f b <.> f c <.> f d++instance TraversableWithKey1 Quaternion' where+  traverseWithKey1 f (Quaternion' a b c d) = +    Quaternion' <$> f E' a <.> f I' b <.> f J' c <.> f K' d++instance HasTrie QuaternionBasis' where+  type BaseTrie QuaternionBasis' = Quaternion'+  embedKey = id+  projectKey = id++instance Additive r => Additive (Quaternion' r) where+  (+) = addRep +  replicate1p = replicate1pRep++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+  replicate = replicateRep++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, Key f ~ QuaternionBasis') => f r -> r+scalarPart' f = index f E'++vectorPart' :: (Representable f, Key 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

@@ -0,0 +1,250 @@+{-# LANGUAGE MultiParamTypeClasses+           , FlexibleInstances+           , TypeFamilies+           , UndecidableInstances+           , DeriveDataTypeable+           , TypeOperators #-}+module Numeric.Coalgebra.Trigonometric +  ( Trigonometric(..)+  , TrigBasis(..)+  , Trig(..)+  ) where++import Control.Applicative+import Control.Monad.Reader.Class+import Data.Data+import Data.Distributive+import Data.Functor.Bind+import Data.Functor.Representable+import Data.Functor.Representable.Trie+import Data.Foldable+import Data.Ix+import Data.Key+import Data.Monoid+import Data.Semigroup.Traversable+import Data.Semigroup.Foldable+import Data.Traversable+import Numeric.Algebra+import Prelude hiding ((-),(+),(*),negate,subtract, fromInteger, sin, cos)+import Numeric.Algebra.Distinguished.Class+import Numeric.Algebra.Complex.Class+import Numeric.Coalgebra.Trigonometric.Class++-- the dual complex basis+data TrigBasis = Cos | Sin deriving (Eq,Ord,Show,Read,Enum,Ix,Bounded,Data,Typeable)+data Trig a = Trig a a deriving (Eq,Show,Read,Data,Typeable)++instance Distinguished TrigBasis where+  e = Cos++instance Complicated TrigBasis where+  i = Sin++instance Trigonometric TrigBasis where+  cos = Cos+  sin = Sin++instance Rig r => Distinguished (Trig r) where+  e = Trig one zero++instance Rig r => Complicated (Trig r) where+  i = Trig zero one++instance Rig r => Trigonometric (Trig r) where+  cos = Trig one zero+  sin = Trig zero one++instance Rig r => Distinguished (TrigBasis -> r) where+  e = cos++instance Rig r => Complicated (TrigBasis -> r) where+  i = sin+  +instance Rig r => Trigonometric (TrigBasis -> r) where+  cos Sin = zero+  cos Cos = one++  sin Sin = one+  sin Cos = zero++instance Rig r => Trigonometric (TrigBasis :->: r) where+  cos = Trie cos+  sin = Trie sin++instance Rig r => Distinguished (TrigBasis :->: r) where+  e = Trie e++instance Rig r => Complicated (TrigBasis :->: r) where+  i = Trie i+  +type instance Key Trig = TrigBasis++instance Representable Trig where+  tabulate f = Trig (f Cos) (f Sin)++instance Indexable Trig where+  index (Trig a _ ) Cos = a+  index (Trig _ b ) Sin = b++instance Lookup Trig where+  lookup = lookupDefault++instance Adjustable Trig where+  adjust f Cos (Trig a b) = Trig (f a) b+  adjust f Sin (Trig a b) = Trig a (f b)++instance Distributive Trig where+  distribute = distributeRep ++instance Functor Trig where+  fmap f (Trig a b) = Trig (f a) (f b)++instance Zip Trig where+  zipWith f (Trig a1 b1) (Trig a2 b2) = Trig (f a1 a2) (f b1 b2)++instance ZipWithKey Trig where+  zipWithKey f (Trig a1 b1) (Trig a2 b2) = Trig (f Cos a1 a2) (f Sin b1 b2)++instance Keyed Trig where+  mapWithKey = mapWithKeyRep++instance Apply Trig where+  (<.>) = apRep++instance Applicative Trig where+  pure = pureRep+  (<*>) = apRep ++instance Bind Trig where+  (>>-) = bindRep++instance Monad Trig where+  return = pureRep+  (>>=) = bindRep++instance MonadReader TrigBasis Trig where+  ask = askRep+  local = localRep++instance Foldable Trig where+  foldMap f (Trig a b) = f a `mappend` f b++instance FoldableWithKey Trig where+  foldMapWithKey f (Trig a b) = f Cos a `mappend` f Sin b++instance Traversable Trig where+  traverse f (Trig a b) = Trig <$> f a <*> f b++instance TraversableWithKey Trig where+  traverseWithKey f (Trig a b) = Trig <$> f Cos a <*> f Sin b++instance Foldable1 Trig where+  foldMap1 f (Trig a b) = f a <> f b++instance FoldableWithKey1 Trig where+  foldMapWithKey1 f (Trig a b) = f Cos a <> f Sin b++instance Traversable1 Trig where+  traverse1 f (Trig a b) = Trig <$> f a <.> f b++instance TraversableWithKey1 Trig where+  traverseWithKey1 f (Trig a b) = Trig <$> f Cos a <.> f Sin b++instance HasTrie TrigBasis where+  type BaseTrie TrigBasis = Trig+  embedKey = id+  projectKey = id++instance Additive r => Additive (Trig r) where+  (+) = addRep +  replicate1p = replicate1pRep++instance LeftModule r s => LeftModule r (Trig s) where+  r .* Trig a b = Trig (r .* a) (r .* b)++instance RightModule r s => RightModule r (Trig s) where+  Trig a b *. r = Trig (a *. r) (b *. r)++instance Monoidal r => Monoidal (Trig r) where+  zero = zeroRep+  replicate = replicateRep++instance Group r => Group (Trig r) where+  (-) = minusRep+  negate = negateRep+  subtract = subtractRep+  times = timesRep++instance Abelian r => Abelian (Trig r)++instance Idempotent r => Idempotent (Trig r)++instance Partitionable r => Partitionable (Trig r) where+  partitionWith f (Trig a b) = id =<<+    partitionWith (\a1 a2 -> +    partitionWith (\b1 b2 -> f (Trig a1 b1) (Trig a2 b2)) b) a++-- the diagonal algebra+instance (Commutative k, Rng k) => Algebra k TrigBasis where+  mult f = f' where+    fc = f Cos Cos+    fs = f Sin Sin+    f' Cos = fc+    f' Sin = fs++-- +instance (Commutative k, Rng k) => UnitalAlgebra k TrigBasis where+  unit = const++-- The trigonometric coalgebra+instance (Commutative k, Rng k) => Coalgebra k TrigBasis where+  comult f = f' where+     fs = f Sin+     fc = f Cos+     fc' = negate fc+     f' Sin Sin = fc'+     f' Sin Cos = fs +     f' Cos Sin = fs+     f' Cos Cos = fc++instance (Commutative k, Rng k) => Bialgebra k TrigBasis++instance (Commutative k, Group k, InvolutiveSemiring k) => InvolutiveAlgebra k TrigBasis where+  inv f = f' where+    afc = adjoint (f Cos)+    nfs = negate (f Sin)+    f' Cos = afc+    f' Sin = nfs++instance (Commutative k, Group k, InvolutiveSemiring k) => InvolutiveCoalgebra k TrigBasis where+  coinv = inv++instance (Commutative k, Group k, InvolutiveSemiring k) => HopfAlgebra k TrigBasis where+  antipode = inv++instance (Commutative k, Rng k) => CounitalCoalgebra k TrigBasis where+  counit f = f Cos++instance (Commutative k, Rng k) => Multiplicative (Trig k) where+  (*) = mulRep++instance (Commutative k, Rng k) => Commutative (Trig k)++instance (Commutative k, Rng k) => Semiring (Trig k)++instance (Commutative k, Ring k) => Unital (Trig k) where+  one = Trig one zero++instance (Commutative r, Ring r) => Rig (Trig r) where+  fromNatural n = Trig (fromNatural n) zero++instance (Commutative r, Ring r) => Ring (Trig r) where+  fromInteger n = Trig (fromInteger n) zero++instance (Commutative r, Rng r) => LeftModule (Trig r) (Trig r) where (.*) = (*)+instance (Commutative r, Rng r) => RightModule (Trig r) (Trig r) where (*.) = (*)++instance (Commutative r, Rng r, InvolutiveMultiplication r) => InvolutiveMultiplication (Trig r) where+  adjoint (Trig a b) = Trig (adjoint a) (negate b)++instance (Commutative r, Rng r, InvolutiveSemiring r) => InvolutiveSemiring (Trig r)

@@ -0,0 +1,14 @@+module Numeric.Coalgebra.Trigonometric.Class+  ( Trigonometric(..)+  ) where++import Prelude (return)+import Numeric.Covector++class Trigonometric r where+  cos :: r+  sin :: r++instance Trigonometric a => Trigonometric (Covector r a) where+  cos = return cos+  sin = return sin

@@ -0,0 +1,10 @@+{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}+module Numeric.Field.Class +  ( Field+  ) where++import Numeric.Ring.Division+import Numeric.Algebra.Commutative++class (Commutative r, DivisionRing r) => Field r+instance (Commutative r, DivisionRing r) => Field r

@@ -0,0 +1,10 @@+{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}+module Numeric.Ring.Division+  ( DivisionRing+  ) where++import Numeric.Algebra.Division+import Numeric.Ring.Class++class (Division r, Ring r) => DivisionRing r+instance (Division r, Ring r) => DivisionRing r

@@ -1,6 +1,6 @@ name:          algebra category:      Math, Algebra-version:       0.6.0+version:       0.7.0 license:       BSD3 cabal-version: >= 1.6 license-file:  LICENSE@@ -34,16 +34,27 @@     representable-tries >= 2.0 && < 2.1,     void >= 0.5.4 && < 0.6 --- reflection >= 0.4 && < 0.5,   exposed-modules:     Numeric.Algebra+    Numeric.Covector+    Numeric.Natural++    Numeric.Algebra.Distinguished.Class     Numeric.Algebra.Complex+    Numeric.Algebra.Complex.Class+    Numeric.Algebra.Dual+    Numeric.Algebra.Dual.Class     Numeric.Algebra.Quaternion-    Numeric.Algebra.Trigonometric+    Numeric.Algebra.Quaternion.Class     Numeric.Algebra.Hyperbolic-    Numeric.Algebra.Geometric+    Numeric.Coalgebra.Dual+    Numeric.Coalgebra.Hyperbolic+    Numeric.Coalgebra.Hyperbolic.Class+    Numeric.Coalgebra.Trigonometric+    Numeric.Coalgebra.Trigonometric.Class+    Numeric.Coalgebra.Geometric+    Numeric.Coalgebra.Quaternion     Numeric.Band.Rectangular-    Numeric.Covector     Numeric.Exp     Numeric.Log     Numeric.Map@@ -64,10 +75,10 @@     Numeric.Algebra.Commutative     Numeric.Algebra.Factorable     Numeric.Algebra.Hopf-    Numeric.Natural     Numeric.Decidable.Zero     Numeric.Decidable.Units     Numeric.Decidable.Associates+    Numeric.Field.Class     Numeric.Module.Class     Numeric.Module.Representable     Numeric.Semiring.Integral@@ -78,6 +89,7 @@     Numeric.Rig.Class     Numeric.Rng.Class     Numeric.Ring.Class+    Numeric.Ring.Division     Numeric.Rig.Ordered     Numeric.Rig.Characteristic     Numeric.Order.Class