semiring-num 0.5.4.0 → 0.6.0.0
raw patch · 4 files changed
+189/−77 lines, 4 files
Files
- semiring-num.cabal +1/−1
- src/Data/Semiring.hs +32/−6
- src/Data/Semiring/Numeric.hs +63/−6
- test/Spec.hs +93/−64
semiring-num.cabal view
@@ -1,5 +1,5 @@ name: semiring-num-version: 0.5.4.0+version: 0.6.0.0 synopsis: Basic semiring class and instances description: Adds a basic semiring class homepage: https://github.com/oisdk/semiring-num
src/Data/Semiring.hs view
@@ -53,7 +53,10 @@ import Data.Coerce (coerce) import GHC.Generics (Generic, Generic1) +import Data.Typeable (Typeable) +import Foreign.Storable (Storable)+ -- | A <https://en.wikipedia.org/wiki/Semiring Semiring> is like the -- the combination of two 'Data.Monoid.Monoid's. The first -- is called '<+>'; it has the identity element 'zero', and it is@@ -153,14 +156,14 @@ newtype Add a = Add { getAdd :: a } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num- ,Enum)+ ,Enum, Typeable, Storable, Fractional, Real, RealFrac) -- | Monoid under '<.>'. Analogous to 'Data.Monoid.Product', but uses the -- 'Semiring' constraint, rather than 'Num'. newtype Mul a = Mul { getMul :: a } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num- ,Enum)+ ,Enum, Typeable, Storable, Fractional, Real, RealFrac) instance Functor Add where fmap = coerce @@ -281,8 +284,10 @@ -- to represent it follows the law. newtype Min a = Min { getMin :: Maybe a- } deriving (Eq, Ord, Read, Show, Generic, Generic1, Functor- ,Foldable)+ } deriving (Eq, Read, Show, Generic, Generic1, Functor, Foldable+ ,Typeable)+ -- } deriving (Eq, Ord, Read, Show, Generic, Generic1, Functor+ -- ,Foldable) -- | The "<https://ncatlab.org/nlab/show/max-plus+algebra Arctic>" -- or max-plus semiring. It is a semiring where:@@ -301,9 +306,22 @@ -- to represent it follows the law. newtype Max a = Max { getMax :: Maybe a- } deriving (Eq, Ord, Read, Show, Generic, Generic1, Functor- ,Foldable)+ } deriving (Eq, Read, Show, Generic, Generic1, Functor, Foldable+ ,Typeable) +instance Ord a => Ord (Min a) where+ compare (Min Nothing) (Min Nothing) = EQ+ compare (Min Nothing) _ = LT+ compare _ (Min Nothing) = GT+ compare (Min (Just x)) (Min (Just y)) = compare x y++instance Ord a => Ord (Max a) where+ compare (Max Nothing) (Max Nothing) = EQ+ compare (Max Nothing) _ = GT+ compare _ (Max Nothing) = LT+ compare (Max (Just x)) (Max (Just y)) = compare x y++ instance Applicative Max where pure = (coerce :: (a -> Maybe a) -> (a -> Max a)) Just (<*>) = (coerce :: (Maybe (a -> b) -> Maybe a -> Maybe b)@@ -359,6 +377,14 @@ zero = mempty (<.>) = liftA2 (<+>) one = Min (Just zero)++instance Bounded a => Bounded (Min a) where+ maxBound = Min (Just maxBound)+ minBound = Min Nothing++instance Bounded a => Bounded (Max a) where+ minBound = Max (Just minBound)+ maxBound = Max Nothing ------------------------------------------------------------------------ -- (->) instance
src/Data/Semiring/Numeric.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -13,18 +15,28 @@ , Division(..) , Łukasiewicz(..) , Viterbi(..)+ , Log(..) ) where import Data.Coerce import Data.Semiring import GHC.Generics +import Data.Typeable (Typeable)+import Foreign.Storable (Storable)+ type WrapBinary f a = (a -> a -> a) -> f a -> f a -> f a --- | '<+>' is 'max', '<.>' is 'min'+-- | Useful for some constraint problems.+--+-- @('<+>') = 'max'+--('<.>') = 'min'+--'zero' = 'minBound'+--'one' = 'maxBound'@ newtype Bottleneck a = Bottleneck { getBottleneck :: a- } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num)+ } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num+ ,Enum, Typeable, Storable, Fractional, Real, RealFrac) instance (Bounded a, Ord a) => Semiring (Bottleneck a) where (<+>) = (coerce :: WrapBinary Bottleneck a) max@@ -32,10 +44,16 @@ zero = Bottleneck minBound one = Bottleneck maxBound --- | '<+>' is 'gcd', '<.>' is 'lcm'. Positive numbers only.+-- | Positive numbers only.+--+-- @('<+>') = 'gcd'+--('<.>') = 'lcm'+--'zero' = 'zero'+--'one' = 'one'@ newtype Division a = Division { getDivision :: a- } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num)+ } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num+ ,Enum, Typeable, Storable, Fractional, Real, RealFrac) -- | Only expects positive numbers instance (Integral a, Semiring a) => Semiring (Division a) where@@ -48,9 +66,15 @@ -- has some information on this. Also -- <http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.304.6152&rep=rep1&type=pdf this> -- paper.+--+-- @('<+>') = 'max'+--x '<.>' y = 'max' 0 (x '+' y '-' 1)+--'zero' = 'zero'+--'one' = 'one'@ newtype Łukasiewicz a = Łukasiewicz { getŁukasiewicz :: a- } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num)+ } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num+ ,Enum, Typeable, Storable, Fractional, Real, RealFrac) instance (Ord a, Num a) => Semiring (Łukasiewicz a) where (<+>) = (coerce :: WrapBinary Łukasiewicz a) max@@ -62,15 +86,48 @@ -- has some information on this. Also -- <http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.304.6152&rep=rep1&type=pdf this> -- paper. Apparently used for probabilistic parsing.+--+-- @('<+>') = 'max'+--('<.>') = ('<.>')+--'zero' = 'zero'+--'one' = 'one'@ newtype Viterbi a = Viterbi { getViterbi :: a- } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num)+ } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num+ ,Enum, Typeable, Storable, Fractional, Real, RealFrac) instance (Ord a, Semiring a) => Semiring (Viterbi a) where (<+>) = (coerce :: WrapBinary Viterbi a) max (<.>) = (coerce :: WrapBinary Viterbi a) (<.>) zero = Viterbi zero one = Viterbi one++-- | Useful for optimizing multiplication, or working with large numbers.+--+-- @('<.>') = ('+')+--x '<+>' y = -('log' ('exp' (-x) + 'exp' (-y)))+--'zero' = ∞ -- represented by 'Nothing'+--'one' = 0@+newtype Log a = Log+ { getLog :: Maybe a+ } deriving (Eq, Read, Show, Generic, Generic1, Typeable, Functor+ ,Foldable, Applicative, Monad)++instance (Semiring a, Floating a) => Semiring (Log a) where+ zero = Log Nothing+ one = Log (Just zero)+ Log (Just x) <.> Log (Just y) = Log (Just (x + y))+ _ <.> _ = Log Nothing+ Log Nothing <+> y = y+ x <+> Log Nothing = x+ Log (Just x) <+> Log (Just y)+ = Log (Just (-(log (exp (-x) + exp (-y)))))++instance Ord a => Ord (Log a) where+ compare (Log Nothing) (Log Nothing) = EQ+ compare (Log Nothing) _ = LT+ compare _ (Log Nothing) = GT+ compare (Log (Just x)) (Log (Just y)) = compare x y ------------------------------------------------------------------------ -- Boring instances
test/Spec.hs view
@@ -2,14 +2,15 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-} module Main (main) where import Control.Applicative import Control.Arrow (first)-import Data.Bits ((.&.)) import Data.Foldable-import Data.Function (on) import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap import qualified Data.Map.Strict as Map@@ -18,11 +19,13 @@ import Data.Semiring.Free import Data.Semiring.Numeric import qualified Data.Set as Set-import Data.Word (Word8) import Test.DocTest import Test.Semiring import Test.SmallCheck import Test.SmallCheck.Series+import GHC.TypeLits+import Data.Function+import Data.Bits ------------------------------------------------------------------------ @@ -33,25 +36,25 @@ smallCheck 100 (binaryLaws :: BinaryLaws Integer) smallCheck 10 (ternaryLaws :: TernaryLaws Integer) - putStrLn "Word2"- smallCheck 16 (unaryLaws :: UnaryLaws Word2)- smallCheck 16 (binaryLaws :: BinaryLaws Word2)- smallCheck 16 (ternaryLaws :: TernaryLaws Word2)+ putStrLn "(WordN 2)"+ smallCheck 16 (unaryLaws :: UnaryLaws (WordN 2))+ smallCheck 16 (binaryLaws :: BinaryLaws (WordN 2))+ smallCheck 16 (ternaryLaws :: TernaryLaws (WordN 2)) - putStrLn "(Word2,Word2)"- smallCheck 16 (unaryLaws :: UnaryLaws (Word2,Word2))- smallCheck 14 (binaryLaws :: BinaryLaws (Word2,Word2))- smallCheck 8 (ternaryLaws :: TernaryLaws (Word2,Word2))+ putStrLn "(WordN 2,WordN 2)"+ smallCheck 16 (unaryLaws :: UnaryLaws (WordN 2,WordN 2))+ smallCheck 14 (binaryLaws :: BinaryLaws (WordN 2,WordN 2))+ smallCheck 8 (ternaryLaws :: TernaryLaws (WordN 2,WordN 2)) - putStrLn "(Word2,Word2,Word2)"- smallCheck 10 (unaryLaws :: UnaryLaws (Word2,Word2,Word2))- smallCheck 5 (binaryLaws :: BinaryLaws (Word2,Word2,Word2))- smallCheck 2 (ternaryLaws :: TernaryLaws (Word2,Word2,Word2))+ putStrLn "(WordN 2,WordN 2,WordN 2)"+ smallCheck 10 (unaryLaws :: UnaryLaws (WordN 2,WordN 2,WordN 2))+ smallCheck 5 (binaryLaws :: BinaryLaws (WordN 2,WordN 2,WordN 2))+ smallCheck 2 (ternaryLaws :: TernaryLaws (WordN 2,WordN 2,WordN 2)) - putStrLn "(Word2,Word2,Word2,Word2)"- smallCheck 8 (unaryLaws :: UnaryLaws (Word2,Word2,Word2,Word2))- smallCheck 4 (binaryLaws :: BinaryLaws (Word2,Word2,Word2,Word2))- smallCheck 1 (ternaryLaws :: TernaryLaws (Word2,Word2,Word2,Word2))+ putStrLn "(WordN 2,WordN 2,WordN 2,WordN 2)"+ smallCheck 8 (unaryLaws :: UnaryLaws (WordN 2,WordN 2,WordN 2,WordN 2))+ smallCheck 4 (binaryLaws :: BinaryLaws (WordN 2,WordN 2,WordN 2,WordN 2))+ smallCheck 1 (ternaryLaws :: TernaryLaws (WordN 2,WordN 2,WordN 2,WordN 2)) putStrLn "Int" smallCheck 1000 (unaryLaws :: UnaryLaws Int)@@ -78,15 +81,15 @@ smallCheck 4 (binLawsOn All :: BinaryLaws Bool) smallCheck 8 (ternLawsOn All :: TernaryLaws Bool) - putStrLn "[Word2]"- smallCheck 5 (unaryLaws :: UnaryLaws [Word2])- smallCheck 4 (binaryLaws :: BinaryLaws [Word2])- smallCheck 3 (ternaryLaws :: TernaryLaws [Word2])+ putStrLn "[WordN 2]"+ smallCheck 5 (unaryLaws :: UnaryLaws [WordN 2])+ smallCheck 4 (binaryLaws :: BinaryLaws [WordN 2])+ smallCheck 3 (ternaryLaws :: TernaryLaws [WordN 2]) - putStrLn "Set [Word2]"- smallCheck 4 (unLawsOn Set.fromList :: UnaryLaws [[Word2]])- smallCheck 3 (binLawsOn Set.fromList :: BinaryLaws [[Word2]])- smallCheck 3 (ternLawsOn Set.fromList :: TernaryLaws [[Word2]])+ putStrLn "Set [WordN 2]"+ smallCheck 4 (unLawsOn Set.fromList :: UnaryLaws [[WordN 2]])+ smallCheck 3 (binLawsOn Set.fromList :: BinaryLaws [[WordN 2]])+ smallCheck 3 (ternLawsOn Set.fromList :: TernaryLaws [[WordN 2]]) putStrLn "Min Integer" smallCheck 1000 (unLawsOn Min :: UnaryLaws (Maybe Integer))@@ -98,15 +101,15 @@ smallCheck 100 (binLawsOn Max :: BinaryLaws (Maybe Integer)) smallCheck 10 (ternLawsOn Max :: TernaryLaws (Maybe Integer)) - putStrLn "Free Word2"- smallCheck 4 (unLawsOn Free :: UnaryLaws [[Word2]])- smallCheck 3 (binLawsOn Free :: BinaryLaws [[Word2]])- smallCheck 3 (ternLawsOn Free :: TernaryLaws [[Word2]])+ putStrLn "Free (WordN 2)"+ smallCheck 4 (unLawsOn Free :: UnaryLaws [[WordN 2]])+ smallCheck 3 (binLawsOn Free :: BinaryLaws [[WordN 2]])+ smallCheck 3 (ternLawsOn Free :: TernaryLaws [[WordN 2]]) - putStrLn "Bottleneck Word2"- smallCheck 1000 (unLawsOn Bottleneck :: UnaryLaws Word2)- smallCheck 100 (binLawsOn Bottleneck :: BinaryLaws Word2)- smallCheck 10 (ternLawsOn Bottleneck :: TernaryLaws Word2)+ putStrLn "Bottleneck (WordN 2)"+ smallCheck 1000 (unLawsOn Bottleneck :: UnaryLaws (WordN 2))+ smallCheck 100 (binLawsOn Bottleneck :: BinaryLaws (WordN 2))+ smallCheck 10 (ternLawsOn Bottleneck :: TernaryLaws (WordN 2)) putStrLn "Division Integer" smallCheck 1000 (unLawsOn (Division . getPositive) :: UnaryLaws (Positive Integer))@@ -114,15 +117,20 @@ smallCheck 10 (ternLawsOn (Division . getPositive) :: TernaryLaws (Positive Integer)) putStrLn "Łukasiewicz Double"- smallCheck 1000 (unLawsOn (Łukasiewicz . getFrac) :: UnaryLaws Fraction)- smallCheck 100 (binLawsOn (Łukasiewicz . getFrac) :: BinaryLaws Fraction)- smallCheck 10 (ternLawsOn (Łukasiewicz . getFrac) :: TernaryLaws Fraction)+ smallCheck 1000 (unLawsOn Łukasiewicz :: UnaryLaws Fraction)+ smallCheck 100 (binLawsOn Łukasiewicz :: BinaryLaws Fraction)+ smallCheck 10 (ternLawsOn Łukasiewicz :: TernaryLaws Fraction) putStrLn "Viterbi Double"- smallCheck 1000 (unLawsOn (Viterbi . getFrac) :: UnaryLaws Fraction)- smallCheck 100 (binLawsOn (Viterbi . getFrac) :: BinaryLaws Fraction)- smallCheck 10 (ternLawsOn (Viterbi . getFrac) :: TernaryLaws Fraction)+ smallCheck 1000 (unLawsOn Viterbi :: UnaryLaws Fraction)+ smallCheck 100 (binLawsOn Viterbi :: BinaryLaws Fraction)+ smallCheck 10 (ternLawsOn Viterbi :: TernaryLaws Fraction) + putStrLn "Log Double"+ smallCheck 1000 (unLawsOn Log :: UnaryLaws (Maybe Fraction))+ smallCheck 100 (binLawsOn Log :: BinaryLaws (Maybe Fraction))+ smallCheck 10 (ternLawsOn Log :: TernaryLaws (Maybe Fraction))+ putStrLn "Bool -> Bool" smallCheck 3 (unLawsOn fromFunc :: UnaryLaws (Bool -> Bool)) smallCheck 2 (binLawsOn fromFunc :: BinaryLaws (Bool -> Bool))@@ -171,8 +179,18 @@ -- Serial wrappers -- | A type with a serial instance between zero and one-newtype Fraction = Fraction { getFrac :: Double } deriving (Show, Eq, Ord)+newtype Fraction+ = Fraction Double+ deriving (Show, Num, Fractional, Real, RealFrac, Floating, RealFloat, Semiring) +instance Eq Fraction where+ Fraction x == Fraction y = abs (x-y) < 0.011++instance Ord Fraction where+ compare (Fraction x) (Fraction y)+ | Fraction x == Fraction y = EQ+ | otherwise = compare x y+ instance Monad m => Serial m Fraction where series = fmap Fraction $ generate (\d -> if d >= 0 then pure 0 else empty) <|> rest where rest = generate $ \d -> take d (1 : go 0 1)@@ -181,37 +199,48 @@ interleave (x:xs) (y:ys) = x : y : interleave xs ys interleave _ _ = undefined --- | A very small numeric type for exhaustivity-newtype Word2 = Word2 { getWord2 :: Word8 } deriving (Eq, Ord)-instance Show Word2 where show = show . getWord2+-- | A very small numeric type for exhaustiveness+newtype WordN (n :: Nat) = WordN { getWordN :: Word } deriving Show -instance Bounded Word2 where- minBound = Word2 0- maxBound = Word2 3+mask :: KnownNat n => WordN n -> Word+mask x = shift 1 (fromInteger (natVal x)) - 1 -instance Enum Word2 where- fromEnum = fromEnum . getWord2- toEnum x = Word2 (toEnum x .&. maxBound)+trunc :: KnownNat n => WordN n -> WordN n+trunc v@(WordN x) = WordN (x .&. mask v) -instance Num Word2 where- Word2 x + Word2 y = Word2 ((x + y) .&. maxBound)- Word2 x * Word2 y = Word2 ((x * y) .&. maxBound)- Word2 x - Word2 y = Word2 ((x - y) .&. maxBound)- fromInteger x = Word2 (fromInteger x .&. maxBound)+instance KnownNat n => Bounded (WordN n) where+ minBound = WordN 0+ maxBound = res where res = WordN (mask res)++instance KnownNat n => Num (WordN n) where+ WordN x + WordN y = trunc (WordN (x + y))+ WordN x * WordN y = trunc (WordN (x * y))+ WordN x - WordN y = trunc (WordN (x - y))+ fromInteger x = trunc (WordN (fromInteger x)) abs = id- signum (Word2 x) = Word2 (signum x)+ signum (WordN x) = WordN (signum x) -instance Real Word2 where- toRational = toRational . getWord2+instance KnownNat n => Eq (WordN n) where+ (==) = (==) `on` getWordN . trunc -instance Integral Word2 where- toInteger = toInteger . getWord2- quotRem (Word2 x) (Word2 y) = (Word2 (quot x y), Word2 (rem x y))+instance KnownNat n => Ord (WordN n) where+ compare = compare `on` getWordN . trunc -instance Monad m => Serial m Word2 where+instance KnownNat n => Real (WordN n) where+ toRational = toRational . getWordN++instance KnownNat n => Enum (WordN n) where+ fromEnum = fromEnum . getWordN+ toEnum = trunc . WordN . toEnum++instance KnownNat n => Integral (WordN n) where+ toInteger = toInteger . getWordN+ quotRem (WordN x) (WordN y) = (WordN (quot x y), WordN (rem x y))++instance (Monad m, KnownNat n) => Serial m (WordN n) where series = generate (`take` [minBound..maxBound]) -instance Semiring Word2+instance KnownNat n => Semiring (WordN n) ------------------------------------------------------------------------ -- Function Equality