packages feed

rings 0.0.2.4 → 0.0.3

raw patch · 29 files changed

+3817/−2131 lines, 29 filesdep +magmasdep +profunctorsdep ~connectionsdep ~lawz

Dependencies added: magmas, profunctors

Dependency ranges changed: connections, lawz

Files

rings.cabal view
@@ -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
+ src/Data/Algebra.hs view
@@ -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
+ src/Data/Algebra/Quaternion.hs view
@@ -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 #-}
− src/Data/Bool/Instance.hs 
@@ -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
− src/Data/Complex/Instance.hs 
@@ -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 #-}
− src/Data/Dioid.hs 
@@ -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)
− src/Data/Dioid/Property.hs 
@@ -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
− src/Data/Double/Instance.hs 
@@ -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)
− src/Data/Fixed/Instance.hs 
@@ -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)
− src/Data/Float/Instance.hs 
@@ -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)
− src/Data/Group.hs 
@@ -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
− src/Data/Int/Instance.hs 
@@ -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)
− src/Data/Ring.hs 
@@ -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 /></ that distributes over /<>/.------ 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
+ src/Data/Semifield.hs view
@@ -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+-}+
+ src/Data/Semigroup/Additive.hs view
@@ -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
+ src/Data/Semigroup/Multiplicative.hs view
@@ -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
+ src/Data/Semigroup/Property.hs view
@@ -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++
+ src/Data/Semimodule.hs view
@@ -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)
+ src/Data/Semimodule/Matrix.hs view
@@ -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 #-}
+ src/Data/Semimodule/Transform.hs view
@@ -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 #-}
+ src/Data/Semimodule/Vector.hs view
@@ -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
src/Data/Semiring.hs view
@@ -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 <http://augustss.blogspot.com/2008/07/lost-and-found-if-i-write-108-in.html>.+-- >>> 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 <https://en.wikipedia.org/wiki/Semiring#Kleene_semirings closed semiring>+-- 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 <http://augustss.blogspot.com/2008/07/lost-and-found-if-i-write-108-in.html>. ---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><c, b><d)-  {-# INLINE (><) #-}+  (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><d, b><e, c><f)-  {-# INLINE (><) #-}+  (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)
− src/Data/Semiring/Matrix.hs 
@@ -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 /</ arrow points towards the return type.------ >>> 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><e><i <> g><b><f <> d><h><c-    odds  = a><h><f <> d><b><i <> g><e><c-{-# INLINE bdet3 #-}---- | 3x3 matrix determinant over a commutative ring.------ @--- 'det3' ≡ 'uncurry' ('<<') . 'bdet3'--- @----det3 :: Ring a => 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><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)-{-# INLINE bdet4 #-}---- | 4x4 matrix determinant over a commutative ring.------ @--- 'det4' ≡ 'uncurry' ('<<') . 'bdet4'--- @----det4 :: Ring a => 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 #-}
− src/Data/Semiring/Module.hs 
@@ -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 (><x) b) a-{-# INLINE outer #-}--infixl 6 <.>---- | 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 #-}
src/Data/Semiring/Property.hs view
@@ -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
− src/Data/Semiring/V2.hs 
@@ -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
− src/Data/Semiring/V3.hs 
@@ -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><f << c><e) (c><d << a><f) (a><e << b><d)-{-# INLINABLE (<@>) #-}---- | 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
− src/Data/Semiring/V4.hs 
@@ -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
− src/Data/Word/Instance.hs 
@@ -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