import StackSet
import Data.Maybe
import System.Environment
import Control.Exception (assert)
import Control.Monad
import Test.QuickCheck
import System.IO
import System.Random
import Text.Printf
import Data.List (nub,sort,group,sort,intersperse)
import Data.Map (keys,elems)
-- ---------------------------------------------------------------------
-- QuickCheck properties for the StackSet
-- | Height of stack 'n'
height :: Int -> StackSet a -> Int
height i w = length (index i w)
-- build (non-empty) StackSets with between 1 and 100 stacks
instance (Ord a, Arbitrary a) => Arbitrary (StackSet a) where
arbitrary = do
sz <- choose (1,20)
n <- choose (0,sz-1)
ls <- vector sz
return $ fromList (n,ls)
coarbitrary = error "no coarbitrary for StackSet"
prop_id x = fromList (toList x) == x
where _ = x :: T
prop_member1 i n = member i (push i x)
where x = empty n :: T
prop_member2 i x = not (member i (delete i x))
where _ = x :: T
prop_member3 i n = member i (empty n :: T) == False
prop_sizepush is n = n > 0 ==> size (foldr push x is ) == n
where x = empty n :: T
prop_currentpush is n = n > 0 ==>
height (current x) (foldr push x js) == length js
where
js = nub is
x = empty n :: T
prop_pushpeek x is = not (null is) ==> fromJust (peek (foldr push x is)) == head is
where _ = x :: T
prop_peekmember x = case peek x of
Just w -> member w x
Nothing -> True {- then we don't know anything -}
where _ = x :: T
type T = StackSet Int
prop_delete_uniq i x = not (member i x) ==> delete i x == x
where _ = x :: T
prop_delete2 i x =
delete i x == delete i (delete i x)
where _ = x :: T
prop_rotaterotate x = rotate LT (rotate GT x) == x
where _ = x :: T
prop_viewview r x =
let n = current x
sz = size x
i = r `mod` sz
in view n (view i x) == x
where _ = x :: T
prop_shiftshift r x =
let n = current x
in shift n (shift r x) == x
where _ = x :: T
prop_fullcache x = cached == allvals where
cached = sort . keys $ cache x
allvals = sort . concat . elems $ stacks x
_ = x :: T
------------------------------------------------------------------------
main :: IO ()
main = do
args <- getArgs
let n = if null args then 100 else read (head args)
mapM_ (\(s,a) -> printf "%-25s: " s >> a n) tests
where
n = 100
tests =
[("read.show ", mytest prop_id)
,("member/push ", mytest prop_member1)
,("member/peek ", mytest prop_peekmember)
,("member/delete ", mytest prop_member2)
,("member/empty ", mytest prop_member3)
,("size/push ", mytest prop_sizepush)
,("height/push ", mytest prop_currentpush)
,("push/peek ", mytest prop_pushpeek)
,("delete/not.member", mytest prop_delete_uniq)
,("delete idempotent", mytest prop_delete2)
,("rotate/rotate ", mytest prop_rotaterotate)
,("view/view ", mytest prop_viewview)
,("fullcache ", mytest prop_fullcache)
]
debug = False
mytest :: Testable a => a -> Int -> IO ()
mytest a n = mycheck defaultConfig
{ configMaxTest=n
, configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a
mycheck :: Testable a => Config -> a -> IO ()
mycheck config a = do
rnd <- newStdGen
mytests config (evaluate a) rnd 0 0 []
mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO ()
mytests config gen rnd0 ntest nfail stamps
| ntest == configMaxTest config = do done "OK," ntest stamps
| nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps
| otherwise =
do putStr (configEvery config ntest (arguments result)) >> hFlush stdout
case ok result of
Nothing ->
mytests config gen rnd1 ntest (nfail+1) stamps
Just True ->
mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps)
Just False ->
putStr ( "Falsifiable after "
++ show ntest
++ " tests:\n"
++ unlines (arguments result)
) >> hFlush stdout
where
result = generate (configSize config ntest) rnd2 gen
(rnd1,rnd2) = split rnd0
done :: String -> Int -> [[String]] -> IO ()
done mesg ntest stamps = putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table )
where
table = display
. map entry
. reverse
. sort
. map pairLength
. group
. sort
. filter (not . null)
$ stamps
display [] = ".\n"
display [x] = " (" ++ x ++ ").\n"
display xs = ".\n" ++ unlines (map (++ ".") xs)
pairLength xss@(xs:_) = (length xss, xs)
entry (n, xs) = percentage n ntest
++ " "
++ concat (intersperse ", " xs)
percentage n m = show ((100 * n) `div` m) ++ "%"
------------------------------------------------------------------------
