diff --git a/rings.cabal b/rings.cabal --- a/rings.cabal +++ b/rings.cabal @@ -1,7 +1,7 @@ name: rings -version: 0.0.2.4 -synopsis: Groups, rings, semirings, and dioids. -description: Lawful algebraic classes and a la carte instances. +version: 0.0.3 +synopsis: Ring-like objects. +description: Semirings, rings, division rings, modules, and algebras. homepage: https://github.com/cmk/rings license: BSD3 license-file: LICENSE @@ -15,45 +15,43 @@ cabal-version: >=1.10 library + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -optc-std=c99 + exposed-modules: - Data.Ring - , Data.Dioid - , Data.Dioid.Property - , Data.Group + Data.Algebra + , Data.Algebra.Quaternion , Data.Semiring - , Data.Semiring.V2 - , Data.Semiring.V3 - , Data.Semiring.V4 - , Data.Semiring.Matrix - , Data.Semiring.Module , Data.Semiring.Property - - , Data.Bool.Instance - , Data.Complex.Instance - , Data.Double.Instance - , Data.Fixed.Instance - , Data.Float.Instance - , Data.Int.Instance - , Data.Word.Instance + , Data.Semifield + , Data.Semimodule + , Data.Semimodule.Vector + , Data.Semimodule.Matrix + , Data.Semimodule.Transform + , Data.Semigroup.Additive + , Data.Semigroup.Multiplicative + , Data.Semigroup.Property default-extensions: ScopedTypeVariables , TypeApplications , MultiParamTypeClasses , UndecidableInstances + , FlexibleContexts , FlexibleInstances + , NoImplicitPrelude + , TypeOperators build-depends: base >= 4.10 && < 5.0 - , lawz >= 0.0.1 && < 1.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 - , connections >= 0.0.2.2 && < 0.0.3 - - hs-source-dirs: src - default-language: Haskell2010 + , profunctors >= 5.0 && < 6.0 test-suite test type: exitcode-stdio-1.0 diff --git a/src/Data/Algebra.hs b/src/Data/Algebra.hs new file mode 100644 --- /dev/null +++ b/src/Data/Algebra.hs @@ -0,0 +1,272 @@ +{-# 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 #-} + +module Data.Algebra ( + (><) + , (//) + , (.@.) + , unit + , norm + , conj + , triple + , reciprocal + , Algebra(..) + , Composition(..) + , Unital(..) + , Division(..) +) where + +import safe Data.Bool +import safe Data.Functor.Rep +import safe Data.Semifield +import safe Data.Semigroup.Additive as A +import safe Data.Semigroup.Multiplicative as M +import safe Data.Semimodule +import safe Data.Semiring hiding ((//)) +import safe Prelude hiding (Num(..), Fractional(..), sum, product) + +-- | < https://en.wikipedia.org/wiki/Algebra_over_a_field#Generalization:_algebra_over_a_ring Algebra > over a semiring. +-- +-- Needn't be associative or unital. +-- +class Semiring r => Algebra r a where + multiplyWith :: (a -> a -> r) -> a -> r + +infixl 7 >< + +-- | Multiplication operator on a free algebra. +-- +-- In particular this is cross product on the 'I3' basis in /R^3/: +-- +-- >>> V3 1 0 0 >< V3 0 1 0 >< V3 0 1 0 :: V3 Int +-- V3 (-1) 0 0 +-- >>> V3 1 0 0 >< (V3 0 1 0 >< V3 0 1 0) :: V3 Int +-- V3 0 0 0 +-- +-- /Caution/ in general (><) needn't be commutative, nor even associative. +-- +-- The cross product in particular satisfies the following properties: +-- +-- @ +-- a '><' a = 'mempty' +-- a '><' b = 'negate' ( b '><' a ) , +-- a '><' ( b <> c ) = ( a '><' b ) <> ( a '><' c ) , +-- ( r a ) '><' b = a '><' ( r b ) = r ( a '><' b ) . +-- a '><' ( b '><' c ) <> b '><' ( c '><' a ) <> c '><' ( a '><' b ) = 'mempty' . +-- @ +-- +-- See < https://en.wikipedia.org/wiki/Jacobi_identity Jacobi identity >. +-- +-- For associative algebras, use (*) instead for clarity: +-- +-- >>> (1 :+ 2) >< (3 :+ 4) :: Complex Int +-- (-5) :+ 10 +-- >>> (1 :+ 2) * (3 :+ 4) :: Complex Int +-- (-5) :+ 10 +-- >>> qi >< qj :: QuatM +-- Quaternion 0.000000 (V3 0.000000 0.000000 1.000000) +-- >>> qi * qj :: QuatM +-- Quaternion 0.000000 (V3 0.000000 0.000000 1.000000) +-- +(><) :: (Representable f, Algebra r (Rep f)) => f r -> f r -> f r +(><) x y = tabulate $ multiplyWith (\i1 i2 -> index x i1 * index y i2) + +-- | 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 '><' y) '><' (x '><' z) +-- @ +-- +-- >>> triple (V3 0 0 1) (V3 1 0 0) (V3 0 1 0) :: Double +-- 1.0 +-- +triple :: Free f => Foldable f => Algebra a (Rep f) => f a -> f a -> f a -> a +triple x y z = x .*. (y >< z) +{-# INLINE triple #-} + +-- | < https://en.wikipedia.org/wiki/Composition_algebra Composition algebra > over a free semimodule. +-- +class Algebra r a => Composition r a where + conjugateWith :: (a -> r) -> a -> r + + normWith :: (a -> r) -> r + + +-- @ 'conj' a '><' 'conj' b = 'conj' (b >< a) @ +--prop_conj :: Representable f => Foldable f => Semiring b => Composition a (Rep f) => Rel a b -> f a -> f a -> b +--prop_conj (~~) p q = sum $ mzipWithRep (~~) (conj (p >< q)) (conj q >< conj p) + +-- @ 'conj' a '><' 'conj' b = 'conj' (b >< a) @ +conj :: Representable f => Composition r (Rep f) => f r -> f r +conj = tabulate . conjugateWith . index + +-- | Norm of a composition algebra. +-- +-- @ +-- 'norm' x '*' 'norm' y = 'norm' (x >< y) +-- 'norm' . 'norm'' $ x = 'norm' x '*' 'norm' x +-- @ +-- +norm :: (Representable f, Composition r (Rep f)) => f r -> r +norm x = normWith $ index x + +--norm' :: (Representable f, Composition r (Rep f)) => f r -> f r +--norm' x = x >< conj x + +class (Semiring r, Algebra r a) => Unital r a where + unitWith :: r -> a -> r + +-- | Unit of a unital algebra. +-- +-- >>> unit :: Complex Int +-- 1 :+ 0 +-- >>> unit :: QuatD +-- Quaternion 1.0 (V3 0.0 0.0 0.0) +-- +unit :: Representable f => Unital r (Rep f) => f r +unit = tabulate $ unitWith one + +-- | A (not necessarily associative) < https://en.wikipedia.org/wiki/Division_algebra division algebra >. +-- +class (Semifield r, Unital r a) => Division r a where + --divideWith :: (a -> a -> r) -> a -> r + + reciprocalWith :: (a -> r) -> a -> r + + + + +-- | @ 'reciprocal' x = (/ 'quadrance' x) '<$>' 'conj' x@ +reciprocal :: Representable f => Division a (Rep f) => f a -> f a +reciprocal = tabulate . reciprocalWith . index + +-- reciprocal' x = (/ quadrance x) <$> conj x + + +infixl 7 // + +-- | Division operator on a free division algebra. +-- +-- >>> (1 :+ 0) // (0 :+ 1) +-- 0.0 :+ (-1.0) +-- +(//) :: Representable f => Division r (Rep f) => f r -> f r -> f r +(//) x y = x >< reciprocal y + +infix 6 .@. +-- | Bilinear form on a free composition algebra. +-- +-- >>> V2 1 2 .@. V2 1 2 +-- 5.0 +-- >>> V2 1 2 .@. V2 2 (-1) +-- 0.0 +-- >>> V3 1 1 1 .@. V3 1 1 (-2) +-- 0.0 +-- +-- >>> (1 :+ 2) .@. (2 :+ (-1)) :: Double +-- 0.0 +-- +-- >>> qi .@. qj :: Double +-- 0.0 +-- >>> qj .@. qk :: Double +-- 0.0 +-- >>> qk .@. qi :: Double +-- 0.0 +-- >>> qk .@. qk :: Double +-- 1.0 +-- +(.@.) :: Representable f => Composition a (Rep f) => Semigroup (f a) => Field a => f a -> f a -> a +x .@. y = prod / two where prod = norm (x <> y) - norm x - norm y + +--------------------------------------------------------------------- +-- Instances +--------------------------------------------------------------------- + + +--instance (Semiring r, Unital r a) => Unital r (a -> r) where +-- unitWith = unitWith one + +--instance (Semiring r, Division r a) => Division r (a -> r) where +-- reciprocalWith = reciprocalWith + +-- incoherent +-- instance Unital () a where unitWith _ _ = () +-- instance (Unital r a, Unital r b) => Unital (a -> r) b where unitWith f b a = unitWith (f a) b + +instance Semiring r => Algebra r () where + multiplyWith f = f () + +instance Semiring r => Unital r () where + unitWith r () = r + +instance (Algebra r a, Algebra r b) => Algebra r (a,b) where + multiplyWith f (a,b) = multiplyWith (\a1 a2 -> multiplyWith (\b1 b2 -> f (a1,b1) (a2,b2)) b) a + +instance (Algebra r a, Algebra r b, Algebra r c) => Algebra r (a,b,c) where + multiplyWith f (a,b,c) = multiplyWith (\a1 a2 -> multiplyWith (\b1 b2 -> multiplyWith (\c1 c2 -> f (a1,b1,c1) (a2,b2,c2)) c) b) a + +instance (Unital r a, Unital r b) => Unital r (a,b) where + unitWith r (a,b) = unitWith r a * unitWith r b + +instance (Unital r a, Unital r b, Unital r c) => Unital r (a,b,c) where + unitWith r (a,b,c) = unitWith r a * unitWith r b * unitWith r c + +-- | Tensor algebra +-- +-- >>> multiplyWith (<>) [1..3 :: Int] +-- [1,2,3,1,2,3,1,2,3,1,2,3] +-- +-- >>> multiplyWith (\f g -> fold (f ++ g)) [1..3] :: Int +-- 24 +-- +instance Semiring r => Algebra r [a] where + multiplyWith f = go [] where + go ls rrs@(r:rs) = f (reverse ls) rrs + go (r:ls) rs + go ls [] = f (reverse ls) [] + +instance Semiring r => Unital r [a] where + unitWith r [] = r + unitWith _ _ = zero + +type ComplexBasis = Bool + +-- Complex basis +--instance Module r ComplexBasis => Algebra r ComplexBasis where +instance Ring r => Algebra r ComplexBasis where + multiplyWith f = f' where + fe = f False False - f True True + fi = f False True + f True False + f' False = fe + f' True = fi + +--instance Module r ComplexBasis => Composition r ComplexBasis where +instance Ring r => Composition r ComplexBasis where + conjugateWith f = f' where + afe = f False + nfi = negate (f True) + f' False = afe + f' True = nfi + + normWith f = flip multiplyWith zero $ \i1 i2 -> f i1 * conjugateWith f i2 + +--instance Module r ComplexBasis => Unital r ComplexBasis where +instance Ring r => Unital r ComplexBasis where + unitWith x False = x + unitWith _ _ = zero + +instance Field r => Division r ComplexBasis where + reciprocalWith f i = conjugateWith f i / normWith f diff --git a/src/Data/Algebra/Quaternion.hs b/src/Data/Algebra/Quaternion.hs new file mode 100644 --- /dev/null +++ b/src/Data/Algebra/Quaternion.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +--{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} + +-- | See the /spatial-math/ package for usage. +module Data.Algebra.Quaternion where + +import safe Data.Algebra +import safe Data.Distributive +import safe Data.Fixed +import safe Data.Functor.Rep +import safe Data.Semifield +import safe Data.Semigroup.Foldable +import safe Data.Semimodule +import safe Data.Semimodule.Vector +import safe Data.Semiring +import safe GHC.Generics hiding (Rep) +import safe Prelude hiding (Num(..), Fractional(..), sum, product) + +{- need tolerances: +λ> prop_conj q12 (q3 :: QuatP) +False +λ> prop_conj q14 (q3 :: QuatP) +False + +prop_conj :: Ring a => (a -> a -> Bool) -> Quaternion a -> Quaternion a -> Bool +prop_conj (~~) p q = sum $ mzipWithRep (~~) (conj (p * q)) (conj q * conj p) + +-- conj (p * q) = conj q * conj p +-- conj q = (-0.5) * (q <> (i * q * i) <> (j * q * j) <> (k * q * k)) +-- 2 * real q '==' q <> conj q +-- 2 * imag q '==' q << conj q +conj :: Group a => Quaternion a -> Quaternion a +conj (Quaternion r v) = Quaternion r $ fmap negate v + +-- TODO: add to Property module +prop_conj' :: Field a => Rel (Quaternion a) b -> Quaternion a -> b +prop_conj' (~~) q = (conj q) ~~ (conj' q) where + conj' q = ((one / negate two) *) <$> q <> (qi * q * qi) <> (qj * q * qj) <> (qk * q * qk) +-} + + + + + +type QuatF = Quaternion Float +type QuatD = Quaternion Double +type QuatR = Quaternion Rational +type QuatM = Quaternion Micro +type QuatN = Quaternion Nano +type QuatP = Quaternion Pico + +data Quaternion a = Quaternion !a {-# UNPACK #-}! (V3 a) deriving (Eq, Ord, Show, Generic, Generic1) + +-- | Obtain a 'Quaternion' from 4 base field elements. +-- +quat :: a -> a -> a -> a -> Quaternion a +quat r x y z = Quaternion r (V3 x y z) + +-- | Real or scalar part of a quaternion. +-- +scal :: Quaternion a -> a +scal (Quaternion r _) = r + +vect :: Quaternion a -> V3 a +vect (Quaternion _ v) = v + +-- | Use a quaternion to rotate a vector. +-- +-- >>> rotate qk . rotate qj $ V3 1 1 0 :: V3 Int +-- V3 1 (-1) 0 +-- +rotate :: Ring a => Quaternion a -> V3 a -> V3 a +rotate q v = v' where Quaternion _ v' = q * Quaternion zero v * conj q + +-- | Scale a 'QuatD' to unit length. +-- +-- >>> normalize $ normalize $ quat 2.0 2.0 2.0 2.0 +-- Quaternion 0.5 (V3 0.5 0.5 0.5) +-- +normalize :: QuatD -> QuatD +normalize q = 1.0 / (sqrt $ norm q) *. q + +------------------------------------------------------------------------------- +-- Standard quaternion basis elements +------------------------------------------------------------------------------- + +-- | The real quaternion. +-- +-- Represents no rotation. +-- +-- 'qe' = 'unit' +-- +qe :: Semiring a => Quaternion a +qe = idx Nothing + +-- | The /i/ quaternion. +-- +-- Represents a \( \pi \) radian rotation about the /x/ axis. +-- +-- >>> rotate (qi :: QuatM) $ V3 1 0 0 +-- V3 1.000000 0.000000 0.000000 +-- >>> rotate (qi :: QuatM) $ V3 0 1 0 +-- V3 0.000000 -1.000000 0.000000 +-- >>> rotate (qi :: QuatM) $ V3 0 0 1 +-- V3 0.000000 0.000000 -1.000000 +-- +-- >>> qi * qj +-- Quaternion 0 (V3 0 0 1) +-- +qi :: Semiring a => Quaternion a +qi = idx (Just I31) + +-- | The /j/ quaternion. +-- +-- Represents a \( \pi \) radian rotation about the /y/ axis. +-- +-- >>> rotate (qj :: QuatM) $ V3 1 0 0 +-- V3 -1.000000 0.000000 0.000000 +-- >>> rotate (qj :: QuatM) $ V3 0 1 0 +-- V3 0.000000 1.000000 0.000000 +-- >>> rotate (qj :: QuatM) $ V3 0 0 1 +-- V3 0.000000 0.000000 -1.000000 +-- +-- >>> qj * qk +-- Quaternion 0 (V3 1 0 0) +-- +qj :: Semiring a => Quaternion a +qj = idx (Just I32) + +-- | The /k/ quaternion. +-- +-- Represents a \( \pi \) radian rotation about the /z/ axis. +-- +-- >>> rotate (qk :: QuatM) $ V3 1 0 0 +-- V3 -1.000000 0.000000 0.000000 +-- >>> rotate (qk :: QuatM) $ V3 0 1 0 +-- V3 0.000000 -1.000000 0.000000 +-- >>> rotate (qk :: QuatM) $ V3 0 0 1 +-- V3 0.000000 0.000000 1.000000 +-- +-- >>> qk * qi +-- Quaternion 0 (V3 0 1 0) +-- >>> qi * qj * qk +-- Quaternion (-1) (V3 0 0 0) +-- +qk :: Semiring a => Quaternion a +qk = idx (Just I33) + +------------------------------------------------------------------------------- +-- Instances +------------------------------------------------------------------------------- + +instance (Additive-Semigroup) a => Semigroup (Quaternion a) where + (<>) = mzipWithRep (+) + +instance (Additive-Monoid) a => Monoid (Quaternion a) where + mempty = pureRep zero + +instance (Additive-Group) a => Magma (Quaternion a) where + (<<) = mzipWithRep (-) + +instance (Additive-Group) a => Quasigroup (Quaternion a) + +instance (Additive-Group) a => Loop (Quaternion a) + +instance (Additive-Group) a => Group (Quaternion a) + +instance (Additive-Group) a => Magma (Additive (Quaternion a)) where + (<<) = mzipWithRep (<<) + +instance (Additive-Group) a => Quasigroup (Additive (Quaternion a)) + +instance (Additive-Group) a => Loop (Additive (Quaternion a)) + +instance (Additive-Group) a => Group (Additive (Quaternion a)) + +instance Semiring a => Semimodule a (Quaternion a) where + (*.) = multl + +instance (Additive-Semigroup) a => Semigroup (Additive (Quaternion a)) where + (<>) = mzipWithRep (<>) + +instance (Additive-Monoid) a => Monoid (Additive (Quaternion a)) where + mempty = pure mempty + +instance Ring a => Semigroup (Multiplicative (Quaternion a)) where + -- >>> qi * qj :: QuatM + -- Quaternion 0.000000 (V3 0.000000 0.000000 1.000000) + -- >>> qk * qi :: QuatM + -- Quaternion 0.000000 (V3 0.000000 1.000000 0.000000) + -- >>> qj * qk :: QuatM + -- Quaternion 0.000000 (V3 1.000000 0.000000 0.000000) + (<>) = mzipWithRep (><) + +instance Ring a => Monoid (Multiplicative (Quaternion a)) where + mempty = pure unit + +instance Ring a => Presemiring (Quaternion a) + +instance Ring a => Semiring (Quaternion a) + +instance Ring a => Ring (Quaternion a) + +instance Functor Quaternion where + fmap f (Quaternion r v) = Quaternion (f r) (fmap f v) + {-# INLINE fmap #-} + + a <$ _ = Quaternion a (V3 a a a) + {-# INLINE (<$) #-} + +instance Foldable Quaternion where + foldMap f (Quaternion e v) = f e <> foldMap f v + {-# INLINE foldMap #-} + foldr f z (Quaternion e v) = f e (foldr f z v) + {-# INLINE foldr #-} + null _ = False + length _ = 4 + +instance Foldable1 Quaternion where + foldMap1 f (Quaternion r v) = f r <> foldMap1 f v + {-# INLINE foldMap1 #-} + +instance Distributive Quaternion where + distribute f = Quaternion (fmap (\(Quaternion x _) -> x) f) $ V3 + (fmap (\(Quaternion _ (V3 y _ _)) -> y) f) + (fmap (\(Quaternion _ (V3 _ z _)) -> z) f) + (fmap (\(Quaternion _ (V3 _ _ w)) -> w) f) + {-# INLINE distribute #-} + +instance Representable Quaternion where + type Rep Quaternion = Maybe I3 + + tabulate f = Quaternion (f Nothing) (V3 (f $ Just I31) (f $ Just I32) (f $ Just I33)) + {-# INLINE tabulate #-} + + index (Quaternion r v) = maybe r (index v) + {-# INLINE index #-} diff --git a/src/Data/Bool/Instance.hs b/src/Data/Bool/Instance.hs deleted file mode 100644 --- a/src/Data/Bool/Instance.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Data.Bool.Instance where - -import Data.Prd -import Data.Dioid -import Data.Semiring -import Prelude - -instance Semigroup Bool where - (<>) = (||) - {-# INLINE (<>) #-} - -instance Monoid Bool where mempty = False - -instance Semiring Bool where - (><) = (&&) - {-# INLINE (><) #-} - - fromBoolean = id - {-# INLINE fromBoolean #-} - -instance Kleene Bool where - star = const True -- == (|| True) - plus = id -- == (&& True) - {-# INLINE star #-} - {-# INLINE plus #-} - -instance Dioid Bool where - fromNatural 0 = False - fromNatural _ = True diff --git a/src/Data/Complex/Instance.hs b/src/Data/Complex/Instance.hs deleted file mode 100644 --- a/src/Data/Complex/Instance.hs +++ /dev/null @@ -1,31 +0,0 @@ -module Data.Complex.Instance where - -import Data.Complex -import Data.Semiring -import Data.Group -import Data.Ring - -import Prelude hiding (negate, fromInteger) - -instance Semigroup a => Semigroup (Complex a) where - (x :+ y) <> (x' :+ y') = (x <> x') :+ (y <> y') - {-# INLINE (<>) #-} - -instance Monoid a => Monoid (Complex a) where - mempty = mempty :+ mempty - -instance Group a => Group (Complex a) where - negate (x :+ y) = negate x :+ negate y - {-# INLINE negate #-} - -instance (Group a, Semiring a) => Semiring (Complex a) where - (x :+ y) >< (x' :+ y') = (x >< x' << y >< y') :+ (x >< y' <> y >< x') - {-# INLINE (><) #-} - - fromBoolean False = mempty - fromBoolean True = fromBoolean True :+ mempty - {-# INLINE fromBoolean #-} - -instance Ring a => Ring (Complex a) where - fromInteger x = fromInteger x :+ mempty - {-# INLINE fromInteger #-} diff --git a/src/Data/Dioid.hs b/src/Data/Dioid.hs deleted file mode 100644 --- a/src/Data/Dioid.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# Language ConstraintKinds #-} - -module Data.Dioid where - -import Data.Connection.Yoneda -import Data.Semiring -import Data.Prd -import Numeric.Natural - --- A constraint kind for topological dioids -type Topological a = (Dioid a, Kleene a, Yoneda a) - -{- -An idempotent dioid is a dioid in which the addition /<>/ is idempotent. A frequently encountered special case is one where addition /<>/ is not only idempotent but also selective. A selective dioid is a dioid in which the addition /<>/ is selective (i.e.: ∀a, b ∈ E: a /<>/ b = a or b). - -Idempotent dioids form a particularly rich class of dioids which contains many sub-classes, in particular: -– Doubly-idempotent dioids and distributive lattices -– Doubly selective dioids -– Idempotent-cancellative dioids and selective-cancellative dioids -– Idempotent-invertible dioids and selective-invertible dioids - --} - --- | Right pre-dioids and dioids. --- --- A right-dioid is a semiring with a right-canonical pre-order relation relative to '<>': --- @a <~ b@ iff @b ≡ a <> c@ for some @c@. --- --- In other words we have that: --- --- @ --- a '<~' (a '<>' b) ≡ 'True' --- @ --- --- Consequently '<~' is both reflexive and transitive: --- --- @ --- a '<~' a ≡ 'True' --- a '<~' b && b '<~' c ==> a '<~' c ≡ 'True' --- @ --- --- Finally '<~' is an order relation: --- --- @(a '=~' b) <==> (a '==' b)@ --- --- See 'Data.Dioid.Property' --- -class (Prd r, Semiring r) => Dioid r where - - -- | A dioid homomorphism from the naturals to /r/. - fromNatural :: Natural -> r - -instance (Monoid a, Monoid b, Dioid a, Dioid b) => Dioid (a, b) where - fromNatural x = (fromNatural x, fromNatural x) - -instance (Monoid a, Monoid b, Monoid c, Dioid a, Dioid b, Dioid c) => Dioid (a, b, c) where - fromNatural x = (fromNatural x, fromNatural x, fromNatural x) diff --git a/src/Data/Dioid/Property.hs b/src/Data/Dioid/Property.hs deleted file mode 100644 --- a/src/Data/Dioid/Property.hs +++ /dev/null @@ -1,284 +0,0 @@ -{-# Language AllowAmbiguousTypes #-} - -module Data.Dioid.Property ( - -- * Properties of dioids (aka ordered semirings) - ordered_preordered - , ordered_monotone_zero - , ordered_monotone_addition - , ordered_positive_addition - , ordered_monotone_multiplication - , ordered_annihilative_sunit - , ordered_idempotent_addition - , ordered_positive_multiplication - -- * Properties of absorbative dioids - , absorbative_addition - , absorbative_addition' - , idempotent_addition - , absorbative_multiplication - , absorbative_multiplication' - -- * Properties of annihilative dioids - , annihilative_addition - , annihilative_addition' - , codistributive - -- * Properties of kleene dioids - , kleene_pstable - , kleene_paffine - , kleene_stable - , kleene_affine - , idempotent_star -) where - -import Data.Prd -import Data.Dioid -import Data.List (unfoldr) -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Semiring hiding (nonunital) -import Numeric.Natural -import Test.Util ((<==>),(==>)) -import qualified Test.Function as Prop -import qualified Test.Operation as Prop hiding (distributive_on) -import qualified Data.Semiring.Property as Prop - ------------------------------------------------------------------------------------- --- Properties of ordered semirings (aka dioids). - --- | '<~' is a preordered relation relative to '<>'. --- --- This is a required property. --- -ordered_preordered :: Dioid r => r -> r -> Bool -ordered_preordered a b = a <~ (a <> b) - --- | 'mempty' is a minimal or least element of @r@. --- --- This is a required property. --- -ordered_monotone_zero :: (Monoid r, Dioid r) => r -> Bool -ordered_monotone_zero a = mempty ?~ a ==> mempty <~ a - --- | \( \forall a, b, c: b \leq c \Rightarrow b + a \leq c + a --- --- In an ordered semiring this follows directly from the definition of '<~'. --- --- Compare 'cancellative_addition'. --- --- This is a required property. --- -ordered_monotone_addition :: Dioid r => r -> r -> r -> Bool -ordered_monotone_addition a = Prop.monotone_on (<~) (<~) (<> a) - --- | \( \forall a, b: a + b = 0 \Rightarrow a = 0 \wedge b = 0 \) --- --- This is a required property. --- -ordered_positive_addition :: (Prd r, Monoid r) => r -> r -> Bool -ordered_positive_addition a b = a <> b =~ mempty ==> a =~ mempty && b =~ mempty - --- | \( \forall a, b, c: b \leq c \Rightarrow b * a \leq c * a --- --- In an ordered semiring this follows directly from 'distributive' and the definition of '<~'. --- --- Compare 'cancellative_multiplication'. --- --- This is a required property. --- -ordered_monotone_multiplication :: Dioid r => r -> r -> r -> Bool -ordered_monotone_multiplication a = Prop.monotone_on (<~) (<~) (>< a) - --- | '<~' is consistent with annihilativity. --- --- This means that a dioid with an annihilative multiplicative sunit must satisfy: --- --- @ --- ('one' <~) ≡ ('one' ==) --- @ --- -ordered_annihilative_sunit :: (Monoid r, Dioid r) => r -> Bool -ordered_annihilative_sunit a = sunit <~ a <==> sunit =~ a - --- | \( \forall a, b: a \leq b \Rightarrow a + b = b --- -ordered_idempotent_addition :: (Prd r, Monoid r) => r -> r -> Bool -ordered_idempotent_addition a b = (a <~ b) <==> (a <> b =~ b) - --- | \( \forall a, b: a * b = 0 \Rightarrow a = 0 \vee b = 0 \) --- -ordered_positive_multiplication :: (Monoid r, Dioid r) => r -> r -> Bool -ordered_positive_multiplication a b = a >< b =~ mempty ==> a =~ mempty || b =~ mempty - ------------------------------------------------------------------------------------- --- Properties of idempotent & absorbative semirings - --- | \( \forall a, b \in R: a * b + b = b \) --- --- Right-additive absorbativity is a generalized form of idempotency: --- --- @ --- 'absorbative_addition' 'sunit' a ~~ a <> a ~~ a --- @ --- -absorbative_addition :: (Eq r, Dioid r) => r -> r -> Bool -absorbative_addition a b = a >< b <> b ~~ b - -idempotent_addition :: (Eq r, Monoid r, Dioid r) => r -> Bool -idempotent_addition = absorbative_addition sunit - --- | \( \forall a, b \in R: b + b * a = b \) --- --- Left-additive absorbativity is a generalized form of idempotency: --- --- @ --- 'absorbative_addition' 'sunit' a ~~ a <> a ~~ a --- @ --- -absorbative_addition' :: (Eq r, Dioid r) => r -> r -> Bool -absorbative_addition' a b = b <> b >< a ~~ b - --- | \( \forall a, b \in R: (a + b) * b = b \) --- --- Right-mulitplicative absorbativity is a generalized form of idempotency: --- --- @ --- 'absorbative_multiplication' 'mempty' a ~~ a '><' a ~~ a --- @ --- --- See < https://en.wikipedia.org/wiki/Absorption_law >. --- -absorbative_multiplication :: (Eq r, Dioid r) => r -> r -> Bool -absorbative_multiplication a b = (a <> b) >< b ~~ b - ---absorbative_multiplication a b c = (a <> b) >< c ~~ c ---kleene a = --- absorbative_multiplication (star a) sunit a && absorbative_multiplication sunit (star a) a - --- | \( \forall a, b \in R: b * (b + a) = b \) --- --- Left-mulitplicative absorbativity is a generalized form of idempotency: --- --- @ --- 'absorbative_multiplication'' 'mempty' a ~~ a '><' a ~~ a --- @ --- --- See < https://en.wikipedia.org/wiki/Absorption_law >. --- -absorbative_multiplication' :: (Eq r, Dioid r) => r -> r -> Bool -absorbative_multiplication' a b = b >< (b <> a) ~~ b - ------------------------------------------------------------------------------------- --- Properties of idempotent and annihilative dioids. - --- | \( \forall a \in R: o + a = o \) --- --- A unital semiring with a right-annihilative muliplicative sunit must satisfy: --- --- @ --- 'sunit' <> a ~~ 'sunit' --- @ --- --- For a dioid this is equivalent to: --- --- @ --- ('sunit' '<~') ~~ ('sunit' '~~') --- @ --- --- For 'Alternative' instances this is known as the left-catch law: --- --- @ --- 'pure' a '<|>' _ ~~ 'pure' a --- @ --- -annihilative_addition :: (Eq r, Monoid r, Dioid r) => r -> Bool -annihilative_addition r = Prop.annihilative_on (~~) (<>) sunit r - --- | \( \forall a \in R: a + o = o \) --- --- A unital semiring with a left-annihilative muliplicative sunit must satisfy: --- --- @ --- a '<>' 'sunit' ~~ 'sunit' --- @ --- --- Note that the left-annihilative property is too strong for many instances. --- This is because it requires that any effects that /r/ generates be undsunit. --- --- See < https://winterkoninkje.dreamwidth.org/90905.html >. --- -annihilative_addition' :: (Eq r, Monoid r, Dioid r) => r -> Bool -annihilative_addition' r = Prop.annihilative_on' (~~) (<>) sunit r - --- | \( \forall a, b, c \in R: c + (a * b) \equiv (c + a) * (c + b) \) --- --- A right-codistributive semiring has a right-annihilative muliplicative sunit: --- --- @ 'codistributive' 'sunit' a 'mempty' ~~ 'sunit' ~~ 'sunit' '<>' a @ --- --- idempotent mulitiplication: --- --- @ 'codistributive' 'mempty' 'mempty' a ~~ a ~~ a '><' a @ --- --- and idempotent addition: --- --- @ 'codistributive' a 'mempty' a ~~ a ~~ a '<>' a @ --- --- Furthermore if /R/ is commutative then it is a right-distributive lattice. --- -codistributive :: (Eq r, Dioid r) => r -> r -> r -> Bool -codistributive = Prop.distributive_on' (~~) (><) (<>) - ------------------------------------------------------------------------------------- --- Properties of kleene dioids - --- | \( 1 + \sum_{i=1}^{P+1} a^i = 1 + \sum_{i=1}^{P} a^i \) --- --- If /a/ is p-stable for some /p/, then we have: --- --- @ --- 'powers' p a ~~ a '><' 'powers' p a '<>' 'sunit' ~~ 'powers' p a '><' a '<>' 'sunit' --- @ --- --- If '<>' and '><' are idempotent then every element is 1-stable: --- --- @ a '><' a '<>' a '<>' 'sunit' = a '<>' a '<>' 'sunit' = a '<>' 'sunit' @ --- -kleene_pstable :: (Eq r, Prd r, Monoid r, Dioid r) => Natural -> r -> Bool -kleene_pstable p a = powers p a ~~ powers (p + 1) a - --- | \( x = a * x + b \Rightarrow x = (1 + \sum_{i=1}^{P} a^i) * b \) --- --- If /a/ is p-stable for some /p/, then we have: --- -kleene_paffine :: (Eq r, Monoid r, Dioid r) => Natural -> r -> r -> Bool -kleene_paffine p a b = kleene_pstable p a ==> x ~~ a >< x <> b - where x = powers p a >< b - --- | \( \forall a \in R : a^* = a^* * a + 1 \) --- --- Closure is /p/-stability for all /a/ in the limit as \( p \to \infinity \). --- --- One way to think of this property is that all geometric series --- "converge": --- --- \( \forall a \in R : 1 + \sum_{i \geq 1} a^i \in R \) --- -kleene_stable :: (Eq r, Monoid r, Dioid r, Kleene r) => r -> Bool -kleene_stable a = star a ~~ star a >< a <> sunit - -kleene_stable' :: (Eq r, Monoid r, Dioid r, Kleene r) => r -> Bool -kleene_stable' a = star a ~~ sunit <> a >< star a - -kleene_affine :: (Eq r, Monoid r, Dioid r, Kleene r) => r -> r -> Bool -kleene_affine a b = x ~~ a >< x <> b where x = star a >< b - --- If /R/ is kleene then 'star' must be idempotent: --- --- @'star' ('star' a) ~~ 'star' a@ --- -idempotent_star :: (Eq r, Monoid r, Dioid r, Kleene r) => r -> Bool -idempotent_star = Prop.idempotent star - --- If @r@ is a kleene dioid then 'star' must be monotone: --- --- @x '<~' y ==> 'star' x '<~' 'star' y@ --- -monotone_star :: (Monoid r, Dioid r, Kleene r) => r -> r -> Bool -monotone_star = Prop.monotone_on (<~) (<~) star diff --git a/src/Data/Double/Instance.hs b/src/Data/Double/Instance.hs deleted file mode 100644 --- a/src/Data/Double/Instance.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE CPP #-} -module Data.Double.Instance where - -import Data.Semiring -import Foreign.C.Types (CDouble(..)) -import Prelude (Monoid(..), Semigroup(..), Double) -import qualified Prelude as N (Num(..)) - -#define deriveSemigroup(ty) \ -instance Semigroup (ty) where { \ - (<>) = (N.+) \ -; {-# INLINE (<>) #-} \ -} - -#define deriveMonoid(ty) \ -instance Monoid (ty) where { \ - mempty = 0 \ -} -#define deriveSemiring(ty) \ -instance Semiring (ty) where { \ - (><) = (N.*) \ -; fromBoolean = fromBooleanDef 1 \ -; {-# INLINE (><) #-} \ -; {-# INLINE fromBoolean #-} \ -} - -deriveSemigroup(Double) -deriveSemigroup(CDouble) -deriveMonoid(Double) -deriveMonoid(CDouble) -deriveSemiring(Double) -deriveSemiring(CDouble) diff --git a/src/Data/Fixed/Instance.hs b/src/Data/Fixed/Instance.hs deleted file mode 100644 --- a/src/Data/Fixed/Instance.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE CPP #-} -module Data.Fixed.Instance where - -import Data.Fixed -import Data.Semiring -import Data.Group -import Data.Ring -import Prelude (Monoid(..), Semigroup(..)) -import qualified Prelude as N (Num(..)) - -#define deriveSemigroup(ty) \ -instance Semigroup (ty) where { \ - (<>) = (N.+) \ -; {-# INLINE (<>) #-} \ -} - -#define deriveMonoid(ty) \ -instance Monoid (ty) where { \ - mempty = 0 \ -} - -#define deriveGroup(ty) \ -instance Group (ty) where { \ - (<<) = (N.-) \ -; negate = N.negate \ -; {-# INLINE (<<) #-} \ -; {-# INLINE negate #-} \ -} - -#define deriveSemiring(ty) \ -instance Semiring (ty) where { \ - (><) = (N.*) \ -; fromBoolean = fromBooleanDef 1 \ -; {-# INLINE (><) #-} \ -; {-# INLINE fromBoolean #-} \ -} - -#define deriveRing(ty) \ -instance Ring (ty) where { \ - fromInteger = N.fromInteger \ -; abs = N.abs \ -; signum = N.signum \ -; {-# INLINE abs #-} \ -; {-# INLINE signum #-} \ -} - -deriveSemigroup(Uni) -deriveSemigroup(Deci) -deriveSemigroup(Centi) -deriveSemigroup(Milli) -deriveSemigroup(Micro) -deriveSemigroup(Nano) -deriveSemigroup(Pico) - -deriveMonoid(Uni) -deriveMonoid(Deci) -deriveMonoid(Centi) -deriveMonoid(Milli) -deriveMonoid(Micro) -deriveMonoid(Nano) -deriveMonoid(Pico) - -deriveGroup(Uni) -deriveGroup(Deci) -deriveGroup(Centi) -deriveGroup(Milli) -deriveGroup(Micro) -deriveGroup(Nano) -deriveGroup(Pico) - -deriveSemiring(Uni) -deriveSemiring(Deci) -deriveSemiring(Centi) -deriveSemiring(Milli) -deriveSemiring(Micro) -deriveSemiring(Nano) -deriveSemiring(Pico) - -deriveRing(Uni) -deriveRing(Deci) -deriveRing(Centi) -deriveRing(Milli) -deriveRing(Micro) -deriveRing(Nano) -deriveRing(Pico) diff --git a/src/Data/Float/Instance.hs b/src/Data/Float/Instance.hs deleted file mode 100644 --- a/src/Data/Float/Instance.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE CPP #-} -module Data.Float.Instance where - -import Data.Semiring -import Foreign.C.Types (CFloat(..)) -import Prelude (Monoid(..), Semigroup(..), Float) -import qualified Prelude as N (Num(..)) - -#define deriveSemigroup(ty) \ -instance Semigroup (ty) where { \ - (<>) = (N.+) \ -; {-# INLINE (<>) #-} \ -} - -#define deriveMonoid(ty) \ -instance Monoid (ty) where { \ - mempty = 0 \ -} -#define deriveSemiring(ty) \ -instance Semiring (ty) where { \ - (><) = (N.*) \ -; fromBoolean = fromBooleanDef 1 \ -; {-# INLINE (><) #-} \ -; {-# INLINE fromBoolean #-} \ -} - -deriveSemigroup(Float) -deriveSemigroup(CFloat) -deriveMonoid(Float) -deriveMonoid(CFloat) -deriveSemiring(Float) -deriveSemiring(CFloat) diff --git a/src/Data/Group.hs b/src/Data/Group.hs deleted file mode 100644 --- a/src/Data/Group.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Data.Group where - -import Data.Complex -import Prelude hiding (Num(..)) - -infixl 6 << - --- | A 'Group' is a 'Monoid' plus a function, 'negate', such that: --- --- @g << negate g ≡ mempty@ --- --- @negate g << g ≡ mempty@ --- -class Monoid g => Group g where - {-# MINIMAL (negate | (<<)) #-} - - negate :: g -> g - negate x = mempty << x - - (<<) :: g -> g -> g - x << y = x <> negate y diff --git a/src/Data/Int/Instance.hs b/src/Data/Int/Instance.hs deleted file mode 100644 --- a/src/Data/Int/Instance.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE CPP #-} -module Data.Int.Instance where - -import Data.Semiring -import Data.Group -import Data.Ring -import Data.Int -import Prelude (Monoid(..), Semigroup(..), Integer) -import qualified Prelude as N (Num(..)) - -#define deriveSemigroup(ty) \ -instance Semigroup (ty) where { \ - (<>) = (N.+) \ -; {-# INLINE (<>) #-} \ -} - -#define deriveMonoid(ty) \ -instance Monoid (ty) where { \ - mempty = 0 \ -} - -#define deriveGroup(ty) \ -instance Group (ty) where { \ - (<<) = (N.-) \ -; negate = N.negate \ -; {-# INLINE (<<) #-} \ -; {-# INLINE negate #-} \ -} - -#define deriveSemiring(ty) \ -instance Semiring (ty) where { \ - (><) = (N.*) \ -; fromBoolean = fromBooleanDef 1 \ -; {-# INLINE (><) #-} \ -; {-# INLINE fromBoolean #-} \ -} - -#define deriveRing(ty) \ -instance Ring (ty) where { \ - fromInteger = N.fromInteger \ -; abs = N.abs \ -; signum = N.signum \ -; {-# INLINE abs #-} \ -; {-# INLINE signum #-} \ -} - -deriveSemigroup(Int) -deriveSemigroup(Int8) -deriveSemigroup(Int16) -deriveSemigroup(Int32) -deriveSemigroup(Int64) -deriveSemigroup(Integer) - -deriveMonoid(Int) -deriveMonoid(Int8) -deriveMonoid(Int16) -deriveMonoid(Int32) -deriveMonoid(Int64) -deriveMonoid(Integer) - -deriveGroup(Int) -deriveGroup(Int8) -deriveGroup(Int16) -deriveGroup(Int32) -deriveGroup(Int64) -deriveGroup(Integer) - -deriveSemiring(Int) -deriveSemiring(Int8) -deriveSemiring(Int16) -deriveSemiring(Int32) -deriveSemiring(Int64) -deriveSemiring(Integer) - -deriveRing(Int) -deriveRing(Int8) -deriveRing(Int16) -deriveRing(Int32) -deriveRing(Int64) -deriveRing(Integer) diff --git a/src/Data/Ring.hs b/src/Data/Ring.hs deleted file mode 100644 --- a/src/Data/Ring.hs +++ /dev/null @@ -1,54 +0,0 @@ -module Data.Ring ( - (<<) - , (><) - , (<>) - , negate - , Ring(..) -) where - -import Data.Group -import Data.Semiring -import Prelude hiding (Num(..)) - --- | Rings. --- --- A ring /R/ is a commutative group with a second monoidal operation />/. --- --- The basic properties of a ring follow immediately from the axioms: --- --- @ r '><' 'mempty' ≡ 'mempty' ≡ 'mempty' '><' r @ --- --- @ 'negate' 'sunit' '><' r ≡ 'negate' r @ --- --- Furthermore, the binomial formula holds for any commuting pair of elements (that is, any /a/ and /b/ such that /a >< b = b >< a/). --- --- If /mempty = sunit/ in a ring /R/, then /R/ has only one element, and is called the zero ring. --- Otherwise the additive identity, the additive inverse of each element, and the multiplicative identity are unique. --- --- See < https://en.wikipedia.org/wiki/Ring_(mathematics) >. --- --- 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 @ --- --- @ mempty <= a && mempty <= b ==> mempty <= a >< b @ --- --- See the properties module for a detailed specification of the laws. --- -class (Group r, Semiring r) => Ring r where - - -- | A ring homomorphism from the integers to /r/. - fromInteger :: Integer -> r - - -- | Absolute value of an element. - -- - -- @ abs r ≡ r >< signum r @ - -- - abs :: Ord r => r -> r - abs x = if mempty <= x then x else negate x - - -- satisfies trichotomy law: - -- Exactly one of the following is true: a is positive, -a is positive, or a = 0. - -- This property follows from the fact that ordered rings are abelian, linearly ordered groups with respect to addition. - signum :: Ord r => r -> r - signum x = if mempty <= x then sunit else negate sunit diff --git a/src/Data/Semifield.hs b/src/Data/Semifield.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semifield.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Semifield ( + (/) + , (^^) + , recip + , anan + , pinf + , ninf + , type SemifieldLaw, Semifield + , type FieldLaw, Field +) where + +import safe Data.Bool +import safe Data.Complex +import safe Data.Fixed +import safe Data.Foldable as Foldable (fold, foldl') +import safe Data.Int +import safe Data.Semiring +import safe Data.Semigroup.Foldable as Foldable1 +import safe Data.Semigroup.Additive +import safe Data.Semigroup.Multiplicative +import safe Data.Tuple +import safe Data.Word +import safe GHC.Real hiding (Fractional(..), (^^), (^), div) +import safe Numeric.Natural +import safe Foreign.C.Types (CFloat(..),CDouble(..)) + +import Prelude ( Eq(..), Ord(..), Show(..), Applicative(..), Functor(..), Monoid(..), Semigroup(..), (.), ($), flip, (<$>), Integer, fromInteger, Float, Double) +import qualified Prelude as P + +infixr 8 ^^ + +-- @ '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) + +-- | Take the reciprocal of a multiplicative group element. +-- +-- >>> 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 #-} + +anan :: Semifield a => a +anan = zero / zero +{-# INLINE anan #-} + +pinf :: Semifield a => a +pinf = one / zero +{-# INLINE pinf #-} + +ninf :: Field a => a +ninf = negate one / zero +{-# INLINE ninf #-} + +-- Sometimes called a division ring +type SemifieldLaw a = ((Additive-Monoid) a, (Multiplicative-Group) a) + +-- | A semifield, near-field, division ring, or associative division algebra. +-- +-- Instances needn't have commutative multiplication or additive inverses. +-- +-- 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 >, and < https://en.wikipedia.org/wiki/Division_algebra division algebra >. +-- +class (Semiring a, SemifieldLaw a) => Semifield a + +instance Semifield () +instance Semifield (Ratio Natural) +instance Semifield Rational + +instance Semifield Uni +instance Semifield Deci +instance Semifield Centi +instance Semifield Milli +instance Semifield Micro +instance Semifield Nano +instance Semifield Pico + +instance Semifield Float +instance Semifield Double +instance Semifield CFloat +instance Semifield CDouble + +instance Field a => Semifield (Complex a) + +type FieldLaw a = ((Additive-Group) a, (Multiplicative-Group) a) + +class (Ring a, Semifield a, FieldLaw a) => Field a + +instance Field () +instance Field Rational + +instance Field Uni +instance Field Deci +instance Field Centi +instance Field Milli +instance Field Micro +instance Field Nano +instance Field Pico + +instance Field Float +instance Field Double +instance Field CFloat +instance Field CDouble + +instance Field a => Field (Complex a) + +{- +class (Ord a, Field a) => Real a + +instance Real Rational + +instance Real Uni +instance Real Deci +instance Real Centi +instance Real Milli +instance Real Micro +instance Real Nano +instance Real Pico + +instance Real Float +instance Real Double +instance Real CFloat +instance Real CDouble +-} + diff --git a/src/Data/Semigroup/Additive.hs b/src/Data/Semigroup/Additive.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semigroup/Additive.hs @@ -0,0 +1,547 @@ +{-# 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.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.Foldable hiding (sum) +import safe Data.Group +import safe Data.Int +import safe Data.List +import safe Data.List.NonEmpty +import safe Data.Ord +import safe Data.Semigroup +import safe Data.Semigroup.Foldable +import safe Data.Semigroup.Multiplicative +import safe Data.Tuple +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, Ordering(..), Bounded(..), Applicative(..), Functor(..), Monoid(..), Semigroup(..), (.), ($), flip, (<$>), Integer, Float, Double) +import safe qualified Prelude as P + +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet + + +infixl 6 + + +-- >>> 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 6 - + +(-) :: (Additive-Group) a => a -> a -> a +a - b = unAdditive (Additive a << Additive b) +{-# INLINE (-) #-} + +zero :: (Additive-Monoid) a => a +zero = unAdditive mempty +{-# INLINE zero #-} + +-- | 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 #-} + + + + +{- +newtype Ordered a = Ordered { unOrdered :: a } deriving (Eq, Generic, Ord, Show, Functor) + +instance Applicative Ordered where + pure = Ordered + Ordered f <*> Ordered a = Ordered (f a) + +instance Distributive Ordered where + distribute = distributeRep + {-# INLINE distribute #-} + +instance Representable Ordered where + type Rep Ordered = () + tabulate f = Ordered (f ()) + {-# INLINE tabulate #-} + + index (Ordered x) () = x + {-# INLINE index #-} + +newtype Plus a = Plus { unPlus :: a } deriving (Eq, Generic, Ord, Show, Functor) + +instance Applicative Plus where + pure = Plus + Plus f <*> Plus a = Plus (f a) + +instance Distributive Plus where + distribute = distributeRep + {-# INLINE distribute #-} + +instance Representable Plus where + type Rep Plus = () + tabulate f = Plus (f ()) + {-# INLINE tabulate #-} + + index (Plus 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 +--------------------------------------------------------------------- + +#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) + +--------------------------------------------------------------------- +-- Complex +--------------------------------------------------------------------- + +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 $ (a - c) :+ (b - d) + {-# 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 $ (a * c - b * d) :+ (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)) :+ ((b * c - a * d) / (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)) + +--------------------------------------------------------------------- +-- 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 (<>) #-} + +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 $ (a * d - c * b) :% (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 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 (<>) #-} + +--------------------------------------------------------------------- +-- Idempotent and selective instances +--------------------------------------------------------------------- + +-- 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 (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 (<>) #-} + +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 + Additive (x1, y1) <> Additive (x2, y2) = Additive (x1 + x2, y1 + y2) + +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, (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 (Additive-Semigroup) a => Monoid (Additive (Maybe a)) where + mempty = Additive Nothing + +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 diff --git a/src/Data/Semigroup/Multiplicative.hs b/src/Data/Semigroup/Multiplicative.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semigroup/Multiplicative.hs @@ -0,0 +1,359 @@ +{-# 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.Complex +import safe Data.Maybe +import safe Data.Either +import safe Data.Fixed +import safe Data.Foldable as Foldable (Foldable, foldr', foldl') +import safe Data.Group +import safe Data.Int +import safe Data.List +import safe Data.List.NonEmpty +import safe Data.Semigroup +import safe Data.Semigroup.Foldable as Foldable1 +import safe Data.Tuple +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 Prelude ( Eq(..), Ord, Show, Ordering(..), Bounded(..), Applicative(..), Functor(..), Monoid(..), Semigroup(..), (.), ($), flip, (<$>), Integer, Float, Double) +import safe qualified Prelude as P + +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import qualified Data.Sequence as Seq + + +import safe Data.Distributive +import safe Data.Functor.Rep + +infixr 1 - + +-- | Hyphenation operator. +type (g - f) a = f (g a) + +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 (*) #-} + +infixl 7 / + +(/) :: (Multiplicative-Group) a => a -> a -> a +a / b = unMultiplicative (Multiplicative a << Multiplicative b) +{-# INLINE (/) #-} + + + +one :: (Multiplicative-Monoid) a => a +one = unMultiplicative mempty +{-# INLINE one #-} + +div :: (Multiplicative-Group) a => a -> a -> a +a `div` b = unMultiplicative (Multiplicative a << Multiplicative b) +{-# INLINE div #-} + +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 #-} + +--------------------------------------------------------------------- +-- Num-based 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 (x@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(x@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 new file mode 100644 --- /dev/null +++ b/src/Data/Semigroup/Property.hs @@ -0,0 +1,140 @@ +{-# Language AllowAmbiguousTypes #-} +{-# LANGUAGE Safe #-} + +module Data.Semigroup.Property where +{- ( + -- * Required properties of semigroups + associative_addition_on + , associative_multiplication_on + -- * Required properties of monoids + , neutral_addition_on + , neutral_multiplication_on + -- * Required properties of semigroup & monoid morphisms + , morphism_additive_on + , morphism_multiplicative_on + , morphism_additive_on' + , morphism_multiplicative_on' + -- * Properties of commuative semigroups + , commutative_addition_on + , commutative_multiplication_on + -- * Properties of idempotent semigroups + , idempotent_addition_on + , idempotent_multiplication_on + -- * Properties of cancellative semigroups + , cancellative_addition_on + , cancellative_multiplication_on +) where +-} + +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) + +import safe Prelude hiding (Num(..), sum) + +{- +------------------------------------------------------------------------------------ +-- Required properties of semigroups + +-- | \( \forall a, b, c \in R: (a + b) + c \sim a + (b + c) \) +-- +-- All semigroups must right-associate addition. +-- +-- This is a required property. +-- +associative_addition_on :: (Additive-Semigroup) r => Rel r b -> r -> r -> r -> b +associative_addition_on (~~) = Prop.associative_on (~~) add + +-- | \( \forall a, b, c \in R: (a * b) * c \sim a * (b * c) \) +-- +-- All semigroups must right-associate multiplication. +-- +-- This is a required property. +-- +associative_multiplication_on :: (Multiplicative-Semigroup) r => Rel r b -> r -> r -> r -> b +associative_multiplication_on (~~) = Prop.associative_on (~~) mul + +------------------------------------------------------------------------------------ +-- Required properties of monoids + +-- | \( \forall a \in R: (z + a) \sim a \) +-- +-- A semigroup with a right-neutral additive identity must satisfy: +-- +-- @ +-- 'neutral_addition' 'zero' ~~ const 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 (~~) add zero + +-- | \( \forall a \in R: (o * a) \sim a \) +-- +-- A semigroup with a right-neutral multiplicative identity must satisfy: +-- +-- @ +-- 'neutral_multiplication' 'one' ~~ const True +-- @ +-- +-- Or, equivalently: +-- +-- @ +-- 'one' '*' r ~~ r +-- @ +-- +-- This is a required propert for multiplicative monoids. +-- +neutral_multiplication_on :: (Multiplicative-Monoid) r => Rel r b -> r -> b +neutral_multiplication_on (~~) = Prop.neutral_on (~~) mul one + +-} + +------------------------------------------------------------------------------------ +-- Properties of 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 `add` y) ~~ (f x `add` f y) + +morphism_multiplicative_on :: (Multiplicative-Semigroup) r => (Multiplicative-Semigroup) s => Rel s b -> (r -> s) -> r -> r -> b +morphism_multiplicative_on (~~) f x y = (f $ x `mul` y) ~~ (f x `mul` f y) + +morphism_additive_on' :: (Additive-Monoid) r => (Additive-Monoid) s => Rel s b -> (r -> s) -> b +morphism_additive_on' (~~) f = (f zero) ~~ zero + +morphism_multiplicative_on' :: (Multiplicative-Monoid) r => (Multiplicative-Monoid) s => Rel s b -> (r -> s) -> b +morphism_multiplicative_on' (~~) f = (f one) ~~ one + +------------------------------------------------------------------------------------ +-- 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 (~~) add + +-- | \( \forall a, b \in R: a * b \sim b * a \) +-- +-- This is a an /optional/ property for semigroups, and a /optional/ property for semirings. +-- It is a /required/ property for rings. +-- +commutative_multiplication_on :: (Multiplicative-Semigroup) r => Rel r b -> r -> r -> b +commutative_multiplication_on (~~) = Prop.commutative_on (~~) mul + +-} +------------------------------------------------------------------------------------ +-- Properties of idempotent dioids and predioids + + diff --git a/src/Data/Semimodule.hs b/src/Data/Semimodule.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semimodule.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} + +module Data.Semimodule where + +import safe Data.Bool +import safe Data.Complex +import safe Data.Semifield +import safe Data.Fixed +import safe Data.Functor.Compose +import safe Data.Functor.Rep +import safe Data.Int +import safe Data.Semiring +import safe Data.Semigroup.Foldable as Foldable1 +import safe Data.Tuple +import safe Data.Word +import safe GHC.Real hiding (Fractional(..)) +import safe Numeric.Natural +import safe Foreign.C.Types (CFloat(..),CDouble(..)) +import safe Prelude hiding (Num(..), Fractional(..), sum, product) +import safe qualified Prelude as N + +import safe Data.Semigroup.Additive as A +import safe Data.Semigroup.Multiplicative as M + +import safe Prelude (fromInteger) + + +type Free f = (Representable f, Eq (Rep f)) + +type Basis b f = (Free f, Rep f ~ b) + +{- + +-- Semimodule over a semifield +-- dioids +type DSpace r a = (Semifield r, Semimodule r a) + + +-- | Free semimodule over a generating set. +-- +type FreeSemimodule a f = (Free f, Semimodule a (f a)) + +type FreeModule a f = (Free f, Module a (f a)) + +type CommutativeGroup a = Module Integer a + +-} + + +--instance (Unital (f a), Algebra (f a), Functor f) => Semifield (f a) where + --recip q = conj' q // norm' q +-- recip q = ((recip . norm' $ q) ><) <$> conj' q + +type Module r a = (Ring r, Group a, Semimodule r a) + +infixl 7 .*, *. + +-- | < https://en.wikipedia.org/wiki/Semimodule Semimodule > over a commutative semiring. +-- +-- All instances must satisfy the following identities: +-- +-- @ r '*.' (x '<>' y) '==' r '*.' x '<>' r '*.' y @ +-- +-- @ (r '+' s) '*.' x '==' r '*.' x '<>' s '*.' x @ +-- +-- @ (r '*' s) '*.' x '==' r '*.' (s '*.' x) @ +-- +-- When the ring of coefficients /r/ is unital we must additionally have: +-- +-- @ 'one' '*.' x '==' x @ +-- +-- See the properties module for a detailed specification of the laws. +-- +class (Semiring r, Semigroup a) => Semimodule r a where + -- | Left-multiply by a scalar. + -- + (*.) :: r -> a -> a + (*.) = flip (.*) + + -- | Right-multiply by a scalar. + -- + (.*) :: a -> r -> a + (.*) = flip (*.) + + + +-- | Default definition of '(*.)' for a free module. +-- +multl :: Semiring a => Functor f => a -> f a -> f a +multl a f = (a *) <$> f + +-- | Default definition of '(.*)' for a free module. +-- +multr :: Semiring a => Functor f => f a -> a -> f a +multr f a = (* a) <$> f + +-- | Default definition of '<<' for a commutative group. +-- +negateDef :: Semimodule Integer a => a -> a +negateDef a = (-1 :: Integer) *. a + +-- | Linearly interpolate between two vectors. +-- +-- >>> u = V3 (1 :% 1) (2 :% 1) (3 :% 1) :: V3 Rational +-- >>> v = V3 (2 :% 1) (4 :% 1) (6 :% 1) :: V3 Rational +-- >>> r = 1 :% 2 :: Rational +-- >>> lerp r u v +-- V3 (6 % 4) (12 % 4) (18 % 4) +-- +lerp :: Module r a => r -> a -> a -> a +lerp r f g = r *. f <> (one - r) *. g +{-# INLINE lerp #-} + +infix 6 .*. + +-- | Dot product. +-- +-- >>> V3 1 2 3 .*. V3 1 2 3 +-- 14 +-- +(.*.) :: Free f => Foldable f => Semiring a => f a -> f a -> a +(.*.) x y = sum $ liftR2 (*) x y +{-# INLINE (.*.) #-} + +-- | Squared /l2/ norm of a vector. +-- +quadrance :: Free f => Foldable f => Semiring a => f a -> a +quadrance f = f .*. f +{-# INLINE quadrance #-} + +-- | Squared /l2/ norm of the difference between two vectors. +-- +qd :: Free f => Foldable f => Module a (f a) => f a -> f a -> a +qd f g = quadrance $ f << g +{-# INLINE qd #-} + +-- | 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 I21 :: V2 Int +-- V2 1 0 +-- +-- >>> idx I42 :: V4 Int +-- V4 0 1 0 0 +-- +idx :: Free f => Semiring a => Rep f -> f a +idx i = tabulate $ dirac i +{-# INLINE idx #-} + +------------------------------------------------------------------------------- +-- Instances +------------------------------------------------------------------------------- + +instance Semiring r => Semimodule r () where + _ *. _ = () + +instance Semigroup a => Semimodule () a where + _ *. a = a + +instance Monoid a => Semimodule Natural a where + (*.) = mreplicate + +instance Group a => Semimodule Integer a where + (*.) = greplicate + +instance Semimodule r a => Semimodule r (e -> a) where + a *. f = (a *.) <$> f + +instance (Semimodule r a, Semimodule r b) => Semimodule r (a, b) where + n *. (a, b) = (n *. a, n *. b) + +instance (Semimodule r a, Semimodule r b, Semimodule r c) => Semimodule r (a, b, c) where + n *. (a, b, c) = (n *. a, n *. b, n *. c) + +instance (Semiring a, Semimodule r a) => Semimodule r (Additive (Ratio a)) where + a *. (Additive (x :% y)) = Additive $ (a *. x) :% y + +instance (Ring a, Semimodule r a) => Semimodule r (Additive (Complex a)) where + a *. (Additive (x :+ y)) = Additive $ (a *. x) :+ (a *. y) + +#define deriveSemimodule(ty) \ +instance Semiring ty => Semimodule ty (Additive ty) where { \ + r *. (Additive a) = Additive $ r * a \ +; {-# INLINE (*.) #-} \ +} + +deriveSemimodule(Bool) +deriveSemimodule(Int) +deriveSemimodule(Int8) +deriveSemimodule(Int16) +deriveSemimodule(Int32) +deriveSemimodule(Int64) +deriveSemimodule(Word) +deriveSemimodule(Word8) +deriveSemimodule(Word16) +deriveSemimodule(Word32) +deriveSemimodule(Word64) +deriveSemimodule(Uni) +deriveSemimodule(Deci) +deriveSemimodule(Centi) +deriveSemimodule(Milli) +deriveSemimodule(Micro) +deriveSemimodule(Nano) +deriveSemimodule(Pico) +deriveSemimodule(Float) +deriveSemimodule(Double) +deriveSemimodule(CFloat) +deriveSemimodule(CDouble) diff --git a/src/Data/Semimodule/Matrix.hs b/src/Data/Semimodule/Matrix.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semimodule/Matrix.hs @@ -0,0 +1,552 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE RankNTypes #-} + +module Data.Semimodule.Matrix ( + type M22 + , type M23 + , type M24 + , type M32 + , type M33 + , type M34 + , type M42 + , type M43 + , type M44 + , lensRep + , grateRep + , tran + , row + , rows + , col + , cols + , (.#) + , (.*) + , (#.) + , (*.) + , (.#.) + , (.*.) + , outer + , scale + , dirac + , identity + , transpose + , trace + , diagonal + , bdet2 + , det2 + , inv2 + , bdet3 + , det3 + , inv3 + , bdet4 + , det4 + , inv4 + , m22 + , m23 + , m24 + , m32 + , m33 + , m34 + , m42 + , m43 + , m44 + ) where + +import safe Data.Bool +import safe Data.Distributive +import safe Data.Functor.Compose +import safe Data.Functor.Rep +import safe Data.Semifield +import safe Data.Semigroup.Additive +import safe Data.Semigroup.Multiplicative +import safe Data.Semimodule +import safe Data.Semimodule.Transform +import safe Data.Semimodule.Vector +import safe Data.Semiring +import safe Data.Tuple +import safe Prelude hiding (Num(..), Fractional(..), sum, negate) + + +-- All matrices use row-major representation. + +-- | A 2x2 matrix. +type M22 a = V2 (V2 a) + +-- | A 2x3 matrix. +type M23 a = V2 (V3 a) + +-- | A 2x4 matrix. +type M24 a = V2 (V4 a) + +-- | A 3x2 matrix. +type M32 a = V3 (V2 a) + +-- | A 3x3 matrix. +type M33 a = V3 (V3 a) + +-- | A 3x4 matrix. +type M34 a = V3 (V4 a) + +-- | A 4x2 matrix. +type M42 a = V4 (V2 a) + +-- | A 4x3 matrix. +type M43 a = V4 (V3 a) + +-- | A 4x4 matrix. +type M44 a = V4 (V4 a) + +lensRep :: Eq (Rep f) => Representable 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 #-} + +grateRep :: Representable f => forall g. Functor g => (Rep f -> g a -> b) -> g (f a) -> f b +grateRep iab s = tabulate $ \i -> iab i (fmap (`index` i) s) +{-# INLINE grateRep #-} + +-- @ ('.#') = 'app' . 'tran' @ +tran :: Semiring a => Basis b f => Basis c g => Foldable g => f (g a) -> Tran a b c +tran m = Tran $ \f -> index $ m .# (tabulate f) + +-- | Retrieve a row of a row-major matrix or element of a row vector. +-- +-- >>> row I21 (V2 1 2) +-- 1 +-- +row :: Representable f => Rep f -> f a -> a +row = flip index +{-# INLINE row #-} + +-- | Retrieve a column of a row-major matrix. +-- +-- >>> row I22 . col I31 $ V2 (V3 1 2 3) (V3 4 5 6) +-- 4 +-- +col :: Functor f => Representable g => Rep g -> f (g a) -> f a +col j = flip index j . distribute +{-# INLINE col #-} + +-- | Outer product of two vectors. +-- +-- >>> V2 1 1 `outer` V2 1 1 +-- V2 (V2 1 1) (V2 1 1) +-- +outer :: Semiring a => Functor f => Functor g => f a -> g a -> f (g a) +outer x y = fmap (\z-> fmap (*z) y) x + +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 15 0 +-- +(#.) :: (Semiring a, Free f, Foldable f, Free g) => f a -> f (g a) -> g a +x #. y = tabulate (\j -> x .*. col j y) +{-# INLINE (#.) #-} + +infixr 7 .#, .#. + +-- | Multiply a matrix on the right by a column vector. +-- +-- @ ('.#') = 'app' . 'fromMatrix' @ +-- +-- >>> m23 1 2 3 4 5 6 .# V3 7 8 9 +-- V2 50 122 +-- +-- >>> m22 1 0 0 0 .# m23 1 2 3 4 5 6 .# V3 7 8 9 +-- V2 50 0 +-- +(.#) :: (Semiring a, Free f, Free g, Foldable g) => f (g a) -> g a -> f a +x .# y = tabulate (\i -> row i x .*. y) +{-# INLINE (.#) #-} + +-- | Multiply two matrices. +-- +-- >>> m22 1 2 3 4 .#. m22 1 2 3 4 :: M22 Int +-- V2 (V2 7 10) (V2 15 22) +-- +-- >>> m23 1 2 3 4 5 6 .#. m32 1 2 3 4 4 5 :: M22 Int +-- V2 (V2 19 25) (V2 43 58) +-- +(.#.) :: (Semiring a, Free f, Free g, Free h, Foldable g) => f (g a) -> g (h a) -> f (h a) +(.#.) x y = getCompose $ tabulate (\(i,j) -> row i x .*. col j y) +{-# INLINE (.#.) #-} + +-- | Obtain a diagonal matrix from a vector. +-- +-- >>> scale (V2 2 3) +-- V2 (V2 2 0) (V2 0 3) +-- +scale :: (Additive-Monoid) a => Free f => f a -> f (f a) +scale f = flip imapRep f $ \i x -> flip imapRep f (\j _ -> bool zero x $ i == j) +{-# INLINE scale #-} + +-- | Identity matrix. +-- +-- >>> identity :: M44 Int +-- V4 (V4 1 0 0 0) (V4 0 1 0 0) (V4 0 0 1 0) (V4 0 0 0 1) +-- +-- >>> identity :: V3 (V3 Int) +-- V3 (V3 1 0 0) (V3 0 1 0) (V3 0 0 1) +-- +identity :: Semiring a => Free f => f (f a) +identity = scale $ pureRep one +{-# INLINE identity #-} + +-- | Compute the trace of a matrix. +-- +-- >>> trace (V2 (V2 a b) (V2 c d)) +-- a <> d +-- +trace :: Semiring a => Free f => Foldable f => f (f a) -> a +trace = sum . diagonal +{-# INLINE trace #-} + +-- | Obtain the diagonal of a matrix as a vector. +-- +-- >>> diagonal (V2 (V2 a b) (V2 c d)) +-- V2 a d +-- +diagonal :: Representable f => f (f a) -> f a +diagonal = flip bindRep id +{-# INLINE diagonal #-} + +ij :: Representable f => Representable g => Rep f -> Rep g -> f (g a) -> a +ij i j = row i . col j + +-- | 2x2 matrix bdeterminant over a commutative semiring. +-- +-- >>> bdet2 $ m22 1 2 3 4 +-- (4,6) +-- +bdet2 :: Semiring a => Basis I2 f => Basis I2 g => f (g a) -> (a, a) +bdet2 m = (ij I21 I21 m * ij I22 I22 m, ij I21 I22 m * ij I22 I21 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 => Basis I2 f => Basis I2 g => f (g a) -> a +det2 = uncurry (-) . bdet2 +{-# INLINE det2 #-} + +-- | 2x2 matrix inverse over a field. +-- +-- >>> inv2 $ m22 1 2 3 4 :: M22 Double +-- V2 (V2 (-2.0) 1.0) (V2 1.5 (-0.5)) +-- +inv2 :: Field a => Basis I2 f => Basis I2 g => f (g a) -> g (f a) +inv2 m = multl (recip $ det2 m) <$> m22 d (-b) (-c) a where + a = ij I21 I21 m + b = ij I21 I22 m + c = ij I22 I21 m + d = ij I22 I22 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 => Basis I3 f => Basis I3 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 = ij I31 I31 m + b = ij I31 I32 m + c = ij I31 I33 m + d = ij I32 I31 m + e = ij I32 I32 m + f = ij I32 I33 m + g = ij I33 I31 m + h = ij I33 I32 m + i = ij I33 I33 m +{-# INLINE bdet3 #-} + +-- | 3x3 double-precision matrix determinant. +-- +-- @ +-- 'det3' '==' 'uncurry' ('-') . 'bdet3' +-- @ +-- +-- Implementation uses a cofactor expansion to avoid loss of precision. +-- +-- >>> det3 (V3 (V3 1 2 3) (V3 4 5 6) (V3 7 8 9)) +-- 0 +-- +det3 :: Ring a => Basis I3 f => Basis I3 g => f (g a) -> a +det3 m = a * (e*i-f*h) - d * (b*i-c*h) + g * (b*f-c*e) where + a = ij I31 I31 m + b = ij I31 I32 m + c = ij I31 I33 m + d = ij I32 I31 m + e = ij I32 I32 m + f = ij I32 I33 m + g = ij I33 I31 m + h = ij I33 I32 m + i = ij I33 I33 m +{-# INLINE det3 #-} + +-- | 3x3 matrix inverse. +-- +-- >>> inv3 $ m33 1 2 4 4 2 2 1 1 1 :: M33 Double +-- V3 (V3 0.0 0.5 (-1.0)) (V3 (-0.5) (-0.75) 3.5) (V3 0.5 0.25 (-1.5)) +-- +inv3 :: forall a f g. Field a => Basis I3 f => Basis I3 g => f (g a) -> g (f a) +inv3 m = multl (recip $ det3 m) <$> m33 a' b' c' d' e' f' g' h' i' where + a = ij I31 I31 m + b = ij I31 I32 m + c = ij I31 I33 m + d = ij I32 I31 m + e = ij I32 I32 m + f = ij I32 I33 m + g = ij I33 I31 m + h = ij I33 I32 m + i = ij I33 I33 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 :: M22 a) +{-# INLINE inv3 #-} + +-- | 4x4 matrix bdeterminant over a commutative semiring. +-- +-- >>> bdet4 (V4 (V4 1 2 3 4) (V4 5 6 7 8) (V4 9 10 11 12) (V4 13 14 15 16)) +-- (27728,27728) +-- +bdet4 :: Semiring a => Basis I4 f => Basis I4 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 = ij I41 I41 x + b = ij I41 I42 x + c = ij I41 I43 x + d = ij I41 I44 x + e = ij I42 I41 x + f = ij I42 I42 x + g = ij I42 I43 x + h = ij I42 I44 x + i = ij I43 I41 x + j = ij I43 I42 x + k = ij I43 I43 x + l = ij I43 I44 x + m = ij I44 I41 x + n = ij I44 I42 x + o = ij I44 I43 x + p = ij I44 I44 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 :: M44 Rational) +-- (-12) % 1 +-- +det4 :: Ring a => Basis I4 f => Basis I4 g => f (g a) -> a +det4 x = s0 * c5 - s1 * c4 + s2 * c3 + s3 * c2 - s4 * c1 + s5 * c0 where + s0 = i00 * i11 - i10 * i01 + s1 = i00 * i12 - i10 * i02 + s2 = i00 * i13 - i10 * i03 + s3 = i01 * i12 - i11 * i02 + s4 = i01 * i13 - i11 * i03 + s5 = i02 * i13 - i12 * i03 + + c5 = i22 * i33 - i32 * i23 + c4 = i21 * i33 - i31 * i23 + c3 = i21 * i32 - i31 * i22 + c2 = i20 * i33 - i30 * i23 + c1 = i20 * i32 - i30 * i22 + c0 = i20 * i31 - i30 * i21 + + i00 = ij I41 I41 x + i01 = ij I41 I42 x + i02 = ij I41 I43 x + i03 = ij I41 I44 x + i10 = ij I42 I41 x + i11 = ij I42 I42 x + i12 = ij I42 I43 x + i13 = ij I42 I44 x + i20 = ij I43 I41 x + i21 = ij I43 I42 x + i22 = ij I43 I43 x + i23 = ij I43 I44 x + i30 = ij I44 I41 x + i31 = ij I44 I42 x + i32 = ij I44 I43 x + i33 = ij I44 I44 x +{-# INLINE det4 #-} + +-- | 4x4 matrix inverse. +-- +-- >>> row I41 $ inv4 (m44 1 0 3 2 2 0 2 1 0 0 0 1 0 3 4 0 :: M44 Rational) +-- V4 (6 % (-12)) ((-9) % (-12)) ((-3) % (-12)) (0 % (-12)) +-- +inv4 :: forall a f g. Field a => Basis I4 f => Basis I4 g => f (g a) -> g (f a) +inv4 x = multl (recip det) <$> x' where + i00 = ij I41 I41 x + i01 = ij I41 I42 x + i02 = ij I41 I43 x + i03 = ij I41 I44 x + i10 = ij I42 I41 x + i11 = ij I42 I42 x + i12 = ij I42 I43 x + i13 = ij I42 I44 x + i20 = ij I43 I41 x + i21 = ij I43 I42 x + i22 = ij I43 I43 x + i23 = ij I43 I44 x + i30 = ij I44 I41 x + i31 = ij I44 I42 x + i32 = ij I44 I43 x + i33 = ij I44 I44 x + + s0 = i00 * i11 - i10 * i01 + s1 = i00 * i12 - i10 * i02 + s2 = i00 * i13 - i10 * i03 + s3 = i01 * i12 - i11 * i02 + s4 = i01 * i13 - i11 * i03 + s5 = i02 * i13 - i12 * i03 + c5 = i22 * i33 - i32 * i23 + c4 = i21 * i33 - i31 * i23 + c3 = i21 * i32 - i31 * i22 + c2 = i20 * i33 - i30 * i23 + c1 = i20 * i32 - i30 * i22 + c0 = i20 * i31 - i30 * i21 + + det = s0 * c5 - s1 * c4 + s2 * c3 + s3 * c2 - s4 * c1 + s5 * c0 + + x' = m44 (i11 * c5 - i12 * c4 + i13 * c3) + (-i01 * c5 + i02 * c4 - i03 * c3) + (i31 * s5 - i32 * s4 + i33 * s3) + (-i21 * s5 + i22 * s4 - i23 * s3) + (-i10 * c5 + i12 * c2 - i13 * c1) + (i00 * c5 - i02 * c2 + i03 * c1) + (-i30 * s5 + i32 * s2 - i33 * s1) + (i20 * s5 - i22 * s2 + i23 * s1) + (i10 * c4 - i11 * c2 + i13 * c0) + (-i00 * c4 + i01 * c2 - i03 * c0) + (i30 * s4 - i31 * s2 + i33 * s0) + (-i20 * s4 + i21 * s2 - i23 * s0) + (-i10 * c3 + i11 * c1 - i12 * c0) + (i00 * c3 - i01 * c1 + i02 * c0) + (-i30 * s3 + i31 * s1 - i32 * s0) + (i20 * s3 - i21 * s1 + i22 * s0) +{-# INLINE inv4 #-} + +-- | Construct a 2x2 matrix. +-- +-- Arguments are in row-major order. +-- +-- >>> m22 1 2 3 4 :: M22 Int +-- V2 (V2 1 2) (V2 3 4) +-- +-- @ 'm22' :: a -> a -> a -> a -> 'M22' a @ +-- +m22 :: Basis I2 f => Basis I2 g => a -> a -> a -> a -> f (g a) +m22 a b c d = fillI2 (fillI2 a b) (fillI2 c d) +{-# INLINE m22 #-} + +-- | Construct a 2x3 matrix. +-- +-- Arguments are in row-major order. +-- +-- @ 'm23' :: a -> a -> a -> a -> a -> a -> 'M23' a @ +-- +m23 :: Basis I2 f => Basis I3 g => a -> a -> a -> a -> a -> a -> f (g a) +m23 a b c d e f = fillI2 (fillI3 a b c) (fillI3 d e f) +{-# INLINE m23 #-} + +-- | Construct a 2x4 matrix. +-- +-- Arguments are in row-major order. +-- +m24 :: Basis I2 f => Basis I4 g => a -> a -> a -> a -> a -> a -> a -> a -> f (g a) +m24 a b c d e f g h = fillI2 (fillI4 a b c d) (fillI4 e f g h) +{-# INLINE m24 #-} + +-- | Construct a 3x2 matrix. +-- +-- Arguments are in row-major order. +-- +m32 :: Basis I3 f => Basis I2 g => a -> a -> a -> a -> a -> a -> f (g a) +m32 a b c d e f = fillI3 (fillI2 a b) (fillI2 c d) (fillI2 e f) +{-# INLINE m32 #-} + +-- | Construct a 3x3 matrix. +-- +-- Arguments are in row-major order. +-- +m33 :: Basis I3 f => Basis I3 g => a -> a -> a -> a -> a -> a -> a -> a -> a -> f (g a) +m33 a b c d e f g h i = fillI3 (fillI3 a b c) (fillI3 d e f) (fillI3 g h i) +{-# INLINE m33 #-} + +-- | Construct a 3x4 matrix. +-- +-- Arguments are in row-major order. +-- +m34 :: Basis I3 f => Basis I4 g => a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> f (g a) +m34 a b c d e f g h i j k l = fillI3 (fillI4 a b c d) (fillI4 e f g h) (fillI4 i j k l) +{-# INLINE m34 #-} + +-- | Construct a 4x2 matrix. +-- +-- Arguments are in row-major order. +-- +m42 :: Basis I4 f => Basis I2 g => a -> a -> a -> a -> a -> a -> a -> a -> f (g a) +m42 a b c d e f g h = fillI4 (fillI2 a b) (fillI2 c d) (fillI2 e f) (fillI2 g h) +{-# INLINE m42 #-} + +-- | Construct a 4x3 matrix. +-- +-- Arguments are in row-major order. +-- +m43 :: Basis I4 f => Basis I3 g => a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> f (g a) +m43 a b c d e f g h i j k l = fillI4 (fillI3 a b c) (fillI3 d e f) (fillI3 g h i) (fillI3 j k l) +{-# INLINE m43 #-} + +-- | Construct a 4x4 matrix. +-- +-- Arguments are in row-major order. +-- +m44 :: Basis I4 f => Basis I4 g => a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> f (g a) +m44 a b c d e f g h i j k l m n o p = fillI4 (fillI4 a b c d) (fillI4 e f g h) (fillI4 i j k l) (fillI4 m n o p) +{-# INLINE m44 #-} diff --git a/src/Data/Semimodule/Transform.hs b/src/Data/Semimodule/Transform.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semimodule/Transform.hs @@ -0,0 +1,247 @@ +{-# 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.Transform where + +import safe Control.Category (Category, (>>>)) +import safe Data.Functor.Compose +import safe Data.Functor.Product +import safe Data.Functor.Rep +import safe Data.Profunctor +import safe Data.Semimodule +import safe Data.Tuple (swap) +import safe Prelude hiding (Num(..), Fractional(..), negate, sum, product) +import safe Test.Logic +import safe qualified Control.Category as C +import safe qualified Data.Bifunctor as B + +{- +app' = app @I3 @V3 @I3 @V3 @Int + +-- >>> app' foo $ V3 1 2 3 +-- V3 2 1 3 +-- >>> app' foo >>> app' foo $ V3 1 2 3 +-- V3 1 2 3 +-- >>> app' (foo >>> foo) $ V3 1 2 3 +-- V3 1 2 3 +-- +foo = Tran $ \f -> f . t + where + t I31 = I32 + t I32 = I31 + t I33 = I33 +-} + + +--------------------------------------------------------------------- + +-- | A binary relation between two basis indices. +-- +-- @ 'Index' b c @ relations correspond to (compositions of) +-- permutation, projection, and embedding transformations. +-- +-- See also < https://en.wikipedia.org/wiki/Logical_matrix >. +-- +type Index b c = forall a . Tran a b c + +-- | A general linear transformation between free semimodules indexed with bases /b/ and /c/. +-- +newtype Tran a b c = Tran { runTran :: (c -> a) -> (b -> a) } deriving Functor + +app :: Basis b f => Basis c g => Tran a b c -> g a -> f a +app t = tabulate . runTran t . index + +instance Category (Tran a) where + id = Tran id + Tran f . Tran g = Tran $ g . f + +instance Profunctor (Tran a) where + lmap f (Tran t) = Tran $ \ca -> t ca . f + rmap = fmap + +-- | /Tran a b c/ is an invariant functor on /a/. +-- +-- 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 + +--------------------------------------------------------------------- + +-- | An endomorphism over a free semimodule. +-- +type Endo a b = Tran a b b + +-- | 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 = getCompose . app in1 +{-# INLINE rows #-} + +-- | 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 = getCompose . app in2 +{-# INLINE cols #-} + +projl :: Free f => Free g => Product f g a -> f a +projl = app exl + +projr :: Free f => Free g => Product f g a -> g a +projr = app exr + +-- | Left (post) composition with a linear transformation. +-- +compl :: Basis b f1 => Basis c f2 => Free g => Index b c -> f2 (g a) -> f1 (g a) +compl f = getCompose . app (first f) . Compose + +-- | Right (pre) composition with a linear transformation. +-- +compr :: Basis b g1 => Basis c g2 => Free f => Index b c -> f (g2 a) -> f (g1 a) +compr f = getCompose . app (second f) . Compose + +-- | Left and right composition with a linear transformation. +-- +-- @ 'complr f g' = 'compl f' . 'compr g' @ +-- +-- When /f . g = id/ this induces a similarity transformation: +-- +-- >>> perm1 = arr (+ I32) +-- >>> perm2 = arr (+ I33) +-- >>> m = m33 1 2 3 4 5 6 7 8 9 :: M33 Int +-- >>> conjugate perm1 perm2 m :: M33 Int +-- V3 (V3 5 6 4) (V3 8 9 7) (V3 2 3 1) +-- +-- See also < https://en.wikipedia.org/wiki/Matrix_similarity > & < https://en.wikipedia.org/wiki/Conjugacy_class >. +-- +complr :: Basis b1 f1 => Basis c1 f2 => Basis b2 g1 => Basis c2 g2 => Index b1 c1 -> Index b2 c2 -> f2 (g2 a) -> f1 (g1 a) +complr f g = getCompose . app (f *** g) . Compose + +-- | Transpose a matrix. +-- +-- >>> transpose (V3 (V2 1 2) (V2 3 4) (V2 5 6)) +-- V2 (V3 1 3 5) (V3 2 4 6) +-- +-- >>> 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 = getCompose . app braid . Compose +{-# INLINE transpose #-} + +--------------------------------------------------------------------- + +-- arr toI3 :: Dim3 e => Index e I3 + +-- @ 'arr' f = 'rmap' f 'C.id' @ +arr :: (b -> c) -> Index b c +arr f = Tran (. f) + +in1 :: Index (a , b) b +in1 = arr snd +{-# INLINE in1 #-} + +in2 :: Index (a , b) a +in2 = arr fst +{-# INLINE in2 #-} + +exl :: Index a (a + b) +exl = arr Left +{-# INLINE exl #-} + +exr :: Index b (a + b) +exr = arr Right +{-# INLINE exr #-} + +braid :: Index (a , b) (b , a) +braid = arr swap +{-# INLINE braid #-} + +ebraid :: Index (a + b) (b + a) +ebraid = arr eswap +{-# INLINE ebraid #-} + +first :: Index b c -> Index (b , d) (c , d) +first (Tran caba) = Tran $ \cda -> cda . B.first (caba id) + +second :: Index b c -> Index (d , b) (d , c) +second (Tran caba) = Tran $ \cda -> cda . B.second (caba id) + +left :: Index b c -> Index (b + d) (c + d) +left (Tran caba) = Tran $ \cda -> cda . B.first (caba id) + +right :: Index b c -> Index (d + b) (d + c) +right (Tran caba) = Tran $ \cda -> cda . B.second (caba id) + +infixr 3 *** + +(***) :: Index a1 b1 -> Index a2 b2 -> Index (a1 , a2) (b1 , b2) +x *** y = first x >>> arr swap >>> first y >>> arr swap +{-# INLINE (***) #-} + +infixr 2 +++ + +(+++) :: Index a1 b1 -> Index a2 b2 -> Index (a1 + a2) (b1 + b2) +x +++ y = left x >>> arr eswap >>> left y >>> arr eswap +{-# INLINE (+++) #-} + +infixr 3 &&& + +(&&&) :: Index a b1 -> Index a b2 -> Index a (b1 , b2) +x &&& y = dimap fork id $ x *** y +{-# INLINE (&&&) #-} + +infixr 2 ||| + +(|||) :: Index a1 b -> Index a2 b -> Index (a1 + a2) b +x ||| y = dimap id join $ x +++ y +{-# INLINE (|||) #-} + +infixr 0 $$$ + +($$$) :: Index a (b -> c) -> Index a b -> Index a c +($$$) f x = dimap fork apply (f *** x) +{-# INLINE ($$$) #-} + +adivide :: (a -> (a1 , a2)) -> Index a1 b -> Index a2 b -> Index a b +adivide f x y = dimap f fst $ x *** y +{-# INLINE adivide #-} + +adivide' :: Index a b -> Index a b -> Index a b +adivide' = adivide fork +{-# INLINE adivide' #-} + +adivided :: Index a1 b -> Index a2 b -> Index (a1 , a2) b +adivided = adivide id +{-# INLINE adivided #-} + +aselect :: ((b1 + b2) -> b) -> Index a b1 -> Index a b2 -> Index a b +aselect f x y = dimap Left f $ x +++ y +{-# INLINE aselect #-} + +aselect' :: Index a b -> Index a b -> Index a b +aselect' = aselect join +{-# INLINE aselect' #-} + +aselected :: Index a b1 -> Index a b2 -> Index a (b1 + b2) +aselected = aselect id +{-# INLINE aselected #-} diff --git a/src/Data/Semimodule/Vector.hs b/src/Data/Semimodule/Vector.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semimodule/Vector.hs @@ -0,0 +1,461 @@ +{-# 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.Vector ( + type Basis + , (*.) + , (.*) + , (.*.) + , (><) + , triple + , lerp + , quadrance + , qd + , dirac + , module Data.Semimodule.Vector +) where + +import safe Control.Applicative +import safe Data.Algebra +import safe Data.Bool +import safe Data.Distributive +import safe Data.Functor.Rep +import safe Data.Semifield +import safe Data.Semigroup.Foldable as Foldable1 +import safe Data.Semimodule +import safe Data.Semiring +import safe Prelude hiding (Num(..), Fractional(..), negate, sum, product) + +------------------------------------------------------------------------------- +-- V2 +------------------------------------------------------------------------------- + +data V2 a = V2 !a !a deriving (Eq,Ord,Show) + +-- | Vector addition. +-- +-- >>> V2 1 2 <> V2 3 4 +-- V2 4 6 +-- +instance (Additive-Semigroup) a => Semigroup (V2 a) where + (<>) = mzipWithRep (+) + +-- | Matrix addition. +-- +-- >>> m23 1 2 3 4 5 6 <> m23 7 8 9 1 2 3 :: M23 Int +-- V2 (V3 8 10 12) (V3 5 7 9) +-- +instance (Additive-Semigroup) a => Semigroup (Additive (V2 a)) where + (<>) = liftA2 $ mzipWithRep (+) + +instance (Additive-Monoid) a => Monoid (V2 a) where + mempty = pureRep zero + +instance (Additive-Monoid) a => Monoid (Additive (V2 a)) where + mempty = pure $ pureRep zero + +-- | Vector subtraction. +-- +-- >>> V2 1 2 << V2 3 4 +-- V2 (-2) (-2) +-- +instance (Additive-Group) a => Magma (V2 a) where + (<<) = mzipWithRep (-) + +-- | Matrix subtraction. +-- +-- >>> m23 1 2 3 4 5 6 << m23 7 8 9 1 2 3 :: M23 Int +-- V2 (V3 (-6) (-6) (-6)) (V3 3 3 3) +-- +instance (Additive-Group) a => Magma (Additive (V2 a)) where + (<<) = liftA2 $ mzipWithRep (-) + +instance (Additive-Group) a => Quasigroup (V2 a) +instance (Additive-Group) a => Quasigroup (Additive (V2 a)) +instance (Additive-Group) a => Loop (V2 a) +instance (Additive-Group) a => Loop (Additive (V2 a)) +instance (Additive-Group) a => Group (V2 a) +instance (Additive-Group) a => Group (Additive (V2 a)) + +instance Semiring a => Semimodule a (V2 a) where + (*.) = multl + {-# INLINE (*.) #-} + +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 = I2 + tabulate f = V2 (f I21) (f I22) + {-# INLINE tabulate #-} + + index (V2 x _) I21 = x + index (V2 _ y) I22 = y + {-# INLINE index #-} + +------------------------------------------------------------------------------- +-- Standard basis on two real dimensions +------------------------------------------------------------------------------- + +data I2 = I21 | I22 deriving (Eq, Ord, Show) + +i2 :: a -> a -> I2 -> a +i2 x _ I21 = x +i2 _ y I22 = y + +fillI2 :: Basis I2 f => a -> a -> f a +fillI2 x y = tabulate $ i2 x y + +instance Semigroup (Additive I2) where + Additive I21 <> x = x + x <> Additive I21 = x + + Additive I22 <> Additive I22 = Additive I21 + +instance Monoid (Additive I2) where + mempty = pure I21 + +-- trivial diagonal algebra +instance Semiring r => Algebra r I2 where + multiplyWith f = f' where + fi = f I21 I21 + fj = f I22 I22 + + f' I21 = fi + f' I22 = fj + +instance Semiring r => Composition r I2 where + conjugateWith = id + + normWith f = flip multiplyWith I21 $ \ix1 ix2 -> + flip multiplyWith I22 $ \jx1 jx2 -> + f ix1 * f ix2 + f jx1 * f jx2 + +------------------------------------------------------------------------------- +-- V3 +------------------------------------------------------------------------------- + + +data V3 a = V3 !a !a !a deriving (Eq,Ord,Show) + +-- | Vector addition. +-- +-- >>> V3 1 2 3 <> V3 4 5 6 +-- V3 5 7 9 +-- +instance (Additive-Semigroup) a => Semigroup (V3 a) where + (<>) = mzipWithRep (+) + +-- | Matrix addition. +-- +-- >>> V2 (V3 1 2 3) (V3 4 5 6) <> V2 (V3 7 8 9) (V3 1 2 3) +-- V2 (V3 8 10 12) (V3 5 7 9) +-- +instance (Additive-Semigroup) a => Semigroup (Additive (V3 a)) where + (<>) = liftA2 $ mzipWithRep (+) + +instance (Additive-Monoid) a => Monoid (V3 a) where + mempty = pureRep zero + +instance (Additive-Monoid) a => Monoid (Additive (V3 a)) where + mempty = pure $ pureRep zero + +-- | Vector subtraction. +-- +-- >>> V3 1 2 3 << V3 4 5 6 +-- V3 (-3) (-3) (-3) +-- +instance (Additive-Group) a => Magma (V3 a) where + (<<) = mzipWithRep (-) + +-- | Matrix subtraction. +-- +-- >>> V3 (V3 1 2 3) (V3 4 5 6) (V3 7 8 9) << V3 (V3 7 8 9) (V3 7 8 9) (V3 7 8 9) +-- V3 (V3 (-6) (-6) (-6)) (V3 (-3) (-3) (-3)) (V3 0 0 0) +-- +instance (Additive-Group) a => Magma (Additive (V3 a)) where + (<<) = liftA2 $ mzipWithRep (-) + +instance (Additive-Group) a => Quasigroup (V3 a) +instance (Additive-Group) a => Quasigroup (Additive (V3 a)) +instance (Additive-Group) a => Loop (V3 a) +instance (Additive-Group) a => Loop (Additive (V3 a)) +instance (Additive-Group) a => Group (V3 a) +instance (Additive-Group) a => Group (Additive (V3 a)) + +instance Semiring a => Semimodule a (V3 a) where + (*.) = multl + {-# INLINE (*.) #-} + +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 = I3 + tabulate f = V3 (f I31) (f I32) (f I33) + {-# INLINE tabulate #-} + + index (V3 x _ _) I31 = x + index (V3 _ y _) I32 = y + index (V3 _ _ z) I33 = z + {-# INLINE index #-} + +------------------------------------------------------------------------------- +-- Standard basis on three real dimensions +------------------------------------------------------------------------------- + +data I3 = I31 | I32 | I33 deriving (Eq, Ord, Show) + +i3 :: a -> a -> a -> I3 -> a +i3 x _ _ I31 = x +i3 _ y _ I32 = y +i3 _ _ z I33 = z + +fillI3 :: Basis I3 f => a -> a -> a -> f a +fillI3 x y z = tabulate $ i3 x y z + +instance Semigroup (Additive I3) where + Additive I31 <> x = x + x <> Additive I31 = x + + Additive I32 <> Additive I33 = Additive I31 + Additive I33 <> Additive I32 = Additive I31 + + Additive I32 <> Additive I32 = Additive I33 + Additive I33 <> Additive I33 = Additive I32 + +instance Monoid (Additive I3) where + mempty = pure I31 + +instance Ring r => Algebra r I3 where + multiplyWith f = f' where + i31 = f I32 I33 - f I33 I32 + i32 = f I33 I31 - f I31 I33 + i33 = f I31 I32 - f I32 I31 + f' I31 = i31 + f' I32 = i32 + f' I33 = i33 + +instance Ring r => Composition r I3 where + conjugateWith = id + + normWith f = flip multiplyWith' I31 $ \ix1 ix2 -> + flip multiplyWith' I32 $ \jx1 jx2 -> + flip multiplyWith' I33 $ \kx1 kx2 -> + f ix1 * f ix2 + f jx1 * f jx2 + f kx1 * f kx2 + + where + multiplyWith' f1 = f1' where + i31 = f1 I31 I31 + i32 = f1 I32 I32 + i33 = f1 I33 I33 + f1' I31 = i31 + f1' I32 = i32 + f1' I33 = i33 + + +------------------------------------------------------------------------------- +-- QuaternionBasis +------------------------------------------------------------------------------- + +type QuaternionBasis = Maybe I3 + +instance Ring r => Algebra r QuaternionBasis where + multiplyWith f = maybe fe f' where + e = Nothing + i = Just I31 + j = Just I32 + k = Just I33 + fe = f e e - (f i i + f j j + f k k) + fi = f e i + f i e + (f j k - f k j) + fj = f e j + f j e + (f k i - f i k) + fk = f e k + f k e + (f i j - f j i) + f' I31 = fi + f' I32 = fj + f' I33 = fk + +instance Ring r => Unital r QuaternionBasis where + unitWith x Nothing = x + unitWith _ _ = zero + +instance Ring r => Composition r QuaternionBasis where + conjugateWith f = maybe fe f' where + fe = f Nothing + f' I31 = negate . f $ Just I31 + f' I32 = negate . f $ Just I32 + f' I33 = negate . f $ Just I33 + + normWith f = flip multiplyWith zero $ \ix1 ix2 -> f ix1 * conjugateWith f ix2 + +instance Field r => Division r QuaternionBasis where + reciprocalWith f i = conjugateWith f i / normWith f +{- +reciprocal'' x = divq unit x + +divq (Quaternion r0 (V3 r1 r2 r3)) (Quaternion q0 (V3 q1 q2 q3)) = + (/denom) <$> Quaternion (r0*q0 + r1*q1 + r2*q2 + r3*q3) imag + where denom = q0*q0 + q1*q1 + q2*q2 + q3*q3 + imag = (V3 (r0*q1 + (negate r1*q0) + (negate r2*q3) + r3*q2) + (r0*q2 + r1*q3 + (negate r2*q0) + (negate r3*q1)) + (r0*q3 + (negate r1*q2) + r2*q1 + (negate r3*q0))) + +-} + +------------------------------------------------------------------------------- +-- V4 +------------------------------------------------------------------------------- + +data V4 a = V4 !a !a !a !a deriving (Eq,Ord,Show) + +-- | Vector addition. +-- +-- >>> V4 1 2 3 4 <> V4 5 6 7 8 +-- V4 6 8 10 12 +-- +instance (Additive-Semigroup) a => Semigroup (V4 a) where + (<>) = mzipWithRep (+) + +-- | Matrix addition. +-- +-- >>> m24 1 2 3 4 5 6 7 8 <> m24 1 2 3 4 5 6 7 8 :: M24 Int +-- V2 (V4 2 4 6 8) (V4 10 12 14 16) +-- +instance (Additive-Semigroup) a => Semigroup (Additive (V4 a)) where + (<>) = liftA2 $ mzipWithRep (+) + +instance (Additive-Monoid) a => Monoid (V4 a) where + mempty = pureRep zero + +instance (Additive-Monoid) a => Monoid (Additive (V4 a)) where + mempty = pure $ pureRep zero + +-- | Vector subtraction. +-- +-- >>> V4 1 2 3 << V4 4 5 6 +-- V4 (-3) (-3) (-3) +-- +instance (Additive-Group) a => Magma (V4 a) where + (<<) = mzipWithRep (-) + +-- | Matrix subtraction. +-- +-- >>> V4 (V4 1 2 3) (V4 4 5 6) (V4 7 8 9) << V4 (V4 7 8 9) (V4 7 8 9) (V4 7 8 9) +-- V4 (V4 (-6) (-6) (-6)) (V4 (-3) (-3) (-3)) (V4 0 0 0) +-- +instance (Additive-Group) a => Magma (Additive (V4 a)) where + (<<) = liftA2 $ mzipWithRep (-) + +instance (Additive-Group) a => Quasigroup (V4 a) +instance (Additive-Group) a => Quasigroup (Additive (V4 a)) +instance (Additive-Group) a => Loop (V4 a) +instance (Additive-Group) a => Loop (Additive (V4 a)) +instance (Additive-Group) a => Group (V4 a) +instance (Additive-Group) a => Group (Additive (V4 a)) + +instance Semiring a => Semimodule a (V4 a) where + (*.) = multl + {-# INLINE (*.) #-} + +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 = I4 + tabulate f = V4 (f I41) (f I42) (f I43) (f I44) + {-# INLINE tabulate #-} + + index (V4 x _ _ _) I41 = x + index (V4 _ y _ _) I42 = y + index (V4 _ _ z _) I43 = z + index (V4 _ _ _ w) I44 = w + {-# INLINE index #-} + +------------------------------------------------------------------------------- +-- Standard basis on four real dimensions +------------------------------------------------------------------------------- + +data I4 = I41 | I42 | I43 | I44 deriving (Eq, Ord, Show) + +i4 :: a -> a -> a -> a -> I4 -> a +i4 x _ _ _ I41 = x +i4 _ y _ _ I42 = y +i4 _ _ z _ I43 = z +i4 _ _ _ w I44 = w + +fillI4 :: Basis I4 f => a -> a -> a -> a -> f a +fillI4 x y z w = tabulate $ i4 x y z w diff --git a/src/Data/Semiring.hs b/src/Data/Semiring.hs --- a/src/Data/Semiring.hs +++ b/src/Data/Semiring.hs @@ -1,363 +1,390 @@ -{-# Language ConstrainedClassMethods #-} -{-# Language ConstraintKinds #-} -{-# Language DefaultSignatures #-} -{-# Language DeriveFunctor #-} -{-# Language DeriveGeneric #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MonoLocalBinds #-} -module Data.Semiring where +module Data.Semiring ( + type (-) + , zero, one, two, (+), (*), (-), (^) + , sum, sum1, sumWith, sumWith1 + , product, product1, productWith, productWith1 + , cross, cross1 + , eval, evalWith, eval1, evalWith1 + , negate, abs, signum + , type PresemiringLaw, Presemiring + , type SemiringLaw, Semiring + , type RingLaw, Ring + , Additive(..) + , Multiplicative(..) + , Magma(..) + , Quasigroup(..) + , Loop(..) + , Group(..) + , mreplicate +) where -import Control.Applicative -import Control.Monad -import Data.Foldable hiding (product) -import Data.Functor.Apply -import Data.Functor.Classes -import Data.Functor.Contravariant (Predicate(..), Equivalence(..), Op(..)) -import Data.Functor.Identity (Identity(..)) -import Data.Group -import Data.List (unfoldr) -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Semigroup -import Data.Semigroup.Foldable -import Data.Typeable (Typeable) -import Foreign.Storable (Storable) -import GHC.Generics (Generic, Generic1) -import GHC.Real (even, quot) -import Numeric.Natural -import Prelude hiding ((^), replicate, sum, product) -import qualified Data.Map as Map -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.IntMap as IntMap +import safe Control.Applicative +import safe Data.Bool +import safe Data.Complex +import safe Data.Either +import safe Data.Fixed +import safe Data.Foldable as Foldable (Foldable, foldr') +import safe Data.Functor.Apply +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.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(..), (^^), (^)) +import safe Numeric.Natural +import safe Prelude (Ord(..), Applicative(..), Functor(..), Monoid(..), Semigroup(..), id, (.), ($), 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 --- | Constraint kind representing a unital semiring. +------------------------------------------------------------------------------- +-- Presemiring +------------------------------------------------------------------------------- + +-- | Right pre-semirings. and (non-unital and unital) right semirings. +-- +-- A right pre-semiring (sometimes referred to as a bisemigroup) is a type /R/ endowed +-- with two associative binary (i.e. semigroup) operations: '+' and '*', along with a +-- right-distributivity property connecting them: -- --- Used for convenience and to distinguish unital semirings from semirings with only an additive unit. +-- /Distributivity/ -- -type Unital r = (Monoid r, Semiring r) +-- @ +-- (a '+' b) '*' c '==' (a '*' c) '+' (b '*' c) +-- @ +-- +-- Note that addition and multiplication needn't be commutative. +-- +-- See the properties module for a detailed specification of the laws. +-- +type PresemiringLaw a = ((Additive-Semigroup) a, (Multiplicative-Semigroup) a) -infixr 7 >< +class PresemiringLaw a => Presemiring a --- | Right pre-semirings and (non-unital and unital) right semirings. +------------------------------------------------------------------------------- +-- Semiring +------------------------------------------------------------------------------- + +type SemiringLaw a = ((Additive-Monoid) a, (Multiplicative-Monoid) a) + +-- | Right semirings. -- --- A right pre-semiring (sometimes referred to as a bisemigroup) is a type /R/ endowed --- with two associative binary (i.e. semigroup) operations: (<>) and (><), along with a --- right-distributivity property connecting them: +-- A right semiring is a pre-semiring with two distinct neutral elements, 'zero' +-- and 'one', such that 'zero' is right-neutral wrt addition, 'one' is right-neutral wrt +-- multiplication, and 'zero' is right-annihilative wrt multiplication. -- +-- /Neutrality/ +-- -- @ --- (a '<>' b) '><' c ≡ (a '><' c) '<>' (b '><' c) +-- 'zero' '+' r '==' r +-- 'one' '*' r '==' r -- @ -- --- A non-unital right semiring (sometimes referred to as a bimonoid) is a pre-semiring --- with a 'mempty' element that is neutral with respect to both addition and multiplication. +-- /Absorbtion/ -- --- A unital right semiring is a pre-semiring with two distinct neutral elements, 'mempty' --- and 'sunit', such that 'mempty' is right-neutral wrt addition, 'sunit' is right-neutral wrt --- multiplication, and 'mempty' is right-annihilative wrt multiplication. +-- @ +-- 'zero' '*' a '==' 'zero' +-- @ -- --- Note that 'sunit' needn't be distinct from 'mempty', moreover addition and multiplication --- needn't be commutative or left-distributive. +class (Presemiring a, SemiringLaw a) => Semiring a + +two :: (Additive-Semigroup) a => (Multiplicative-Monoid) a => a +two = one + one +{-# INLINE two #-} + + +infixr 8 ^ + +-- @ 'one' == a '^' 0 @ -- --- See the properties module for a detailed specification of the laws. +-- >>> 8 ^ 0 :: Int +-- 1 -- -class Semigroup r => Semiring r where +(^) :: Semiring a => a -> Natural -> a +a ^ n = unMultiplicative $ mreplicate (P.fromIntegral n) (Multiplicative a) - -- | Multiplicative operation. - (><) :: r -> r -> r +-- >>> sum [1..5 :: Int] +-- 15 +sum :: (Additive-Monoid) a => Presemiring a => Foldable f => f a -> a +sum = sumWith id - -- | Semiring homomorphism from the Boolean semiring to @r@. - -- - -- If this map is injective then @r@ has a distinct multiplicative unit. - -- - fromBoolean :: Monoid r => Bool -> r - fromBoolean _ = mempty +sum1 :: Presemiring a => Foldable1 f => f a -> a +sum1 = sumWith1 id --- | Multiplicative unit of the semiring. +sumWith :: (Additive-Monoid) a => Presemiring a => Foldable t => (b -> a) -> t b -> a +sumWith f = foldr' ((+) . f) zero +{-# INLINE sumWith #-} + +-- >>> evalWith1 Max $ (1 :| [2..5 :: Int]) :| [1 :| [2..5 :: Int]] +-- | Fold over a non-empty collection using the additive operation of an arbitrary semiring. -- -sunit :: Unital r => r -sunit = fromBoolean True +-- >>> sumWith1 First $ (1 :| [2..5 :: Int]) * (1 :| [2..5 :: Int]) +-- First {getFirst = 1} +-- >>> sumWith1 First $ Nothing :| [Just (5 :: Int), Just 6, Nothing] +-- First {getFirst = Nothing} +-- >>> sumWith1 Just $ 1 :| [2..5 :: Int] +-- Just 15 +-- +sumWith1 :: Foldable1 t => Presemiring a => (b -> a) -> t b -> a +sumWith1 f = unAdditive . foldMap1 (Additive . f) +{-# INLINE sumWith1 #-} --- | Default implementation of 'fromBoolean' given a multiplicative unit. +-- >>> product [1..5 :: Int] +-- 120 +product :: (Multiplicative-Monoid) a => Presemiring a => Foldable f => f a -> a +product = productWith id + -- -fromBooleanDef :: Unital r => r -> Bool -> r -fromBooleanDef _ False = mempty -fromBooleanDef o True = o +-- | The product of at a list of semiring elements (of length at least one) +product1 :: Presemiring a => Foldable1 f => f a -> a +product1 = productWith1 id --- | Fold over a collection using the multiplicative operation of a semiring. +-- | Fold over a collection using the multiplicative operation of an arbitrary semiring. -- -- @ --- 'product' f ≡ 'Data.foldr'' ((><) . f) 'sunit' +-- 'product' f '==' 'Data.foldr'' ((*) . f) 'one' -- @ -- --- >>> (foldMap . product) id [[1, 2], [3, (4 :: Int)]] -- 1 >< 2 <> 3 >< 4 --- 14 -- --- >>> (product . foldMap) id [[1, 2], [3, (4 :: Int)]] -- 1 <> 2 >< 3 <> 4 --- 21 --- --- For semirings without a distinct multiplicative sunit this is equivalent to @const mempty@: --- --- >>> product Just [1..(5 :: Int)] --- Just 0 --- --- In this situation you most likely want to use 'product1'. +-- >>> productWith Just [1..5 :: Int] +-- Just 120 -- -product :: Foldable t => Unital r => (a -> r) -> t a -> r -product f = foldr' ((><) . f) sunit +productWith :: (Multiplicative-Monoid) a => Presemiring a => Foldable t => (b -> a) -> t b -> a +productWith f = foldr' ((*) . f) one +{-# INLINE productWith #-} + -- | Fold over a non-empty collection using the multiplicative operation of a semiring. -- -- As the collection is non-empty this does not require a distinct multiplicative unit: -- --- >>> product1 Just $ 1 :| [2..(5 :: Int)] +-- >>> productWith1 Just $ 1 :| [2..5 :: Int] -- Just 120 +-- >>> productWith1 First $ 1 :| [2..(5 :: Int)] +-- First {getFirst = 15} +-- >>> productWith1 First $ Nothing :| [Just (5 :: Int), Just 6, Nothing] +-- First {getFirst = Just 11} -- -product1 :: Foldable1 t => Semiring r => (a -> r) -> t a -> r -product1 f = getProd . foldMap1 (Prod . f) +productWith1 :: Foldable1 t => Presemiring a => (b -> a) -> t b -> a +productWith1 f = unMultiplicative . foldMap1 (Multiplicative . f) +{-# INLINE productWith1 #-} -- | Cross-multiply two collections. -- +-- >>> cross (V3 1 2 3) (V3 1 2 3) +-- 14 -- >>> cross [1,2,3 :: Int] [1,2,3] -- 36 --- -- >>> cross [1,2,3 :: Int] [] -- 0 -- -cross :: Foldable f => Applicative f => Unital r => f r -> f r -> r -cross a b = fold $ liftA2 (><) a b +cross :: Foldable f => Applicative f => Presemiring a => (Additive-Monoid) a => f a -> f a -> a +cross a b = sum $ liftA2 (*) a b +{-# INLINE cross #-} -- | Cross-multiply two non-empty collections. -- -- >>> cross1 (Right 2 :| [Left "oops"]) (Right 2 :| [Right 3]) :: Either [Char] Int -- Right 4 -- -cross1 :: Foldable1 f => Apply f => Semiring r => f r -> f r -> r -cross1 a b = fold1 $ liftF2 (><) a b +cross1 :: Foldable1 f => Apply f => Presemiring a => f a -> f a -> a +cross1 a b = sum1 $ liftF2 (*) a b +{-# INLINE cross1 #-} --- | A generalization of 'Data.List.replicate' to an arbitrary 'Monoid'. +-- | Evaluate a semiring expression. +-- +-- @ (a11 * .. * a1m) + (a21 * .. * a2n) + ... @ -- --- Adapted from . +-- >>> eval [[1, 2], [3, 4 :: Int]] -- 1 * 2 + 3 * 4 +-- 14 +-- >>> eval $ sequence [[1, 2], [3, 4 :: Int]] -- 1 + 2 * 3 + 4 +-- 21 -- -replicate :: Monoid r => Natural -> r -> r -replicate n a - | n == 0 = mempty - | otherwise = f a n - where - f x y - | even y = f (x <> x) (y `quot` 2) - | y == 1 = x - | otherwise = g (x <> x) ((y - 1) `quot` 2) x - g x y z - | even y = g (x <> x) (y `quot` 2) z - | y == 1 = x <> z - | otherwise = g (x <> x) ((y - 1) `quot` 2) (x <> z) -{-# INLINE replicate #-} - -replicate' :: Unital r => Natural -> r -> r -replicate' n a = getProd $ replicate n (Prod a) +eval :: Semiring a => Functor f => Foldable f => Foldable g => f (g a) -> a +eval = sum . fmap product -infixr 8 ^ +-- >>> evalWith Max [[1..4 :: Int], [0..2 :: Int]] +-- Max {getMax = 24} +evalWith :: Semiring r => Functor f => Functor g => Foldable f => Foldable g => (a -> r) -> f (g a) -> r +evalWith f = sum . fmap product . (fmap . fmap) f -(^) :: Unital r => r -> Natural -> r -(^) = flip replicate' +eval1 :: Presemiring a => Functor f => Foldable1 f => Foldable1 g => f (g a) -> a +eval1 = sum1 . fmap product1 -powers :: Unital r => Natural -> r -> r -powers n a = foldr' (<>) sunit . flip unfoldr n $ \m -> - if m == 0 then Nothing else Just (a^m,m-1) +-- >>> evalWith1 (Max . Down) $ (1 :| [2..5 :: Int]) :| [-5 :| [2..5 :: Int]] +-- Max {getMax = Down 9} +-- >>> evalWith1 Max $ (1 :| [2..5 :: Int]) :| [-5 :| [2..5 :: Int]] +-- Max {getMax = 15} +-- +evalWith1 :: Presemiring r => Functor f => Functor g => Foldable1 f => Foldable1 g => (a -> r) -> f (g a) -> r +evalWith1 f = sum1 . fmap product1 . (fmap . fmap) f ------------------------------------------------------------------------------- --- 'Kleene' +-- Ring ------------------------------------------------------------------------------- --- | Infinite closures of a semiring. +type RingLaw a = ((Additive-Group) a, (Multiplicative-Monoid) a) + +-- | Rings. -- --- 'Kleene' adds a Kleene 'star' operator to a 'Semiring', with an infinite closure property: +-- A ring /R/ is a commutative group with a second monoidal operation '*' that distributes over '+'. -- --- @'star' x ≡ 'star' x '><' x '<>' 'sunit' ≡ x '><' 'star' x '<>' 'sunit'@ +-- The basic properties of a ring follow immediately from the axioms: +-- +-- @ r '*' 'zero' '==' 'zero' '==' 'zero' '*' r @ -- --- If @r@ is a dioid then 'star' must be monotonic: +-- @ 'negate' 'one' '*' r '==' 'negate' r @ -- --- @x '<~' y ==> 'star' x '<~' 'star' y +-- Furthermore, the binomial formula holds for any commuting pair of elements (that is, any /a/ and /b/ such that /a * b = b * a/). -- --- See also +-- If /zero = one/ in a ring /R/, then /R/ has only one element, and is called the zero ring. +-- Otherwise the additive identity, the additive inverse of each element, and the multiplicative identity are unique. -- -class Semiring a => Kleene a where - {-# MINIMAL star | plus #-} +-- See < https://en.wikipedia.org/wiki/Ring_(mathematics) >. +-- +-- 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 @ +-- +-- @ '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 - star :: a -> a - default star :: Monoid a => a -> a - star a = sunit <> plus a +negate :: (Additive-Group) a => a -> a +negate a = zero - a +{-# INLINE negate #-} - plus :: a -> a - plus a = a >< star a +-- | 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 #-} --- This only works if * is idempotent (a lattice?), as it just sums w/o powers ---star = fmap fold . many ---plus = fmap fold . some +-- satisfies trichotomy law: +-- Exactly one of the following is true: a is positive, -a is positive, or a = 0. +-- This property follows from the fact that ordered rings are abelian, linearly ordered groups with respect to addition. +signum :: RingLaw a => Ord a => a -> a +signum x = bool (negate one) one $ zero <= x +{-# INLINE signum #-} ---interior :: (r -> r) -> r -> r ---interior f r = (r ><) . f ---adjoint . star = plus . adjoint +{- +-- | Default implementation of 'fromBoolean' given a multiplicative unit. +-- +fromBooleanDef :: Unital a => a -> Bool -> a +fromBooleanDef _ False = mempty +fromBooleanDef o True = o +{-# INLINE fromBooleanDef #-} ---star = (>< mempty) . (<> mempty) ---plus = (<> sunit) . (>< sunit) +-- | Multiplicative unit. +-- +-- Note that 'one' needn't be distinct from 'mempty' for a semiring to be valid. +-- +one :: Unital a => a +one = fromBoolean True +{-# INLINE one #-} -instance Kleene () where - star _ = () - plus _ = () - {-# INLINE star #-} - {-# INLINE plus #-} -instance (Monoid b, Kleene b) => Kleene (a -> b) where - plus = fmap plus - {-# INLINE plus #-} - - star = fmap star - {-# INLINE star #-} +infixr 8 ^ -------------------------------------------------------------------------------- --- Pre-semirings -------------------------------------------------------------------------------- +(^) :: Unital a => a -> Natural -> a +(^) = flip sinnum' +{-# INLINE (^) #-} --- | 'First a' forms a pre-semiring for any semigroup @a@. --- --- >>> foldMap1 First $ 1 :| [2..(5 :: Int)] >< 1 :| [2..(5 :: Int)] --- First {getFirst = 1} --- --- >>> product1 First $ 1 :| [2..(5 :: Int)] --- First {getFirst = 15} --- --- >>> foldMap1 First $ Nothing :| [Just (5 :: Int), Just 6, Nothing] --- First {getFirst = Nothing} +-- | A generalization of 'Data.List.replicate' to an arbitrary 'Monoid'. -- --- >>> product1 First $ Nothing :| [Just (5 :: Int), Just 6, Nothing] --- First {getFirst = Just 11} +-- Adapted from . -- -instance Semigroup a => Semiring (First a) where - (><) = liftA2 (<>) - {-# INLINE (><) #-} - -instance Semigroup a => Semiring (Last a) where - (><) = liftA2 (<>) - {-# INLINE (><) #-} - -instance Ord a => Semiring (Max a) where - (><) = min - {-# INLINE (><) #-} - -instance Ord a => Semiring (Min a) where - (><) = max - {-# INLINE (><) #-} +sinnum :: Monoid a => Natural -> a -> a +sinnum n a + | n == 0 = mempty + | otherwise = f a n + where + f x y + | even y = f (x <> x) (y `quot` 2) + | y == 1 = x + | otherwise = g (x <> x) ((y N.- 1) `quot` 2) x + g x y z + | even y = g (x <> x) (y `quot` 2) z + | y == 1 = x <> z + | otherwise = g (x <> x) ((y N.- 1) `quot` 2) (x <> z) +{-# INLINE sinnum #-} -instance Semigroup a => Semiring (Either e a) where - (><) = liftA2 (<>) - {-# INLINE (><) #-} +sinnum' :: Unital a => Natural -> a -> a +sinnum' n a = getProd $ sinnum n (Prod a) +{-# INLINE sinnum' #-} --- >>> (1 :| [2 :: Int]) >< (3 :| [4 :: Int]) --- 4 :| [5,5,6] -instance Semigroup a => Semiring (NonEmpty a) where - (><) = liftA2 (<>) - {-# INLINE (><) #-} +powers :: Unital a => Natural -> a -> a +powers n a = foldr' (<>) one . flip unfoldr n $ \m -> + if m == 0 then Nothing else Just (a^m,m N.- 1) +{-# INLINE powers #-} ------------------------------------------------------------------------------- --- Semirings +-- Pre-semirings ------------------------------------------------------------------------------- -instance Semiring () where - (><) _ _ = () +instance Semigroup a => Semiring (Either e a) where + (*) = liftA2 (<>) + {-# INLINE (*) #-} - fromBoolean _ = () instance Semiring Ordering where - LT >< LT = LT - LT >< GT = LT - _ >< EQ = EQ - EQ >< _ = EQ - GT >< x = x + LT * LT = LT + LT * GT = LT + _ * EQ = EQ + EQ * _ = EQ + GT * x = x fromBoolean = fromBooleanDef GT --- >>> (> (0::Int)) >< ((< 10) <> (== 15)) $ 10 --- False --- >>> (> (0::Int)) >< ((< 10) <> (== 15)) $ 15 --- True -instance Unital b => Semiring (a -> b) where - (><) = liftA2 (><) - {-# INLINE (><) #-} + fromBoolean = const . fromBoolean instance Unital a => Semiring (Op a b) where - Op f >< Op g = Op $ \x -> f x >< g x - {-# INLINE (><) #-} + Op f * Op g = Op $ \x -> f x * g x + {-# INLINE (*) #-} - fromBoolean = fromBooleanDef $ Op (const sunit) + fromBoolean = fromBooleanDef $ Op (const one) instance (Unital a, Unital b) => Semiring (a, b) where - (a, b) >< (c, d) = (a><) #-} + (a, b) * (c, d) = (a*c, b*d) + {-# INLINE (*) #-} fromBoolean = liftA2 (,) fromBoolean fromBoolean instance (Unital a, Unital b, Unital c) => Semiring (a, b, c) where - (a, b, c) >< (d, e, f) = (a><) #-} + (a, b, c) * (d, e, f) = (a*d, b*e, c*f) + {-# INLINE (*) #-} fromBoolean = liftA3 (,,) fromBoolean fromBoolean fromBoolean -instance Monoid a => Semiring [a] where - (><) = liftA2 (<>) - {-# INLINE (><) #-} - fromBoolean = fromBooleanDef $ pure mempty -instance (Monoid a, Semiring a) => Semiring (Maybe a) where - (><) = liftA2 (><) - {-# INLINE (><) #-} - fromBoolean = fromBooleanDef $ pure mempty - -instance (Monoid a, Semiring a) => Semiring (Dual a) where - (><) = liftA2 $ flip (><) - {-# INLINE (><) #-} - - fromBoolean = Dual . fromBoolean - {-# INLINE fromBoolean #-} - -instance (Monoid a, Semiring a) => Semiring (Const a b) where - (Const x) >< (Const y) = Const (x >< y) - {-# INLINE (><) #-} - - fromBoolean = Const . fromBoolean - {-# INLINE fromBoolean #-} - -instance (Monoid a, Semiring a) => Semiring (Identity a) where - (><) = liftA2 (><) - {-# INLINE (><) #-} - - fromBoolean = fromBooleanDef $ pure mempty - -instance Semiring Any where - Any x >< Any y = Any $ x && y - {-# INLINE (><) #-} - - fromBoolean = fromBooleanDef $ Any True - -instance Semiring All where - All x >< All y = All $ x || y - {-# INLINE (><) #-} - - --Note that the truth values are flipped here to create a - --valid semiring homomorphism. Users should precompose with 'not' - --where necessary. - fromBoolean False = All True - fromBoolean True = All False - -instance (Monoid a, Semiring a) => Semiring (IO a) where - (><) = liftA2 (><) - {-# INLINE (><) #-} - - fromBoolean = fromBooleanDef $ pure mempty - +{- --------------------------------------------------------------------- -- Instances (contravariant) --------------------------------------------------------------------- @@ -365,8 +392,8 @@ -- Note that due to the underlying 'Monoid' instance this instance -- has 'All' semiring semantics rather than 'Any'. instance Semiring (Predicate a) where - Predicate f >< Predicate g = Predicate $ \x -> f x || g x - {-# INLINE (><) #-} + Predicate f * Predicate g = Predicate $ \x -> f x || g x + {-# INLINE (*) #-} --Note that the truth values are flipped here to create a --valid semiring homomorphism. Users should precompose with 'not' @@ -378,58 +405,153 @@ -- Note that due to the underlying 'Monoid' instance this instance -- has 'All' semiring semantics rather than 'Any'. instance Semiring (Equivalence a) where - Equivalence f >< Equivalence g = Equivalence $ \x y -> f x y || g x y - {-# INLINE (><) #-} + Equivalence f * Equivalence g = Equivalence $ \x y -> f x y || g x y + {-# INLINE (*) #-} --Note that the truth values are flipped here to create a --valid semiring homomorphism. Users should precompose with 'not' --where necessary. fromBoolean False = Equivalence $ \_ _ -> True fromBoolean True = Equivalence $ \_ _ -> False +-} --------------------------------------------------------------------- -- Instances (containers) --------------------------------------------------------------------- instance Ord a => Semiring (Set.Set a) where - (><) = Set.intersection + (*) = Set.intersection instance Monoid a => Semiring (Seq.Seq a) where - (><) = liftA2 (<>) - {-# INLINE (><) #-} + (*) = liftA2 (<>) + {-# INLINE (*) #-} fromBoolean = fromBooleanDef $ Seq.singleton mempty instance (Ord k, Monoid k, Monoid a) => Semiring (Map.Map k a) where - xs >< ys = foldMap (flip Map.map xs . (<>)) ys - {-# INLINE (><) #-} + xs * ys = foldMap (flip Map.map xs . (<>)) ys + {-# INLINE (*) #-} fromBoolean = fromBooleanDef $ Map.singleton mempty mempty instance Monoid a => Semiring (IntMap.IntMap a) where - xs >< ys = foldMap (flip IntMap.map xs . (<>)) ys - {-# INLINE (><) #-} + xs * ys = foldMap (flip IntMap.map xs . (<>)) ys + {-# INLINE (*) #-} fromBoolean = fromBooleanDef $ IntMap.singleton 0 mempty +-} + --------------------------------------------------------------------- --- Newtype wrappers +-- Instances --------------------------------------------------------------------- --- | Monoid under '><'. Analogous to 'Data.Monoid.Product', but uses the --- 'Semiring' constraint, rather than 'Num'. -newtype Prod a = Prod { getProd :: a } - deriving (Eq,Ord,Show,Bounded,Generic,Generic1,Typeable,Functor) +-- Semirings +instance Presemiring () +instance Presemiring Bool +instance Presemiring Word +instance Presemiring Word8 +instance Presemiring Word16 +instance Presemiring Word32 +instance Presemiring Word64 +instance Presemiring Natural +instance Presemiring (Ratio Natural) -instance Applicative Prod where - pure = Prod - Prod f <*> Prod a = Prod (f a) +instance Presemiring Int +instance Presemiring Int8 +instance Presemiring Int16 +instance Presemiring Int32 +instance Presemiring Int64 +instance Presemiring Integer +instance Presemiring (Ratio Integer) -instance Semiring a => Semigroup (Prod a) where - (<>) = liftA2 (><) - {-# INLINE (<>) #-} +instance Presemiring Uni +instance Presemiring Deci +instance Presemiring Centi +instance Presemiring Milli +instance Presemiring Micro +instance Presemiring Nano +instance Presemiring Pico --- Note that 'sunit' must be distinct from 'mempty' for this instance to be legal. -instance (Monoid a, Semiring a) => Monoid (Prod a) where - mempty = Prod sunit - {-# INLINE mempty #-} +instance Presemiring Float +instance Presemiring Double +instance Presemiring CFloat +instance Presemiring CDouble + + +instance Ring a => Presemiring (Complex a) +instance Presemiring a => Presemiring (r -> a) +instance (Presemiring a, Presemiring b) => Presemiring (Either a b) +instance Presemiring a => Presemiring (Maybe a) +instance (Additive-Semigroup) a => Presemiring [a] +instance (Additive-Semigroup) a => Presemiring (NonEmpty a) + + +instance Semiring () +instance Semiring Bool +instance Semiring Word +instance Semiring Word8 +instance Semiring Word16 +instance Semiring Word32 +instance Semiring Word64 +instance Semiring Natural +instance Semiring (Ratio Natural) + +instance Semiring Int +instance Semiring Int8 +instance Semiring Int16 +instance Semiring Int32 +instance Semiring Int64 +instance Semiring Integer +instance Semiring (Ratio Integer) + +instance Semiring Uni +instance Semiring Deci +instance Semiring Centi +instance Semiring Milli +instance Semiring Micro +instance Semiring Nano +instance Semiring Pico + +instance Semiring Float +instance Semiring Double +instance Semiring CFloat +instance Semiring CDouble + +instance Ring a => Semiring (Complex a) +instance Semiring a => Semiring (r -> a) +instance Semiring a => Semiring (Maybe a) +instance (Additive-Monoid) a => Semiring [a] + +instance Presemiring IntSet.IntSet +instance Ord a => Presemiring (Set.Set a) +instance Presemiring a => Presemiring (IntMap.IntMap a) +instance (Ord k, Presemiring a) => Presemiring (Map.Map k a) +instance Semiring a => Semiring (IntMap.IntMap a) +instance (Ord k, (Multiplicative-Monoid) k, Semiring a) => Semiring (Map.Map k a) + +-- Rings +instance Ring () +instance Ring Int +instance Ring Int8 +instance Ring Int16 +instance Ring Int32 +instance Ring Int64 +instance Ring Integer +instance Ring (Ratio Integer) + +instance Ring Uni +instance Ring Deci +instance Ring Centi +instance Ring Milli +instance Ring Micro +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) diff --git a/src/Data/Semiring/Matrix.hs b/src/Data/Semiring/Matrix.hs deleted file mode 100644 --- a/src/Data/Semiring/Matrix.hs +++ /dev/null @@ -1,491 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - --- | API essentially follows that of /linear/ & /hmatrix/. -module Data.Semiring.Matrix ( - type M22 - , type M23 - , type M24 - , type M32 - , type M33 - , type M34 - , type M42 - , type M43 - , type M44 - , m22 - , m23 - , m24 - , m32 - , m33 - , m34 - , m42 - , m43 - , m44 - , row - , col - , (.>) - , (<.) - , (#>) - , (<#) - , (<#>) - , scale - , identity - , transpose - , trace - , diag - , bdet2 - , det2 - , det2d - , inv2d - , bdet3 - , det3 - , det3d - , inv3d - , bdet4 - , det4 - , det4d - , inv4d - ) where - -import Data.Distributive -import Data.Foldable as Foldable (fold, foldl') -import Data.Functor.Compose -import Data.Functor.Rep -import Data.Group -import Data.Prd -import Data.Ring -import Data.Semigroup.Foldable as Foldable1 -import Data.Semiring -import Data.Semiring.Module -import Data.Semiring.V2 -import Data.Semiring.V3 -import Data.Semiring.V4 -import Data.Tuple - -import Data.Double.Instance () -- Semiring instance. -import Prelude hiding (sum, negate) - --- All matrices use row-major representation. - --- | A 2x2 matrix. -type M22 a = V2 (V2 a) - --- | A 2x3 matrix. -type M23 a = V2 (V3 a) - --- | A 2x4 matrix. -type M24 a = V2 (V4 a) - --- | A 3x2 matrix. -type M32 a = V3 (V2 a) - --- | A 3x3 matrix. -type M33 a = V3 (V3 a) - --- | A 3x4 matrix. -type M34 a = V3 (V4 a) - --- | A 4x2 matrix. -type M42 a = V4 (V2 a) - --- | A 4x3 matrix. -type M43 a = V4 (V3 a) - --- | A 4x4 matrix. -type M44 a = V4 (V4 a) - --- | Construct a 2x2 matrix. --- --- Arguments are in row-major order. --- -m22 :: a -> a -> a -> a -> M22 a -m22 a b c d = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = V4 (V4 a b c d) (V4 e f g h) (V4 i j k l) (V4 m n o p) -{-# INLINE m44 #-} - --- | Index into a row of a matrix or vector. --- --- >>> row I21 (V2 1 2) --- 1 --- -row :: Representable f => Rep f -> f c -> c -row i = flip index i -{-# INLINE row #-} - --- | Index into a column of a matrix. --- --- >>> row I22 . col I31 $ V2 (V3 1 2 3) (V3 4 5 6) --- 4 --- -col :: Functor f => Representable g => Rep g -> f (g a) -> f a -col j m = flip index j $ distribute m -{-# INLINE col #-} - -infixl 7 <. - --- | Matrix-scalar product. --- --- The />> m22 1 2 3 4 <. 5 --- V2 (V2 5 10) (V2 15 20) --- --- >>> m22 1 2 3 4 <. 5 <. 2 --- V2 (V2 10 20) (V2 30 40) --- -(<.) :: Semiring a => Functor f => Functor g => f (g a) -> a -> f (g a) -f <. a = fmap (fmap (>< a)) f -{-# INLINE (<.) #-} - -infixr 7 .> - --- | Scalar-matrix product. --- --- The />/ arrow points towards the return type. --- --- >>> 5 .> V2 (V2 1 2) (V2 3 4) --- V2 (V2 5 10) (V2 15 20) --- -(.>) :: Semiring a => Functor f => Functor g => a -> f (g a) -> f (g a) -(.>) a = fmap (fmap (a ><)) -{-# 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 15 0 --- -(<#) :: (Semiring a, Free f, Free g) => f a -> f (g a) -> g a -x <# y = tabulate (\j -> x <.> col j y) -{-# INLINE (<#) #-} - -infixr 7 #>, <#> - --- | Multiply a matrix on the right by a column vector. --- --- >>> m23 1 2 3 4 5 6 #> V3 7 8 9 --- V2 50 122 --- --- >>> m22 1 0 0 0 #> m23 1 2 3 4 5 6 #> V3 7 8 9 --- V2 50 0 --- -(#>) :: (Semiring a, Free f, Free g) => f (g a) -> g a -> f a -x #> y = tabulate (\i -> row i x <.> y) -{-# INLINE (#>) #-} - --- | Multiply two matrices. --- --- >>> m22 1 2 3 4 <#> m22 1 2 3 4 :: M22 Int --- V2 (V2 7 10) (V2 15 22) --- --- >>> m23 1 2 3 4 5 6 <#> m32 1 2 3 4 4 5 :: M22 Int --- V2 (V2 19 25) (V2 43 58) --- -(<#>) :: (Semiring a, Free f, Free g, Free h) => f (g a) -> g (h a) -> f (h a) -(<#>) x y = getCompose $ tabulate (\(i,j) -> row i x <.> col j y) -{-# INLINE (<#>) #-} - --- | Obtain a diagonal matrix from a vector. --- --- >>> scale (V2 2 3) --- V2 (V2 2 0) (V2 0 3) --- -scale :: Monoid a => Free f => f a -> f (f a) -scale f = flip imapRep f $ \i x -> flip imapRep f (\j _ -> if i == j then x else mempty) -{-# INLINE scale #-} - --- | Identity matrix. --- --- >>> identity :: M44 Int --- V4 (V4 1 0 0 0) (V4 0 1 0 0) (V4 0 0 1 0) (V4 0 0 0 1) --- --- >>> identity :: V3 (V3 Int) --- V3 (V3 1 0 0) (V3 0 1 0) (V3 0 0 1) --- -identity :: Unital a => Free f => f (f a) -identity = scale $ pureRep sunit -{-# INLINE identity #-} - --- | Transpose a matrix. --- --- > transpose (V3 (V2 1 2) (V2 3 4) (V2 5 6)) --- V2 (V3 1 3 5) (V3 2 4 6) --- -transpose :: Functor f => Distributive g => f (g a) -> g (f a) -transpose = distribute -{-# INLINE transpose #-} - --- | Compute the trace of a matrix. --- --- >>> trace (V2 (V2 a b) (V2 c d)) --- a <> d --- -trace :: Semigroup a => Free f => f (f a) -> a -trace = Foldable1.fold1 . diag -{-# INLINE trace #-} - --- | Compute the diagonal of a matrix. --- --- >>> diagonal (V2 (V2 a b) (V2 c d)) --- V2 a d --- -diag :: Representable f => f (f a) -> f a -diag = flip bindRep id -{-# INLINE diag #-} - --- | 2x2 matrix bideterminant over a commutative semiring. --- --- >>> bdet2 $ m22 1 2 3 4 --- (4,6) --- -bdet2 :: Semiring a => M22 a -> (a, a) -bdet2 (V2 (V2 a b) (V2 c d)) = (a >< d, b >< c) -{-# INLINE bdet2 #-} - --- | 2x2 matrix determinant over a commutative ring. --- --- @ --- 'det2' ≡ 'uncurry' ('<<') . 'bdet2' --- @ --- -det2 :: Ring a => M22 a -> a -det2 = uncurry (<<) . bdet2 -{-# INLINE det2 #-} - --- | 2x2 double-precision matrix determinant. --- --- >>> det2d $ m22 1 2 3 4 --- -2.0 --- -det2d :: M22 Double -> Double -det2d (V2 (V2 a b) (V2 c d)) = a * d - b * c -{-# INLINE det2d #-} - --- | 2x2 double-precision matrix inverse. --- --- >>> inv2d $ m22 1 2 3 4 --- V2 (V2 (-2.0) 1.0) (V2 1.5 (-0.5)) --- -inv2d :: M22 Double -> M22 Double -inv2d m@(V2 (V2 a b) (V2 c d)) = (1 / det2d m) .> m22 d (-b) (-c) a -{-# INLINE inv2d #-} - --- | 3x3 matrix bideterminant over a commutative semiring. --- --- >>> bdet3 (V3 (V3 1 2 3) (V3 4 5 6) (V3 7 8 9)) --- (225, 225) --- -bdet3 :: Semiring a => M33 a -> (a, a) -bdet3 (V3 (V3 a b c) (V3 d e f) (V3 g h i)) = (evens, odds) - where - evens = a> g> d> d> g> M33 a -> a -det3 = uncurry (<<) . bdet3 -{-# INLINE det3 #-} - --- | 3x3 double-precision matrix determinant. --- --- This implementation uses a cofactor expansion to avoid loss of precision. --- -det3d :: M33 Double -> Double -det3d (V3 (V3 a b c) - (V3 d e f) - (V3 g h i)) = a * (e*i-f*h) - d * (b*i-c*h) + g * (b*f-c*e) -{-# INLINE det3d #-} - --- | 3x3 double-precision matrix inverse. --- --- >>> inv3d $ m33 1 2 4 4 2 2 1 1 1 --- V3 (V3 0.0 0.5 (-1.0)) (V3 (-0.5) (-0.75) 3.5) (V3 0.5 0.25 (-1.5)) --- -inv3d :: M33 Double -> M33 Double -inv3d m@(V3 (V3 a b c) - (V3 d e f) - (V3 g h i)) = - let 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) = det2d $ m22 q r s t - det = det3d m - in (1 / det) .> m33 a' b' c' d' e' f' g' h' i' -{-# INLINE inv3d #-} - --- | 4x4 matrix bideterminant over a commutative semiring. --- --- >>> bdet4 (V4 (V4 1 2 3 4) (V4 5 6 7 8) (V4 9 10 11 12) (V4 13 14 15 16)) --- (27728,27728) --- -bdet4 :: Semiring a => M44 a -> (a, a) -bdet4 (V4 (V4 a b c d) (V4 e f g h) (V4 i j k l) (V4 m n o p)) = (evens, odds) - where - evens = a >< (f>

g> h> - b >< (g>

e> h> - c >< (e>

f> h> - d >< (f> e> g>< (g>

f> h> - b >< (e>

g> h> - c >< (f>

e> h> - d >< (e> f> g> M44 a -> a -det4 = uncurry (<<) . bdet4 -{-# INLINE det4 #-} - --- | 4x4 double-precision matrix determinant. --- --- This implementation uses a cofactor expansion to avoid loss of precision. --- -det4d :: M44 Double -> Double -det4d (V4 (V4 i00 i01 i02 i03) - (V4 i10 i11 i12 i13) - (V4 i20 i21 i22 i23) - (V4 i30 i31 i32 i33)) = - let - s0 = i00 * i11 - i10 * i01 - s1 = i00 * i12 - i10 * i02 - s2 = i00 * i13 - i10 * i03 - s3 = i01 * i12 - i11 * i02 - s4 = i01 * i13 - i11 * i03 - s5 = i02 * i13 - i12 * i03 - - c5 = i22 * i33 - i32 * i23 - c4 = i21 * i33 - i31 * i23 - c3 = i21 * i32 - i31 * i22 - c2 = i20 * i33 - i30 * i23 - c1 = i20 * i32 - i30 * i22 - c0 = i20 * i31 - i30 * i21 - in s0 * c5 - s1 * c4 + s2 * c3 + s3 * c2 - s4 * c1 + s5 * c0 -{-# INLINE det4d #-} - --- | 4x4 double-precision matrix inverse. --- -inv4d :: M44 Double -> M44 Double -inv4d (V4 (V4 i00 i01 i02 i03) - (V4 i10 i11 i12 i13) - (V4 i20 i21 i22 i23) - (V4 i30 i31 i32 i33)) = - let s0 = i00 * i11 - i10 * i01 - s1 = i00 * i12 - i10 * i02 - s2 = i00 * i13 - i10 * i03 - s3 = i01 * i12 - i11 * i02 - s4 = i01 * i13 - i11 * i03 - s5 = i02 * i13 - i12 * i03 - c5 = i22 * i33 - i32 * i23 - c4 = i21 * i33 - i31 * i23 - c3 = i21 * i32 - i31 * i22 - c2 = i20 * i33 - i30 * i23 - c1 = i20 * i32 - i30 * i22 - c0 = i20 * i31 - i30 * i21 - det = s0 * c5 - s1 * c4 + s2 * c3 + s3 * c2 - s4 * c1 + s5 * c0 - invDet = recip det - in invDet .> V4 (V4 (i11 * c5 - i12 * c4 + i13 * c3) - (-i01 * c5 + i02 * c4 - i03 * c3) - (i31 * s5 - i32 * s4 + i33 * s3) - (-i21 * s5 + i22 * s4 - i23 * s3)) - (V4 (-i10 * c5 + i12 * c2 - i13 * c1) - (i00 * c5 - i02 * c2 + i03 * c1) - (-i30 * s5 + i32 * s2 - i33 * s1) - (i20 * s5 - i22 * s2 + i23 * s1)) - (V4 (i10 * c4 - i11 * c2 + i13 * c0) - (-i00 * c4 + i01 * c2 - i03 * c0) - (i30 * s4 - i31 * s2 + i33 * s0) - (-i20 * s4 + i21 * s2 - i23 * s0)) - (V4 (-i10 * c3 + i11 * c1 - i12 * c0) - (i00 * c3 - i01 * c1 + i02 * c0) - (-i30 * s3 + i31 * s1 - i32 * s0) - (i20 * s3 - i21 * s1 + i22 * s0)) -{-# INLINE inv4d #-} diff --git a/src/Data/Semiring/Module.hs b/src/Data/Semiring/Module.hs deleted file mode 100644 --- a/src/Data/Semiring/Module.hs +++ /dev/null @@ -1,132 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - -module Data.Semiring.Module where - -import Data.Distributive -import Data.Functor.Compose -import Data.Foldable as Foldable (fold, foldl') -import Data.Semigroup.Foldable as Foldable1 -import Data.Functor.Rep -import Data.Semiring -import Data.Group -import Data.Ring -import Data.Prd -import Data.Tuple -import Data.Int.Instance () -import Prelude hiding (sum, negate) - --- | Free semimodule over a generating set. --- --- See < https://en.wikipedia.org/wiki/Free_module > and < https://en.wikipedia.org/wiki/Semimodule >. --- -type Free f = (Foldable1 f, Representable f, Eq (Rep f)) - -lensRep :: Eq (Rep f) => Representable 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 -> if i == j then b else index s' j) -{-# INLINE lensRep #-} - -grateRep :: Representable f => forall g. Functor g => (Rep f -> g a -> b) -> g (f a) -> f b -grateRep iab s = tabulate $ \i -> iab i (fmap (`index` i) s) -{-# INLINE grateRep #-} - --- | The zero vector. --- -fempty :: Monoid a => Representable f => f a -fempty = pureRep mempty -{-# INLINE fempty #-} - --- | Negation of a vector. --- --- >>> neg (V2 2 4) --- V2 (-2) (-4) --- -neg :: Group a => Functor f => f a -> f a -neg = fmap negate -{-# INLINE neg #-} - -infixl 6 `sum` - --- | Sum of two vectors. --- --- >>> V2 1 2 `sum` V2 3 4 --- V2 4 6 --- --- >>> V2 1 2 <> V2 3 4 --- V2 4 6 --- --- >>> V2 (V2 1 2) (V2 3 4) <> V2 (V2 1 2) (V2 3 4) --- V2 (V2 2 4) (V2 6 8) --- -sum :: Semigroup a => Representable f => f a -> f a -> f a -sum = liftR2 (<>) -{-# INLINE sum #-} - -infixl 6 `diff` - --- | Difference between two vectors. --- --- >>> V2 4 5 `diff` V2 3 1 --- V2 1 4 --- --- >>> V2 4 5 << V2 3 1 --- V2 1 4 --- -diff :: Group a => Representable f => f a -> f a -> f a -diff x y = x `sum` fmap negate y -{-# INLINE diff #-} - --- | Outer (tensor) product. --- -outer :: Semiring a => Functor f => Functor g => f a -> g a -> f (g a) -outer a b = fmap (\x->fmap (> - --- | Dot product. --- -(<.>) :: Semiring a => Free f => f a -> f a -> a -(<.>) a b = fold1 $ liftR2 (><) a b -{-# INLINE (<.>) #-} - --- | Squared /l2/ norm of a vector. --- -quadrance :: Semiring a => Free f => f a -> a -quadrance f = f <.> f -{-# INLINE quadrance #-} - --- | Squared /l2/ norm of the difference between two vectors. --- -qd :: Ring a => Free f => f a -> f a -> a -qd f g = quadrance $ f `diff` g -{-# INLINE qd #-} - --- | Linearly interpolate between two vectors. --- -lerp :: Ring a => Representable f => a -> f a -> f a -> f a -lerp a f g = fmap (a ><) f `sum` fmap ((sunit << a) ><) g -{-# INLINE lerp #-} - --- | Dirac delta function. --- -dirac :: Eq i => Unital a => i -> i -> a -dirac i j = if i == j then sunit else mempty -{-# INLINE dirac #-} - --- | Create a unit vector. --- --- >>> unit I21 :: V2 Int --- V2 1 0 --- --- >>> unit I42 :: V4 Int --- V4 0 1 0 0 --- -unit :: Unital a => Free f => Rep f -> f a -unit i = tabulate $ dirac i -{-# INLINE unit #-} 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,108 +1,103 @@ {-# Language AllowAmbiguousTypes #-} - +-- | See the /connections/ package for idempotent & selective semirings, and lattices. module Data.Semiring.Property ( - -- * Properties of pre-semirings & semirings - neutral_addition_on - , neutral_addition_on' + -- * Required properties of pre-semirings + nonunital_on + , morphism_presemiring + , associative_addition_on + , commutative_addition_on + , associative_multiplication_on + , distributive_on + , distributive_finite1_on + , morphism_distribitive_on + -- * Required properties of semirings + , morphism_semiring + , neutral_addition_on , neutral_multiplication_on - , neutral_multiplication_on' - , associative_addition_on - , associative_multiplication_on - , distributive_on - -- * Properties of non-unital (near-)semirings - , nonunital_on - -- * Properties of unital semirings - , annihilative_multiplication_on - , homomorphism_boolean - -- * Properties of cancellative semirings - , cancellative_addition_on - , cancellative_multiplication_on - -- * Properties of commutative semirings - , commutative_addition_on - , commutative_multiplication_on - -- * Properties of distributive semirings + , annihilative_multiplication_on , distributive_finite_on - , distributive_finite1_on + -- * Left-distributive presemirings and semirings , distributive_cross_on - , distributive_cross1_on + , distributive_cross1_on + -- * Commutative presemirings & semirings + , commutative_multiplication_on + -- * Cancellative presemirings & semirings + , cancellative_addition_on + , cancellative_multiplication_on ) where -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Foldable + import Data.Semiring -import Data.Semigroup.Foldable -import Test.Util +import Test.Logic (Rel) +import Data.Foldable (Foldable) +import Data.Functor.Apply (Apply) +import Data.Semigroup.Foldable (Foldable1) +import Data.Semigroup.Additive +import Data.Semigroup.Multiplicative +import Data.Semigroup.Property import qualified Test.Function as Prop import qualified Test.Operation as Prop +import Prelude hiding (Num(..), sum) + + ------------------------------------------------------------------------------------ --- Properties of pre-semirings & semirings +-- Required properties of pre-semirings & semirings --- | \( \forall a \in R: (z + a) \sim a \) --- --- A (pre-)semiring with a right-neutral additive sunit must satisfy: --- --- @ --- 'neutral_addition' 'mempty' ~~ const True --- @ --- --- Or, equivalently: +-- | \( \forall a, b \in R: a * b \sim a * b + b \) -- --- @ --- 'mempty' '<>' r ~~ r --- @ +-- If /R/ is non-unital (i.e. /one/ is not distinct from /zero/) then it will instead satisfy +-- a right-absorbtion property. -- --- This is a required property. +-- This follows from right-neutrality and right-distributivity. -- -neutral_addition_on :: Semigroup r => Rel r -> r -> r -> Bool -neutral_addition_on (~~) = Prop.neutral_on (~~) (<>) - -neutral_addition_on' :: Monoid r => Rel r -> r -> Bool -neutral_addition_on' (~~) = Prop.neutral_on (~~) (<>) mempty - --- | \( \forall a \in R: (o * a) \sim a \) +-- Compare 'codistributive' and 'closed_stable'. -- --- A (pre-)semiring with a right-neutral multiplicative sunit must satisfy: +-- When /R/ is also left-distributive we get: \( \forall a, b \in R: a * b = a + a * b + b \) -- --- @ --- 'neutral_multiplication' 'sunit' ~~ const True --- @ --- --- Or, equivalently: +-- See also 'Data.Warning' and < https://blogs.ncl.ac.uk/andreymokhov/united-monoids/#whatif >. -- --- @ --- 'sunit' '><' r ~~ r --- @ +nonunital_on :: Presemiring r => Rel r b -> r -> r -> b +nonunital_on (~~) a b = (a * b) ~~ (a * b + b) + +-- | Presemiring morphisms are distributive semigroup morphisms. -- --- This is a required property. +-- This is a required property for presemiring morphisms. -- -neutral_multiplication_on :: Semiring r => Rel r -> r -> r -> Bool -neutral_multiplication_on (~~) = Prop.neutral_on (~~) (><) +morphism_presemiring :: Eq s => Presemiring r => Presemiring s => (r -> s) -> r -> r -> r -> Bool +morphism_presemiring f x y z = + morphism_additive_on (==) f x y && + morphism_multiplicative_on (==) f x y && + morphism_distribitive_on (==) f x y z -neutral_multiplication_on' :: Unital r => Rel r -> r -> Bool -neutral_multiplication_on' (~~) = Prop.neutral_on (~~) (><) sunit +------------------------------------------------------------------------------------ +-- Required properties of semigroups -- | \( \forall a, b, c \in R: (a + b) + c \sim a + (b + c) \) -- --- /R/ must right-associate addition. --- --- This should be verified by the underlying 'Semigroup' instance, --- but is included here for completeness. +-- All semigroups must right-associate addition. -- -- This is a required property. -- -associative_addition_on :: Semigroup r => Rel r -> r -> r -> r -> Bool -associative_addition_on (~~) = Prop.associative_on (~~) (<>) +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) \) -- --- /R/ must right-associate multiplication. +-- All semigroups must right-associate multiplication. -- -- This is a required property. -- -associative_multiplication_on :: Semiring r => Rel r -> r -> r -> r -> Bool -associative_multiplication_on (~~) = Prop.associative_on (~~) (><) +associative_multiplication_on :: (Multiplicative-Semigroup) r => Rel r b -> r -> r -> r -> b +associative_multiplication_on (~~) = Prop.associative_on (~~) (*) +-- | \( \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, c \in R: (a + b) * c \sim (a * c) + (b * c) \) -- -- /R/ must right-distribute multiplication. @@ -118,37 +113,95 @@ -- -- This is a required property. -- -distributive_on :: Semiring r => Rel r -> r -> r -> r -> Bool -distributive_on (~~) = Prop.distributive_on (~~) (<>) (><) +distributive_on :: Presemiring r => Rel r b -> r -> r -> r -> b +distributive_on (~~) = Prop.distributive_on (~~) (+) (*) +-- | \( \forall M \geq 1; a_1 \dots a_M, b \in R: (\sum_{i=1}^M a_i) * b \sim \sum_{i=1}^M a_i * b \) +-- +-- /R/ must right-distribute multiplication over finite (non-empty) sums. +-- +-- For types with exact arithmetic this follows from 'distributive' and the universality of 'fold1'. +-- +distributive_finite1_on :: Presemiring r => Foldable1 f => Rel r b -> f r -> r -> b +distributive_finite1_on (~~) as b = (sum1 as * b) ~~ (sumWith1 (* b) as) + +-- | \( \forall a, b, c \in R: f ((a + b) * c) \sim f (a * c) + f (b * c) \) +-- +-- Presemiring morphisms must be compatible with right-distribution. +-- +morphism_distribitive_on :: Presemiring r => Presemiring s => Rel s b -> (r -> s) -> r -> r -> r -> b +morphism_distribitive_on (~~) f x y z = (f $ (x + y) * z) ~~ (f (x * z) + f (y * z)) + ------------------------------------------------------------------------------------ --- Properties of non-unital semirings (aka near-semirings) +-- Required properties of semirings --- | \( \forall a, b \in R: a * b \sim a * b + b \) +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) + +morphism_multiplicative_on :: (Multiplicative-Semigroup) r => (Multiplicative-Semigroup) s => Rel s b -> (r -> s) -> r -> r -> b +morphism_multiplicative_on (~~) f x y = (f $ x * y) ~~ (f x * f y) + +morphism_additive_on' :: (Additive-Monoid) r => (Additive-Monoid) s => Rel s b -> (r -> s) -> b +morphism_additive_on' (~~) f = (f zero) ~~ zero + +morphism_multiplicative_on' :: (Multiplicative-Monoid) r => (Multiplicative-Monoid) s => Rel s b -> (r -> s) -> b +morphism_multiplicative_on' (~~) f = (f one) ~~ one + +-- | Semiring morphisms are monoidal presemiring morphisms. -- --- If /R/ is non-unital (i.e. /sunit/ is not distinct from /mempty/) then it will instead satisfy --- a right-absorbtion property. +-- This is a required property for semiring morphisms. -- --- This follows from right-neutrality and right-distributivity. +morphism_semiring :: Eq s => Semiring r => Semiring s => (r -> s) -> r -> r -> r -> Bool +morphism_semiring f x y z = + morphism_presemiring f x y z && + morphism_additive_on' (==) f && + morphism_multiplicative_on' (==) f + + +-- | \( \forall a \in R: (z + a) \sim a \) -- --- Compare 'codistributive' and 'closed_stable'. +-- A semigroup with a right-neutral additive identity must satisfy: -- --- When /R/ is also left-distributive we get: \( \forall a, b \in R: a * b = a + a * b + b \) +-- @ +-- 'neutral_addition' 'zero' ~~ const True +-- @ +-- +-- Or, equivalently: -- --- See also 'Data.Warning' and < https://blogs.ncl.ac.uk/andreymokhov/united-monoids/#whatif >. +-- @ +-- 'zero' '+' r ~~ r +-- @ -- -nonunital_on :: Unital r => Rel r -> r -> r -> Bool -nonunital_on (~~) a b = (a >< b) ~~ (a >< b <> b) +-- 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 ------------------------------------------------------------------------------------- --- Properties of unital semirings +-- | \( \forall a \in R: (o * a) \sim a \) +-- +-- A semigroup with a right-neutral multiplicative identity must satisfy: +-- +-- @ +-- 'neutral_multiplication' 'one' ~~ const True +-- @ +-- +-- Or, equivalently: +-- +-- @ +-- 'one' '*' r ~~ r +-- @ +-- +-- This is a required propert for multiplicative monoids. +-- +neutral_multiplication_on :: (Multiplicative-Monoid) r => Rel r b -> r -> b +neutral_multiplication_on (~~) = Prop.neutral_on (~~) (*) one -- | \( \forall a \in R: (z * a) \sim u \) -- --- A /R/ is unital then its addititive sunit must be right-annihilative, i.e.: +-- A /R/ is semiring then its addititive one must be right-annihilative, i.e.: -- -- @ --- 'mempty' '><' a ~~ 'mempty' +-- 'zero' '*' a ~~ 'zero' -- @ -- -- For 'Alternative' instances this property translates to: @@ -157,93 +210,97 @@ -- 'empty' '*>' a ~~ 'empty' -- @ -- --- All right semirings must have a right-absorbative addititive sunit, +-- 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: -- -- @ --- 'mempty' '><' NaN ~~ NaN +-- 'zero' '*' NaN ~~ NaN -- @ -- -- This is a required property. -- -annihilative_multiplication_on :: Unital r => Rel r -> r -> Bool -annihilative_multiplication_on (~~) r = Prop.annihilative_on (~~) (><) mempty r +annihilative_multiplication_on :: Semiring r => Rel r b -> r -> b +annihilative_multiplication_on (~~) r = Prop.annihilative_on (~~) (*) zero r --- | 'fromBoolean' must be a semiring homomorphism into /R/. +-- | \( \forall M \geq 0; a_1 \dots a_M, b \in R: (\sum_{i=1}^M a_i) * b \sim \sum_{i=1}^M a_i * b \) -- --- This is a required property. +-- /R/ must right-distribute multiplication between finite sums. -- -homomorphism_boolean :: forall r. (Eq r, Unital r) => Bool -> Bool -> Bool -homomorphism_boolean i j = - fromBoolean True == (sunit @r) && - fromBoolean False == (mempty @r) && - fromBoolean (i && j) == fi >< fj && - fromBoolean (i || j) == fi <> fj - - where fi :: r = fromBoolean i - fj :: r = fromBoolean j +-- For types with exact arithmetic this follows from 'distributive' & 'neutral_multiplication'. +-- +distributive_finite_on :: Semiring r => Foldable f => Rel r b -> f r -> r -> b +distributive_finite_on (~~) as b = (sum as * b) ~~ (sumWith (* b) as) ------------------------------------------------------------------------------------ --- Properties of cancellative & commutative semirings +-- Left-distributive presemirings and semirings --- | \( \forall a, b, c \in R: b + a \sim c + a \Rightarrow b = c \) +-- | \( \forall M,N \geq 0; a_1 \dots a_M, b_1 \dots b_N \in R: (\sum_{i=1}^M a_i) * (\sum_{j=1}^N b_j) \sim \sum_{i=1 j=1}^{i=M j=N} a_i * b_j \) -- --- If /R/ is right-cancellative wrt addition then for all /a/ --- the section /(a <>)/ is injective. +-- If /R/ is also left-distributive then it supports cross-multiplication. -- -cancellative_addition_on :: Semigroup r => Rel r -> r -> r -> r -> Bool -cancellative_addition_on (~~) a = Prop.injective_on (~~) (<> a) +distributive_cross_on :: Semiring r => Applicative f => Foldable f => Rel r b -> f r -> f r -> b +distributive_cross_on (~~) as bs = (sum as * sum bs) ~~ (cross as bs) --- | \( \forall a, b, c \in R: b * a \sim c * a \Rightarrow b = c \) +-- | \( \forall M,N \geq 1; a_1 \dots a_M, b_1 \dots b_N \in R: (\sum_{i=1}^M a_i) * (\sum_{j=1}^N b_j) = \sum_{i=1 j=1}^{i=M j=N} a_i * b_j \) -- --- If /R/ is right-cancellative wrt multiplication then for all /a/ --- the section /(a ><)/ is injective. +-- If /R/ is also left-distributive then it supports (non-empty) cross-multiplication. -- -cancellative_multiplication_on :: Semiring r => Rel r -> r -> r -> r -> Bool -cancellative_multiplication_on (~~) a = Prop.injective_on (~~) (>< a) +distributive_cross1_on :: Presemiring r => Apply f => Foldable1 f => Rel r b -> f r -> f r -> b +distributive_cross1_on (~~) as bs = (sum1 as * sum1 bs) ~~ (cross1 as bs) --- | \( \forall a, b \in R: a + b \sim b + a \) --- -commutative_addition_on :: Semigroup r => Rel r -> r -> r -> Bool -commutative_addition_on (~~) = Prop.commutative_on (~~) (<>) +------------------------------------------------------------------------------------ +-- Commutative presemirings and semirings -- | \( \forall a, b \in R: a * b \sim b * a \) -- -commutative_multiplication_on :: Semiring r => Rel r -> r -> r -> Bool -commutative_multiplication_on (~~) = Prop.commutative_on (~~) (><) +-- This is a an /optional/ property for semigroups, and a /optional/ property for semirings. +-- It is a /required/ property for rings. +-- +commutative_multiplication_on :: (Multiplicative-Semigroup) r => Rel r b -> r -> r -> b +commutative_multiplication_on (~~) = Prop.commutative_on (~~) (*) ------------------------------------------------------------------------------------ --- Properties of distributive & co-distributive semirings +-- Properties of cancellative semigroups --- | \( \forall M \geq 0; a_1 \dots a_M, b \in R: (\sum_{i=1}^M a_i) * b \sim \sum_{i=1}^M a_i * b \) +-- | \( \forall a, b, c \in R: b + a \sim c + a \Rightarrow b = c \) -- --- /R/ must right-distribute multiplication between finite sums. +-- If /R/ is right-cancellative wrt addition then for all /a/ +-- the section /(a +)/ is injective. -- --- For types with exact arithmetic this follows from 'distributive' & 'neutral_multiplication'. +-- See < https://en.wikipedia.org/wiki/Cancellation_property > -- -distributive_finite_on :: Unital r => Rel r -> [r] -> r -> Bool -distributive_finite_on (~~) as b = (fold as >< b) ~~ (foldMap (>< b) as) +cancellative_addition_on :: (Additive-Semigroup) r => Rel r Bool -> r -> r -> r -> Bool +cancellative_addition_on (~~) a = Prop.injective_on (~~) (+ a) --- | \( \forall M \geq 1; a_1 \dots a_M, b \in R: (\sum_{i=1}^M a_i) * b \sim \sum_{i=1}^M a_i * b \) --- --- /R/ must right-distribute multiplication over finite (non-empty) sums. +-- | \( \forall a, b, c \in R: b * a \sim c * a \Rightarrow b = c \) -- --- For types with exact arithmetic this follows from 'distributive' and the universality of 'fold1'. +-- If /R/ is right-cancellative wrt multiplication then for all /a/ +-- the section /(a *)/ is injective. -- -distributive_finite1_on :: Semiring r => Rel r -> NonEmpty r -> r -> Bool -distributive_finite1_on (~~) as b = (fold1 as >< b) ~~ (foldMap1 (>< b) as) +cancellative_multiplication_on :: (Multiplicative-Semigroup) r => Rel r Bool -> r -> r -> r -> Bool +cancellative_multiplication_on (~~) a = Prop.injective_on (~~) (* a) --- | \( \forall M,N \geq 0; a_1 \dots a_M, b_1 \dots b_N \in R: (\sum_{i=1}^M a_i) * (\sum_{j=1}^N b_j) \sim \sum_{i=1 j=1}^{i=M j=N} a_i * b_j \) +-- | Idempotency property for additive semigroups. -- --- If /R/ is also left-distributive then it supports cross-multiplication. +-- @ 'idempotent_addition' = 'absorbative_addition' 'one' @ +-- +-- See < https://en.wikipedia.org/wiki/Band_(mathematics) >. -- -distributive_cross_on :: Unital r => Rel r -> [r] -> [r] -> Bool -distributive_cross_on (~~) as bs = (fold as >< fold bs) ~~ (cross as bs) +-- 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 --- | \( \forall M,N \geq 1; a_1 \dots a_M, b_1 \dots b_N \in R: (\sum_{i=1}^M a_i) * (\sum_{j=1}^N b_j) = \sum_{i=1 j=1}^{i=M j=N} a_i * b_j \) +-- | Idempotency property for semigroups. -- --- If /R/ is also left-distributive then it supports (non-empty) cross-multiplication. +-- @ 'idempotent_multiplication' = 'absorbative_multiplication' 'zero' @ +-- +-- See < https://en.wikipedia.org/wiki/Band_(mathematics) >. -- -distributive_cross1_on :: Semiring r => Rel r -> NonEmpty r -> NonEmpty r -> Bool -distributive_cross1_on (~~) as bs = (fold1 as >< fold1 bs) ~~ (cross1 as bs) +-- This is a an /optional/ property for semigroups, and a /optional/ property for 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 diff --git a/src/Data/Semiring/V2.hs b/src/Data/Semiring/V2.hs deleted file mode 100644 --- a/src/Data/Semiring/V2.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - -module Data.Semiring.V2 where - -import Data.Dioid -import Data.Distributive -import Data.Foldable as Foldable (fold, foldl') -import Data.Functor.Rep -import Data.Group -import Data.Prd -import Data.Ring -import Data.Semigroup.Foldable as Foldable1 -import Data.Semiring - -import Prelude hiding (sum, negate) - -data V2 a = V2 !a !a deriving (Eq,Ord,Show) - -instance Prd a => Prd (V2 a) where - V2 a b <~ V2 d e = a <~ d && b <~ e - --- | Entry-wise vector or matrix addition. --- --- >>> V2 (V3 1 2 3) (V3 4 5 6) <> V2 (V3 7 8 9) (V3 1 2 3) --- V2 (V3 8 10 12) (V3 5 7 9) --- -instance Semigroup a => Semigroup (V2 a) where - (<>) = mzipWithRep (<>) - -instance Monoid a => Monoid (V2 a) where - mempty = pureRep mempty - --- | Entry-wise vector or matrix multiplication. --- --- >>> V2 (V3 1 2 3) (V3 4 5 6) >< V2 (V3 7 8 9) (V3 1 2 3) --- V2 (V3 7 16 27) (V3 4 10 18) --- -instance Unital a => Semiring (V2 a) where - (><) = mzipWithRep (><) - fromBoolean = pureRep . fromBoolean - -instance (Monoid a, Dioid a) => Dioid (V2 a) where - fromNatural = pureRep . fromNatural - --- | Entry-wise vector or matrix subtraction. --- --- >>> V2 (V3 1 2 3) (V3 4 5 6) << V2 (V3 7 8 9) (V3 1 2 3) --- V2 (V3 (-6) (-6) (-6)) (V3 3 3 3) --- -instance Group a => Group (V2 a) where - (<<) = mzipWithRep (<<) - -instance Functor V2 where - fmap f (V2 a b) = V2 (f a) (f b) - {-# INLINE fmap #-} - a <$ _ = V2 a a - {-# INLINE (<$) #-} - -instance Foldable V2 where - foldMap f (V2 a b) = f a <> f b - {-# INLINE foldMap #-} - null _ = False - length _ = 2 - -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 #-} - -data I2 = I21 | I22 deriving (Eq, Ord, Show) - -instance Representable V2 where - type Rep V2 = I2 - tabulate f = V2 (f I21) (f I22) - {-# INLINE tabulate #-} - - index (V2 x _) I21 = x - index (V2 _ y) I22 = y - {-# INLINE index #-} - -instance Prd I2 where - (<~) = (<=) - (>~) = (>=) - pcompare = pcompareOrd - -instance Minimal I2 where - minimal = I21 - -instance Maximal I2 where - maximal = I22 diff --git a/src/Data/Semiring/V3.hs b/src/Data/Semiring/V3.hs deleted file mode 100644 --- a/src/Data/Semiring/V3.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - -module Data.Semiring.V3 where - -import Data.Dioid -import Data.Distributive -import Data.Foldable as Foldable (fold, foldl') -import Data.Functor.Rep -import Data.Group -import Data.Prd -import Data.Ring -import Data.Semigroup.Foldable as Foldable1 -import Data.Semiring -import Data.Semiring.Module - -import Prelude hiding (sum, negate) - -data V3 a = V3 !a !a !a deriving (Eq,Ord,Show) - -infixl 7 <@> - --- | Cross product. --- --- >>> V3 1 1 1 <@> V3 (-2) 1 1 --- V3 0 (-3) 3 --- --- The cross product satisfies the following properties: --- --- @ --- a '<@>' a = 0 --- a '<@>' b = − ( b '<@>' a ) , --- a '<@>' ( b + c ) = ( a '<@>' b ) + ( a '<@>' c ) , --- ( r a ) '<@>' b = a '<@>' ( r b ) = r ( a '<@>' b ) . --- a '<@>' ( b '<@>' c ) + b '<@>' ( c '<@>' a ) + c '<@>' ( a '<@>' b ) = 0 . --- @ --- -(<@>) :: Ring a => V3 a -> V3 a -> V3 a -(<@>) (V3 a b c) (V3 d e f) = V3 (b>) #-} - --- | Scalar triple product. --- -triple :: Ring a => V3 a -> V3 a -> V3 a -> a -triple a b c = a <.> b <@> c -{-# INLINE triple #-} - -instance Prd a => Prd (V3 a) where - V3 a b c <~ V3 d e f = a <~ d && b <~ e && c <~ f - -instance Semigroup a => Semigroup (V3 a) where - (<>) = mzipWithRep (<>) - -instance Monoid a => Monoid (V3 a) where - mempty = pureRep mempty - -instance Unital a => Semiring (V3 a) where - (><) = mzipWithRep (><) - fromBoolean = pureRep . fromBoolean - -instance (Monoid a, Dioid a) => Dioid (V3 a) where - fromNatural = pureRep . fromNatural - -instance Group a => Group (V3 a) where - (<<) = mzipWithRep (<<) - -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 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 = I3 - tabulate f = V3 (f I31) (f I32) (f I33) - {-# INLINE tabulate #-} - - index (V3 x _ _) I31 = x - index (V3 _ y _) I32 = y - index (V3 _ _ z) I33 = z - {-# INLINE index #-} - -data I3 = I31 | I32 | I33 deriving (Eq, Ord, Show) - -instance Prd I3 where - (<~) = (<=) - (>~) = (>=) - pcompare = pcompareOrd - -instance Minimal I3 where - minimal = I31 - -instance Maximal I3 where - maximal = I33 diff --git a/src/Data/Semiring/V4.hs b/src/Data/Semiring/V4.hs deleted file mode 100644 --- a/src/Data/Semiring/V4.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - -module Data.Semiring.V4 where - -import Data.Dioid -import Data.Distributive -import Data.Foldable as Foldable (fold, foldl') -import Data.Functor.Rep -import Data.Group -import Data.Prd -import Data.Ring -import Data.Semigroup.Foldable as Foldable1 -import Data.Semiring - -import Prelude hiding (sum, negate) - -data V4 a = V4 !a !a !a !a deriving (Eq,Ord,Show) - -instance Prd a => Prd (V4 a) where - V4 a b c d <~ V4 e f g h = a <~ e && b <~ f && c <~ g && d <~ h - -instance Semigroup a => Semigroup (V4 a) where - (<>) = mzipWithRep (<>) - -instance Monoid a => Monoid (V4 a) where - mempty = pureRep mempty - -instance Unital a => Semiring (V4 a) where - (><) = mzipWithRep (><) - fromBoolean = pureRep . fromBoolean - -instance (Monoid a, Dioid a) => Dioid (V4 a) where - fromNatural = pureRep . fromNatural - -instance Group a => Group (V4 a) where - (<<) = mzipWithRep (<<) - -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 Foldable V4 where - foldMap f (V4 a b c d) = f a <> f b <> f c <> f d - {-# INLINE foldMap #-} - null _ = False - length _ = 4 - -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 = I4 - tabulate f = V4 (f I41) (f I42) (f I43) (f I44) - {-# INLINE tabulate #-} - - index (V4 x _ _ _) I41 = x - index (V4 _ y _ _) I42 = y - index (V4 _ _ z _) I43 = z - index (V4 _ _ _ w) I44 = w - {-# INLINE index #-} - -data I4 = I41 | I42 | I43 | I44 deriving (Eq, Ord, Show) - -instance Prd I4 where - (<~) = (<=) - (>~) = (>=) - pcompare = pcompareOrd - -instance Minimal I4 where - minimal = I41 - -instance Maximal I4 where - maximal = I44 diff --git a/src/Data/Word/Instance.hs b/src/Data/Word/Instance.hs deleted file mode 100644 --- a/src/Data/Word/Instance.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE CPP #-} -module Data.Word.Instance where - -import Data.Connection -import Data.Connection.Word -import Data.Dioid -import Data.Prd -import Data.Semiring -import Data.Word -import Numeric.Natural -import Prelude (id, Monoid(..), Semigroup(..)) -import qualified Prelude as N (Num(..)) - -#define deriveSemigroup(ty) \ -instance Semigroup (ty) where { \ - (<>) = (N.+) \ -; {-# INLINE (<>) #-} \ -} - -#define deriveMonoid(ty) \ -instance Monoid (ty) where { \ - mempty = 0 \ -} - -#define deriveSemiring(ty) \ -instance Semiring (ty) where { \ - (><) = (N.*) \ -; fromBoolean = fromBooleanDef 1 \ -; {-# INLINE (><) #-} \ -; {-# INLINE fromBoolean #-} \ -} - - -deriveSemigroup(Word) -deriveSemigroup(Word8) -deriveSemigroup(Word16) -deriveSemigroup(Word32) -deriveSemigroup(Word64) -deriveSemigroup(Natural) - -deriveMonoid(Word) -deriveMonoid(Word8) -deriveMonoid(Word16) -deriveMonoid(Word32) -deriveMonoid(Word64) -deriveMonoid(Natural) - -deriveSemiring(Word) -deriveSemiring(Word8) -deriveSemiring(Word16) -deriveSemiring(Word32) -deriveSemiring(Word64) -deriveSemiring(Natural) - -instance Dioid Word8 where - fromNatural = connr w08nat - -instance Dioid Word16 where - fromNatural = connr w16nat - -instance Dioid Word32 where - fromNatural = connr w32nat - -instance Dioid Word64 where - fromNatural = connr w64nat - -instance Dioid Natural where - fromNatural = id