diff --git a/rings.cabal b/rings.cabal --- a/rings.cabal +++ b/rings.cabal @@ -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 diff --git a/src/Data/Algebra.hs b/src/Data/Algebra.hs deleted file mode 100644 --- a/src/Data/Algebra.hs +++ /dev/null @@ -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) --} - - diff --git a/src/Data/Semimodule.hs b/src/Data/Semimodule.hs --- a/src/Data/Semimodule.hs +++ b/src/Data/Semimodule.hs @@ -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)) diff --git a/src/Data/Semimodule/Algebra.hs b/src/Data/Semimodule/Algebra.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semimodule/Algebra.hs @@ -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 + + + +-} + + + diff --git a/src/Data/Semimodule/Basis.hs b/src/Data/Semimodule/Basis.hs --- a/src/Data/Semimodule/Basis.hs +++ b/src/Data/Semimodule/Basis.hs @@ -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 diff --git a/src/Data/Semimodule/Dual.hs b/src/Data/Semimodule/Dual.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semimodule/Dual.hs @@ -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 diff --git a/src/Data/Semimodule/Free.hs b/src/Data/Semimodule/Free.hs --- a/src/Data/Semimodule/Free.hs +++ b/src/Data/Semimodule/Free.hs @@ -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) $ diff --git a/src/Data/Semimodule/Operator.hs b/src/Data/Semimodule/Operator.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semimodule/Operator.hs @@ -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 #-} diff --git a/src/Data/Semimodule/Transform.hs b/src/Data/Semimodule/Transform.hs deleted file mode 100644 --- a/src/Data/Semimodule/Transform.hs +++ /dev/null @@ -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 - - - --} - - -