W7Test.hs

module W7Test where

import W7

import Impl.Test
import Data.List
import Data.Ord
import Data.Function
import Control.Monad
import Control.Monad.State

import Test.QuickCheck hiding (Result,reason,classify,Failure,(===))

main = testExs tests -- $forAllProperties (quickCheckWithResult args)

tests = [[ex1_1, property ex1_2]
        ,[property ex2]
        ,[property ex3_1, property ex3_2]
        ,[property ex4_1, property ex4_2]
        ,[property ex5_getters, property ex5_addPoints]
        ,[property ex6_height, property ex6_size]
        ,[property ex7_eq, property ex7_neq, property ex7_sort]
        ,[property ex8_ok, property ex8_fail]
        ,[property ex9_maybe, property ex9_state]
        ,[property ex10_odds]
        ]

-- -- -- -- -- -- -- --

ex1_1 =
  conjoin
  [pyramid 1 === "*\n"
  ,pyramid 2 === " *\n***\n"
  ,pyramid 3 === "  *\n ***\n*****\n"]

ex1_2 = forAll (choose (1,25)) $ \n ->
  let ls = lines (pyramid n)
  in conjoin [counterexample "number of lines" $ length ls === n
             ,counterexample "lengths of lines" $
              map length ls === [n,n+1..2*n-1]
             ,counterexample "numbers of stars" $
              map (length . filter (=='*')) ls === [1,3..2*n-1]
             ,counterexample "all lines consist of spaces followed by stars" $
              all ck0 ls
             ]
  where
    ck0 (' ':xs) = ck0 xs
    ck0 ('*':xs) = ck1 xs
    ck0 _ = False
    ck1 ('*':xs) = ck1 xs
    ck1 [] = True
    ck1 _ = False

ex2 :: [Int] -> Property
ex2 xs = everySecond xs === f xs
  where f xs = [x | (i,x) <- zip [0..] xs, even i]

ex3_1 = do
  ls <- listOf1 arbitrary :: Gen [Int]
  i <- choose (0,length ls-1)
  let l = ls !! i
      (g,q) = wrap ls
  counterexample' ("wrap "++show ls) $
    conjoin [counterexample ("get "++show i) $
             g i === l
            ,counterexample ("query "++show l) $
             q l === True]

ex3_2 = do
  ls <- listOf1 arbitrary :: Gen [Int]
  l <- arbitrary `suchThat` \i -> not (elem i ls)
  let (_,q) = wrap ls
  counterexample' ("wrap "++show ls) $
    counterexample' ("query "++show l) $
      q l === False

ex4_1 = do
  starts <- listOf1 (choose (0,10))
  seqs <- forM starts $ \s -> liftM (scanl (+) s) (listOf1 (choose (11,20)))
  let l = concat seqs
      res = increasings l
  counterexample' ("increasings "++show l) $
    res == seqs

ex4_2 = do
  l <- listOf1 (choose (0,20))
  let res = increasings l
  return $ conjoin
    [counterexample ("concat (increasings "++show l++")") $
     concat res === l
    ,counterexample ("increasings "++show l++"\nall increasing") $
     all p res]
  where p (x:y:xs) = x<y && p (y:xs)
        p _ = True

ex5_getters = do
  n <- word
  Positive o <- arbitrary :: Gen (Positive Int)
  let num = show o
      s = newStudent n num
      d = "newStudent "++show n++" "++show num
  return $ conjoin [
    counterexample ("getName $ "++d) $ getName s === n,
    counterexample ("getNumber $ "++d) $ getNumber s === num,
    counterexample ("getPoints $ "++d) $ getPoints s === 0]

ex5_addPoints = do
  n <- word
  Positive o <- arbitrary :: Gen (Positive Int)
  let num = show o
      s = newStudent n num
      d = "newStudent "++show n++" "++show num
      f x = "addPoints "++show x++" $ "
  a <- choose (0,20)
  b <- choose (0,20)
  c <- choose (-10,-1)
  counterexample' (f a ++ f c ++ f b ++ d) $
    getPoints (addPoints a $ addPoints c $ addPoints b $ s) === a+b

genH 0 = return leaf
genH h = do
  b <- arbitrary
  if b then genH2 h else genH3 h

genH2 h = do
  i <- choose (0,h-1)
  t0 <- genH i
  t1 <- genH (h-1)
  b <- arbitrary
  return $ if b then node2 t0 t1 else node2 t1 t0

genH3 h = do
  i <- choose (0,h-1)
  t0 <- genH i
  j <- choose (0,h-1)
  t1 <- genH j
  t2 <- genH (h-1)
  b <- choose (0,2::Int)
  return $ case b of 0 -> node3 t0 t1 t2
                     1 -> node3 t0 t2 t1
                     _ -> node3 t2 t0 t1

ex6_height =
  forAllShrink (choose (0,10::Int)) shrink $ \h ->
  do
    t <- genH h
    counterexample' ("treeHeight ("++show t++")") $ treeHeight t === h

genS 0 = return leaf
genS s = do
  b <- arbitrary
  if b then genS2 s else genS3 s

genS2 s = do
  i <- choose (0,s-1)
  t0 <- genS i
  t1 <- genS (s-1-i)
  return $ node2 t0 t1

genS3 s = do
  i <- choose (0,s-1)
  t0 <- genS i
  j <- choose (0,s-1-i)
  t1 <- genS j
  t2 <- genS (s-1-i-j)
  return $ node3 t0 t1 t2

ex6_size =
  forAllShrink (choose (0,20::Int)) shrink $ \s ->
  do
    t <- genS s
    counterexample' ("treeSize ("++show t++")") $ treeSize t === s

genExpr = do
  i <- choose (0,4::Int)
  case i of 4 -> do (e1,v1) <- genExpr
                    (e2,v2) <- genExpr
                    return (Plus e1 e2,v1+v2)
            3 -> do (e1,v1) <- genExpr
                    (e2,v2) <- genExpr `suchThat` \(_,v2) -> v2 /= 0
                    return (Div e1 e2,v1 `div` v2)
            _ -> do c <- choose (-10,10)
                    return (Constant c, c)

genExpr' k = do
  i <- choose (0,4::Int)
  case i of 4 -> do j <- choose (0,k)
                    e1 <- genExpr' j
                    e2 <- genExpr' (k-j)
                    return $ Plus e1 e2
            3 -> do m <- choose (1,4)
                    fuzz <- choose (0,k `div` 2)
                    e1 <- genExpr' (k*m+fuzz)
                    e2 <- genExpr' m
                    return $ Div e1 e2
            _ -> return $ Constant k

genSucc = fmap fst genExpr
genZero = genExpr' 0

genFail = do
  i <- choose (0,3::Int)
  k <- choose (False,True)
  case i of 3 -> do e1 <- if k then genSucc else genFail
                    e2 <- if k then genFail else genSucc
                    return $ Div e1 e2
            2 -> do e1 <- genSucc
                    e2 <- genZero
                    return $ Div e1 e2
            _ -> do e1 <- if k then genSucc else genFail
                    e2 <- if k then genFail else genSucc
                    return $ Plus e1 e2

ex7_eq s = counterexample ("fromString "++show s++" == fromString "++show s) $
               (fromString s == fromString s) === True

ex7_neq s s' = s /= s' ==> counterexample ("fromString "++show s++" == fromString "++show s')
                   ((fromString s == fromString s') === False)

word = listOf1 (choose ('a','z'))

ex7_sort = do
  words <- listOf1 word
  let res = map toString . sort $ map fromString words
      should = concat . map sort . groupBy ((==)`on`length) . sortBy (comparing length) $ words
  counterexample' ("map toString (sort (map fromString "++show words++"))") $
    res === should

ex8_ok = do
  (e,v) <- genExpr
  counterexample' ("safeEval ("++show e++")") $
    safeEval e === Just v

ex8_fail = do
  e <- genFail
  counterexample' ("safeEval ("++show e++")") $
    safeEval e === Nothing

t1 :: Int -> Int -> Maybe Bool
t1 k x = Just (x>k)

t2 :: Int -> Int -> State [Int] Bool
t2 k x = do modify (k:)
            return (x>k)

ex9_maybe = do
  ts <- listOf1 (choose (0,10))
  i <- choose (maximum ts+1,maximum ts+10)
  j <- choose (minimum ts,maximum ts)
  let ms = map t1 ts
      s = "["++intercalate "," (map f ts)++"]"
      f t = "test1 "++show t
      d = "test "++s++" "
  return $ conjoin [counterexample (d++show i) (test ms i === Just True)
                   ,counterexample (d++show j) (test ms j === Just False)]

ex9_state = do
  ts <- listOf1 (choose (0,10))
  i <- choose (maximum ts+1,maximum ts+10)
  j <- choose (minimum ts,maximum ts)
  let ms = map t2 ts
      s = "["++intercalate "," (map f ts)++"]"
      f t = "test2 "++show t
      d i = "runState (test "++s++" "++show i++") []"
      ts' = take (length (takeWhile (<j) ts) + 1) ts
  return $ conjoin
    [counterexample (d i) (runState (test ms i) [] === (True,reverse ts))
    ,counterexample (d j) (runState (test ms j) [] === (False,reverse ts'))]


ex10_odds = do
  n <- listOf (choose (0::Int,10))
  let res = map head . filter (odd.length) . group $ sort n
  counterexample' ("snd $ runState (odds "++show n++") []") $
    sort (snd (runState (odds n) [])) === res