Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Example tweaks.

  • Loading branch information...
commit 88dd956fb42d11205750937c8046ff0b26385ba0 1 parent 3871c0d
@leepike authored
Showing with 106 additions and 58 deletions.
  1. +32 −30 examples/Div0.hs
  2. +74 −28 examples/Large.hs
View
62 examples/Div0.hs
@@ -14,48 +14,50 @@ import Data.Typeable
-----------------------------------------------------------------
-data M = C Int
- | A M M
- | D M M
+data Exp = C Int
+ | Add Exp Exp
+ | Div Exp Exp
deriving (Read, Show, Typeable, Generic)
-instance SubTypes M
+instance SubTypes Exp
-eval :: M -> Maybe Int
+eval :: Exp -> Maybe Int
eval (C i) = Just i
-eval (A a b) = do
- i <- eval a
- j <- eval b
- return $ i + j
-eval (D a b) =
- if eval b == Just 0 then Nothing
- else do i <- eval a
- j <- eval b
- return $ i `div` j
-
-instance Arbitrary M where
+eval (Add e0 e1) =
+ liftM2 (+) (eval e0) (eval e1)
+eval (Div e0 e1) =
+ let e = eval e1 in
+ if e == Just 0 then Nothing
+ else liftM2 div (eval e0) e
+
+instance Arbitrary Exp where
arbitrary = sized mkM
where
mkM 0 = liftM C arbitrary
- mkM n = oneof [ liftM2 A mkM' mkM'
- , liftM2 D mkM' mkM' ]
+ mkM n = oneof [ liftM2 Add mkM' mkM'
+ , liftM2 Div mkM' mkM' ]
where mkM' = mkM =<< choose (0,n-1)
- -- shrink (C _) = []
- -- shrink (A a b) = [a, b]
- -- shrink (D a b) = [a, b]
+ shrink (C i) = map C (shrink i)
+ shrink (Add e0 e1) = [e0, e1]
+ shrink (Div e0 e1) = [e0, e1]
-- property: so long as 0 isn't in the divisor, we won't try to divide by 0.
-- It's false: something might evaluate to 0 still.
-div_prop :: M -> Property
-div_prop m = divSubTerms m ==> eval m /= Nothing
+div_prop :: Exp -> Property
+--div_prop e = divSubTerms e ==> eval e /= Nothing
+div_prop e = property $ case x of
+ Nothing -> True
+ Just True -> True
+ _ -> False
+ where x = fmap (< 1) (eval e)
-- precondition: no dividand in a subterm can be 0.
-divSubTerms :: M -> Bool
-divSubTerms (C _) = True
-divSubTerms (D _ (C 0)) = False
-divSubTerms (A m0 m1) = divSubTerms m0 && divSubTerms m1
-divSubTerms (D m0 m1) = divSubTerms m0 && divSubTerms m1
+divSubTerms :: Exp -> Bool
+divSubTerms (C _) = True
+divSubTerms (Div _ (C 0)) = False
+divSubTerms (Add e0 e1) = divSubTerms e0 && divSubTerms e1
+divSubTerms (Div e0 e1) = divSubTerms e0 && divSubTerms e1
-- div0 (A _ _) = property False
-- div0 _ = property True
@@ -68,10 +70,10 @@ divSubTerms (D m0 m1) = divSubTerms m0 && divSubTerms m1
divTest :: IO ()
divTest = smartCheck args div_prop
where
- args = scStdArgs { qcArgs = stdArgs
+ args = scStdArgs { qcArgs = stdArgs
-- { maxSuccess = 1000
-- , maxSize = 20 }
- , treeShow = PrintString
+ , format = PrintString
}
---------------------------------------------------------------------------------
View
102 examples/Large.hs
@@ -7,13 +7,13 @@ module Large where
import Test.SmartCheck
import Test.QuickCheck
-import Test.LazySmallCheck hiding (Property, test)
-import qualified Test.LazySmallCheck as S
+import Test.LazySmallCheck hiding (Property, test, (==>))
import GHC.Generics hiding (P, C)
import Data.Typeable
import Control.Monad
-import Data.List
+
+import Data.Int
-----------------------------------------------------------------
@@ -21,47 +21,93 @@ import Data.List
-- single element to have a long list.
-- Container so that we don't have base types.
-data C = C Int
+data A = A Int16
deriving (Read, Show, Typeable, Generic)
-instance SubTypes C
+instance Serial Int16 where
+ series d = drawnFrom [(-d')..d']
+ where d' = fromIntegral d
+
+instance SubTypes A
-instance Arbitrary C where
- arbitrary = liftM C arbitrary
- shrink (C i) = map C (shrink i)
+instance Arbitrary A where
+ arbitrary = liftM A arbitrary
+ shrink (A i) = map A (shrink i)
-instance Serial C where
- series = cons1 C
+instance Serial A where
+ series = cons1 A
-data P = P [C] [C] [C] [C]
+data B = B [A] [A] [A] [A]
deriving (Read, Show, Typeable, Generic)
-instance SubTypes P
+instance SubTypes B
-instance Arbitrary P where
- arbitrary = liftM4 P arbitrary arbitrary arbitrary arbitrary
--- shrink (P a b c d) = [ P w x y z | w <- shrink a, x <- shrink b, y <- shrink c, z <- shrink d ]
+-- qc/shrink takes over 1m seconds
+instance Arbitrary B where
+ arbitrary = liftM4 B arbitrary arbitrary arbitrary arbitrary
+-- shrink (B a b c d) = [ B w x y z | w <- shrink a, x <- shrink b, y <- shrink c, z <- shrink d ]
-instance Serial P where
- series = cons4 P
+instance Serial B where
+ series = cons4 B
-sumC :: [C] -> Int
-sumC = foldl' (\acc (C c) -> acc + c) 0
+add :: [A] -> Int16
+add = sum . map (\(A i) -> i)
-test :: P -> Bool
-test (P a b _ _) = sumC a - sumC b < 4096
+pre :: B -> Bool
+pre (B a b c d) = and $ map pre' [a, b, c, d]
+ where
+ pre' x = add x < 16
-prop :: P -> Property
-prop = property . test
+test :: B -> Bool
+test (B a b c d) = add a + add b + add c + add d < 64
-main :: IO ()
-main = smartCheck scStdArgs { format = PrintString
- , scMaxDepth = Just 20
- }
- prop
+prop_p :: B -> Property
+prop_p p = pre p ==> test p
+main :: IO ()
+main = smartCheck scStdArgs { extrap = False, constrGen = False } prop_p
+ -- smartCheck scStdArgs { format = PrintString
+ -- , scMaxDepth = Just 20
+ -- }
+ -- prop_p
+-- sc :: Int -> IO ()
+-- sc n = smallCheck n test
t0 :: Int -> Bool
t0 a = a < 99999999999
+
+---------------------
+
+
+-- data A = A {int :: Int} deriving Show
+-- instance Arbitrary A where
+-- arbitrary = liftM A arbitrary
+-- shrink (A i) = map A (shrink i)
+-- prop :: [A] -> Property
+-- prop x = property (sum (map int x) /= 10)
+
+-- instance Serial A where
+-- series = cons1 A
+
+-- data B = B A A A A deriving Show
+-- instance Arbitrary B where
+-- arbitrary = liftM4 B arbitrary arbitrary arbitrary arbitrary
+-- instance Serial B where
+-- series = cons4 B
+-- prop0 :: B -> Bool
+-- prop0 (B a b c d) = and $ map f [a, b, c, d]
+-- where f (A x) = x < 30
+
+-- data E = E Bool deriving Show
+
+-- instance Serial E where
+-- series = cons1 E
+
+-- data F = F E E deriving Show
+
+-- instance Serial F where
+-- series = cons2 F
+
+-- prop1 (F (E a) (E b)) = not a || not b
Please sign in to comment.
Something went wrong with that request. Please try again.