semirings 0.1.3.0 → 0.2.0.0

raw patch · 7 files changed

+499/−177 lines, 7 filesdep +taggeddep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies added: tagged

Dependency ranges changed: containers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−3
• Data/Semiring.hs +369/−146
• Data/Semiring/Free.hs +89/−0
• Data/Semiring/Generic.hs +2/−1
• Data/Star.hs +15/−16
• README.md +6/−4
• semirings.cabal +10/−7

@@ -1,7 +1,12 @@-0.1.3.0: [2018.05.23]+0.2.0.0: [2018.07.23] ----------------------* remove dependency on `constrictor`.-* some doc fixes.+* Fixed the `Semiring` instances of `Set`, `HashSet`, `Vector`, `Storable Vector`, `Unboxed Vector`.+* Removed the `Semiring` instances of `Seq`, `Alt`, `Endo`.+* Added comprehensive test suite that tests all `Semiring` instances defined in Data.Semiring+* Added Free semiring (Data.Semiring.Free)+* Added newtypes: `Add`, `Mul`+* Bounds for containers: [0.3,0.6] -> [0.5.4,0.6.0.9]+* Add semiring instance for `Proxy`  0.1.2: [2018.05.04] -------------------

@@ -1,9 +1,15 @@ {-# LANGUAGE BangPatterns               #-} {-# LANGUAGE CPP                        #-} {-# LANGUAGE DefaultSignatures          #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoImplicitPrelude          #-} {-# LANGUAGE Rank2Types                 #-}+{-# LANGUAGE ScopedTypeVariables        #-} {-# LANGUAGE StandaloneDeriving         #-}  {-# OPTIONS_GHC -Wall #-}@@ -20,17 +26,21 @@   , foldMapP   , foldMapT   , sum-  , prod+  , product   , sum'-  , prod'-  +  , product'++    -- * Types+  , Add(..)+  , Mul(..)+     -- * Ring typeclass    , Ring(..)   , (-)   , minus    ) where  -import           Control.Applicative (Alternative(..), Applicative(..), Const(..), liftA2)+import           Control.Applicative (Applicative(..), Const(..), liftA2) import           Data.Bool (Bool(..), (||), (&&), otherwise, not) import           Data.Complex (Complex(..)) import           Data.Eq (Eq(..))@@ -38,7 +48,7 @@ import           Data.Foldable (Foldable) import qualified Data.Foldable as Foldable import           Data.Function ((.), const, flip, id)-import           Data.Functor (fmap)+import           Data.Functor (Functor(..)) import           Data.Functor.Identity (Identity(..)) #if defined(VERSION_unordered_containers) import           Data.Hashable (Hashable)@@ -49,30 +59,35 @@ #endif import           Data.Int (Int, Int8, Int16, Int32, Int64) import           Data.Maybe (Maybe(..))+#if MIN_VERSION_base(4,12,0)+import           Data.Monoid (Ap(..))+#endif #if defined(VERSION_containers)-import           Data.IntMap (IntMap)-import qualified Data.IntMap as IntMap-import           Data.IntSet (IntSet)-import qualified Data.IntSet as IntSet+--import           Data.IntMap (IntMap)+--import qualified Data.IntMap as IntMap+--import           Data.IntSet (IntSet)+--import qualified Data.IntSet as IntSet import           Data.Map (Map) import qualified Data.Map as Map #endif-import           Data.Monoid (Monoid(..),Dual(..), Endo(..), Product(..), Sum(..))-#if MIN_VERSION_base(4,8,0)-import           Data.Monoid (Alt(..))-#endif+import           Data.Monoid (Monoid(..),Dual(..), Product(..), Sum(..)) import           Data.Ord (Ord(..), Ordering(..), compare) #if MIN_VERSION_base(4,6,0) import           Data.Ord (Down(..)) #endif+import           Data.Proxy (Proxy(..)) import           Data.Ratio (Ratio)-import           Data.Semigroup (Max(..), Min(..))+import           Data.Semigroup (Semigroup(..),Max(..), Min(..)) #if defined(VERSION_containers)-import           Data.Sequence (Seq)-import qualified Data.Sequence as Seq import           Data.Set (Set) import qualified Data.Set as Set #endif+-- #if defined(VERSION_primitive)+-- import           Data.Primitive.Array (Array(..))+-- import qualified Data.Primitive.Array as Array+-- #endif+import           Data.Traversable (Traversable)+import           Data.Typeable (Typeable) #if defined(VERSION_vector) import           Data.Vector (Vector) import qualified Data.Vector as Vector@@ -88,12 +103,19 @@    CUIntMax, CUIntPtr, CULLong, CULong,    CUSeconds, CUShort, CWchar) import           Foreign.Ptr (IntPtr, WordPtr)+import           Foreign.Storable (Storable) import           GHC.Base (build)+import           GHC.Enum (Enum, Bounded) import           GHC.Float (Float, Double)+#if MIN_VERSION_base(4,6,1)+import           GHC.Generics (Generic,Generic1)+#endif import           GHC.IO (IO) import           GHC.Integer (Integer) import qualified GHC.Num as Num-import           GHC.Real (Integral, quot, even)+import           GHC.Read (Read)+import           GHC.Real (Integral, Fractional, Real, RealFrac, quot, even)+import           GHC.Show (Show) import           Numeric.Natural (Natural) import           System.Posix.Types   (CCc, CDev, CGid, CIno, CMode, CNlink,@@ -121,18 +143,22 @@     g x y z | even y = g (x * x) (y `quot` 2) z             | y == 1 = x * z             | otherwise = g (x * x) (y `quot` 2) (x * z)+{-# INLINE (^) #-}  -- | Infix shorthand for 'plus'. (+) :: Semiring a => a -> a -> a (+) = plus+{-# INLINE (+) #-}  -- | Infix shorthand for 'times'. (*) :: Semiring a => a -> a -> a (*) = times+{-# INLINE (*) #-}  -- | Infix shorthand for 'minus'. (-) :: Ring a => a -> a -> a (-) = minus+{-# INLINE (-) #-}  -- | Map each element of the structure to a semiring, and combine the results --   using 'plus'.@@ -150,22 +176,94 @@ --   This function is lazy. For a strict version, see 'sum''. sum  :: (Foldable t, Semiring a) => t a -> a sum  = Foldable.foldr plus zero+{-# INLINE sum #-}  -- | The 'prod' function computes the multiplicative sum of the elements in a structure. --   This function is lazy. for a strict version, see 'prod''.-prod :: (Foldable t, Semiring a) => t a -> a-prod = Foldable.foldr times one+product :: (Foldable t, Semiring a) => t a -> a+product = Foldable.foldr times one+{-# INLINE product #-}  -- | The 'sum'' function computes the additive sum of the elements in a structure. --   This function is strict. For a lazy version, see 'sum'. sum'  :: (Foldable t, Semiring a) => t a -> a-sum'  = Foldable.foldr' plus zero+sum'  = Foldable.foldl' plus zero+{-# INLINE sum' #-}  -- | The 'prod'' function computes the additive sum of the elements in a structure. --   This function is strict. For a lazy version, see 'prod'.-prod' :: (Foldable t, Semiring a) => t a -> a-prod' = Foldable.foldr' times one+product' :: (Foldable t, Semiring a) => t a -> a+product' = Foldable.foldl' times one+{-# INLINE product' #-} +newtype Add a = Add { getAdd :: a }+  deriving+    ( Bounded+    , Enum+    , Eq+    , Foldable+    , Fractional+    , Functor+#if MIN_VERSION_base(4,6,1)+    , Generic+    , Generic1+#endif+    , Num.Num+    , Ord+    , Read+    , Real+    , RealFrac+    , Semiring+    , Show+    , Storable+    , Traversable+    , Typeable+    )++newtype Mul a = Mul { getMul :: a }+  deriving+    ( Bounded+    , Enum+    , Eq+    , Foldable+    , Fractional+    , Functor+#if MIN_VERSION_base(4,6,1)+    , Generic+    , Generic1+#endif+    , Num.Num+    , Ord+    , Read+    , Real+    , RealFrac+    , Semiring+    , Show+    , Storable+    , Traversable+    , Typeable+    )++instance Semiring a => Semigroup (Add a) where+  (<>) = (+)+  {-# INLINE (<>) #-}++instance Semiring a => Monoid (Add a) where+  mempty = Add zero+  mappend = (<>)+  {-# INLINE mempty #-}+  {-# INLINE mappend #-}++instance Semiring a => Semigroup (Mul a) where+  (<>) = (*)+  {-# INLINE (<>) #-}++instance Semiring a => Monoid (Mul a) where+  mempty = Mul one+  mappend = (<>)+  {-# INLINE mempty #-}+  {-# INLINE mappend #-}+ {--------------------------------------------------------------------   Classes --------------------------------------------------------------------}@@ -175,8 +273,8 @@ -- can think of a semiring as two monoids of the same -- underlying type: A commutative monoid and an -- associative monoid. For any type R with a 'Prelude.Num'--- instance, the commutative monoid is (R, 'GHC.Num.+', 0)--- and the associative monoid is (R, 'GHC.Num.*', 1).+-- instance, the commutative monoid is (R, '(Prelude.+)', 0)+-- and the associative monoid is (R, '(Prelude.*)', 1). -- -- Instances should satisfy the following laws: --@@ -202,15 +300,12 @@ --  -- [/left- and right-distributivity of '*' over '+'/] -----     @---     x '*' (y '+' z) = (x '*' y) '+' (x '*' z)---     (x '+' y) '*' z = (x '*' z) '+' (y '*' z)---     @+--     @x '*' (y '+' z) = (x '*' y) '+' (x '*' z)@+--     @(x '+' y) '*' z = (x '*' z) '+' (y '*' z)@ -- -- [/annihilation/] -- --     @'zero' '*' x = x '*' 'zero' = 'zero'@---  class Semiring a where #if __GLASGOW_HASKELL__ >= 708@@ -222,10 +317,10 @@   one   :: a           -- ^ Associative Unit    -- useful for defining semirings over ground types-  default zero  :: Num.Num a => a-  default one   :: Num.Num a => a-  default plus  :: Num.Num a => a -> a -> a-  default times :: Num.Num a => a -> a -> a+  default zero  :: Num.Num a => a -- ^ 0+  default one   :: Num.Num a => a -- ^ 1+  default plus  :: Num.Num a => a -> a -> a -- ^ '(Prelude.+)'+  default times :: Num.Num a => a -> a -> a -- ^ '(Prelude.*)'   zero  = 0   one   = 1   plus  = (Num.+)@@ -245,11 +340,12 @@   negate = Num.negate  -- | Substract two 'Ring' values. For any type 'R' with--- a 'Prelude.Num' instance, this is the same as Prelude's 'GHC.Num.-'.+-- a 'Prelude.Num' instance, this is the same as '(Prelude.-)'. -- --     @x `minus` y = x '+' 'negate' y@ minus :: Ring a => a -> a -> a minus x y = x + negate y+{-# INLINE minus #-}  {--------------------------------------------------------------------   Instances (base)@@ -260,27 +356,52 @@   zero        = const zero   times f g x = f x `times` g x   one         = const one+  {-# INLINE plus  #-}+  {-# INLINE zero  #-}+  {-# INLINE times #-}+  {-# INLINE one   #-}  instance Ring b => Ring (a -> b) where   negate f x = negate (f x)+  {-# INLINE negate #-}  instance Semiring () where   plus _ _  = ()   zero      = ()   times _ _ = ()   one       = ()+  {-# INLINE plus  #-}+  {-# INLINE zero  #-}+  {-# INLINE times #-}+  {-# INLINE one   #-}  instance Ring () where   negate _ = ()+  {-# INLINE negate #-} +instance Semiring (Proxy a) where+  plus _ _  = Proxy+  zero      = Proxy+  times _ _ = Proxy+  one       = Proxy+  {-# INLINE plus  #-}+  {-# INLINE zero  #-}+  {-# INLINE times #-}+  {-# INLINE one   #-}+ instance Semiring Bool where   plus  = (||)   zero  = False   times = (&&)   one   = True+  {-# INLINE plus  #-}+  {-# INLINE zero  #-}+  {-# INLINE times #-}+  {-# INLINE one   #-}  instance Ring Bool where   negate = not+  {-# INLINE negate #-}  -- See Section: List fusion instance Semiring a => Semiring [a] where@@ -288,9 +409,14 @@   one  = [one]   plus  = listAdd   times = listTimes+  {-# INLINE plus  #-}+  {-# INLINE zero  #-}+  {-# INLINE times #-}+  {-# INLINE one   #-}  instance Ring a => Ring [a] where   negate = fmap negate+  {-# INLINE negate #-}  instance Semiring a => Semiring (Maybe a) where   zero  = Nothing@@ -303,75 +429,85 @@   times Nothing _ = Nothing   times _ Nothing = Nothing   times (Just x) (Just y) = Just (times x y)+  {-# INLINE plus  #-}+  {-# INLINE zero  #-}+  {-# INLINE times #-}+  {-# INLINE one   #-}  instance Ring a => Ring (Maybe a) where   negate = fmap negate+  {-# INLINE negate #-}  instance Semiring a => Semiring (IO a) where   zero  = pure zero   one   = pure one   plus  = liftA2 plus   times = liftA2 times+  {-# INLINE plus  #-}+  {-# INLINE zero  #-}+  {-# INLINE times #-}+  {-# INLINE one   #-}  instance Ring a => Ring (IO a) where   negate = fmap negate+  {-# INLINE negate #-}  instance Semiring a => Semiring (Dual a) where   zero = Dual zero   Dual x `plus` Dual y = Dual (y `plus` x)   one = Dual one   Dual x `times` Dual y = Dual (y `times` x)+  {-# INLINE plus  #-}+  {-# INLINE zero  #-}+  {-# INLINE times #-}+  {-# INLINE one   #-}  instance Ring a => Ring (Dual a) where   negate (Dual x) = Dual (negate x)---- | This is not a true semiring. Even if the underlying--- monoid is commutative, it is only a near semiring. It--- is, however, quite useful. For instance, this type:------ @forall a. 'Endo' ('Endo' a)@------ is a valid encoding of church numerals, with addition and--- multiplication being their semiring variants.-instance Monoid a => Semiring (Endo a) where-  zero  = Endo mempty-  plus (Endo f) (Endo g) = Endo (mappend f g)-  one   = mempty-  times = mappend--instance (Monoid a, Ring a) => Ring (Endo a) where-  negate (Endo f) = Endo (negate f)--#if MIN_VERSION_base(4,8,0)-instance (Alternative f, Semiring a) => Semiring (Alt f a) where-  zero  = empty-  one   = Alt (pure one)-  plus  = (<|>)-  times = liftA2 times--instance (Alternative f, Ring a) => Ring (Alt f a) where-  negate = fmap negate-#endif+  {-# INLINE negate #-}  instance Semiring a => Semiring (Const a b) where   zero = Const zero   one  = Const one   plus  (Const x) (Const y) = Const (x `plus`  y)   times (Const x) (Const y) = Const (x `times` y)+  {-# INLINE plus  #-}+  {-# INLINE zero  #-}+  {-# INLINE times #-}+  {-# INLINE one   #-}  instance Ring a => Ring (Const a b) where   negate (Const x) = Const (negate x)+  {-# INLINE negate #-} +-- | This instance can suffer due to floating point arithmetic. instance Ring a => Semiring (Complex a) where   zero = zero :+ zero   one  = one  :+ zero   plus  (x :+ y) (x' :+ y') = plus x x' :+ plus y y'   times (x :+ y) (x' :+ y')     = (x * x' - (y * y')) :+ (x * y' + y * x')+  {-# INLINE plus  #-}+  {-# INLINE zero  #-}+  {-# INLINE times #-}+  {-# INLINE one   #-}  instance Ring a => Ring (Complex a) where   negate (x :+ y) = negate x :+ negate y+  {-# INLINE negate #-} +#if MIN_VERSION_base(4,12,0)+instance (Semiring a, Applicative f) => Semiring (Ap f a) where+  zero  = pure zero+  one   = pure one+  plus  = liftA2 plus+  times = liftA2 times+  {-# INLINE plus  #-}+  {-# INLINE zero  #-}+  {-# INLINE times #-}+  {-# INLINE one   #-}+#endif+ instance Semiring Int instance Semiring Int8 instance Semiring Int16@@ -383,7 +519,9 @@ instance Semiring Word16 instance Semiring Word32 instance Semiring Word64+-- | This instance can suffer due to floating point arithmetic. instance Semiring Float+-- | This instance can suffer due to floating point arithmetic. instance Semiring Double instance Semiring CUIntMax instance Semiring CIntMax@@ -427,6 +565,7 @@ instance Semiring CIno instance Semiring CDev instance Semiring Natural+-- | Non-negative rational numbers form a semiring. instance Integral a => Semiring (Ratio a) deriving instance Semiring a => Semiring (Product a) deriving instance Semiring a => Semiring (Sum a)@@ -509,50 +648,71 @@ --------------------------------------------------------------------}  #if defined(VERSION_containers)-instance (Ord a, Semiring a) => Semiring (Set a) where++-- | The multiplication laws are satisfied for+--   any underlying 'Monoid', so we require a+--   'Monoid' contraint instead of a 'Semiring'+--   constraint since 'times' can use+--   the context of either.+instance (Ord a, Monoid a) => Semiring (Set a) where   zero  = Set.empty-  one   = Set.singleton one+  one   = Set.singleton mempty   plus  = Set.union-#if MIN_VERSION_containers(5,11,0)-  times xs ys = Set.map (P.uncurry times) (Set.cartesianProduct xs ys)-#else-  -- I think this could also be 'times xs ys = foldMapT (flip Set.map ys . times) xs'-  times xs ys = Set.fromList (times (Set.toList xs) (Set.toList ys))-#endif+  times xs ys = Foldable.foldMap (flip Set.map ys . mappend) xs+  {-# INLINE plus  #-}+  {-# INLINE zero  #-}+  {-# INLINE times #-}+  {-# INLINE one   #-} -instance (Ord a, Semiring a, Semiring b) => Semiring (Map a b) where+-- | The multiplication laws are satisfied for+--   any underlying 'Monoid' as the key type,+--   so we require a 'Monoid' contraint instead of+--   a 'Semiring' constraint since 'times' can use+--   the context of either.+instance (Ord k, Monoid k, Semiring v) => Semiring (Map k v) where   zero = Map.empty-  one  = Map.singleton zero one+  one  = Map.singleton mempty one   plus = Map.unionWith (+)   xs `times` ys     = Map.fromListWith (+)-        [ (plus k l, v * u)+        [ (mappend k l, v * u)         | (k,v) <- Map.toList xs         , (l,u) <- Map.toList ys         ]--instance Semiring IntSet where-  zero = IntSet.empty-  one  = IntSet.singleton one-  plus = IntSet.union-  times xs ys = IntSet.fromList (times (IntSet.toList xs) (IntSet.toList ys))+  {-# INLINE plus  #-}+  {-# INLINE zero  #-}+  {-# INLINE times #-}+  {-# INLINE one   #-} -instance (Semiring a) => Semiring (IntMap a) where-  zero = IntMap.empty-  one  = IntMap.singleton zero one-  plus = IntMap.unionWith (+)-  xs `times` ys-    = IntMap.fromListWith (+)-        [ (plus k l, v * u)-        | (k,v) <- IntMap.toList xs-        , (l,u) <- IntMap.toList ys-        ]+--newtype IntSetP = IntSetP { intSetP :: IntSet }+--newtype IntSetT = IntSetT { intSetT :: IntSet }+--+--instance Semiring IntSetP where+--  zero = IntSetP (IntSet.empty)+--  one  = IntSetP (IntSet.singleton zero)+--  plus (IntSetP x) (IntSetP y) = IntSetP (IntSet.union x y)+--  times (IntSetP xs) (IntSetP ys) = IntSetP (foldMapIntSet (flip IntSet.map ys . plus) xs)+--+--instance Semiring IntSetT where+--  zero = IntSetT IntSet.empty+--  one  = IntSetT (IntSet.singleton one)+--  plus (IntSetT x) (IntSetT y) = IntSetT (IntSet.union x y)+--  times (IntSetT xs) (IntSetT ys) = IntSetT (foldMapIntSet (flip IntSet.map ys . times) xs)+--+--foldMapIntSet :: Monoid m => (Int -> m) -> IntSet -> m+--foldMapIntSet f = IntSet.foldl' (flip (mappend . f)) mempty+--{-# INLINE foldMapIntSet #-} -instance (Semiring a) => Semiring (Seq a) where-  zero = Seq.empty-  one  = Seq.singleton one-  plus = (Seq.><)-  times xs ys = Seq.fromList (times (Foldable.toList xs) (Foldable.toList ys))+--instance (Semiring a) => Semiring (IntMap a) where+--  zero = IntMap.empty+--  one  = IntMap.singleton zero one+--  plus = IntMap.unionWith (+)+--  xs `times` ys+--    = IntMap.fromListWith (+)+--        [ (plus k l, v * u)+--        | (k,v) <- IntMap.toList xs+--        , (l,u) <- IntMap.toList ys+--        ] #endif  {--------------------------------------------------------------------@@ -560,24 +720,67 @@ --------------------------------------------------------------------}  #if defined(VERSION_unordered_containers)-instance (Eq a, Hashable a, Semiring a) => Semiring (HashSet a) where++-- | The multiplication laws are satisfied for+--   any underlying 'Monoid', so we require a+--   'Monoid' contraint instead of a 'Semiring'+--   constraint since 'times' can use+--   the context of either.+instance (Eq a, Hashable a, Monoid a) => Semiring (HashSet a) where   zero = HashSet.empty-  one  = HashSet.singleton one+  one  = HashSet.singleton mempty   plus = HashSet.union-  times xs ys = foldMapT (flip HashSet.map ys . times) xs+  times xs ys = Foldable.foldMap (flip HashSet.map ys . mappend) xs+  {-# INLINE plus  #-}+  {-# INLINE zero  #-}+  {-# INLINE times #-}+  {-# INLINE one   #-} -instance (Eq k, Hashable k, Semiring k, Semiring v) => Semiring (HashMap k v) where+-- | The multiplication laws are satisfied for+--   any underlying 'Monoid' as the key type,+--   so we require a 'Monoid' contraint instead of+--   a 'Semiring' constraint since 'times' can use+--   the context of either.+instance (Eq k, Hashable k, Monoid k, Semiring v) => Semiring (HashMap k v) where   zero = HashMap.empty-  one  = HashMap.singleton zero one+  one  = HashMap.singleton mempty one   plus = HashMap.unionWith (+)   xs `times` ys     = HashMap.fromListWith (+)-        [ (k + l, v * u)+        [ (mappend k l, v * u)         | (k,v) <- HashMap.toList xs-        , (l,u) <- HashMap.toList ys ]+        , (l,u) <- HashMap.toList ys+        ]+  {-# INLINE plus  #-}+  {-# INLINE zero  #-}+  {-# INLINE times #-}+  {-# INLINE one   #-} #endif  {--------------------------------------------------------------------+  Instances (primitive)+--------------------------------------------------------------------}++#if defined(VERSION_primitive)+-- | The multiplication laws are satisfied for+--   any underlying 'Monoid', so we require a+--   'Monoid' contraint instead of a 'Semiring'+--   constraint since 'times' can use+--   the context of either.+-- instance (Monoid a) => Semiring (Array a) where+--   zero  = mempty+--   one   = runST e where+--     e :: forall s. Monoid a => ST s (Array a)+--     e = (Array.newArray 1 mempty) >>= Array.unsafeFreezeArray+--   plus _ _ = mempty+--   times _ _ = mempty+--   {-# INLINE plus  #-}+--   {-# INLINE zero  #-}+--   {-# INLINE times #-}+--   {-# INLINE one   #-}+#endif++{--------------------------------------------------------------------   Instances (vector) --------------------------------------------------------------------} @@ -590,24 +793,31 @@       EQ -> Vector.zipWith (+) xs ys       LT -> Vector.unsafeAccumulate (+) ys (Vector.indexed xs)       GT -> Vector.unsafeAccumulate (+) xs (Vector.indexed ys)-  times xs ys-    | Vector.null xs = Vector.empty-    | Vector.null ys = Vector.empty-    | otherwise = Vector.generate maxlen f-      where-        f n = Foldable.foldl'-          (\_ k -> -            Vector.unsafeIndex xs k *-            Vector.unsafeIndex ys (n Num.- k)) zero [kmin .. kmax]-          where-            !kmin = max 0 (n Num.- (klen Num.- 1))-            !kmax = min n (slen Num.- 1)-        !slen = Vector.length xs-        !klen = Vector.length ys-        !maxlen = max slen klen+  times signal kernel+    | Vector.null signal = Vector.empty+    | Vector.null kernel = Vector.empty+    | otherwise = Vector.generate (slen + klen - 1) f+    where+      !slen = Vector.length signal+      !klen = Vector.length kernel+      f n = Foldable.foldl'+        (\a k -> a ++                 Vector.unsafeIndex signal k *+                 Vector.unsafeIndex kernel (n - k)+        )+        zero+        [kmin .. kmax]+        where+          !kmin = max 0 (n - (klen - 1))+          !kmax = min n (slen - 1)+  {-# INLINE plus  #-}+  {-# INLINE zero  #-}+  {-# INLINE times #-}+  {-# INLINE one   #-}  instance Ring a => Ring (Vector a) where   negate = Vector.map negate+  {-# INLINE negate #-}  instance (UV.Unbox a, Semiring a) => Semiring (UV.Vector a) where   zero = UV.empty@@ -617,28 +827,35 @@       EQ -> UV.zipWith (+) xs ys       LT -> UV.unsafeAccumulate (+) ys (UV.indexed xs)       GT -> UV.unsafeAccumulate (+) xs (UV.indexed ys)-  times xs ys-    | UV.null xs = UV.empty-    | UV.null ys = UV.empty-    | otherwise = UV.generate maxlen f-      where-        f n = Foldable.foldl'-          (\_ k -> -            UV.unsafeIndex xs k *-            UV.unsafeIndex ys (n Num.- k)) zero [kmin .. kmax]-          where-            !kmin = max 0 (n Num.- (klen Num.- 1))-            !kmax = min n (slen Num.- 1)-        !slen = UV.length xs-        !klen = UV.length ys-        !maxlen = max slen klen-+  times signal kernel+    | UV.null signal = UV.empty+    | UV.null kernel = UV.empty+    | otherwise = UV.generate (slen + klen - 1) f+    where+      !slen = UV.length signal+      !klen = UV.length kernel+      f n = Foldable.foldl'+        (\a k -> a ++                 UV.unsafeIndex signal k *+                 UV.unsafeIndex kernel (n - k)+        )+        zero+        [kmin .. kmax]+        where+          !kmin = max 0 (n - (klen - 1))+          !kmax = min n (slen - 1)+  {-# INLINE plus  #-}+  {-# INLINE zero  #-}+  {-# INLINE times #-}+  {-# INLINE one   #-}+  instance (UV.Unbox a, Ring a) => Ring (UV.Vector a) where   negate = UV.map negate+  {-# INLINE negate #-}  instance (SV.Storable a, Semiring a) => Semiring (SV.Vector a) where   zero = SV.empty-  one  = SV.singleton one+  one = SV.singleton one   plus xs ys =     case compare lxs lys of       EQ -> SV.zipWith (+) xs ys@@ -647,24 +864,30 @@     where       lxs = SV.length xs       lys = SV.length ys-  times xs ys-    | SV.null xs = SV.empty-    | SV.null ys = SV.empty-    | otherwise  = SV.generate maxlen f+  times signal kernel+    | SV.null signal = SV.empty+    | SV.null kernel = SV.empty+    | otherwise = SV.generate (slen + klen - 1) f       where+        !slen = SV.length signal+        !klen = SV.length kernel         f n = Foldable.foldl'-          (\_ k -> -            SV.unsafeIndex xs k *-            SV.unsafeIndex ys (n Num.- k)) zero [kmin .. kmax]+          (\a k -> a ++                  SV.unsafeIndex signal k *+                  SV.unsafeIndex kernel (n - k))+                zero+                [kmin .. kmax]           where-            !kmin = max 0 (n Num.- (klen Num.- 1))-            !kmax = min n (slen Num.- 1)-        !slen = SV.length xs-        !klen = SV.length ys-        !maxlen = max slen klen-+            !kmin = max 0 (n - (klen - 1))+            !kmax = min n (slen - 1)+  {-# INLINE plus  #-}+  {-# INLINE zero  #-}+  {-# INLINE times #-}+  {-# INLINE one   #-}+   instance (SV.Storable a, Ring a) => Ring (SV.Vector a) where   negate = SV.map negate+  {-# INLINE negate #-} #endif  -- [Section: List fusion]

@@ -0,0 +1,89 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE StandaloneDeriving #-}++#if !MIN_VERSION_base(4,9,0)+{-# OPTIONS_GHC -fno-warn-orphans #-}+#endif++module Data.Semiring.Free+  (+#if defined(VERSION_containers)+#if MIN_VERSION_base(4,8,0)+    Free(..)+  , runFree+  , lowerFree+  , liftFree+#endif+#endif+  ) where++#if defined(VERSION_containers)+#if MIN_VERSION_base(4,8,0)+import           Control.Applicative (pure)+import           Data.Bool (otherwise)+import           Data.Coerce (Coercible, coerce)+import           Data.Eq (Eq)+import           Data.Functor (Functor(..))+import           Data.Functor.Identity (Identity(..))+import           Data.Function (flip,id, (.))+import           Data.Ord (Ord)+#if !MIN_VERSION_base(4,9,0)+import           Data.Semigroup ()+#endif+import           Data.Semiring+import           Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import           Data.Monoid (Monoid(..))++import           GHC.Show (Show)+import           GHC.Read (Read)+import           GHC.Real (even, div)+import           Numeric.Natural++newtype Free a = Free+  { getFree :: Map (Identity a) Natural+  } deriving (Show, Read, Eq, Ord, Semiring)++#if !MIN_VERSION_base(4,9,0)+--deriving instance Semigroup a => Semigroup (Identity a)+deriving instance Monoid a => Monoid (Identity a)+#endif++runFree :: Semiring s => (a -> s) -> Free a -> s+runFree f = getAdd #. Map.foldMapWithKey ((rep .# Add) . product . fmap f) . getFree++lowerFree :: Semiring s => Free s -> s+lowerFree = runFree id++liftFree :: a -> Free a+liftFree = Free . flip Map.singleton one . pure++rep :: Monoid m => m -> Natural -> m+rep x = go+  where+    go 0 = mempty+    go 1 = x+    go n+      | even n = r `mappend` r+      | otherwise = x `mappend` r `mappend` r+      where+        r = go (n `div` 2)+{-# INLINE rep #-}++-- | Coercive left-composition.+infixr 9 #.+(#.) :: Coercible b c => (b -> c) -> (a -> b) -> a -> c+(#.) _ = coerce+{-# INLINE (#.) #-}++-- | Coercive right-composition.+infixr 9 .#+(.#) :: Coercible a b => (b -> c) -> (a -> b) -> a -> c+(.#) f _ = coerce f+{-# INLINE (.#) #-}++#endif++#endif

@@ -1,7 +1,8 @@ {-# LANGUAGE CPP              #-}+#if MIN_VERSION_base(4,6,0) {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeOperators    #-}-+#endif {-# OPTIONS_GHC -Wall #-}  -- below are safe orphan instances

@@ -1,17 +1,14 @@+{-# LANGUAGE NoImplicitPrelude #-}+ module Data.Star   ( Star(..)   ) where -import Control.Monad (ap)-import Control.Monad.Fix (fix) import Data.Bool (Bool(..)) import Data.Function (id, (.))-import Data.Monoid-+import Data.Proxy (Proxy(..)) import Data.Semiring -import Prelude hiding (Num(..))- -- | A <https://en.wikipedia.org/wiki/Semiring#Star_semirings Star semiring> -- adds one operation, 'star' to a 'Semiring', such that it follows the -- law:@@ -32,22 +29,24 @@ instance Star b => Star (a -> b) where   star  = (.) star   aplus = (.) aplus+  {-# INLINE star #-}+  {-# INLINE aplus #-}  instance Star Bool where   star _  = True   aplus   = id+  {-# INLINE star #-}+  {-# INLINE aplus #-}  instance Star () where   star  _ = ()   aplus _ = ()+  {-# INLINE star #-}+  {-# INLINE aplus #-} -instance (Eq a, Monoid a) => Star (Endo a) where-  star (Endo f) = Endo converge-    where-      if' :: Bool -> a -> a -> a-      if' True  x _ = x-      if' False _ y = y-      converge = fix (ap mappend . ap (if' =<< ap (==) (ap mappend f)) . (. ap mappend f))-      --converge inp = mappend inp (if inp == next then inp else converge next)-      -- where-      --   next = mappend inp (f inp)+instance Star (Proxy a) where+  star _ = Proxy+  aplus _ = Proxy+  {-# INLINE star #-}+  {-# INLINE aplus #-}+

@@ -5,7 +5,7 @@  A Semiring has two appending operations, 'plus' and 'times', and two respective identity elements, 'zero' and 'one'. -More formally, A semiring <i>R</i> is a set equipped with two binary relations + and *, such that:+More formally, A semiring R is a set equipped with two binary relations + and *, such that:  - (R, +) is a commutative monoid with identity element 0:   - (a + b) + c = a + (b + c)@@ -45,9 +45,11 @@  Some relevant (informal) reading material: -http://stedolan.net/research/semirings.pdf <br>-http://r6.ca/blog/20110808T035622Z.html <br>-https://byorgey.wordpress.com/2016/04/05/the-network-reliability-problem-and-star-semirings/ <br>+http://stedolan.net/research/semirings.pdf++http://r6.ca/blog/20110808T035622Z.html++https://byorgey.wordpress.com/2016/04/05/the-network-reliability-problem-and-star-semirings/  additional credit ======

@@ -1,6 +1,6 @@ name:          semirings category:      Algebra, Data, Data Structures, Math, Maths, Mathematics-version:       0.1.3.0+version:       0.2.0.0 license:       BSD3 cabal-version: >= 1.10 license-file:  LICENSE@@ -13,7 +13,6 @@ synopsis:      two monoids as one, in holy haskimony description:     In mathematics, a semiring is an algebraic structure consisting of a set together with two binary operations, one commutative and one associative. A semiring has two identity elements respective to its operations. Thus a semiring can be seen as a combination of two monoids, a commutative monoid and an associative monoid.-    For some useful semirings, see the 'semirings-types' package. build-type:    Simple extra-source-files: README.md CHANGELOG.md tested-with:   GHC == 7.4.1 @@ -32,6 +31,8 @@              , GHC == 8.2.2              , GHC == 8.4.1              , GHC == 8.4.2+             , GHC == 8.4.3+             , GHC == 8.6.1  source-repository head   type: git@@ -43,8 +44,6 @@     .     Disabling this may be useful for accelerating builds in sandboxes for expert users.     .-    If disabled we will not supply instances of `Hashable`-    .     Note: `-f-hashable` implies `-f-unordered-containers`, as we are necessarily not able to supply those instances as well.   default: True   manual: True@@ -88,17 +87,21 @@    if impl(ghc < 8.0)     build-depends: semigroups-    ++  if impl(ghc < 7.8)+    build-depends: tagged+   if impl(ghc >= 7.2)     exposed-modules:       Data.Semiring+      Data.Semiring.Free       Data.Star   if impl(ghc >= 7.6.1)     exposed-modules:       Data.Semiring.Generic-    +        if flag(containers)-      build-depends: containers >= 0.3 && < 0.6+      build-depends: containers >= 0.5.4 && < 0.6.1.0      if flag(hashable)       build-depends: hashable >= 1.1  && < 1.3