packages feed

rings 0.1.1 → 0.1.1.1

raw patch · 11 files changed

+1266/−448 lines, 11 filesdep −profunctorsdep ~semigroupoids

Dependencies removed: profunctors

Dependency ranges changed: semigroupoids

Files

rings.cabal view
@@ -1,7 +1,7 @@ name:                rings-version:             0.1.1+version:             0.1.1.1 synopsis:            Ring-like objects.-description:         Semirings, rings, division rings, and modules.+description:         Semirings, rings, division rings, algebras, and modules. homepage:            https://github.com/cmk/rings license:             BSD3 license-file:        LICENSE@@ -14,19 +14,15 @@ extra-source-files:  ChangeLog.md cabal-version:       >=1.10 -flag development-    description:-        Enable `-Werror`-    default: False-    manual: True  library   hs-source-dirs:   src   default-language: Haskell2010-  ghc-options:      -Wall+  ghc-options:     -Wall    exposed-modules:-      Data.Semiring+      Data.Algebra+    , Data.Semiring     , Data.Semiring.Property     , Data.Semifield     , Data.Semigroup.Additive@@ -52,6 +48,5 @@     , adjunctions    >= 4.4   && < 5.0     , containers     >= 0.4.0 && < 1.0     , distributive   >= 0.3   && < 1.0-    , semigroupoids  >= 0.5   && < 1.0-    , profunctors    >= 5.0   && < 6.0+    , semigroupoids  >= 5.0   && < 6.0     , magmas         >= 0.0.1 && < 1.0
+ src/Data/Algebra.hs view
@@ -0,0 +1,309 @@+{-# 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)+-}++
src/Data/Semifield.hs view
@@ -13,11 +13,12 @@   -- * Semifields     type SemifieldLaw, Semifield   , anan, pinf-  , (/), (\\), (^^)+  , (/), (\\)   , recip   -- * Fields   , type FieldLaw, Field, Real   , ninf+  , (^^) ) where  import safe Data.Complex@@ -28,7 +29,7 @@ import safe Numeric.Natural import safe Foreign.C.Types (CFloat(..),CDouble(..)) -import Prelude (Monoid(..) , Float, Double)+import Prelude (Monoid(..), Integer, Float, Double, ($))  ------------------------------------------------------------------------------- -- Semifields@@ -50,7 +51,6 @@ --  class (Semiring a, SemifieldLaw a) => Semifield a - -- | The /NaN/ value of the semifield. -- -- @ 'anan' = 'zero' '/' 'zero' @@@ -88,6 +88,20 @@ ninf :: Field a => a ninf = negate one / zero {-# INLINE ninf #-}++infixr 8 ^^++-- | Integral power of a multiplicative group element.+--+-- @ 'one' '==' a '^^' 0 @+--+-- >>> 8 ^^ 0 :: Double+-- 1.0+-- >>> 8 ^^ 0 :: Pico+-- 1.000000000000+--+(^^) :: (Multiplicative-Group) a => a -> Integer -> a+a ^^ n = unMultiplicative $ greplicate n (Multiplicative a)  ------------------------------------------------------------------------------- -- Instances
src/Data/Semigroup/Additive.hs view
@@ -21,7 +21,7 @@ import safe Data.Distributive import safe Data.Functor.Rep import safe Data.Fixed-import safe Data.Group+import safe Data.Group hiding ((\\)) import safe Data.Int import safe Data.List.NonEmpty import safe Data.Ord@@ -47,22 +47,32 @@ -- | Hyphenation operator. type (g - f) a = f (g a) +-------------------------------------------------------------------------------+-- Additive+-------------------------------------------------------------------------------  -- | A commutative 'Semigroup' under '+'. newtype Additive a = Additive { unAdditive :: a } deriving (Eq, Generic, Ord, Show, Functor) +-- | Additive unit of a semiring.+-- zero :: (Additive-Monoid) a => a zero = unAdditive mempty {-# INLINE zero #-}  infixl 6 + +-- | Additive semigroup operation on a semiring.+-- -- >>> Dual [2] + Dual [3] :: Dual [Int] -- Dual {getDual = [3,2]}+-- (+) :: (Additive-Semigroup) a => a -> a -> a a + b = unAdditive (Additive a <> Additive b) {-# INLINE (+) #-} +-- | Subtract two elements.+-- subtract :: (Additive-Group) a => a -> a -> a subtract a b = unAdditive (Additive b << Additive a) {-# INLINE subtract #-}@@ -88,48 +98,26 @@ -------------------------------------------------------------------------------  --- | A (potentially non-commutative) 'Semigroup' under '+'.+-- | A (potentially non-commutative) 'Semigroup' under '*'. newtype Multiplicative a = Multiplicative { unMultiplicative :: a } deriving (Eq, Generic, Ord, Show, Functor) +-- | Multiplicative unit of a semiring.+-- one :: (Multiplicative-Monoid) a => a one = unMultiplicative mempty {-# INLINE one #-}  infixl 7 *, \\, / +-- | Multiplicative semigroup operation on a semiring.+-- -- >>> Dual [2] * Dual [3] :: Dual [Int] -- Dual {getDual = [5]}+-- (*) :: (Multiplicative-Semigroup) a => a -> a -> a a * b = unMultiplicative (Multiplicative a <> Multiplicative b) {-# INLINE (*) #-} -(/) :: (Multiplicative-Group) a => a -> a -> a-a / b = unMultiplicative (Multiplicative a << Multiplicative b)-{-# INLINE (/) #-}---- | Left division by a multiplicative group element.------ When '*' is commutative we must have:------ @ x '\\' y = y '/' x @----(\\) :: (Multiplicative-Group) a => a -> a -> a-(\\) x y = recip x * y--infixr 8 ^^---- | Integral power of a multiplicative group element.------ @ 'one' '==' a '^^' 0 @------ >>> 8 ^^ 0 :: Double--- 1.0--- >>> 8 ^^ 0 :: Pico--- 1.000000000000----(^^) :: (Multiplicative-Group) a => a -> Integer -> a-a ^^ n = unMultiplicative $ greplicate n (Multiplicative a)- -- | Reciprocal of a multiplicative group element. -- -- @ @@ -148,6 +136,21 @@ recip a = one / a {-# INLINE recip #-} +-- | Right division by a multiplicative group element.+--+(/) :: (Multiplicative-Group) a => a -> a -> a+a / b = unMultiplicative (Multiplicative a << Multiplicative b)+{-# INLINE (/) #-}++-- | Left division by a multiplicative group element.+--+-- When '*' is commutative we must have:+--+-- @ x '\\' y = y '/' x @+--+(\\) :: (Multiplicative-Group) a => a -> a -> a+(\\) x y = recip x * y+ instance Applicative Multiplicative where   pure = Multiplicative   Multiplicative f <*> Multiplicative a = Multiplicative (f a)@@ -401,6 +404,13 @@ instance (Additive-Semigroup) b => Semigroup (Additive (a -> b)) where   (<>) = liftA2 . liftA2 $ (+)   {-# INLINE (<>) #-}++instance (Additive-Group) b => Magma (Additive (a -> b)) where+  (<<) = liftA2 . liftA2 $ flip subtract ++instance (Additive-Group) b => Quasigroup (Additive (a -> b)) where+instance (Additive-Group) b => Loop (Additive (a -> b)) where+instance (Additive-Group) b => Group (Additive (a -> b)) where  instance (Additive-Monoid) b => Monoid (Additive (a -> b)) where   mempty = pure . pure $ zero
src/Data/Semigroup/Property.hs view
@@ -38,18 +38,18 @@  -- | \( \forall a, b, c \in R: (a + b) + c \sim a + (b + c) \) ----- All semigroups must right-associate addition.+-- A semigroup must right-associate addition. ----- This is a required property.+-- This is a required property for semigroups. -- associative_addition_on :: (Additive-Semigroup) r => Rel r b -> r -> r -> r -> b associative_addition_on (~~) = Prop.associative_on (~~) (+)   -- | \( \forall a, b, c \in R: (a * b) * c \sim a * (b * c) \) ----- All semigroups must right-associate multiplication.+-- A semigroup must right-associate multiplication. ----- This is a required property.+-- This is a required property for semigroups. -- associative_multiplication_on :: (Multiplicative-Semigroup) r => Rel r b -> r -> r -> r -> b associative_multiplication_on (~~) = Prop.associative_on (~~) (*) @@ -62,7 +62,7 @@ -- A semigroup with a right-neutral additive identity must satisfy: -- -- @--- 'neutral_addition' 'zero' = const True+-- 'neutral_addition_on' ('==') 'zero' r = 'True' -- @ --  -- Or, equivalently:@@ -81,7 +81,7 @@ -- A semigroup with a right-neutral multiplicative identity must satisfy: -- -- @--- 'neutral_multiplication' 'one' = const True+-- 'neutral_multiplication_on' ('==') 'one' r = 'True' -- @ --  -- Or, equivalently:@@ -90,7 +90,7 @@ -- 'one' '*' r = r -- @ ----- This is a required propert for multiplicative monoids.+-- This is a required property for multiplicative monoids. -- neutral_multiplication_on :: (Multiplicative-Monoid) r => Rel r b -> r -> b neutral_multiplication_on (~~) = Prop.neutral_on (~~) (*) one@@ -100,15 +100,14 @@  -- | \( \forall a, b \in R: a + b \sim b + a \) ----- This is a an /optional/ property for semigroups, and a /required/ property for semirings.+-- This is a an optional property for semigroups, and a required property for semirings. -- commutative_addition_on :: (Additive-Semigroup) r => Rel r b -> r -> r -> b commutative_addition_on (~~) = Prop.commutative_on (~~) (+)   -- | \( \forall a, b \in R: a * b \sim b * a \) ----- This is a an /optional/ property for semigroups, and a /optional/ property for semirings.--- It is a /required/ property for rings.+-- This is a an optional property for semigroups, and a optional property for semirings and rings. -- commutative_multiplication_on :: (Multiplicative-Semigroup) r => Rel r b -> r -> r -> b commutative_multiplication_on (~~) = Prop.commutative_on (~~) (*) @@ -139,10 +138,10 @@  -- | Idempotency property for additive semigroups. ----- @ 'idempotent_addition' = 'absorbative_addition' 'one' @---  -- See < https://en.wikipedia.org/wiki/Band_(mathematics) >. --+-- This is a an optional property for semigroups and semirings.+-- -- This is a required property for lattices. -- idempotent_addition_on :: (Additive-Semigroup) r => Rel r b -> r -> b@@ -150,13 +149,11 @@  -- | Idempotency property for multplicative semigroups. ----- @ 'idempotent_multiplication' = 'absorbative_multiplication' 'zero' @---  -- See < https://en.wikipedia.org/wiki/Band_(mathematics) >. ----- This is a an /optional/ property for semigroups, and a /optional/ property for semirings.+-- This is a an optional property for semigroups and semirings. ----- This is a /required/ property for lattices.+-- This is a required property for lattices. -- idempotent_multiplication_on :: (Multiplicative-Semigroup) r => Rel r b -> r -> b idempotent_multiplication_on (~~) r = (r * r) ~~ r@@ -164,41 +161,30 @@ ------------------------------------------------------------------------------------ -- Properties of semigroup morphisms +-- |+--+-- This is a required property for additive semigroup morphisms.+-- morphism_additive_on :: (Additive-Semigroup) r => (Additive-Semigroup) s => Rel s b -> (r -> s) -> r -> r -> b morphism_additive_on (~~) f x y = (f $ x + y) ~~ (f x + f y) +-- |+--+-- This is a required property for multiplicative semigroup morphisms.+-- morphism_multiplicative_on :: (Multiplicative-Semigroup) r => (Multiplicative-Semigroup) s => Rel s b -> (r -> s) -> r -> r -> b morphism_multiplicative_on (~~) f x y = (f $ x * y) ~~ (f x * f y) -morphism_additive_on' :: (Additive-Monoid) r => (Additive-Monoid) s => Rel s b -> (r -> s) -> b-morphism_additive_on' (~~) f = (f zero) ~~ zero--morphism_multiplicative_on' :: (Multiplicative-Monoid) r => (Multiplicative-Monoid) s => Rel s b -> (r -> s) -> b-morphism_multiplicative_on' (~~) f = (f one) ~~ one--{--morphism_additive_on :: (Additive-Semigroup) r => (Additive-Semigroup) s => Rel s b -> (r -> s) -> r -> r -> b-morphism_additive_on (~~) f x y = (f $ x `add` y) ~~ (f x `add` f y)--morphism_multiplicative_on :: (Multiplicative-Semigroup) r => (Multiplicative-Semigroup) s => Rel s b -> (r -> s) -> r -> r -> b-morphism_multiplicative_on (~~) f x y = (f $ x `mul` y) ~~ (f x `mul` f y)-+-- |+--+-- This is a required property for additive monoid morphisms.+-- morphism_additive_on' :: (Additive-Monoid) r => (Additive-Monoid) s => Rel s b -> (r -> s) -> b morphism_additive_on' (~~) f = (f zero) ~~ zero -morphism_multiplicative_on' :: (Multiplicative-Monoid) r => (Multiplicative-Monoid) s => Rel s b -> (r -> s) -> b-morphism_multiplicative_on' (~~) f = (f one) ~~ one----- | \( \forall a, b \in R: a * b \sim b * a \)+-- | ----- This is a an /optional/ property for semigroups, and a /optional/ property for semirings.--- It is a /required/ property for rings.+-- This is a required property for multiplicative monoid morphisms. ---commutative_multiplication_on :: (Multiplicative-Semigroup) r => Rel r b -> r -> r -> b-commutative_multiplication_on (~~) = Prop.commutative_on (~~) mul ---}---+morphism_multiplicative_on' :: (Multiplicative-Monoid) r => (Multiplicative-Monoid) s => Rel s b -> (r -> s) -> b+morphism_multiplicative_on' (~~) f = (f one) ~~ one
src/Data/Semimodule.hs view
@@ -22,38 +22,40 @@   -- * Left modules   , type LeftModule   , LeftSemimodule(..)-  , lscaleDef-  , negateDef-  , lerp   , (*.)   , (/.)   , (\.)+  , lerp+  , lscaleDef+  , negateDef   -- * Right modules   , type RightModule   , RightSemimodule(..)-  , rscaleDef   , (.*)   , (./)   , (.\)+  , rscaleDef   -- * Bimodules   , type Bimodule   , Bisemimodule(..) ) where  import safe Data.Complex-import safe Data.Semifield+import safe Data.Fixed import safe Data.Functor.Rep+import safe Data.Int+import safe Data.Semifield import safe Data.Semiring+import safe Data.Word+import safe Foreign.C.Types (CFloat(..),CDouble(..)) import safe GHC.Real hiding (Fractional(..)) import safe Numeric.Natural-import safe Prelude hiding (Num(..), Fractional(..), sum, product)- import safe Prelude (fromInteger)-+import safe Prelude hiding (Num(..), Fractional(..), sum, product) -type Free f = (Representable f, Eq (Rep f))+type Free f = (Representable f) -type Basis b f = (Free f, Rep f ~ b)+type Basis b f = (Free f, Rep f ~ b, Eq b)  type Basis2 b c f g = (Basis b f, Basis c g) @@ -92,16 +94,24 @@   --   lscale :: l -> a -> a --- | Default definition of 'lscale' for a free module.++infixr 7 *., \., /. ++-- | Left-multiply a module element by a scalar. ---lscaleDef :: Semiring a => Functor f => a -> f a -> f a-lscaleDef a f = (a *) <$> f+(*.) :: LeftSemimodule l a => l -> a -> a+(*.) = lscale --- | Default definition of '<<' for a commutative group.+-- | Right-divide a vector by a scalar (on the left). ---negateDef :: LeftModule Integer a => a -> a-negateDef a = (-1 :: Integer) *. a+(/.) :: Semifield a => Functor f => a -> f a -> f a+a /. f = (/ a) <$> f +-- | Left-divide a vector by a scalar.+--+(\.) :: Semifield a => Functor f => a -> f a -> f a+a \. f = (a \\)  <$> f+ -- | Linearly interpolate between two vectors. -- -- >>> u = V3 (1 :% 1) (2 :% 1) (3 :% 1) :: V3 Rational@@ -112,19 +122,16 @@ -- lerp :: LeftModule r a => r -> a -> a -> a lerp r f g = r *. f + (one - r) *. g-{-# INLINE lerp #-} -infixr 7 *., \., /. --(*.) :: LeftSemimodule l a => l -> a -> a-(*.) = lscale--(/.) :: Semifield a => Functor f => a -> f a -> f a-a /. f = (a /) <$> f--(\.) :: Semifield a => Functor f => a -> f a -> f a-a \. f = (a \\) <$> f+-- | Default definition of 'lscale' for a free module.+--+lscaleDef :: Semiring a => Functor f => a -> f a -> f a+lscaleDef a f = (a *) <$> f +-- | Default definition of '<<' for a commutative group.+--+negateDef :: LeftModule Integer a => a -> a+negateDef a = (-1 :: Integer) *. a  ------------------------------------------------------------------------------- -- Right modules@@ -144,21 +151,28 @@   --   rscale :: r -> a -> a --- | Default definition of 'rscale' for a free module.----rscaleDef :: Semiring a => Functor f => a -> f a -> f a-rscaleDef a f = (* a) <$> f+infixl 7 .*, .\, ./ -infixl 7 .*, .\, ./ +-- | Right-multiply a module element by a scalar.+-- (.*) :: RightSemimodule r a => a -> r -> a (.*) = flip rscale +-- | Right-divide a vector by a scalar.+-- (./) :: Semifield a => Functor f => f a -> a -> f a (./) = flip (/.) +-- | Left-divide a vector by a scalar (on the right).+-- (.\) :: Semifield a => Functor f => f a -> a -> f a (.\) = flip (\.) +-- | Default definition of 'rscale' for a free module.+--+rscaleDef :: Semiring a => Functor f => a -> f a -> f a+rscaleDef a f = (* a) <$> f+ ------------------------------------------------------------------------------- -- Bimodules -------------------------------------------------------------------------------@@ -173,6 +187,8 @@ -- class (LeftSemimodule l a, RightSemimodule r a) => Bisemimodule l r a where +  -- | Left and right-multiply by two scalars.+  --   discale :: l -> r -> a -> a   discale l r = lscale l . rscale r @@ -210,7 +226,6 @@ instance Ring a => LeftSemimodule (Complex a) (Complex a) where     lscale = (*)   -{- #define deriveLeftSemimodule(ty)                      \ instance LeftSemimodule ty ty where {                 \    lscale = (*)                                       \@@ -239,8 +254,13 @@ deriveLeftSemimodule(Double) deriveLeftSemimodule(CFloat) deriveLeftSemimodule(CDouble)--}+deriveLeftSemimodule((Ratio Integer))+deriveLeftSemimodule((Ratio Natural)) +-------------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------------+ instance Semiring r => RightSemimodule r () where    rscale _ = const () @@ -271,6 +291,37 @@ instance Ring a => RightSemimodule (Complex a) (Complex a) where    rscale = (*)  +#define deriveRightSemimodule(ty)                     \+instance RightSemimodule ty ty where {                \+   rscale = (*)                                       \+;  {-# INLINE rscale #-}                              \+}++deriveRightSemimodule(Bool)+deriveRightSemimodule(Int)+deriveRightSemimodule(Int8)+deriveRightSemimodule(Int16)+deriveRightSemimodule(Int32)+deriveRightSemimodule(Int64)+deriveRightSemimodule(Word)+deriveRightSemimodule(Word8)+deriveRightSemimodule(Word16)+deriveRightSemimodule(Word32)+deriveRightSemimodule(Word64)+deriveRightSemimodule(Uni)+deriveRightSemimodule(Deci)+deriveRightSemimodule(Centi)+deriveRightSemimodule(Milli)+deriveRightSemimodule(Micro)+deriveRightSemimodule(Nano)+deriveRightSemimodule(Pico)+deriveRightSemimodule(Float)+deriveRightSemimodule(Double)+deriveRightSemimodule(CFloat)+deriveRightSemimodule(CDouble)+deriveRightSemimodule((Ratio Integer))+deriveRightSemimodule((Ratio Natural))+ instance Semiring r => Bisemimodule r r ()  instance Bisemimodule r r a => Bisemimodule r r (e -> a)@@ -285,3 +336,31 @@  instance Ring a => Bisemimodule (Complex a) (Complex a) (Complex a) ++#define deriveBisemimodule(ty)                     \+instance Bisemimodule ty ty ty                        \++deriveBisemimodule(Bool)+deriveBisemimodule(Int)+deriveBisemimodule(Int8)+deriveBisemimodule(Int16)+deriveBisemimodule(Int32)+deriveBisemimodule(Int64)+deriveBisemimodule(Word)+deriveBisemimodule(Word8)+deriveBisemimodule(Word16)+deriveBisemimodule(Word32)+deriveBisemimodule(Word64)+deriveBisemimodule(Uni)+deriveBisemimodule(Deci)+deriveBisemimodule(Centi)+deriveBisemimodule(Milli)+deriveBisemimodule(Micro)+deriveBisemimodule(Nano)+deriveBisemimodule(Pico)+deriveBisemimodule(Float)+deriveBisemimodule(Double)+deriveBisemimodule(CFloat)+deriveBisemimodule(CDouble)+deriveBisemimodule((Ratio Integer))+deriveBisemimodule((Ratio Natural))
src/Data/Semimodule/Basis.hs view
@@ -7,20 +7,20 @@   , E2(..), e2, fillE2   , E3(..), e3, fillE3   , E4(..), e4, fillE4-  , E6(..) ) where +import safe Data.Algebra import safe Data.Functor.Rep import safe Data.Semimodule+import safe Data.Semiring import safe Prelude hiding (Num(..), Fractional(..), negate, sum, product)--+import safe Control.Monad as M  ------------------------------------------------------------------------------- -- Standard basis on one real dimension ------------------------------------------------------------------------------- -data E1 = E1 deriving (Eq, Ord, Show)+data E1 = E11 deriving (Eq, Ord, Show)  e1 :: a -> E1 -> a e1 = const@@ -28,6 +28,22 @@ fillE1 :: Basis E1 f => a -> f a fillE1 x = tabulate $ e1 x +-- 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++instance Semiring r => Unital r E1 where+  aempty = const++instance Semiring r => Coalgebra r E1 where+  coappend f E11 E11 = f E11++instance Semiring r => Counital r E1 where+  coempty f = f E11++instance Semiring r => Bialgebra r E1+ ------------------------------------------------------------------------------- -- Standard basis on two real dimensions -------------------------------------------------------------------------------@@ -41,6 +57,22 @@ fillE2 :: Basis E2 f => a -> a -> f a fillE2 x y = tabulate $ e2 x y +instance Semiring r => Algebra r E2 where+  append = M.join++instance Semiring r => Unital r E2 where+  aempty = const++instance Semiring r => Coalgebra r E2 where+  coappend f E21 E21 = f E21+  coappend f E22 E22 = f E22+  coappend _ _ _ = zero++instance Semiring r => Counital r E2 where+  coempty f = f E21 + f E22++instance Semiring r => Bialgebra r E2+ ------------------------------------------------------------------------------- -- Standard basis on three real dimensions  -------------------------------------------------------------------------------@@ -55,6 +87,23 @@ fillE3 :: Basis E3 f => a -> a -> a -> f a fillE3 x y z = tabulate $ e3 x y z +instance Semiring r => Algebra r E3 where+  append = M.join++instance Semiring r => Unital r E3 where+  aempty = 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++instance Semiring r => Counital r E3 where+  coempty f = f E31 + f E32 + f E33++instance Semiring r => Bialgebra r E3+ ------------------------------------------------------------------------------- -- Standard basis on four real dimensions -------------------------------------------------------------------------------@@ -70,6 +119,25 @@ fillE4 :: Basis E4 f => a -> a -> a -> a -> f a fillE4 x y z w = tabulate $ e4 x y z w +instance Semiring r => Algebra r E4 where+  append = M.join++instance Semiring r => Unital r E4 where+  aempty = 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++instance Semiring r => Counital r E4 where+  coempty f = f E41 + f E42 + f E43 + f E44++instance Semiring r => Bialgebra r E4++{- ------------------------------------------------------------------------------- -- Standard basis on five real dimensions -------------------------------------------------------------------------------@@ -81,3 +149,4 @@ -------------------------------------------------------------------------------  data E6 = E61 | E62 | E63 | E64 | E65 | E66 deriving (Eq, Ord, Show)+-}
src/Data/Semimodule/Free.hs view
@@ -21,13 +21,17 @@   , type Basis3   -- * Vector arithmetic   , (.*)+  , (!*)   , (.#)+  , (!#)   , (*.)+  , (*!)   , (#.)-  , dot+  , (#!)+  , dual+  , inner   , lerp   , quadrance-  , qd   , cross   , triple   -- * Vector accessors and constructors@@ -38,6 +42,7 @@   , grateRep   -- * Matrix arithmetic   , (.#.)+  , (!#!)   , trace   , transpose   , inv1@@ -58,9 +63,10 @@   , col   , cols   , diag+  , codiag   , outer+  , scalar   , identity-  , diagonal   -- * Vector types   , V1(..)   , unV1@@ -107,7 +113,7 @@ import safe Data.Distributive import safe Data.Functor.Classes import safe Data.Functor.Compose-import safe Data.Functor.Rep+import safe Data.Functor.Rep hiding (Co) import safe Data.Semifield import safe Data.Semigroup.Foldable as Foldable1 import safe Data.Semimodule@@ -117,67 +123,12 @@ import safe Prelude hiding (Num(..), Fractional(..), negate, sum, product) import safe Prelude (fromInteger) + ------------------------------------------------------------------------------- -- Vector Arithmetic ------------------------------------------------------------------------------- --infix 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 15 0----(#.) :: Semiring a => Foldable f => Basis2 b c f g => f a -> (f**g) a -> g a-x #. y = tabulate (\j -> x `dot` col j y)-{-# INLINE (#.) #-}---- | Multiply a matrix on the right by a column vector.------ @ ('.#') = 'app' . 'tran' @------ >>> app (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 50 0----(.#) :: Semiring a => Foldable g => Basis2 b c f g => (f**g) a -> g a -> f a-x .# y = tabulate (\i -> row i x `dot` y)-{-# INLINE (.#) #-}---infix 6 `dot`---- | Dot product.------ This is a variant of 'Data.Semiring.xmult' restricted to free functors.------ >>> V3 1 2 3 `dot` V3 1 2 3--- 14--- -dot :: Semiring a => Foldable f => Basis b f => f a -> f a -> a-dot x y = sum $ liftR2 (*) x y-{-# INLINE dot #-}---- | Squared /l2/ norm of a vector.----quadrance :: Semiring a => Foldable f => Basis b f => f a -> a-quadrance x = x `dot` x-{-# INLINE quadrance #-}---- | Squared /l2/ norm of the difference between two vectors.----qd :: FreeModule a f => Foldable f => f a -> f a -> a-qd x y = quadrance $ x - y-{-# INLINE qd #-}---- | Cross product+-- | Cross product. -- -- @  -- a `'cross'` a = 'zero'@@ -206,7 +157,7 @@ -- 1.0 -- triple :: Ring a => V3 a -> V3 a -> V3 a -> a-triple x y z = dot x (cross y z)+triple x y z = inner x (cross y z) {-# INLINE triple #-}  -------------------------------------------------------------------------------@@ -258,29 +209,6 @@ -- Matrix Arithmetic ------------------------------------------------------------------------------- -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))----(.#.) :: Semiring a => Foldable g => Basis3 b c d f g h => (f**g) a -> (g**h) a -> (f**h) a-(.#.) x y = tabulate (\(i,j) -> row i x `dot` col j y)-{-# INLINE (.#.) #-}---- | Compute the trace of a matrix.------ >>> trace $ m22 1.0 2.0 3.0 4.0--- 5.0----trace :: Semiring a => Foldable f => Basis b f => (f**f) a -> a-trace = sum . diagonal-{-# INLINE trace #-}- -- | 1x1 matrix inverse over a field. -- -- >>> inv1 $ m11 4.0 :: M11 Double@@ -535,13 +463,6 @@ -- Matrix constructors and accessors ------------------------------------------------------------------------------- --- | Lift a matrix into a linear transformation------ @ ('.#') = 'app' . 'tran' @----tran :: Semiring a => Basis2 b c f g => Foldable g => (f**g) a -> Tran a b c-tran m = Tran $ \f -> index $ m .# (tabulate f)- -- | Retrieve an element of a matrix. -- -- >>> elt2 E21 E21 $ m22 1 2 3 4@@ -551,59 +472,6 @@ 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 :: Basis b f => b -> (f**g) a -> g a-row i = elt i . getCompose-{-# INLINE row #-}---- | Retrieve a column of a matrix.------ >>> elt E22 . col E31 $ m23 1 2 3 4 5 6--- 4----col :: Basis2 b c f g => c -> (f**g) a -> f a-col j = elt j . distribute . getCompose-{-# INLINE col #-}---- | Obtain a diagonal matrix from a vector.------ >>> diag $ V2 2 3--- Compose (V2 (V2 2 0) (V2 0 3))----diag :: Semiring a => Basis b f => f a -> (f**f) a-diag f = Compose $ flip imapRep f $ \i x -> flip imapRep f (\j _ -> bool zero x $ i == j)-{-# INLINE diag #-}---- | Outer product of two vectors.------ >>> V2 1 1 `outer` V2 1 1--- Compose (V2 (V2 1 1) (V2 1 1))----outer :: Semiring a => Basis2 b c f g => f a -> g a -> (f**g) a-outer x y = Compose $ fmap (\z-> fmap (*z) y) x---- | Identity matrix.------ >>> identity :: M33 Int--- Compose (V3 (V3 1 0 0) (V3 0 1 0) (V3 0 0 1))----identity :: Semiring a => Basis b f => (f**f) a-identity = diag $ pureRep one-{-# INLINE identity #-}---- | Obtain the diagonal of a matrix as a vector.------ >>> diagonal $ m22 1.0 2.0 3.0 4.0--- V2 1.0 4.0----diagonal :: Representable f => (f**f) a -> f a-diagonal = flip bindRep id . getCompose-{-# INLINE diagonal #-}- -- | Construct a 1x1 matrix. -- -- >>> m11 1 :: M11 Int@@ -843,10 +711,10 @@  instance Representable V1 where   type Rep V1 = E1-  tabulate f = V1 (f E1)+  tabulate f = V1 (f E11)   {-# INLINE tabulate #-} -  index (V1 x) E1 = x+  index (V1 x) E11 = x   {-# INLINE index #-}  -------------------------------------------------------------------------------
src/Data/Semimodule/Transform.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE Safe                       #-} {-# LANGUAGE ConstraintKinds            #-} {-# LANGUAGE DefaultSignatures          #-}-{-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE DeriveGeneric              #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-}@@ -17,263 +16,728 @@   -- * Types     type (**)    , type (++) -  , type Dim-  , type Endo-  , Tran(..)-  , app+  -- * Linear functionals+  , Dual+  , dual+  , image'+  , (!*)+  , (*!)+  , toTran+  , fromTran +  -- * Linear transformations +  , Endo +  , Tran   , arr+  , tran+  , image +  , (!#)+  , (#!)+  , (!#!)+  , dimap   , invmap-  -- * Matrix combinators+  -- * 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-  , transpose-  -- * Dimensional combinators-  , braid-  , sbraid-  , first-  , second-  , left-  , right-  , (***)-  , (+++)-  , (&&&)-  , (|||)-  , ($$$)-  , adivide-  , adivide'-  , aselect-  , aselect'+  -- * Reexports+  , Representable(..) ) where -import safe Control.Category (Category, (>>>))+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-import safe Data.Profunctor+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(..), negate, sum, product)-import safe Test.Logic+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 Data.Bifunctor as B+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 --- | A dimensional (binary) relation between two bases.+-------------------------------------------------------------------------------+-- Linear functionals+-------------------------------------------------------------------------------++infixr 3 `runDual`++-- | Linear functionals from elements of a free semimodule to a scalar. ----- @ 'Dim' b c @ relations correspond to (compositions of) --- permutation, projection, and embedding transformations.+-- @ +-- f '!*' (x '+' y) = (f '!*' x) '+' (f '!*' y)+-- f '!*' (x '.*' a) = a '*' (f '!*' x)+-- @ ----- See also < https://en.wikipedia.org/wiki/Logical_matrix >.+newtype Dual a c = Dual { runDual :: (c -> a) -> a }++-- | Take the dual of a vector. ---type Dim b c = forall a . Tran a b c+-- >>> 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 morphism between free semimodules indexed with bases /b/ and /c/.+-- | A linear transformation between free semimodules indexed with bases /b/ and /c/. ---newtype Tran a b c = Tran { runTran :: (c -> a) -> (b -> a) } deriving Functor+-- > f '!#' x '+' y = (f '!#' x) + (f '!#' y)+-- > f '!#' (r '.*' x) = r '.*' (f '!#' x)+--+newtype Tran a b c = Tran { runTran :: (c -> a) -> b -> a } -instance Category (Tran a) where-  id = Tran id-  Tran f . Tran g = Tran $ g . f+-- | 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 -instance Profunctor (Tran a) where-  lmap f (Tran t) = Tran $ \ca -> t ca . f-  rmap = fmap+-- | 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. ---app :: Basis2 b c f g => Tran a b c -> g a -> f a-app t = tabulate . runTran t . index+(!#) :: Free f => Free g => Tran a (Rep f) (Rep g) -> g a -> f a+(!#) t = tabulate . runTran t . index --- | Lift a function on basis indices into a transformation.+infixl 2 #!++-- | Apply a transformation to a vector. ----- @ 'arr' f = 'rmap' f 'C.id' @+(#!) :: Free f => Free g => g a -> Tran a (Rep f) (Rep g) -> f a+(#!) = flip (!#)++infix 2 !#!++-- | Compose two transformations. ---arr :: (b -> c) -> Tran a b c-arr f = Tran (. f)+(!#!) :: Tran a c d -> Tran a b c -> Tran a b d+Tran f !#! Tran g = Tran $ g . f --- | /Tran a b c/ is an invariant functor on /a/.+-- | '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+------------------------------------------------------------------------------- --- | Obtain a matrix by stacking rows.+{-++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 ----- >>> rows (V2 1 2) :: M22 Int--- V2 (V2 1 2) (V2 1 2)+init :: Unital a b => Tran a b ()+init = Tran $ \k -> aempty $ k ()++-- | TODO: Document ---rows :: Basis2 b c f g => g a -> (f**g) a-rows = app $ arr snd-{-# INLINE rows #-}+init' :: Unital a b => b -> Dual a ()+init' b = Dual $ \k -> aempty (k ()) b --- | Obtain a matrix by stacking columns.+-- | TODO: Document ----- >>> cols (V2 1 2) :: M22 Int--- V2 (V2 1 1) (V2 2 2)+coinit :: Counital a c => Tran a () c+coinit = Tran $ \k () -> coempty k++-- | TODO: Document ---cols :: Basis2 b c f g => f a -> (f**g) a-cols = app $ arr fst-{-# INLINE cols #-}+coinit' :: Counital a c => Dual a c+coinit' = Dual coempty --- | Project onto the left-hand component of a direct sum.+-- | Swap components of a tensor product. ---projl :: Basis2 b c f g => (f++g) a -> f a-projl = app $ arr Left-{-# INLINE projl #-}+braid :: Tran a (b , c) (c , b)+braid = arr swap+{-# INLINE braid #-} --- | Project onto the right-hand component of a direct sum.+-- | Swap components of a direct sum. ---projr :: Basis2 b c f g => (f++g) a -> g a-projr = app $ arr Right-{-# INLINE projr #-}+cobraid :: Tran a (b + c) (c + b)+cobraid = arr eswap+{-# INLINE cobraid #-} --- | Left (post) composition with a linear transformation.+-- | TODO: Document ---compl :: Basis3 b c d f1 f2 g => Dim b c -> (f2**g) a -> (f1**g) a-compl f = app (first f)+join :: Algebra a b => Tran a b (b,b)+join = Tran $ append . curry --- | Right (pre) composition with a linear transformation.+-- | TODO: Document ---compr :: Basis3 b c d f g1 g2 => Dim c d -> (f**g2) a -> (f**g1) a-compr f = app (second f)+join' :: Algebra a b => b -> Dual a (b,b)+join' b = Dual $ \k -> append (curry k) b --- | Left and right composition with a linear transformation.+-- | TODO: Document ----- @ 'complr' f g = 'compl' f '>>>' 'compr' g @+cojoin :: Coalgebra a c => Tran a (c,c) c+cojoin = Tran $ uncurry . coappend++-- | TODO: Document ----- When /f . g = id/ this induces a similarity transformation:+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 ----- >>> perm1 = arr (+ E32)--- >>> perm2 = arr (+ E33)--- >>> m = m33 1 2 3 4 5 6 7 8 9 :: M33 Int--- >>> complr perm1 perm2 m :: M33 Int--- V3 (V3 5 6 4) (V3 8 9 7) (V3 2 3 1)+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 ----- See also < https://en.wikipedia.org/wiki/Matrix_similarity > & < https://en.wikipedia.org/wiki/Conjugacy_class >.+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 ---complr :: Basis2 b1 c1 f1 f2 => Basis2 b2 c2 g1 g2 => Dim b1 c1 -> Dim b2 c2 -> (f2**g2) a -> (f1**g1) a-complr f g = app (f *** g)+--+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 --- | Transpose a matrix.+-- | TODO: Document ----- >>> transpose (V3 (V2 1 2) (V2 3 4) (V2 5 6))--- V2 (V3 1 3 5) (V3 2 4 6)+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 :: Basis2 b c f g => (f**g) a -> (g**f) a-transpose = app braid+transpose :: Free f => Free g => (f**g) a -> (g**f) a+transpose fg = braid !# fg {-# INLINE transpose #-} ----------------------------------------------------------------------+-------------------------------------------------------------------------------+-- Matrix constructors and accessors+------------------------------------------------------------------------------- --- | Swap components of a tensor product.+-- | Obtain a < https://en.wikipedia.org/wiki/Diagonal_matrix diagonal matrix > from a vector. ---braid :: Dim (a , b) (b , a)-braid = arr swap-{-# INLINE braid #-}+-- @ 'diag' = 'flip' 'bindRep' 'id' '.' 'getCompose' @+--+diag :: FreeCoalgebra a f => f a -> (f**f) a+diag f = cojoin !# f --- | Swap components of a direct sum.+-- | Obtain the diagonal of a matrix as a vector. ---sbraid :: Dim (a + b) (b + a)-sbraid = arr eswap-{-# INLINE sbraid #-}+-- @ '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 --- | Lift a transform into a transform on tensor products.+-- | Obtain a < https://en.wikipedia.org/wiki/Diagonal_matrix#Scalar_matrix scalar matrix > from a scalar. ---first :: Dim b c -> Dim (b , d) (c , d)-first (Tran caba) = Tran $ \cda -> cda . B.first (caba id)+-- >>> 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 --- | Lift a transform into a transform on tensor products.+-- | Obtain an identity matrix. ---second :: Dim b c -> Dim (d , b) (d , c)-second (Tran caba) = Tran $ \cda -> cda . B.second (caba id)+-- >>> 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 #-} --- | Lift a transform into a transform on direct sums.+-- | Retrieve a row of a matrix. ---left :: Dim b c -> Dim (b + d) (c + d)-left (Tran caba) = Tran $ \cda -> cda . B.first (caba id)+-- >>> 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 #-} --- | Lift a transform into a transform on direct sums.+-- | Obtain a matrix by stacking rows. ---right :: Dim b c -> Dim (d + b) (d + c)-right (Tran caba) = Tran $ \cda -> cda . B.second (caba id)+-- >>> 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 #-} -infixr 3 ***+-- | 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 #-} --- | Create a transform on a tensor product of semimodules.+-- | Obtain a matrix by stacking columns. ---(***) :: Dim a1 b1 -> Dim a2 b2 -> Dim (a1 , a2) (b1 , b2)-x *** y = first x >>> arr swap >>> first y >>> arr swap-{-# INLINE (***) #-}+-- >>> 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 #-} -infixr 2 ++++-- | 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 #-} --- | Create a transform on a direct sum of semimodules.+-- | Project onto the right-hand component of a direct sum. ---(+++) :: Dim a1 b1 -> Dim a2 b2 -> Dim (a1 + a2) (b1 + b2)-x +++ y = left x >>> arr eswap >>> left y >>> arr eswap-{-# INLINE (+++) #-}+projr :: Free f => Free g => (f++g) a -> g a+projr fg = arr Right !# fg+{-# INLINE projr #-} -infixr 3 &&&+-- | 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 -(&&&) :: Dim a b1 -> Dim a b2 -> Dim a (b1 , b2)-x &&& y = dimap fork id $ x *** y-{-# INLINE (&&&) #-}+-- | 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 -infixr 2 |||+-- | 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 -(|||) :: Dim a1 b -> Dim a2 b -> Dim (a1 + a2) b-x ||| y = dimap id join $ x +++ y-{-# INLINE (|||) #-}+-------------------------------------------------------------------------------+-- Dual instances+------------------------------------------------------------------------------- -infixr 0 $$$+instance Functor (Dual a) where+  fmap f m = Dual $ \k -> m `runDual` k . f -($$$) :: Dim a (b -> c) -> Dim a b -> Dim a c-($$$) f x = dimap fork apply (f *** x)-{-# INLINE ($$$) #-}+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.  ----- @ 'adivide' 'fork' = 'C.id' @ +-- @ 'Cayley' a = (a -> a) -> (a -> a) @ ---adivide :: (a -> (a1 , a2)) -> Dim a1 b -> Dim a2 b -> Dim a b-adivide f x y = dimap f fst $ x *** y-{-# INLINE adivide #-}+type Cayley a = Tran a a a -adivide' :: Dim a1 b -> Dim a2 b -> Dim (a1 , a2) b-adivide' = adivide id-{-# INLINE adivide' #-}+-- | 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'. ----- @ 'aselect' 'join' = 'C.id' @ +-- >>> 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)) ---aselect :: ((b1 + b2) -> b) -> Dim a b1 -> Dim a b2 -> Dim a b-aselect f x y = dimap Left f $ x +++ y-{-# INLINE aselect #-}+runCayley :: Semiring a => Cayley a -> a+runCayley (Tran f) = f (one +) zero -aselect' :: Dim a b1 -> Dim a b2 -> Dim a (b1 + b2)-aselect' = aselect id-{-# INLINE aselect' #-}+-- 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++++-}++
src/Data/Semiring.hs view
@@ -16,6 +16,7 @@   -- * Presemirings   , type PresemiringLaw, Presemiring   , (+), (*)+  -- * Presemiring folds   , sum1, sumWith1   , product1, productWith1   , xmult1@@ -24,6 +25,7 @@   , type SemiringLaw, Semiring   , zero, one, two   , (^)+  -- * Semiring folds   , sum, sumWith   , product, productWith   , xmult   @@ -31,7 +33,7 @@   -- * Rings   , type RingLaw, Ring   , (-)-  , negate, abs, signum+  , subtract, negate, abs, signum   -- * Re-exports   , mreplicate   , Additive(..)@@ -70,6 +72,8 @@ -- Presemiring ------------------------------------------------------------------------------- +type PresemiringLaw a = ((Additive-Semigroup) a, (Multiplicative-Semigroup) a)+ -- | Right pre-semirings. and (non-unital and unital) right semirings. --  -- A right pre-semiring (sometimes referred to as a bisemigroup) is a type /R/ endowed @@ -86,15 +90,16 @@ -- -- See the properties module for a detailed specification of the laws. ---type PresemiringLaw a = ((Additive-Semigroup) a, (Multiplicative-Semigroup) a)- class PresemiringLaw a => Presemiring a  +-------------------------------------------------------------------------------+-- Presemiring folds+-------------------------------------------------------------------------------  -- | Evaluate a non-empty presemiring sum. ---sum1 :: Presemiring a => Foldable1 f => f a -> a+sum1 :: (Additive-Semigroup) a => Foldable1 f => f a -> a sum1 = sumWith1 id  -- | Evaluate a non-empty presemiring sum using a given presemiring.@@ -109,13 +114,13 @@ -- >>> sumWith1 Just $ 1 :| [2..5 :: Int] -- Just 15 ---sumWith1 :: Foldable1 t => Presemiring a => (b -> a) -> t b -> a+sumWith1 :: (Additive-Semigroup) a => Foldable1 t => (b -> a) -> t b -> a sumWith1 f = unAdditive . foldMap1 (Additive . f) {-# INLINE sumWith1 #-}  -- | Evaluate a non-empty presemiring product. ---product1 :: Presemiring a => Foldable1 f => f a -> a+product1 :: (Multiplicative-Semigroup) a => Foldable1 f => f a -> a product1 = productWith1 id  -- | Evaluate a non-empty presemiring product using a given presemiring.@@ -129,7 +134,7 @@ -- >>> productWith1 First $ Nothing :| [Just (5 :: Int), Just 6,  Nothing] -- First {getFirst = Just 11} ---productWith1 :: Foldable1 t => Presemiring a => (b -> a) -> t b -> a+productWith1 :: (Multiplicative-Semigroup) a => Foldable1 t => (b -> a) -> t b -> a productWith1 f = unMultiplicative . foldMap1 (Multiplicative . f) {-# INLINE productWith1 #-} @@ -138,7 +143,7 @@ -- >>> xmult1 (Right 2 :| [Left "oops"]) (Right 2 :| [Right 3]) :: Either [Char] Int -- Right 4 ---xmult1 :: Foldable1 f => Apply f => Presemiring a => f a -> f a -> a+xmult1 :: Presemiring a => Foldable1 f => Apply f => f a -> f a -> a xmult1 a b = sum1 $ liftF2 (*) a b {-# INLINE xmult1 #-} @@ -206,17 +211,21 @@ (^) :: Semiring a => a -> Natural -> a a ^ n = unMultiplicative $ mreplicate (P.fromIntegral n) (Multiplicative a) +-------------------------------------------------------------------------------+-- Semiring folds+-------------------------------------------------------------------------------+ -- | Evaluate a semiring sum. --  -- >>> sum [1..5 :: Int] -- 15 ---sum :: (Additive-Monoid) a => Presemiring a => Foldable f => f a -> a+sum :: (Additive-Monoid) a => Foldable f => f a -> a sum = sumWith id  -- | Evaluate a semiring sum using a given semiring. -- -sumWith :: (Additive-Monoid) a => Presemiring a => Foldable t => (b -> a) -> t b -> a+sumWith :: (Additive-Monoid) a => Foldable f => (b -> a) -> f b -> a sumWith f = foldr' ((+) . f) zero {-# INLINE sumWith #-} @@ -225,7 +234,7 @@ -- >>> product [1..5 :: Int] -- 120 ---product :: (Multiplicative-Monoid) a => Presemiring a => Foldable f => f a -> a+product :: (Multiplicative-Monoid) a => Foldable f => f a -> a product = productWith id  -- | Evaluate a semiring product using a given semiring.@@ -237,7 +246,7 @@ -- >>> productWith Just [1..5 :: Int] -- Just 120 ---productWith :: (Multiplicative-Monoid) a => Presemiring a => Foldable t => (b -> a) -> t b -> a+productWith :: (Multiplicative-Monoid) a => Foldable f => (b -> a) -> f b -> a productWith f = foldr' ((*) . f) one {-# INLINE productWith #-} @@ -250,7 +259,7 @@ -- >>> xmult [1,2,3 :: Int] [] -- 0 ---xmult :: Foldable f => Applicative f => Presemiring a => (Additive-Monoid) a => f a -> f a -> a+xmult :: Semiring a => Foldable f => Applicative f => f a -> f a -> a xmult a b = sum $ liftA2 (*) a b {-# INLINE xmult #-} @@ -309,26 +318,41 @@  infixl 6 - +-- | Subtract two elements.+--+-- @+-- a '-' b = 'subtract' b a+-- @+-- (-) :: (Additive-Group) a => a -> a -> a a - b = unAdditive (Additive a << Additive b) {-# INLINE (-) #-} +-- | Reverse the sign of an element.+-- negate :: (Additive-Group) a => a -> a negate a = zero - a {-# INLINE negate #-}  -- | Absolute value of an element. ----- @ 'abs' r = 'mul' r ('signum' r) @+-- @ 'abs' r = r '*' ('signum' r) @ ----- https://en.wikipedia.org/wiki/Linearly_ordered_group abs :: (Additive-Group) a => Ord a => a -> a abs x = bool (negate x) x $ zero <= x {-# INLINE abs #-} --- satisfies trichotomy law:--- Exactly one of the following is true: a is positive, -a is positive, or a = 0.--- This property follows from the fact that ordered rings are abelian, linearly ordered groups with respect to addition.+-- | Extract the sign of an element.+--+-- 'signum' satisfies a trichotomy law:+--+-- @ 'signum' r = 'negate' r || 'zero' || r @+-- +-- This follows from the fact that ordered rings are abelian, linearly +-- ordered groups with respect to addition.+--+-- See < https://en.wikipedia.org/wiki/Linearly_ordered_group >.+-- signum :: Ring a => Ord a => a -> a signum x = bool (negate one) one $ zero <= x {-# INLINE signum #-}
src/Data/Semiring/Property.hs view
@@ -72,11 +72,11 @@ -- -- /R/ must right-distribute multiplication. ----- When /R/ is a functor and the semiring structure is derived from 'Alternative', +-- When /R/ is a functor and the semiring structure is derived from 'Control.Applicative.Alternative',  -- this translates to:  -- -- @--- (a '<|>' b) '*>' c = (a '*>' c) '<|>' (b '*>' c)+-- (a 'Control.Applicative.<|>' b) '*>' c = (a '*>' c) 'Control.Applicative.<|>' (b '*>' c) -- @   -- -- See < https://en.wikibooks.org/wiki/Haskell/Alternative_and_MonadPlus >.@@ -90,7 +90,7 @@ -- -- /R/ must right-distribute multiplication over finite (non-empty) sums. ----- For types with exact arithmetic this follows from 'distributive' and the universality of 'fold1'.+-- For types with exact arithmetic this follows from 'distributive_on' and the universality of folds. -- distributive_finite1_on :: Presemiring r => Foldable1 f => Rel r b -> f r -> r -> b distributive_finite1_on (~~) as b = (sum1 as * b) ~~ (sumWith1 (* b) as)@@ -120,13 +120,13 @@ -- A /R/ is semiring then its addititive one must be right-annihilative, i.e.: -- -- @--- 'zero' '*' a ~~ 'zero'+-- 'zero' '*' a = 'zero' -- @ ----- For 'Alternative' instances this property translates to:+-- For 'Control.Applicative.Alternative' instances this property translates to: -- -- @--- 'empty' '*>' a ~~ 'empty'+-- 'Control.Applicative.empty' '*>' a = 'Control.Applicative.empty' -- @ -- -- This is a required property.@@ -138,7 +138,7 @@ -- -- /R/ must right-distribute multiplication between finite sums. ----- For types with exact arithmetic this follows from 'distributive' & 'neutral_multiplication'.+-- For types with exact arithmetic this follows from 'distributive_on' & 'Data.Semigroup.neutral_multiplication_on'. -- distributive_finite_on :: Semiring r => Foldable f => Rel r b -> f r -> r -> b distributive_finite_on (~~) as b = (sum as * b) ~~ (sumWith (* b) as)