packages feed

semiring-num 0.2.0.0 → 0.3.0.0

raw patch · 6 files changed

+318/−152 lines, 6 filesdep +smallcheckdep −QuickCheckdep −random

Dependencies added: smallcheck

Dependencies removed: QuickCheck, random

Files

semiring-num.cabal view
@@ -1,5 +1,5 @@ name:                semiring-num-version:             0.2.0.0+version:             0.3.0.0 synopsis:            Basic semiring class and instances description:         Adds a basic semiring class homepage:            https://github.com/oisdk/semiring-num@@ -20,8 +20,6 @@                      , Test.Semiring   build-depends:       base >= 4.9 && < 5                      , containers >= 0.5-                     , QuickCheck >= 2.8-                     , random >= 1.1   default-language:    Haskell2010   ghc-options:         -Wall @@ -31,7 +29,7 @@   main-is:             Spec.hs   build-depends:       base >= 4.9 && < 5                      , semiring-num-                     , QuickCheck >= 2.8+                     , smallcheck >= 1.1                      , doctest >= 0.11                      , containers >= 0.5   ghc-options:         -threaded
src/Data/Semiring.hs view
@@ -50,8 +50,8 @@ 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 -- the combination of two 'Data.Monoid.Monoid's. The first -- is called '<+>'; it has the identity element 'zero', and it is@@ -150,14 +150,14 @@ newtype Add a = Add   { getAdd :: a   } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num-             ,Arbitrary, Enum)+             ,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, Enum)+             ,Enum)  instance Functor Add where fmap = coerce @@ -232,7 +232,7 @@ -- @'one'  = 'zero'@ (over the inner value) newtype Min a = Min   { getMin :: Maybe a-  } deriving (Eq, Ord, Read, Show, Generic, Generic1, Arbitrary, Functor+  } deriving (Eq, Ord, Read, Show, Generic, Generic1, Functor              ,Foldable)  -- | The "<https://ncatlab.org/nlab/show/https://ncatlab.org/nlab/show/max-plus+algebra Arctic>"@@ -243,7 +243,7 @@ -- @'one'  = 'zero'@ (over the inner value) newtype Max a = Max   { getMax :: Maybe a-  } deriving (Eq, Ord, Read, Show, Generic, Generic1, Arbitrary, Functor+  } deriving (Eq, Ord, Read, Show, Generic, Generic1, Functor              ,Foldable)  instance Applicative Max where
src/Data/Semiring/Free.hs view
@@ -24,8 +24,6 @@ import qualified Data.Map.Strict as Map import           Data.Map.Strict (Map) -import           Test.QuickCheck (Arbitrary(..))- -- | The free semiring. Adapted from PureScript's version, available -- <https://pursuit.purescript.org/packages/purescript-semirings/3.0.0/docs/Data.Semiring.Free here>. -- Only a valid semiring if treated as a multiset, as in:@@ -60,9 +58,6 @@  instance Ord a => Ord (Free a) where   compare = comparing (sort . getFree)--instance Arbitrary a => Arbitrary (Free a) where-  arbitrary = Free <$> arbitrary  infixr 9 .# (.#) :: Coercible b c => (b -> c) -> (a -> b) -> a -> c
src/Data/Semiring/Numeric.hs view
@@ -18,17 +18,13 @@ import           Data.Coerce import           Data.Semiring import           GHC.Generics-import           System.Random-import           Test.QuickCheck-import           Test.QuickCheck.Gen  type WrapBinary f a = (a -> a -> a) -> f a -> f a -> f a  -- | '<+>' is 'max', '<.>' is 'min' newtype Bottleneck a = Bottleneck   { getBottleneck :: a-  } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num-             ,Arbitrary)+  } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num)  instance (Bounded a, Ord a) => Semiring (Bottleneck a) where   (<+>) = (coerce :: WrapBinary Bottleneck a) max@@ -48,9 +44,6 @@   zero = Division zero   one = Division one -instance (Integral a, Arbitrary a) => Arbitrary (Division a) where-  arbitrary = fmap (Division . abs) arbitrary- -- | <https://en.wikipedia.org/wiki/Semiring#cite_ref-droste_14-0 Wikipedia> -- has some information on this. Also -- <http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.304.6152&rep=rep1&type=pdf this>@@ -59,9 +52,6 @@   { getŁukasiewicz :: a   } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num) -instance (Num a, Random a) => Arbitrary (Łukasiewicz a) where-  arbitrary = fmap Łukasiewicz (choose (0,1))- instance (Ord a, Num a) => Semiring (Łukasiewicz a) where   (<+>) = (coerce :: WrapBinary Łukasiewicz a) max   (<.>) = (coerce :: WrapBinary Łukasiewicz a) (\x y -> max 0 (x + y - 1))@@ -75,9 +65,6 @@ newtype Viterbi a = Viterbi   { getViterbi :: a   } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num)--instance (Semiring a, Random a) => Arbitrary (Viterbi a) where-  arbitrary = fmap Viterbi (choose (zero,one))  instance (Ord a, Semiring a) => Semiring (Viterbi a) where   (<+>) = (coerce :: WrapBinary Viterbi a) max
src/Test/Semiring.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE ScopedTypeVariables #-}+ {-| Module: Test.Semiring Description: Some QuickCheck properties for Semirings@@ -15,123 +17,156 @@   , plusId   , mulId   , annihilate-  , semiringLaws-  , Laws+  , unaryLaws+  , binaryLaws+  , ternaryLaws   ) where  import           Data.Semiring   (Semiring (..))-import           Test.QuickCheck (Property, conjoin, counterexample)  -- | Plus is associative.-plusAssoc :: (Eq a, Semiring a, Show a) => a -> a -> a -> Property-plusAssoc x y z = counterexample s res where+plusAssoc :: (Eq a, Semiring a, Show a) => a -> a -> a -> Either String String+plusAssoc x y z = if res then Right s else Left s where   res = lp == rp   l = x <+> y   r = y <+> z   lp = l <+> z   rp = x <+> r   s = unlines-    [ "Testing associativity of plus."-    , "Law: (x <+> y) <+> z = x <+> (y <+> z)"-    , "x <+> y = " ++ show l-    , "y <+> z = " ++ show r-    , "(x <+> y) <+> z = " ++ show lp-    , "x <+> (y <+> z) = " ++ show rp]+    [ "<+> is " ++ (if res then "" else "not ") ++ "associative."+    , "    Law:"+    , "        (x <+> y) <+> z = x <+> (y <+> z)"+    , "    x = " ++ show x+    , "    y = " ++ show y+    , "    z = " ++ show z+    , "    x <+> y = " ++ show l+    , "    y <+> z = " ++ show r+    , "    (x <+> y) <+> z = " ++ show lp+    , "    x <+> (y <+> z) = " ++ show rp ]  -- | Multiplication is associative.-mulAssoc :: (Eq a, Semiring a, Show a) => a -> a -> a -> Property-mulAssoc x y z = counterexample s (lp == rp) where+mulAssoc :: (Eq a, Semiring a, Show a) => a -> a -> a -> Either String String+mulAssoc x y z = if res then Right s else Left s  where+  res = lp == rp   l = x <.> y   r = y <.> z   lp = l <.> z   rp = x <.> r   s = unlines-    [ "Testing associativity of <.>."-    , "Law: (x <.> y) <.> z = x <.> (y <.> z)"-    , "x <.> y = " ++ show l-    , "y <.> z = " ++ show r-    , "(x <.> y) <.> z = " ++ show lp-    , "x <.> (y <.> z) = " ++ show rp]+    [ "<+> is " ++ (if res then "" else "not ") ++ "associative."+    , "    Law:"+    , "        (x <.> y) <.> z = x <.> (y <.> z)"+    , "    x = " ++ show x+    , "    y = " ++ show y+    , "    z = " ++ show z+    , "    x <.> y = " ++ show l+    , "    y <.> z = " ++ show r+    , "    (x <.> y) <.> z = " ++ show lp+    , "    x <.> (y <.> z) = " ++ show rp]  -- | Plus is commutative.-plusComm :: (Eq a, Semiring a, Show a) => a -> a -> Property-plusComm x y = counterexample s (l == r) where+plusComm :: (Eq a, Semiring a, Show a) => a -> a -> Either String String+plusComm x y = if res then Right s else Left s where+  res = l == r   l = x <+> y   r = y <+> x   s = unlines-    [ "Testing commutativity of <+>."-    , "Law: x <+> y = y <+> x"-    , "x <+> y = " ++ show l-    , "y <+> x = " ++ show r ]+    [ "<+> is " ++ (if res then "" else "not ") ++ "commutative."+    , "    Law:"+    , "        x <+> y = y <+> x"+    , "    x = " ++ show x+    , "    y = " ++ show y+    , "    x <+> y = " ++ show l+    , "    y <+> x = " ++ show r ]  -- | Multiplication distributes left.-mulDistribL :: (Eq a, Semiring a, Show a) => a -> a -> a -> Property-mulDistribL x y z = counterexample s (l == r) where+mulDistribL :: (Eq a, Semiring a, Show a) => a -> a -> a -> Either String String+mulDistribL x y z = if res then Right s else Left s where+  res = l == r    l = x <.> (y <+> z)   r = x <.> y <+> x <.> z   s = unlines-    [ "Testing left distributivity of <.> over <+>."-    , "Law: x <.> (y <+> z) = x <.> y <+> x <.> z"-    , "x <.> (y <+> z) = " ++ show l-    , "x <.> y <+> x <.> z  = " ++ show r ]+    [ "<.> does " ++ (if res then "" else "not ") ++ "distribute left over <+>."+    , "    Law:"+    , "        x <.> (y <+> z) = x <.> y <+> x <.> z"+    , "    x = " ++ show x+    , "    y = " ++ show y+    , "    z = " ++ show z+    , "    x <.> (y <+> z) = " ++ show l+    , "    x <.> y <+> x <.> z  = " ++ show r ]  -- | Multiplication distributes right.-mulDistribR :: (Eq a, Semiring a, Show a) => a -> a -> a -> Property-mulDistribR x y z = counterexample s (l == r) where+mulDistribR :: (Eq a, Semiring a, Show a) => a -> a -> a -> Either String String+mulDistribR x y z = if res then Right s else Left s where+  res = l == r   l = (x <+> y) <.> z   r = x <.> z <+> y <.> z   s = unlines-    [ "Testing right distributivity of <.> over <+>."-    , "Law: (x <+> y) <.> z = x <.> z <+> y <.> z"-    , "(x <+> y) <.> z = " ++ show l-    , "x <.> z <+> y <.> z = " ++ show r ]+    [ "<.> does " ++ (if res then "" else "not ") ++ "distribute left over <+>."+    , "    Law:"+    , "        (x <+> y) <.> z = x <.> z <+> y <.> z"+    , "    x = " ++ show x+    , "    y = " ++ show y+    , "    z = " ++ show z+    , "    (x <+> y) <.> z = " ++ show l+    , "    x <.> z <+> y <.> z = " ++ show r ]  -- | Additive identity.-plusId :: (Eq a, Semiring a, Show a) => a -> Property-plusId x = counterexample s (l == x && r ==x) where+plusId :: (Eq a, Semiring a, Show a) => a -> Either String String+plusId (x :: a) = if res then Right s else Left s where+  res = l == x && r ==x   l = x <+> zero   r = zero <+> x   s = unlines-    [ "Testing identity of <+>."-    , "Law: x <+> zero = zero <+> x = x"-    , "x = " ++ show x-    , "x <+> zero = " ++ show l-    , "zero <+> x = " ++ show r ]+    [ "zero is" ++ (if res then "" else " not") ++ " the identity of <+>."+    , "    Law:"+    , "        x <+> zero = zero <+> x = x"+    , "    x = " ++ show x+    , "    zero = " ++ show (zero :: a)+    , "    x <+> zero = " ++ show l+    , "    zero <+> x = " ++ show r ]  -- | Multiplicative identity.-mulId :: (Eq a, Semiring a, Show a) => a -> Property-mulId x = counterexample s (l == x && r ==x) where+mulId :: (Eq a, Semiring a, Show a) => a -> Either String String+mulId (x :: a) = if res then Right s else Left s where+  res = l == x && r == x   l = x <.> one   r = one <.> x   s = unlines-    [ "Testing identity of <.>."-    , "Law: x <.> one = one <.> x = x"-    , "x = " ++ show x-    , "x <.> one = " ++ show l-    , "one <.> x = " ++ show r ]+    [ "one is" ++ (if res then "" else " not") ++ " the identity of <+>."+    , "    Law:"+    , "        x <.> one = one <.> x = x"+    , "    x = " ++ show x+    , "    one = " ++ show (one :: a)+    , "    x <.> one = " ++ show l+    , "    one <.> x = " ++ show r ]  -- | Annihilation of '<.>' by 'zero'.-annihilate :: (Eq a, Semiring a, Show a) => a -> Property-annihilate x = counterexample s (l == zero && r == zero) where+annihilate :: (Eq a, Semiring a, Show a) => a -> Either String String+annihilate (x :: a) = if res then Right s else Left s where+  res = l == zero && r == zero   l = x <.> zero   r = zero <.> x   s = unlines-    [ "Testing annihilation of <.> by zero."-    , "Law: x <.> zero = zero <.> x = zero"-    , "x = " ++ show x-    , "x <.> zero = " ++ show l-    , "zero <.> x = " ++ show r ]+    [ "zero does " ++ (if res then "" else "not ") ++ "annihilate with <.>."+    , "    Law:"+    , "        x <.> zero = zero <.> x = zero"+    , "    x = " ++ show x+    , "    zero = " ++ show (zero :: a)+    , "    x <.> zero = " ++ show l+    , "    zero <.> x = " ++ show r ] --- | A property for all laws of 'Semiring'.-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 ]+unaryLaws :: (Eq a, Semiring a, Show a) => a -> Either String String+unaryLaws x = fmap unlines (sequence [plusId x, mulId x, annihilate x]) -type Laws a = a -> a -> a -> Property+binaryLaws :: (Eq a, Semiring a, Show a)+           => a -> a -> Either String String+binaryLaws = plusComm++ternaryLaws :: (Eq a, Semiring a, Show a)+            => a -> a -> a -> Either String String+ternaryLaws x y z =+  fmap unlines (sequence [ plusAssoc x y z+                         , mulAssoc x y z+                         , mulDistribL x y z+                         , mulDistribR x y z])
test/Spec.hs view
@@ -1,83 +1,220 @@+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE ScopedTypeVariables        #-}+ module Main (main) where -import           Control.Applicative   (liftA2)+import           Control.Applicative+import           Control.Arrow          (first)+import           Data.Bits              ((.&.)) import           Data.Foldable-import qualified Data.Map.Strict       as Map+import           Data.Function          (on)+import           Data.IntMap.Strict     (IntMap)+import qualified Data.IntMap.Strict     as IntMap+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)-import           Data.Word             (Word8)+import qualified Data.Set               as Set+import           Data.Word              (Word8) import           Test.DocTest-import           Test.QuickCheck import           Test.Semiring--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)+import           Test.SmallCheck+import           Test.SmallCheck.Series +------------------------------------------------------------------------  main :: IO () main = do-  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))+  putStrLn "Integer"+  smallCheck 1000 (unaryLaws   :: UnaryLaws   Integer)+  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 "(Word2,Word2)"+  smallCheck 16 (unaryLaws   :: UnaryLaws   (Word2,Word2))+  smallCheck 14 (binaryLaws  :: BinaryLaws  (Word2,Word2))+  smallCheck 8  (ternaryLaws :: TernaryLaws (Word2,Word2))++  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 "(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 "Int"+  smallCheck 1000 (unaryLaws   :: UnaryLaws   Int)+  smallCheck 100  (binaryLaws  :: BinaryLaws  Int)+  smallCheck 10   (ternaryLaws :: TernaryLaws Int)++  putStrLn "()"+  smallCheck 1 (unaryLaws   :: UnaryLaws   ())+  smallCheck 1 (binaryLaws  :: BinaryLaws  ())+  smallCheck 1 (ternaryLaws :: TernaryLaws ())++  putStrLn "Bool"+  smallCheck 2 (unaryLaws   :: UnaryLaws   Bool)+  smallCheck 4 (binaryLaws  :: BinaryLaws  Bool)+  smallCheck 8 (ternaryLaws :: TernaryLaws Bool)++  putStrLn "Any"+  smallCheck 2 (unLawsOn   Any :: UnaryLaws   Bool)+  smallCheck 4 (binLawsOn  Any :: BinaryLaws  Bool)+  smallCheck 8 (ternLawsOn Any :: TernaryLaws Bool)++  putStrLn "All"+  smallCheck 2 (unLawsOn   All :: UnaryLaws   Bool)+  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 "Set [Word2]"+  smallCheck 4 (unLawsOn   Set.fromList :: UnaryLaws   [[Word2]])+  smallCheck 3 (binLawsOn  Set.fromList :: BinaryLaws  [[Word2]])+  smallCheck 3 (ternLawsOn Set.fromList :: TernaryLaws [[Word2]])++  putStrLn "Min Integer"+  smallCheck 1000 (unLawsOn   Min :: UnaryLaws   (Maybe Integer))+  smallCheck 100  (binLawsOn  Min :: BinaryLaws  (Maybe Integer))+  smallCheck 10   (ternLawsOn Min :: TernaryLaws (Maybe Integer))++  putStrLn "Max Integer"+  smallCheck 1000 (unLawsOn   Max :: UnaryLaws   (Maybe Integer))+  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 "Bottleneck Word2"+  smallCheck 1000 (unLawsOn   Bottleneck :: UnaryLaws   Word2)+  smallCheck 100  (binLawsOn  Bottleneck :: BinaryLaws  Word2)+  smallCheck 10   (ternLawsOn Bottleneck :: TernaryLaws Word2)++  putStrLn "Division Integer"+  smallCheck 1000 (unLawsOn   (Division . getPositive) :: UnaryLaws   (Positive Integer))+  smallCheck 100  (binLawsOn  (Division . getPositive) :: BinaryLaws  (Positive Integer))+  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)++  putStrLn "Viterbi Double"+  smallCheck 1000 (unLawsOn   (Viterbi . getFrac) :: UnaryLaws   Fraction)+  smallCheck 100  (binLawsOn  (Viterbi . getFrac) :: BinaryLaws  Fraction)+  smallCheck 10   (ternLawsOn (Viterbi . getFrac) :: TernaryLaws Fraction)++  putStrLn "Bool -> Bool"+  smallCheck 3 (unLawsOn   fromFunc :: UnaryLaws   (Bool -> Bool))+  smallCheck 2 (binLawsOn  fromFunc :: BinaryLaws  (Bool -> Bool))+  smallCheck 2 (ternLawsOn fromFunc :: TernaryLaws (Bool -> Bool))+   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)+------------------------------------------------------------------------+-- Test helpers -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 '}'+type UnaryLaws   a =           a -> Either String String+type BinaryLaws  a =      a -> a -> Either String String+type TernaryLaws a = a -> a -> a -> Either String String -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+unLawsOn :: (Eq b, Semiring b, Show b) => (a -> b) -> UnaryLaws a+unLawsOn f = unaryLaws . f -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)+binLawsOn :: (Eq b, Semiring b, Show b) => (a -> b) -> BinaryLaws a+binLawsOn f = binaryLaws `on` f -fromList :: (Ord a, Eq b) => b -> [(a,b)] -> Func a b-fromList cnst+ternLawsOn :: (Eq b, Semiring b, Show b) => (a -> b) -> TernaryLaws a+ternLawsOn f x y z = ternaryLaws (f x) (f y) (f z)++------------------------------------------------------------------------+-- Serial wrappers++-- | A type with a serial instance between zero and one+newtype Fraction = Fraction { getFrac :: Double } deriving (Show, Eq, Ord)++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)+    go lower upper = let mid = (lower + upper) / 2 in+      mid : interleave (go lower mid) (go mid upper)+    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++instance Bounded Word2 where+  minBound = Word2 0+  maxBound = Word2 3++instance Enum Word2 where+  fromEnum = fromEnum . getWord2+  toEnum x = Word2 (toEnum x .&. maxBound)++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)+  abs = id+  signum (Word2 x) = Word2 (signum x)++instance Real Word2 where+  toRational = toRational . getWord2++instance Integral Word2 where+  toInteger = toInteger . getWord2+  quotRem (Word2 x) (Word2 y) = (Word2 (quot x y), Word2 (rem x y))++instance Monad m => Serial m Word2 where+  series = generate (`take` [minBound..maxBound])++instance Semiring Word2++------------------------------------------------------------------------+-- Function Equality++-- | A representation of a function+data Func a b = Func b (IntMap b)+  deriving (Eq, Ord)++fromList' :: Eq b => b -> [(Int,b)] -> Func a b+fromList' cnst   = Func cnst-  . Map.toList-  . Map.fromList+  . IntMap.fromList   . filter ((cnst/=) . snd) -fromFunc :: (Enum a, Bounded a, Ord a, Ord b) => (a -> b) -> Func a b+fromList :: (Enum a, Eq b) => b -> [(a,b)] -> Func a b+fromList cnst+  = fromList' cnst+  . map (first fromEnum)++fromFunc :: (Enum a, Bounded a, Ord b) => (a -> b) -> Func a b fromFunc f = fromList cnst (zip xs ys) where   xs = [minBound..maxBound]   ys = map f xs@@ -90,3 +227,17 @@     nb = case b of       Just (a,d) | d >= c -> (a,d)       _ -> (e,c)++apply :: Enum a => Func a b -> a -> b+apply (Func c cs) x = IntMap.findWithDefault c (fromEnum x) cs++instance (Enum a, Show a, Show b) => Show (Func a b) where+  showsPrec _ (Func c xs :: Func a b)  = showChar '{' . IntMap.foldrWithKey f b xs where+    f x y a = shows (toEnum x :: a) . showString " -> " . shows y . showString ", " . a+    b = showString "_ -> " . shows c . showChar '}'++instance (Enum a, Bounded 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)