packages feed

semiring-num 0.1.0.6 → 0.2.0.0

raw patch · 4 files changed

+178/−85 lines, 4 files

Files

semiring-num.cabal view
@@ -1,5 +1,5 @@ name:                semiring-num-version:             0.1.0.6+version:             0.2.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
@@ -15,16 +15,14 @@   ( Semiring(..)   , Add(..)   , Mul(..)+  , Max(..)+  , Min(..)   ) where -import           Data.Coerce           (coerce)  import           Data.Functor.Const    (Const (..)) import           Data.Functor.Identity (Identity (..)) -import           Data.Monoid-import           Data.Semigroup        (Max (..), Min (..))- import           Data.Complex          (Complex) import           Data.Fixed            (Fixed, HasResolution) import           Data.Ratio            (Ratio)@@ -47,8 +45,11 @@                                         COff, CPid, CRLim, CSpeed, CSsize,                                         CTcflag, CUid, Fd) -import           GHC.Generics          (Generic, Generic1)+import           Data.Monoid +import           Control.Applicative   (liftA2)+import           Data.Coerce           (coerce)+import           GHC.Generics          (Generic, Generic1) import           Test.QuickCheck       (Arbitrary)  -- | A <https://en.wikipedia.org/wiki/Semiring Semiring> is like the@@ -149,54 +150,54 @@ newtype Add a = Add   { getAdd :: a   } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num-             ,Arbitrary)+             ,Arbitrary, Enum)  -- | 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-             ,Arbitrary)+             ,Arbitrary, Enum)  instance Functor Add where fmap = coerce  instance Functor Mul where fmap = coerce  instance Foldable Add where-  foldr   =-    (coerce :: ((a -> b -> c) -> (b -> a -> c))-            -> (a -> b -> c)-            -> (b -> Add a -> c)) flip-  foldl   = coerce+  foldr =+    (coerce :: ((a -> b -> c) -> (b ->     a -> c))+            ->  (a -> b -> c) -> (b -> Add a -> c)+    ) flip+  foldl = coerce   foldMap = coerce-  length  = const 1+  length = const 1  instance Foldable Mul where-  foldr   =-    (coerce :: ((a -> b -> c) -> (b -> a -> c))-            -> (a -> b -> c)-            -> (b -> Mul a -> c)) flip-  foldl   = coerce+  foldr =+    (coerce :: ((a -> b -> c) -> (b ->     a -> c))+            ->  (a -> b -> c) -> (b -> Mul a -> c)+    ) flip+  foldl = coerce   foldMap = coerce-  length  = const 1+  length = const 1  instance Applicative Add where   pure = coerce   (<*>) =-    (coerce :: ((a -> b) -> a -> b)-            -> (Add (a -> b) -> Add a -> Add b)) ($)+    (coerce :: (    (a -> b) ->     a ->     b)+            -> (Add (a -> b) -> Add a -> Add b)+    ) ($)  instance Applicative Mul where   pure = coerce   (<*>) =-    (coerce :: ((a -> b) -> a -> b)-            -> (Mul (a -> b) -> Mul a -> Mul b)) ($)+    (coerce :: (    (a -> b) ->     a ->     b)+            -> (Mul (a -> b) -> Mul a -> Mul b)+    ) ($) -instance Monad Add where-  (>>=) = flip coerce+instance Monad Add where (>>=) = flip coerce -instance Monad Mul where-  (>>=) = flip coerce+instance Monad Mul where (>>=) = flip coerce  instance Semiring a => Monoid (Add a) where   mempty = Add zero@@ -222,21 +223,74 @@ -- Ord wrappers ------------------------------------------------------------------------ --- | The 'Semiring' for 'Max' uses the 'max' operation for '<+>', and--- normal '+' for '<.>'.-instance (Ord a, Bounded a, Semiring a) => Semiring (Max a) where++-- | The "<https://ncatlab.org/nlab/show/tropical+semiring Tropical>" or+-- min-plus semiring. It is a semiring where:+-- @'<+>'  = 'min'@+-- @'zero' = -∞@ (represented by 'Nothing')+-- @'<.>'  = '<+>'@ (over the inner value)+-- @'one'  = 'zero'@ (over the inner value)+newtype Min a = Min+  { getMin :: Maybe a+  } deriving (Eq, Ord, Read, Show, Generic, Generic1, Arbitrary, Functor+             ,Foldable)++-- | The "<https://ncatlab.org/nlab/show/https://ncatlab.org/nlab/show/max-plus+algebra Arctic>"+-- or max-plus semiring. It is a semiring where:+-- @'<+>'  = 'max'@+-- @'zero' = ∞@ (represented by 'Nothing')+-- @'<.>'  = '<+>'@ (over the inner value)+-- @'one'  = 'zero'@ (over the inner value)+newtype Max a = Max+  { getMax :: Maybe a+  } deriving (Eq, Ord, Read, Show, Generic, Generic1, Arbitrary, Functor+             ,Foldable)++instance Applicative Max where+  pure = (coerce :: (a -> Maybe a) -> (a -> Max a)) Just+  (<*>) = (coerce :: (Maybe (a -> b) -> Maybe a -> Maybe b)+                  ->  Max   (a -> b) -> Max   a -> Max   b+          ) (<*>)++instance Applicative Min where+  pure = (coerce :: (a -> Maybe a) -> (a -> Min a)) Just+  (<*>) = (coerce :: (Maybe (a -> b) -> Maybe a -> Maybe b)+                  ->  Min   (a -> b) -> Min   a -> Min   b+          ) (<*>)++instance Monad Max where+  (>>=) = (coerce :: (Maybe a -> (a -> Maybe b) -> Maybe b)+                  ->  Max   a -> (a -> Max   b) -> Max   b+          ) (>>=)++instance Monad Min where+  (>>=) = (coerce :: (Maybe a -> (a -> Maybe b) -> Maybe b)+                  ->  Min   a -> (a -> Min   b) -> Min   b+          ) (>>=)++instance Ord a => Monoid (Max a) where+  mempty = Max Nothing+  Max Nothing `mappend` x = x+  x `mappend` Max Nothing = x+  Max (Just x) `mappend` Max (Just y) = (Max . Just) (min x y)++instance Ord a => Monoid (Min a) where+  mempty = Min Nothing+  Min Nothing `mappend` x = x+  x `mappend` Min Nothing = x+  Min (Just x) `mappend` Min (Just y) = (Min . Just) (min x y)++instance (Semiring a, Ord a) => Semiring (Max a) where   (<+>) = mappend   zero = mempty-  (<.>) = (coerce :: WrapBinary Max a) (<+>)-  one = Max zero+  (<.>) = liftA2 (<+>)+  one = Max (Just zero) --- | The 'Semiring' for 'Min' uses the 'min' operation for '<+>', and--- normal '+' for '<.>'.-instance (Ord a, Bounded a, Semiring a) => Semiring (Min a) where+instance (Semiring a, Ord a) => Semiring (Min a) where   (<+>) = mappend   zero = mempty-  (<.>) = (coerce :: WrapBinary Min a) (<+>)-  one = Min zero+  (<.>) = liftA2 (<+>)+  one = Min (Just zero)  ------------------------------------------------------------------------ -- (->) instance@@ -248,19 +302,6 @@   one = const one   (f <+> g) x = f x <+> g x   (f <.> g) x = f x <.> g x----------------------------------------------------------------------------- Endo instance----------------------------------------------------------------------------- | The 'Endo' semiring uses function composition for '<.>', and--- pointwise 'mappend' for '<+>'. The underlying 'Monoid' needs to be--- commutative.-instance Monoid a => Semiring (Endo a) where-  (<.>) = mappend-  one = mempty-  Endo f <+> Endo g = Endo (\x -> f x `mappend` g x)-  zero = Endo (const mempty)  ------------------------------------------------------------------------ -- Instances for Bool wrappers
src/Test/Semiring.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE ScopedTypeVariables #-}- {-| Module: Test.Semiring Description: Some QuickCheck properties for Semirings@@ -18,12 +16,11 @@   , mulId   , annihilate   , semiringLaws+  , Laws   ) where -import           Data.Proxy import           Data.Semiring   (Semiring (..))-import           Test.QuickCheck (Arbitrary, Property, conjoin, counterexample,-                                  property)+import           Test.QuickCheck (Property, conjoin, counterexample)  -- | Plus is associative. plusAssoc :: (Eq a, Semiring a, Show a) => a -> a -> a -> Property@@ -126,13 +123,15 @@     , "zero <.> x = " ++ show r ]  -- | A property for all laws of 'Semiring'.-semiringLaws :: (Eq a, Semiring a, Show a, Arbitrary a) => Proxy a -> Property-semiringLaws (_ :: Proxy a) = conjoin-  [ property (plusAssoc   :: a -> a -> a -> Property)-  , property (mulAssoc    :: a -> a -> a -> Property)-  , property (plusComm    ::      a -> a -> Property)-  , property (mulDistribL :: a -> a -> a -> Property)-  , property (mulDistribR :: a -> a -> a -> Property)-  , property (plusId      ::           a -> Property)-  , property (mulId       ::           a -> Property)-  , property (annihilate  ::           a -> Property)]+semiringLaws :: (Eq a, Semiring a, Show a) => a -> a -> a -> Property+semiringLaws x y z = conjoin+  [ plusAssoc   x y z+  , mulAssoc    x y z+  , plusComm    x y+  , mulDistribL x y z+  , mulDistribR x y z+  , plusId      x+  , mulId       x+  , annihilate  x ]++type Laws a = a -> a -> a -> Property
test/Spec.hs view
@@ -1,9 +1,10 @@-{-# LANGUAGE TypeApplications #-}- module Main (main) where -import           Data.Proxy            (Proxy (..))-import           Data.Semiring         (Add, Mul)+import           Control.Applicative   (liftA2)+import           Data.Foldable+import qualified Data.Map.Strict       as Map+import           Data.Monoid+import           Data.Semiring import           Data.Semiring.Free import           Data.Semiring.Numeric import           Data.Set              (Set)@@ -15,25 +16,77 @@ smallCheck :: Testable prop => prop -> IO () smallCheck = quickCheckWith (stdArgs { maxSuccess = 40, maxSize = 30}) +instance (Enum a, Bounded a, Ord a, Ord b, Semiring b) => Semiring (Func a b) where+  zero = fromFunc zero+  one = fromFunc one+  f <+> g = fromFunc (apply f <+> apply g)+  f <.> g = fromFunc (apply f <.> apply g)++ main :: IO () main = do-  smallCheck (semiringLaws (Proxy :: Proxy (Free Word8)))-  quickCheck (semiringLaws (Proxy :: Proxy [Integer]))-  quickCheck (semiringLaws (Proxy :: Proxy Integer))-  quickCheck (semiringLaws (Proxy :: Proxy Bool))-  quickCheck (semiringLaws (Proxy :: Proxy (Add Integer)))-  quickCheck (semiringLaws (Proxy :: Proxy (Mul Integer)))-  quickCheck (semiringLaws (Proxy :: Proxy (Integer,Integer)))-  quickCheck (semiringLaws (Proxy :: Proxy (Integer,Integer,Integer)))-  quickCheck (semiringLaws (Proxy :: Proxy (Integer,Integer,Integer,Integer)))-  quickCheck (semiringLaws (Proxy :: Proxy (Integer,Integer,Integer,Integer,Integer)))-  quickCheck (semiringLaws (Proxy :: Proxy (Set (Add Word8)) ))-  quickCheck (semiringLaws (Proxy :: Proxy (Division Integer)))-  quickCheck (semiringLaws (Proxy :: Proxy (Bottleneck Int)))-  quickCheck (semiringLaws (Proxy :: Proxy (Łukasiewicz Integer)))-  quickCheck (semiringLaws (Proxy :: Proxy (Viterbi Integer)))+  quickCheck (semiringLaws :: Laws (Func Word8 Word8))+  quickCheck (semiringLaws :: Laws ())+  quickCheck (semiringLaws :: Laws Bool)+  quickCheck (forAll arbitrary (\(x,y,z) -> semiringLaws (Any x) (Any y) (Any z)))+  quickCheck (forAll arbitrary (\(x,y,z) -> semiringLaws (All x) (All y) (All z)))+  quickCheck (semiringLaws :: Laws ())+  quickCheck (semiringLaws :: Laws Integer)+  smallCheck (semiringLaws :: Laws (Set (Add Integer)))+  smallCheck (semiringLaws :: Laws [Integer])+  quickCheck (semiringLaws :: Laws (Max Integer))+  quickCheck (semiringLaws :: Laws (Min Integer))+  quickCheck (semiringLaws :: Laws (Integer,Integer))+  quickCheck (semiringLaws :: Laws (Integer,Integer,Integer))+  quickCheck (semiringLaws :: Laws (Integer,Integer,Integer,Integer))+  quickCheck (semiringLaws :: Laws (Integer,Integer,Integer,Integer,Integer))+  smallCheck (semiringLaws :: Laws (Free Integer))+  quickCheck (semiringLaws :: Laws (Bottleneck Word8))+  quickCheck (semiringLaws :: Laws (Division Integer))+  quickCheck (semiringLaws :: Laws (Łukasiewicz Integer))+  quickCheck (semiringLaws :: Laws (Viterbi Integer))   doctest [ "-isrc"           , "src/Data/Semiring.hs"           , "src/Data/Semiring/Numeric.hs"           , "src/Test/Semiring.hs"           , "src/Data/Semiring/Free.hs" ]++data Func a b = Func b [(a,b)]+  deriving (Eq, Ord)++instance (Show a, Show b) => Show (Func a b) where+  showsPrec _ (Func c xs)  = showChar '{' . foldr f b xs where+    f (x,y) a = shows x . showString " -> " . shows y . showString ", " . a+    b = showString "_ -> " . shows c . showChar '}'++apply :: Ord a => Func a b -> a -> b+apply (Func c cs) x = foldr f c cs where+  f (e,y) a = case compare x e of+    LT -> c+    EQ -> y+    GT -> a++instance (Ord a, Eq b, Arbitrary a, Arbitrary b) => Arbitrary (Func a b) where+  arbitrary = liftA2 fromList arbitrary arbitrary+  shrink (Func c xs) = map (fromList c) (shrink xs)++fromList :: (Ord a, Eq b) => b -> [(a,b)] -> Func a b+fromList cnst+  = Func cnst+  . Map.toList+  . Map.fromList+  . filter ((cnst/=) . snd)++fromFunc :: (Enum a, Bounded a, Ord a, Ord b) => (a -> b) -> Func a b+fromFunc f = fromList cnst (zip xs ys) where+  xs = [minBound..maxBound]+  ys = map f xs+  Just cnst = mostFrequent ys++mostFrequent :: (Ord a, Foldable f) => f a -> Maybe a+mostFrequent = fmap fst . fst . foldl' f (Nothing, Map.empty :: Map.Map a Int) where+  f (b,m) e = (Just nb, Map.insert e c m) where+    c = maybe 1 succ (Map.lookup e m)+    nb = case b of+      Just (a,d) | d >= c -> (a,d)+      _ -> (e,c)