mirror of
https://github.com/iritmaximus/haskell.git
synced 2026-10-12 19:13:39 +03:00
294 lines
11 KiB
Haskell
294 lines
11 KiB
Haskell
{-# 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
|