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.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 diff --git a/src/Data/Semiring.hs b/src/Data/Semiring.hs --- a/src/Data/Semiring.hs +++ b/src/Data/Semiring.hs @@ -50,8 +50,8 @@ import Control.Applicative (liftA2) import Data.Coerce (coerce) import GHC.Generics (Generic, Generic1) -import Test.QuickCheck (Arbitrary) + -- | 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 @@ -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 "" @@ -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 diff --git a/src/Data/Semiring/Free.hs b/src/Data/Semiring/Free.hs --- a/src/Data/Semiring/Free.hs +++ b/src/Data/Semiring/Free.hs @@ -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 -- . -- 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 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 @@ -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 - -- | -- has some information on this. Also -- @@ -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 diff --git a/src/Test/Semiring.hs b/src/Test/Semiring.hs --- a/src/Test/Semiring.hs +++ b/src/Test/Semiring.hs @@ -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]) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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)