semiring-num 1.4.0.0 → 1.5.0.0
raw patch · 4 files changed
+242/−17 lines, 4 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Data.Semiring: instance (Data.Vector.Unboxed.Base.Unbox a, Data.Semiring.DetectableZero a) => Data.Semiring.DetectableZero (Data.Vector.Unboxed.Base.Vector a)
+ Data.Semiring: instance (Data.Vector.Unboxed.Base.Unbox a, Data.Semiring.Semiring a) => Data.Semiring.Semiring (Data.Vector.Unboxed.Base.Vector a)
+ Data.Semiring: instance (Foreign.Storable.Storable a, Data.Semiring.DetectableZero a) => Data.Semiring.DetectableZero (Data.Vector.Storable.Vector a)
+ Data.Semiring: instance (Foreign.Storable.Storable a, Data.Semiring.Semiring a) => Data.Semiring.Semiring (Data.Vector.Storable.Vector a)
+ Data.Semiring: instance Data.Semiring.DetectableZero a => Data.Semiring.DetectableZero (Data.Vector.Vector a)
+ Data.Semiring: instance Data.Semiring.Semiring a => Data.Semiring.Semiring (Data.Vector.Vector a)
Files
- bench/bench.hs +22/−1
- semiring-num.cabal +3/−1
- src/Data/Semiring.hs +192/−2
- test/Spec.hs +25/−13
bench/bench.hs view
@@ -8,6 +8,8 @@ import Data.Semiring +import qualified Data.Vector as Vector+ threeInts :: IO (Int,Int,Int) threeInts = (,,) <$> randomIO <*> randomIO <*> randomIO @@ -26,5 +28,24 @@ \xs -> bench "prod-list" (nf (uncurry (<.>)) xs) +prodAtSizeVec :: Int -> Int -> Benchmark+prodAtSizeVec n m =+ env ((,) <$> Vector.replicateM n int <*> Vector.replicateM m int) $+ \xs ->+ bgroup+ "vec"+ [ bench (show n ++ "<.>" ++ show m) (nf (uncurry (<.>)) xs)+ , bench (show m ++ "<.>" ++ show n) (nf (uncurry (flip (<.>))) xs)+ , bench (show n ++ "<+>" ++ show m) (nf (uncurry (<+>)) xs)+ , bench (show m ++ "<+>" ++ show n) (nf (uncurry (flip (<+>))) xs)+ ]+ main :: IO ()-main = defaultMain [prodAtSize 2000 1000, sumAtSize 10000]+main =+ defaultMain+ [ prodAtSizeVec 4000 2000+ , prodAtSizeVec 4000 2000]++++-- prodAtSize 2000 1000, sumAtSize 10000]
semiring-num.cabal view
@@ -1,5 +1,5 @@ name: semiring-num-version: 1.4.0.0+version: 1.5.0.0 synopsis: Basic semiring class and instances description: Adds a basic semiring class homepage: https://github.com/oisdk/semiring-num@@ -47,6 +47,7 @@ , tasty-smallcheck >= 0.8 , tasty-quickcheck >= 0.8 , log-domain >= 0.10+ , vector >= 0.12 ghc-options: -threaded -rtsopts -with-rtsopts=-N@@ -62,6 +63,7 @@ , criterion >=1.1 , random >= 1.1 , containers >= 0.5+ , vector >= 0.12 ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010
src/Data/Semiring.hs view
@@ -83,6 +83,10 @@ import qualified Data.HashSet as HashSet import Data.Hashable +import qualified Data.Vector as Vector+import qualified Data.Vector.Storable as StorableVector+import qualified Data.Vector.Unboxed as UnboxedVector+ import Numeric.Log hiding (sum) import qualified Numeric.Log @@ -391,6 +395,182 @@ isZero = all isZero {-# INLINE isZero #-} +type BinaryContainer c a = c a -> c a -> c a++instance Semiring a =>+ Semiring (Vector.Vector a) where+ one = Vector.singleton one+ zero = Vector.empty+ xs <+> ys =+ case compare (Vector.length xs) (Vector.length ys) of+ EQ -> Vector.zipWith (<+>) xs ys+ LT -> Vector.unsafeAccumulate (<+>) ys (Vector.indexed xs)+ GT -> Vector.unsafeAccumulate (<+>) xs (Vector.indexed ys)+ signal <.> kernel+ | Vector.null signal = Vector.empty+ | Vector.null kernel = Vector.empty+ | otherwise = Vector.generate (slen + klen - 1) f+ where+ f n =+ 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)+ slen = Vector.length signal+ klen = Vector.length kernel+ {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Double #-}+ {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Float #-}+ {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Int #-}+ {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Bool #-}+ {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Word #-}+ {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Int8 #-}+ {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Int16 #-}+ {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Int32 #-}+ {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Int64 #-}+ {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Word8 #-}+ {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Word16 #-}+ {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Word32 #-}+ {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Word64 #-}+ {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Double #-}+ {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Float #-}+ {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Int #-}+ {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Bool #-}+ {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Word #-}+ {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Int8 #-}+ {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Int16 #-}+ {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Int32 #-}+ {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Int64 #-}+ {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Word8 #-}+ {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Word16 #-}+ {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Word32 #-}+ {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Word64 #-}++instance DetectableZero a => DetectableZero (Vector.Vector a) where+ isZero = Vector.all isZero++instance (UnboxedVector.Unbox a, Semiring a) =>+ Semiring (UnboxedVector.Vector a) where+ one = UnboxedVector.singleton one+ zero = UnboxedVector.empty+ xs <+> ys =+ case compare (UnboxedVector.length xs) (UnboxedVector.length ys) of+ EQ -> UnboxedVector.zipWith (<+>) xs ys+ LT -> UnboxedVector.unsafeAccumulate (<+>) ys (UnboxedVector.indexed xs)+ GT -> UnboxedVector.unsafeAccumulate (<+>) xs (UnboxedVector.indexed ys)+ signal <.> kernel+ | UnboxedVector.null signal = UnboxedVector.empty+ | UnboxedVector.null kernel = UnboxedVector.empty+ | otherwise = UnboxedVector.generate (slen + klen - 1) f+ where+ f n =+ foldl'+ (\a k ->+ a <+>+ UnboxedVector.unsafeIndex signal k <.>+ UnboxedVector.unsafeIndex kernel (n - k))+ zero+ [kmin .. kmax]+ where+ kmin = max 0 (n - (klen - 1))+ kmax = min n (slen - 1)+ slen = UnboxedVector.length signal+ klen = UnboxedVector.length kernel+ {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Double #-}+ {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Float #-}+ {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Int #-}+ {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Bool #-}+ {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Word #-}+ {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Int8 #-}+ {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Int16 #-}+ {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Int32 #-}+ {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Int64 #-}+ {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Word8 #-}+ {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Word16 #-}+ {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Word32 #-}+ {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Word64 #-}+ {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Double #-}+ {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Float #-}+ {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Int #-}+ {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Bool #-}+ {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Word #-}+ {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Int8 #-}+ {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Int16 #-}+ {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Int32 #-}+ {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Int64 #-}+ {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Word8 #-}+ {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Word16 #-}+ {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Word32 #-}+ {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Word64 #-}++instance (UnboxedVector.Unbox a, DetectableZero a) => DetectableZero (UnboxedVector.Vector a) where+ isZero = UnboxedVector.all isZero++instance (StorableVector.Storable a, Semiring a) =>+ Semiring (StorableVector.Vector a) where+ one = StorableVector.singleton one+ zero = StorableVector.empty+ xs <+> ys =+ case compare lxs lys of+ EQ -> StorableVector.zipWith (<+>) xs ys+ LT -> StorableVector.unsafeAccumulate_ (<+>) ys (StorableVector.enumFromN 0 lxs) xs+ GT -> StorableVector.unsafeAccumulate_ (<+>) xs (StorableVector.enumFromN 0 lys) ys+ where+ lxs = StorableVector.length xs+ lys = StorableVector.length ys+ signal <.> kernel+ | StorableVector.null signal = StorableVector.empty+ | StorableVector.null kernel = StorableVector.empty+ | otherwise = StorableVector.generate (slen + klen - 1) f+ where+ f n =+ foldl'+ (\a k ->+ a <+>+ StorableVector.unsafeIndex signal k <.>+ StorableVector.unsafeIndex kernel (n - k))+ zero+ [kmin .. kmax]+ where+ kmin = max 0 (n - (klen - 1))+ kmax = min n (slen - 1)+ slen = StorableVector.length signal+ klen = StorableVector.length kernel+ {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Double #-}+ {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Float #-}+ {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Int #-}+ {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Bool #-}+ {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Word #-}+ {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Int8 #-}+ {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Int16 #-}+ {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Int32 #-}+ {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Int64 #-}+ {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Word8 #-}+ {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Word16 #-}+ {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Word32 #-}+ {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Word64 #-}+ {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Double #-}+ {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Float #-}+ {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Int #-}+ {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Bool #-}+ {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Word #-}+ {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Int8 #-}+ {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Int16 #-}+ {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Int32 #-}+ {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Int64 #-}+ {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Word8 #-}+ {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Word16 #-}+ {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Word32 #-}+ {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Word64 #-}++instance (StorableVector.Storable a, DetectableZero a) => DetectableZero (StorableVector.Vector a) where+ isZero = StorableVector.all isZero+ instance (Monoid a, Ord a) => Semiring (Set a) where (<+>) = Set.union@@ -473,7 +653,15 @@ -- Newtype utilities -------------------------------------------------------------------------------- -showsNewtype :: Coercible b a => String -> String -> (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> b -> ShowS+showsNewtype+ :: Coercible b a+ => String+ -> String+ -> (Int -> a -> ShowS)+ -> ([a] -> ShowS)+ -> Int+ -> b+ -> ShowS showsNewtype cons acc = s where s sp _ n x =@@ -482,7 +670,9 @@ showString " {" . showString acc . showString " =" . sp 0 (coerce x) . showChar '}' -readsNewtype :: Coercible a b => String -> String -> (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS b+readsNewtype+ :: Coercible a b+ => String -> String -> (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS b readsNewtype cons acc = r where r rp _ = readPrec_to_S $ prec 10 $ do Ident c <- lexP
test/Spec.hs view
@@ -30,6 +30,8 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map +import qualified Data.Vector as Vector+ import Data.Semiring import Data.Semiring.Free import Data.Semiring.Infinite@@ -212,7 +214,7 @@ , let p = Proxy :: Proxy (Tup3 (WordOfSize 2)) in testGroup "Tup3 (WordOfSize 2)"- [semiringLawsSC p, zeroLawsSC p]+ [semiringLawsQC p, zeroLawsQC p] , let p = Proxy :: Proxy (Tup4 Int) in testGroup "Tup4 Int" [semiringLawsQC p, zeroLawsQC p] , let p = Proxy :: Proxy (Tup5 Int)@@ -307,18 +309,28 @@ in testGroup "All" [semiringLawsSC p, ordLawsSC p, zeroLawsSC p, starLawsSC p]- , let p = Proxy :: Proxy [WordOfSize 2]+ , let p = Proxy :: Proxy [Integer] in testGroup- "[WordOfSize 2]"- [ semiringLawsSC p- , semiringLawsQC p- , starLawsSC (Proxy :: Proxy (LimitSize 10000 (PositiveInfinite Integer)))- , starLawsQC (Proxy :: Proxy (LimitSize 10000 (PositiveInfinite Integer)))+ "[Integer]"+ [ semiringLawsQC p+ , starLawsQC+ (Proxy :: Proxy (LimitSize 100 (PositiveInfinite Integer))) , QC.testProperty "reference implementation of <.>" (\xs ys -> Polynomial (xs <.> ys) ===- Polynomial (refListMul xs (ys :: [WordOfSize 2])))]+ Polynomial+ (refListMul xs (ys :: [WordOfSize 2])))]+ , let p = Proxy :: Proxy (Vector.Vector Int)+ in testGroup+ "Vector Int"+ [ semiringLawsQC p+ , QC.testProperty+ "reference implementation of <.>"+ (\xs ys ->+ (xs <.> ys :: [Int]) ===+ Vector.toList+ (Vector.fromList xs <.> Vector.fromList ys))] , let p = Proxy :: Proxy (Min (PositiveInfinite Integer)) in testGroup "Min Inf Integer" [semiringLawsSC p, zeroLawsSC p] , let p = Proxy :: Proxy (Min (Infinite Integer))@@ -340,11 +352,7 @@ "Łukasiewicz Fraction" [semiringLawsSC p, zeroLawsSC p] , let p = Proxy :: Proxy (Viterbi Fraction)- in testGroup "Viterbi Fraction" [semiringLawsSC p, zeroLawsSC p]]-- , let p = Proxy :: Proxy (Log (Approx Double))- -- in testGroup- -- "Log (Approx Double)"- -- [semiringLawsQC p, zeroLawsQC p]]-+ in testGroup "Viterbi Fraction" [semiringLawsSC p, zeroLawsSC p]] ------------------------------------------------------------------------ -- Serial wrappers@@ -567,6 +575,10 @@ instance Arbitrary a => Arbitrary (Infinite a) where arbitrary = fmap (either (bool Positive Negative) Finite) arbitrary++instance Arbitrary a => Arbitrary (Vector.Vector a) where+ arbitrary = fmap Vector.fromList arbitrary+ shrink = fmap Vector.fromList . shrink . Vector.toList instance Testable (Either String String) where property = either (`counterexample` False) (const (property True))