packages feed

rings 0.0.2.1 → 0.0.2.2

raw patch · 16 files changed

+1084/−73 lines, 16 filesdep +adjunctionsdep +distributivedep +lawzdep ~connectionsdep ~propertydep ~semigroupoids

Dependencies added: adjunctions, distributive, lawz

Dependency ranges changed: connections, property, semigroupoids

Files

rings.cabal view
@@ -1,7 +1,7 @@ name:                rings-version:             0.0.2.1-synopsis:            Rings, semirings, and dioids.-description:         Lawful versions of several of the numeric typeclasses in base.+version:             0.0.2.2+synopsis:            Groups, rings, semirings, and dioids.+description:         Lawful algebraic classes and a la carte instances. homepage:            https://github.com/cmk/rings license:             BSD3 license-file:        LICENSE@@ -16,12 +16,17 @@  library   exposed-modules:-      Data.Dioid+      Data.Ring+    , Data.Dioid     , Data.Dioid.Property     , Data.Group     , Data.Semiring+    , Data.Semiring.V2+    , Data.Semiring.V3+    , Data.Semiring.V4+    , Data.Semiring.Matrix+    , Data.Semiring.Module     , Data.Semiring.Property-    , Data.Ring     , Data.Bool.Instance     , Data.Complex.Instance     , Data.Double.Instance@@ -39,10 +44,12 @@    build-depends:              base           >= 4.10    && < 5.0+    , lawz           >= 0.0.1   && < 1.0+    , adjunctions    >= 4.4     && < 5.0     , containers     >= 0.4.0   && < 0.7-    , semigroupoids  == 5.*-    , property       >= 0.0.1   && < 1.0-    , connections    >= 0.0.2.1 && < 0.0.3+    , 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
src/Data/Bool/Instance.hs view
@@ -1,4 +1,3 @@--- | Instance instances from base. module Data.Bool.Instance where  import Data.Prd@@ -26,3 +25,5 @@   {-# INLINE plus #-}  instance Dioid Bool where+  fromNatural 0 = False+  fromNatural _ = True
src/Data/Complex/Instance.hs view
@@ -1,12 +1,31 @@--- | Instance instances from base. module Data.Complex.Instance where  import Data.Complex-import Prelude+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 view
@@ -5,6 +5,7 @@ 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)@@ -18,8 +19,6 @@ – Idempotent-cancellative dioids and selective-cancellative dioids – Idempotent-invertible dioids and selective-invertible dioids -Dioids (idempotent dioids in particular) play an important role in many applications in computer science, ranging from regular languages and Kleene algebras to shortest path algorithms using tropical semirings such as the max-plus semiring. They are also generalizations of distributive lattices, quantales, residuated lattices and relation algebras, each of which have been studied extensively in mathematics and logic.- -}  -- | Right pre-dioids and dioids.@@ -46,4 +45,19 @@ -- -- See 'Data.Dioid.Property' ---class (Prd a, Semiring a) => Dioid a where+class (Prd r, Semiring r) => Dioid r where++  -- | A dioid homomorphism from the naturals to /r/.+  fromNatural :: Natural -> r+{-+  psignum :: Monoid r => r -> Maybe r+  psignum x = case pcomparePrd mempty x+     Just GT -> Just sunit+     Just EQ -> Just mempty+     _ -> Nothing+-}+++instance (Monoid a, Monoid b, Dioid a, Dioid b) => Dioid (a, b)++instance (Monoid a, Monoid b, Monoid c, Dioid a, Dioid b, Dioid c) => Dioid (a, b, c)
src/Data/Dioid/Property.hs view
@@ -34,8 +34,9 @@ import Data.List.NonEmpty (NonEmpty(..)) import Data.Semiring hiding (nonunital) import Numeric.Natural-import Test.Property.Util ((<==>),(==>))-import qualified Test.Property as Prop hiding (distributive_on)+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  ------------------------------------------------------------------------------------
src/Data/Group.hs view
@@ -5,20 +5,17 @@  infixl 6 << --- |A 'Group' is a 'Monoid' plus a function, 'negate', such that: +-- | A 'Group' is a 'Monoid' plus a function, 'negate', such that:  ----- @a << negate a == mempty@+-- @g << negate g ≡ mempty@ ----- @negate a << a == mempty@+-- @negate g << g ≡ mempty@ ---class Monoid a => Group a where+class Monoid g => Group g where   {-# MINIMAL (negate | (<<)) #-} -  negate :: a -> a+  negate :: g -> g   negate x = mempty << x -  (<<) :: a -> a -> a+  (<<) :: g -> g -> g   x << y = x <> negate y--instance (Monoid (Complex a), Group a) => Group (Complex a) where-  negate (x :+ y) = negate x :+ negate y
src/Data/Int/Instance.hs view
@@ -37,7 +37,8 @@  #define deriveRing(ty)             \ instance Ring (ty) where {         \-   abs = N.abs                     \+   fromInteger = N.fromInteger     \+;  abs = N.abs                     \ ;  signum = N.signum               \ ;  {-# INLINE abs #-}              \ ;  {-# INLINE signum #-}           \
src/Data/Ring.hs view
@@ -2,6 +2,7 @@     (<<)   , (><)   , (<>)+  , abs   , negate   , Ring(..) ) where@@ -10,8 +11,45 @@ import Data.Semiring import Prelude hiding (Num(..)) -class (Group a, Semiring a) => Ring a where-  {-# MINIMAL abs, signum #-}-  abs :: a -> a+-- | 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 -  signum :: a -> a -- satisfies trichotomy law+  -- | 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/Semiring.hs view
@@ -1,4 +1,5 @@ {-# Language ConstrainedClassMethods #-}+{-# Language ConstraintKinds   #-} {-# Language DefaultSignatures #-} {-# Language DeriveFunctor #-} {-# Language DeriveGeneric #-}@@ -7,7 +8,6 @@  import Control.Applicative import Control.Monad-import Data.Complex import Data.Foldable hiding (product) import Data.Functor.Apply import Data.Functor.Classes@@ -29,6 +29,12 @@ import qualified Data.Set as Set import qualified Data.IntMap as IntMap +-- | Constraint kind representing a unital semiring.+--+-- Used for convenience and to distinguish unital semirings from semirings with only an additive unit.+--+type Unital r = (Monoid r, Semiring r)+ infixr 7 ><  -- | Right pre-semirings and (non-unital and unital) right semirings.@@ -38,7 +44,7 @@ -- right-distributivity property connecting them: -- -- @--- (a <> b) >< c ≡ (a >< c) <> (b >< c)+-- (a '<>' b) '><' c ≡ (a '><' c) '<>' (b '><' c) -- @ -- -- A non-unital right semiring (sometimes referred to as a bimonoid) is a pre-semiring @@ -55,18 +61,24 @@ -- class Semigroup r => Semiring r where -  -- Multiplicative operation+  -- | Multiplicative operation.   (><) :: r -> r -> r   -  -- A semiring homomorphism from the Boolean semiring to @r@. -  -- If this map is injective then @r@ has a distinct sunit.+  -- | 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 -sunit :: (Monoid r, Semiring r) => r+-- | Multiplicative unit of the semiring.+--+sunit :: Unital r => r sunit = fromBoolean True -fromBooleanDef :: (Monoid r, Semiring r) => r -> Bool -> r+-- | Default implementation of 'fromBoolean' given a multiplicative unit.+--+fromBooleanDef :: Unital r => r -> Bool -> r fromBooleanDef _ False = mempty fromBooleanDef o True = o @@ -89,7 +101,7 @@ -- -- In this situation you most likely want to use 'product1'. ---product :: Foldable t => Monoid r => Semiring r => (a -> r) -> t a -> r+product :: Foldable t => Unital r => (a -> r) -> t a -> r product f = foldr' ((><) . f) sunit  -- | Fold over a non-empty collection using the multiplicative operation of a semiring.@@ -110,7 +122,7 @@ -- >>> cross [1,2,3 :: Int] [] -- 0 ---cross :: Foldable f => Applicative f => Monoid r => Semiring r => f r -> f r -> r+cross :: Foldable f => Applicative f => Unital r => f r -> f r -> r cross a b = fold $ liftA2 (><) a b  -- | Cross-multiply two non-empty collections.@@ -126,9 +138,9 @@ -- Adapted from <http://augustss.blogspot.com/2008/07/lost-and-found-if-i-write-108-in.html>. -- replicate :: Monoid r => Natural -> r -> r-replicate y0 x0-    | y0 == 0 = mempty-    | otherwise = f x0 y0+replicate n a+    | n == 0 = mempty+    | otherwise = f a n     where         f x y              | even y = f (x <> x) (y `quot` 2)@@ -140,15 +152,15 @@             | otherwise = g (x <> x) ((y - 1) `quot` 2) (x <> z) {-# INLINE replicate #-} -replicate' :: Monoid r => Semiring r => Natural -> r -> r-replicate' n r = getProd $ replicate n (Prod r)+replicate' :: Unital r => Natural -> r -> r+replicate' n a = getProd $ replicate n (Prod a)  infixr 8 ^ -(^) :: Monoid r => Semiring r => r -> Natural -> r+(^) :: Unital r => r -> Natural -> r (^) = flip replicate' -powers :: Monoid r => Semiring r => Natural -> r -> r+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) @@ -268,31 +280,29 @@ -- False -- >>> (> (0::Int)) >< ((< 10) <> (== 15)) $ 15 -- True-instance (Monoid b, Semiring b) => Semiring (a -> b) where+instance Unital b => Semiring (a -> b) where   (><) = liftA2 (><)   {-# INLINE (><) #-}    fromBoolean = const . fromBoolean -instance (Monoid a, Semiring a) => Semiring (Op a b) where+instance Unital a => Semiring (Op a b) where   Op f >< Op g = Op $ \x -> f x >< g x   {-# INLINE (><) #-}    fromBoolean = fromBooleanDef $ Op (const sunit) -instance (Monoid a, Monoid b, Semiring a, Semiring b) => Semiring (a, b) where+instance (Unital a, Unital b) => Semiring (a, b) where   (a, b) >< (c, d) = (a><c, b><d)   {-# INLINE (><) #-}    fromBoolean = liftA2 (,) fromBoolean fromBoolean -instance (Semigroup (Complex a), Group a, Semiring a) => Semiring (Complex a) where-  (x :+ y) >< (x' :+ y') = (x >< x' << y >< y') :+ (x >< y' <> y >< x')+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 (><) #-} -  fromBoolean False = mempty-  fromBoolean True = fromBoolean True :+ mempty-  {-# INLINE fromBoolean #-}+  fromBoolean = liftA3 (,,) fromBoolean fromBoolean fromBoolean  instance Monoid a => Semiring [a] where    (><) = liftA2 (<>)
+ src/Data/Semiring/Matrix.hs view
@@ -0,0 +1,491 @@+{-# 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 view
@@ -0,0 +1,132 @@+{-# 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
@@ -31,8 +31,9 @@ import Data.Foldable import Data.Semiring import Data.Semigroup.Foldable-import Test.Property.Util-import qualified Test.Property as Prop+import Test.Util+import qualified Test.Function  as Prop+import qualified Test.Operation as Prop  ------------------------------------------------------------------------------------ -- Properties of pre-semirings & semirings@@ -78,7 +79,7 @@ neutral_multiplication_on :: Semiring r => Rel r -> r -> r -> Bool neutral_multiplication_on (~~) = Prop.neutral_on (~~) (><)  -neutral_multiplication_on' :: (Monoid r, Semiring r) => Rel r -> r -> Bool+neutral_multiplication_on' :: Unital r => Rel r -> r -> Bool neutral_multiplication_on' (~~) = Prop.neutral_on (~~) (><) sunit  -- | \( \forall a, b, c \in R: (a + b) + c \sim a + (b + c) \)@@ -136,7 +137,7 @@ -- -- See also 'Data.Warning' and < https://blogs.ncl.ac.uk/andreymokhov/united-monoids/#whatif >. ---nonunital_on :: (Monoid r, Semiring r) => Rel r -> r -> r -> Bool+nonunital_on :: Unital r => Rel r -> r -> r -> Bool nonunital_on (~~) a b = (a >< b) ~~ (a >< b <> b)  ------------------------------------------------------------------------------------@@ -166,14 +167,14 @@ -- -- This is a required property. ---annihilative_multiplication_on :: (Monoid r, Semiring r) => Rel r -> r -> Bool+annihilative_multiplication_on :: Unital r => Rel r -> r -> Bool annihilative_multiplication_on (~~) r = Prop.annihilative_on (~~) (><) mempty r  -- | 'fromBoolean' must be a semiring homomorphism into /R/. -- -- This is a required property. ---homomorphism_boolean :: forall r. (Eq r, Monoid r, Semiring r) => Bool -> Bool -> Bool+homomorphism_boolean :: forall r. (Eq r, Unital r) => Bool -> Bool -> Bool homomorphism_boolean i j =   fromBoolean True     == (sunit @r)  &&   fromBoolean False    == (mempty @r) &&@@ -221,7 +222,7 @@ -- -- For types with exact arithmetic this follows from 'distributive' & 'neutral_multiplication'. ---distributive_finite_on :: (Monoid r, Semiring r) => Rel r -> [r] -> r -> Bool+distributive_finite_on :: Unital r => Rel r -> [r] -> r -> Bool distributive_finite_on (~~) as b = (fold as >< b) ~~ (foldMap (>< b) as)  -- | \( \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 \)@@ -230,14 +231,14 @@ -- -- For types with exact arithmetic this follows from 'distributive' and the universality of 'fold1'. ---distributive_finite1_on :: (Semiring r) => Rel r -> NonEmpty r -> r -> Bool+distributive_finite1_on :: Semiring r => Rel r -> NonEmpty r -> r -> Bool distributive_finite1_on (~~) as b = (fold1 as >< b) ~~ (foldMap1 (>< b) as)  -- | \( \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 also left-distributive then it supports cross-multiplication. ---distributive_cross_on :: (Monoid r, Semiring r) => Rel r -> [r] -> [r] -> Bool+distributive_cross_on :: Unital r => Rel r -> [r] -> [r] -> Bool distributive_cross_on (~~) as bs = (fold as >< fold bs) ~~ (cross as bs)  -- | \( \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 \)
+ src/Data/Semiring/V2.hs view
@@ -0,0 +1,97 @@+{-# 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 view
@@ -0,0 +1,111 @@+{-# 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 view
@@ -0,0 +1,84 @@+{-# 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 view
@@ -1,12 +1,14 @@ {-# 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 (Monoid(..), Semigroup(..))+import Prelude (id, Monoid(..), Semigroup(..)) import qualified Prelude as N (Num(..))  #define deriveSemigroup(ty)        \@@ -28,9 +30,6 @@ ;  {-# INLINE fromBoolean #-}      \ } -#define deriveDioid(ty)             \-instance Dioid (ty) where {         \-}  deriveSemigroup(Word) deriveSemigroup(Word8)@@ -53,9 +52,17 @@ deriveSemiring(Word64) deriveSemiring(Natural) -deriveDioid(Word)-deriveDioid(Word8)-deriveDioid(Word16)-deriveDioid(Word32)-deriveDioid(Word64)-deriveDioid(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