semiring-num 1.3.0.0 → 1.4.0.0
raw patch · 5 files changed
+235/−105 lines, 5 filesdep +hashabledep +scientificdep +timePVP ok
version bump matches the API change (PVP)
Dependencies added: hashable, scientific, time, unordered-containers, vector
API changes (from Hackage documentation)
- Data.Semiring: instance Data.Semiring.Semiring a => Data.Semiring.DetectableZero [a]
- Data.Semiring: instance GHC.Base.Applicative Data.Semiring.State
- Data.Semiring: instance GHC.Base.Functor Data.Semiring.State
+ Data.Semiring: instance (Data.Hashable.Class.Hashable a, GHC.Base.Monoid a, Data.Semiring.Semiring b, GHC.Classes.Eq a) => Data.Semiring.Semiring (Data.HashMap.Base.HashMap a b)
+ Data.Semiring: instance (Data.Traversable.Traversable f, GHC.Base.Applicative f, Data.Semiring.DetectableZero a, f ~ g) => Data.Semiring.DetectableZero (Data.Semiring.Matrix f g a)
+ Data.Semiring: instance (GHC.Base.Monoid a, Data.Hashable.Class.Hashable a, GHC.Classes.Eq a) => Data.Semiring.DetectableZero (Data.HashSet.HashSet a)
+ Data.Semiring: instance (GHC.Base.Monoid a, Data.Hashable.Class.Hashable a, GHC.Classes.Eq a) => Data.Semiring.Semiring (Data.HashSet.HashSet a)
+ Data.Semiring: instance Data.Semiring.DetectableZero Data.Scientific.Scientific
+ Data.Semiring: instance Data.Semiring.DetectableZero Data.Time.Clock.Scale.DiffTime
+ Data.Semiring: instance Data.Semiring.DetectableZero Data.Time.Clock.UTC.NominalDiffTime
+ Data.Semiring: instance Data.Semiring.DetectableZero a => Data.Semiring.DetectableZero [a]
+ Data.Semiring: instance Data.Semiring.Semiring Data.Scientific.Scientific
+ Data.Semiring: instance Data.Semiring.Semiring Data.Time.Clock.Scale.DiffTime
+ Data.Semiring: instance Data.Semiring.Semiring Data.Time.Clock.UTC.NominalDiffTime
+ Data.Semiring: instance Data.Semiring.StarSemiring a => Data.Semiring.StarSemiring [a]
Files
- bench/bench.hs +11/−1
- semiring-num.cabal +6/−1
- src/Data/Semiring.hs +134/−36
- src/Test/Semiring.hs +2/−2
- test/Spec.hs +82/−65
bench/bench.hs view
@@ -11,10 +11,20 @@ threeInts :: IO (Int,Int,Int) threeInts = (,,) <$> randomIO <*> randomIO <*> randomIO +int :: IO Int+int = randomIO+ sumAtSize :: Int -> Benchmark sumAtSize n = env (replicateM n threeInts) $ \xs -> bgroup (show n) [bench "add" $ nf add xs]++prodAtSize :: Int -> Int -> Benchmark+prodAtSize n m =+ env ((,) <$> replicateM n int <*> replicateM m int) $+ \xs ->+ bench "prod-list" (nf (uncurry (<.>)) xs)+ main :: IO ()-main = defaultMain [sumAtSize 10000]+main = defaultMain [prodAtSize 2000 1000, sumAtSize 10000]
semiring-num.cabal view
@@ -1,5 +1,5 @@ name: semiring-num-version: 1.3.0.0+version: 1.4.0.0 synopsis: Basic semiring class and instances description: Adds a basic semiring class homepage: https://github.com/oisdk/semiring-num@@ -24,6 +24,11 @@ , template-haskell >= 2.11 , containers >= 0.5 , log-domain >= 0.10+ , scientific >= 0.3+ , time >= 1.6+ , unordered-containers >= 0.2+ , vector >= 0.12+ , hashable >= 1.2 default-language: Haskell2010 ghc-options: -Wall
src/Data/Semiring.hs view
@@ -7,6 +7,7 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE BangPatterns #-} {-| Module: Data.Semiring@@ -58,11 +59,16 @@ import System.Posix.Types (CCc, CDev, CGid, CIno, CMode, CNlink, COff, CPid, CRLim, CSpeed, CSsize, CTcflag, CUid, Fd)+import Data.Scientific(Scientific)+import Data.Time.Clock(DiffTime,NominalDiffTime)+ import Data.Semigroup hiding (Max(..), Min(..))+ import Data.Coerce import GHC.Generics (Generic, Generic1) import Data.Typeable (Typeable) import Foreign.Storable (Storable)+ import Data.Semiring.TH import Data.Functor.Classes import Text.Read@@ -73,12 +79,17 @@ import Data.Set (Set) import qualified Data.Set as Set +import qualified Data.HashMap.Strict as HashMap+import qualified Data.HashSet as HashSet+import Data.Hashable+ import Numeric.Log hiding (sum) import qualified Numeric.Log import Control.Monad import Control.Applicative import Data.Foldable+import Data.Traversable -- $setup -- >>> import Data.Function@@ -363,12 +374,21 @@ (x:xs) <+> (y:ys) = (x <+> y) : (xs <+> ys) [] <.> _ = [] _ <.> [] = []- (x:xs) <.> (y:ys) =- (x <.> y) : (map (x <.>) ys <+> map (<.> y) xs <+> (xs <.> ys))+ (x:xs) <.> (y:ys) = (x <.> y) : add' xs ys+ where+ add' xs' [] = map (<.> y) xs'+ add' [] ys' = map (x <.>) ys'+ add' xs' ys' =+ map (x <.>) ys' <+> map (<.> y) xs' <+> (zero : (xs' <.> ys')) -instance Semiring a =>+instance StarSemiring a => StarSemiring [a] where+ star [] = one+ star (x:xs) = r where+ r = [star x] <.> (one : (xs <.> r))++instance DetectableZero a => DetectableZero [a] where- isZero = null+ isZero = all isZero {-# INLINE isZero #-} instance (Monoid a, Ord a) =>@@ -382,6 +402,16 @@ {-# INLINE zero #-} {-# INLINE one #-} +instance (Monoid a, Hashable a, Eq a) => Semiring (HashSet.HashSet a) where+ (<+>) = HashSet.union+ zero = HashSet.empty+ one = HashSet.singleton mempty+ xs <.> ys = foldMap (flip HashSet.map ys . mappend) xs+ {-# INLINE (<+>) #-}+ {-# INLINE (<.>) #-}+ {-# INLINE zero #-}+ {-# INLINE one #-}+ instance (Ord a, Monoid a, Semiring b) => Semiring (Map a b) where one = Map.singleton mempty one@@ -398,11 +428,31 @@ , (l,u) <- Map.toList ys ] {-# INLINE (<.>) #-} +instance (Hashable a, Monoid a, Semiring b, Eq a) =>+ Semiring (HashMap.HashMap a b) where+ one = HashMap.singleton mempty one+ {-# INLINE one #-}+ zero = HashMap.empty+ {-# INLINE zero #-}+ (<+>) = HashMap.unionWith (<+>)+ {-# INLINE (<+>) #-}+ xs <.> ys =+ HashMap.fromListWith+ (<+>)+ [ (mappend k l, v <.> u)+ | (k,v) <- HashMap.toList xs+ , (l,u) <- HashMap.toList ys ]+ {-# INLINE (<.>) #-}+ instance (Monoid a, Ord a) => DetectableZero (Set a) where isZero = Set.null {-# INLINE isZero #-} +instance (Monoid a, Hashable a, Eq a) =>+ DetectableZero (HashSet.HashSet a) where+ isZero = HashSet.null+ instance (Precise a, RealFloat a) => Semiring (Log a) where (<.>) = (*) {-# INLINE (<.>) #-}@@ -420,24 +470,9 @@ {-# INLINE isZero #-} ----------------------------------------------------------------------------------- Addition and multiplication newtypes+-- Newtype utilities ---------------------------------------------------------------------------------type WrapBinary f a = (a -> a -> a) -> f a -> f a -> f a --- | Monoid under '<+>'. Analogous to 'Data.Monoid.Sum', but uses the--- 'Semiring' constraint, rather than 'Num'.-newtype Add a = Add- { getAdd :: a- } deriving (Eq,Ord,Read,Show,Bounded,Generic,Generic1,Num,Enum,Typeable- ,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable- ,Semiring,DetectableZero,StarSemiring)--instance Eq1 Add where- liftEq = coerce--instance Ord1 Add where- liftCompare = coerce- showsNewtype :: Coercible b a => String -> String -> (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> b -> ShowS showsNewtype cons acc = s where@@ -460,11 +495,34 @@ Punc "}" <- lexP pure (coerce x) +--------------------------------------------------------------------------------+-- Addition and multiplication newtypes+--------------------------------------------------------------------------------+type WrapBinary f a = (a -> a -> a) -> f a -> f a -> f a++-- | Monoid under '<+>'. Analogous to 'Data.Monoid.Sum', but uses the+-- 'Semiring' constraint, rather than 'Num'.+newtype Add a = Add+ { getAdd :: a+ } deriving (Eq,Ord,Read,Show,Bounded,Generic,Generic1,Num,Enum,Typeable+ ,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable+ ,Semiring,DetectableZero,StarSemiring)++instance Eq1 Add where+ liftEq = coerce+ {-# INLINE liftEq #-}++instance Ord1 Add where+ liftCompare = coerce+ {-# INLINE liftCompare #-}+ instance Show1 Add where liftShowsPrec = showsNewtype "Add" "getAdd"+ {-# INLINE liftShowsPrec #-} instance Read1 Add where liftReadsPrec = readsNewtype "Add" "getAdd"+ {-# INLINE liftReadsPrec #-} -- | Monoid under '<.>'. Analogous to 'Data.Monoid.Product', but uses the -- 'Semiring' constraint, rather than 'Num'.@@ -476,15 +534,19 @@ instance Eq1 Mul where liftEq = coerce+ {-# INLINE liftEq #-} instance Ord1 Mul where liftCompare = coerce+ {-# INLINE liftCompare #-} instance Show1 Mul where liftShowsPrec = showsNewtype "Mul" "getMul"+ {-# INLINE liftShowsPrec #-} instance Read1 Mul where liftReadsPrec = readsNewtype "Mul" "getMul"+ {-# INLINE liftReadsPrec #-} instance Semiring a => Semigroup (Add a) where@@ -563,16 +625,17 @@ (<.>) = mulMatrix (<+>) = liftA2 (<+>) zero = pure zero- one = case zero of- Matrix xs -> Matrix (imap (\i -> imap (\j x -> if i == j then one else x)) xs)--newtype State a = State (Int -> (a, Int)) deriving Functor+ one =+ (coerce :: (f (g a) -> f (g a)) -> Matrix f g a -> Matrix f g a)+ (imap (\i -> imap (\j z -> if i == j then o else z))) zero+ where+ imap f = snd . mapAccumL (\ !i x -> (i + 1, f i x)) (0 :: Int)+ o :: a+ o = one -instance Applicative State where- pure x = State (\i -> (x, i))- State fs <*> State xs = State (\i -> case fs i of- (f, i') -> case xs i' of- (x,i'') -> (f x, i''))+instance (Traversable f, Applicative f, DetectableZero a, f ~ g) =>+ DetectableZero (Matrix f g a) where+ isZero = all isZero -- | Transpose the matrix. transpose :: (Applicative g, Traversable f) => Matrix f g a -> Matrix g f a@@ -588,13 +651,6 @@ where c = sequenceA ys -evalState :: State a -> Int -> a-evalState (State r) i = case r i of- (x,_) -> x--imap :: Traversable t => (Int -> a -> b) -> t a -> t b-imap f xs = evalState (traverse (\x -> State (\i -> (f i x, i + 1))) xs) 0- infixr 9 #. (#.) :: Coercible b c => (b -> c) -> (a -> b) -> a -> c (#.) _ = coerce@@ -1027,6 +1083,36 @@ {-# INLINE (<+>) #-} {-# INLINE (<.>) #-} +instance Semiring Scientific where+ one = 1+ zero = 0+ (<+>) = (+)+ (<.>) = (*)+ {-# INLINE zero #-}+ {-# INLINE one #-}+ {-# INLINE (<+>) #-}+ {-# INLINE (<.>) #-}++instance Semiring DiffTime where+ one = 1+ zero = 0+ (<+>) = (+)+ (<.>) = (*)+ {-# INLINE zero #-}+ {-# INLINE one #-}+ {-# INLINE (<+>) #-}+ {-# INLINE (<.>) #-}++instance Semiring NominalDiffTime where+ one = 1+ zero = 0+ (<+>) = (+)+ (<.>) = (*)+ {-# INLINE zero #-}+ {-# INLINE one #-}+ {-# INLINE (<+>) #-}+ {-# INLINE (<.>) #-}+ instance Semiring CUIntMax where one = 1 zero = 0@@ -1559,6 +1645,18 @@ {-# INLINE isZero #-} instance DetectableZero Double where+ isZero = isZeroEq+ {-# INLINE isZero #-}++instance DetectableZero Scientific where+ isZero = isZeroEq+ {-# INLINE isZero #-}++instance DetectableZero DiffTime where+ isZero = isZeroEq+ {-# INLINE isZero #-}++instance DetectableZero NominalDiffTime where isZero = isZeroEq {-# INLINE isZero #-}
src/Test/Semiring.hs view
@@ -160,7 +160,7 @@ rp = x <.> r s = unlines- [ "<+> is " +++ [ "<.> is " ++ (if res then "" else "not ") ++@@ -309,7 +309,7 @@ (if res then "" else " not") ++- " the identity of <+>."+ " the identity of <.>." , " Law:" , " x <.> one = one <.> x = x" , " x = " ++ show x
test/Spec.hs view
@@ -9,6 +9,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE KindSignatures #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main (main) where@@ -16,6 +17,7 @@ import Control.Applicative import Control.Arrow (first)+import Data.Function import Data.Bool import Data.Proxy @@ -115,6 +117,44 @@ type Tup8 a = (a,a,a,a,a,a,a,a) type Tup9 a = (a,a,a,a,a,a,a,a,a) +refListMul+ :: Semiring a+ => [a] -> [a] -> [a]+refListMul [] _ = []+refListMul _ [] = []+refListMul (x:xs) (y:ys) =+ (x <.> y) :+ (map (x <.>) ys <+> map (<.> y) xs <+> (zero : refListMul xs ys))++newtype Polynomial a =+ Polynomial [a]+ deriving (Show,Arbitrary,Semiring,DetectableZero)++instance (Monad m, Serial m a) => Serial m (Polynomial a) where+ series = fmap Polynomial series++instance (DetectableZero a, Eq a) => Eq (Polynomial a) where+ Polynomial xs' == Polynomial ys' = go xs' ys' where+ go [] ys = isZero ys+ go xs [] = isZero xs+ go (x:xs) (y:ys) = x == y && go xs ys++newtype LimitSize (n :: Nat) a =+ LimitSize [a]+ deriving (Arbitrary,Semiring,DetectableZero,StarSemiring)++takeFirst :: KnownNat n => LimitSize n a -> [a]+takeFirst (LimitSize xs :: LimitSize n a) = take (fromInteger (natVal (Proxy :: Proxy n))) xs++instance (Monad m, Serial m a) => Serial m (LimitSize n a) where+ series = fmap LimitSize series++instance (Eq a, KnownNat n) => Eq (LimitSize n a) where+ (==) = (==) `on` takeFirst++instance (Show a, KnownNat n) => Show (LimitSize n a) where+ showsPrec n = showsPrec n . takeFirst+ main :: IO () main = do doctest ["-isrc", "src/"]@@ -122,7 +162,9 @@ testGroup "Tests" [ let p = Proxy :: Proxy (Map String Int)- in testGroup "Map" [localOption (QC.QuickCheckMaxSize 10) $ semiringLawsQC p]+ in testGroup+ "Map"+ [localOption (QC.QuickCheckMaxSize 10) $ semiringLawsQC p] , let p = Proxy :: Proxy (Matrix Quad Quad Integer) in testGroup "Matrix" [semiringLawsQC p] , let p = Proxy :: Proxy Integer@@ -130,9 +172,9 @@ "Integer" [semiringLawsSC p, ordLawsSC p, zeroLawsSC p] , let p = Proxy :: Proxy (Func Bool Bool)- in testGroup "Bool -> Bool"- [semiringLawsQC p]- , testGroup "Endo Bool"+ in testGroup "Bool -> Bool" [semiringLawsQC p]+ , testGroup+ "Endo Bool" [ QC.testProperty "plusId" (plusId :: UnaryLaws (EndoFunc (Add Bool)))@@ -162,9 +204,7 @@ , let p = Proxy :: Proxy Int in testGroup "Int" [semiringLawsSC p, ordLawsSC p, zeroLawsSC p] , let p = Proxy :: Proxy (WordOfSize 2)- in testGroup- "WordOfSize 2"- [semiringLawsSC p, zeroLawsSC p]+ in testGroup "WordOfSize 2" [semiringLawsSC p, zeroLawsSC p] , let p = Proxy :: Proxy (Tup2 (WordOfSize 2)) in testGroup "Tup2 (WordOfSize 2)"@@ -174,61 +214,33 @@ "Tup3 (WordOfSize 2)" [semiringLawsSC p, zeroLawsSC p] , let p = Proxy :: Proxy (Tup4 Int)- in testGroup- "Tup4 Int"- [semiringLawsQC p, zeroLawsQC p]+ in testGroup "Tup4 Int" [semiringLawsQC p, zeroLawsQC p] , let p = Proxy :: Proxy (Tup5 Int)- in testGroup- "Tup5 Int"- [semiringLawsQC p, zeroLawsQC p]+ in testGroup "Tup5 Int" [semiringLawsQC p, zeroLawsQC p] , let p = Proxy :: Proxy (Tup6 Int)- in testGroup- "Tup6 Int"- [semiringLawsQC p, zeroLawsQC p]+ in testGroup "Tup6 Int" [semiringLawsQC p, zeroLawsQC p] , let p = Proxy :: Proxy (Tup7 Int)- in testGroup- "Tup7 Int"- [semiringLawsQC p, zeroLawsQC p]+ in testGroup "Tup7 Int" [semiringLawsQC p, zeroLawsQC p] , let p = Proxy :: Proxy (Tup8 Int)- in testGroup- "Tup8 Int"- [semiringLawsQC p, zeroLawsQC p]+ in testGroup "Tup8 Int" [semiringLawsQC p, zeroLawsQC p] , let p = Proxy :: Proxy (Tup9 Int)- in testGroup- "Tup9 Int"- [semiringLawsQC p, zeroLawsQC p]+ in testGroup "Tup9 Int" [semiringLawsQC p, zeroLawsQC p] , let p = Proxy :: Proxy (Tup2 (PositiveInfinite (WordOfSize 2)))- in testGroup- "Tup2 (WordOfSize 2)"- [starLawsSC p]+ in testGroup "Tup2 (WordOfSize 2)" [starLawsSC p] , let p = Proxy :: Proxy (Tup3 (PositiveInfinite (WordOfSize 2)))- in testGroup- "Tup3 (WordOfSize 2)"- [starLawsSC p]+ in testGroup "Tup3 (WordOfSize 2)" [starLawsSC p] , let p = Proxy :: Proxy (Tup4 (PositiveInfinite Int))- in testGroup- "Tup4 Int"- [starLawsQC p]+ in testGroup "Tup4 Int" [starLawsQC p] , let p = Proxy :: Proxy (Tup5 (PositiveInfinite Int))- in testGroup- "Tup5 Int"- [starLawsQC p]+ in testGroup "Tup5 Int" [starLawsQC p] , let p = Proxy :: Proxy (Tup6 (PositiveInfinite Int))- in testGroup- "Tup6 Int"- [starLawsQC p]+ in testGroup "Tup6 Int" [starLawsQC p] , let p = Proxy :: Proxy (Tup7 (PositiveInfinite Int))- in testGroup- "Tup7 Int"- [starLawsQC p]+ in testGroup "Tup7 Int" [starLawsQC p] , let p = Proxy :: Proxy (Tup8 (PositiveInfinite Int))- in testGroup- "Tup8 Int"- [starLawsQC p]+ in testGroup "Tup8 Int" [starLawsQC p] , let p = Proxy :: Proxy (Tup9 (PositiveInfinite Int))- in testGroup- "Tup9 Int"- [starLawsQC p]+ in testGroup "Tup9 Int" [starLawsQC p] , testGroup "Negative Infinite Integer" [ SC.testProperty@@ -296,25 +308,31 @@ "All" [semiringLawsSC p, ordLawsSC p, zeroLawsSC p, starLawsSC p] , let p = Proxy :: Proxy [WordOfSize 2]- in testGroup "[WordOfSize 2]" [semiringLawsSC p, zeroLawsSC p]- , let p = Proxy :: Proxy (Min (PositiveInfinite Integer)) in testGroup- "Min Inf Integer"- [semiringLawsSC p, zeroLawsSC p]+ "[WordOfSize 2]"+ [ semiringLawsSC p+ , semiringLawsQC p+ , starLawsSC (Proxy :: Proxy (LimitSize 10000 (PositiveInfinite Integer)))+ , starLawsQC (Proxy :: Proxy (LimitSize 10000 (PositiveInfinite Integer)))+ , QC.testProperty+ "reference implementation of <.>"+ (\xs ys ->+ Polynomial (xs <.> ys) ===+ Polynomial (refListMul xs (ys :: [WordOfSize 2])))]+ , let p = Proxy :: Proxy (Min (PositiveInfinite Integer))+ in testGroup "Min Inf Integer" [semiringLawsSC p, zeroLawsSC p] , let p = Proxy :: Proxy (Min (Infinite Integer))- in testGroup- "Min Inf Integer"- [starLawsSC p]+ in testGroup "Min Inf Integer" [starLawsSC p] , let p = Proxy :: Proxy (Max (NegativeInfinite Integer)) in testGroup "Max NegInf Integer" [semiringLawsSC p, zeroLawsSC p] , let p = Proxy :: Proxy (Max (Infinite Integer))- in testGroup- "Max Inf Integer"- [starLawsSC p]+ in testGroup "Max Inf Integer" [starLawsSC p] , let p = Proxy :: Proxy (Free (WordOfSize 2))- in testGroup "Free (WordOfSize 2)" [localOption (QC.QuickCheckMaxSize 10) $ semiringLawsQC p]+ in testGroup+ "Free (WordOfSize 2)"+ [localOption (QC.QuickCheckMaxSize 10) $ semiringLawsQC p] , let p = Proxy :: Proxy (Division (SC.Positive Integer)) in testGroup "Division Integer" [semiringLawsSC p, zeroLawsSC p] , let p = Proxy :: Proxy (Łukasiewicz Fraction)@@ -322,11 +340,10 @@ "Ł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]]-- , let p = Proxy :: Proxy (Log (Approx Double))+ -- in testGroup+ -- "Log (Approx Double)"+ -- [semiringLawsQC p, zeroLawsQC p]] ------------------------------------------------------------------------