diff --git a/rings.cabal b/rings.cabal --- a/rings.cabal +++ b/rings.cabal @@ -1,5 +1,5 @@ name: rings -version: 0.0.3.1 +version: 0.1 synopsis: Ring-like objects. description: Semirings, rings, division rings, and modules. homepage: https://github.com/cmk/rings @@ -17,14 +17,13 @@ library hs-source-dirs: src default-language: Haskell2010 - ghc-options: -Wall -optc-std=c99 + ghc-options: -Wall exposed-modules: Data.Semiring , Data.Semiring.Property , Data.Semifield , Data.Semigroup.Additive - , Data.Semigroup.Multiplicative , Data.Semigroup.Property , Data.Semimodule , Data.Semimodule.Free @@ -42,14 +41,14 @@ , TypeOperators build-depends: - base >= 4.10 && < 5.0 - , lawz >= 0.1.1 && < 1.0 - , magmas >= 0.0.1 && < 0.1 - , adjunctions >= 4.4 && < 5.0 - , containers >= 0.4.0 && < 0.7 - , distributive >= 0.3 && < 1.0 - , semigroupoids >= 5.0 && < 6.0 - , profunctors >= 5.0 && < 6.0 + base >= 4.10 + , lawz >= 0.1.1 + , adjunctions >= 4.4 + , containers >= 0.4.0 + , distributive >= 0.3 + , semigroupoids >= 0.5 + , profunctors >= 5.0 + , magmas >= 0.0.1 test-suite test type: exitcode-stdio-1.0 diff --git a/src/Data/Semifield.hs b/src/Data/Semifield.hs --- a/src/Data/Semifield.hs +++ b/src/Data/Semifield.hs @@ -23,7 +23,7 @@ import safe Data.Complex import safe Data.Fixed import safe Data.Semiring -import safe Data.Semigroup.Multiplicative +import safe Data.Semigroup.Additive import safe GHC.Real hiding (Real, Fractional(..), (^^), (^), div) import safe Numeric.Natural import safe Foreign.C.Types (CFloat(..),CDouble(..)) @@ -36,19 +36,20 @@ type SemifieldLaw a = ((Additive-Monoid) a, (Multiplicative-Group) a) --- | A semifield, near-field, division ring, or associative division algebra. +-- | A semifield, near-field, or division ring. -- -- Instances needn't have commutative multiplication or additive inverses, --- however addition and multiplication must be associative as usual. +-- however addition must be commutative, and addition and multiplication must +-- be associative as usual. -- -- See also the wikipedia definitions of: -- -- * < https://en.wikipedia.org/wiki/Semifield semifield > -- * < https://en.wikipedia.org/wiki/Near-field_(mathematics) near-field > -- * < https://en.wikipedia.org/wiki/Division_ring division ring > --- * < https://en.wikipedia.org/wiki/Division_algebra division algebra >. -- class (Semiring a, SemifieldLaw a) => Semifield a + -- | The /NaN/ value of the semifield. -- diff --git a/src/Data/Semigroup/Additive.hs b/src/Data/Semigroup/Additive.hs --- a/src/Data/Semigroup/Additive.hs +++ b/src/Data/Semigroup/Additive.hs @@ -9,6 +9,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} module Data.Semigroup.Additive where @@ -25,7 +26,6 @@ import safe Data.List.NonEmpty import safe Data.Ord import safe Data.Semigroup -import safe Data.Semigroup.Multiplicative import safe Data.Word import safe Foreign.C.Types (CFloat(..),CDouble(..)) import safe GHC.Generics (Generic) @@ -34,7 +34,7 @@ import safe Prelude ( Eq(..), Ord(..), Show, Applicative(..), Functor(..), Monoid(..), Semigroup(..) - , (.), ($), (<$>), Integer, Float, Double) + , (.), ($), (<$>), flip, Integer, Float, Double) import safe qualified Prelude as P import safe qualified Data.Map as Map @@ -42,7 +42,12 @@ 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) + + -- | A commutative 'Semigroup' under '+'. newtype Additive a = Additive { unAdditive :: a } deriving (Eq, Generic, Ord, Show, Functor) @@ -58,29 +63,9 @@ a + b = unAdditive (Additive a <> Additive b) {-# INLINE (+) #-} -infixl 6 - - -(-) :: (Additive-Group) a => a -> a -> a -a - b = unAdditive (Additive a << Additive b) -{-# INLINE (-) #-} - -negate :: (Additive-Group) a => a -> a -negate a = zero - a -{-# INLINE negate #-} - --- | Absolute value of an element. --- --- @ 'abs' r = 'mul' r ('signum' r) @ --- --- https://en.wikipedia.org/wiki/Linearly_ordered_group -abs :: (Additive-Group) a => Ord a => a -> a -abs x = bool (negate x) x $ zero <= x -{-# INLINE abs #-} - -------------------------------------------------------------------------------- --- Instances -------------------------------------------------------------------------------- - +subtract :: (Additive-Group) a => a -> a -> a +subtract a b = unAdditive (Additive b << Additive a) +{-# INLINE subtract #-} instance Applicative Additive where pure = Additive @@ -98,76 +83,91 @@ index (Additive x) () = x {-# INLINE index #-} +------------------------------------------------------------------------------- +-- Multiplicative +------------------------------------------------------------------------------- -{- -newtype Ordered a = Ordered { unOrdered :: a } deriving (Eq, Generic, Ord, Show, Functor) +-- | A (potentially non-commutative) 'Semigroup' under '+'. +newtype Multiplicative a = Multiplicative { unMultiplicative :: a } deriving (Eq, Generic, Ord, Show, Functor) -instance Applicative Ordered where - pure = Ordered - Ordered f <*> Ordered a = Ordered (f a) +one :: (Multiplicative-Monoid) a => a +one = unMultiplicative mempty +{-# INLINE one #-} -instance Distributive Ordered where - distribute = distributeRep - {-# INLINE distribute #-} +infixl 7 *, \\, / -instance Representable Ordered where - type Rep Ordered = () - tabulate f = Ordered (f ()) - {-# INLINE tabulate #-} +-- >>> Dual [2] * Dual [3] :: Dual [Int] +-- Dual {getDual = [5]} +(*) :: (Multiplicative-Semigroup) a => a -> a -> a +a * b = unMultiplicative (Multiplicative a <> Multiplicative b) +{-# INLINE (*) #-} - index (Ordered x) () = x - {-# INLINE index #-} +(/) :: (Multiplicative-Group) a => a -> a -> a +a / b = unMultiplicative (Multiplicative a << Multiplicative b) +{-# INLINE (/) #-} -newtype Plus a = Plus { unPlus :: a } deriving (Eq, Generic, Ord, Show, Functor) +-- | 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 Plus where - pure = Plus - Plus f <*> Plus a = Plus (f a) +infixr 8 ^^ -instance Distributive Plus where +-- | Integral power of a multiplicative group element. +-- +-- @ 'one' '==' a '^^' 0 @ +-- +-- >>> 8 ^^ 0 :: Double +-- 1.0 +-- >>> 8 ^^ 0 :: Pico +-- 1.000000000000 +-- +(^^) :: (Multiplicative-Group) a => a -> Integer -> a +a ^^ n = unMultiplicative $ greplicate n (Multiplicative a) + +-- | Reciprocal of a multiplicative group element. +-- +-- @ +-- 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 #-} + +instance Applicative Multiplicative where + pure = Multiplicative + Multiplicative f <*> Multiplicative a = Multiplicative (f a) + +instance Distributive Multiplicative where distribute = distributeRep {-# INLINE distribute #-} -instance Representable Plus where - type Rep Plus = () - tabulate f = Plus (f ()) +instance Representable Multiplicative where + type Rep Multiplicative = () + tabulate f = Multiplicative (f ()) {-# INLINE tabulate #-} - index (Plus x) () = x + index (Multiplicative x) () = x {-# INLINE index #-} -instance (Additive-Semigroup) a => Semigroup (Multiplicative (Plus a)) where - Multiplicative a <> Multiplicative b = Multiplicative $ liftA2 (+) a b -instance (Additive-Monoid) a => Monoid (Multiplicative (Plus a)) where - mempty = Multiplicative $ pure zero --} -{- -instance (Multiplicative-Semigroup) (Plus a) => Semigroup (Multiplicative ((Min-Plus) a)) where - (<>) = liftA2 (<>) - -instance (Multiplicative-Monoid) (Plus a) => Monoid (Multiplicative ((Min-Plus) a)) where - mempty = pure mempty --} -{- -instance Semigroup (Min a) => Semigroup ((Min-Plus) a) where - (<>) = liftA2 (<>) - -instance Monoid (Min a) => Monoid ((Min-Plus) a) where - mempty = pure mempty - -instance Semigroup (Max a) => Semigroup ((Max-Plus) a) where - (<>) = liftA2 (<>) - -instance Monoid (Max a) => Monoid ((Max-Plus) a) where - mempty = pure mempty --} - - --------------------------------------------------------------------- --- Num-based +-- Additive semigroup instances --------------------------------------------------------------------- #define deriveAdditiveSemigroup(ty) \ @@ -338,10 +338,8 @@ deriveAdditiveGroup(Double) deriveAdditiveGroup(CDouble) ---------------------------------------------------------------------- --- Complex ---------------------------------------------------------------------- + instance (Additive-Semigroup) a => Semigroup (Additive (Complex a)) where Additive (a :+ b) <> Additive (c :+ d) = Additive $ (a + b) :+ (c + d) {-# INLINE (<>) #-} @@ -350,7 +348,7 @@ mempty = Additive $ zero :+ zero instance (Additive-Group) a => Magma (Additive (Complex a)) where - Additive (a :+ b) << Additive (c :+ d) = Additive $ (a - c) :+ (b - d) + Additive (a :+ b) << Additive (c :+ d) = Additive $ (subtract c a) :+ (subtract d b) {-# INLINE (<<) #-} instance (Additive-Group) a => Quasigroup (Additive (Complex a)) @@ -362,7 +360,7 @@ -- 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 $ (a * c - b * d) :+ (a * d + b * c) + 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) @@ -370,7 +368,7 @@ 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)) :+ ((b * c - a * d) / (c * c + d * d)) + 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)) @@ -380,10 +378,8 @@ instance ((Additive-Group) a, (Multiplicative-Group) a) => Group (Multiplicative (Complex a)) ---------------------------------------------------------------------- --- Ratio ---------------------------------------------------------------------- + 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 (<>) #-} @@ -392,7 +388,7 @@ mempty = Additive $ zero :% one instance ((Additive-Group) a, (Multiplicative-Monoid) a) => Magma (Additive (Ratio a)) where - Additive (a :% b) << Additive (c :% d) = Additive $ (a * d - c * b) :% (b * d) + 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)) @@ -433,10 +429,8 @@ (<>) = liftA2 (+) {-# INLINE (<>) #-} ---------------------------------------------------------------------- --- Idempotent and selective instances ---------------------------------------------------------------------- + -- MinPlus Predioid -- >>> Min 1 * Min 2 :: Min Int -- Min {getMin = 3} @@ -454,40 +448,8 @@ --Additive (Down a) <> Additive (Down b) mempty = pure . pure $ zero -{- -instance (Additive-Semigroup) a => Semigroup (Additive (Dual a)) where - (<>) = liftA2 . liftA2 $ flip (+) -instance (Additive-Monoid) a => Monoid (Additive (Dual a)) where - mempty = pure . pure $ zero -instance Semigroup (First a) => Semigroup (Additive (First a)) where - (<>) = liftA2 (<>) - --- FirstPlus Predioid -instance (Additive-Semigroup) a => Semigroup (Multiplicative (First a)) where - Multiplicative a <> Multiplicative b = Multiplicative $ liftA2 (+) a b - -instance Semigroup (Last a) => Semigroup (Additive (Last a)) where - (<>) = liftA2 (<>) - --- LastPlus Predioid -instance (Additive-Semigroup) a => Semigroup (Multiplicative (Last a)) where - Multiplicative a <> Multiplicative b = Multiplicative $ liftA2 (+) a b - - - --- >>> Min 1 + Min 2 :: Min Int --- Min {getMin = 1} -instance Semigroup (Min a) => Semigroup (Additive (Min a)) where - (<>) = liftA2 (<>) - -instance Semigroup (Max a) => Semigroup (Additive (Max a)) where - (<>) = liftA2 (<>) - - --} - instance Semigroup (Additive ()) where _ <> _ = pure () {-# INLINE (<>) #-} @@ -568,3 +530,268 @@ 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/Multiplicative.hs b/src/Data/Semigroup/Multiplicative.hs deleted file mode 100644 --- a/src/Data/Semigroup/Multiplicative.hs +++ /dev/null @@ -1,386 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE Safe #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} - -module Data.Semigroup.Multiplicative where - -import safe Data.Ord -import safe Control.Applicative -import safe Data.Bool -import safe Data.Distributive -import safe Data.Functor.Rep -import safe Data.Maybe -import safe Data.Either -import safe Data.Fixed -import safe Data.Group -import safe Data.Int -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) - --- | A (potentially non-commutative) 'Semigroup' under '+'. -newtype Multiplicative a = Multiplicative { unMultiplicative :: a } deriving (Eq, Generic, Ord, Show, Functor) - -one :: (Multiplicative-Monoid) a => a -one = unMultiplicative mempty -{-# INLINE one #-} - -infixl 7 *, \\, / - --- >>> Dual [2] * Dual [3] :: Dual [Int] --- Dual {getDual = [5]} -(*) :: (Multiplicative-Semigroup) a => a -> a -> a -a * b = unMultiplicative (Multiplicative a <> Multiplicative b) -{-# INLINE (*) #-} - -(/) :: (Multiplicative-Group) a => a -> a -> a -a / b = unMultiplicative (Multiplicative a << Multiplicative b) -{-# INLINE (/) #-} - --- | Left division by a multiplicative group element. --- --- When '*' is commutative we must have: --- --- @ x '\\' y = y '/' x @ --- -(\\) :: (Multiplicative-Group) a => a -> a -> a -(\\) x y = recip x * y - -infixr 8 ^^ - --- | Integral power of a multiplicative group element. --- --- @ 'one' '==' a '^^' 0 @ --- --- >>> 8 ^^ 0 :: Double --- 1.0 --- >>> 8 ^^ 0 :: Pico --- 1.000000000000 --- -(^^) :: (Multiplicative-Group) a => a -> Integer -> a -a ^^ n = unMultiplicative $ greplicate n (Multiplicative a) - --- | Reciprocal of a multiplicative group element. --- --- @ --- 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 #-} - - -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 #-} - ---------------------------------------------------------------------- --- 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) - ---------------------------------------------------------------------- --- Ratio ---------------------------------------------------------------------- - -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)) - ---------------------------------------------------------------------- --- Semigroup Instances ---------------------------------------------------------------------- - ---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 --- a/src/Data/Semigroup/Property.hs +++ b/src/Data/Semigroup/Property.hs @@ -27,7 +27,6 @@ import safe Test.Logic (Rel) import safe Data.Semigroup.Additive -import safe Data.Semigroup.Multiplicative import safe qualified Test.Function as Prop import safe qualified Test.Operation as Prop hiding (distributive_on) 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 @@ -240,14 +240,18 @@ elt = flip index {-# INLINE elt #-} -lensRep :: Basis b f => b -> forall g. Functor g => (a -> g a) -> f a -> (g**f) a -lensRep i f s = Compose $ setter s <$> f (getter s) +-- | 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 #-} -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) $ getCompose s) +-- | 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 #-} ------------------------------------------------------------------------------- diff --git a/src/Data/Semiring.hs b/src/Data/Semiring.hs --- a/src/Data/Semiring.hs +++ b/src/Data/Semiring.hs @@ -55,7 +55,6 @@ import safe Data.Maybe import safe Data.Semigroup.Additive as A import safe Data.Semigroup.Foldable as Foldable1 -import safe Data.Semigroup.Multiplicative as M import safe Data.Word import safe Foreign.C.Types (CFloat(..),CDouble(..)) import safe GHC.Real hiding (Fractional(..), (^^), (^)) @@ -91,6 +90,8 @@ class PresemiringLaw a => Presemiring a + + -- | Evaluate a non-empty presemiring sum. -- sum1 :: Presemiring a => Foldable1 f => f a -> a @@ -298,13 +299,32 @@ -- -- If the ring is < https://en.wikipedia.org/wiki/Ordered_ring ordered > (i.e. has an 'Ord' instance), then the following additional properties must hold: -- --- @ a '<=' b '==>' a '+' c '<=' b '+' c @ +-- @ a '<=' b ⇒ a '+' c '<=' b '+' c @ -- --- @ 'zero' '<=' a '&&' 'zero' '<=' b '==>' 'zero' '<=' a '*' b @ +-- @ 'zero' '<=' a '&&' 'zero' '<=' b ⇒ 'zero' '<=' a '*' b @ -- -- See the properties module for a detailed specification of the laws. -- class (Semiring a, RingLaw a) => Ring a where + +infixl 6 - + +(-) :: (Additive-Group) a => a -> a -> a +a - b = unAdditive (Additive a << Additive b) +{-# INLINE (-) #-} + +negate :: (Additive-Group) a => a -> a +negate a = zero - a +{-# INLINE negate #-} + +-- | Absolute value of an element. +-- +-- @ 'abs' r = 'mul' r ('signum' r) @ +-- +-- https://en.wikipedia.org/wiki/Linearly_ordered_group +abs :: (Additive-Group) a => Ord a => a -> a +abs x = bool (negate x) x $ zero <= x +{-# INLINE abs #-} -- satisfies trichotomy law: -- Exactly one of the following is true: a is positive, -a is positive, or a = 0. 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 @@ -48,8 +48,6 @@ -- -- This follows from right-neutrality and right-distributivity. -- --- Compare 'codistributive' and 'closed_stable'. --- -- When /R/ is also left-distributive we get: \( \forall a, b \in R: a * b = a + a * b + b \) -- -- See also 'Data.Warning' and < https://blogs.ncl.ac.uk/andreymokhov/united-monoids/#whatif >. @@ -129,14 +127,6 @@ -- -- @ -- 'empty' '*>' a ~~ 'empty' --- @ --- --- All right semirings must have a right-absorbative addititive one, --- however note that depending on the 'Prd' instance this does not preclude --- IEEE754-mandated behavior such as: --- --- @ --- 'zero' '*' NaN ~~ NaN -- @ -- -- This is a required property.