diff --git a/semiring-num.cabal b/semiring-num.cabal --- a/semiring-num.cabal +++ b/semiring-num.cabal @@ -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 diff --git a/src/Data/Semiring.hs b/src/Data/Semiring.hs --- a/src/Data/Semiring.hs +++ b/src/Data/Semiring.hs @@ -53,7 +53,10 @@ import Data.Coerce (coerce) import GHC.Generics (Generic, Generic1) +import Data.Typeable (Typeable) +import Foreign.Storable (Storable) + -- | A 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 "" -- 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 diff --git a/src/Data/Semiring/Numeric.hs b/src/Data/Semiring/Numeric.hs --- a/src/Data/Semiring/Numeric.hs +++ b/src/Data/Semiring/Numeric.hs @@ -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 -- -- 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 -- -- 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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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