rings 0.1.2 → 0.1.3
raw patch · 14 files changed
+3650/−3424 lines, 14 filesdep +profunctors
Dependencies added: profunctors
Files
- rings.cabal +5/−7
- src/Data/Semifield.hs +37/−4
- src/Data/Semigroup/Additive.hs +0/−807
- src/Data/Semigroup/Property.hs +0/−190
- src/Data/Semimodule.hs +536/−43
- src/Data/Semimodule/Algebra.hs +0/−704
- src/Data/Semimodule/Basis.hs +17/−8
- src/Data/Semimodule/Combinator.hs +347/−0
- src/Data/Semimodule/Dual.hs +0/−180
- src/Data/Semimodule/Finite.hs +1033/−0
- src/Data/Semimodule/Free.hs +668/−1164
- src/Data/Semimodule/Operator.hs +0/−299
- src/Data/Semiring.hs +826/−9
- src/Data/Semiring/Property.hs +181/−9
rings.cabal view
@@ -1,5 +1,5 @@ name: rings-version: 0.1.2+version: 0.1.3 synopsis: Ring-like objects. description: Semirings, rings, division rings, modules, and algebras. homepage: https://github.com/cmk/rings@@ -24,14 +24,11 @@ Data.Semiring , Data.Semiring.Property , Data.Semifield- , Data.Semigroup.Additive- , Data.Semigroup.Property , Data.Semimodule- , Data.Semimodule.Operator- , Data.Semimodule.Algebra- , Data.Semimodule.Basis- , Data.Semimodule.Dual , Data.Semimodule.Free+ , Data.Semimodule.Basis+ , Data.Semimodule.Finite+ , Data.Semimodule.Combinator default-extensions: ScopedTypeVariables@@ -51,3 +48,4 @@ , distributive >= 0.3 && < 1.0 , semigroupoids >= 5.0 && < 6.0 , magmas >= 0.0.1 && < 1.0+ , profunctors >= 5.3 && < 6
src/Data/Semifield.hs view
@@ -21,10 +21,8 @@ , (^^) ) where -import safe Data.Complex import safe Data.Fixed import safe Data.Semiring-import safe Data.Semigroup.Additive import safe GHC.Real hiding (Real, Fractional(..), (^^), (^), div) import safe Numeric.Natural import safe Foreign.C.Types (CFloat(..),CDouble(..))@@ -67,6 +65,41 @@ pinf = one / zero {-# INLINE pinf #-} +infixl 7 \\, /++-- | Reciprocal of a multiplicative group element.+--+-- @ +-- x '/' y = x '*' 'recip' y+-- x '\\' y = 'recip' x '*' y+-- @+--+-- >>> recip (3 :+ 4) :: Complex Rational+-- 3 % 25 :+ (-4) % 25+-- >>> recip (3 :+ 4) :: Complex Double+-- 0.12 :+ (-0.16)+-- >>> recip (3 :+ 4) :: Complex Pico+-- 0.120000000000 :+ -0.160000000000+-- +recip :: (Multiplicative-Group) a => a -> a +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+ ------------------------------------------------------------------------------- -- Fields -------------------------------------------------------------------------------@@ -124,7 +157,7 @@ instance Semifield CFloat instance Semifield CDouble -instance Field a => Semifield (Complex a)+--instance Field a => Semifield (Complex a) instance Field ()@@ -143,7 +176,7 @@ instance Field CFloat instance Field CDouble -instance Field a => Field (Complex a)+--instance Field a => Field (Complex a)
− src/Data/Semigroup/Additive.hs
@@ -1,807 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE Safe #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -fno-warn-type-defaults #-}--module Data.Semigroup.Additive where--import safe Control.Applicative-import safe Data.Bool-import safe Data.Complex-import safe Data.Maybe-import safe Data.Either-import safe Data.Distributive-import safe Data.Functor.Rep-import safe Data.Fixed-import safe Data.Group hiding ((\\))-import safe Data.Int-import safe Data.List.NonEmpty-import safe Data.Ord-import safe Data.Semigroup-import safe Data.Word-import safe Foreign.C.Types (CFloat(..),CDouble(..))-import safe GHC.Generics (Generic)-import safe GHC.Real hiding (Fractional(..), div, (^^), (^), (%))-import safe Numeric.Natural--import safe Prelude- ( Eq(..), Ord(..), Show, Applicative(..), Functor(..), Monoid(..), Semigroup(..)- , (.), ($), (<$>), flip, Integer, Float, Double)-import safe qualified Prelude as P--import safe qualified Data.Map as Map-import safe qualified Data.Set as Set-import safe qualified Data.IntMap as IntMap-import safe qualified Data.IntSet as IntSet--infixr 1 ----- | 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 #-}--instance Applicative Additive where- pure = Additive- Additive f <*> Additive a = Additive (f a)--instance Distributive Additive where- distribute = distributeRep- {-# INLINE distribute #-}--instance Representable Additive where- type Rep Additive = ()- tabulate f = Additive (f ())- {-# INLINE tabulate #-}-- index (Additive x) () = x- {-# INLINE index #-}------------------------------------------------------------------------------------ Multiplicative------------------------------------------------------------------------------------- | 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 (*) #-}---- | Reciprocal of a multiplicative group element.------ @ --- x '/' y = x '*' 'recip' y--- x '\\' y = 'recip' x '*' y--- @------ >>> recip (3 :+ 4) :: Complex Rational--- 3 % 25 :+ (-4) % 25--- >>> recip (3 :+ 4) :: Complex Double--- 0.12 :+ (-0.16)--- >>> recip (3 :+ 4) :: Complex Pico--- 0.120000000000 :+ -0.160000000000--- -recip :: (Multiplicative-Group) a => a -> a -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)--instance Distributive Multiplicative where- distribute = distributeRep- {-# INLINE distribute #-}--instance Representable Multiplicative where- type Rep Multiplicative = ()- tabulate f = Multiplicative (f ())- {-# INLINE tabulate #-}-- index (Multiplicative x) () = x- {-# INLINE index #-}---------------------------------------------------------------------------- Additive semigroup instances------------------------------------------------------------------------#define deriveAdditiveSemigroup(ty) \-instance Semigroup (Additive ty) where { \- a <> b = (P.+) <$> a <*> b \-; {-# INLINE (<>) #-} \-}--deriveAdditiveSemigroup(Int)-deriveAdditiveSemigroup(Int8)-deriveAdditiveSemigroup(Int16)-deriveAdditiveSemigroup(Int32)-deriveAdditiveSemigroup(Int64)-deriveAdditiveSemigroup(Integer)--deriveAdditiveSemigroup(Word) --TODO clip these at maxBound to make dioids-deriveAdditiveSemigroup(Word8)-deriveAdditiveSemigroup(Word16)-deriveAdditiveSemigroup(Word32)-deriveAdditiveSemigroup(Word64)-deriveAdditiveSemigroup(Natural)--deriveAdditiveSemigroup(Uni)-deriveAdditiveSemigroup(Deci)-deriveAdditiveSemigroup(Centi)-deriveAdditiveSemigroup(Milli)-deriveAdditiveSemigroup(Micro)-deriveAdditiveSemigroup(Nano)-deriveAdditiveSemigroup(Pico)--deriveAdditiveSemigroup(Float)-deriveAdditiveSemigroup(CFloat)-deriveAdditiveSemigroup(Double)-deriveAdditiveSemigroup(CDouble)--#define deriveAdditiveMonoid(ty) \-instance Monoid (Additive ty) where { \- mempty = pure 0 \-; {-# INLINE mempty #-} \-}--deriveAdditiveMonoid(Int)-deriveAdditiveMonoid(Int8)-deriveAdditiveMonoid(Int16)-deriveAdditiveMonoid(Int32)-deriveAdditiveMonoid(Int64)-deriveAdditiveMonoid(Integer)--deriveAdditiveMonoid(Word)-deriveAdditiveMonoid(Word8)-deriveAdditiveMonoid(Word16)-deriveAdditiveMonoid(Word32)-deriveAdditiveMonoid(Word64)-deriveAdditiveMonoid(Natural)--deriveAdditiveMonoid(Uni)-deriveAdditiveMonoid(Deci)-deriveAdditiveMonoid(Centi)-deriveAdditiveMonoid(Milli)-deriveAdditiveMonoid(Micro)-deriveAdditiveMonoid(Nano)-deriveAdditiveMonoid(Pico)--deriveAdditiveMonoid(Float)-deriveAdditiveMonoid(CFloat)-deriveAdditiveMonoid(Double)-deriveAdditiveMonoid(CDouble)--#define deriveAdditiveMagma(ty) \-instance Magma (Additive ty) where { \- a << b = (P.-) <$> a <*> b \-; {-# INLINE (<<) #-} \-}--deriveAdditiveMagma(Int)-deriveAdditiveMagma(Int8)-deriveAdditiveMagma(Int16)-deriveAdditiveMagma(Int32)-deriveAdditiveMagma(Int64)-deriveAdditiveMagma(Integer)--deriveAdditiveMagma(Uni)-deriveAdditiveMagma(Deci)-deriveAdditiveMagma(Centi)-deriveAdditiveMagma(Milli)-deriveAdditiveMagma(Micro)-deriveAdditiveMagma(Nano)-deriveAdditiveMagma(Pico)--deriveAdditiveMagma(Float)-deriveAdditiveMagma(CFloat)-deriveAdditiveMagma(Double)-deriveAdditiveMagma(CDouble)--#define deriveAdditiveQuasigroup(ty) \-instance Quasigroup (Additive ty) where { \-}--deriveAdditiveQuasigroup(Int)-deriveAdditiveQuasigroup(Int8)-deriveAdditiveQuasigroup(Int16)-deriveAdditiveQuasigroup(Int32)-deriveAdditiveQuasigroup(Int64)-deriveAdditiveQuasigroup(Integer)--deriveAdditiveQuasigroup(Uni)-deriveAdditiveQuasigroup(Deci)-deriveAdditiveQuasigroup(Centi)-deriveAdditiveQuasigroup(Milli)-deriveAdditiveQuasigroup(Micro)-deriveAdditiveQuasigroup(Nano)-deriveAdditiveQuasigroup(Pico)--deriveAdditiveQuasigroup(Float)-deriveAdditiveQuasigroup(CFloat)-deriveAdditiveQuasigroup(Double)-deriveAdditiveQuasigroup(CDouble)--#define deriveAdditiveLoop(ty) \-instance Loop (Additive ty) where { \- lreplicate n (Additive a) = Additive $ P.fromIntegral n * (-a) \-; {-# INLINE lreplicate #-} \-}--deriveAdditiveLoop(Int)-deriveAdditiveLoop(Int8)-deriveAdditiveLoop(Int16)-deriveAdditiveLoop(Int32)-deriveAdditiveLoop(Int64)-deriveAdditiveLoop(Integer)--deriveAdditiveLoop(Uni)-deriveAdditiveLoop(Deci)-deriveAdditiveLoop(Centi)-deriveAdditiveLoop(Milli)-deriveAdditiveLoop(Micro)-deriveAdditiveLoop(Nano)-deriveAdditiveLoop(Pico)--deriveAdditiveLoop(Float)-deriveAdditiveLoop(CFloat)-deriveAdditiveLoop(Double)-deriveAdditiveLoop(CDouble)--#define deriveAdditiveGroup(ty) \-instance Group (Additive ty) where { \- greplicate n (Additive a) = Additive $ P.fromInteger n * a \-; {-# INLINE greplicate #-} \-}--deriveAdditiveGroup(Int)-deriveAdditiveGroup(Int8)-deriveAdditiveGroup(Int16)-deriveAdditiveGroup(Int32)-deriveAdditiveGroup(Int64)-deriveAdditiveGroup(Integer)--deriveAdditiveGroup(Uni)-deriveAdditiveGroup(Deci)-deriveAdditiveGroup(Centi)-deriveAdditiveGroup(Milli)-deriveAdditiveGroup(Micro)-deriveAdditiveGroup(Nano)-deriveAdditiveGroup(Pico)--deriveAdditiveGroup(Float)-deriveAdditiveGroup(CFloat)-deriveAdditiveGroup(Double)-deriveAdditiveGroup(CDouble)----instance (Additive-Semigroup) a => Semigroup (Additive (Complex a)) where- Additive (a :+ b) <> Additive (c :+ d) = Additive $ (a + b) :+ (c + d)- {-# INLINE (<>) #-}--instance (Additive-Monoid) a => Monoid (Additive (Complex a)) where- mempty = Additive $ zero :+ zero--instance (Additive-Group) a => Magma (Additive (Complex a)) where- Additive (a :+ b) << Additive (c :+ d) = Additive $ (subtract c a) :+ (subtract d b)- {-# INLINE (<<) #-}--instance (Additive-Group) a => Quasigroup (Additive (Complex a))--instance (Additive-Group) a => Loop (Additive (Complex a)) where- lreplicate n = mreplicate n . inv--instance (Additive-Group) a => Group (Additive (Complex a))---- type Rng a = ((Additive-Group) a, (Multiplicative-Semigroup) a)-instance ((Additive-Group) a, (Multiplicative-Semigroup) a) => Semigroup (Multiplicative (Complex a)) where- Multiplicative (a :+ b) <> Multiplicative (c :+ d) = Multiplicative $ (subtract (b * d) (a * c)) :+ (a * d + b * c)- {-# INLINE (<>) #-}---- type Ring a = ((Additive-Group) a, (Multiplicative-Monoid) a)-instance ((Additive-Group) a, (Multiplicative-Monoid) a) => Monoid (Multiplicative (Complex a)) where- mempty = Multiplicative $ one :+ zero--instance ((Additive-Group) a, (Multiplicative-Group) a) => Magma (Multiplicative (Complex a)) where- Multiplicative (a :+ b) << Multiplicative (c :+ d) = Multiplicative $ ((a * c + b * d) / (c * c + d * d)) :+ ((subtract (a * d) (b * c)) / (c * c + d * d))- {-# INLINE (<<) #-}--instance ((Additive-Group) a, (Multiplicative-Group) a) => Quasigroup (Multiplicative (Complex a))--instance ((Additive-Group) a, (Multiplicative-Group) a) => Loop (Multiplicative (Complex a)) where- lreplicate n = mreplicate n . inv--instance ((Additive-Group) a, (Multiplicative-Group) a) => Group (Multiplicative (Complex a))----instance ((Additive-Semigroup) a, (Multiplicative-Semigroup) a) => Semigroup (Additive (Ratio a)) where- Additive (a :% b) <> Additive (c :% d) = Additive $ (a * d + c * b) :% (b * d)- {-# INLINE (<>) #-}--instance ((Additive-Monoid) a, (Multiplicative-Monoid) a) => Monoid (Additive (Ratio a)) where- mempty = Additive $ zero :% one--instance ((Additive-Group) a, (Multiplicative-Monoid) a) => Magma (Additive (Ratio a)) where- Additive (a :% b) << Additive (c :% d) = Additive $ (subtract (c * b) (a * d)) :% (b * d)- {-# INLINE (<<) #-}--instance ((Additive-Group) a, (Multiplicative-Monoid) a) => Quasigroup (Additive (Ratio a))--instance ((Additive-Group) a, (Multiplicative-Monoid) a) => Loop (Additive (Ratio a)) where- lreplicate n = mreplicate n . inv--instance ((Additive-Group) a, (Multiplicative-Monoid) a) => Group (Additive (Ratio a))--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--instance Semigroup (Additive [a]) where- (<>) = liftA2 (<>)--instance Monoid (Additive [a]) where- mempty = pure mempty---- >>> [1, 2] * [3, 4]--- [4,5,5,6]-instance (Additive-Semigroup) a => Semigroup (Multiplicative [a]) where - (<>) = liftA2 . liftA2 $ (+) - {-# INLINE (<>) #-}--instance (Additive-Monoid) a => Monoid (Multiplicative [a]) where - mempty = pure [zero]---- >>> (1 :| [2 :: Int]) * (3 :| [4 :: Int])--- 4 :| [5,5,6]-instance Semigroup (Additive (NonEmpty a)) where- (<>) = liftA2 (<>)--instance (Additive-Semigroup) a => Semigroup (Multiplicative (NonEmpty a)) where- (<>) = liftA2 (+) - {-# INLINE (<>) #-}------ MinPlus Predioid--- >>> Min 1 * Min 2 :: Min Int--- Min {getMin = 3}-instance (Additive-Semigroup) a => Semigroup (Multiplicative (Min a)) where- Multiplicative a <> Multiplicative b = Multiplicative $ liftA2 (+) a b---- MinPlus Dioid-instance (Additive-Monoid) a => Monoid (Multiplicative (Min a)) where- mempty = Multiplicative $ pure zero--instance (Additive-Semigroup) a => Semigroup (Additive (Down a)) where- (<>) = liftA2 . liftA2 $ (+) --instance (Additive-Monoid) a => Monoid (Additive (Down a)) where- --Additive (Down a) <> Additive (Down b)- mempty = pure . pure $ zero----instance Semigroup (Additive ()) where- _ <> _ = pure ()- {-# INLINE (<>) #-}--instance Monoid (Additive ()) where- mempty = pure ()- {-# INLINE mempty #-}--instance Magma (Additive ()) where- _ << _ = pure ()--instance Quasigroup (Additive ()) --instance Loop (Additive ()) --instance Group (Additive ()) --instance Semigroup (Additive Bool) where- a <> b = (P.||) <$> a <*> b- {-# INLINE (<>) #-}--instance Monoid (Additive Bool) where- mempty = pure False- {-# INLINE mempty #-}----instance ((Additive-Semigroup) a, Minimal a) => Monoid (Additive a) where--- mempty = Additive minimal---- instance (Meet-Monoid) (Down a) => Monoid (Meet (Down a)) where mempty = Down <$> mempty--instance ((Additive-Semigroup) a, (Additive-Semigroup) b) => Semigroup (Additive (a, b)) where- (<>) = liftA2 $ \(x1,y1) (x2,y2) -> (x1+x2, y1+y2)--instance ((Additive-Monoid) a, (Additive-Monoid) b) => Monoid (Additive (a, b)) where- mempty = pure (zero, zero)--instance ((Additive-Semigroup) a, (Additive-Semigroup) b, (Additive-Semigroup) c) => Semigroup (Additive (a, b, c)) where- (<>) = liftA2 $ \(x1,y1,z1) (x2,y2,z2) -> (x1+x2, y1+y2, z1+z2)--instance ((Additive-Monoid) a, (Additive-Monoid) b, (Additive-Monoid) c) => Monoid (Additive (a, b, c)) where- mempty = pure (zero, zero, zero)--instance (Additive-Semigroup) a => Semigroup (Additive (Maybe a)) where- Additive (Just x) <> Additive (Just y) = Additive . Just $ x + y- Additive (x@Just{}) <> _ = Additive x- Additive Nothing <> y = y--instance (Additive-Semigroup) a => Monoid (Additive (Maybe a)) where- mempty = Additive Nothing--instance ((Additive-Semigroup) a, (Additive-Semigroup) b) => Semigroup (Additive (Either a b)) where- Additive (Right x) <> Additive (Right y) = Additive . Right $ x + y-- Additive(x@Right{}) <> _ = Additive x- Additive (Left x) <> Additive (Left y) = Additive . Left $ x + y- Additive (Left _) <> y = y--instance Ord a => Semigroup (Additive (Set.Set a)) where- (<>) = liftA2 Set.union --instance (Ord k, (Additive-Semigroup) a) => Semigroup (Additive (Map.Map k a)) where- (<>) = liftA2 (Map.unionWith (+))--instance (Additive-Semigroup) a => Semigroup (Additive (IntMap.IntMap a)) where- (<>) = liftA2 (IntMap.unionWith (+))--instance Semigroup (Additive IntSet.IntSet) where- (<>) = liftA2 IntSet.union --instance Monoid (Additive IntSet.IntSet) where- mempty = Additive IntSet.empty--instance (Additive-Semigroup) a => Monoid (Additive (IntMap.IntMap a)) where- mempty = Additive IntMap.empty--instance Ord a => Monoid (Additive (Set.Set a)) where- mempty = Additive Set.empty--instance (Ord k, (Additive-Semigroup) a) => Monoid (Additive (Map.Map k a)) where- mempty = Additive Map.empty----------------------------------------------------------------------------- Multiplicative Semigroup Instances------------------------------------------------------------------------#define deriveMultiplicativeSemigroup(ty) \-instance Semigroup (Multiplicative ty) where { \- a <> b = (P.*) <$> a <*> b \-; {-# INLINE (<>) #-} \-}--deriveMultiplicativeSemigroup(Int)-deriveMultiplicativeSemigroup(Int8)-deriveMultiplicativeSemigroup(Int16)-deriveMultiplicativeSemigroup(Int32)-deriveMultiplicativeSemigroup(Int64)-deriveMultiplicativeSemigroup(Integer)--deriveMultiplicativeSemigroup(Word)-deriveMultiplicativeSemigroup(Word8)-deriveMultiplicativeSemigroup(Word16)-deriveMultiplicativeSemigroup(Word32)-deriveMultiplicativeSemigroup(Word64)-deriveMultiplicativeSemigroup(Natural)--deriveMultiplicativeSemigroup(Uni)-deriveMultiplicativeSemigroup(Deci)-deriveMultiplicativeSemigroup(Centi)-deriveMultiplicativeSemigroup(Milli)-deriveMultiplicativeSemigroup(Micro)-deriveMultiplicativeSemigroup(Nano)-deriveMultiplicativeSemigroup(Pico)--deriveMultiplicativeSemigroup(Float)-deriveMultiplicativeSemigroup(CFloat)-deriveMultiplicativeSemigroup(Double)-deriveMultiplicativeSemigroup(CDouble)--#define deriveMultiplicativeMonoid(ty) \-instance Monoid (Multiplicative ty) where { \- mempty = pure 1 \-; {-# INLINE mempty #-} \-}--deriveMultiplicativeMonoid(Int)-deriveMultiplicativeMonoid(Int8)-deriveMultiplicativeMonoid(Int16)-deriveMultiplicativeMonoid(Int32)-deriveMultiplicativeMonoid(Int64)-deriveMultiplicativeMonoid(Integer)--deriveMultiplicativeMonoid(Word)-deriveMultiplicativeMonoid(Word8)-deriveMultiplicativeMonoid(Word16)-deriveMultiplicativeMonoid(Word32)-deriveMultiplicativeMonoid(Word64)-deriveMultiplicativeMonoid(Natural)--deriveMultiplicativeMonoid(Uni)-deriveMultiplicativeMonoid(Deci)-deriveMultiplicativeMonoid(Centi)-deriveMultiplicativeMonoid(Milli)-deriveMultiplicativeMonoid(Micro)-deriveMultiplicativeMonoid(Nano)-deriveMultiplicativeMonoid(Pico)--deriveMultiplicativeMonoid(Float)-deriveMultiplicativeMonoid(CFloat)-deriveMultiplicativeMonoid(Double)-deriveMultiplicativeMonoid(CDouble)--#define deriveMultiplicativeMagma(ty) \-instance Magma (Multiplicative ty) where { \- a << b = (P./) <$> a <*> b \-; {-# INLINE (<<) #-} \-}--deriveMultiplicativeMagma(Uni)-deriveMultiplicativeMagma(Deci)-deriveMultiplicativeMagma(Centi)-deriveMultiplicativeMagma(Milli)-deriveMultiplicativeMagma(Micro)-deriveMultiplicativeMagma(Nano)-deriveMultiplicativeMagma(Pico)--deriveMultiplicativeMagma(Float)-deriveMultiplicativeMagma(CFloat)-deriveMultiplicativeMagma(Double)-deriveMultiplicativeMagma(CDouble)--#define deriveMultiplicativeQuasigroup(ty) \-instance Quasigroup (Multiplicative ty) where { \-}--deriveMultiplicativeQuasigroup(Uni)-deriveMultiplicativeQuasigroup(Deci)-deriveMultiplicativeQuasigroup(Centi)-deriveMultiplicativeQuasigroup(Milli)-deriveMultiplicativeQuasigroup(Micro)-deriveMultiplicativeQuasigroup(Nano)-deriveMultiplicativeQuasigroup(Pico)--deriveMultiplicativeQuasigroup(Float)-deriveMultiplicativeQuasigroup(CFloat)-deriveMultiplicativeQuasigroup(Double)-deriveMultiplicativeQuasigroup(CDouble)--#define deriveMultiplicativeLoop(ty) \-instance Loop (Multiplicative ty) where { \- lreplicate n = mreplicate n . inv \-}--deriveMultiplicativeLoop(Uni)-deriveMultiplicativeLoop(Deci)-deriveMultiplicativeLoop(Centi)-deriveMultiplicativeLoop(Milli)-deriveMultiplicativeLoop(Micro)-deriveMultiplicativeLoop(Nano)-deriveMultiplicativeLoop(Pico)--deriveMultiplicativeLoop(Float)-deriveMultiplicativeLoop(CFloat)-deriveMultiplicativeLoop(Double)-deriveMultiplicativeLoop(CDouble)--#define deriveMultiplicativeGroup(ty) \-instance Group (Multiplicative ty) where { \- greplicate n (Multiplicative a) = Multiplicative $ a P.^^ P.fromInteger n \-; {-# INLINE greplicate #-} \-}--deriveMultiplicativeGroup(Uni)-deriveMultiplicativeGroup(Deci)-deriveMultiplicativeGroup(Centi)-deriveMultiplicativeGroup(Milli)-deriveMultiplicativeGroup(Micro)-deriveMultiplicativeGroup(Nano)-deriveMultiplicativeGroup(Pico)--deriveMultiplicativeGroup(Float)-deriveMultiplicativeGroup(CFloat)-deriveMultiplicativeGroup(Double)-deriveMultiplicativeGroup(CDouble)----instance (Multiplicative-Semigroup) a => Semigroup (Multiplicative (Ratio a)) where- Multiplicative (a :% b) <> Multiplicative (c :% d) = Multiplicative $ (a * c) :% (b * d)- {-# INLINE (<>) #-}--instance (Multiplicative-Monoid) a => Monoid (Multiplicative (Ratio a)) where- mempty = Multiplicative $ unMultiplicative mempty :% unMultiplicative mempty--instance (Multiplicative-Monoid) a => Magma (Multiplicative (Ratio a)) where- Multiplicative (a :% b) << Multiplicative (c :% d) = Multiplicative $ (a * d) :% (b * c)- {-# INLINE (<<) #-}--instance (Multiplicative-Monoid) a => Quasigroup (Multiplicative (Ratio a))--instance (Multiplicative-Monoid) a => Loop (Multiplicative (Ratio a)) where- lreplicate n = mreplicate n . inv--instance (Multiplicative-Monoid) a => Group (Multiplicative (Ratio a))--------------------------------------------------------------------------- Misc--------------------------------------------------------------------------instance ((Multiplicative-Semigroup) a, Maximal a) => Monoid (Multiplicative a) where--- mempty = Multiplicative maximal--instance Semigroup (Multiplicative ()) where- _ <> _ = pure ()- {-# INLINE (<>) #-}--instance Monoid (Multiplicative ()) where- mempty = pure ()- {-# INLINE mempty #-}--instance Magma (Multiplicative ()) where- _ << _ = pure ()- {-# INLINE (<<) #-}--instance Quasigroup (Multiplicative ())--instance Loop (Multiplicative ())--instance Group (Multiplicative ())--instance Semigroup (Multiplicative Bool) where- a <> b = (P.&&) <$> a <*> b- {-# INLINE (<>) #-}--instance Monoid (Multiplicative Bool) where- mempty = pure True- {-# INLINE mempty #-}--instance (Multiplicative-Semigroup) a => Semigroup (Multiplicative (Dual a)) where- (<>) = liftA2 . liftA2 $ flip (*)--instance (Multiplicative-Monoid) a => Monoid (Multiplicative (Dual a)) where- mempty = pure . pure $ one--instance (Multiplicative-Semigroup) a => Semigroup (Multiplicative (Down a)) where- --Additive (Down a) <> Additive (Down b)- (<>) = liftA2 . liftA2 $ (*) --instance (Multiplicative-Monoid) a => Monoid (Multiplicative (Down a)) where- mempty = pure . pure $ one---- MaxTimes Predioid--instance (Multiplicative-Semigroup) a => Semigroup (Multiplicative (Max a)) where- Multiplicative a <> Multiplicative b = Multiplicative $ liftA2 (*) a b---- MaxTimes Dioid-instance (Multiplicative-Monoid) a => Monoid (Multiplicative (Max a)) where- mempty = Multiplicative $ pure one--instance ((Multiplicative-Semigroup) a, (Multiplicative-Semigroup) b) => Semigroup (Multiplicative (a, b)) where- Multiplicative (x1, y1) <> Multiplicative (x2, y2) = Multiplicative (x1 * x2, y1 * y2)--instance (Multiplicative-Semigroup) b => Semigroup (Multiplicative (a -> b)) where- (<>) = liftA2 . liftA2 $ (*)- {-# INLINE (<>) #-}--instance (Multiplicative-Monoid) b => Monoid (Multiplicative (a -> b)) where- mempty = pure . pure $ one--instance (Multiplicative-Semigroup) a => Semigroup (Multiplicative (Maybe a)) where- Multiplicative Nothing <> _ = Multiplicative Nothing- Multiplicative (Just{}) <> Multiplicative Nothing = Multiplicative Nothing- Multiplicative (Just x) <> Multiplicative (Just y) = Multiplicative . Just $ x * y- -- Mul a <> Mul b = Mul $ liftA2 (*) a b--instance (Multiplicative-Monoid) a => Monoid (Multiplicative (Maybe a)) where- mempty = Multiplicative $ pure one--instance ((Multiplicative-Semigroup) a, (Multiplicative-Semigroup) b) => Semigroup (Multiplicative (Either a b)) where- Multiplicative (Right x) <> Multiplicative (Right y) = Multiplicative . Right $ x * y- Multiplicative (Right{}) <> y = y- Multiplicative (Left x) <> Multiplicative (Left y) = Multiplicative . Left $ x * y- Multiplicative (x@Left{}) <> _ = Multiplicative x--instance Ord a => Semigroup (Multiplicative (Set.Set a)) where- (<>) = liftA2 Set.intersection --instance (Ord k, (Multiplicative-Semigroup) a) => Semigroup (Multiplicative (Map.Map k a)) where- (<>) = liftA2 (Map.intersectionWith (*))--instance (Multiplicative-Semigroup) a => Semigroup (Multiplicative (IntMap.IntMap a)) where- (<>) = liftA2 (IntMap.intersectionWith (*))--instance Semigroup (Multiplicative IntSet.IntSet) where- (<>) = liftA2 IntSet.intersection --instance (Ord k, (Multiplicative-Monoid) k, (Multiplicative-Monoid) a) => Monoid (Multiplicative (Map.Map k a)) where- mempty = Multiplicative $ Map.singleton one one--instance (Multiplicative-Monoid) a => Monoid (Multiplicative (IntMap.IntMap a)) where- mempty = Multiplicative $ IntMap.singleton 0 one
− src/Data/Semigroup/Property.hs
@@ -1,190 +0,0 @@-{-# Language AllowAmbiguousTypes #-}-{-# LANGUAGE Safe #-}--module Data.Semigroup.Property (- -- * Required properties of semigroups- associative_addition_on - , associative_multiplication_on- -- * Required properties of monoids- , neutral_addition_on- , neutral_multiplication_on- -- * Properties of commuative semigroups- , commutative_addition_on - , commutative_multiplication_on- -- * Properties of cancellative semigroups- , cancellative_addition_on- , cancellative_multiplication_on- -- * Properties of idempotent semigroups- , idempotent_addition_on- , idempotent_multiplication_on- -- * Required properties of semigroup & monoid morphisms- , morphism_additive_on- , morphism_multiplicative_on- , morphism_additive_on'- , morphism_multiplicative_on'-) where---import safe Test.Logic (Rel)-import safe Data.Semigroup.Additive-import safe qualified Test.Function as Prop-import safe qualified Test.Operation as Prop hiding (distributive_on)--import safe Prelude hiding (Num(..), sum)------------------------------------------------------------------------------------------ Required properties of semigroups---- | \( \forall a, b, c \in R: (a + b) + c \sim a + (b + c) \)------ A semigroup must right-associate addition.------ 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) \)------ A semigroup must right-associate multiplication.------ 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 (~~) (*) ----------------------------------------------------------------------------------------- Required properties of monoids---- | \( \forall a \in R: (z + a) \sim a \)------ A semigroup with a right-neutral additive identity must satisfy:------ @--- 'neutral_addition_on' ('==') 'zero' r = 'True'--- @--- --- Or, equivalently:------ @--- 'zero' '+' r = r--- @------ This is a required property for additive monoids.----neutral_addition_on :: (Additive-Monoid) r => Rel r b -> r -> b-neutral_addition_on (~~) = Prop.neutral_on (~~) (+) zero---- | \( \forall a \in R: (o * a) \sim a \)------ A semigroup with a right-neutral multiplicative identity must satisfy:------ @--- 'neutral_multiplication_on' ('==') 'one' r = 'True'--- @--- --- Or, equivalently:------ @--- 'one' '*' r = r--- @------ 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----------------------------------------------------------------------------------------- Properties of commutative semigroups---- | \( \forall a, b \in R: a + b \sim b + a \)------ 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 and rings.----commutative_multiplication_on :: (Multiplicative-Semigroup) r => Rel r b -> r -> r -> b-commutative_multiplication_on (~~) = Prop.commutative_on (~~) (*) ----------------------------------------------------------------------------------------- Properties of cancellative semigroups---- | \( \forall a, b, c \in R: b + a \sim c + a \Rightarrow b = c \)------ If /R/ is right-cancellative wrt addition then for all /a/--- the section /(a +)/ is injective.------ See < https://en.wikipedia.org/wiki/Cancellation_property >----cancellative_addition_on :: (Additive-Semigroup) r => Rel r Bool -> r -> r -> r -> Bool-cancellative_addition_on (~~) a = Prop.injective_on (~~) (+ a)---- | \( \forall a, b, c \in R: b * a \sim c * a \Rightarrow b = c \)------ If /R/ is right-cancellative wrt multiplication then for all /a/--- the section /(a *)/ is injective.----cancellative_multiplication_on :: (Multiplicative-Semigroup) r => Rel r Bool -> r -> r -> r -> Bool-cancellative_multiplication_on (~~) a = Prop.injective_on (~~) (* a)----------------------------------------------------------------------------------------- Properties of idempotent semigroups---- | Idempotency property for additive semigroups.------ 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-idempotent_addition_on (~~) r = (r + r) ~~ r---- | Idempotency property for multplicative semigroups.------ 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_multiplication_on :: (Multiplicative-Semigroup) r => Rel r b -> r -> b-idempotent_multiplication_on (~~) r = (r * r) ~~ r----------------------------------------------------------------------------------------- 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)---- |------ 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---- |------ This is a required property for multiplicative monoid morphisms.----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
@@ -12,17 +12,8 @@ {-# LANGUAGE TypeFamilies #-} module Data.Semimodule (- -- * Types- type (**) - , type (++) - , type Free- , type Basis- , type Basis2- , type Basis3 - , type FreeModule - , type FreeSemimodule -- * Left modules- , type LeftModule+ type LeftModule , LeftSemimodule(..) , (*.) , (/.)@@ -39,13 +30,31 @@ , rscaleDef -- * Bimodules , type Bimodule+ , type FreeModule + , type FreeSemimodule , Bisemimodule(..)+ -- * Algebras + , type FreeAlgebra+ , Algebra(..)+ -- * Unital algebras + , type FreeUnital+ , Unital(..)+ -- * Coalgebras + , type FreeCoalgebra+ , Coalgebra(..)+ -- * Unital coalgebras + , type FreeCounital+ , Counital(..)+ -- * Bialgebras + , type FreeBialgebra+ , Bialgebra ) where import safe Data.Complex import safe Data.Fixed import safe Data.Functor.Rep import safe Data.Functor.Compose+import safe Data.Functor.Contravariant import safe Data.Functor.Product import safe Data.Int import safe Data.Semifield@@ -55,30 +64,25 @@ import safe GHC.Real hiding (Fractional(..)) import safe Numeric.Natural 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)--type Basis2 b c f g = (Basis b f, Basis c g)--type Basis3 b c d f g h = (Basis b f, Basis c g, Basis d h)--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))+import safe Control.Arrow+import safe Control.Applicative+import safe Control.Category (Category, (<<<), (>>>))+import safe Data.Bool+--import safe Data.Functor.Contravariant+--import safe qualified Data.Functor.Contravariant.Rep as F+import safe Data.Functor.Apply+import safe Data.Functor.Rep+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) ------------------------------------------------------------------------------- -- Left modules@@ -110,7 +114,7 @@ lscale :: l -> a -> a -infixr 7 *., \., /. +infixr 7 *., \., /., `lscaleDef` -- | Left-multiply a module element by a scalar. --@@ -166,7 +170,7 @@ -- rscale :: r -> a -> a -infixl 7 .*, .\, ./+infixl 7 .*, .\, ./, `rscaleDef` -- | Right-multiply a module element by a scalar. --@@ -194,6 +198,10 @@ type Bimodule l r a = (LeftModule l a, RightModule r a, Bisemimodule l r 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))+ -- | < https://en.wikipedia.org/wiki/Bimodule Bisemimodule > over a commutative semiring. -- -- @@@ -208,9 +216,321 @@ discale l r = lscale l . rscale r -------------------------------------------------------------------------------+-- 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 < 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' = 'runLin' 'diagonal' '.' 'uncurry'+ -- @+ --+ joined :: (b -> b -> a) -> b -> a++-------------------------------------------------------------------------------+-- 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' = 'runLin' 'initial' '.' 'const'+ -- @+ --+ unital :: a -> b -> a++-------------------------------------------------------------------------------+-- 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' '.' 'runLin' 'codiagonal'+ -- @+ --+ cojoined :: (c -> a) -> c -> c -> a+ +-------------------------------------------------------------------------------+-- 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' ('runLin' 'counital') '()'+ -- @+ --+ counital :: (c -> a) -> a++-------------------------------------------------------------------------------+-- 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+++-------------------------------------------------------------------------------+-- Module Instances+-------------------------------------------------------------------------------+++instance Semiring a => LeftSemimodule a a where+ lscale = (*)++{-+instance Semiring l => LeftSemimodule l () where+ lscale _ = const ()++instance (Additive-Monoid) a => LeftSemimodule () a where + lscale _ = id++instance (Additive-Monoid) a => LeftSemimodule Natural a where+ lscale l a = unAdditive $ mreplicate l (Additive a)++instance ((Additive-Monoid) a, (Additive-Group) a) => LeftSemimodule Integer a where+ lscale l a = unAdditive $ greplicate l (Additive a)+-}++instance LeftSemimodule l a => LeftSemimodule l (e -> a) where + lscale l = fmap (l *.)++instance LeftSemimodule l a => LeftSemimodule l (Op a e) where + lscale l (Op f) = Op $ fmap (l *.) f++++{-++instance Semiring a => LeftSemimodule a (Op a e) where + lscale l (Op f) = Op $ fmap (l *) f++instance Semiring a => RightSemimodule a (Op a e) where + rscale r (Op f) = Op $ fmap (* r) f++instance Semiring a => Bisemimodule a a (Op a e)+-}++instance (LeftSemimodule l a, LeftSemimodule l b) => LeftSemimodule l (a, b) where+ lscale n (a, b) = (n *. a, n *. b)++instance (LeftSemimodule l a, LeftSemimodule l b, LeftSemimodule l c) => LeftSemimodule l (a, b, c) where+ lscale n (a, b, c) = (n *. a, n *. b, n *. c)++instance Semiring a => LeftSemimodule a (Ratio a) where + lscale l (x :% y) = (l * x) :% y++instance Ring a => LeftSemimodule a (Complex a) where + lscale l (x :+ y) = (l * x) :+ (l * y)++{-+--instance Ring a => LeftSemimodule (Complex a) (Complex a) where +-- lscale = (*) ++#define deriveLeftSemimodule(ty) \+instance LeftSemimodule ty ty where { \+ lscale = (*) \+; {-# INLINE lscale #-} \+}++deriveLeftSemimodule(Bool)+deriveLeftSemimodule(Int)+deriveLeftSemimodule(Int8)+deriveLeftSemimodule(Int16)+deriveLeftSemimodule(Int32)+deriveLeftSemimodule(Int64)+deriveLeftSemimodule(Word)+deriveLeftSemimodule(Word8)+deriveLeftSemimodule(Word16)+deriveLeftSemimodule(Word32)+deriveLeftSemimodule(Word64)+deriveLeftSemimodule(Uni)+deriveLeftSemimodule(Deci)+deriveLeftSemimodule(Centi)+deriveLeftSemimodule(Milli)+deriveLeftSemimodule(Micro)+deriveLeftSemimodule(Nano)+deriveLeftSemimodule(Pico)+deriveLeftSemimodule(Float)+deriveLeftSemimodule(Double)+deriveLeftSemimodule(CFloat)+deriveLeftSemimodule(CDouble)+deriveLeftSemimodule((Ratio Integer))+deriveLeftSemimodule((Ratio Natural))+-}++------------------------------------------------------------------------------- -- Instances ------------------------------------------------------------------------------- +instance Semiring a => RightSemimodule a a where+ rscale = (*)++{-+instance Semiring r => RightSemimodule r () where + rscale _ = const ()++instance (Additive-Monoid) a => RightSemimodule () a where + rscale _ = id++instance (Additive-Monoid) a => RightSemimodule Natural a where+ rscale r a = unAdditive $ mreplicate r (Additive a)++instance ((Additive-Monoid) a, (Additive-Group) a) => RightSemimodule Integer a where+ rscale r a = unAdditive $ greplicate r (Additive a)+-}++instance RightSemimodule r a => RightSemimodule r (e -> a) where + rscale r = fmap (.* r)++instance RightSemimodule r a => RightSemimodule r (Op a e) where + rscale r (Op f) = Op $ fmap (.* r) f++instance (RightSemimodule r a, RightSemimodule r b) => RightSemimodule r (a, b) where+ rscale n (a, b) = (a .* n, b .* n)++instance (RightSemimodule r a, RightSemimodule r b, RightSemimodule r c) => RightSemimodule r (a, b, c) where+ rscale n (a, b, c) = (a .* n, b .* n, c .* n)++instance Semiring a => RightSemimodule a (Ratio a) where + rscale r (x :% y) = (r * x) :% y+++--instance Ring a => RightSemimodule a (Complex a) where +-- rscale r (x :+ y) = (r * x) :+ (r * y)++--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 a => Bisemimodule a a a++--instance Semiring r => Bisemimodule r r ()++instance Bisemimodule r r a => Bisemimodule r r (e -> a)++instance Bisemimodule r r a => Bisemimodule r r (Op a e)++instance (Bisemimodule r r a, Bisemimodule r r b) => Bisemimodule r r (a, b)++instance (Bisemimodule r r a, Bisemimodule r r b, Bisemimodule r r c) => Bisemimodule r r (a, b, c)++instance Semiring a => Bisemimodule a a (Ratio a)++--instance Ring a => Bisemimodule a a (Complex a)++--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))+-}++{-+-------------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------------+ instance Semiring l => LeftSemimodule l () where lscale _ = const () @@ -226,6 +546,9 @@ instance LeftSemimodule l a => LeftSemimodule l (e -> a) where lscale l = fmap (l *.) +instance LeftSemimodule l a => LeftSemimodule l (Op a e) where + lscale l (Op f) = Op $ fmap (l *.) f+ instance (LeftSemimodule l a, LeftSemimodule l b) => LeftSemimodule l (a, b) where lscale n (a, b) = (n *. a, n *. b) @@ -238,8 +561,8 @@ instance Ring a => LeftSemimodule a (Complex a) where lscale l (x :+ y) = (l * x) :+ (l * y) -instance Ring a => LeftSemimodule (Complex a) (Complex a) where - lscale = (*) +--instance Ring a => LeftSemimodule (Complex a) (Complex a) where +-- lscale = (*) #define deriveLeftSemimodule(ty) \ instance LeftSemimodule ty ty where { \@@ -291,6 +614,9 @@ instance RightSemimodule r a => RightSemimodule r (e -> a) where rscale r = fmap (.* r) +instance RightSemimodule r a => RightSemimodule r (Op a e) where + rscale r (Op f) = Op $ fmap (.* r) f+ instance (RightSemimodule r a, RightSemimodule r b) => RightSemimodule r (a, b) where rscale n (a, b) = (a .* n, b .* n) @@ -300,11 +626,11 @@ instance Semiring a => RightSemimodule a (Ratio a) where rscale r (x :% y) = (r * x) :% y -instance Ring a => RightSemimodule a (Complex a) where - rscale r (x :+ y) = (r * x) :+ (r * y)+--instance Ring a => RightSemimodule a (Complex a) where +-- rscale r (x :+ y) = (r * x) :+ (r * y) -instance Ring a => RightSemimodule (Complex a) (Complex a) where - rscale = (*) +--instance Ring a => RightSemimodule (Complex a) (Complex a) where +-- rscale = (*) #define deriveRightSemimodule(ty) \ instance RightSemimodule ty ty where { \@@ -341,15 +667,17 @@ instance Bisemimodule r r a => Bisemimodule r r (e -> a) +instance Bisemimodule r r a => Bisemimodule r r (Op a e)+ instance (Bisemimodule r r a, Bisemimodule r r b) => Bisemimodule r r (a, b) instance (Bisemimodule r r a, Bisemimodule r r b, Bisemimodule r r c) => Bisemimodule r r (a, b, c) instance Semiring a => Bisemimodule a a (Ratio a) -instance Ring a => Bisemimodule a a (Complex a)+--instance Ring a => Bisemimodule a a (Complex a) -instance Ring a => Bisemimodule (Complex a) (Complex a) (Complex a)+--instance Ring a => Bisemimodule (Complex a) (Complex a) (Complex a) #define deriveBisemimodule(ty) \@@ -379,3 +707,168 @@ deriveBisemimodule(CDouble) deriveBisemimodule((Ratio Integer)) deriveBisemimodule((Ratio Natural))++-}+++-------------------------------------------------------------------------------+-- Algebra instances+-------------------------------------------------------------------------------++{-+instance (Bisemimodule a a a, Algebra a b) => Semigroup (Multiplicative (Op a b)) where+ (<>) = liftA2 $ \(Op x) (Op y) -> Op $ x .*. y+-}++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 ()++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+ counital 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+ counital 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+ counital 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+ counital 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+ counital f = f IntSet.empty++{-++ joined = runLin diagonal . uncurry+ counital = flip (runLin counital) ()+ unital = runLin initial . const+ cojoined = curry . runLin codiagonal++-- | 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)++
− src/Data/Semimodule/Algebra.hs
@@ -1,704 +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.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-----}---
src/Data/Semimodule/Basis.hs view
@@ -1,21 +1,30 @@ {-# LANGUAGE Safe #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-} module Data.Semimodule.Basis (+ type Basis+ , type Basis2+ , type Basis3 -- * Euclidean bases- E1(..), e1, fillE1+ , E1(..), e1, fillE1 , E2(..), e2, fillE2 , E3(..), e3, fillE3 , E4(..), e4, fillE4 ) where import safe Data.Functor.Rep-import safe Data.Semimodule-import safe Data.Semimodule.Algebra import safe Data.Semiring+import safe Data.Semimodule import safe Prelude hiding (Num(..), Fractional(..), negate, sum, product) import safe Control.Monad as M +type Basis b f = (Free f, Rep f ~ b, Eq b)++type Basis2 b c f g = (Basis b f, Basis c g)++type Basis3 b c d f g h = (Basis b f, Basis c g, Basis d h)+ ------------------------------------------------------------------------------- -- Standard basis on one real dimension -------------------------------------------------------------------------------@@ -40,7 +49,7 @@ cojoined f E11 E11 = f E11 instance Semiring r => Counital r E1 where- coinitial = Tran $ \f _ -> f E11+ counital f = f E11 instance Semiring r => Bialgebra r E1 @@ -69,7 +78,7 @@ cojoined _ _ _ = zero instance Semiring r => Counital r E2 where- coinitial = Tran $ \f _ -> f E21 + f E22+ counital f = f E21 + f E22 instance Semiring r => Bialgebra r E2 @@ -100,7 +109,7 @@ cojoined _ _ _ = zero instance Semiring r => Counital r E3 where- coinitial = Tran $ \f _ -> f E31 + f E32 + f E33+ counital f = f E31 + f E32 + f E33 instance Semiring r => Bialgebra r E3 @@ -133,7 +142,7 @@ cojoined _ _ _ = zero instance Semiring r => Counital r E4 where- coinitial = Tran $ \f _ -> f E41 + f E42 + f E43 + f E44+ counital f = f E41 + f E42 + f E43 + f E44 instance Semiring r => Bialgebra r E4
+ src/Data/Semimodule/Combinator.hs view
@@ -0,0 +1,347 @@+{-# 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.Combinator (+ -- * Vector accessors and constructors+ elt+ , vec+ , cov+ , unit+ , unit'+ , counit+ , dirac+ , lensRep+ , grateRep+ -- * Vector combinators+ , (.*)+ , (*.)+ , (.*.)+ , (!*)+ , (*!)+ , (!*!)+ , vmap+ , cmap+ , inner+ , outer+ , lerp+ , quadrance+ -- * Matrix accessors and constructors+ , lin+ , elt2+ , row+ , rows+ , col+ , cols+ , diag+ , codiag+ , scalar+ , identity+ -- * Matrix combinators+ , (.#)+ , (#.)+ , (#!)+ , (!#)+ , (.#.)+ , 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+import safe Data.Semimodule+import safe Data.Semimodule.Free+import safe Data.Semiring+import safe Prelude hiding (Num(..), Fractional(..), negate, sum, product)+import safe qualified Control.Monad as M++-------------------------------------------------------------------------------+-- Vector constructors & acessors+-------------------------------------------------------------------------------++-- | Retrieve the coefficient of a basis element+--+-- >>> elt E21 (V2 1 2)+-- 1+--+elt :: Free f => Rep f -> f a -> a+elt = flip index+{-# INLINE elt #-}++-- | Obtain a vector from an array of coefficients and a basis.+--+vec :: Free f => f a -> Vec a (Rep f)+vec = Vec . index++-- | Obtain a covector from an array of coefficients and a basis.+--+-- >>> cov (V2 7 4) !* vec (V2 1 2) :: Int+-- 11+--+cov :: FreeCounital a f => f a -> Cov a (Rep f)+cov f = Cov $ \k -> f `inner` tabulate k++-- | Insert an element into an algebra.+--+-- When the algebra is trivial this is equal to 'pureRep'.+--+-- >>> 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' :: Complex Int+-- 1 :+ 0+--+unit' :: FreeUnital a f => f a+unit' = unit one++-- | Obtain an element from a coalgebra over a free semimodule.+--+counit :: FreeCounital a f => f a -> a+counit = counital . index++-- | Create a unit vector at an index.+--+-- >>> dirac E21 :: V2 Int+-- V2 1 0+--+-- >>> dirac E42 :: V4 Int+-- V4 0 1 0 0+--+dirac :: Semiring a => Free f => Eq (Rep f) => Rep f -> f a+dirac i = tabulate $ \j -> bool zero one (i == j)+{-# INLINE dirac #-}++-- | Create a lens from a representable functor.+--+lensRep :: Free f => Eq (Rep f) => Rep f -> 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 :: Free f => forall g. Functor g => (Rep f -> g a1 -> a2) -> g (f a1) -> f a2+grateRep iab s = tabulate $ \i -> iab i (fmap (`index` i) s)+{-# INLINE grateRep #-}++-------------------------------------------------------------------------------+-- Vector operations+-------------------------------------------------------------------------------++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)++infix 6 `inner`++-- | Inner product.+--+-- When the coalgebra is trivial 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+{-# INLINE outer #-}++-- | Squared /l2/ norm of a vector.+--+quadrance :: FreeCounital a f => f a -> a+quadrance = M.join inner +{-# INLINE quadrance #-}++-------------------------------------------------------------------------------+-- Matrix accessors and constructors+-------------------------------------------------------------------------------++-- | Obtain a linear linsformation from a matrix.+--+-- @ ('.#') = ('!#') . 'lin' @+--+lin :: Free f => FreeCounital a g => (f**g) a -> Lin a (Rep f) (Rep g) +lin m = Lin $ \k -> index $ m .# tabulate k++-- | Retrieve an element of a matrix.+--+-- >>> elt2 E21 E21 $ m22 1 2 3 4+-- 1+--+elt2 :: Free f => Free g => Rep f -> Rep g -> (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 vector from a tensor.+--+-- When the algebra 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++-- | 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++-- | 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 a matrix on the right by a column vector.+--+-- @ ('.#') = ('!#') . 'lin' @+--+-- >>> lin (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 (.#.) #-}++-- | 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+{-# INLINE trace #-}++-- | 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 #-}
− src/Data/Semimodule/Dual.hs
@@ -1,180 +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.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
+ src/Data/Semimodule/Finite.hs view
@@ -0,0 +1,1033 @@+{-# 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.Finite (+ -- * Vector types+ V1(..)+ , unV1+ , V2(..)+ , V3(..)+ , cross+ , triple+ , V4(..)+ -- * Matrix types+ , type M11+ , type M12+ , type M13+ , type M14+ , type M21+ , type M31+ , type M41+ , type M22+ , type M23+ , type M24+ , type M32+ , type M33+ , type M34+ , type M42+ , type M43+ , type M44+ , m11+ , m12+ , m13+ , m14+ , m21+ , m31+ , m41+ , m22+ , m23+ , m24+ , m32+ , m33+ , m34+ , m42+ , m43+ , m44+ -- * Matrix determinants & inverses+ , inv1+ , inv2+ , bdet2+ , det2+ , bdet3+ , det3+ , inv3+ , bdet4+ , det4+ , inv4+) where++import safe Control.Applicative+import safe Data.Bool+import safe Data.Distributive+import safe Data.Functor.Classes+import safe Data.Functor.Compose+import safe Data.Functor.Rep hiding (Co)+import safe Data.Semifield+import safe Data.Semigroup.Foldable as Foldable1+import safe Data.Semimodule+import safe Data.Semimodule.Basis+import safe Data.Semimodule.Combinator+import safe Data.Semiring+import safe Prelude hiding (Num(..), Fractional(..), negate, sum, product)+import safe Prelude (fromInteger)++-------------------------------------------------------------------------------+-- 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.+--+-- @ +-- a `'cross'` a = 'zero'+-- a `'cross'` b = 'negate' ( b `'cross'` a ) , +-- a `'cross'` ( b '+' c ) = ( a `'cross'` b ) '+' ( a `'cross'` c ) , +-- ( r a ) `'cross'` b = a `'cross'` ( r b ) = r ( a `'cross'` b ) . +-- a `'cross'` ( b `'cross'` c ) '+' b `'cross'` ( c `'cross'` a ) '+' c `'cross'` ( a `'cross'` b ) = 'zero' . +-- @+--+-- See < https://en.wikipedia.org/wiki/Jacobi_identity Jacobi identity >.+--+cross :: Ring a => V3 a -> V3 a -> V3 a+cross (V3 a b c) (V3 d e f) = V3 (b*f-c*e) (c*d-a*f) (a*e-b*d)+{-# INLINABLE cross #-}++-- | Scalar triple product.+--+-- @+-- 'triple' x y z = 'triple' z x y = 'triple' y z x+-- 'triple' x y z = 'negate' '$' 'triple' x z y = 'negate' '$' 'triple' y x z+-- 'triple' x x y = 'triple' x y y = 'triple' x y x = 'zero'+-- ('triple' x y z) '*.' x = (x `'cross'` y) `'cross'` (x `'cross'` z)+-- @+--+-- >>> triple (V3 0 0 1) (V3 1 0 0) (V3 0 1 0) :: Double+-- 1.0+--+triple :: Ring a => V3 a -> V3 a -> V3 a -> a+triple x y z = inner x (cross y z)+{-# INLINE triple #-}+++-------------------------------------------------------------------------------+-- Matrices+-------------------------------------------------------------------------------++-- 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.+--+-- >>> 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 determinants and inverses+-------------------------------------------------------------------------------++-- | 1x1 matrix inverse over a field.+--+-- >>> inv1 $ m11 4.0 :: M11 Double+-- Compose (V1 (V1 0.25))+--+inv1 :: Field a => M11 a -> M11 a+inv1 = transpose . fmap recip++-- | 2x2 matrix bdeterminant over a commutative semiring.+--+-- >>> bdet2 $ m22 1 2 3 4+-- (4,6)+--+bdet2 :: Semiring a => Basis2 E2 E2 f g => (f**g) a -> (a, a)+bdet2 m = (elt2 E21 E21 m * elt2 E22 E22 m, elt2 E21 E22 m * elt2 E22 E21 m)+{-# INLINE bdet2 #-}++-- | 2x2 matrix determinant over a commutative ring.+--+-- @+-- 'det2' = 'uncurry' ('-') . 'bdet2'+-- @+--+-- >>> det2 $ m22 1 2 3 4 :: Double+-- -2.0+--+det2 :: Ring a => Basis2 E2 E2 f g => (f**g) a -> a+det2 = uncurry (-) . bdet2 +{-# INLINE det2 #-}++-- | 2x2 matrix inverse over a field.+--+-- >>> inv2 $ m22 1 2 3 4 :: M22 Double+-- Compose (V2 (V2 (-2.0) 1.0) (V2 1.5 (-0.5)))+--+inv2 :: Field a => M22 a -> M22 a+inv2 m = lscaleDef (recip $ det2 m) $ m22 d (-b) (-c) a where+ a = elt2 E21 E21 m+ b = elt2 E21 E22 m+ c = elt2 E22 E21 m+ d = elt2 E22 E22 m+{-# INLINE inv2 #-}++-- | 3x3 matrix bdeterminant over a commutative semiring.+--+-- >>> bdet3 (V3 (V3 1 2 3) (V3 4 5 6) (V3 7 8 9))+-- (225, 225)+--+bdet3 :: Semiring a => Basis2 E3 E3 f g => (f**g) a -> (a, a)+bdet3 m = (evens, odds) where+ evens = a*e*i + g*b*f + d*h*c+ odds = a*h*f + d*b*i + g*e*c+ a = elt2 E31 E31 m+ b = elt2 E31 E32 m+ c = elt2 E31 E33 m+ d = elt2 E32 E31 m+ e = elt2 E32 E32 m+ f = elt2 E32 E33 m+ g = elt2 E33 E31 m+ h = elt2 E33 E32 m+ i = elt2 E33 E33 m+{-# INLINE bdet3 #-}++-- | 3x3 double-precision matrix determinant.+--+-- @+-- 'det3' = 'uncurry' ('-') . 'bdet3'+-- @+--+-- Implementation uses a cofactor expansion to avoid loss of precision.+--+-- >>> det3 $ m33 1 2 3 4 5 6 7 8 9+-- 0+--+det3 :: Ring a => Basis2 E3 E3 f g => (f**g) a -> a+det3 m = a * (e*i-f*h) - d * (b*i-c*h) + g * (b*f-c*e) where+ a = elt2 E31 E31 m+ b = elt2 E31 E32 m+ c = elt2 E31 E33 m+ d = elt2 E32 E31 m+ e = elt2 E32 E32 m+ f = elt2 E32 E33 m+ g = elt2 E33 E31 m+ h = elt2 E33 E32 m+ i = elt2 E33 E33 m+{-# INLINE det3 #-}++-- | 3x3 matrix inverse.+--+-- >>> inv3 $ m33 1 2 4 4 2 2 1 1 1 :: M33 Double+-- Compose (V3 (V3 0.0 0.5 (-1.0)) (V3 (-0.5) (-0.75) 3.5) (V3 0.5 0.25 (-1.5)))+--+inv3 :: Field a => M33 a -> M33 a+inv3 m = lscaleDef (recip $ det3 m) $ m33 a' b' c' d' e' f' g' h' i' where+ a = elt2 E31 E31 m+ b = elt2 E31 E32 m+ c = elt2 E31 E33 m+ d = elt2 E32 E31 m+ e = elt2 E32 E32 m+ f = elt2 E32 E33 m+ g = elt2 E33 E31 m+ h = elt2 E33 E32 m+ i = elt2 E33 E33 m+ a' = cofactor (e,f,h,i)+ b' = cofactor (c,b,i,h)+ c' = cofactor (b,c,e,f)+ d' = cofactor (f,d,i,g)+ e' = cofactor (a,c,g,i)+ f' = cofactor (c,a,f,d)+ g' = cofactor (d,e,g,h)+ h' = cofactor (b,a,h,g)+ i' = cofactor (a,b,d,e)+ cofactor (q,r,s,t) = det2 (m22 q r s t)+{-# INLINE inv3 #-}++-- | 4x4 matrix bdeterminant over a commutative semiring.+--+-- >>> bdet4 $ m44 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16+-- (27728,27728)+--+bdet4 :: Semiring a => Basis2 E4 E4 f g => (f**g) a -> (a, a) +bdet4 x = (evens, odds) where+ evens = a * (f*k*p + g*l*n + h*j*o) ++ b * (g*i*p + e*l*o + h*k*m) ++ c * (e*j*p + f*l*m + h*i*n) ++ d * (f*i*o + e*k*n + g*j*m)+ odds = a * (g*j*p + f*l*o + h*k*n) ++ b * (e*k*p + g*l*m + h*i*o) ++ c * (f*i*p + e*l*n + h*j*m) ++ d * (e*j*o + f*k*m + g*i*n)+ a = elt2 E41 E41 x+ b = elt2 E41 E42 x+ c = elt2 E41 E43 x+ d = elt2 E41 E44 x+ e = elt2 E42 E41 x+ f = elt2 E42 E42 x+ g = elt2 E42 E43 x+ h = elt2 E42 E44 x+ i = elt2 E43 E41 x+ j = elt2 E43 E42 x+ k = elt2 E43 E43 x+ l = elt2 E43 E44 x+ m = elt2 E44 E41 x+ n = elt2 E44 E42 x+ o = elt2 E44 E43 x+ p = elt2 E44 E44 x+{-# INLINE bdet4 #-}++-- | 4x4 matrix determinant over a commutative ring.+--+-- @+-- 'det4' = 'uncurry' ('-') . 'bdet4'+-- @+--+-- This implementation uses a cofactor expansion to avoid loss of precision.+--+-- >>> det4 $ m44 1 0 3 2 2 0 2 1 0 0 0 1 0 3 4 0 :: Rational+-- (-12) % 1+--+det4 :: Ring a => Basis2 E4 E4 f g => (f**g) a -> a+det4 x = s0 * c5 - s1 * c4 + s2 * c3 + s3 * c2 - s4 * c1 + s5 * c0 where+ s0 = i00 * e11 - e10 * i01+ s1 = i00 * e12 - e10 * i02+ s2 = i00 * e13 - e10 * i03+ s3 = i01 * e12 - e11 * i02+ s4 = i01 * e13 - e11 * i03+ s5 = i02 * e13 - e12 * i03++ c5 = e22 * e33 - e32 * e23+ c4 = e21 * e33 - e31 * e23+ c3 = e21 * e32 - e31 * e22+ c2 = e20 * e33 - e30 * e23+ c1 = e20 * e32 - e30 * e22+ c0 = e20 * e31 - e30 * e21++ i00 = elt2 E41 E41 x+ i01 = elt2 E41 E42 x+ i02 = elt2 E41 E43 x+ i03 = elt2 E41 E44 x+ e10 = elt2 E42 E41 x+ e11 = elt2 E42 E42 x+ e12 = elt2 E42 E43 x+ e13 = elt2 E42 E44 x+ e20 = elt2 E43 E41 x+ e21 = elt2 E43 E42 x+ e22 = elt2 E43 E43 x+ e23 = elt2 E43 E44 x+ e30 = elt2 E44 E41 x+ e31 = elt2 E44 E42 x+ e32 = elt2 E44 E43 x+ e33 = elt2 E44 E44 x+{-# INLINE det4 #-}++-- | 4x4 matrix inverse.+--+-- >>> row E41 . inv4 $ m44 1 0 3 2 2 0 2 1 0 0 0 1 0 3 4 0 :: V4 Rational+-- V4 (6 % (-12)) ((-9) % (-12)) ((-3) % (-12)) (0 % (-12))+--+inv4 :: Field a => M44 a -> M44 a+inv4 x = lscaleDef (recip det) $ x' where+ i00 = elt2 E41 E41 x+ i01 = elt2 E41 E42 x+ i02 = elt2 E41 E43 x+ i03 = elt2 E41 E44 x+ e10 = elt2 E42 E41 x+ e11 = elt2 E42 E42 x+ e12 = elt2 E42 E43 x+ e13 = elt2 E42 E44 x+ e20 = elt2 E43 E41 x+ e21 = elt2 E43 E42 x+ e22 = elt2 E43 E43 x+ e23 = elt2 E43 E44 x+ e30 = elt2 E44 E41 x+ e31 = elt2 E44 E42 x+ e32 = elt2 E44 E43 x+ e33 = elt2 E44 E44 x++ s0 = i00 * e11 - e10 * i01+ s1 = i00 * e12 - e10 * i02+ s2 = i00 * e13 - e10 * i03+ s3 = i01 * e12 - e11 * i02+ s4 = i01 * e13 - e11 * i03+ s5 = i02 * e13 - e12 * i03+ c5 = e22 * e33 - e32 * e23+ c4 = e21 * e33 - e31 * e23+ c3 = e21 * e32 - e31 * e22+ c2 = e20 * e33 - e30 * e23+ c1 = e20 * e32 - e30 * e22+ c0 = e20 * e31 - e30 * e21++ det = s0 * c5 - s1 * c4 + s2 * c3 + s3 * c2 - s4 * c1 + s5 * c0++ x' = m44 (e11 * c5 - e12 * c4 + e13 * c3)+ (-i01 * c5 + i02 * c4 - i03 * c3)+ (e31 * s5 - e32 * s4 + e33 * s3)+ (-e21 * s5 + e22 * s4 - e23 * s3)+ (-e10 * c5 + e12 * c2 - e13 * c1)+ (i00 * c5 - i02 * c2 + i03 * c1)+ (-e30 * s5 + e32 * s2 - e33 * s1)+ (e20 * s5 - e22 * s2 + e23 * s1)+ (e10 * c4 - e11 * c2 + e13 * c0)+ (-i00 * c4 + i01 * c2 - i03 * c0)+ (e30 * s4 - e31 * s2 + e33 * s0)+ (-e20 * s4 + e21 * s2 - e23 * s0)+ (-e10 * c3 + e11 * c1 - e12 * c0)+ (i00 * c3 - i01 * c1 + i02 * c0)+ (-e30 * s3 + e31 * s1 - e32 * s0)+ (e20 * s3 - e21 * s1 + e22 * s0)+{-# INLINE inv4 #-}++-------------------------------------------------------------------------------+-- V1 instances+-------------------------------------------------------------------------------++instance Show1 V1 where+ liftShowsPrec f _ d (V1 a) = showParen (d >= 10) $ showString "V1 " . f d a++{-+instance Field a => Composition a V1 where+ conj = id++ norm f = unV1 $ liftA2 (*) f f+-}++instance Functor V1 where+ fmap f (V1 a) = V1 (f a)+ {-# INLINE fmap #-}+ a <$ _ = V1 a+ {-# INLINE (<$) #-}++instance Applicative V1 where+ pure = pureRep+ liftA2 = liftR2++instance Foldable V1 where+ foldMap f (V1 a) = f a+ {-# INLINE foldMap #-}+ null _ = False+ length _ = one++instance Foldable1 V1 where+ foldMap1 f (V1 a) = f a+ {-# INLINE foldMap1 #-}++instance Distributive V1 where+ distribute f = V1 $ fmap (\(V1 x) -> x) f+ {-# INLINE distribute #-}++instance Representable V1 where+ type Rep V1 = E1+ tabulate f = V1 (f E11)+ {-# INLINE tabulate #-}++ index (V1 x) E11 = x+ {-# INLINE index #-}++-------------------------------------------------------------------------------+-- V2 instances+-------------------------------------------------------------------------------+++instance Show1 V2 where+ liftShowsPrec f _ d (V2 a b) = showsBinaryWith f f "V2" d a b++instance Functor V2 where+ fmap f (V2 a b) = V2 (f a) (f b)+ {-# INLINE fmap #-}+ a <$ _ = V2 a a+ {-# INLINE (<$) #-}++instance Applicative V2 where+ pure = pureRep+ liftA2 = liftR2++instance Foldable V2 where+ foldMap f (V2 a b) = f a <> f b+ {-# INLINE foldMap #-}+ null _ = False+ length _ = two++instance Foldable1 V2 where+ foldMap1 f (V2 a b) = f a <> f b+ {-# INLINE foldMap1 #-}++instance Distributive V2 where+ distribute f = V2 (fmap (\(V2 x _) -> x) f) (fmap (\(V2 _ y) -> y) f)+ {-# INLINE distribute #-}++instance Representable V2 where+ type Rep V2 = E2+ tabulate f = V2 (f E21) (f E22)+ {-# INLINE tabulate #-}++ index (V2 x _) E21 = x+ index (V2 _ y) E22 = y+ {-# INLINE index #-}++-------------------------------------------------------------------------------+-- V3 instances+-------------------------------------------------------------------------------+++-- 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++instance Show1 V3 where+ liftShowsPrec f _ d (V3 a b c) = showParen (d > 10) $+ showString "V3 " . f 11 a . showChar ' ' . f 11 b . showChar ' ' . f 11 c++instance Functor V3 where+ fmap f (V3 a b c) = V3 (f a) (f b) (f c)+ {-# INLINE fmap #-}+ a <$ _ = V3 a a a+ {-# INLINE (<$) #-}++instance Applicative V3 where+ pure = pureRep+ liftA2 = liftR2++instance Foldable V3 where+ foldMap f (V3 a b c) = f a <> f b <> f c+ {-# INLINE foldMap #-}+ null _ = False+ --length _ = 3++instance Foldable1 V3 where+ foldMap1 f (V3 a b c) = f a <> f b <> f c+ {-# INLINE foldMap1 #-}++instance Distributive V3 where+ distribute f = V3 (fmap (\(V3 x _ _) -> x) f) (fmap (\(V3 _ y _) -> y) f) (fmap (\(V3 _ _ z) -> z) f)+ {-# INLINE distribute #-}++instance Representable V3 where+ type Rep V3 = E3+ tabulate f = V3 (f E31) (f E32) (f E33)+ {-# INLINE tabulate #-}++ index (V3 x _ _) E31 = x+ index (V3 _ y _) E32 = y+ index (V3 _ _ z) E33 = z+ {-# INLINE index #-}++-------------------------------------------------------------------------------+-- V4 instances+-------------------------------------------------------------------------------+++instance Show1 V4 where+ liftShowsPrec f _ z (V4 a b c d) = showParen (z > 10) $+ showString "V4 " . f 11 a . showChar ' ' . f 11 b . showChar ' ' . f 11 c . showChar ' ' . f 11 d++instance Functor V4 where+ fmap f (V4 a b c d) = V4 (f a) (f b) (f c) (f d)+ {-# INLINE fmap #-}+ a <$ _ = V4 a a a a+ {-# INLINE (<$) #-}++instance Applicative V4 where+ pure = pureRep+ liftA2 = liftR2++instance Foldable V4 where+ foldMap f (V4 a b c d) = f a <> f b <> f c <> f d+ {-# INLINE foldMap #-}+ null _ = False+ length _ = two + two++instance Foldable1 V4 where+ foldMap1 f (V4 a b c d) = f a <> f b <> f c <> f d+ {-# INLINE foldMap1 #-}++instance Distributive V4 where+ distribute f = V4 (fmap (\(V4 x _ _ _) -> x) f) (fmap (\(V4 _ y _ _) -> y) f) (fmap (\(V4 _ _ z _) -> z) f) (fmap (\(V4 _ _ _ w) -> w) f)+ {-# INLINE distribute #-}++instance Representable V4 where+ type Rep V4 = E4+ tabulate f = V4 (f E41) (f E42) (f E43) (f E44)+ {-# INLINE tabulate #-}++ index (V4 x _ _ _) E41 = x+ index (V4 _ y _ _) E42 = y+ index (V4 _ _ z _) E43 = z+ index (V4 _ _ _ w) E44 = w+ {-# INLINE index #-}+++-------------------------------------------------------------------------------+-- Autogenerated instances+-------------------------------------------------------------------------------+++#define deriveAdditiveSemigroup(ty) \+instance (Additive-Semigroup) a => Semigroup (Additive (ty a)) where { \+ (<>) = liftA2 $ mzipWithRep (+) \+; {-# INLINE (<>) #-} \+}++#define deriveAdditiveMonoid(ty) \+instance (Additive-Monoid) a => Monoid (Additive (ty a)) where { \+ mempty = pure $ pureRep zero \+; {-# INLINE mempty #-} \+}++#define deriveMultiplicativeSemigroup(ty) \+instance (Multiplicative-Semigroup) a => Semigroup (Multiplicative (ty a)) where { \+ (<>) = liftA2 $ mzipWithRep (*) \+; {-# INLINE (<>) #-} \+}++#define deriveMultiplicativeMonoid(ty) \+instance (Multiplicative-Monoid) a => Monoid (Multiplicative (ty a)) where { \+ mempty = pure $ pureRep one \+; {-# INLINE mempty #-} \+}++#define deriveMultiplicativeMatrixSemigroup(ty) \+instance Semiring a => Semigroup (Multiplicative (ty a)) where { \+ (<>) = liftA2 $ (.#.) \+; {-# INLINE (<>) #-} \+}++#define deriveMultiplicativeMatrixMonoid(ty) \+instance Semiring a => Monoid (Multiplicative (ty a)) where { \+ mempty = pure identity \+; {-# INLINE mempty #-} \+}++#define deriveAdditiveMagma(ty) \+instance (Additive-Group) a => Magma (Additive (ty a)) where { \+ (<<) = liftA2 $ mzipWithRep (-) \+; {-# INLINE (<<) #-} \+}++#define deriveAdditiveQuasigroup(ty) \+instance (Additive-Group) a => Quasigroup (Additive (ty a)) \++#define deriveAdditiveLoop(ty) \+instance (Additive-Group) a => Loop (Additive (ty a)) \++#define deriveAdditiveGroup(ty) \+instance (Additive-Group) a => Group (Additive (ty a)) \++#define derivePresemiring(ty) \+instance Semiring a => Presemiring (ty a) \++#define deriveSemiring(ty) \+instance Semiring a => Semiring (ty a) \++#define deriveRing(ty) \+instance Ring a => Ring (ty a) \++#define deriveFreeLeftSemimodule(ty) \+instance Semiring a => LeftSemimodule a (ty a) where { \+ lscale = lscaleDef \+; {-# INLINE lscale #-} \+}++#define deriveFreeRightSemimodule(ty) \+instance Semiring a => RightSemimodule a (ty a) where { \+ rscale = rscaleDef \+; {-# INLINE rscale #-} \+}++#define deriveFreeBisemimodule(ty) \+instance Semiring a => Bisemimodule a a (ty a) \++#define deriveBisemimodule(tyl, tyr, ty) \+instance Semiring a => Bisemimodule (tyl a) (tyr a) (ty a) \++#define deriveLeftSemimodule(tyl,ty) \+instance Semiring a => LeftSemimodule (tyl a) (ty a) where { \+ lscale = (.#.) \+; {-# INLINE lscale #-} \+}++#define deriveRightSemimodule(tyr,ty) \+instance Semiring a => RightSemimodule (tyr a) (ty a) where { \+ rscale = flip (.#.) \+; {-# INLINE rscale #-} \+}++#define deriveBisemimodule(tyl, tyr, ty) \+instance Semiring a => Bisemimodule (tyl a) (tyr a) (ty a) \++++-- V1+deriveAdditiveSemigroup(V1)+deriveAdditiveMonoid(V1)++deriveAdditiveMagma(V1)+deriveAdditiveQuasigroup(V1)+deriveAdditiveLoop(V1)+deriveAdditiveGroup(V1)++deriveFreeLeftSemimodule(V1)+deriveFreeRightSemimodule(V1)+deriveFreeBisemimodule(V1)+++-- V2+deriveAdditiveSemigroup(V2)+deriveAdditiveMonoid(V2)++deriveAdditiveMagma(V2)+deriveAdditiveQuasigroup(V2)+deriveAdditiveLoop(V2)+deriveAdditiveGroup(V2)++deriveFreeLeftSemimodule(V2)+deriveFreeRightSemimodule(V2)+deriveFreeBisemimodule(V2)+++-- V3+deriveAdditiveSemigroup(V3)+deriveAdditiveMonoid(V3)++deriveAdditiveMagma(V3)+deriveAdditiveQuasigroup(V3)+deriveAdditiveLoop(V3)+deriveAdditiveGroup(V3)++deriveFreeLeftSemimodule(V3)+deriveFreeRightSemimodule(V3)+deriveFreeBisemimodule(V3)++-- V4+deriveAdditiveSemigroup(V4)+deriveAdditiveMonoid(V4)++deriveAdditiveMagma(V4)+deriveAdditiveQuasigroup(V4)+deriveAdditiveLoop(V4)+deriveAdditiveGroup(V4)++deriveFreeLeftSemimodule(V4)+deriveFreeRightSemimodule(V4)+deriveFreeBisemimodule(V4)++-- M11+deriveLeftSemimodule(M11, M11)+deriveRightSemimodule(M11, M11)++deriveMultiplicativeMatrixSemigroup(M11)+deriveMultiplicativeMatrixMonoid(M11)++derivePresemiring(M11)+deriveSemiring(M11)+deriveRing(M11)++-- M21+deriveLeftSemimodule(M22, M21)+deriveRightSemimodule(M11, M21)+deriveBisemimodule(M22, M11, M21)+++-- M31+deriveLeftSemimodule(M33, M31)+deriveRightSemimodule(M11, M31)+deriveBisemimodule(M33, M11, M31)+++-- M41+deriveLeftSemimodule(M44, M41)+deriveRightSemimodule(M11, M41)+deriveBisemimodule(M44, M11, M41)+++-- M12+deriveLeftSemimodule(M11, M12)+deriveRightSemimodule(M22, M12)+deriveBisemimodule(M11, M22, M12)+++-- M22+deriveLeftSemimodule(M22, M22)+deriveRightSemimodule(M22, M22)++deriveMultiplicativeMatrixSemigroup(M22)+deriveMultiplicativeMatrixMonoid(M22)++derivePresemiring(M22)+deriveSemiring(M22)+deriveRing(M22)+++-- M32+deriveLeftSemimodule(M33, M32)+deriveRightSemimodule(M22, M32)+deriveBisemimodule(M33, M22, M32)+++-- M42+deriveLeftSemimodule(M44, M42)+deriveRightSemimodule(M22, M42)+deriveBisemimodule(M44, M22, M42)+++-- M13+deriveLeftSemimodule(M11, M13)+deriveRightSemimodule(M33, M13)+deriveBisemimodule(M11, M33, M13)+++-- M23+deriveLeftSemimodule(M22, M23)+deriveRightSemimodule(M33, M23)+deriveBisemimodule(M22, M33, M23)+++-- M33+deriveLeftSemimodule(M33, M33)+deriveRightSemimodule(M33, M33)++deriveMultiplicativeMatrixSemigroup(M33)+deriveMultiplicativeMatrixMonoid(M33)++derivePresemiring(M33)+deriveSemiring(M33)+deriveRing(M33)+++-- M43+deriveLeftSemimodule(M44, M43)+deriveRightSemimodule(M33, M43)+deriveBisemimodule(M44, M33, M43)+++-- M14+deriveLeftSemimodule(M11, M14)+deriveRightSemimodule(M44, M14)+deriveBisemimodule(M11, M44, M14)+++-- M24+deriveLeftSemimodule(M22, M24)+deriveRightSemimodule(M44, M24)+deriveBisemimodule(M22, M44, M24)+++-- M34+deriveLeftSemimodule(M33, M34)+deriveRightSemimodule(M44, M34)+deriveBisemimodule(M33, M44, M34)+++-- M44+deriveLeftSemimodule(M44, M44)+deriveRightSemimodule(M44, M44)++deriveMultiplicativeMatrixSemigroup(M44)+deriveMultiplicativeMatrixMonoid(M44)++derivePresemiring(M44)+deriveSemiring(M44)+deriveRing(M44)
src/Data/Semimodule/Free.hs view
@@ -1,1166 +1,670 @@ {-# 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.Free (- -- * Vector types- V1(..)- , unV1- , V2(..)- , V3(..)- , cross- , triple- , V4(..)- -- * Matrix types- , type M11- , type M12- , type M13- , type M14- , type M21- , type M31- , type M41- , type M22- , type M23- , type M24- , type M32- , type M33- , type M34- , type M42- , type M43- , type M44- , m11- , m12- , m13- , m14- , m21- , m31- , m41- , m22- , m23- , m24- , m32- , m33- , m34- , m42- , m43- , m44- -- * Matrix determinants & inverses- , inv1- , inv2- , bdet2- , det2- , bdet3- , det3- , inv3- , bdet4- , det4- , inv4-) where--import safe Control.Applicative-import safe Data.Bool-import safe Data.Distributive-import safe Data.Functor.Classes-import safe Data.Functor.Compose-import safe Data.Functor.Rep hiding (Co)-import safe Data.Semifield-import safe Data.Semigroup.Foldable as Foldable1-import safe Data.Semimodule-import safe Data.Semimodule.Basis-import safe Data.Semimodule.Operator-import safe Data.Semiring-import safe Prelude hiding (Num(..), Fractional(..), negate, sum, product)-import safe Prelude (fromInteger)------------------------------------------------------------------------------------- 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.------ @ --- a `'cross'` a = 'zero'--- a `'cross'` b = 'negate' ( b `'cross'` a ) , --- a `'cross'` ( b '+' c ) = ( a `'cross'` b ) '+' ( a `'cross'` c ) , --- ( r a ) `'cross'` b = a `'cross'` ( r b ) = r ( a `'cross'` b ) . --- a `'cross'` ( b `'cross'` c ) '+' b `'cross'` ( c `'cross'` a ) '+' c `'cross'` ( a `'cross'` b ) = 'zero' . --- @------ See < https://en.wikipedia.org/wiki/Jacobi_identity Jacobi identity >.----cross :: Ring a => V3 a -> V3 a -> V3 a-cross (V3 a b c) (V3 d e f) = V3 (b*f-c*e) (c*d-a*f) (a*e-b*d)-{-# INLINABLE cross #-}---- | Scalar triple product.------ @--- 'triple' x y z = 'triple' z x y = 'triple' y z x--- 'triple' x y z = 'negate' '$' 'triple' x z y = 'negate' '$' 'triple' y x z--- 'triple' x x y = 'triple' x y y = 'triple' x y x = 'zero'--- ('triple' x y z) '*.' x = (x `'cross'` y) `'cross'` (x `'cross'` z)--- @------ >>> triple (V3 0 0 1) (V3 1 0 0) (V3 0 1 0) :: Double--- 1.0----triple :: Ring a => V3 a -> V3 a -> V3 a -> a-triple x y z = inner x (cross y z)-{-# INLINE triple #-}------------------------------------------------------------------------------------- Matrices------------------------------------------------------------------------------------ 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.------ >>> 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 determinants and inverses------------------------------------------------------------------------------------ | 1x1 matrix inverse over a field.------ >>> inv1 $ m11 4.0 :: M11 Double--- Compose (V1 (V1 0.25))----inv1 :: Field a => M11 a -> M11 a-inv1 = transpose . fmap recip---- | 2x2 matrix bdeterminant over a commutative semiring.------ >>> bdet2 $ m22 1 2 3 4--- (4,6)----bdet2 :: Semiring a => Basis2 E2 E2 f g => (f**g) a -> (a, a)-bdet2 m = (elt2 E21 E21 m * elt2 E22 E22 m, elt2 E21 E22 m * elt2 E22 E21 m)-{-# INLINE bdet2 #-}---- | 2x2 matrix determinant over a commutative ring.------ @--- 'det2' = 'uncurry' ('-') . 'bdet2'--- @------ >>> det2 $ m22 1 2 3 4 :: Double--- -2.0----det2 :: Ring a => Basis2 E2 E2 f g => (f**g) a -> a-det2 = uncurry (-) . bdet2 -{-# INLINE det2 #-}---- | 2x2 matrix inverse over a field.------ >>> inv2 $ m22 1 2 3 4 :: M22 Double--- Compose (V2 (V2 (-2.0) 1.0) (V2 1.5 (-0.5)))----inv2 :: Field a => M22 a -> M22 a-inv2 m = lscaleDef (recip $ det2 m) $ m22 d (-b) (-c) a where- a = elt2 E21 E21 m- b = elt2 E21 E22 m- c = elt2 E22 E21 m- d = elt2 E22 E22 m-{-# INLINE inv2 #-}---- | 3x3 matrix bdeterminant over a commutative semiring.------ >>> bdet3 (V3 (V3 1 2 3) (V3 4 5 6) (V3 7 8 9))--- (225, 225)----bdet3 :: Semiring a => Basis2 E3 E3 f g => (f**g) a -> (a, a)-bdet3 m = (evens, odds) where- evens = a*e*i + g*b*f + d*h*c- odds = a*h*f + d*b*i + g*e*c- a = elt2 E31 E31 m- b = elt2 E31 E32 m- c = elt2 E31 E33 m- d = elt2 E32 E31 m- e = elt2 E32 E32 m- f = elt2 E32 E33 m- g = elt2 E33 E31 m- h = elt2 E33 E32 m- i = elt2 E33 E33 m-{-# INLINE bdet3 #-}---- | 3x3 double-precision matrix determinant.------ @--- 'det3' = 'uncurry' ('-') . 'bdet3'--- @------ Implementation uses a cofactor expansion to avoid loss of precision.------ >>> det3 $ m33 1 2 3 4 5 6 7 8 9--- 0----det3 :: Ring a => Basis2 E3 E3 f g => (f**g) a -> a-det3 m = a * (e*i-f*h) - d * (b*i-c*h) + g * (b*f-c*e) where- a = elt2 E31 E31 m- b = elt2 E31 E32 m- c = elt2 E31 E33 m- d = elt2 E32 E31 m- e = elt2 E32 E32 m- f = elt2 E32 E33 m- g = elt2 E33 E31 m- h = elt2 E33 E32 m- i = elt2 E33 E33 m-{-# INLINE det3 #-}---- | 3x3 matrix inverse.------ >>> inv3 $ m33 1 2 4 4 2 2 1 1 1 :: M33 Double--- Compose (V3 (V3 0.0 0.5 (-1.0)) (V3 (-0.5) (-0.75) 3.5) (V3 0.5 0.25 (-1.5)))----inv3 :: Field a => M33 a -> M33 a-inv3 m = lscaleDef (recip $ det3 m) $ m33 a' b' c' d' e' f' g' h' i' where- a = elt2 E31 E31 m- b = elt2 E31 E32 m- c = elt2 E31 E33 m- d = elt2 E32 E31 m- e = elt2 E32 E32 m- f = elt2 E32 E33 m- g = elt2 E33 E31 m- h = elt2 E33 E32 m- i = elt2 E33 E33 m- a' = cofactor (e,f,h,i)- b' = cofactor (c,b,i,h)- c' = cofactor (b,c,e,f)- d' = cofactor (f,d,i,g)- e' = cofactor (a,c,g,i)- f' = cofactor (c,a,f,d)- g' = cofactor (d,e,g,h)- h' = cofactor (b,a,h,g)- i' = cofactor (a,b,d,e)- cofactor (q,r,s,t) = det2 (m22 q r s t)-{-# INLINE inv3 #-}---- | 4x4 matrix bdeterminant over a commutative semiring.------ >>> bdet4 $ m44 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16--- (27728,27728)----bdet4 :: Semiring a => Basis2 E4 E4 f g => (f**g) a -> (a, a) -bdet4 x = (evens, odds) where- evens = a * (f*k*p + g*l*n + h*j*o) +- b * (g*i*p + e*l*o + h*k*m) +- c * (e*j*p + f*l*m + h*i*n) +- d * (f*i*o + e*k*n + g*j*m)- odds = a * (g*j*p + f*l*o + h*k*n) +- b * (e*k*p + g*l*m + h*i*o) +- c * (f*i*p + e*l*n + h*j*m) +- d * (e*j*o + f*k*m + g*i*n)- a = elt2 E41 E41 x- b = elt2 E41 E42 x- c = elt2 E41 E43 x- d = elt2 E41 E44 x- e = elt2 E42 E41 x- f = elt2 E42 E42 x- g = elt2 E42 E43 x- h = elt2 E42 E44 x- i = elt2 E43 E41 x- j = elt2 E43 E42 x- k = elt2 E43 E43 x- l = elt2 E43 E44 x- m = elt2 E44 E41 x- n = elt2 E44 E42 x- o = elt2 E44 E43 x- p = elt2 E44 E44 x-{-# INLINE bdet4 #-}---- | 4x4 matrix determinant over a commutative ring.------ @--- 'det4' = 'uncurry' ('-') . 'bdet4'--- @------ This implementation uses a cofactor expansion to avoid loss of precision.------ >>> det4 $ m44 1 0 3 2 2 0 2 1 0 0 0 1 0 3 4 0 :: Rational--- (-12) % 1----det4 :: Ring a => Basis2 E4 E4 f g => (f**g) a -> a-det4 x = s0 * c5 - s1 * c4 + s2 * c3 + s3 * c2 - s4 * c1 + s5 * c0 where- s0 = i00 * e11 - e10 * i01- s1 = i00 * e12 - e10 * i02- s2 = i00 * e13 - e10 * i03- s3 = i01 * e12 - e11 * i02- s4 = i01 * e13 - e11 * i03- s5 = i02 * e13 - e12 * i03-- c5 = e22 * e33 - e32 * e23- c4 = e21 * e33 - e31 * e23- c3 = e21 * e32 - e31 * e22- c2 = e20 * e33 - e30 * e23- c1 = e20 * e32 - e30 * e22- c0 = e20 * e31 - e30 * e21-- i00 = elt2 E41 E41 x- i01 = elt2 E41 E42 x- i02 = elt2 E41 E43 x- i03 = elt2 E41 E44 x- e10 = elt2 E42 E41 x- e11 = elt2 E42 E42 x- e12 = elt2 E42 E43 x- e13 = elt2 E42 E44 x- e20 = elt2 E43 E41 x- e21 = elt2 E43 E42 x- e22 = elt2 E43 E43 x- e23 = elt2 E43 E44 x- e30 = elt2 E44 E41 x- e31 = elt2 E44 E42 x- e32 = elt2 E44 E43 x- e33 = elt2 E44 E44 x-{-# INLINE det4 #-}---- | 4x4 matrix inverse.------ >>> row E41 . inv4 $ m44 1 0 3 2 2 0 2 1 0 0 0 1 0 3 4 0 :: V4 Rational--- V4 (6 % (-12)) ((-9) % (-12)) ((-3) % (-12)) (0 % (-12))----inv4 :: Field a => M44 a -> M44 a-inv4 x = lscaleDef (recip det) $ x' where- i00 = elt2 E41 E41 x- i01 = elt2 E41 E42 x- i02 = elt2 E41 E43 x- i03 = elt2 E41 E44 x- e10 = elt2 E42 E41 x- e11 = elt2 E42 E42 x- e12 = elt2 E42 E43 x- e13 = elt2 E42 E44 x- e20 = elt2 E43 E41 x- e21 = elt2 E43 E42 x- e22 = elt2 E43 E43 x- e23 = elt2 E43 E44 x- e30 = elt2 E44 E41 x- e31 = elt2 E44 E42 x- e32 = elt2 E44 E43 x- e33 = elt2 E44 E44 x-- s0 = i00 * e11 - e10 * i01- s1 = i00 * e12 - e10 * i02- s2 = i00 * e13 - e10 * i03- s3 = i01 * e12 - e11 * i02- s4 = i01 * e13 - e11 * i03- s5 = i02 * e13 - e12 * i03- c5 = e22 * e33 - e32 * e23- c4 = e21 * e33 - e31 * e23- c3 = e21 * e32 - e31 * e22- c2 = e20 * e33 - e30 * e23- c1 = e20 * e32 - e30 * e22- c0 = e20 * e31 - e30 * e21-- det = s0 * c5 - s1 * c4 + s2 * c3 + s3 * c2 - s4 * c1 + s5 * c0-- x' = m44 (e11 * c5 - e12 * c4 + e13 * c3)- (-i01 * c5 + i02 * c4 - i03 * c3)- (e31 * s5 - e32 * s4 + e33 * s3)- (-e21 * s5 + e22 * s4 - e23 * s3)- (-e10 * c5 + e12 * c2 - e13 * c1)- (i00 * c5 - i02 * c2 + i03 * c1)- (-e30 * s5 + e32 * s2 - e33 * s1)- (e20 * s5 - e22 * s2 + e23 * s1)- (e10 * c4 - e11 * c2 + e13 * c0)- (-i00 * c4 + i01 * c2 - i03 * c0)- (e30 * s4 - e31 * s2 + e33 * s0)- (-e20 * s4 + e21 * s2 - e23 * s0)- (-e10 * c3 + e11 * c1 - e12 * c0)- (i00 * c3 - i01 * c1 + i02 * c0)- (-e30 * s3 + e31 * s1 - e32 * s0)- (e20 * s3 - e21 * s1 + e22 * s0)-{-# INLINE inv4 #-}------------------------------------------------------------------------------------ V1 instances----------------------------------------------------------------------------------instance Show1 V1 where- liftShowsPrec f _ d (V1 a) = showParen (d >= 10) $ showString "V1 " . f d a--{--instance Field a => Composition a V1 where- conj = id-- norm f = unV1 $ liftA2 (*) f f--}--instance Functor V1 where- fmap f (V1 a) = V1 (f a)- {-# INLINE fmap #-}- a <$ _ = V1 a- {-# INLINE (<$) #-}--instance Applicative V1 where- pure = pureRep- liftA2 = liftR2--instance Foldable V1 where- foldMap f (V1 a) = f a- {-# INLINE foldMap #-}- null _ = False- length _ = one--instance Foldable1 V1 where- foldMap1 f (V1 a) = f a- {-# INLINE foldMap1 #-}--instance Distributive V1 where- distribute f = V1 $ fmap (\(V1 x) -> x) f- {-# INLINE distribute #-}--instance Representable V1 where- type Rep V1 = E1- tabulate f = V1 (f E11)- {-# INLINE tabulate #-}-- index (V1 x) E11 = x- {-# INLINE index #-}------------------------------------------------------------------------------------ V2 instances-----------------------------------------------------------------------------------instance Show1 V2 where- liftShowsPrec f _ d (V2 a b) = showsBinaryWith f f "V2" d a b--instance Functor V2 where- fmap f (V2 a b) = V2 (f a) (f b)- {-# INLINE fmap #-}- a <$ _ = V2 a a- {-# INLINE (<$) #-}--instance Applicative V2 where- pure = pureRep- liftA2 = liftR2--instance Foldable V2 where- foldMap f (V2 a b) = f a <> f b- {-# INLINE foldMap #-}- null _ = False- length _ = two--instance Foldable1 V2 where- foldMap1 f (V2 a b) = f a <> f b- {-# INLINE foldMap1 #-}--instance Distributive V2 where- distribute f = V2 (fmap (\(V2 x _) -> x) f) (fmap (\(V2 _ y) -> y) f)- {-# INLINE distribute #-}--instance Representable V2 where- type Rep V2 = E2- tabulate f = V2 (f E21) (f E22)- {-# INLINE tabulate #-}-- index (V2 x _) E21 = x- index (V2 _ y) E22 = y- {-# INLINE index #-}------------------------------------------------------------------------------------ V3 instances------------------------------------------------------------------------------------- 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--instance Show1 V3 where- liftShowsPrec f _ d (V3 a b c) = showParen (d > 10) $- showString "V3 " . f 11 a . showChar ' ' . f 11 b . showChar ' ' . f 11 c--instance Functor V3 where- fmap f (V3 a b c) = V3 (f a) (f b) (f c)- {-# INLINE fmap #-}- a <$ _ = V3 a a a- {-# INLINE (<$) #-}--instance Applicative V3 where- pure = pureRep- liftA2 = liftR2--instance Foldable V3 where- foldMap f (V3 a b c) = f a <> f b <> f c- {-# INLINE foldMap #-}- null _ = False- --length _ = 3--instance Foldable1 V3 where- foldMap1 f (V3 a b c) = f a <> f b <> f c- {-# INLINE foldMap1 #-}--instance Distributive V3 where- distribute f = V3 (fmap (\(V3 x _ _) -> x) f) (fmap (\(V3 _ y _) -> y) f) (fmap (\(V3 _ _ z) -> z) f)- {-# INLINE distribute #-}--instance Representable V3 where- type Rep V3 = E3- tabulate f = V3 (f E31) (f E32) (f E33)- {-# INLINE tabulate #-}-- index (V3 x _ _) E31 = x- index (V3 _ y _) E32 = y- index (V3 _ _ z) E33 = z- {-# INLINE index #-}------------------------------------------------------------------------------------ V4 instances-----------------------------------------------------------------------------------instance Show1 V4 where- liftShowsPrec f _ z (V4 a b c d) = showParen (z > 10) $- showString "V4 " . f 11 a . showChar ' ' . f 11 b . showChar ' ' . f 11 c . showChar ' ' . f 11 d--instance Functor V4 where- fmap f (V4 a b c d) = V4 (f a) (f b) (f c) (f d)- {-# INLINE fmap #-}- a <$ _ = V4 a a a a- {-# INLINE (<$) #-}--instance Applicative V4 where- pure = pureRep- liftA2 = liftR2--instance Foldable V4 where- foldMap f (V4 a b c d) = f a <> f b <> f c <> f d- {-# INLINE foldMap #-}- null _ = False- length _ = two + two--instance Foldable1 V4 where- foldMap1 f (V4 a b c d) = f a <> f b <> f c <> f d- {-# INLINE foldMap1 #-}--instance Distributive V4 where- distribute f = V4 (fmap (\(V4 x _ _ _) -> x) f) (fmap (\(V4 _ y _ _) -> y) f) (fmap (\(V4 _ _ z _) -> z) f) (fmap (\(V4 _ _ _ w) -> w) f)- {-# INLINE distribute #-}--instance Representable V4 where- type Rep V4 = E4- tabulate f = V4 (f E41) (f E42) (f E43) (f E44)- {-# INLINE tabulate #-}-- index (V4 x _ _ _) E41 = x- index (V4 _ y _ _) E42 = y- index (V4 _ _ z _) E43 = z- index (V4 _ _ _ w) E44 = w- {-# INLINE index #-}------------------------------------------------------------------------------------- Autogenerated instances-----------------------------------------------------------------------------------#define deriveAdditiveSemigroup(ty) \-instance (Additive-Semigroup) a => Semigroup (Additive (ty a)) where { \- (<>) = liftA2 $ mzipWithRep (+) \-; {-# INLINE (<>) #-} \-}--#define deriveAdditiveMonoid(ty) \-instance (Additive-Monoid) a => Monoid (Additive (ty a)) where { \- mempty = pure $ pureRep zero \-; {-# INLINE mempty #-} \-}--#define deriveMultiplicativeSemigroup(ty) \-instance (Multiplicative-Semigroup) a => Semigroup (Multiplicative (ty a)) where { \- (<>) = liftA2 $ mzipWithRep (*) \-; {-# INLINE (<>) #-} \-}--#define deriveMultiplicativeMonoid(ty) \-instance (Multiplicative-Monoid) a => Monoid (Multiplicative (ty a)) where { \- mempty = pure $ pureRep one \-; {-# INLINE mempty #-} \-}--#define deriveMultiplicativeMatrixSemigroup(ty) \-instance Semiring a => Semigroup (Multiplicative (ty a)) where { \- (<>) = liftA2 $ (.#.) \-; {-# INLINE (<>) #-} \-}--#define deriveMultiplicativeMatrixMonoid(ty) \-instance Semiring a => Monoid (Multiplicative (ty a)) where { \- mempty = pure identity \-; {-# INLINE mempty #-} \-}--#define deriveAdditiveMagma(ty) \-instance (Additive-Group) a => Magma (Additive (ty a)) where { \- (<<) = liftA2 $ mzipWithRep (-) \-; {-# INLINE (<<) #-} \-}--#define deriveAdditiveQuasigroup(ty) \-instance (Additive-Group) a => Quasigroup (Additive (ty a)) \--#define deriveAdditiveLoop(ty) \-instance (Additive-Group) a => Loop (Additive (ty a)) \--#define deriveAdditiveGroup(ty) \-instance (Additive-Group) a => Group (Additive (ty a)) \--#define derivePresemiring(ty) \-instance Semiring a => Presemiring (ty a) \--#define deriveSemiring(ty) \-instance Semiring a => Semiring (ty a) \--#define deriveRing(ty) \-instance Ring a => Ring (ty a) \--#define deriveFreeLeftSemimodule(ty) \-instance Semiring a => LeftSemimodule a (ty a) where { \- lscale = lscaleDef \-; {-# INLINE lscale #-} \-}--#define deriveFreeRightSemimodule(ty) \-instance Semiring a => RightSemimodule a (ty a) where { \- rscale = rscaleDef \-; {-# INLINE rscale #-} \-}--#define deriveFreeBisemimodule(ty) \-instance Semiring a => Bisemimodule a a (ty a) \--#define deriveBisemimodule(tyl, tyr, ty) \-instance Semiring a => Bisemimodule (tyl a) (tyr a) (ty a) \--#define deriveLeftSemimodule(tyl,ty) \-instance Semiring a => LeftSemimodule (tyl a) (ty a) where { \- lscale = (.#.) \-; {-# INLINE lscale #-} \-}--#define deriveRightSemimodule(tyr,ty) \-instance Semiring a => RightSemimodule (tyr a) (ty a) where { \- rscale = flip (.#.) \-; {-# INLINE rscale #-} \-}--#define deriveBisemimodule(tyl, tyr, ty) \-instance Semiring a => Bisemimodule (tyl a) (tyr a) (ty a) \------ V1-deriveAdditiveSemigroup(V1)-deriveAdditiveMonoid(V1)--deriveAdditiveMagma(V1)-deriveAdditiveQuasigroup(V1)-deriveAdditiveLoop(V1)-deriveAdditiveGroup(V1)--deriveFreeLeftSemimodule(V1)-deriveFreeRightSemimodule(V1)-deriveFreeBisemimodule(V1)----- V2-deriveAdditiveSemigroup(V2)-deriveAdditiveMonoid(V2)--deriveAdditiveMagma(V2)-deriveAdditiveQuasigroup(V2)-deriveAdditiveLoop(V2)-deriveAdditiveGroup(V2)--deriveFreeLeftSemimodule(V2)-deriveFreeRightSemimodule(V2)-deriveFreeBisemimodule(V2)----- V3-deriveAdditiveSemigroup(V3)-deriveAdditiveMonoid(V3)--deriveAdditiveMagma(V3)-deriveAdditiveQuasigroup(V3)-deriveAdditiveLoop(V3)-deriveAdditiveGroup(V3)--deriveFreeLeftSemimodule(V3)-deriveFreeRightSemimodule(V3)-deriveFreeBisemimodule(V3)---- V4-deriveAdditiveSemigroup(V4)-deriveAdditiveMonoid(V4)--deriveAdditiveMagma(V4)-deriveAdditiveQuasigroup(V4)-deriveAdditiveLoop(V4)-deriveAdditiveGroup(V4)--deriveFreeLeftSemimodule(V4)-deriveFreeRightSemimodule(V4)-deriveFreeBisemimodule(V4)---- M11-deriveAdditiveSemigroup(M11)-deriveAdditiveMonoid(M11)--deriveAdditiveMagma(M11)-deriveAdditiveQuasigroup(M11)-deriveAdditiveLoop(M11)-deriveAdditiveGroup(M11)--deriveLeftSemimodule(M11, M11)-deriveRightSemimodule(M11, M11)-deriveBisemimodule(M11, M11, M11)--deriveMultiplicativeMatrixSemigroup(M11)-deriveMultiplicativeMatrixMonoid(M11)--derivePresemiring(M11)-deriveSemiring(M11)-deriveRing(M11)---- M21-deriveAdditiveSemigroup(M21)-deriveAdditiveMonoid(M21)--deriveAdditiveMagma(M21)-deriveAdditiveQuasigroup(M21)-deriveAdditiveLoop(M21)-deriveAdditiveGroup(M21)--deriveLeftSemimodule(M22, M21)-deriveRightSemimodule(M11, M21)-deriveBisemimodule(M22, M11, M21)----- M31-deriveAdditiveSemigroup(M31)-deriveAdditiveMonoid(M31)--deriveAdditiveMagma(M31)-deriveAdditiveQuasigroup(M31)-deriveAdditiveLoop(M31)-deriveAdditiveGroup(M31)--deriveLeftSemimodule(M33, M31)-deriveRightSemimodule(M11, M31)-deriveBisemimodule(M33, M11, M31)----- M41-deriveAdditiveSemigroup(M41)-deriveAdditiveMonoid(M41)--deriveAdditiveMagma(M41)-deriveAdditiveQuasigroup(M41)-deriveAdditiveLoop(M41)-deriveAdditiveGroup(M41)--deriveLeftSemimodule(M44, M41)-deriveRightSemimodule(M11, M41)-deriveBisemimodule(M44, M11, M41)----- M12-deriveAdditiveSemigroup(M12)-deriveAdditiveMonoid(M12)--deriveAdditiveMagma(M12)-deriveAdditiveQuasigroup(M12)-deriveAdditiveLoop(M12)-deriveAdditiveGroup(M12)--deriveLeftSemimodule(M11, M12)-deriveRightSemimodule(M22, M12)-deriveBisemimodule(M11, M22, M12)----- M22-deriveAdditiveSemigroup(M22)-deriveAdditiveMonoid(M22)--deriveAdditiveMagma(M22)-deriveAdditiveQuasigroup(M22)-deriveAdditiveLoop(M22)-deriveAdditiveGroup(M22)--deriveLeftSemimodule(M22, M22)-deriveRightSemimodule(M22, M22)-deriveBisemimodule(M22, M22, M22)--deriveMultiplicativeMatrixSemigroup(M22)-deriveMultiplicativeMatrixMonoid(M22)--derivePresemiring(M22)-deriveSemiring(M22)-deriveRing(M22)----- M32-deriveAdditiveSemigroup(M32)-deriveAdditiveMonoid(M32)--deriveAdditiveMagma(M32)-deriveAdditiveQuasigroup(M32)-deriveAdditiveLoop(M32)-deriveAdditiveGroup(M32)--deriveLeftSemimodule(M33, M32)-deriveRightSemimodule(M22, M32)-deriveBisemimodule(M33, M22, M32)----- M42-deriveAdditiveSemigroup(M42)-deriveAdditiveMonoid(M42)--deriveAdditiveMagma(M42)-deriveAdditiveQuasigroup(M42)-deriveAdditiveLoop(M42)-deriveAdditiveGroup(M42)--deriveLeftSemimodule(M44, M42)-deriveRightSemimodule(M22, M42)-deriveBisemimodule(M44, M22, M42)----- M13-deriveAdditiveSemigroup(M13)-deriveAdditiveMonoid(M13)--deriveAdditiveMagma(M13)-deriveAdditiveQuasigroup(M13)-deriveAdditiveLoop(M13)-deriveAdditiveGroup(M13)--deriveLeftSemimodule(M11, M13)-deriveRightSemimodule(M33, M13)-deriveBisemimodule(M11, M33, M13)----- M23-deriveAdditiveSemigroup(M23)-deriveAdditiveMonoid(M23)--deriveAdditiveMagma(M23)-deriveAdditiveQuasigroup(M23)-deriveAdditiveLoop(M23)-deriveAdditiveGroup(M23)--deriveLeftSemimodule(M22, M23)-deriveRightSemimodule(M33, M23)-deriveBisemimodule(M22, M33, M23)----- M33-deriveAdditiveSemigroup(M33)-deriveAdditiveMonoid(M33)--deriveAdditiveMagma(M33)-deriveAdditiveQuasigroup(M33)-deriveAdditiveLoop(M33)-deriveAdditiveGroup(M33)--deriveLeftSemimodule(M33, M33)-deriveRightSemimodule(M33, M33)-deriveBisemimodule(M33, M33, M33)--deriveMultiplicativeMatrixSemigroup(M33)-deriveMultiplicativeMatrixMonoid(M33)--derivePresemiring(M33)-deriveSemiring(M33)-deriveRing(M33)----- M43-deriveAdditiveSemigroup(M43)-deriveAdditiveMonoid(M43)--deriveAdditiveMagma(M43)-deriveAdditiveQuasigroup(M43)-deriveAdditiveLoop(M43)-deriveAdditiveGroup(M43)--deriveLeftSemimodule(M44, M43)-deriveRightSemimodule(M33, M43)-deriveBisemimodule(M44, M33, M43)----- M14-deriveAdditiveSemigroup(M14)-deriveAdditiveMonoid(M14)--deriveAdditiveMagma(M14)-deriveAdditiveQuasigroup(M14)-deriveAdditiveLoop(M14)-deriveAdditiveGroup(M14)--deriveLeftSemimodule(M11, M14)-deriveRightSemimodule(M44, M14)-deriveBisemimodule(M11, M44, M14)----- M24-deriveAdditiveSemigroup(M24)-deriveAdditiveMonoid(M24)--deriveAdditiveMagma(M24)-deriveAdditiveQuasigroup(M24)-deriveAdditiveLoop(M24)-deriveAdditiveGroup(M24)--deriveLeftSemimodule(M22, M24)-deriveRightSemimodule(M44, M24)-deriveBisemimodule(M22, M44, M24)----- M34-deriveAdditiveSemigroup(M34)-deriveAdditiveMonoid(M34)--deriveAdditiveMagma(M34)-deriveAdditiveQuasigroup(M34)-deriveAdditiveLoop(M34)-deriveAdditiveGroup(M34)--deriveLeftSemimodule(M33, M34)-deriveRightSemimodule(M44, M34)-deriveBisemimodule(M33, M44, M34)----- M44-deriveAdditiveSemigroup(M44)-deriveAdditiveMonoid(M44)--deriveAdditiveMagma(M44)-deriveAdditiveQuasigroup(M44)-deriveAdditiveLoop(M44)-deriveAdditiveGroup(M44)--deriveLeftSemimodule(M44, M44)-deriveRightSemimodule(M44, M44)-deriveBisemimodule(M44, M44, M44)--deriveMultiplicativeMatrixSemigroup(M44)-deriveMultiplicativeMatrixMonoid(M44)--derivePresemiring(M44)-deriveSemiring(M44)-deriveRing(M44)+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}++module Data.Semimodule.Free (+ -- * Types+ type Free+ -- * Vectors+ , Vec(..)+ , vmap+ , join+ , init+ , (!*)+ , (*!)+ , (!*!)+ -- * Covectors+ , Cov(..)+ , images+ , cmap+ , cojoin+ , coinit+ , comult+ -- * Linear transformations+ , Lin(..)+ , End + , image+ , invmap+ , augment+ , (!#)+ , (#!)+ , (!#!)+ -- * Dimensional transforms+ , braid+ , cobraid + , split+ , cosplit+ , projl+ , projr+ , compl+ , compr+ , complr+ -- * Algebraic transforms+ , diagonal+ , codiagonal+ , initial+ , coinitial+ , convolve+) where++import safe Control.Applicative+import safe Control.Arrow+import safe Control.Category (Category, (<<<), (>>>))+import safe Control.Monad (MonadPlus(..))+import safe Data.Foldable (foldl')+import safe Data.Functor.Apply+import safe Data.Functor.Contravariant (Contravariant(..))+import safe Data.Functor.Rep+import safe Data.Profunctor+import safe Data.Profunctor.Sieve+import safe Data.Semimodule+import safe Data.Semiring+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 Data.Profunctor.Rep as PR++-------------------------------------------------------------------------------+-- Vectors+-------------------------------------------------------------------------------++infixr 3 `runVec`++-- | A vector in a vector space or free semimodule.+--+-- Equivalent to < https://hackage.haskell.org/package/base/docs/Data-Functor-Contravariant.html#t:Op Op >.+--+-- Vectors transform contravariantly as a function of their bases.+--+-- See < https://en.wikipedia.org/wiki/Covariance_and_contravariance_of_vectors#Definition >.+--+newtype Vec a b = Vec { runVec :: b -> a }++infixr 7 !*++-- | Apply a covector to a vector on the right.+--+(!*) :: Vec a b -> Cov a b -> a +(!*) = flip (*!)++infixl 7 *!++-- | Apply a covector to a vector on the left.+--+(*!) :: Cov a b -> Vec a b -> a+(*!) f = runCov f . runVec++-- | Use a linear transformation to map over a vector space.+--+-- Note that the basis transforms < https://en.wikipedia.org/wiki/Covariant_transformation#Contravariant_transformation > contravariantly.+--+vmap :: Lin a b c -> Vec a c -> Vec a b+vmap f g = Vec $ runLin f (runVec g)++-- | Obtain a vector from a vector on the tensor product space.+--+join :: Algebra a b => Vec a (b, b) -> Vec a b+join = vmap diagonal++-- | Obtain a vector from the unit of a unital algebra.+--+-- @+-- 'init' a = 'vmap' 'initial' ('Vec' $ \_ -> a)+-- @+--+init :: Unital a b => a -> Vec a b+init = Vec . unital++infixr 7 !*!++-- | Multiplication operator on an algebra over a free semimodule.+--+-- >>> flip runVec E22 $ (vec $ V2 1 2) !*! (vec $ V2 7 4)+-- 8+--+-- /Caution/ in general 'mult' needn't be commutative, nor associative.+--+(!*!) :: Algebra a b => Vec a b -> Vec a b -> Vec a b+(!*!) x y = Vec $ joined (\i j -> runVec x i * runVec y j)++-------------------------------------------------------------------------------+-- Covectors+-------------------------------------------------------------------------------+++infixr 3 `runCov`++-- | 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.+--+-- Co-vectors transform covariantly as a function of their bases.+--+-- See < https://en.wikipedia.org/wiki/Covariance_and_contravariance_of_vectors#Definition >.+--+newtype Cov a c = Cov { runCov :: (c -> a) -> a }++-- | Obtain a covector from a linear combination of basis elements.+--+-- >>> images [(2, E31),(3, E32)] !* vec (V3 1 1 1) :: Int+-- 5+--+images :: Semiring a => Foldable f => f (a, c) -> Cov a c+images f = Cov $ \k -> foldl' (\acc (a, c) -> acc + a * k c) zero f ++-- | Use a linear transformation to map over a dual space.+--+-- Note that the basis transforms < https://en.wikipedia.org/wiki/Covariant_transformation covariantly >.+--+cmap :: Lin a b c -> Cov a b -> Cov a c+cmap f g = Cov $ runCov g . runLin f++-- | Obtain a covector from a covector on the tensor product space.+--+cojoin :: Coalgebra a c => Cov a (c, c) -> Cov a c+cojoin = cmap codiagonal++-- | Obtain a covector from the counit of a counital coalgebra.+--+-- @+-- 'coinit' = 'cmap' 'coinitial' ('Cov' $ \f -> f ())+-- @+--+coinit :: Counital a c => Cov a c+coinit = Cov counital++infixr 7 `comult`++-- | Multiplication operator on a coalgebra over a free semimodule.+--+-- >>> flip runCov (e2 1 1) $ comult (cov $ V2 1 2) (cov $ V2 7 4)+-- 11+--+-- /Caution/ in general 'comult' needn't be commutative, nor coassociative.+--+comult :: Coalgebra a c => Cov a c -> Cov a c -> Cov a c+comult (Cov f) (Cov g) = Cov $ \k -> f (\m -> g (cojoined k m))++-------------------------------------------------------------------------------+-- 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.Combinator.tran' where appropriate.+--+newtype Lin a b c = Lin { runLin :: (c -> a) -> b -> a }++-- | An endomorphism over a free semimodule.+--+-- >>> one + two !# V2 1 2 :: V2 Double+-- V2 3.0 6.0+--+type End a b = Lin a b b++-- | Create a 'Lin' 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)]) -> Lin a b c+image f = Lin $ \k b -> sum [ a * k c | (a, c) <- f b ]++-- | 'Lin' is an invariant functor.+--+-- See also < http://comonad.com/reader/2008/rotten-bananas/ >.+--+invmap :: (a1 -> a2) -> (a2 -> a1) -> Lin a1 b c -> Lin a2 b c+invmap f g (Lin t) = Lin $ \x -> t (x >>> g) >>> f++-- | The < https://en.wikipedia.org/wiki/Augmentation_(algebra) augmentation > ring homomorphism.+--+augment :: Semiring a => Lin a b c -> b -> a+augment l = l !# const one++infixr 2 !#++-- | Apply a transformation to a vector.+--+(!#) :: Free f => Free g => Lin a (Rep f) (Rep g) -> g a -> f a+(!#) t = tabulate . runLin t . index++infixl 2 #!++-- | Apply a transformation to a vector.+--+(#!) :: Free f => Free g => g a -> Lin a (Rep f) (Rep g) -> f a+(#!) = flip (!#)++infixr 2 !#!++-- | Compose two transformations.+--+-- '!#!' = '<<<'+--+(!#!) :: Lin a c d -> Lin a b c -> Lin a b d+(!#!) = (C..)++-------------------------------------------------------------------------------+-- Common linear transformations+-------------------------------------------------------------------------------++-- | Swap components of a tensor product.+--+-- This is equivalent to a matrix transpose.+--+braid :: Lin a (b , c) (c , b)+braid = arr swap+{-# INLINE braid #-}++-- | Swap components of a direct sum.+--+cobraid :: Lin a (b + c) (c + b)+cobraid = arr eswap+{-# INLINE cobraid #-}++-- | TODO: Document+--+split :: (b -> (b1 , b2)) -> Lin a b1 c -> Lin a b2 c -> Lin a b c+split f x y = dimap f fst $ x *** y+{-# INLINE split #-}++-- | TODO: Document+--+cosplit :: ((c1 + c2) -> c) -> Lin a b c1 -> Lin a b c2 -> Lin 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 => Lin 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 => Lin 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 => Lin a (Rep f1) (Rep f2) -> Lin a (Rep g1) (Rep g2) -> (f2**g2) a -> (f1**g1) a+complr t1 t2 fg = t1 *** t2 !# fg++-------------------------------------------------------------------------------+-- Algebraic transformations+-------------------------------------------------------------------------------++-- |+--+-- @+-- 'rmap' (\((c1,()),(c2,())) -> (c1,c2)) '$' ('C.id' '***' 'initial') 'C..' 'diagonal' = 'C.id'+-- 'rmap' (\(((),c1),((),c2)) -> (c1,c2)) '$' ('initial' '***' 'C.id') 'C..' 'diagonal' = 'C.id'+-- @+--+diagonal :: Algebra a b => Lin a b (b,b)+diagonal = Lin $ joined . curry++{-++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)))+-}++-- |+--+-- @+-- 'lmap' (\(c1,c2) -> ((c1,()),(c2,()))) '$' ('C.id' '***' 'coinitial') 'C..' 'codiagonal' = 'C.id'+-- 'lmap' (\(c1,c2) -> (((),c1),((),c2))) '$' ('coinitial' '***' 'C.id') 'C..' 'codiagonal' = 'C.id'+-- @+--+codiagonal :: Coalgebra a c => Lin a (c,c) c+codiagonal = Lin $ uncurry . cojoined++-- | TODO: Document+--+initial :: Unital a b => Lin a b ()+initial = Lin $ \k -> unital $ k ()++-- | TODO: Document+--+coinitial :: Counital a c => Lin a () c+coinitial = Lin $ const . counital++{-+λ> 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 => Lin a b c -> Lin a b c -> Lin a b c+convolve f g = codiagonal <<< (f *** g) <<< diagonal++-------------------------------------------------------------------------------+-- Vec instances+-------------------------------------------------------------------------------++addVec :: (Additive-Semigroup) a => Vec a b -> Vec a b -> Vec a b+addVec (Vec f) (Vec g) = Vec $ \b -> f b + g b++subVec :: (Additive-Group) a => Vec a b -> Vec a b -> Vec a b+subVec (Vec f) (Vec g) = Vec $ \b -> f b - g b++instance Contravariant (Vec a) where+ contramap f g = Vec (runVec g . f)++instance Category Vec where+ id = Vec id+ Vec f . Vec g = Vec (g . f)++instance (Additive-Semigroup) a => Semigroup (Additive (Vec a b)) where+ (<>) = liftA2 addVec++instance (Additive-Monoid) a => Monoid (Additive (Vec a b)) where+ mempty = Additive . Vec $ const zero++instance (Additive-Group) a => Magma (Additive (Vec a b)) where+ (<<) = liftA2 subVec++instance (Additive-Group) a => Quasigroup (Additive (Vec a b))+instance (Additive-Group) a => Loop (Additive (Vec a b))+instance (Additive-Group) a => Group (Additive (Vec a b))++instance Semiring a => LeftSemimodule a (Vec a b) where+ lscale a v = Vec $ \b -> a *. runVec v b++instance Semiring a => LeftSemimodule (End a b) (Vec a b) where+ lscale = vmap++instance Semiring a => RightSemimodule a (Vec a b) where+ rscale a v = Vec $ \b -> runVec v b .* a++instance Semiring a => RightSemimodule (End a b) (Vec a b) where+ rscale = vmap++instance Semiring a => Bisemimodule (End a b) (End a b) (Vec a b)++instance Bisemimodule a a a => Bisemimodule a a (Vec a b)++-------------------------------------------------------------------------------+-- Cov instances+-------------------------------------------------------------------------------++instance Functor (Cov a) where+ fmap f m = Cov $ \k -> m `runCov` k . f++instance Applicative (Cov a) where+ pure a = Cov $ \k -> k a+ mf <*> ma = Cov $ \k -> mf `runCov` \f -> ma `runCov` k . f++instance Monad (Cov a) where+ return a = Cov $ \k -> k a+ m >>= f = Cov $ \k -> m `runCov` \a -> f a `runCov` k++instance (Additive-Monoid) a => Alternative (Cov a) where+ Cov m <|> Cov n = Cov $ m + n+ empty = Cov zero++instance (Additive-Monoid) a => MonadPlus (Cov a) where+ Cov m `mplus` Cov n = Cov $ m + n+ mzero = Cov zero+{-+newtype Vect a b = Vect (b -> a)++instance ((Additive-Semigroup) a) => Semigroup (Additive (Vect a b)) where+ Additive (Vect f) <> Additive (Vect g) = Additive . Vect $ \b -> f b + g b+ {-# INLINE (<>) #-}++instance ((Additive-Monoid) a) => Monoid (Additive (Vect a b)) where+ mempty = Additive . Vect $ const zero++instance ((Additive-Group) a) => Magma (Additive (Vect a b)) where+ Additive (Vect f) << Additive (Vect g) = Additive . Vect $ \b -> f b - g b+ {-# INLINE (<<) #-}++instance ((Additive-Group) a) => Quasigroup (Additive (Vect a b))+instance ((Additive-Group) a) => Loop (Additive (Vect a b)) where+instance ((Additive-Group) a) => Group (Additive (Vect a b))+-}++instance (Additive-Semigroup) a => Semigroup (Additive (Cov a b)) where+ (<>) = liftA2 $ \(Cov m) (Cov n) -> Cov $ m + n++instance (Additive-Monoid) a => Monoid (Additive (Cov a b)) where+ mempty = Additive $ Cov zero++instance (Additive-Group) a => Magma (Additive (Cov a b)) where+ (<<) = liftA2 $ \(Cov m) (Cov n) -> Cov $ m - n++instance (Additive-Group) a => Quasigroup (Additive (Cov a b))+instance (Additive-Group) a => Loop (Additive (Cov a b))+instance (Additive-Group) a => Group (Additive (Cov a b))++instance Semiring a => LeftSemimodule a (Cov a b) where+ lscale s m = Cov $ \k -> s *. runCov m k++instance Counital a b => LeftSemimodule (End a b) (Cov a b) where+ lscale = cmap++instance Semiring a => RightSemimodule a (Cov a b) where+ rscale s m = Cov $ \k -> runCov m k .* s++instance Counital a b => RightSemimodule (End a b) (Cov a b) where+ rscale = cmap++instance Counital a b => Bisemimodule (End a b) (End a b) (Cov a b)++instance Bisemimodule a a a => Bisemimodule a a (Cov a b)++-------------------------------------------------------------------------------+-- Lin instances+-------------------------------------------------------------------------------++addLin :: (Additive-Semigroup) a => Lin a b c -> Lin a b c -> Lin a b c+addLin (Lin f) (Lin g) = Lin $ f + g++subLin :: (Additive-Group) a => Lin a b c -> Lin a b c -> Lin a b c+subLin (Lin f) (Lin g) = Lin $ \h -> f h - g h++-- mulLin :: (Multiplicative-Semigroup) a => Lin a b c -> Lin a b c -> Lin a b c+-- mulLin (Lin f) (Lin g) = Lin $ \h -> f h * g h++instance Functor (Lin a b) where+ fmap f m = Lin $ \k -> m !# k . f++instance Category (Lin a) where+ id = Lin id+ Lin f . Lin g = Lin $ g . f++instance Apply (Lin a b) where+ mf <.> ma = Lin $ \k b -> (mf !# \f -> (ma !# k . f) b) b++instance Applicative (Lin a b) where+ pure a = Lin $ \k _ -> k a+ (<*>) = (<.>)++instance Profunctor (Lin a) where+ -- | 'Lin' 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 l r f = arr r <<< f <<< arr l++instance Strong (Lin a) where+ first' = first+ second' = second++instance Choice (Lin a) where+ left' = left+ right' = right++instance Sieve (Lin a) (Cov a) where+ sieve l b = Cov $ \k -> (l !# k) b ++instance PR.Representable (Lin a) where+ type Rep (Lin a) = Cov a+ tabulate f = Lin $ \k b -> runCov (f b) k++instance Monad (Lin a b) where+ return a = Lin $ \k _ -> k a+ m >>= f = Lin $ \k b -> (m !# \a -> (f a !# k) b) b++instance Arrow (Lin a) where+ arr f = Lin (. f)+ first m = Lin $ \k (a,c) -> (m !# \b -> k (b,c)) a+ second m = Lin $ \k (c,a) -> (m !# \b -> k (c,b)) a+ m *** n = Lin $ \k (a,c) -> (m !# \b -> (n !# \d -> k (b,d)) c) a+ m &&& n = Lin $ \k a -> (m !# \b -> (n !# \c -> k (b,c)) a) a++instance ArrowChoice (Lin a) where+ left m = Lin $ \k -> either (m !# k . Left) (k . Right)+ right m = Lin $ \k -> either (k . Left) (m !# k . Right)+ m +++ n = Lin $ \k -> either (m !# k . Left) (n !# k . Right)+ m ||| n = Lin $ \k -> either (m !# k) (n !# k)++instance ArrowApply (Lin a) where+ app = Lin $ \k (f,a) -> (f !# k) a++instance (Additive-Semigroup) a => Semigroup (Additive (Lin a b c)) where+ (<>) = liftA2 addLin++instance (Additive-Monoid) a => Monoid (Additive (Lin a b c)) where+ mempty = pure . Lin $ const zero++instance Presemiring a => Semigroup (Multiplicative (End a b)) where+ (<>) = liftA2 (<<<)++instance Semiring a => Monoid (Multiplicative (End a b)) where+ mempty = pure C.id++instance Presemiring a => Presemiring (End a b)+instance Semiring a => Semiring (End a b)+instance Ring a => Ring (End a b)++ +{-+instance Coalgebra a c => Semigroup (Multiplicative (Lin a b c)) where+ (<>) = liftR2 $ \ f g -> Lin $ \k b -> (f !# \a -> (g !# cojoined k a) b) b++instance Counital a c => Monoid (Multiplicative (Lin a b c)) where+ mempty = pure . Lin $ \k _ -> counital k++instance Coalgebra a c => Presemiring (Lin a b c)+instance Counital a c => Semiring (Lin a b c)+instance (Ring a, Counital a c) => Ring (Lin a b c)+-}++instance Counital a b => LeftSemimodule (Lin a b b) (Lin a b c) where+ -- | Left matrix multiplication+ lscale = (>>>)++instance Semiring a => LeftSemimodule a (Lin a b c) where+ lscale l (Lin m) = Lin $ \k b -> l *. m k b++instance Counital a c => RightSemimodule (Lin a c c) (Lin a b c) where+ -- | Right matrix multiplication+ rscale = (<<<)++instance (Counital a b, Counital a c) => Bisemimodule (Lin a b b) (Lin a c c) (Lin a b c)++instance Semiring a => RightSemimodule a (Lin a b m) where+ rscale r (Lin m) = Lin $ \k b -> m k b .* r++instance Bisemimodule a a a => Bisemimodule a a (Lin a b c)++instance (Additive-Group) a => Magma (Additive (Lin a b c)) where+ (<<) = liftR2 subLin++instance (Additive-Group) a => Quasigroup (Additive (Lin a b c))+instance (Additive-Group) a => Loop (Additive (Lin a b c))+instance (Additive-Group) a => Group (Additive (Lin a b c))++{-+-- | An endomorphism of endomorphisms. +--+-- @ 'Cayley' a = (a -> a) -> (a -> a) @+--+type Cayley a = Lin 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 = Lin $ \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 (Lin f) = f (one +) zero++-- ring homomorphism from a -> a^b+embed :: (Multiplicative-Semigroup) a => (Multiplicative-Monoid) c => (b -> a) -> Lin a b c+embed f = Lin $ \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+-}
− src/Data/Semimodule/Operator.hs
@@ -1,299 +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.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 #-}
src/Data/Semiring.hs view
@@ -8,11 +8,16 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MonoLocalBinds #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-} module Data.Semiring ( -- * Types type (-)+ , type (**) + , type (++) + , type Free -- * Presemirings , type PresemiringLaw, Presemiring , (+), (*)@@ -34,10 +39,12 @@ , type RingLaw, Ring , (-) , subtract, negate, abs, signum- -- * Re-exports- , mreplicate+ -- * Additive , Additive(..)+ -- * Multiplicative , Multiplicative(..)+ -- * Re-exports+ , mreplicate , Magma(..) , Quasigroup , Loop@@ -47,27 +54,51 @@ import safe Control.Applicative import safe Data.Bool import safe Data.Complex+import safe Data.Distributive import safe Data.Either import safe Data.Fixed import safe Data.Foldable as Foldable (Foldable, foldr') import safe Data.Functor.Apply+import safe Data.Functor.Rep+import safe Data.Functor.Compose+import safe Data.Functor.Product+import safe Data.Functor.Contravariant import safe Data.Group import safe Data.Int import safe Data.List.NonEmpty import safe Data.Maybe-import safe Data.Semigroup.Additive as A+import safe Data.Semigroup hiding (Product) import safe Data.Semigroup.Foldable as Foldable1+import safe Data.Ord (Down(..)) import safe Data.Word import safe Foreign.C.Types (CFloat(..),CDouble(..))+import safe GHC.Generics (Generic) import safe GHC.Real hiding (Fractional(..), (^^), (^)) import safe Numeric.Natural-import safe Prelude (Ord(..), Applicative(..), Functor(..), Monoid(..), Semigroup(..), id, (.), ($), Integer, Float, Double)+import safe Prelude (Eq, Ord(..), Show(..), Applicative(..), Functor(..), Monoid(..), Semigroup(..), id, flip, const, (.), ($), Integer, Float, Double) import safe qualified Prelude as P import safe qualified Data.IntMap as IntMap import safe qualified Data.IntSet as IntSet import safe qualified Data.Map as Map import safe qualified Data.Set as Set +-- | Hyphenation operator.+type (g - f) a = f (g a)++infixr 2 **++-- | Tensor product.+--+type (f ** g) = Compose f g++infixr 1 ++++-- | Direct sum.+--+type (f ++ g) = Product f g++type Free = Representable+ ------------------------------------------------------------------------------- -- Presemiring -------------------------------------------------------------------------------@@ -93,6 +124,29 @@ class PresemiringLaw a => Presemiring a +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 (+) #-}+++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 (*) #-}+ ------------------------------------------------------------------------------- -- Presemiring folds -------------------------------------------------------------------------------@@ -189,6 +243,18 @@ -- class (Presemiring a, SemiringLaw a) => Semiring a +-- | Additive unit of a semiring.+--+zero :: (Additive-Monoid) a => a+zero = unAdditive mempty+{-# INLINE zero #-}++-- | Multiplicative unit of a semiring.+--+one :: (Multiplicative-Monoid) a => a+one = unMultiplicative mempty+{-# INLINE one #-}+ -- | -- -- @@@ -334,6 +400,12 @@ negate a = zero - a {-# INLINE negate #-} +-- | Subtract two elements.+--+subtract :: (Additive-Group) a => a -> a -> a+subtract a b = unAdditive (Additive b << Additive a)+{-# INLINE subtract #-}+ -- | Absolute value of an element. -- -- @ 'abs' r = r '*' ('signum' r) @@@ -395,7 +467,8 @@ instance Ring a => Presemiring (Complex a)-instance Presemiring a => Presemiring (r -> a)+instance Presemiring a => Presemiring (e -> a)+--instance Presemiring a => Presemiring (Op a e) instance (Presemiring a, Presemiring b) => Presemiring (Either a b) instance Presemiring a => Presemiring (Maybe a) instance (Additive-Semigroup) a => Presemiring [a]@@ -433,8 +506,9 @@ instance Semiring CFloat instance Semiring CDouble -instance Ring a => Semiring (Complex a)-instance Semiring a => Semiring (r -> a)+--instance Ring a => Semiring (Complex a)+instance Semiring a => Semiring (e -> a)+--instance Semiring a => Semiring (Op a e) instance Semiring a => Semiring (Maybe a) instance (Additive-Monoid) a => Semiring [a] @@ -463,10 +537,753 @@ instance Ring Nano instance Ring Pico --- Unlawful instances instance Ring Float instance Ring Double instance Ring CFloat instance Ring CDouble -instance Ring a => Ring (Complex a)+--instance Ring a => Ring (Complex a)+instance Ring a => Ring (e -> a)+--instance Ring a => Ring (Op a e)++++-------------------------------------------------------------------------------+-- Additive+-------------------------------------------------------------------------------++-- | A commutative 'Semigroup' under '+'.+newtype Additive a = Additive { unAdditive :: a } deriving (Eq, Generic, Ord, Show, Functor)++instance Applicative Additive where+ pure = Additive+ Additive f <*> Additive a = Additive (f a)++instance Distributive Additive where+ distribute = distributeRep+ {-# INLINE distribute #-}++instance Representable Additive where+ type Rep Additive = ()+ tabulate f = Additive (f ())+ {-# INLINE tabulate #-}++ index (Additive x) () = x+ {-# INLINE index #-}++-------------------------------------------------------------------------------+-- Multiplicative+-------------------------------------------------------------------------------+++-- | A (potentially non-commutative) 'Semigroup' under '*'.+newtype Multiplicative a = Multiplicative { unMultiplicative :: a } deriving (Eq, Generic, Ord, Show, Functor)++instance Applicative Multiplicative where+ pure = Multiplicative+ Multiplicative f <*> Multiplicative a = Multiplicative (f a)++instance Distributive Multiplicative where+ distribute = distributeRep+ {-# INLINE distribute #-}++instance Representable Multiplicative where+ type Rep Multiplicative = ()+ tabulate f = Multiplicative (f ())+ {-# INLINE tabulate #-}++ index (Multiplicative x) () = x+ {-# INLINE index #-}+++---------------------------------------------------------------------+-- Additive semigroup instances+---------------------------------------------------------------------++#define deriveAdditiveSemigroup(ty) \+instance Semigroup (Additive ty) where { \+ a <> b = (P.+) <$> a <*> b \+; {-# INLINE (<>) #-} \+}++deriveAdditiveSemigroup(Int)+deriveAdditiveSemigroup(Int8)+deriveAdditiveSemigroup(Int16)+deriveAdditiveSemigroup(Int32)+deriveAdditiveSemigroup(Int64)+deriveAdditiveSemigroup(Integer)++deriveAdditiveSemigroup(Word) --TODO clip these at maxBound to make dioids+deriveAdditiveSemigroup(Word8)+deriveAdditiveSemigroup(Word16)+deriveAdditiveSemigroup(Word32)+deriveAdditiveSemigroup(Word64)+deriveAdditiveSemigroup(Natural)++deriveAdditiveSemigroup(Uni)+deriveAdditiveSemigroup(Deci)+deriveAdditiveSemigroup(Centi)+deriveAdditiveSemigroup(Milli)+deriveAdditiveSemigroup(Micro)+deriveAdditiveSemigroup(Nano)+deriveAdditiveSemigroup(Pico)++deriveAdditiveSemigroup(Float)+deriveAdditiveSemigroup(CFloat)+deriveAdditiveSemigroup(Double)+deriveAdditiveSemigroup(CDouble)++#define deriveAdditiveMonoid(ty) \+instance Monoid (Additive ty) where { \+ mempty = pure 0 \+; {-# INLINE mempty #-} \+}++deriveAdditiveMonoid(Int)+deriveAdditiveMonoid(Int8)+deriveAdditiveMonoid(Int16)+deriveAdditiveMonoid(Int32)+deriveAdditiveMonoid(Int64)+deriveAdditiveMonoid(Integer)++deriveAdditiveMonoid(Word)+deriveAdditiveMonoid(Word8)+deriveAdditiveMonoid(Word16)+deriveAdditiveMonoid(Word32)+deriveAdditiveMonoid(Word64)+deriveAdditiveMonoid(Natural)++deriveAdditiveMonoid(Uni)+deriveAdditiveMonoid(Deci)+deriveAdditiveMonoid(Centi)+deriveAdditiveMonoid(Milli)+deriveAdditiveMonoid(Micro)+deriveAdditiveMonoid(Nano)+deriveAdditiveMonoid(Pico)++deriveAdditiveMonoid(Float)+deriveAdditiveMonoid(CFloat)+deriveAdditiveMonoid(Double)+deriveAdditiveMonoid(CDouble)++#define deriveAdditiveMagma(ty) \+instance Magma (Additive ty) where { \+ a << b = (P.-) <$> a <*> b \+; {-# INLINE (<<) #-} \+}++deriveAdditiveMagma(Int)+deriveAdditiveMagma(Int8)+deriveAdditiveMagma(Int16)+deriveAdditiveMagma(Int32)+deriveAdditiveMagma(Int64)+deriveAdditiveMagma(Integer)++deriveAdditiveMagma(Uni)+deriveAdditiveMagma(Deci)+deriveAdditiveMagma(Centi)+deriveAdditiveMagma(Milli)+deriveAdditiveMagma(Micro)+deriveAdditiveMagma(Nano)+deriveAdditiveMagma(Pico)++deriveAdditiveMagma(Float)+deriveAdditiveMagma(CFloat)+deriveAdditiveMagma(Double)+deriveAdditiveMagma(CDouble)++#define deriveAdditiveQuasigroup(ty) \+instance Quasigroup (Additive ty) where { \+}++deriveAdditiveQuasigroup(Int)+deriveAdditiveQuasigroup(Int8)+deriveAdditiveQuasigroup(Int16)+deriveAdditiveQuasigroup(Int32)+deriveAdditiveQuasigroup(Int64)+deriveAdditiveQuasigroup(Integer)++deriveAdditiveQuasigroup(Uni)+deriveAdditiveQuasigroup(Deci)+deriveAdditiveQuasigroup(Centi)+deriveAdditiveQuasigroup(Milli)+deriveAdditiveQuasigroup(Micro)+deriveAdditiveQuasigroup(Nano)+deriveAdditiveQuasigroup(Pico)++deriveAdditiveQuasigroup(Float)+deriveAdditiveQuasigroup(CFloat)+deriveAdditiveQuasigroup(Double)+deriveAdditiveQuasigroup(CDouble)++#define deriveAdditiveLoop(ty) \+instance Loop (Additive ty) where { \+ lreplicate n (Additive a) = Additive $ P.fromIntegral n * (-a) \+; {-# INLINE lreplicate #-} \+}++deriveAdditiveLoop(Int)+deriveAdditiveLoop(Int8)+deriveAdditiveLoop(Int16)+deriveAdditiveLoop(Int32)+deriveAdditiveLoop(Int64)+deriveAdditiveLoop(Integer)++deriveAdditiveLoop(Uni)+deriveAdditiveLoop(Deci)+deriveAdditiveLoop(Centi)+deriveAdditiveLoop(Milli)+deriveAdditiveLoop(Micro)+deriveAdditiveLoop(Nano)+deriveAdditiveLoop(Pico)++deriveAdditiveLoop(Float)+deriveAdditiveLoop(CFloat)+deriveAdditiveLoop(Double)+deriveAdditiveLoop(CDouble)++#define deriveAdditiveGroup(ty) \+instance Group (Additive ty) where { \+ greplicate n (Additive a) = Additive $ P.fromInteger n * a \+; {-# INLINE greplicate #-} \+}++deriveAdditiveGroup(Int)+deriveAdditiveGroup(Int8)+deriveAdditiveGroup(Int16)+deriveAdditiveGroup(Int32)+deriveAdditiveGroup(Int64)+deriveAdditiveGroup(Integer)++deriveAdditiveGroup(Uni)+deriveAdditiveGroup(Deci)+deriveAdditiveGroup(Centi)+deriveAdditiveGroup(Milli)+deriveAdditiveGroup(Micro)+deriveAdditiveGroup(Nano)+deriveAdditiveGroup(Pico)++deriveAdditiveGroup(Float)+deriveAdditiveGroup(CFloat)+deriveAdditiveGroup(Double)+deriveAdditiveGroup(CDouble)+++instance ((Additive-Semigroup) a, Free f, Free g) => Semigroup (Additive ((f++g) a)) where+ (<>) = liftA2 $ mzipWithRep (+)+ {-# INLINE (<>) #-}++instance ((Additive-Monoid) a, Free f, Free g) => Monoid (Additive ((f++g) a)) where+ mempty = pure $ pureRep zero + {-# INLINE mempty #-}++instance ((Additive-Group) a, Free f, Free g) => Magma (Additive ((f++g) a)) where+ (<<) = liftA2 $ mzipWithRep (-)+ {-# INLINE (<<) #-}++instance ((Additive-Group) a, Free f, Free g) => Quasigroup (Additive ((f++g) a))+instance ((Additive-Group) a, Free f, Free g) => Loop (Additive ((f++g) a))+instance ((Additive-Group) a, Free f, Free g) => Group (Additive ((f++g) a))++instance ((Additive-Semigroup) a, Free f, Free g) => Semigroup (Additive ((f**g) a)) where+ (<>) = liftA2 $ mzipWithRep (+)+ {-# INLINE (<>) #-}++instance ((Additive-Monoid) a, Free f, Free g) => Monoid (Additive ((f**g) a)) where+ mempty = pure $ pureRep zero + {-# INLINE mempty #-}++instance ((Additive-Group) a, Free f, Free g) => Magma (Additive ((f**g) a)) where+ (<<) = liftA2 $ mzipWithRep (-)+ {-# INLINE (<<) #-}++instance ((Additive-Group) a, Free f, Free g) => Quasigroup (Additive ((f**g) a))+instance ((Additive-Group) a, Free f, Free g) => Loop (Additive ((f**g) a))+instance ((Additive-Group) a, Free f, Free g) => Group (Additive ((f**g) a))++instance (Additive-Semigroup) a => Semigroup (Additive (Complex a)) where+ Additive (a :+ b) <> Additive (c :+ d) = Additive $ (a + b) :+ (c + d)+ {-# INLINE (<>) #-}++instance (Additive-Monoid) a => Monoid (Additive (Complex a)) where+ mempty = Additive $ zero :+ zero++instance (Additive-Group) a => Magma (Additive (Complex a)) where+ Additive (a :+ b) << Additive (c :+ d) = Additive $ (subtract c a) :+ (subtract d b)+ {-# INLINE (<<) #-}++instance (Additive-Group) a => Quasigroup (Additive (Complex a))++instance (Additive-Group) a => Loop (Additive (Complex a)) where+ lreplicate n = mreplicate n . inv++instance (Additive-Group) a => Group (Additive (Complex a))++-- type Rng a = ((Additive-Group) a, (Multiplicative-Semigroup) a)+instance ((Additive-Group) a, (Multiplicative-Semigroup) a) => Semigroup (Multiplicative (Complex a)) where+ Multiplicative (a :+ b) <> Multiplicative (c :+ d) = Multiplicative $ (subtract (b * d) (a * c)) :+ (a * d + b * c)+ {-# INLINE (<>) #-}++{-+-- type Ring a = ((Additive-Group) a, (Multiplicative-Monoid) a)+instance ((Additive-Group) a, (Multiplicative-Monoid) a) => Monoid (Multiplicative (Complex a)) where+ mempty = Multiplicative $ one :+ zero++instance ((Additive-Group) a, (Multiplicative-Group) a) => Magma (Multiplicative (Complex a)) where+ Multiplicative (a :+ b) << Multiplicative (c :+ d) = Multiplicative $ ((a * c + b * d) / (c * c + d * d)) :+ ((subtract (a * d) (b * c)) / (c * c + d * d))+ {-# INLINE (<<) #-}++instance ((Additive-Group) a, (Multiplicative-Group) a) => Quasigroup (Multiplicative (Complex a))++instance ((Additive-Group) a, (Multiplicative-Group) a) => Loop (Multiplicative (Complex a)) where+ lreplicate n = mreplicate n . inv++instance ((Additive-Group) a, (Multiplicative-Group) a) => Group (Multiplicative (Complex a))+-}++instance ((Additive-Semigroup) a, (Multiplicative-Semigroup) a) => Semigroup (Additive (Ratio a)) where+ Additive (a :% b) <> Additive (c :% d) = Additive $ (a * d + c * b) :% (b * d)+ {-# INLINE (<>) #-}++instance ((Additive-Monoid) a, (Multiplicative-Monoid) a) => Monoid (Additive (Ratio a)) where+ mempty = Additive $ zero :% one++instance ((Additive-Group) a, (Multiplicative-Monoid) a) => Magma (Additive (Ratio a)) where+ Additive (a :% b) << Additive (c :% d) = Additive $ (subtract (c * b) (a * d)) :% (b * d)+ {-# INLINE (<<) #-}++instance ((Additive-Group) a, (Multiplicative-Monoid) a) => Quasigroup (Additive (Ratio a))++instance ((Additive-Group) a, (Multiplicative-Monoid) a) => Loop (Additive (Ratio a)) where+ lreplicate n = mreplicate n . inv++instance ((Additive-Group) a, (Multiplicative-Monoid) a) => Group (Additive (Ratio a))++instance (Additive-Semigroup) b => Semigroup (Additive (a -> b)) where+ (<>) = liftA2 . liftA2 $ (+)+ {-# INLINE (<>) #-}++instance (Additive-Monoid) b => Monoid (Additive (a -> b)) where+ mempty = pure . pure $ zero++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-Semigroup) a) => Semigroup (Additive (Op a b)) where+ Additive (Op f) <> Additive (Op g) = Additive . Op $ \b -> f b + g b+ {-# INLINE (<>) #-}++instance ((Additive-Monoid) a) => Monoid (Additive (Op a b)) where+ mempty = Additive . Op $ const zero++instance ((Additive-Group) a) => Magma (Additive (Op a b)) where+ Additive (Op f) << Additive (Op g) = Additive . Op $ \b -> f b - g b+ {-# INLINE (<<) #-}++instance ((Additive-Group) a) => Quasigroup (Additive (Op a b))+instance ((Additive-Group) a) => Loop (Additive (Op a b)) where+instance ((Additive-Group) a) => Group (Additive (Op a b))++instance Semigroup (Additive [a]) where+ (<>) = liftA2 (<>)++instance Monoid (Additive [a]) where+ mempty = pure mempty++-- >>> [1, 2] * [3, 4]+-- [4,5,5,6]+instance (Additive-Semigroup) a => Semigroup (Multiplicative [a]) where + (<>) = liftA2 . liftA2 $ (+) + {-# INLINE (<>) #-}++instance (Additive-Monoid) a => Monoid (Multiplicative [a]) where + mempty = pure [zero]++-- >>> (1 :| [2 :: Int]) * (3 :| [4 :: Int])+-- 4 :| [5,5,6]+instance Semigroup (Additive (NonEmpty a)) where+ (<>) = liftA2 (<>)++instance (Additive-Semigroup) a => Semigroup (Multiplicative (NonEmpty a)) where+ (<>) = liftA2 (+) + {-# INLINE (<>) #-}++++-- MinPlus Predioid+-- >>> Min 1 * Min 2 :: Min Int+-- Min {getMin = 3}+instance (Additive-Semigroup) a => Semigroup (Multiplicative (Min a)) where+ Multiplicative a <> Multiplicative b = Multiplicative $ liftA2 (+) a b++-- MinPlus Dioid+instance (Additive-Monoid) a => Monoid (Multiplicative (Min a)) where+ mempty = Multiplicative $ pure zero++instance (Additive-Semigroup) a => Semigroup (Additive (Down a)) where+ (<>) = liftA2 . liftA2 $ (+) ++instance (Additive-Monoid) a => Monoid (Additive (Down a)) where+ --Additive (Down a) <> Additive (Down b)+ mempty = pure . pure $ zero++++instance Semigroup (Additive ()) where+ _ <> _ = pure ()+ {-# INLINE (<>) #-}++instance Monoid (Additive ()) where+ mempty = pure ()+ {-# INLINE mempty #-}++instance Magma (Additive ()) where+ _ << _ = pure ()++instance Quasigroup (Additive ()) ++instance Loop (Additive ()) ++instance Group (Additive ()) ++instance Semigroup (Additive Bool) where+ a <> b = (P.||) <$> a <*> b+ {-# INLINE (<>) #-}++instance Monoid (Additive Bool) where+ mempty = pure False+ {-# INLINE mempty #-}++--instance ((Additive-Semigroup) a, Minimal a) => Monoid (Additive a) where+-- mempty = Additive minimal++-- instance (Meet-Monoid) (Down a) => Monoid (Meet (Down a)) where mempty = Down <$> mempty++instance ((Additive-Semigroup) a, (Additive-Semigroup) b) => Semigroup (Additive (a, b)) where+ (<>) = liftA2 $ \(x1,y1) (x2,y2) -> (x1+x2, y1+y2)++instance ((Additive-Monoid) a, (Additive-Monoid) b) => Monoid (Additive (a, b)) where+ mempty = pure (zero, zero)++instance ((Additive-Semigroup) a, (Additive-Semigroup) b, (Additive-Semigroup) c) => Semigroup (Additive (a, b, c)) where+ (<>) = liftA2 $ \(x1,y1,z1) (x2,y2,z2) -> (x1+x2, y1+y2, z1+z2)++instance ((Additive-Monoid) a, (Additive-Monoid) b, (Additive-Monoid) c) => Monoid (Additive (a, b, c)) where+ mempty = pure (zero, zero, zero)++instance (Additive-Semigroup) a => Semigroup (Additive (Maybe a)) where+ Additive (Just x) <> Additive (Just y) = Additive . Just $ x + y+ Additive (x@Just{}) <> _ = Additive x+ Additive Nothing <> y = y++instance (Additive-Semigroup) a => Monoid (Additive (Maybe a)) where+ mempty = Additive Nothing++instance ((Additive-Semigroup) a, (Additive-Semigroup) b) => Semigroup (Additive (Either a b)) where+ Additive (Right x) <> Additive (Right y) = Additive . Right $ x + y++ Additive(x@Right{}) <> _ = Additive x+ Additive (Left x) <> Additive (Left y) = Additive . Left $ x + y+ Additive (Left _) <> y = y++instance Ord a => Semigroup (Additive (Set.Set a)) where+ (<>) = liftA2 Set.union ++instance (Ord k, (Additive-Semigroup) a) => Semigroup (Additive (Map.Map k a)) where+ (<>) = liftA2 (Map.unionWith (+))++instance (Additive-Semigroup) a => Semigroup (Additive (IntMap.IntMap a)) where+ (<>) = liftA2 (IntMap.unionWith (+))++instance Semigroup (Additive IntSet.IntSet) where+ (<>) = liftA2 IntSet.union ++instance Monoid (Additive IntSet.IntSet) where+ mempty = Additive IntSet.empty++instance (Additive-Semigroup) a => Monoid (Additive (IntMap.IntMap a)) where+ mempty = Additive IntMap.empty++instance Ord a => Monoid (Additive (Set.Set a)) where+ mempty = Additive Set.empty++instance (Ord k, (Additive-Semigroup) a) => Monoid (Additive (Map.Map k a)) where+ mempty = Additive Map.empty+++++---------------------------------------------------------------------+-- Multiplicative Semigroup Instances+---------------------------------------------------------------------++#define deriveMultiplicativeSemigroup(ty) \+instance Semigroup (Multiplicative ty) where { \+ a <> b = (P.*) <$> a <*> b \+; {-# INLINE (<>) #-} \+}++deriveMultiplicativeSemigroup(Int)+deriveMultiplicativeSemigroup(Int8)+deriveMultiplicativeSemigroup(Int16)+deriveMultiplicativeSemigroup(Int32)+deriveMultiplicativeSemigroup(Int64)+deriveMultiplicativeSemigroup(Integer)++deriveMultiplicativeSemigroup(Word)+deriveMultiplicativeSemigroup(Word8)+deriveMultiplicativeSemigroup(Word16)+deriveMultiplicativeSemigroup(Word32)+deriveMultiplicativeSemigroup(Word64)+deriveMultiplicativeSemigroup(Natural)++deriveMultiplicativeSemigroup(Uni)+deriveMultiplicativeSemigroup(Deci)+deriveMultiplicativeSemigroup(Centi)+deriveMultiplicativeSemigroup(Milli)+deriveMultiplicativeSemigroup(Micro)+deriveMultiplicativeSemigroup(Nano)+deriveMultiplicativeSemigroup(Pico)++deriveMultiplicativeSemigroup(Float)+deriveMultiplicativeSemigroup(CFloat)+deriveMultiplicativeSemigroup(Double)+deriveMultiplicativeSemigroup(CDouble)++#define deriveMultiplicativeMonoid(ty) \+instance Monoid (Multiplicative ty) where { \+ mempty = pure 1 \+; {-# INLINE mempty #-} \+}++deriveMultiplicativeMonoid(Int)+deriveMultiplicativeMonoid(Int8)+deriveMultiplicativeMonoid(Int16)+deriveMultiplicativeMonoid(Int32)+deriveMultiplicativeMonoid(Int64)+deriveMultiplicativeMonoid(Integer)++deriveMultiplicativeMonoid(Word)+deriveMultiplicativeMonoid(Word8)+deriveMultiplicativeMonoid(Word16)+deriveMultiplicativeMonoid(Word32)+deriveMultiplicativeMonoid(Word64)+deriveMultiplicativeMonoid(Natural)++deriveMultiplicativeMonoid(Uni)+deriveMultiplicativeMonoid(Deci)+deriveMultiplicativeMonoid(Centi)+deriveMultiplicativeMonoid(Milli)+deriveMultiplicativeMonoid(Micro)+deriveMultiplicativeMonoid(Nano)+deriveMultiplicativeMonoid(Pico)++deriveMultiplicativeMonoid(Float)+deriveMultiplicativeMonoid(CFloat)+deriveMultiplicativeMonoid(Double)+deriveMultiplicativeMonoid(CDouble)++#define deriveMultiplicativeMagma(ty) \+instance Magma (Multiplicative ty) where { \+ a << b = (P./) <$> a <*> b \+; {-# INLINE (<<) #-} \+}++deriveMultiplicativeMagma(Uni)+deriveMultiplicativeMagma(Deci)+deriveMultiplicativeMagma(Centi)+deriveMultiplicativeMagma(Milli)+deriveMultiplicativeMagma(Micro)+deriveMultiplicativeMagma(Nano)+deriveMultiplicativeMagma(Pico)++deriveMultiplicativeMagma(Float)+deriveMultiplicativeMagma(CFloat)+deriveMultiplicativeMagma(Double)+deriveMultiplicativeMagma(CDouble)++#define deriveMultiplicativeQuasigroup(ty) \+instance Quasigroup (Multiplicative ty) where { \+}++deriveMultiplicativeQuasigroup(Uni)+deriveMultiplicativeQuasigroup(Deci)+deriveMultiplicativeQuasigroup(Centi)+deriveMultiplicativeQuasigroup(Milli)+deriveMultiplicativeQuasigroup(Micro)+deriveMultiplicativeQuasigroup(Nano)+deriveMultiplicativeQuasigroup(Pico)++deriveMultiplicativeQuasigroup(Float)+deriveMultiplicativeQuasigroup(CFloat)+deriveMultiplicativeQuasigroup(Double)+deriveMultiplicativeQuasigroup(CDouble)++#define deriveMultiplicativeLoop(ty) \+instance Loop (Multiplicative ty) where { \+ lreplicate n = mreplicate n . inv \+}++deriveMultiplicativeLoop(Uni)+deriveMultiplicativeLoop(Deci)+deriveMultiplicativeLoop(Centi)+deriveMultiplicativeLoop(Milli)+deriveMultiplicativeLoop(Micro)+deriveMultiplicativeLoop(Nano)+deriveMultiplicativeLoop(Pico)++deriveMultiplicativeLoop(Float)+deriveMultiplicativeLoop(CFloat)+deriveMultiplicativeLoop(Double)+deriveMultiplicativeLoop(CDouble)++#define deriveMultiplicativeGroup(ty) \+instance Group (Multiplicative ty) where { \+ greplicate n (Multiplicative a) = Multiplicative $ a P.^^ P.fromInteger n \+; {-# INLINE greplicate #-} \+}++deriveMultiplicativeGroup(Uni)+deriveMultiplicativeGroup(Deci)+deriveMultiplicativeGroup(Centi)+deriveMultiplicativeGroup(Milli)+deriveMultiplicativeGroup(Micro)+deriveMultiplicativeGroup(Nano)+deriveMultiplicativeGroup(Pico)++deriveMultiplicativeGroup(Float)+deriveMultiplicativeGroup(CFloat)+deriveMultiplicativeGroup(Double)+deriveMultiplicativeGroup(CDouble)++++instance (Multiplicative-Semigroup) a => Semigroup (Multiplicative (Ratio a)) where+ Multiplicative (a :% b) <> Multiplicative (c :% d) = Multiplicative $ (a * c) :% (b * d)+ {-# INLINE (<>) #-}++instance (Multiplicative-Monoid) a => Monoid (Multiplicative (Ratio a)) where+ mempty = Multiplicative $ unMultiplicative mempty :% unMultiplicative mempty++instance (Multiplicative-Monoid) a => Magma (Multiplicative (Ratio a)) where+ Multiplicative (a :% b) << Multiplicative (c :% d) = Multiplicative $ (a * d) :% (b * c)+ {-# INLINE (<<) #-}++instance (Multiplicative-Monoid) a => Quasigroup (Multiplicative (Ratio a))++instance (Multiplicative-Monoid) a => Loop (Multiplicative (Ratio a)) where+ lreplicate n = mreplicate n . inv++instance (Multiplicative-Monoid) a => Group (Multiplicative (Ratio a))+++---------------------------------------------------------------------+-- Misc+---------------------------------------------------------------------++--instance ((Multiplicative-Semigroup) a, Maximal a) => Monoid (Multiplicative a) where+-- mempty = Multiplicative maximal++instance Semigroup (Multiplicative ()) where+ _ <> _ = pure ()+ {-# INLINE (<>) #-}++instance Monoid (Multiplicative ()) where+ mempty = pure ()+ {-# INLINE mempty #-}++instance Magma (Multiplicative ()) where+ _ << _ = pure ()+ {-# INLINE (<<) #-}++instance Quasigroup (Multiplicative ())++instance Loop (Multiplicative ())++instance Group (Multiplicative ())++instance Semigroup (Multiplicative Bool) where+ a <> b = (P.&&) <$> a <*> b+ {-# INLINE (<>) #-}++instance Monoid (Multiplicative Bool) where+ mempty = pure True+ {-# INLINE mempty #-}++instance (Multiplicative-Semigroup) a => Semigroup (Multiplicative (Dual a)) where+ (<>) = liftA2 . liftA2 $ flip (*)++instance (Multiplicative-Monoid) a => Monoid (Multiplicative (Dual a)) where+ mempty = pure . pure $ one++instance (Multiplicative-Semigroup) a => Semigroup (Multiplicative (Down a)) where+ --Additive (Down a) <> Additive (Down b)+ (<>) = liftA2 . liftA2 $ (*) ++instance (Multiplicative-Monoid) a => Monoid (Multiplicative (Down a)) where+ mempty = pure . pure $ one++-- MaxTimes Predioid++instance (Multiplicative-Semigroup) a => Semigroup (Multiplicative (Max a)) where+ Multiplicative a <> Multiplicative b = Multiplicative $ liftA2 (*) a b++-- MaxTimes Dioid+instance (Multiplicative-Monoid) a => Monoid (Multiplicative (Max a)) where+ mempty = Multiplicative $ pure one++instance ((Multiplicative-Semigroup) a, (Multiplicative-Semigroup) b) => Semigroup (Multiplicative (a, b)) where+ Multiplicative (x1, y1) <> Multiplicative (x2, y2) = Multiplicative (x1 * x2, y1 * y2)++instance (Multiplicative-Semigroup) b => Semigroup (Multiplicative (a -> b)) where+ (<>) = liftA2 . liftA2 $ (*)+ {-# INLINE (<>) #-}++instance (Multiplicative-Monoid) b => Monoid (Multiplicative (a -> b)) where+ mempty = pure . pure $ one++{-+instance ((Multiplicative-Semigroup) a) => Semigroup (Multiplicative (Op a b)) where+ Multiplicative (Op f) <> Multiplicative (Op g) = Multiplicative . Op $ \b -> f b * g b+ {-# INLINE (<>) #-}++instance ((Multiplicative-Monoid) a) => Monoid (Multiplicative (Op a b)) where+ mempty = Multiplicative . Op $ const one+-}++instance (Multiplicative-Semigroup) a => Semigroup (Multiplicative (Maybe a)) where+ Multiplicative Nothing <> _ = Multiplicative Nothing+ Multiplicative (Just{}) <> Multiplicative Nothing = Multiplicative Nothing+ Multiplicative (Just x) <> Multiplicative (Just y) = Multiplicative . Just $ x * y+ -- Mul a <> Mul b = Mul $ liftA2 (*) a b++instance (Multiplicative-Monoid) a => Monoid (Multiplicative (Maybe a)) where+ mempty = Multiplicative $ pure one++instance ((Multiplicative-Semigroup) a, (Multiplicative-Semigroup) b) => Semigroup (Multiplicative (Either a b)) where+ Multiplicative (Right x) <> Multiplicative (Right y) = Multiplicative . Right $ x * y+ Multiplicative (Right{}) <> y = y+ Multiplicative (Left x) <> Multiplicative (Left y) = Multiplicative . Left $ x * y+ Multiplicative (x@Left{}) <> _ = Multiplicative x++instance Ord a => Semigroup (Multiplicative (Set.Set a)) where+ (<>) = liftA2 Set.intersection ++instance (Ord k, (Multiplicative-Semigroup) a) => Semigroup (Multiplicative (Map.Map k a)) where+ (<>) = liftA2 (Map.intersectionWith (*))++instance (Multiplicative-Semigroup) a => Semigroup (Multiplicative (IntMap.IntMap a)) where+ (<>) = liftA2 (IntMap.intersectionWith (*))++instance Semigroup (Multiplicative IntSet.IntSet) where+ (<>) = liftA2 IntSet.intersection ++instance (Ord k, (Multiplicative-Monoid) k, (Multiplicative-Monoid) a) => Monoid (Multiplicative (Map.Map k a)) where+ mempty = Multiplicative $ Map.singleton one one++instance (Multiplicative-Monoid) a => Monoid (Multiplicative (IntMap.IntMap a)) where+ mempty = Multiplicative $ IntMap.singleton 0 one
src/Data/Semiring/Property.hs view
@@ -1,4 +1,6 @@ {-# Language AllowAmbiguousTypes #-}+{-# LANGUAGE Safe #-}+ -- | See the /connections/ package for idempotent & selective semirings, and lattices. module Data.Semiring.Property ( -- * Required properties of pre-semirings@@ -9,13 +11,17 @@ , associative_multiplication_on , distributive_on , distributive_finite1_on+ , morphism_additive_on+ , morphism_multiplicative_on , morphism_distribitive_on -- * Required properties of semirings- , morphism_semiring , neutral_addition_on , neutral_multiplication_on , annihilative_multiplication_on , distributive_finite_on+ , morphism_additive_on'+ , morphism_multiplicative_on'+ , morphism_semiring -- * Left-distributive presemirings and semirings , distributive_xmult_on , distributive_xmult1_on@@ -24,20 +30,26 @@ -- * Cancellative presemirings & semirings , cancellative_addition_on , cancellative_multiplication_on + -- * Properties of idempotent semigroups+ , idempotent_addition_on+ , idempotent_multiplication_on ) where -import Data.Semiring-import Test.Logic (Rel)-import Data.Foldable (Foldable)-import Data.Functor.Apply (Apply)-import Data.Semigroup.Foldable (Foldable1)-import Data.Semigroup.Property-import qualified Test.Operation as Prop+import safe Data.Semiring+import safe Test.Logic (Rel)+import safe Data.Foldable (Foldable)+import safe Data.Functor.Apply (Apply)+import safe Data.Semigroup.Foldable (Foldable1)+--import Data.Semigroup.Property+import safe qualified Test.Operation as Prop -import Prelude hiding (Num(..), sum)+import safe Prelude hiding (Num(..), sum) +import safe qualified Test.Function as Prop+--import safe qualified Test.Operation as Prop hiding (distributive_on) + ------------------------------------------------------------------------------------ -- Required properties of pre-semirings & semirings @@ -159,3 +171,163 @@ -- distributive_xmult1_on :: Presemiring r => Apply f => Foldable1 f => Rel r b -> f r -> f r -> b distributive_xmult1_on (~~) as bs = (sum1 as * sum1 bs) ~~ (xmult1 as bs)++++++------------------------------------------------------------------------------------+-- Required properties of semigroups++-- | \( \forall a, b, c \in R: (a + b) + c \sim a + (b + c) \)+--+-- A semigroup must right-associate addition.+--+-- 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) \)+--+-- A semigroup must right-associate multiplication.+--+-- 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 (~~) (*) ++------------------------------------------------------------------------------------+-- Required properties of monoids++-- | \( \forall a \in R: (z + a) \sim a \)+--+-- A semigroup with a right-neutral additive identity must satisfy:+--+-- @+-- 'neutral_addition_on' ('==') 'zero' r = 'True'+-- @+-- +-- Or, equivalently:+--+-- @+-- 'zero' '+' r = r+-- @+--+-- This is a required property for additive monoids.+--+neutral_addition_on :: (Additive-Monoid) r => Rel r b -> r -> b+neutral_addition_on (~~) = Prop.neutral_on (~~) (+) zero++-- | \( \forall a \in R: (o * a) \sim a \)+--+-- A semigroup with a right-neutral multiplicative identity must satisfy:+--+-- @+-- 'neutral_multiplication_on' ('==') 'one' r = 'True'+-- @+-- +-- Or, equivalently:+--+-- @+-- 'one' '*' r = r+-- @+--+-- 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++------------------------------------------------------------------------------------+-- Properties of commutative semigroups++-- | \( \forall a, b \in R: a + b \sim b + a \)+--+-- 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 and rings.+--+commutative_multiplication_on :: (Multiplicative-Semigroup) r => Rel r b -> r -> r -> b+commutative_multiplication_on (~~) = Prop.commutative_on (~~) (*) ++------------------------------------------------------------------------------------+-- Properties of cancellative semigroups++-- | \( \forall a, b, c \in R: b + a \sim c + a \Rightarrow b = c \)+--+-- If /R/ is right-cancellative wrt addition then for all /a/+-- the section /(a +)/ is injective.+--+-- See < https://en.wikipedia.org/wiki/Cancellation_property >+--+cancellative_addition_on :: (Additive-Semigroup) r => Rel r Bool -> r -> r -> r -> Bool+cancellative_addition_on (~~) a = Prop.injective_on (~~) (+ a)++-- | \( \forall a, b, c \in R: b * a \sim c * a \Rightarrow b = c \)+--+-- If /R/ is right-cancellative wrt multiplication then for all /a/+-- the section /(a *)/ is injective.+--+cancellative_multiplication_on :: (Multiplicative-Semigroup) r => Rel r Bool -> r -> r -> r -> Bool+cancellative_multiplication_on (~~) a = Prop.injective_on (~~) (* a)++------------------------------------------------------------------------------------+-- Properties of idempotent semigroups++-- | Idempotency property for additive semigroups.+--+-- 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+idempotent_addition_on (~~) r = (r + r) ~~ r++-- | Idempotency property for multplicative semigroups.+--+-- 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_multiplication_on :: (Multiplicative-Semigroup) r => Rel r b -> r -> b+idempotent_multiplication_on (~~) r = (r * r) ~~ r++------------------------------------------------------------------------------------+-- 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)++-- |+--+-- 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++-- |+--+-- This is a required property for multiplicative monoid morphisms.+--+morphism_multiplicative_on' :: (Multiplicative-Monoid) r => (Multiplicative-Monoid) s => Rel s b -> (r -> s) -> b+morphism_multiplicative_on' (~~) f = (f one) ~~ one