Set13bTest.hs

{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, StandaloneDeriving #-}

module Set13bTest where

import Mooc.Test
import Mooc.Th

import Control.Monad
import Control.Monad.Trans.State
import qualified Data.Bits
import Data.Char
import Data.Either
import Data.Function
import Data.IORef
import Data.List
import qualified Data.Map as Map
import Test.QuickCheck hiding (Result,Failure)
import Test.QuickCheck.Monadic

import Examples.Bank
import Set13b hiding (perhapsIncrement,sumBounded,sumNotTwice)

main = score tests

tests = [(1,"ifM",[ex1_maybe, ex1_state])
        ,(2,"mapM2",[ex2_maybe, ex2_state])
        ,(3,"path",[ex3_visit_examples, ex3_visit_tree, ex3_visit_linear, ex3_visit
                   ,ex3_path_examples, ex3_path_linear, ex3_path])
        ,(4,"findSum2", [ex4_simple, ex4])
        ,(5,"allSums", [ex5_bits])
        ,(6,"foldM", [ex6_sumBounded_ok, ex6_sumBounded_fail, ex6_sumNotTwice])
        ,(7,"Monad Result", [ex7_fmap, ex7_fmap_empties, ex7_monad])
        ,(8,"Monad SL", [ex8_fmap_1, ex8_fmap_2, ex8_1, ex8_2, ex8_stress])
        ,(9,"mkCounter",[ex9_mkCounter])]

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

ex1_maybe =
  forAll_ $ \(c::Char) ->
  forAll_ $ \(d::Char) ->
  forAll_ $ \(b::Bool) ->
  let nc = Nothing :: Maybe Char
      nb = Nothing :: Maybe Bool
  in conjoin [$(testing [|ifM (Just b) (Just c) (Just d)|]) (?==Just (if b then c else d))
             ,$(testing [|ifM (Just b) (Just c) nc|]) (?==if b then Just c else Nothing)
             ,$(testing [|ifM (Just b) nc (Just d)|]) (?==if b then Nothing else Just d)
             ,$(testing [|ifM nb (Just c) (Just d)|]) (?==Nothing)]

ex1_state =
  conjoin [$(testing' [|runState (ifM get (return 'a') (return 'b')) True|]) (?==('a',True))
          ,$(testing' [|runState (ifM get (return 'a') (return 'b')) False|]) (?==('b',False))]

ex2_maybe =
  forAll_ $ \(as::[Int]) ->
  forAll_ $ \(bs::[Int]) ->
  let z = zipWith (-) as bs
      res = if all (/=0) z then Just z else Nothing
  in counterexample ("mapM2 (\\x y -> if x == y then Nothing else Just (x-y)) "++show as++" "++show bs) $
    mapM2 (\x y -> if x == y then Nothing else Just (x-y)) as bs ?== res

perhapsIncrement :: Bool -> Int -> State Int ()
perhapsIncrement True x = modify (+x)
perhapsIncrement False _ = return ()

ex2_state =
  forAll_ $ \(bs::[Bool]) ->
  forAll_ $ \(is::[Int]) ->
  counterexample ("runState (mapM2 perhapsIncrement "++show bs++" "++show is++") 0") $
  runState (mapM2 perhapsIncrement bs is) 0 ?== (zipWith (\_ _ -> ()) is bs, sum $ zipWith (\b i -> if b then i else 0) bs is)

ex3_visit_examples = conjoin [$(testing' [|runState (visit maze1 "Pit") []|]) (?==((),["Pit"]))
                             ,$(testing' [|runState (visit maze1 "Corridor 2") []|]) (?==((),["Corridor 3","Corridor 2"]))
                             ,$(testing' [|runState (visit maze1 "Entry") []|]) (?==((),["Dead end","Corridor 1","Pit","Entry"]))
                             ,$(testing' [|runState (visit maze1 "Entry") ["Corridor 1"]|]) (?==((),["Pit","Entry","Corridor 1"]))]

genTree 0 name = return [(name,[])]
genTree height name = do
  n <- choose (1,3)
  children <- nub <$> vectorOf n ((:name) <$> choose ('a','z'))
  rest <- concat <$> forM children (genTree (height-1))
  return $ (name,children):rest

shrinkTree xs = do pair@(x,_) <- xs
                   return $ map (\(n,ns) -> (n,delete x ns)) $ delete pair xs

ex3_visit_tree = forAllBlind (choose (1::Int,4)) $ \depth ->
  forAllShrinkBlind (genTree depth "0") shrinkTree $ \maze ->
  let root = fst (head maze)
  in counterexample ("runState (visit "++show maze++" "++show root++") []") $
  within timeLimit $
  ($ runState (visit maze root) []) . was $ \(_,state) ->
  counterexample " Final state" $
  hasElements (map fst maze) state

ex3_visit_linear = forAllBlind (choose (2::Int,6)) $ \n ->
  forAllBlind (choose (0,n-1)) $ \start ->
  forAllBlind (choose (start,n)) $ \end ->
  let maze = [(show i,[show (i+1)]) | i <- [0..n-1]]++[(show n,[])]
      sstart = show start
      send = show end
  in counterexample ("runState (visit "++show maze++" "++show sstart++") ["++show send++"]") $
  within timeLimit $
  ($ runState (visit maze sstart) [send]) . was $ \(_,state) ->
  counterexample " Final state" $
  hasElements (map show [start..end]) state

genConn :: [String] -> [String] -> Gen [(String,String)]
genConn nodes [] = return []
genConn nodes todo = do
  u <- elements todo
  v <- elements $ nodes \\ todo
  rest <- genConn nodes (delete u todo)
  return $ (u,v):(v,u):rest

genGraph :: [String] -> Gen [(String,String)]
genGraph nodes = do
  base <- genConn nodes (tail nodes)
  ns <- vectorOf 3 (elements nodes)
  return $ (ns!!0,ns!!1):(ns!!1,ns!!2):base

adj :: [(String,String)] -> [(String,[String])]
adj = map (simpl.unzip) . groupBy ((==)`on`fst) . sort . nub
  where simpl (x:_,ys) = (x,ys)

ex3_visit = property $ do
  n1 <- choose (1,5)
  n2 <- choose (1,4)
  names <- shuffle $ map show [1..n1+n2]
  let (names1,names2) = splitAt n1 names
  g1 <- genGraph names1
  g2 <- genGraph names2
  let maze = adj (g1++g2)
  return $ counterexample ("runState (visit "++show maze++" "++head names1++") []") $
    within timeLimit $
    ($ runState (visit maze (head names1)) []) . was $ \(_,state) ->
    counterexample " Final state" $
    hasElements names1 state

ex3_path_examples =
  conjoin [$(testing' [|path maze1 "Entry" "Pit"|]) (?==True)
          ,$(testing' [|path maze1 "Entry" "Dead end"|]) (?==True)
          ,$(testing' [|path maze1 "Pit" "Entry"|]) (?==False)
          ,$(testing' [|path maze1 "Entry" "Corridor 2"|]) (?==False)]

ex3_path_linear = forAllBlind (choose (2::Int,6)) $ \n ->
  forAllBlind (choose (0,n)) $ \start ->
  forAllBlind (choose (0,n)) $ \end ->
  let maze = [(show i,[show (i+1)]) | i <- [0..n-1]]++[(show n,[])]
      sstart = show start
      send = show end
  in $(testing [|path maze sstart send|]) (?==(start<=end))

ex3_path = property $ do
  n1 <- choose (1,5)
  n2 <- choose (1,5)
  names <- shuffle $ map show [1..n1+n2]
  let (names1,names2) = splitAt n1 names
  g1 <- genGraph names1
  g2 <- genGraph names2
  let maze = adj (g1++g2)
  from <- elements names
  to <- elements names
  return $ $(testing [|path maze from to|]) (?==(elem from names1 == elem to names1))

ex4_simple =
  conjoin [$(testing [|findSum2 [6,1] [7]|]) (hasElements [(1,6,7),(6,1,7)])
          ,$(testing [|findSum2 [6,1] [8]|]) (?==[])
          ,$(testing [|findSum2 [2,1] [4]|]) (hasElements [(2,2,4)])
          ,$(testing [|findSum2 [1,2,3,4] [6,7]|]) (hasElements [(2,4,6),(3,3,6),(3,4,7),(4,2,6),(4,3,7)])]

ex4 = forAllShrink_ (choose (1, 10)) $ \n ->
  (n>0 ==>) $
  property $ do
  step <- choose (1,5)
  start <- choose (1,100)
  let vals = [start,start+step..start+step*(n-1)]
  i1 <- choose (0,length vals-1)
  --i2 <- choose (0,n)
  let v1 = (vals!!i1)*2
      lim1 = min i1 (length vals-1-i1)
      triples1 = [(vals!!(i1-k),vals!!(i1+k),v1) | k <- [-lim1..lim1]]
  return $ $(testing [|findSum2 vals [v1]|]) (hasElements triples1)

ex5_bits = forAllShrink_ (choose (1::Int,9)) $ \n ->
  let vals = 0:map (\x -> 2^x) [0..n]
      all = nub $ [0..2^(n+1)-1]
  in conjoin [forAllBlind (elements vals) $ \del ->
                 del > 0 ==>
                 $(testing [|allSums (delete del vals)|]) (hasElementsDuplicates (filter ((==0).(Data.Bits..&.del)) all))
             ,$(testing [|allSums vals|]) (hasElementsDuplicates all)]

m is = maximum (scanl1 (+) is)

sumBounded :: Int -> [Int] -> Maybe Int
sumBounded k xs = foldM (f1 k) 0 xs

ex6_sumBounded_ok =
  forAllShrink_ (listOf1 (choose (-10,10))) $ \is ->
  forAllBlind (choose (0,3)) $ \diff ->
  let k = m is + diff
  in $(testing [|sumBounded k is|]) (?==Just (sum is))

ex6_sumBounded_fail =
  forAllBlind (listOf1 (choose (-10,10))) $ \is ->
  forAllBlind (choose (1::Int,3)) $ \diff ->
  let k = m is - diff
  in $(testing [|sumBounded k is|]) (?==Nothing)

sumNotTwice :: [Int] -> Int
sumNotTwice xs = fst $ runState (foldM f2 0 xs) []

ex6_sumNotTwice =
  forAllShrink_ (listOf1 (choose (-5,5))) $ \is ->
  $(testing [|sumNotTwice is|]) (?==sum (nub is))

ex7_fmap =
  forAll_ $ \(k::Int) ->
  counterexample ("fmap (+1) (MkResult "++show k++")") $
  fmap (+(1::Int)) (MkResult k) ?== MkResult (k+1)

ex7_fmap_empties =
  $(testing' [|fmap not NoResult|]) (?== NoResult)
  .&.
  $(testing' [|fmap not (Failure "oh no.")|]) (?== Failure "oh no.")
  .&.
  $(testing' [|fmap not (Failure "Mein Gott!")|]) (?== Failure "Mein Gott!")

ex7_monad =
  let op :: Int -> Result Int
      op i = if i>3 then Failure "big" else return (i+1)
      s = "let op i = if (i>3) then Failure \"big\" else return (i+1) in "
  in conjoin [counterexample' (s++" MkResult 1 >>= op") $
              (MkResult 1 >>= op) ?== MkResult 2,
              counterexample' (s++" MkResult 4 >>= op") $
              (MkResult 4 >>= op) ?== Failure "big",
              counterexample' (s++" Fail \"foo\" >>= op") $
              (Failure "foo" >>= op) ?== Failure "foo",
              counterexample' (s++" NoResult >>= op") $
              (NoResult >>= op) ?== NoResult]

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

ex8_fmap_1 = property $
  do i <- choose (0,10)
     let op = fmap (+1) getSL
     return $ counterexample ("runSL (fmap (+1) getSL) " ++ show i) $
       runSL op i ?== (i+1,i,[])

ex8_fmap_2 = property $
  do m <- word
     s <- choose (0,10)
     let op = fmap (const True) (msgSL m)
     return $ counterexample ("runSL (fmap (const True) (msgSL "++show m++")) "++show s) $
       runSL op s ?== (True,s,[m])

ex8_1 = property $
  do i <- choose (0,10)
     let op = putSL i >> getSL >>= \i -> msgSL (show i)
         s = "putSL "++show i++" >> getSL >>= \\i -> msgSL (show i)"
     return $ counterexample ("runSL ("++s++") 1") $ runSL op 1 ?== ((),i,[show i])

ex8_2 = property $
  do msg <- word
     msg2 <- word
     i <- choose (0,10)
     j <- choose (0,10)
     let op = do msgSL msg
                 x <- getSL
                 msgSL (msg2++show x)
                 putSL (x+i)
                 return x
         s = "op = \ndo msgSL "++show msg++"\n   x <- getSL\n   msgSL ("++show msg2++"++show x)\n   putSL (x+"++show i++")\n   return x"
     return $ counterexample (s++"\n\nrunSL op "++show j) $ runSL op j ?== (j,j+i,[msg,msg2++show j])

ex8_stress =
  forAll_ $ \ops ->
  let m (Left i) = modifySL (+i)
      m (Right s) = msgSL s
      s (Left i) = "modifySL (+"++show i++")"
      s (Right m) = "msgSL "++show m
      op = mapM_ m ops
      desc = "runSL ("++intercalate " >> " (map s ops)++") 0"
      (incs,msgs) = partitionEithers ops
      state = sum incs
  in counterexample desc $ runSL op 0 ?== ((),state,msgs)

ex9_mkCounter = forAllBlind (choose (0,20)) $ \n ->
  counterexample "(inc,get) <- mkCounter" $
  counterexample (" Called inc "++show n++" times, then called get") $
  monadicIO $ do m <- run $ do (i,g) <- mkCounter
                               replicateM_ n i
                               g
                 stop_ $ m ?== n