rings 0.1.1.1 → 0.1.2

raw patch · 9 files changed

+1447/−1395 lines, 9 files

Files

• rings.cabal +8/−7
• src/Data/Algebra.hs +0/−309
• src/Data/Semimodule.hs +17/−2
• src/Data/Semimodule/Algebra.hs +704/−0
• src/Data/Semimodule/Basis.hs +26/−26
• src/Data/Semimodule/Dual.hs +180/−0
• src/Data/Semimodule/Free.hs +213/−308
• src/Data/Semimodule/Operator.hs +299/−0
• src/Data/Semimodule/Transform.hs +0/−743

@@ -1,7 +1,7 @@ name:                rings-version:             0.1.1.1+version:             0.1.2 synopsis:            Ring-like objects.-description:         Semirings, rings, division rings, algebras, and modules.+description:         Semirings, rings, division rings, modules, and algebras. homepage:            https://github.com/cmk/rings license:             BSD3 license-file:        LICENSE@@ -18,19 +18,20 @@ library   hs-source-dirs:   src   default-language: Haskell2010-  ghc-options:     -Wall+  ghc-options: -Wall    exposed-modules:-      Data.Algebra-    , Data.Semiring+      Data.Semiring     , Data.Semiring.Property     , Data.Semifield     , Data.Semigroup.Additive     , Data.Semigroup.Property     , Data.Semimodule-    , Data.Semimodule.Free+    , Data.Semimodule.Operator+    , Data.Semimodule.Algebra     , Data.Semimodule.Basis-    , Data.Semimodule.Transform+    , Data.Semimodule.Dual+    , Data.Semimodule.Free    default-extensions:       ScopedTypeVariables

@@ -1,309 +0,0 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE Safe                       #-}-{-# LANGUAGE PolyKinds                  #-}-{-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE DefaultSignatures          #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE NoImplicitPrelude          #-}-{-# LANGUAGE RebindableSyntax           #-}-{-# LANGUAGE TypeOperators              #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE RankNTypes               #-}--module Data.Algebra (-  -- * Algebras -    type FreeAlgebra-  , Algebra(..)-  , (.*.)-  , type FreeUnital-  , Unital(..)-  , unital-  , unit-  -- * Coalgebras -  , type FreeCoalgebra-  , Coalgebra(..)-  , type FreeCounital-  , Counital(..)-  , counital-  -- * Bialgebras -  , type FreeBialgebra-  , Bialgebra-) where--import safe Data.Bool-import safe Data.Functor.Rep-import safe Data.Semimodule-import safe Data.Semiring-import safe Prelude (Ord, reverse)-import safe qualified Data.IntSet as IntSet-import safe qualified Data.Set as Set-import safe qualified Data.Sequence as Seq-import safe Data.Sequence hiding (reverse,index)-import safe Prelude hiding (Num(..), Fractional(..), negate, sum, product)------------------------------------------------------------------------------------ Algebras------------------------------------------------------------------------------------ | An algebra over a free module /f/.------ Note that this is distinct from a < https://en.wikipedia.org/wiki/Free_algebra free algebra >.----type FreeAlgebra a f = (FreeSemimodule a f, Algebra a (Rep f))---- | An algebra < https://en.wikipedia.org/wiki/Algebra_over_a_field#Generalization:_algebra_over_a_ring algebra > over a semiring.------ Note that the algebra < https://en.wikipedia.org/wiki/Non-associative_algebra needn't be associative >.----class Semiring a => Algebra a b where-  append :: (b -> b -> a) -> b -> a--infixl 7 .*.---- | Multiplication operator on an algebra over a free semimodule.------ /Caution/ in general (.*.) needn't be commutative, nor associative.----(.*.) :: FreeAlgebra a f => f a -> f a -> f a-(.*.) x y = tabulate $ append (\i j -> index x i * index y j)---- | A unital algebra over a free semimodule /f/.----type FreeUnital a f = (FreeAlgebra a f, Unital a (Rep f))---- | A < https://en.wikipedia.org/wiki/Algebra_over_a_field#Unital_algebra unital algebra > over a semiring.----class Algebra a b => Unital a b where-  aempty :: a -> b -> a---- | Insert an element into an algebra.------ >>> V4 1 2 3 4 .*. unital two :: V4 Int--- V4 2 4 6 8-unital :: FreeUnital a f => a -> f a-unital = tabulate . aempty---- | Unital element of a unital algebra over a free semimodule.------ >>> unit :: Complex Int--- 1 :+ 0--- >>> unit :: QuatD--- Quaternion 1.0 (V3 0.0 0.0 0.0)----unit :: FreeUnital a f => f a-unit = unital one------------------------------------------------------------------------------------ Coalgebras------------------------------------------------------------------------------------ | A coalgebra over a free semimodule /f/.----type FreeCoalgebra a f = (FreeSemimodule a f, Coalgebra a (Rep f))---- | A coalgebra over a semiring.------ ( id *** coempty ) . coappend = id = ( coempty *** id ) . coappend-class Semiring a => Coalgebra a c where-  coappend :: (c -> a) -> c -> c -> a---- | A counital coalgebra over a free semimodule /f/.----type FreeCounital a f = (FreeCoalgebra a f, Counital a (Rep f))---- | A counital coalgebra over a semiring.----class Coalgebra a c => Counital a c where-  coempty :: (c -> a) -> a---- | Obtain an element from a coalgebra over a free semimodule.----counital :: FreeCounital a f => f a -> a-counital = coempty . index------------------------------------------------------------------------------------ Bialgebras------------------------------------------------------------------------------------ | A bialgebra over a free semimodule /f/.----type FreeBialgebra a f = (FreeAlgebra a f, FreeCoalgebra a f, Bialgebra a (Rep f))---- | A < https://en.wikipedia.org/wiki/Bialgebra bialgebra > over a semiring.----class (Unital a b, Counital a b) => Bialgebra a b------------------------------------------------------------------------------------ Instances-------------------------------------------------------------------------------------instance (Semiring a, Algebra a b) => Algebra a (a -> r) where---  aempty = aempty one----instance (Semiring a, Division a b) => Division r (a -> r) where---  reciprocalWith = reciprocalWith---- incoherent--- instance Algebra () a where aempty _ _ = ()--- instance (Algebra a b, Algebra a c) => Algebra (a -> r) b where aempty f b a = aempty (f a) b---instance (Algebra r a, Algebra r b) => Algebra (a -> r) b where aempty f b a = aempty (f a) b----instance (Algebra r b, Algebra r a) => Algebra (b -> r) a where append f a b = append (\a1 a2 -> f a1 a2 b) a---instance Semiring a => Algebra a () where-  append f = f ()--instance Semiring a => Unital a () where-  aempty r () = r--instance (Algebra a b, Algebra a c) => Algebra a (b, c) where-  append f (a,b) = append (\a1 a2 -> append (\b1 b2 -> f (a1,b1) (a2,b2)) b) a--instance (Unital a b, Unital a c) => Unital a (b, c) where-  aempty r (a,b) = aempty r a * aempty r b--instance (Algebra a b, Algebra a c, Algebra a d) => Algebra a (b, c, d) where-  append f (a,b,c) = append (\a1 a2 -> append (\b1 b2 -> append (\c1 c2 -> f (a1,b1,c1) (a2,b2,c2)) c) b) a--instance (Unital a b, Unital a c, Unital a d) => Unital a (b, c, d) where-  aempty r (a,b,c) = aempty r a * aempty r b * aempty r c---- | Tensor algebra------ >>> append (<>) [1..3 :: Int]--- [1,2,3,1,2,3,1,2,3,1,2,3]------ >>> append (\f g -> fold (f ++ g)) [1..3] :: Int--- 24----instance Semiring a => Algebra a [a] where-  append f = go [] where-    go ls rrs@(r:rs) = f (reverse ls) rrs + go (r:ls) rs-    go ls [] = f (reverse ls) []--instance Semiring a => Unital a [a] where-  aempty a [] = a-  aempty _ _ = zero----- | The tensor algebra-instance Semiring r => Algebra r (Seq a) where-  append f = go Seq.empty where-    go ls s = case viewl s of-       EmptyL -> f ls s -       r :< rs -> f ls s + go (ls |> r) rs--instance Semiring r => Unital r (Seq a) where-  aempty r a | Seq.null a = r-             | otherwise = zero--instance (Semiring r, Ord a) => Algebra r (Set.Set a) where-  append f = go Set.empty where-    go ls s = case Set.minView s of-       Nothing -> f ls s-       Just (r, rs) -> f ls s + go (Set.insert r ls) rs--instance (Semiring r, Ord a) => Unital r (Set.Set a) where-  aempty r a | Set.null a = r-           | otherwise = zero--instance Semiring r => Algebra r IntSet.IntSet where-  append f = go IntSet.empty where-    go ls s = case IntSet.minView s of-       Nothing -> f ls s-       Just (r, rs) -> f ls s + go (IntSet.insert r ls) rs--instance Semiring r => Unital r IntSet.IntSet where-  aempty r a | IntSet.null a = r-             | otherwise = zero-------------------------------------------------------------------------- Coalgebra instances-------------------------------------------------------------------------instance Semiring r => Coalgebra r () where-  coappend = const--instance Semiring r => Counital r () where-  coempty f = f ()--instance (Coalgebra r a, Coalgebra r b) => Coalgebra r (a, b) where-  coappend f (a1,b1) (a2,b2) = coappend (\a -> coappend (\b -> f (a,b)) b1 b2) a1 a2--instance (Counital r a, Counital r b) => Counital r (a, b) where-  coempty k = coempty $ \a -> coempty $ \b -> k (a,b)--instance (Coalgebra r a, Coalgebra r b, Coalgebra r c) => Coalgebra r (a, b, c) where-  coappend f (a1,b1,c1) (a2,b2,c2) = coappend (\a -> coappend (\b -> coappend (\c -> f (a,b,c)) c1 c2) b1 b2) a1 a2--instance (Counital r a, Counital r b, Counital r c) => Counital r (a, b, c) where-  coempty k = coempty $ \a -> coempty $ \b -> coempty $ \c -> k (a,b,c)--instance (Algebra r a) => Coalgebra r (a -> r) where-  coappend k f g = k (f * g)--instance (Algebra r a) => Counital r (a -> r) where-  coempty k = k one--{--instance (Semiring r, FreeAlgebra r f) => Coalgebra r (f r) where-  coappend k f g = k (f .*. g)--instance (Semiring r, FreeUnital r f) => Counital r (f r) where-  coempty k = k unit--}----- incoherent--- instance (UnitalAlgebra r a, Coalgebra r c) => Coalgebra (a -> r) c where coempty k a = coempty (`k` a)--- instance Coalgebra () a where coempty _ = ()----- | The tensor Hopf algebra--- Δ(x) = x ⊗ 1 + 1 ⊗ x, x in V, Δ(1) = 1 ⊗ 1-instance Semiring r => Coalgebra r [a] where-  coappend f as bs = f (mappend as bs)--instance Semiring r => Counital r [a] where-  coempty k = k []---- | The tensor Hopf algebra-instance Semiring r => Coalgebra r (Seq a) where-  coappend f as bs = f (mappend as bs)--instance Semiring r => Counital r (Seq a) where-  coempty k = k (Seq.empty)---- | the free commutative band coalgebra-instance (Semiring r, Ord a) => Coalgebra r (Set.Set a) where-  coappend f as bs = f (Set.union as bs)--instance (Semiring r, Ord a) => Counital r (Set.Set a) where-  coempty k = k (Set.empty)---- | the free commutative band coalgebra over Int-instance Semiring r => Coalgebra r IntSet.IntSet where-  coappend f as bs = f (IntSet.union as bs)--instance Semiring r => Counital r IntSet.IntSet where-  coempty k = k (IntSet.empty)--{---- | the free commutative coalgebra over a set and a given semigroup-instance (Semiring r, Ord a, Additive b) => Coalgebra r (Map a b) where-  coappend f as bs = f (Map.unionWith (+) as bs)-  coempty k = k (Map.empty)---- | the free commutative coalgebra over a set and Int-instance (Semiring r, Additive b) => Coalgebra r (IntMap b) where-  coappend f as bs = f (IntMap.unionWith (+) as bs)-  coempty k = k (IntMap.empty)--}--

@@ -13,7 +13,9 @@  module Data.Semimodule (   -- * Types-    type Free+    type (**) +  , type (++) +  , type Free   , type Basis   , type Basis2   , type Basis3 @@ -43,6 +45,8 @@ import safe Data.Complex import safe Data.Fixed import safe Data.Functor.Rep+import safe Data.Functor.Compose+import safe Data.Functor.Product import safe Data.Int import safe Data.Semifield import safe Data.Semiring@@ -53,6 +57,17 @@ import safe Prelude (fromInteger) import safe Prelude hiding (Num(..), Fractional(..), sum, product) +infixr 2 **+infixr 1 ++++-- | A tensor product of semimodule morphisms.+--+type (f ** g) = Compose f g++-- | A direct sum of free semimodule elements.+--+type (f ++ g) = Product f g+ type Free f = (Representable f)  type Basis b f = (Free f, Rep f ~ b, Eq b)@@ -61,7 +76,7 @@  type Basis3 b c d f g h = (Basis b f, Basis c g, Basis d h) -type FreeModule a f = (Free f, Bimodule a a (f a))+type FreeModule a f = (Free f, (Additive-Group) (f a), Bimodule a a (f a))  type FreeSemimodule a f = (Free f, Bisemimodule a a (f a)) 

@@ -0,0 +1,704 @@+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE Safe                       #-}+{-# LANGUAGE PolyKinds                  #-}+{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DefaultSignatures          #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE NoImplicitPrelude          #-}+{-# LANGUAGE RebindableSyntax           #-}+{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE RankNTypes                 #-}++module Data.Semimodule.Algebra (+  -- * Algebras +    type FreeAlgebra+  , Algebra(..)+  , diag+  , (.*.)+  -- * Unital Algebras +  , type FreeUnital+  , Unital(..)+  , unit+  , unit'+  -- * Coalgebras +  , type FreeCoalgebra+  , Coalgebra(..)+  , codiag+  , convolve+  -- * Unital Coalgebras +  , type FreeCounital+  , Counital(..)+  , counit+  -- * Bialgebras +  , type FreeBialgebra+  , Bialgebra+  -- * Tran+  , Tran(..)+  , Endo +  , image+  , (!#)+  , (#!)+  , (!#!)+  , dimap'+  , lmap'+  , rmap'+  , invmap+  -- * Common linear transformations+  , braid+  , cobraid +  , split+  , cosplit+  , projl+  , projr+  , compl+  , compr+  , complr+) where++import safe Control.Arrow+import safe Control.Applicative+import safe Control.Category (Category, (>>>), (<<<))+import safe Data.Bool+import safe Data.Functor.Rep+import safe Data.Semimodule+import safe Data.Semiring+import safe Data.Tuple (swap)+import safe Prelude (Ord, reverse)+import safe qualified Data.IntSet as IntSet+import safe qualified Data.Set as Set+import safe qualified Data.Sequence as Seq+import safe Data.Sequence hiding (reverse,index)+import safe Prelude hiding (Num(..), Fractional(..), negate, sum, product)+import safe qualified Control.Category as C+import safe Test.Logic hiding (join)++-------------------------------------------------------------------------------+-- Algebras+-------------------------------------------------------------------------------++-- | An algebra over a free module /f/.+--+-- Note that this is distinct from a < https://en.wikipedia.org/wiki/Free_algebra free algebra >.+--+type FreeAlgebra a f = (FreeSemimodule a f, Algebra a (Rep f))++-- | An algebra < https://en.wikipedia.org/wiki/Algebra_over_a_field#Generalization:_algebra_over_a_ring algebra > over a semiring.+--+-- Note that the algebra < https://en.wikipedia.org/wiki/Non-associative_algebra needn't be associative >.+--+class Semiring a => Algebra a b where++  -- |+  --+  -- @+  -- 'joined' = 'runTran' 'diagonal' '.' 'uncurry'+  -- @+  --+  joined :: (b -> b -> a) -> b -> a+  joined = runTran diagonal . uncurry++  -- |+  --+  -- @+  -- 'Data.Semimodule.Dual.rmap'' (\((c1,()),(c2,())) -> (c1,c2)) '$' ('C.id' '***' 'initial') 'C..' 'diagonal' = 'C.id'+  -- 'Data.Semimodule.Dual.rmap'' (\(((),c1),((),c2)) -> (c1,c2)) '$' ('initial' '***' 'C.id') 'C..' 'diagonal' = 'C.id'+  -- @+  --+  diagonal :: Tran a b (b,b)+  diagonal = Tran $ joined . curry++-- | Obtain the diagonal of a tensor product as a vector.+--+-- When the coalgebra is trivial we have:+--+-- @ 'diag' f = 'tabulate' $ 'joined' ('index' . 'index' ('getCompose' f)) @+--+-- >>> diag $ m22 1.0 2.0 3.0 4.0+-- V2 1.0 4.0+--+diag :: FreeAlgebra a f => (f**f) a -> f a+diag f = diagonal !# f++infixl 7 .*.++-- | Multiplication operator on an algebra over a free semimodule.+--+-- /Caution/ in general (.*.) needn't be commutative, nor associative.+--+(.*.) :: FreeAlgebra a f => f a -> f a -> f a+(.*.) x y = tabulate $ joined (\i j -> index x i * index y j)++-------------------------------------------------------------------------------+-- Unital algebras+-------------------------------------------------------------------------------++-- | A unital algebra over a free semimodule /f/.+--+type FreeUnital a f = (FreeAlgebra a f, Unital a (Rep f))++-- | A < https://en.wikipedia.org/wiki/Algebra_over_a_field#Unital_algebra unital algebra > over a semiring.+--+class Algebra a b => Unital a b where++  -- |+  --+  -- @+  -- 'unital' = 'runTran' 'initial' '.' 'const'+  -- @+  --+  unital :: a -> b -> a+  unital = runTran initial . const++  initial :: Tran a b ()+  initial = Tran $ \k -> unital $ k ()++-- | Insert an element into an algebra.+--+-- >>> V4 1 2 3 4 .*. unit two :: V4 Int+-- V4 2 4 6 8+--+unit :: FreeUnital a f => a -> f a+unit = tabulate . unital++-- | Unital element of a unital algebra over a free semimodule.+--+-- >>> unit one :: Complex Int+-- 1 :+ 0+--+unit' :: FreeUnital a f => f a+unit' = unit one++-------------------------------------------------------------------------------+-- Coalgebras+-------------------------------------------------------------------------------++-- | A coalgebra over a free semimodule /f/.+--+type FreeCoalgebra a f = (FreeSemimodule a f, Coalgebra a (Rep f))++-- | A coalgebra over a semiring.+--+class Semiring a => Coalgebra a c where++  -- |+  --+  -- @+  -- 'cojoined' = 'curry' '.' 'runTran' 'codiagonal'+  -- @+  --+  cojoined :: (c -> a) -> c -> c -> a+  cojoined = curry . runTran codiagonal+  +  -- |+  --+  -- @+  -- 'Data.Semimodule.Dual.lmap'' (\(c1,c2) -> ((c1,()),(c2,()))) '$' ('C.id' '***' 'coinitial') 'C..' 'codiagonal' = 'C.id'+  -- 'Data.Semimodule.Dual.lmap'' (\(c1,c2) -> (((),c1),((),c2))) '$' ('coinitial' '***' 'C.id') 'C..' 'codiagonal' = 'C.id'+  -- @+  --+  codiagonal :: Tran a (c,c) c+  codiagonal = Tran $ uncurry . cojoined++{-++prop_cojoined (~~) f = (codiagonal !# f) ~~ (Compose . tabulate $ \i -> tabulate $ \j -> cojoined (index f) i j)++-- trivial coalgebra+prop_codiagonal' (~~) f = (codiagonal !# f) ~~ (Compose $ flip imapRep f $ \i x -> flip imapRep f $ \j _ -> bool zero x $ (i == j))++-- trivial coalgebra+prop_codiagonal (~~) f = (codiagonal !# f) ~~ (flip bindRep id . getCompose $ f)++prop_diagonal (~~) f = (diagonal !# f) ~~ (tabulate $ joined (index . index (getCompose f)))+-}++-- | Obtain a tensor from a vector.+--+-- When the coalgebra is trivial we have:+--+-- @ 'codiag' = 'flip' 'bindRep' 'id' '.' 'getCompose' @+--+codiag :: FreeCoalgebra a f => f a -> (f**f) a+codiag f = codiagonal !# f++{-+λ> foo = convolve (tran $ m22 1 0 0 1) (tran $ m22 1 0 0 1)+λ> foo !# V2 1 2 :: V2 Int+V2 1 2+λ> foo = convolve (tran $ m22 1 0 0 1) (tran $ m22 1 1 1 1)+λ> foo !# V2 1 2 :: V2 Int+V2 1 2+λ> foo = convolve (tran $ m22 1 1 1 1) (tran $ m22 1 1 1 1)+λ> foo !# V2 1 2 :: V2 Int+V2 3 3+-}++-- | Convolution with an associative algebra and coassociative coalgebra+--+--+convolve :: Algebra a b => Coalgebra a c => Tran a b c -> Tran a b c -> Tran a b c+convolve f g = codiagonal <<< (f *** g) <<< diagonal++-------------------------------------------------------------------------------+-- Counital Coalgebras+-------------------------------------------------------------------------------++-- | A counital coalgebra over a free semimodule /f/.+--+type FreeCounital a f = (FreeCoalgebra a f, Counital a (Rep f))++-- | A counital coalgebra over a semiring.+--+class Coalgebra a c => Counital a c where++  -- @+  -- 'counital' = 'flip' ('runTran' 'coinitial') '()'+  -- @+  --+  counital :: (c -> a) -> a+  counital = flip (runTran coinitial) ()++  coinitial :: Tran a () c+  coinitial = Tran $ const . counital++-- | Obtain an element from a coalgebra over a free semimodule.+--+counit :: FreeCounital a f => f a -> a+counit = counital . index++-------------------------------------------------------------------------------+-- Bialgebras+-------------------------------------------------------------------------------++-- | A bialgebra over a free semimodule /f/.+--+type FreeBialgebra a f = (FreeAlgebra a f, FreeCoalgebra a f, Bialgebra a (Rep f))++-- | A < https://en.wikipedia.org/wiki/Bialgebra bialgebra > over a semiring.+--+class (Unital a b, Counital a b) => Bialgebra a b++-------------------------------------------------------------------------------+-- General linear transformations+-------------------------------------------------------------------------------++-- | A linear transformation between free semimodules indexed with bases /b/ and /c/.+--+-- @+-- f '!#' x '+' y = (f '!#' x) + (f '!#' y)+-- f '!#' (r '.*' x) = r '.*' (f '!#' x)+-- @+--+-- /Caution/: You must ensure these laws hold when using the default constructor.+--+-- Prefer 'image' or 'Data.Semimodule.Operator.tran' where appropriate.+--+newtype Tran a b c = Tran { runTran :: (c -> a) -> b -> a }++-- | An endomorphism over a free semimodule.+--+-- >>> one + two !# V2 1 2 :: V2 Double+-- V2 3.0 6.0+--+type Endo a b = Tran a b b++-- | Create a 'Tran' from a linear combination of basis vectors.+--+-- >>> image (e2 [(2, E31),(3, E32)] [(1, E33)]) !# V3 1 1 1 :: V2 Int+-- V2 5 1+--+image :: Semiring a => (b -> [(a, c)]) -> Tran a b c+image f = Tran $ \k b -> sum [ a * k c | (a, c) <- f b ]++infixr 2 !#++-- | Apply a transformation to a vector.+--+(!#) :: Free f => Free g => Tran a (Rep f) (Rep g) -> g a -> f a+(!#) t = tabulate . runTran t . index++infixl 2 #!++-- | Apply a transformation to a vector.+--+(#!) :: Free f => Free g => g a -> Tran a (Rep f) (Rep g) -> f a+(#!) = flip (!#)++infix 2 !#!++-- | Compose two transformations.+--+(!#!) :: Tran a c d -> Tran a b c -> Tran a b d+(!#!) = (C..)++-- | 'Tran' is a profunctor in the category of semimodules.+--+-- /Caution/: Arbitrary mapping functions may violate linearity.+--+-- >>> dimap' id (e3 True True False) (arr id) !# 4 :+ 5 :: V3 Int+-- V3 5 5 4+--+dimap' :: (b1 -> b2) -> (c1 -> c2) -> Tran a b2 c1 -> Tran a b1 c2+dimap' l r f = arr r <<< f <<< arr l++lmap' :: (b1 -> b2) -> Tran a b2 c -> Tran a b1 c+lmap' l = dimap' l id++rmap' :: (c1 -> c2) -> Tran a b c1 -> Tran a b c2+rmap' = dimap' id++-- | 'Tran' is an invariant functor.+--+-- See also < http://comonad.com/reader/2008/rotten-bananas/ >.+--+invmap :: (a1 -> a2) -> (a2 -> a1) -> Tran a1 b c -> Tran a2 b c+invmap f g (Tran t) = Tran $ \x -> t (x >>> g) >>> f++-------------------------------------------------------------------------------+-- Common linear transformations+-------------------------------------------------------------------------------++-- | Swap components of a tensor product.+--+braid :: Tran a (b , c) (c , b)+braid = arr swap+{-# INLINE braid #-}++-- | Swap components of a direct sum.+--+cobraid :: Tran a (b + c) (c + b)+cobraid = arr eswap+{-# INLINE cobraid #-}++-- | TODO: Document+--+split :: (b -> (b1 , b2)) -> Tran a b1 c -> Tran a b2 c -> Tran a b c+split f x y = dimap' f fst $ x *** y+{-# INLINE split #-}++-- | TODO: Document+--+cosplit :: ((c1 + c2) -> c) -> Tran a b c1 -> Tran a b c2 -> Tran a b c+cosplit f x y = dimap' Left f $ x +++ y+{-# INLINE cosplit #-}++-- | Project onto the left-hand component of a direct sum.+--+projl :: Free f => Free g => (f++g) a -> f a+projl fg = arr Left !# fg+{-# INLINE projl #-}++-- | Project onto the right-hand component of a direct sum.+--+projr :: Free f => Free g => (f++g) a -> g a+projr fg = arr Right !# fg+{-# INLINE projr #-}++-- | Left (post) composition with a linear transformation.+--+compl :: Free f1 => Free f2 => Free g => Tran a (Rep f1) (Rep f2) -> (f2**g) a -> (f1**g) a+compl t fg = first t !# fg++-- | Right (pre) composition with a linear transformation.+--+compr :: Free f => Free g1 => Free g2 => Tran a (Rep g1) (Rep g2) -> (f**g2) a -> (f**g1) a+compr t fg = second t !# fg++-- | Left and right composition with a linear transformation.+--+-- @ 'complr' f g = 'compl' f '>>>' 'compr' g @+--+complr :: Free f1 => Free f2 => Free g1 => Free g2 => Tran a (Rep f1) (Rep f2) -> Tran a (Rep g1) (Rep g2) -> (f2**g2) a -> (f1**g1) a+complr t1 t2 fg = t1 *** t2 !# fg++-------------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------------++instance Semiring a => Algebra a () where+  joined f = f ()++instance Semiring a => Unital a () where+  unital r () = r++instance (Algebra a b1, Algebra a b2) => Algebra a (b1, b2) where+  joined f (a,b) = joined (\a1 a2 -> joined (\b1 b2 -> f (a1,b1) (a2,b2)) b) a++instance (Unital a b1, Unital a b2) => Unital a (b1, b2) where+  unital r (a,b) = unital r a * unital r b++instance (Algebra a b1, Algebra a b2, Algebra a b3) => Algebra a (b1, b2, b3) where+  joined f (a,b,c) = joined (\a1 a2 -> joined (\b1 b2 -> joined (\c1 c2 -> f (a1,b1,c1) (a2,b2,c2)) c) b) a++instance (Unital a b1, Unital a b2, Unital a b3) => Unital a (b1, b2, b3) where+  unital r (a,b,c) = unital r a * unital r b * unital r c++-- | Tensor algebra on /b/.+--+-- >>> joined (<>) [1..3 :: Int]+-- [1,2,3,1,2,3,1,2,3,1,2,3]+--+-- >>> joined (\f g -> fold (f ++ g)) [1..3] :: Int+-- 24+--+instance Semiring a => Algebra a [b] where+  joined f = go [] where+    go ls rrs@(r:rs) = f (reverse ls) rrs + go (r:ls) rs+    go ls [] = f (reverse ls) []++instance Semiring a => Unital a [b] where+  unital a [] = a+  unital _ _ = zero++instance Semiring a => Algebra a (Seq b) where+  joined f = go Seq.empty where+    go ls s = case viewl s of+       EmptyL -> f ls s +       r :< rs -> f ls s + go (ls |> r) rs++instance Semiring a => Unital a (Seq b) where+  unital a b | Seq.null b = a+             | otherwise = zero++instance (Semiring a, Ord b) => Algebra a (Set.Set b) where+  joined f = go Set.empty where+    go ls s = case Set.minView s of+       Nothing -> f ls s+       Just (r, rs) -> f ls s + go (Set.insert r ls) rs++instance (Semiring a, Ord b) => Unital a (Set.Set b) where+  unital a b | Set.null b = a+           | otherwise = zero++instance Semiring a => Algebra a IntSet.IntSet where+  joined f = go IntSet.empty where+    go ls s = case IntSet.minView s of+       Nothing -> f ls s+       Just (r, rs) -> f ls s + go (IntSet.insert r ls) rs++instance Semiring a => Unital a IntSet.IntSet where+  unital a b | IntSet.null b = a+             | otherwise = zero++---------------------------------------------------------------------+-- Coalgebra instances+---------------------------------------------------------------------+++instance Semiring a => Coalgebra a () where+  cojoined = const++instance Semiring a => Counital a () where+  counital f = f ()+  coinitial = Tran $ \f _ -> f ()++instance (Coalgebra a c1, Coalgebra a c2) => Coalgebra a (c1, c2) where+  cojoined f (a1,b1) (a2,b2) = cojoined (\a -> cojoined (\b -> f (a,b)) b1 b2) a1 a2++instance (Counital a c1, Counital a c2) => Counital a (c1, c2) where+  counital k = counital $ \a -> counital $ \b -> k (a,b)++instance (Coalgebra a c1, Coalgebra a c2, Coalgebra a c3) => Coalgebra a (c1, c2, c3) where+  cojoined f (a1,b1,c1) (a2,b2,c2) = cojoined (\a -> cojoined (\b -> cojoined (\c -> f (a,b,c)) c1 c2) b1 b2) a1 a2++instance (Counital a c1, Counital a c2, Counital a c3) => Counital a (c1, c2, c3) where+  counital k = counital $ \a -> counital $ \b -> counital $ \c -> k (a,b,c)++instance Algebra a b => Coalgebra a (b -> a) where+  cojoined k f g = k (f * g)++instance Unital a b => Counital a (b -> a) where+  coinitial = Tran $ \f _ -> f one++-- | The tensor coalgebra on /c/.+--+instance Semiring a => Coalgebra a [c] where+  cojoined f as bs = f (mappend as bs)++instance Semiring a => Counital a [c] where+  coinitial = Tran $ \f _ -> f []++instance Semiring a => Coalgebra a (Seq c) where+  cojoined f as bs = f (mappend as bs)++instance Semiring a => Counital a (Seq c) where+  coinitial = Tran $ \f _ -> f Seq.empty++-- | The free commutative band coalgebra+instance (Semiring a, Ord c) => Coalgebra a (Set.Set c) where+  cojoined f as bs = f (Set.union as bs)++instance (Semiring a, Ord c) => Counital a (Set.Set c) where+  coinitial = Tran $ \f _ -> f Set.empty++-- | The free commutative band coalgebra over Int+instance Semiring a => Coalgebra a IntSet.IntSet where+  cojoined f as bs = f (IntSet.union as bs)++instance Semiring a => Counital a IntSet.IntSet where+  coinitial = Tran $ \f _ -> f IntSet.empty++{-+-- | The free commutative coalgebra over a set and a given semigroup+instance (Semiring r, Ord a, Additive b) => Coalgebra r (Map a b) where+  cojoined f as bs = f (Map.unionWith (+) as bs)+  counital k = k (Map.empty)++-- | The free commutative coalgebra over a set and Int+instance (Semiring r, Additive b) => Coalgebra r (IntMap b) where+  cojoined f as bs = f (IntMap.unionWith (+) as bs)+  counital k = k (IntMap.empty)+-}++---------------------------------------------------------------------+-- Bialgebra instances+---------------------------------------------------------------------++instance Semiring a => Bialgebra a () where+instance (Bialgebra a b1, Bialgebra a b2) => Bialgebra a (b1, b2) where+instance (Bialgebra a b1, Bialgebra a b2, Bialgebra a b3) => Bialgebra a (b1, b2, b3) where++instance Semiring a => Bialgebra a [b]+instance Semiring a => Bialgebra a (Seq b)+++-------------------------------------------------------------------------------+-- Tran instances+-------------------------------------------------------------------------------++addTran :: (Additive-Semigroup) a => Tran a b c -> Tran a b c -> Tran a b c+addTran (Tran f) (Tran g) = Tran $ f + g++subTran :: (Additive-Group) a => Tran a b c -> Tran a b c -> Tran a b c+subTran (Tran f) (Tran g) = Tran $ \h -> f h - g h++-- mulTran :: (Multiplicative-Semigroup) a => Tran a b c -> Tran a b c -> Tran a b c+-- mulTran (Tran f) (Tran g) = Tran $ \h -> f h * g h++instance Functor (Tran a b) where+  fmap f m = Tran $ \k -> m !# k . f++instance Applicative (Tran a b) where+  pure a = Tran $ \k _ -> k a+  mf <*> ma = Tran $ \k b -> (mf !# \f -> (ma !# k . f) b) b++instance Monad (Tran a b) where+  return a = Tran $ \k _ -> k a+  m >>= f = Tran $ \k b -> (m !# \a -> (f a !# k) b) b++instance Category (Tran a) where+  id = Tran id+  Tran f . Tran g = Tran $ g . f++instance Arrow (Tran a) where+  arr f = Tran (. f)+  first m = Tran $ \k (a,c) -> (m !# \b -> k (b,c)) a+  second m = Tran $ \k (c,a) -> (m !# \b -> k (c,b)) a+  m *** n = Tran $ \k (a,c) -> (m !# \b -> (n !# \d -> k (b,d)) c) a+  m &&& n = Tran $ \k a -> (m !# \b -> (n !# \c -> k (b,c)) a) a++instance ArrowChoice (Tran a) where+  left m = Tran $ \k -> either (m !# k . Left) (k . Right)+  right m = Tran $ \k -> either (k . Left) (m !# k . Right)+  m +++ n =  Tran $ \k -> either (m !# k . Left) (n !# k . Right)+  m ||| n = Tran $ \k -> either (m !# k) (n !# k)++instance ArrowApply (Tran a) where+  app = Tran $ \k (f,a) -> (f !# k) a++instance (Additive-Monoid) a => ArrowZero (Tran a) where+  zeroArrow = Tran zero++instance (Additive-Monoid) a => ArrowPlus (Tran a) where+  (<+>) = addTran++instance (Additive-Semigroup) a => Semigroup (Additive (Tran a b c)) where+  (<>) = liftA2 addTran++instance (Additive-Monoid) a => Monoid (Additive (Tran a b c)) where+  mempty = pure . Tran $ const zero++instance Coalgebra a c => Semigroup (Multiplicative (Tran a b c)) where+  (<>) = liftR2 $ \ f g -> Tran $ \k b -> (f !# \a -> (g !# cojoined k a) b) b++instance Counital a c => Monoid (Multiplicative (Tran a b c)) where+  mempty = pure . Tran $ \k _ -> counital k++instance Coalgebra a c => Presemiring (Tran a b c)+instance Counital a c => Semiring (Tran a b c)++instance Counital a m => LeftSemimodule (Tran a b m) (Tran a b m) where+  lscale = (*)++instance LeftSemimodule r s => LeftSemimodule r (Tran s b m) where+  lscale s (Tran m) = Tran $ \k b -> s *. m k b++instance Counital a m => RightSemimodule (Tran a b m) (Tran a b m) where+  rscale = (*)++instance RightSemimodule r s => RightSemimodule r (Tran s b m) where+  rscale s (Tran m) = Tran $ \k b -> m k b .* s++instance (Additive-Group) a => Magma (Additive (Tran a b c)) where+  (<<) = liftR2 subTran++instance (Additive-Group) a => Quasigroup (Additive (Tran a b c)) where+instance (Additive-Group) a => Loop (Additive (Tran a b c)) where+instance (Additive-Group) a => Group (Additive (Tran a b c)) where++instance (Ring a, Counital a c) => Ring (Tran a b c)++++{-++-- | An endomorphism of endomorphisms. +--+-- @ 'Cayley' a = (a -> a) -> (a -> a) @+--+type Cayley a = Tran a a a++-- | Lift a semiring element into a 'Cayley'.+--+-- @ 'runCayley' . 'cayley' = 'id' @+--+-- >>> runCayley . cayley $ 3.4 :: Double+-- 3.4+-- >>> runCayley . cayley $ m22 1 2 3 4 :: M22 Int+-- Compose (V2 (V2 1 2) (V2 3 4))+-- +cayley :: Semiring a => a -> Cayley a+cayley a = Tran $ \k b -> a * k zero + b++-- | Extract a semiring element from a 'Cayley'.+--+-- >>> runCayley $ two * (one + (cayley 3.4)) :: Double+-- 8.8+-- >>> runCayley $ two * (one + (cayley $ m22 1 2 3 4)) :: M22 Int+-- Compose (V2 (V2 4 4) (V2 6 10))+--+runCayley :: Semiring a => Cayley a -> a+runCayley (Tran f) = f (one +) zero++-- ring homomorphism from a -> a^b+--embed :: Counital a c => (b -> a) -> Tran a b c+embed f = Tran $ \k b -> f b * k one++-- if the characteristic of s does not divide the order of a, then s[a] is semisimple+-- and if a has a length function, we can build a filtered algebra++-- | The < https://en.wikipedia.org/wiki/Augmentation_(algebra) augmentation > ring homomorphism from a^b -> a+--+augment :: Semiring a => Tran a b c -> b -> a+augment m = m !# const one++++-}+++

@@ -9,9 +9,9 @@   , E4(..), e4, fillE4 ) where -import safe Data.Algebra import safe Data.Functor.Rep import safe Data.Semimodule+import safe Data.Semimodule.Algebra import safe Data.Semiring import safe Prelude hiding (Num(..), Fractional(..), negate, sum, product) import safe Control.Monad as M@@ -31,16 +31,16 @@ -- The squaring function /N(x) = x^2/ on the real number field forms the primordial composition algebra. -- instance Semiring r => Algebra r E1 where-  append = M.join+  joined = M.join  instance Semiring r => Unital r E1 where-  aempty = const+  unital = const  instance Semiring r => Coalgebra r E1 where-  coappend f E11 E11 = f E11+  cojoined f E11 E11 = f E11  instance Semiring r => Counital r E1 where-  coempty f = f E11+  coinitial = Tran $ \f _ -> f E11  instance Semiring r => Bialgebra r E1 @@ -58,18 +58,18 @@ fillE2 x y = tabulate $ e2 x y  instance Semiring r => Algebra r E2 where-  append = M.join+  joined = M.join  instance Semiring r => Unital r E2 where-  aempty = const+  unital = const  instance Semiring r => Coalgebra r E2 where-  coappend f E21 E21 = f E21-  coappend f E22 E22 = f E22-  coappend _ _ _ = zero+  cojoined f E21 E21 = f E21+  cojoined f E22 E22 = f E22+  cojoined _ _ _ = zero  instance Semiring r => Counital r E2 where-  coempty f = f E21 + f E22+  coinitial = Tran $ \f _ -> f E21 + f E22  instance Semiring r => Bialgebra r E2 @@ -88,19 +88,19 @@ fillE3 x y z = tabulate $ e3 x y z  instance Semiring r => Algebra r E3 where-  append = M.join+  joined = M.join  instance Semiring r => Unital r E3 where-  aempty = const+  unital = const  instance Semiring r => Coalgebra r E3 where-  coappend f E31 E31 = f E31-  coappend f E32 E32 = f E32-  coappend f E33 E33 = f E33-  coappend _ _ _ = zero+  cojoined f E31 E31 = f E31+  cojoined f E32 E32 = f E32+  cojoined f E33 E33 = f E33+  cojoined _ _ _ = zero  instance Semiring r => Counital r E3 where-  coempty f = f E31 + f E32 + f E33+  coinitial = Tran $ \f _ -> f E31 + f E32 + f E33  instance Semiring r => Bialgebra r E3 @@ -120,20 +120,20 @@ fillE4 x y z w = tabulate $ e4 x y z w  instance Semiring r => Algebra r E4 where-  append = M.join+  joined = M.join  instance Semiring r => Unital r E4 where-  aempty = const+  unital = const  instance Semiring r => Coalgebra r E4 where-  coappend f E41 E41 = f E41-  coappend f E42 E42 = f E42-  coappend f E43 E43 = f E43-  coappend f E44 E44 = f E44-  coappend _ _ _ = zero+  cojoined f E41 E41 = f E41+  cojoined f E42 E42 = f E42+  cojoined f E43 E43 = f E43+  cojoined f E44 E44 = f E44+  cojoined _ _ _ = zero  instance Semiring r => Counital r E4 where-  coempty f = f E41 + f E42 + f E43 + f E44+  coinitial = Tran $ \f _ -> f E41 + f E42 + f E43 + f E44  instance Semiring r => Bialgebra r E4 

@@ -0,0 +1,180 @@+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE Safe                       #-}+{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DefaultSignatures          #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE NoImplicitPrelude          #-}+{-# LANGUAGE RebindableSyntax           #-}+{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE RankNTypes                 #-}+++module Data.Semimodule.Dual (+  -- * Linear functionals+    Dual(..)+  , image'+  , (!*)+  , (*!)+  , toTran+  , fromTran +  -- * Common linear functionals +  , init+  , coinit+  , joined'+  , cojoined'+  , convolve'+) where++import safe Control.Applicative+import safe Data.Functor.Rep hiding (Co)+import safe Data.Foldable (foldl')+import safe Data.Semiring+import safe Data.Semimodule+import safe Data.Semimodule.Algebra+import safe Prelude hiding (Num(..), Fractional(..), init, negate, sum, product)+import safe Control.Monad (MonadPlus(..))++-------------------------------------------------------------------------------+-- Linear functionals+-------------------------------------------------------------------------------++infixr 3 `runDual`++-- | Linear functionals from elements of a free semimodule to a scalar.+--+-- @ +-- f '!*' (x '+' y) = (f '!*' x) '+' (f '!*' y)+-- f '!*' (x '.*' a) = a '*' (f '!*' x)+-- @+--+-- /Caution/: You must ensure these laws hold when using the default constructor.+--+newtype Dual a c = Dual { runDual :: (c -> a) -> a }++-- | Create a 'Dual' from a linear combination of basis vectors.+--+-- >>> image' [(2, E31),(3, E32)] !* V3 1 1 1 :: Int+-- 5+--+image' :: Semiring a => Foldable f => f (a, c) -> Dual a c+image' f = Dual $ \k -> foldl' (\acc (a, c) -> acc + a * k c) zero f ++-- | Obtain a linear transfrom from a linear functional.+--+toTran :: (b -> Dual a c) -> Tran a b c+toTran f = Tran $ \k b -> f b !* k++-- | Obtain a linear functional from a linear transform.+--+fromTran :: Tran a b c -> b -> Dual a c+fromTran m b = Dual $ \k -> (m !# k) b++infixr 3 !*++-- | Apply a linear functional to a vector.+--+(!*) :: Free f => Dual a (Rep f) -> f a -> a+(!*) f x = runDual f $ index x++infixl 3 *!++-- | Apply a linear functional to a vector.+--+(*!) :: Free f => f a -> Dual a (Rep f) -> a +(*!) = flip (!*)++-- | TODO: Document+--+init :: Unital a b => b -> Dual a ()+init = fromTran initial++-- | TODO: Document+--+coinit :: Counital a c => Dual a c+coinit = Dual counital++-- | TODO: Document+--+joined' :: Algebra a b => b -> Dual a (b,b)+joined' b = Dual $ \k -> joined (curry k) b++-- | TODO: Document+--+-- @+-- 'cojoined'' = 'curry' '$' 'fromTran' 'codiagonal'+-- @+--+cojoined' :: Coalgebra a c => c -> c -> Dual a c+cojoined' x y = Dual $ \k -> cojoined k x y ++-- | TODO: Document+--+convolve' :: Algebra a b => Coalgebra a c => (b -> Dual a c) -> (b -> Dual a c) -> b -> Dual a c+convolve' f g c = do+   (c1,c2) <- joined' c+   a1 <- f c1+   a2 <- g c2+   cojoined' a1 a2++-------------------------------------------------------------------------------+-- Dual instances+-------------------------------------------------------------------------------++instance Functor (Dual a) where+  fmap f m = Dual $ \k -> m `runDual` k . f++instance Applicative (Dual a) where+  pure a = Dual $ \k -> k a+  mf <*> ma = Dual $ \k -> mf `runDual` \f -> ma `runDual` k . f++instance Monad (Dual a) where+  return a = Dual $ \k -> k a+  m >>= f = Dual $ \k -> m `runDual` \a -> f a `runDual` k++instance (Additive-Monoid) a => Alternative (Dual a) where+  Dual m <|> Dual n = Dual $ m + n+  empty = Dual zero++instance (Additive-Monoid) a => MonadPlus (Dual a) where+  Dual m `mplus` Dual n = Dual $ m + n+  mzero = Dual zero++instance (Additive-Semigroup) a => Semigroup (Additive (Dual a b)) where+  (<>) = liftA2 $ \(Dual m) (Dual n) -> Dual $ m + n++instance (Additive-Monoid) a => Monoid (Additive (Dual a b)) where+  mempty = Additive $ Dual zero++instance Coalgebra a b => Semigroup (Multiplicative (Dual a b)) where+  (<>) = liftA2 $ \(Dual f) (Dual g) -> Dual $ \k -> f (\m -> g (cojoined k m))++instance Counital a b => Monoid (Multiplicative (Dual a b)) where+  mempty = Multiplicative $ Dual counital++instance Coalgebra a b => Presemiring (Dual a b)++instance Counital a b => Semiring (Dual a b)++instance (Additive-Group) a => Magma (Additive (Dual a b)) where+  (<<) = liftA2 $ \(Dual m) (Dual n) -> Dual $ m - n++instance (Additive-Group) a => Quasigroup (Additive (Dual a b)) where+instance (Additive-Group) a => Loop (Additive (Dual a b)) where+instance (Additive-Group) a => Group (Additive (Dual a b)) where++instance (Ring a, Counital a b) => Ring (Dual a b)++instance Counital r m => LeftSemimodule (Dual r m) (Dual r m) where+  lscale = (*)++instance LeftSemimodule r s => LeftSemimodule r (Dual s m) where+  lscale s m = Dual $ \k -> s *. runDual m k++instance Counital r m => RightSemimodule (Dual r m) (Dual r m) where+  rscale = (*)++instance RightSemimodule r s => RightSemimodule r (Dual s m) where+  rscale s m = Dual $ \k -> runDual m k .* s

@@ -14,64 +14,13 @@ {-# LANGUAGE RankNTypes               #-}  module Data.Semimodule.Free (-  -- * Types-    type Free-  , type Basis-  , type Basis2-  , type Basis3-  -- * Vector arithmetic-  , (.*)-  , (!*)-  , (.#)-  , (!#)-  , (*.)-  , (*!)-  , (#.)-  , (#!)-  , dual-  , inner-  , lerp-  , quadrance-  , cross-  , triple-  -- * Vector accessors and constructors-  , dirac-  , idx-  , elt-  , lensRep-  , grateRep-  -- * Matrix arithmetic-  , (.#.)-  , (!#!)-  , trace-  , transpose-  , inv1-  , inv2-  , bdet2-  , det2-  , bdet3-  , det3-  , inv3-  , bdet4-  , det4-  , inv4-  -- * Matrix accessors and constructors-  , tran-  , elt2-  , row-  , rows-  , col-  , cols-  , diag-  , codiag-  , outer-  , scalar-  , identity   -- * Vector types-  , V1(..)+    V1(..)   , unV1   , V2(..)   , V3(..)+  , cross+  , triple   , V4(..)   -- * Matrix types   , type M11@@ -106,6 +55,17 @@   , m42   , m43   , m44+  -- * Matrix determinants & inverses+  , inv1+  , inv2+  , bdet2+  , det2+  , bdet3+  , det3+  , inv3+  , bdet4+  , det4+  , inv4 ) where  import safe Control.Applicative@@ -118,16 +78,27 @@ import safe Data.Semigroup.Foldable as Foldable1 import safe Data.Semimodule import safe Data.Semimodule.Basis-import safe Data.Semimodule.Transform+import safe Data.Semimodule.Operator import safe Data.Semiring import safe Prelude hiding (Num(..), Fractional(..), negate, sum, product) import safe Prelude (fromInteger)   ---------------------------------------------------------------------------------- Vector Arithmetic+-- Vectors ------------------------------------------------------------------------------- +unV1 :: V1 a -> a+unV1 (V1 a) = a++newtype V1 a = V1 a deriving (Eq,Ord,Show)++data V2 a = V2 !a !a deriving (Eq,Ord,Show)++data V3 a = V3 !a !a !a deriving (Eq,Ord,Show)++data V4 a = V4 !a !a !a !a deriving (Eq,Ord,Show)+ -- | Cross product. -- -- @ @@ -160,53 +131,205 @@ triple x y z = inner x (cross y z) {-# INLINE triple #-} + ---------------------------------------------------------------------------------- Vector Constructors & Acessors+-- Matrices ------------------------------------------------------------------------------- --- | Dirac delta function.+-- All matrices use row-major representation.++-- | A 1x1 matrix.+type M11 = Compose V1 V1++-- | A 1x2 matrix.+type M12 = Compose V1 V2++-- | A 1x3 matrix.+type M13 = Compose V1 V3++-- | A 1x4 matrix.+type M14 = Compose V1 V4++-- | A 2x1 matrix.+type M21 = Compose V2 V1++-- | A 3x1 matrix.+type M31 = Compose V3 V1++-- | A 4x1 matrix.+type M41 = Compose V4 V1++-- | A 2x2 matrix.+type M22 = Compose V2 V2++-- | A 2x3 matrix.+type M23 = Compose V2 V3++-- | A 2x4 matrix.+type M24 = Compose V2 V4++-- | A 3x2 matrix.+type M32 = Compose V3 V2++-- | A 3x3 matrix.+type M33 = Compose V3 V3++-- | A 3x4 matrix.+type M34 = Compose V3 V4++-- | A 4x2 matrix.+type M42 = Compose V4 V2++-- | A 4x3 matrix.+type M43 = Compose V4 V3++-- | A 4x4 matrix.+type M44 = Compose V4 V4++-------------------------------------------------------------------------------+-- Matrix constructors+-------------------------------------------------------------------------------++-- | Construct a 1x1 matrix. ---dirac :: Eq i => Semiring a => i -> i -> a-dirac i j = bool zero one (i == j)-{-# INLINE dirac #-}+-- >>> m11 1 :: M11 Int+-- Compose (V1 (V1 1))+--+m11 :: a -> M11 a+m11 a = Compose $ V1 (V1 a)+{-# INLINE m11 #-} --- | Create a unit vector at an index.+-- | Construct a 1x2 matrix. ----- >>> idx E21 :: V2 Int--- V2 1 0+-- >>> m12 1 2 :: M12 Int+-- Compose (V1 (V2 1 2)) ----- >>> idx E42 :: V4 Int--- V4 0 1 0 0+m12 :: a -> a -> M12 a+m12 a b = Compose $ V1 (V2 a b)+{-# INLINE m12 #-}++-- | Construct a 1x3 matrix. ---idx :: Semiring a => Basis b f => b -> f a-idx i = tabulate $ dirac i-{-# INLINE idx #-}+-- >>> m13 1 2 3 :: M13 Int+-- Compose (V1 (V3 1 2 3))+--+m13 :: a -> a -> a -> M13 a+m13 a b c = Compose $ V1 (V3 a b c)+{-# INLINE m13 #-} --- | Retrieve an element of a vector.+-- | Construct a 1x4 matrix. ----- >>> elt E21 (V2 1 2)--- 1+-- >>> m14 1 2 3 4 :: M14 Int+-- Compose (V1 (V4 1 2 3 4)) ---elt :: Basis b f => b -> f a -> a-elt = flip index-{-# INLINE elt #-}+m14 :: a -> a -> a -> a -> M14 a+m14 a b c d = Compose $ V1 (V4 a b c d)+{-# INLINE m14 #-} --- | Create a lens from a representable functor.+-- | Construct a 2x1 matrix. ---lensRep :: Basis b f => b -> forall g. Functor g => (a -> g a) -> f a -> g (f a) -lensRep i f s = setter s <$> f (getter s)-  where getter = flip index i-        setter s' b = tabulate $ \j -> bool (index s' j) b (i == j)-{-# INLINE lensRep #-}+-- >>> m21 1 2 :: M21 Int+-- Compose (V2 (V1 1) (V1 2))+--+m21 :: a -> a -> M21 a+m21 a b = Compose $ V2 (V1 a) (V1 b)+{-# INLINE m21 #-} --- | Create an indexed grate from a representable functor.+-- | Construct a 3x1 matrix. ---grateRep :: Basis b f => forall g. Functor g => (b -> g a1 -> a2) -> g (f a1) -> f a2-grateRep iab s = tabulate $ \i -> iab i (fmap (`index` i) s)-{-# INLINE grateRep #-}+-- >>> m31 1 2 3 :: M31 Int+-- Compose (V3 (V1 1) (V1 2) (V1 3))+--+m31 :: a -> a -> a -> M31 a+m31 a b c = Compose $ V3 (V1 a) (V1 b) (V1 c)+{-# INLINE m31 #-} +-- | Construct a 4x1 matrix.+--+-- >>> m41 1 2 3 4 :: M41 Int+-- Compose (V4 (V1 1) (V1 2) (V1 3) (V1 4))+--+m41 :: a -> a -> a -> a -> M41 a+m41 a b c d = Compose $ V4 (V1 a) (V1 b) (V1 c) (V1 d)+{-# INLINE m41 #-}++-- | Construct a 2x2 matrix.+--+-- Arguments are in row-major order.+--+-- >>> m22 1 2 3 4 :: M22 Int+-- Compose (V2 (V2 1 2) (V2 3 4))+--+m22 :: a -> a -> a -> a -> M22 a+m22 a b c d = Compose $ V2 (V2 a b) (V2 c d)+{-# INLINE m22 #-}++-- | Construct a 2x3 matrix.+--+-- Arguments are in row-major order.+--+m23 :: a -> a -> a -> a -> a -> a -> M23 a+m23 a b c d e f = Compose $ V2 (V3 a b c) (V3 d e f)+{-# INLINE m23 #-}++-- | Construct a 2x4 matrix.+--+-- Arguments are in row-major order.+--+m24 :: a -> a -> a -> a -> a -> a -> a -> a -> M24 a+m24 a b c d e f g h = Compose $ V2 (V4 a b c d) (V4 e f g h)+{-# INLINE m24 #-}++-- | Construct a 3x2 matrix.+--+-- Arguments are in row-major order.+--+m32 :: a -> a -> a -> a -> a -> a -> M32 a+m32 a b c d e f = Compose $ V3 (V2 a b) (V2 c d) (V2 e f)+{-# INLINE m32 #-}++-- | Construct a 3x3 matrix.+--+-- Arguments are in row-major order.+--+m33 :: a -> a -> a -> a -> a -> a -> a -> a -> a -> M33 a+m33 a b c d e f g h i = Compose $ V3 (V3 a b c) (V3 d e f) (V3 g h i)+{-# INLINE m33 #-}++-- | Construct a 3x4 matrix.+--+-- Arguments are in row-major order.+--+m34 :: a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> M34 a+m34 a b c d e f g h i j k l = Compose $ V3 (V4 a b c d) (V4 e f g h) (V4 i j k l)+{-# INLINE m34 #-}++-- | Construct a 4x2 matrix.+--+-- Arguments are in row-major order.+--+m42 :: a -> a -> a -> a -> a -> a -> a -> a -> M42 a+m42 a b c d e f g h = Compose $ V4 (V2 a b) (V2 c d) (V2 e f) (V2 g h)+{-# INLINE m42 #-}++-- | Construct a 4x3 matrix.+--+-- Arguments are in row-major order.+--+m43 :: a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> M43 a+m43 a b c d e f g h i j k l = Compose $ V4 (V3 a b c) (V3 d e f) (V3 g h i) (V3 j k l)+{-# INLINE m43 #-}++-- | Construct a 4x4 matrix.+--+-- Arguments are in row-major order.+--+m44 :: a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> M44 a+m44 a b c d e f g h i j k l m n o p = Compose $ V4 (V4 a b c d) (V4 e f g h) (V4 i j k l) (V4 m n o p)+{-# INLINE m44 #-}+ ---------------------------------------------------------------------------------- Matrix Arithmetic+-- Matrix determinants and inverses -------------------------------------------------------------------------------  -- | 1x1 matrix inverse over a field.@@ -460,221 +583,9 @@ {-# INLINE inv4 #-}  ---------------------------------------------------------------------------------- Matrix constructors and accessors------------------------------------------------------------------------------------ | Retrieve an element of a matrix.------ >>> elt2 E21 E21 $ m22 1 2 3 4--- 1----elt2 :: Basis2 b c f g => b -> c -> (f**g) a -> a-elt2 i j = elt i . col j-{-# INLINE elt2 #-}---- | Construct a 1x1 matrix.------ >>> m11 1 :: M11 Int--- Compose (V1 (V1 1))----m11 :: a -> M11 a-m11 a = Compose $ V1 (V1 a)-{-# INLINE m11 #-}---- | Construct a 1x2 matrix.------ >>> m12 1 2 :: M12 Int--- Compose (V1 (V2 1 2))----m12 :: a -> a -> M12 a-m12 a b = Compose $ V1 (V2 a b)-{-# INLINE m12 #-}---- | Construct a 1x3 matrix.------ >>> m13 1 2 3 :: M13 Int--- Compose (V1 (V3 1 2 3))----m13 :: a -> a -> a -> M13 a-m13 a b c = Compose $ V1 (V3 a b c)-{-# INLINE m13 #-}---- | Construct a 1x4 matrix.------ >>> m14 1 2 3 4 :: M14 Int--- Compose (V1 (V4 1 2 3 4))----m14 :: a -> a -> a -> a -> M14 a-m14 a b c d = Compose $ V1 (V4 a b c d)-{-# INLINE m14 #-}---- | Construct a 2x1 matrix.------ >>> m21 1 2 :: M21 Int--- Compose (V2 (V1 1) (V1 2))----m21 :: a -> a -> M21 a-m21 a b = Compose $ V2 (V1 a) (V1 b)-{-# INLINE m21 #-}---- | Construct a 3x1 matrix.------ >>> m31 1 2 3 :: M31 Int--- Compose (V3 (V1 1) (V1 2) (V1 3))----m31 :: a -> a -> a -> M31 a-m31 a b c = Compose $ V3 (V1 a) (V1 b) (V1 c)-{-# INLINE m31 #-}---- | Construct a 4x1 matrix.------ >>> m41 1 2 3 4 :: M41 Int--- Compose (V4 (V1 1) (V1 2) (V1 3) (V1 4))----m41 :: a -> a -> a -> a -> M41 a-m41 a b c d = Compose $ V4 (V1 a) (V1 b) (V1 c) (V1 d)-{-# INLINE m41 #-}---- | Construct a 2x2 matrix.------ Arguments are in row-major order.------ >>> m22 1 2 3 4 :: M22 Int--- Compose (V2 (V2 1 2) (V2 3 4))----m22 :: a -> a -> a -> a -> M22 a-m22 a b c d = Compose $ V2 (V2 a b) (V2 c d)-{-# INLINE m22 #-}---- | Construct a 2x3 matrix.------ Arguments are in row-major order.----m23 :: a -> a -> a -> a -> a -> a -> M23 a-m23 a b c d e f = Compose $ V2 (V3 a b c) (V3 d e f)-{-# INLINE m23 #-}---- | Construct a 2x4 matrix.------ Arguments are in row-major order.----m24 :: a -> a -> a -> a -> a -> a -> a -> a -> M24 a-m24 a b c d e f g h = Compose $ V2 (V4 a b c d) (V4 e f g h)-{-# INLINE m24 #-}---- | Construct a 3x2 matrix.------ Arguments are in row-major order.----m32 :: a -> a -> a -> a -> a -> a -> M32 a-m32 a b c d e f = Compose $ V3 (V2 a b) (V2 c d) (V2 e f)-{-# INLINE m32 #-}---- | Construct a 3x3 matrix.------ Arguments are in row-major order.----m33 :: a -> a -> a -> a -> a -> a -> a -> a -> a -> M33 a-m33 a b c d e f g h i = Compose $ V3 (V3 a b c) (V3 d e f) (V3 g h i)-{-# INLINE m33 #-}---- | Construct a 3x4 matrix.------ Arguments are in row-major order.----m34 :: a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> M34 a-m34 a b c d e f g h i j k l = Compose $ V3 (V4 a b c d) (V4 e f g h) (V4 i j k l)-{-# INLINE m34 #-}---- | Construct a 4x2 matrix.------ Arguments are in row-major order.----m42 :: a -> a -> a -> a -> a -> a -> a -> a -> M42 a-m42 a b c d e f g h = Compose $ V4 (V2 a b) (V2 c d) (V2 e f) (V2 g h)-{-# INLINE m42 #-}---- | Construct a 4x3 matrix.------ Arguments are in row-major order.----m43 :: a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> M43 a-m43 a b c d e f g h i j k l = Compose $ V4 (V3 a b c) (V3 d e f) (V3 g h i) (V3 j k l)-{-# INLINE m43 #-}---- | Construct a 4x4 matrix.------ Arguments are in row-major order.----m44 :: a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> M44 a-m44 a b c d e f g h i j k l m n o p = Compose $ V4 (V4 a b c d) (V4 e f g h) (V4 i j k l) (V4 m n o p)-{-# INLINE m44 #-}------------------------------------------------------------------------------------ Matrix types------------------------------------------------------------------------------------ All matrices use row-major representation.---- | A 1x1 matrix.-type M11 = Compose V1 V1---- | A 1x2 matrix.-type M12 = Compose V1 V2---- | A 1x3 matrix.-type M13 = Compose V1 V3---- | A 1x4 matrix.-type M14 = Compose V1 V4---- | A 2x1 matrix.-type M21 = Compose V2 V1---- | A 3x1 matrix.-type M31 = Compose V3 V1---- | A 4x1 matrix.-type M41 = Compose V4 V1---- | A 2x2 matrix.-type M22 = Compose V2 V2---- | A 2x3 matrix.-type M23 = Compose V2 V3---- | A 2x4 matrix.-type M24 = Compose V2 V4---- | A 3x2 matrix.-type M32 = Compose V3 V2---- | A 3x3 matrix.-type M33 = Compose V3 V3---- | A 3x4 matrix.-type M34 = Compose V3 V4---- | A 4x2 matrix.-type M42 = Compose V4 V2---- | A 4x3 matrix.-type M43 = Compose V4 V3---- | A 4x4 matrix.-type M44 = Compose V4 V4-------------------------------------------------------------------------------------- V1+-- V1 instances ------------------------------------------------------------------------------- -unV1 :: V1 a -> a-unV1 (V1 a) = a--newtype V1 a = V1 a deriving (Eq,Ord,Show)- instance Show1 V1 where   liftShowsPrec f _ d (V1 a) = showParen (d >= 10) $ showString "V1 " . f d a @@ -718,10 +629,9 @@   {-# INLINE index #-}  ---------------------------------------------------------------------------------- V2+-- V2 instances ------------------------------------------------------------------------------- -data V2 a = V2 !a !a deriving (Eq,Ord,Show)  instance Show1 V2 where   liftShowsPrec f _ d (V2 a b) = showsBinaryWith f f "V2" d a b@@ -760,12 +670,10 @@   {-# INLINE index #-}  ---------------------------------------------------------------------------------- V3+-- V3 instances -------------------------------------------------------------------------------  -data V3 a = V3 !a !a !a deriving (Eq,Ord,Show)- -- TODO add Prd1 and push instance downstream instance Eq1 V3 where   liftEq k (V3 a b c) (V3 d e f) = k a d && k b e && k c f@@ -808,13 +716,10 @@   index (V3 _ _ z) E33 = z   {-# INLINE index #-} -- ---------------------------------------------------------------------------------- V4+-- V4 instances ------------------------------------------------------------------------------- -data V4 a = V4 !a !a !a !a deriving (Eq,Ord,Show)  instance Show1 V4 where   liftShowsPrec f _ z (V4 a b c d) = showParen (z > 10) $

@@ -0,0 +1,299 @@+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE Safe                       #-}+{-# LANGUAGE PolyKinds                  #-}+{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DefaultSignatures          #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE NoImplicitPrelude          #-}+{-# LANGUAGE RebindableSyntax           #-}+{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE RankNTypes               #-}++module Data.Semimodule.Operator (+  -- * Types+    type Free+  , type Basis+  , type Basis2+  , type Basis3+  -- * Vector accessors and constructors+  , Dual(..)+  , dual+  , image'+  , dirac+  , idx+  , elt+  , lensRep+  , grateRep+  -- * Vector arithmetic+  , (.*)+  , (!*)+  , (.#)+  , (!#)+  , (*.)+  , (*!)+  , (#.)+  , (#!)+  , inner+  , outer+  , lerp+  , quadrance+  -- * Matrix accessors and constructors+  , Tran(..)+  , tran+  , image+  , elt2+  , row+  , rows+  , col+  , cols+  , diag+  , codiag+  , scalar+  , identity+  -- * Matrix arithmetic+  , (.#.)+  , (!#!)+  , trace+  , transpose+) where++import safe Control.Arrow+import safe Control.Applicative+import safe Data.Bool+import safe Data.Functor.Compose+import safe Data.Functor.Rep hiding (Co)+import safe Data.Semimodule+import safe Data.Semimodule.Algebra+import safe Data.Semimodule.Dual+import safe Data.Semiring+import safe Prelude hiding (Num(..), Fractional(..), negate, sum, product)+import safe qualified Control.Monad as M++-------------------------------------------------------------------------------+-- Vector constructors & acessors+-------------------------------------------------------------------------------++-- | Take the dual of a vector.+--+-- >>> dual (V2 3 4) !% V2 1 2 :: Int+-- 11+--+dual :: FreeCounital a f => f a -> Dual a (Rep f)+dual f = Dual $ \k -> f `inner` tabulate k++-- | Dirac delta function.+--+dirac :: Eq i => Semiring a => i -> i -> a+dirac i j = bool zero one (i == j)+{-# INLINE dirac #-}++-- | Create a unit vector at an index.+--+-- >>> idx E21 :: V2 Int+-- V2 1 0+--+-- >>> idx E42 :: V4 Int+-- V4 0 1 0 0+--+idx :: Semiring a => Basis b f => b -> f a+idx i = tabulate $ dirac i+{-# INLINE idx #-}++-- | Retrieve an element of a vector.+--+-- >>> elt E21 (V2 1 2)+-- 1+--+elt :: Basis b f => b -> f a -> a+elt = flip index+{-# INLINE elt #-}++-- | Create a lens from a representable functor.+--+lensRep :: Basis b f => b -> forall g. Functor g => (a -> g a) -> f a -> g (f a) +lensRep i f s = setter s <$> f (getter s)+  where getter = flip index i+        setter s' b = tabulate $ \j -> bool (index s' j) b (i == j)+{-# INLINE lensRep #-}++-- | Create an indexed grate from a representable functor.+--+grateRep :: Basis b f => forall g. Functor g => (b -> g a1 -> a2) -> g (f a1) -> f a2+grateRep iab s = tabulate $ \i -> iab i (fmap (`index` i) s)+{-# INLINE grateRep #-}+++-------------------------------------------------------------------------------+-- Vector operations+-------------------------------------------------------------------------------++infixr 7 .#++-- | Multiply a matrix on the right by a column vector.+--+-- @ ('.#') = ('!#') . 'tran' @+--+-- >>> tran (m23 1 2 3 4 5 6) !# V3 7 8 9 :: V2 Int+-- V2 50 122+-- >>> m23 1 2 3 4 5 6 .# V3 7 8 9 :: V2 Int+-- V2 50 122+-- >>> m22 1 0 0 0 .# m23 1 2 3 4 5 6 .# V3 7 8 9 :: V2 Int+-- V2 50 0+--+(.#) :: Free f => FreeCounital a g => (f**g) a -> g a -> f a+x .# y = tabulate (\i -> row i x `inner` y)+{-# INLINE (.#) #-}++infixl 7 #.++-- | Multiply a matrix on the left by a row vector.+--+-- >>> V2 1 2 #. m23 3 4 5 6 7 8+-- V3 15 18 21+--+-- >>> V2 1 2 #. m23 3 4 5 6 7 8 #. m32 1 0 0 0 0 0 :: V2 Int+-- V2 15 0+--+(#.) :: FreeCounital a f => Free g => f a -> (f**g) a -> g a+x #. y = tabulate (\j -> x `inner` col j y)+{-# INLINE (#.) #-}++infix 6 `inner`++-- | Inner product.+--+-- This is a variant of 'Data.Semiring.xmult' restricted to free functors.+--+-- >>> V3 1 2 3 `inner` V3 1 2 3+-- 14+-- +inner :: FreeCounital a f => f a -> f a -> a+inner x y = counit $ liftR2 (*) x y+{-# INLINE inner #-}++-- | Outer product.+--+-- >>> V2 1 1 `outer` V2 1 1+-- Compose (V2 (V2 1 1) (V2 1 1))+--+outer :: Semiring a => Free f => Free g => f a -> g a -> (f**g) a+outer x y = Compose $ fmap (\z-> fmap (*z) y) x++-- | Squared /l2/ norm of a vector.+--+quadrance :: FreeCounital a f => f a -> a+quadrance = M.join inner +{-# INLINE quadrance #-}++-------------------------------------------------------------------------------+-- Matrix accessors and constructors+-------------------------------------------------------------------------------++-- | Lift a matrix into a linear transformation+--+-- @ ('.#') = ('!#') . 'tran' @+--+tran :: Free f => FreeCounital a g => (f**g) a -> Tran a (Rep f) (Rep g) +tran m = Tran $ \k -> index $ m .# tabulate k++-- | Retrieve an element of a matrix.+--+-- >>> elt2 E21 E21 $ m22 1 2 3 4+-- 1+--+elt2 :: Basis2 b c f g => b -> c -> (f**g) a -> a+elt2 i j = elt i . col j+{-# INLINE elt2 #-}++-- | Retrieve a row of a matrix.+--+-- >>> row E22 $ m23 1 2 3 4 5 6+-- V3 4 5 6+--+row :: Free f => Rep f -> (f**g) a -> g a+row i = flip index i . getCompose+{-# INLINE row #-}++-- | Obtain a matrix by stacking rows.+--+-- >>> rows (V2 1 2) :: M22 Int+-- V2 (V2 1 2) (V2 1 2)+--+rows :: Free f => Free g => g a -> (f**g) a+rows g = arr snd !# g+{-# INLINE rows #-}++-- | Retrieve a column of a matrix.+--+-- >>> elt E22 . col E31 $ m23 1 2 3 4 5 6+-- 4+--+col :: Free f => Free g => Rep g -> (f**g) a -> f a+col j = flip index j . distributeRep . getCompose+{-# INLINE col #-}++-- | Obtain a matrix by stacking columns.+--+-- >>> cols (V2 1 2) :: M22 Int+-- V2 (V2 1 1) (V2 2 2)+--+cols :: Free f => Free g => f a -> (f**g) a+cols f = arr fst !# f+{-# INLINE cols #-}++-- | Obtain a < https://en.wikipedia.org/wiki/Diagonal_matrix#Scalar_matrix scalar matrix > from a scalar.+--+-- >>> scalar 4.0 :: M22 Double+-- Compose (V2 (V2 4.0 0.0) (V2 0.0 4.0))+--+scalar :: FreeCoalgebra a f => a -> (f**f) a+scalar = codiag . pureRep++-- | Obtain an identity matrix.+--+-- >>> identity :: M33 Int+-- Compose (V3 (V3 1 0 0) (V3 0 1 0) (V3 0 0 1))+--+identity :: FreeCoalgebra a f => (f**f) a+identity = scalar one+{-# INLINE identity #-}++-------------------------------------------------------------------------------+-- Matrix operators+-------------------------------------------------------------------------------+++infixr 7 .#.++-- | Multiply two matrices.+--+-- >>> m22 1 2 3 4 .#. m22 1 2 3 4 :: M22 Int+-- Compose (V2 (V2 7 10) (V2 15 22))+-- +-- >>> m23 1 2 3 4 5 6 .#. m32 1 2 3 4 4 5 :: M22 Int+-- Compose (V2 (V2 19 25) (V2 43 58))+--+(.#.) :: Free f => FreeCounital a g => Free h => (f**g) a -> (g**h) a -> (f**h) a+(.#.) x y = tabulate (\(i,j) -> row i x `inner` col j y)+{-# INLINE (.#.) #-}++-- | Trace of an endomorphism.+--+-- >>> trace $ m22 1.0 2.0 3.0 4.0+-- 5.0+--+trace :: FreeBialgebra a f => (f**f) a -> a+trace = counit . diag++-- | Transpose a matrix.+--+-- >>> transpose $ m23 1 2 3 4 5 6 :: M32 Int+-- V3 (V2 1 4) (V2 2 5) (V2 3 6)+--+transpose :: Free f => Free g => (f**g) a -> (g**f) a+transpose fg = braid !# fg+{-# INLINE transpose #-}

@@ -1,743 +0,0 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE Safe                       #-}-{-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE DefaultSignatures          #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE NoImplicitPrelude          #-}-{-# LANGUAGE RebindableSyntax           #-}-{-# LANGUAGE TypeOperators              #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE RankNTypes                 #-}---module Data.Semimodule.Transform (-  -- * Types-    type (**) -  , type (++) -  -- * Linear functionals-  , Dual-  , dual-  , image'-  , (!*)-  , (*!)-  , toTran-  , fromTran -  -- * Linear transformations -  , Endo -  , Tran-  , arr-  , tran-  , image -  , (!#)-  , (#!)-  , (!#!)-  , dimap-  , invmap-  -- * Common linear functionals and transformations -  , init-  , init'-  , coinit-  , coinit'-  , braid-  , cobraid -  , join-  , join'-  , cojoin-  , cojoin'-  -- * Other operations on linear functionals and transformations-  , split-  , cosplit-  , convolve-  , convolve'-  , commutator-  -- * Matrix arithmetic-  , (.#)-  , (#.)-  , (.#.)-  , outer-  , inner-  , quadrance-  , trace-  , transpose-  -- * Matrix constructors and accessors-  , diag-  , codiag-  , scalar-  , identity-  , row-  , rows-  , col-  , cols-  , projl-  , projr-  , compl-  , compr-  , complr-  -- * Reexports-  , Representable(..)-) where--import safe Control.Arrow-import safe Control.Applicative-import safe Control.Category (Category, (>>>), (<<<))-import safe Data.Functor.Compose-import safe Data.Functor.Product-import safe Data.Functor.Rep hiding (Co)-import safe Data.Foldable (foldl')-import safe Data.Algebra-import safe Data.Semiring-import safe Data.Semimodule-import safe Data.Tuple (swap)-import safe Prelude hiding (Num(..), Fractional(..), init, negate, sum, product)-import safe Test.Logic hiding (join)-import safe qualified Control.Category as C-import safe qualified Control.Monad as M-import safe Control.Monad (MonadPlus(..))--infixr 2 **-infixr 1 ++---- | A tensor product of semimodule morphisms.----type (f ** g) = Compose f g---- | A direct sum of free semimodule elements.----type (f ++ g) = Product f g------------------------------------------------------------------------------------ Linear functionals----------------------------------------------------------------------------------infixr 3 `runDual`---- | Linear functionals from elements of a free semimodule to a scalar.------ @ --- f '!*' (x '+' y) = (f '!*' x) '+' (f '!*' y)--- f '!*' (x '.*' a) = a '*' (f '!*' x)--- @----newtype Dual a c = Dual { runDual :: (c -> a) -> a }---- | Take the dual of a vector.------ >>> dual (V2 3 4) !% V2 1 2 :: Int--- 11----dual :: FreeCounital a f => f a -> Dual a (Rep f)-dual f = Dual $ \k -> f `inner` tabulate k---- | Create a 'Dual' from a linear combination of basis vectors.------ >>> image' [(2, E31),(3, E32)] !* V3 1 1 1 :: Int--- 5----image' :: Semiring a => Foldable f => f (a, c) -> Dual a c-image' f = Dual $ \k -> foldl' (\acc (a, c) -> acc + a * k c) zero f ---- | Obtain a linear transfrom from a linear functional.----toTran :: (b -> Dual a c) -> Tran a b c-toTran f = Tran $ \k b -> f b !* k---- | Obtain a linear functional from a linear transform.----fromTran :: Tran a b c -> b -> Dual a c-fromTran m b = Dual $ \k -> (m !# k) b--infixr 3 !*---- | Apply a linear functional to a vector.----(!*) :: Free f => Dual a (Rep f) -> f a -> a-(!*) f x = runDual f $ index x--infixl 3 *!---- | Apply a linear functional to a vector.----(*!) :: Free f => f a -> Dual a (Rep f) -> a -(*!) = flip (!*)------------------------------------------------------------------------------------ General linear transformations------------------------------------------------------------------------------------ | An endomorphism over a free semimodule.------ >>> one + two !# V2 1 2 :: V2 Double--- V2 3.0 6.0----type Endo a b = Tran a b b---- | A linear transformation between free semimodules indexed with bases /b/ and /c/.------ > f '!#' x '+' y = (f '!#' x) + (f '!#' y)--- > f '!#' (r '.*' x) = r '.*' (f '!#' x)----newtype Tran a b c = Tran { runTran :: (c -> a) -> b -> a }---- | Lift a matrix into a linear transformation------ @ ('.#') = ('!#') . 'tran' @----tran :: Free f => FreeCounital a g => (f**g) a -> Tran a (Rep f) (Rep g) -tran m = Tran $ \k -> index $ m .# tabulate k---- | Create a 'Tran' from a linear combination of basis vectors.------ >>> image (e2 [(2, E31),(3, E32)] [(1, E33)]) !# V3 1 1 1 :: V2 Int--- V2 5 1----image :: Semiring a => (b -> [(a, c)]) -> Tran a b c-image f = Tran $ \k b -> sum [ a * k c | (a, c) <- f b ]--infixr 2 !#---- | Apply a transformation to a vector.----(!#) :: Free f => Free g => Tran a (Rep f) (Rep g) -> g a -> f a-(!#) t = tabulate . runTran t . index--infixl 2 #!---- | Apply a transformation to a vector.----(#!) :: Free f => Free g => g a -> Tran a (Rep f) (Rep g) -> f a-(#!) = flip (!#)--infix 2 !#!---- | Compose two transformations.----(!#!) :: Tran a c d -> Tran a b c -> Tran a b d-Tran f !#! Tran g = Tran $ g . f---- | 'Tran' is a profunctor in the category of semimodules.------ /Caution/: Arbitrary mapping functions may violate linearity.------ >>> dimap id (e3 True True False) (arr id) !# 4 :+ 5 :: V3 Int--- V3 5 5 4----dimap :: (b1 -> b2) -> (c1 -> c2) -> Tran a b2 c1 -> Tran a b1 c2-dimap l r f = arr r <<< f <<< arr l---- | 'Tran' is an invariant functor.------ See also < http://comonad.com/reader/2008/rotten-bananas/ >.----invmap :: (a1 -> a2) -> (a2 -> a1) -> Tran a1 b c -> Tran a2 b c-invmap f g (Tran t) = Tran $ \x -> t (x >>> g) >>> f------------------------------------------------------------------------------------ Common linear transformations----------------------------------------------------------------------------------{---prop_cojoin (~~) f = (cojoin !# f) ~~ (Compose . tabulate $ \i -> tabulate $ \j -> coappend (index f) i j)--prop_diag' (~~) f = (diag !# f) ~~ (Compose $ flip imapRep f $ \i x -> flip imapRep f $ \j _ -> bool zero x $ (i == j))--prop_diag (~~) f = (diag !# f) ~~ (flip bindRep id . getCompose $ f)--prop_codiag (~~) f = (codiag !# f) ~~ (tabulate $ append (index . index (getCompose f)))--}---- | TODO: Document----init :: Unital a b => Tran a b ()-init = Tran $ \k -> aempty $ k ()---- | TODO: Document----init' :: Unital a b => b -> Dual a ()-init' b = Dual $ \k -> aempty (k ()) b---- | TODO: Document----coinit :: Counital a c => Tran a () c-coinit = Tran $ \k () -> coempty k---- | TODO: Document----coinit' :: Counital a c => Dual a c-coinit' = Dual coempty---- | Swap components of a tensor product.----braid :: Tran a (b , c) (c , b)-braid = arr swap-{-# INLINE braid #-}---- | Swap components of a direct sum.----cobraid :: Tran a (b + c) (c + b)-cobraid = arr eswap-{-# INLINE cobraid #-}---- | TODO: Document----join :: Algebra a b => Tran a b (b,b)-join = Tran $ append . curry---- | TODO: Document----join' :: Algebra a b => b -> Dual a (b,b)-join' b = Dual $ \k -> append (curry k) b---- | TODO: Document----cojoin :: Coalgebra a c => Tran a (c,c) c-cojoin = Tran $ uncurry . coappend---- | TODO: Document----cojoin' :: Coalgebra a c => c -> c -> Dual a c-cojoin' x y = Dual $ \k -> coappend k x y ------------------------------------------------------------------------------------ General operations on covectors and transforms------------------------------------------------------------------------------------ | TODO: Document----split :: (b -> (b1 , b2)) -> Tran a b1 c -> Tran a b2 c -> Tran a b c-split f x y = dimap f fst $ x *** y-{-# INLINE split #-}---- | TODO: Document----cosplit :: ((c1 + c2) -> c) -> Tran a b c1 -> Tran a b c2 -> Tran a b c-cosplit f x y = dimap Left f $ x +++ y-{-# INLINE cosplit #-}--{--λ> foo = convolve (tran $ m22 1 0 0 1) (tran $ m22 1 0 0 1)-λ> foo !# V2 1 2 :: V2 Int-V2 1 2-λ> foo = convolve (tran $ m22 1 0 0 1) (tran $ m22 1 1 1 1)-λ> foo !# V2 1 2 :: V2 Int-V2 1 2-λ> foo = convolve (tran $ m22 1 1 1 1) (tran $ m22 1 1 1 1)-λ> foo !# V2 1 2 :: V2 Int-V2 3 3--}--- | Convolution with an associative algebra and coassociative coalgebra-------convolve :: Algebra a b => Coalgebra a c => Tran a b c -> Tran a b c -> Tran a b c-convolve f g = cojoin <<< (f *** g) <<< join---- | TODO: Document----convolve' :: Algebra a b => Coalgebra a c => (b -> Dual a c) -> (b -> Dual a c) -> b -> Dual a c-convolve' f g c = do-   (c1,c2) <- join' c-   a1 <- f c1-   a2 <- g c2-   cojoin' a1 a2---- | Commutator or Lie bracket of two semimodule endomorphisms.----commutator :: (Additive-Group) a => Endo a b -> Endo a b -> Endo a b-commutator x y = (x <<< y) `subTran` (y <<< x)------------------------------------------------------------------------------------ Vector and matrix arithmetic----------------------------------------------------------------------------------infixr 7 .#---- | Multiply a matrix on the right by a column vector.------ @ ('.#') = ('!#') . 'tran' @------ >>> tran (m23 1 2 3 4 5 6) !# V3 7 8 9 :: V2 Int--- V2 50 122--- >>> m23 1 2 3 4 5 6 .# V3 7 8 9 :: V2 Int--- V2 50 122--- >>> m22 1 0 0 0 .# m23 1 2 3 4 5 6 .# V3 7 8 9 :: V2 Int--- V2 50 0----(.#) :: Free f => FreeCounital a g => (f**g) a -> g a -> f a-x .# y = tabulate (\i -> row i x `inner` y)-{-# INLINE (.#) #-}--infixl 7 #.---- | Multiply a matrix on the left by a row vector.------ >>> V2 1 2 #. m23 3 4 5 6 7 8--- V3 15 18 21------ >>> V2 1 2 #. m23 3 4 5 6 7 8 #. m32 1 0 0 0 0 0 :: V2 Int--- V2 15 0----(#.) :: FreeCounital a f => Free g => f a -> (f**g) a -> g a-x #. y = tabulate (\j -> x `inner` col j y)-{-# INLINE (#.) #-}--infixr 7 .#.---- | Multiply two matrices.------ >>> m22 1 2 3 4 .#. m22 1 2 3 4 :: M22 Int--- Compose (V2 (V2 7 10) (V2 15 22))--- --- >>> m23 1 2 3 4 5 6 .#. m32 1 2 3 4 4 5 :: M22 Int--- Compose (V2 (V2 19 25) (V2 43 58))----(.#.) :: Free f => FreeCounital a g => Free h => (f**g) a -> (g**h) a -> (f**h) a-(.#.) x y = tabulate (\(i,j) -> row i x `inner` col j y)-{-# INLINE (.#.) #-}---- | Outer product.------ >>> V2 1 1 `outer` V2 1 1--- Compose (V2 (V2 1 1) (V2 1 1))----outer :: Semiring a => Free f => Free g => f a -> g a -> (f**g) a-outer x y = Compose $ fmap (\z-> fmap (*z) y) x--infix 6 `inner`---- | Inner product.------ This is a variant of 'Data.Semiring.xmult' restricted to free functors.------ >>> V3 1 2 3 `inner` V3 1 2 3--- 14--- -inner :: FreeCounital a f => f a -> f a -> a-inner x y = counital $ liftR2 (*) x y-{-# INLINE inner #-}---- | Squared /l2/ norm of a vector.----quadrance :: FreeCounital a f => f a -> a-quadrance = M.join inner -{-# INLINE quadrance #-}---- | Trace of an endomorphism.------ >>> trace $ m22 1.0 2.0 3.0 4.0--- 5.0----trace :: FreeBialgebra a f => (f**f) a -> a-trace = counital . codiag---- | Transpose a matrix.------ >>> transpose $ m23 1 2 3 4 5 6 :: M32 Int--- V3 (V2 1 4) (V2 2 5) (V2 3 6)----transpose :: Free f => Free g => (f**g) a -> (g**f) a-transpose fg = braid !# fg-{-# INLINE transpose #-}------------------------------------------------------------------------------------ Matrix constructors and accessors------------------------------------------------------------------------------------ | Obtain a < https://en.wikipedia.org/wiki/Diagonal_matrix diagonal matrix > from a vector.------ @ 'diag' = 'flip' 'bindRep' 'id' '.' 'getCompose' @----diag :: FreeCoalgebra a f => f a -> (f**f) a-diag f = cojoin !# f---- | Obtain the diagonal of a matrix as a vector.------ @ 'codiag' f = 'tabulate' $ 'append' ('index' . 'index' ('getCompose' f)) @------ >>> codiag $ m22 1.0 2.0 3.0 4.0--- V2 1.0 4.0----codiag :: FreeAlgebra a f => (f**f) a -> f a-codiag f = join !# f---- | Obtain a < https://en.wikipedia.org/wiki/Diagonal_matrix#Scalar_matrix scalar matrix > from a scalar.------ >>> scalar 4.0 :: M22 Double--- Compose (V2 (V2 4.0 0.0) (V2 0.0 4.0))----scalar :: FreeCoalgebra a f => a -> (f**f) a-scalar = diag . pureRep---- | Obtain an identity matrix.------ >>> identity :: M33 Int--- Compose (V3 (V3 1 0 0) (V3 0 1 0) (V3 0 0 1))----identity :: FreeCoalgebra a f => (f**f) a-identity = scalar one-{-# INLINE identity #-}---- | Retrieve a row of a matrix.------ >>> row E22 $ m23 1 2 3 4 5 6--- V3 4 5 6----row :: Free f => Rep f -> (f**g) a -> g a-row i = flip index i . getCompose-{-# INLINE row #-}---- | Obtain a matrix by stacking rows.------ >>> rows (V2 1 2) :: M22 Int--- V2 (V2 1 2) (V2 1 2)----rows :: Free f => Free g => g a -> (f**g) a-rows g = arr snd !# g-{-# INLINE rows #-}---- | Retrieve a column of a matrix.------ >>> elt E22 . col E31 $ m23 1 2 3 4 5 6--- 4----col :: Free f => Free g => Rep g -> (f**g) a -> f a-col j = flip index j . distributeRep . getCompose-{-# INLINE col #-}---- | Obtain a matrix by stacking columns.------ >>> cols (V2 1 2) :: M22 Int--- V2 (V2 1 1) (V2 2 2)----cols :: Free f => Free g => f a -> (f**g) a-cols f = arr fst !# f-{-# INLINE cols #-}---- | Project onto the left-hand component of a direct sum.----projl :: Free f => Free g => (f++g) a -> f a-projl fg = arr Left !# fg-{-# INLINE projl #-}---- | Project onto the right-hand component of a direct sum.----projr :: Free f => Free g => (f++g) a -> g a-projr fg = arr Right !# fg-{-# INLINE projr #-}---- | Left (post) composition with a linear transformation.----compl :: Free f1 => Free f2 => Free g => Tran a (Rep f1) (Rep f2) -> (f2**g) a -> (f1**g) a-compl t fg = first t !# fg---- | Right (pre) composition with a linear transformation.----compr :: Free f => Free g1 => Free g2 => Tran a (Rep g1) (Rep g2) -> (f**g2) a -> (f**g1) a-compr t fg = second t !# fg---- | Left and right composition with a linear transformation.------ @ 'complr' f g = 'compl' f '>>>' 'compr' g @----complr :: Free f1 => Free f2 => Free g1 => Free g2 => Tran a (Rep f1) (Rep f2) -> Tran a (Rep g1) (Rep g2) -> (f2**g2) a -> (f1**g1) a-complr t1 t2 fg = t1 *** t2 !# fg------------------------------------------------------------------------------------ Dual instances----------------------------------------------------------------------------------instance Functor (Dual a) where-  fmap f m = Dual $ \k -> m `runDual` k . f--instance Applicative (Dual a) where-  pure a = Dual $ \k -> k a-  mf <*> ma = Dual $ \k -> mf `runDual` \f -> ma `runDual` k . f--instance Monad (Dual a) where-  return a = Dual $ \k -> k a-  m >>= f = Dual $ \k -> m `runDual` \a -> f a `runDual` k--instance (Additive-Monoid) a => Alternative (Dual a) where-  Dual m <|> Dual n = Dual $ m + n-  empty = Dual zero--instance (Additive-Monoid) a => MonadPlus (Dual a) where-  Dual m `mplus` Dual n = Dual $ m + n-  mzero = Dual zero--instance (Additive-Semigroup) a => Semigroup (Additive (Dual a b)) where-  (<>) = liftA2 $ \(Dual m) (Dual n) -> Dual $ m + n--instance (Additive-Monoid) a => Monoid (Additive (Dual a b)) where-  mempty = Additive $ Dual zero--instance Coalgebra a b => Semigroup (Multiplicative (Dual a b)) where-  (<>) = liftA2 $ \(Dual f) (Dual g) -> Dual $ \k -> f (\m -> g (coappend k m))--instance Counital a b => Monoid (Multiplicative (Dual a b)) where-  mempty = Multiplicative $ Dual coempty--instance Coalgebra a b => Presemiring (Dual a b)--instance Counital a b => Semiring (Dual a b)--instance (Additive-Group) a => Magma (Additive (Dual a b)) where-  (<<) = liftA2 $ \(Dual m) (Dual n) -> Dual $ m - n--instance (Additive-Group) a => Quasigroup (Additive (Dual a b)) where-instance (Additive-Group) a => Loop (Additive (Dual a b)) where-instance (Additive-Group) a => Group (Additive (Dual a b)) where--instance (Ring a, Counital a b) => Ring (Dual a b)--instance Counital r m => LeftSemimodule (Dual r m) (Dual r m) where-  lscale = (*)--instance LeftSemimodule r s => LeftSemimodule r (Dual s m) where-  lscale s m = Dual $ \k -> s *. runDual m k--instance Counital r m => RightSemimodule (Dual r m) (Dual r m) where-  rscale = (*)--instance RightSemimodule r s => RightSemimodule r (Dual s m) where-  rscale s m = Dual $ \k -> runDual m k .* s------------------------------------------------------------------------------------- Trans instances----------------------------------------------------------------------------------addTran :: (Additive-Semigroup) a => Tran a b c -> Tran a b c -> Tran a b c-addTran (Tran f) (Tran g) = Tran $ f + g--subTran :: (Additive-Group) a => Tran a b c -> Tran a b c -> Tran a b c-subTran (Tran f) (Tran g) = Tran $ \h -> f h - g h---- mulTran :: (Multiplicative-Semigroup) a => Tran a b c -> Tran a b c -> Tran a b c--- mulTran (Tran f) (Tran g) = Tran $ \h -> f h * g h--instance Functor (Tran a b) where-  fmap f m = Tran $ \k -> m !# k . f--instance Applicative (Tran a b) where-  pure a = Tran $ \k _ -> k a-  mf <*> ma = Tran $ \k b -> (mf !# \f -> (ma !# k . f) b) b--instance Monad (Tran a b) where-  return a = Tran $ \k _ -> k a-  m >>= f = Tran $ \k b -> (m !# \a -> (f a !# k) b) b--instance Category (Tran a) where-  id = Tran id-  (.) = (!#!)--instance Arrow (Tran a) where-  arr f = Tran (. f)-  first m = Tran $ \k (a,c) -> (m !# \b -> k (b,c)) a-  second m = Tran $ \k (c,a) -> (m !# \b -> k (c,b)) a-  m *** n = Tran $ \k (a,c) -> (m !# \b -> (n !# \d -> k (b,d)) c) a-  m &&& n = Tran $ \k a -> (m !# \b -> (n !# \c -> k (b,c)) a) a--instance ArrowChoice (Tran a) where-  left m = Tran $ \k -> either (m !# k . Left) (k . Right)-  right m = Tran $ \k -> either (k . Left) (m !# k . Right)-  m +++ n =  Tran $ \k -> either (m !# k . Left) (n !# k . Right)-  m ||| n = Tran $ \k -> either (m !# k) (n !# k)--instance ArrowApply (Tran a) where-  app = Tran $ \k (f,a) -> (f !# k) a--instance (Additive-Monoid) a => ArrowZero (Tran a) where-  zeroArrow = Tran zero--instance (Additive-Monoid) a => ArrowPlus (Tran a) where-  (<+>) = addTran--instance (Additive-Semigroup) a => Semigroup (Additive (Tran a b c)) where-  (<>) = liftA2 addTran--instance (Additive-Monoid) a => Monoid (Additive (Tran a b c)) where-  mempty = pure . Tran $ const zero--instance Coalgebra a c => Semigroup (Multiplicative (Tran a b c)) where-  (<>) = liftR2 $ \ f g -> Tran $ \k b -> (f !# \a -> (g !# coappend k a) b) b--instance Counital a c => Monoid (Multiplicative (Tran a b c)) where-  mempty = pure . Tran $ \k _ -> coempty k--instance Coalgebra a c => Presemiring (Tran a b c)-instance Counital a c => Semiring (Tran a b c)--instance Counital a m => LeftSemimodule (Tran a b m) (Tran a b m) where-  lscale = (*)--instance LeftSemimodule r s => LeftSemimodule r (Tran s b m) where-  lscale s (Tran m) = Tran $ \k b -> s *. m k b--instance Counital a m => RightSemimodule (Tran a b m) (Tran a b m) where-  rscale = (*)--instance RightSemimodule r s => RightSemimodule r (Tran s b m) where-  rscale s (Tran m) = Tran $ \k b -> m k b .* s--instance (Additive-Group) a => Magma (Additive (Tran a b c)) where-  (<<) = liftR2 subTran--instance (Additive-Group) a => Quasigroup (Additive (Tran a b c)) where-instance (Additive-Group) a => Loop (Additive (Tran a b c)) where-instance (Additive-Group) a => Group (Additive (Tran a b c)) where--instance (Ring a, Counital a c) => Ring (Tran a b c)-----{----- | An endomorphism of endomorphisms. ------ @ 'Cayley' a = (a -> a) -> (a -> a) @----type Cayley a = Tran a a a---- | Lift a semiring element into a 'Cayley'.------ @ 'runCayley' . 'cayley' = 'id' @------ >>> runCayley . cayley $ 3.4 :: Double--- 3.4--- >>> runCayley . cayley $ m22 1 2 3 4 :: M22 Int--- Compose (V2 (V2 1 2) (V2 3 4))--- -cayley :: Semiring a => a -> Cayley a-cayley a = Tran $ \k b -> a * k zero + b---- | Extract a semiring element from a 'Cayley'.------ >>> runCayley $ two * (one + (cayley 3.4)) :: Double--- 8.8--- >>> runCayley $ two * (one + (cayley $ m22 1 2 3 4)) :: M22 Int--- Compose (V2 (V2 4 4) (V2 6 10))----runCayley :: Semiring a => Cayley a -> a-runCayley (Tran f) = f (one +) zero---- ring homomorphism from a -> a^b---embed :: Counital a c => (b -> a) -> Tran a b c-embed f = Tran $ \k b -> f b * k one---- if the characteristic of s does not divide the order of a, then s[a] is semisimple--- and if a has a length function, we can build a filtered algebra---- | The < https://en.wikipedia.org/wiki/Augmentation_(algebra) augmentation > ring homomorphism from a^b -> a----augment :: Semiring a => Tran a b c -> b -> a-augment m = m !# const one-----}---