diff options
| -rw-r--r-- | StackSet.hs | 175 |
1 files changed, 4 insertions, 171 deletions
diff --git a/StackSet.hs b/StackSet.hs index 7c388f2..9f8cdb6 100644 --- a/StackSet.hs +++ b/StackSet.hs @@ -1,4 +1,3 @@ -{-# OPTIONS -cpp #-} ----------------------------------------------------------------------------- -- | -- Module : StackSet @@ -17,13 +16,15 @@ module StackSet ( - StackSet, -- abstract + StackSet, -- abstract -- * Introduction empty, -- :: Int -> StackSet a fromList, -- :: [[a]] -> StackSet a + toList, -- :: StackSet -> [[a]] -- * Inspection + size, -- :: StackSet -> Int member, -- :: Ord a => a -> StackSet a -> Bool peek, -- :: StackSet a -> Maybe a stack, -- :: StackSet a -> [a] @@ -38,6 +39,7 @@ module StackSet ( -- * Modification to arbitrary stacks delete, -- :: Ord a => a -> StackSet a -> StackSet a + insert, -- :: Ord a => a -> Int -> StackSet a -> StackSet a -- * Changing which stack is 'current' view, -- :: Int -> StackSet a -> StackSet a @@ -50,17 +52,6 @@ import qualified Data.List as L import qualified Data.Map as M import qualified Data.Sequence as S --- All for testing: -#if TESTING -import Control.Exception (assert) -import Control.Monad -import Test.QuickCheck -import System.IO -import System.Random -import Text.Printf -import Data.List (sort,group,sort,intersperse) -#endif - ------------------------------------------------------------------------ -- | The StackSet data structure. A table of stacks, with a cursor @@ -223,161 +214,3 @@ delete k w = case M.lookup k (cache w) of unsafeModify :: ([a] -> [a]) -> StackSet a -> StackSet a unsafeModify f w = w { stacks = S.adjust f (cursor w) (stacks w) } - -#if TESTING --- --------------------------------------------------------------------- --- QuickCheck properties - --- | Height of stack 'n' -height :: Int -> StackSet a -> Int -height i w = length (S.index (stacks w) i) - --- 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 :: StackSet Int - -prop_uniq_pushpop i x = not (member i x) ==> - (pop . push i) x == x - where _ = x :: StackSet Int - -prop_pushpop i x = - (pop . push i) x == delete i x - where _ = x :: StackSet Int - --- popping an empty stack leaves an empty stack -prop_popempty x = height (cursor x) x == 0 ==> pop x == x - where _ = x :: StackSet Int - -prop_popone x = - let l = height (cursor x) x - in l > 0 ==> height (cursor x) (pop x) == l-1 - where _ = x :: StackSet Int - --- check the cache of the size works -prop_size_length x = - size x == S.length (stacks x) - where _ = x :: StackSet Int - -prop_delete_uniq i x = not (member i x) ==> - delete i x == x - where _ = x :: StackSet Int - -prop_delete2 i x = - delete i x == delete i (delete i x) - where _ = x :: StackSet Int - -prop_uniq_insertdelete i n x = not (member i x) ==> - delete i (insert i n x) == x - where _ = x :: StackSet Int - -prop_insertdelete i n x = - delete i (insert i n x) == delete i x - where _ = x :: StackSet Int - -prop_rotaterotate x = rotate LT (rotate GT x) == x - where _ = x :: StackSet Int - -prop_viewview r x = - let n = cursor x - sz = size x - i = r `mod` sz - in - view n (view i x) == x - - where _ = x :: StackSet Int - -prop_shiftshift r x = - let n = cursor x - in - shift n (shift r x) == x - where _ = x :: StackSet Int - ------------------------------------------------------------------------- - -testall :: IO () -testall = mapM_ (\(s,a) -> printf "%-25s: " s >> a n) tests - where - n = 100 - - tests = - [("fromList.toList ", mytest prop_id) - ,("pop/push ", mytest prop_uniq_pushpop) - ,("pop/push/delete ", mytest prop_pushpop) - ,("pop/empty ", mytest prop_popempty) - ,("size/length ", mytest prop_size_length) - ,("delete/not.member", mytest prop_delete_uniq) - ,("delete idempotent", mytest prop_delete2) - ,("delete/insert new", mytest prop_uniq_insertdelete) - ,("delete/insert ", mytest prop_insertdelete) - ,("rotate/rotate ", mytest prop_rotaterotate) - ,("pop one ", mytest prop_popone) - ,("view/view ", mytest prop_viewview) - ] - -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) ++ "%" - ------------------------------------------------------------------------- -#endif |