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