diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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] ------------------- diff --git a/Data/Semiring.hs b/Data/Semiring.hs --- a/Data/Semiring.hs +++ b/Data/Semiring.hs @@ -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] diff --git a/Data/Semiring/Free.hs b/Data/Semiring/Free.hs new file mode 100644 --- /dev/null +++ b/Data/Semiring/Free.hs @@ -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 diff --git a/Data/Semiring/Generic.hs b/Data/Semiring/Generic.hs --- a/Data/Semiring/Generic.hs +++ b/Data/Semiring/Generic.hs @@ -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 diff --git a/Data/Star.hs b/Data/Star.hs --- a/Data/Star.hs +++ b/Data/Star.hs @@ -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 -- 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 #-} + diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 R 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
-http://r6.ca/blog/20110808T035622Z.html
-https://byorgey.wordpress.com/2016/04/05/the-network-reliability-problem-and-star-semirings/
+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 ====== diff --git a/semirings.cabal b/semirings.cabal --- a/semirings.cabal +++ b/semirings.cabal @@ -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