fitspec 0.4.2 → 0.4.3
raw patch · 5 files changed
+757/−2 lines, 5 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- bench/AVLTree.hs +250/−0
- bench/Digraph.hs +211/−0
- bench/Heap.hs +46/−0
- bench/Set.hs +243/−0
- fitspec.cabal +7/−2
+ bench/AVLTree.hs view
@@ -0,0 +1,250 @@+module AVLTree+ (+ -- | * External API+ empty+ , insert+ , remove+ , find+ , preOrder+ , inOrder+ , postOrder+ , flatten+ , height+ , nElem+ , isEmpty+ , fromList++ , leaf+ , (//)+ , (\\)+ , (-/)+ , (\-)++ -- | * Internal API+ , Tree(..)+ , node+ , bf+ , v+ , l+ , r+ , rotatell+ , rotaterr+ , rotatelr+ , rotaterl+ , balance+ , same+ , removeRoot+ , removeGreatest+ )+where++-- | Tree definition+data Tree a = Empty |+ Node Int (Tree a) a (Tree a)++-- | Smart node constructor that infers height from given subtrees+node :: Tree a -> a -> Tree a -> Tree a+node lst x rst = Node (max (height lst) (height rst) + 1) lst x rst++-- | Smart node constructor for leafs+leaf :: a -> Tree a+leaf x = node empty x empty++empty :: Tree a+empty = Empty++-- | Left infix tree constructor+(//) :: Tree a -> a -> (Tree a -> Tree a)+(//) = node+infix 6 //++-- | Left infix tree constructor (leaf value)+(-/) :: a -> a -> (Tree a -> Tree a)+x -/ y = node (leaf x) y+infix 6 -/++-- | Right infix tree constructor+(\\) :: (Tree a -> Tree a) -> Tree a -> Tree a+(\\) = ($)+infix 5 \\++-- | Right infix tree constructor (leaf value)+(\-) :: (Tree a -> Tree a) -> a -> Tree a+ctx \- x = ctx (leaf x)+infix 5 \-+++-- | Shows tree in format (1-/2\-3)//4\\(empty//5\-7)+instance (Show a) => Show (Tree a) where+ showsPrec _ Empty = showString "empty"+ showsPrec d (Node _ Empty x Empty) = showParen (d>9) $ showString "leaf " . showsPrec 10 x+ showsPrec d (Node _ lst x rst) = showParen (d>4) $ left . showsPrec 7 x . right+ where left | isLeaf lst = showsPrec 7 (v lst) . showString "-/"+ | otherwise = showsPrec 6 lst . showString "//"+ right | isLeaf rst = showString "\\-" . showsPrec 7 (v rst)+ | otherwise = showString "\\\\" . showsPrec 6 rst++-- | Two trees are equal if they hold the same elements. To check for equality also on the structure of the tree, use "same"+instance (Eq a) => Eq (Tree a) where+ t == u = flatten t == flatten u++instance (Ord a) => Ord (Tree a) where+ t `compare` u = flatten t `compare` flatten u++-- | The function should map values keeping ordering, otherwise you'll get a+-- problematic AVL. The resulting AVL can only be manipulated by 'insert' and+-- 'delete' if it follows the 'Invariants.ordered'.+instance Functor Tree where+ fmap _ Empty = Empty+ fmap f (Node h lst x rst) = Node h (fmap f lst) (f x) (fmap f rst)+++-- | Two trees are **same** if their *values* and *structure* is the same.+-- Every **same** pair of 'Tree's is '==', not every '==' pair of 'Tree's is+-- **same**+infix 4 `same`+same :: Eq a => Tree a -> Tree a -> Bool+Empty `same` Empty = True+(Node _ tlst x trst) `same` (Node _ ulst y urst) = x == y && tlst `same` ulst && trst `same` urst+_ `same` _ = False+++insert :: Ord a => a -> Tree a -> Tree a+insert x Empty = node Empty x Empty+insert x t@(Node _ lt y gt) = balance u+ where u = case x `compare` y of+ EQ -> t+ LT -> node (insert x lt) y gt+ GT -> node lt y (insert x gt)+++remove :: Ord a => a -> Tree a -> Tree a+remove _ Empty = Empty -- no-op+remove x t@(Node _ lst y rst) = balance $+ case x `compare` y of+ EQ -> removeRoot t+ LT -> remove x lst+ GT -> remove x rst+++removeRoot :: Tree a -> Tree a+removeRoot Empty = Empty+removeRoot (Node _ Empty _ Empty) = Empty+removeRoot (Node _ lst _ Empty) = lst+removeRoot (Node _ Empty _ rst) = rst+removeRoot (Node _ lst _ rst) = balance (node nlst y rst)+ where+ (y, nlst) = removeGreatest lst+++removeGreatest :: Tree a -> (a, Tree a)+removeGreatest Empty = errorEmptyTree "removeGreatest"+removeGreatest (Node _ lst x Empty) = (x, lst)+removeGreatest (Node _ lst x rst) = (y, balance (node lst x nrst))+ where+ (y, nrst) = removeGreatest rst+++find :: Ord a => a -> Tree a -> Maybe a+find _ Empty = Nothing+find x (Node _ lt y gt) =+ case x `compare` y of+ EQ -> Just y+ LT -> find x lt+ GT -> find x gt+++preOrder :: Tree a -> [a]+preOrder Empty = []+preOrder (Node _ lst x rst) = [x] ++ preOrder lst ++ preOrder rst++inOrder :: Tree a -> [a]+inOrder Empty = []+inOrder (Node _ lst x rst) = inOrder lst ++ [x] ++ inOrder rst++postOrder :: Tree a -> [a]+postOrder Empty = []+postOrder (Node _ lst x rst) = postOrder lst ++ postOrder rst ++ [x]++-- | Alias for inOrder+flatten :: Tree a -> [a]+flatten = inOrder++fromList :: Ord a => [a] -> Tree a+fromList = foldr insert empty+++-- | Height of a Tree+height :: Tree a -> Int+height Empty = -1+height (Node h _ _ _) = h++-- | Number of values stored in the tree. Note: this is slow, as it actually+-- evaluates the whole "spine" of the tree.+nElem :: Tree a -> Int+nElem Empty = 0+nElem (Node _ lt _ gt) = nElem lt + nElem gt + 1++isEmpty :: Tree a -> Bool+isEmpty Empty = True+isEmpty _ = False++isLeaf :: Tree a -> Bool+isLeaf (Node _ Empty _ Empty) = True+isLeaf _ = False++-- | Balancing factor of a Tree+bf :: Tree a -> Int+bf Empty = 0+bf (Node _ lt _ gt) = height lt - height gt++-- | Value of a node (root)+v :: Tree a -> a+v (Node _ _ x _) = x+v Empty = errorEmptyTree "v"++-- | Left subtree+l :: Tree a -> Tree a+l (Node _ lst _ _) = lst+l Empty = errorEmptyTree "l"++-- | Right subtree+r :: Tree a -> Tree a+r (Node _ _ _ rst) = rst+r Empty = errorEmptyTree "r"++rotatell :: Tree a -> Tree a+rotatell (Node _ (Node _ llst y lrst) x rst) = node llst y (node lrst x rst)+rotatell _ = errorEmptySubtree "rotatell"++rotaterr :: Tree a -> Tree a+rotaterr (Node _ lst x (Node _ rlst y rrst)) = node (node lst x rlst) y rrst+rotaterr _ = errorEmptySubtree "rotaterr"++rotatelr :: Tree a -> Tree a+rotatelr (Node _ lst x rst) = rotatell (node (rotaterr lst) x rst)+rotatelr _ = errorEmptySubtree "rotatelr"++rotaterl :: Tree a -> Tree a+rotaterl (Node _ lst x rst) = rotaterr (node lst x (rotatell rst))+rotaterl _ = errorEmptySubtree "rotaterl"++balance :: Tree a -> Tree a+balance t | bf t > 1 = if bf (l t) == (-1)+ then rotatelr t+ else rotatell t+ | bf t < -1 = if bf (r t) == 1+ then rotaterl t+ else rotaterr t+ | otherwise = t+++errorEmptyTree :: String -> a+errorEmptyTree fun = err fun "empty tree (trying to balance non-AVL tree?)"++errorEmptySubtree :: String -> a+errorEmptySubtree fun = err fun "empty subtree (trying to balance non-AVL tree?)"++err :: String -> String -> a+err fun msg = error ("AVLTree.Internals." ++ fun ++ ": " ++ msg)+
+ bench/Digraph.hs view
@@ -0,0 +1,211 @@+-- A small library of functions on directed graphs+-- using a simple list-of-successors representation.+-- Colin Runciman, May 2015++module Digraph (Digraph(..), okDigraph, strictOrder,+ sources, targets, nodes, preds, succs,+ isNode, isEdge, isPath,+ emptyDigraph, addNode, addEdge, assoc1toNdigraph,+ transitiveClosure, topoSort,+ insert, union, diff, cycles, subgraph, maxDagFrom) where++import GHC.Exts (groupWith)+import Data.List (partition,(\\),sort)+import Data.Maybe (isJust,fromJust)+import Control.Monad (guard)++data Digraph a = D {nodeSuccs :: [(a,[a])]} deriving (Eq, Show)+-- Data invariant: in a digraph pair-list [...(source,targets)...]:+-- (1) pairs are listed in strictly increasing source order+-- (2) each list of targets is in strictly increasing order+-- (3) every element in a list of targets must itself be+-- listed as a "source", though perhaps with [] targets++okDigraph :: (Ord a, Eq a) => Digraph a -> Bool+okDigraph (D d) =+ strictOrder ss && all goodTargetList tss+ where+ ss = map fst d+ tss = map snd d+ goodTargetList ts = strictOrder ts &&+ all (`elemOrd` ss) ts++strictOrder :: (Ord a, Eq a) => [a] -> Bool+strictOrder (x:y:etc) = x < y && strictOrder (y:etc)+strictOrder _ = True++nodes :: Digraph a -> [a]+nodes (D d) = [s | (s,_) <- d]++sources :: Digraph a -> [a]+sources (D d) = [s | (s,ts) <- d, not (null ts)]++targets :: (Ord a, Eq a) => Digraph a -> [a]+targets (D d) = foldr union [] (map snd d)++preds :: (Ord a, Eq a) => a -> Digraph a -> [a]+preds t (D d) = [s | (s,ts) <- d, t `elemOrd` ts]++succs :: (Ord a, Eq a) => a -> Digraph a -> [a]+succs s (D d) = case lookup s d of+ Just ns -> ns+ Nothing -> []++isNode :: (Ord a, Eq a) => a -> Digraph a -> Bool+isNode n (D d) = isJust (lookup n d)++isEdge :: (Ord a, Eq a) => a -> a -> Digraph a -> Bool+isEdge s t (D d) = case lookup s d of+ Just ns -> t `elemOrd` ns+ Nothing -> False++isPath :: (Ord a, Eq a) => a -> a -> Digraph a -> Bool+isPath s t d = t `elemOrd` closeInto d [] [s]++emptyDigraph :: Digraph a+emptyDigraph = D []++addNode :: (Ord a, Eq a) => a -> Digraph a -> Digraph a+addNode s (D d) =+ let (these,those) = span ((< s) . fst) d in+ D $ these +++ case those of+ [] -> [(s,[])]+ (sd,tsd):etc -> if s == sd then error "addNode: already present"+ else (s,[]) : those++addEdge :: (Ord a, Eq a) => a -> a -> Digraph a -> Digraph a+addEdge s t (D d) =+ let (these,those) = span ((< s) . fst) d in+ D $ these +++ case those of+ [] -> [(s,[t])]+ (sd,tsd):etc -> if s == sd then+ if t `elemOrd` tsd then error "addEdge: already present"+ else (s,insert t tsd) : etc+ else (s,[t]) : those++-- The function assoc1toNdigraph derives a digraph from an association list+-- pairing single sources with lists of targets. Sorting is applied to+-- outer and inner lists, so there is no ordering requirement on the argument.+-- If there is more than one pair with the same source, target lists are merged.+-- If the same value appears more than once in a target list, duplicates are removed.+-- If any target does not occur as a source, it is added, with an empty target list.+assoc1toNdigraph :: (Ord a, Eq a) => [(a,[a])] -> Digraph a+assoc1toNdigraph stss = D $ addMissingSources $ mergeAndSortTargets $ sort stss+ where+ mergeAndSortTargets [] = []+ mergeAndSortTargets [(s,ts)] = [(s, nubOrd $ sort ts)]+ mergeAndSortTargets ((s0,ts0):(s1,ts1):etc) =+ if s0 == s1 then mergeAndSortTargets ((s0,ts0++ts1):etc)+ else (s0,nubOrd $ sort ts0) : mergeAndSortTargets ((s1,ts1):etc)+ addMissingSources stss =+ union [(s,[]) | s <- missingSources] stss+ where+ missingSources = allTargets `diff` map fst stss+ allTargets = foldr union [] (map snd stss)++transitiveClosure :: (Ord a, Eq a) => Digraph a -> Digraph a+transitiveClosure d = D $ map (close d) (nodeSuccs d)++close :: (Ord a, Eq a) => Digraph a -> (a,[a]) -> (a,[a])+close d (s,ts) = (s, closeInto d [] ts)++closeInto :: (Ord a, Eq a) => Digraph a -> [a] -> [a] -> [a]+closeInto d clo [] = clo+closeInto d clo (t:ts) =+ case lookup t (nodeSuccs d) of+ Nothing -> closeInto d clo ts+ Just tsuccs -> closeInto d clo' (union (diff tsuccs clo') ts)+ where+ clo' = insert t clo++-- auxiliary functions for ordered list processing++nubOrd :: (Ord a, Eq a) => [a] -> [a]+nubOrd [] = []+nubOrd [x] = [x]+nubOrd (x:y:etc) = if x==y then nubOrd (y:etc) else x : nubOrd (y:etc)++elemOrd :: Ord a => a -> [a] -> Bool+elemOrd x ys = null (diff [x] ys)++insert :: Ord a => a -> [a] -> [a]+insert x ys = union [x] ys++union :: Ord a => [a] -> [a] -> [a]+union [] ys = ys+union (x:xs) [] = x:xs+union (x:xs) (y:ys) = case compare x y of+ LT -> x : union xs (y:ys)+ EQ -> union xs (y:ys)+ GT -> y : union (x:xs) ys++diff :: Ord a => [a] -> [a] -> [a]+diff [] ys = []+diff (x:xs) [] = x:xs+diff (x:xs) (y:ys) = case compare x y of+ LT -> x : diff xs (y:ys)+ EQ -> diff xs ys+ GT -> diff (x:xs) ys++-- The result of cycles lists disjoint maximal subsets of nodes in+-- each of which there is a cycle passing through all nodes.+cycles:: (Ord a, Eq a) => Digraph a -> [[a]]+cycles d =+ let d' = transitiveClosure d+ cycleNodes = filter (hasLoop d') (sources d')+ in+ map (sources . D) $ groupWith snd $ nodeSuccs $ subgraph cycleNodes d'++hasLoop :: Eq a => Digraph a -> a -> Bool+hasLoop d s =+ case lookup s (nodeSuccs d) of+ Nothing -> False+ Just ts -> elem s ts++subgraph :: Eq a => [a] -> Digraph a -> Digraph a+subgraph ns d = D $ [(s,filter (`elem` ns) ts) | (s,ts) <- nodeSuccs d, elem s ns]++-- The result of topoSort d, where d is an acyclic digraph, lists all nodes+-- in an order where each node precedes all its digraph successors;+-- the result is Nothing if d has a cycle.+topoSort :: (Ord a, Eq a) => Digraph a -> Maybe [a]+topoSort (D []) = Just []+topoSort d = do+ guard (not $ null maxima)+ ns <- topoSort (D nodesuccs')+ return $ ns ++ maxima+ where+ (these,those) = partition (null.snd) (nodeSuccs d)+ maxima = nodes (D these)+ nodesuccs' = [(s,ts \\ maxima) | (s,ts) <- those]++-- The result of maxDAGfrom s d is a subgraph of d which is a maximal+-- DAG rooted at node s.+maxDagFrom :: (Ord a, Eq a) => a -> Digraph a -> Digraph a+maxDagFrom s d = md [] [s] (removeAllEdges d) (removeLoops d)++-- In a call md done todo dag d, done is an ordered list of nodes already+-- visited, todo is a disjoint ordered list of nodes to be visited, dag is+-- the dag so far, and d is the full loop-free digraph.+md :: (Ord a, Eq a) => [a] -> [a] -> Digraph a -> Digraph a -> Digraph a+md _ [] dag d = dag+md done (s:ss) dag d =+ case lookup s (nodeSuccs d) of+ Nothing -> md done' ss dag d+ Just ts -> md done' (union (diff ts done) ss) dag' d+ where+ dag' = foldr (uncurry addEdgeIfAcyclic) dag [(s,t) | t <- ts]+ where+ done' = insert s done++addEdgeIfAcyclic :: (Ord a, Eq a) => a -> a -> Digraph a -> Digraph a+addEdgeIfAcyclic s t d = if isPath t s d then d else addEdge s t d++removeLoops :: (Ord a, Eq a) => Digraph a -> Digraph a+removeLoops d = D $ [(s, diff ts [s]) | (s, ts) <- nodeSuccs d]++removeAllEdges :: (Ord a, Eq a) => Digraph a -> Digraph a+removeAllEdges d = D $ [(s, []) | (s, _) <- nodeSuccs d]+
+ bench/Heap.hs view
@@ -0,0 +1,46 @@+-- Heap code from QuickSpec examples.+-- https://github.com/nick8325/quickspec/blob/0.9.6/examples/Heaps.hs+--+-- Copyright (c) 2009-2014, Nick Smallbone+-- https://github.com/nick8325/quickspec/blob/0.9.6/LICENSE (BSD3 license)+module Heap where++data Heap a = Nil | Branch Int a (Heap a) (Heap a) deriving Show++instance Ord a => Eq (Heap a) where+ h1 == h2 = toList h1 == toList h2++toList :: Ord a => Heap a -> [a]+toList Nil = []+toList h = findMin h : toList (deleteMin h)++fromList :: Ord a => [a] -> Heap a+fromList = foldr insert Nil++null :: Heap a -> Bool+null Nil = True+null _ = False++findMin :: Heap a -> a+findMin (Branch _ x _ _) = x++insert :: Ord a => a -> Heap a -> Heap a+insert x h = merge h (branch x Nil Nil)++deleteMin :: Ord a => Heap a -> Heap a+deleteMin (Branch _ _ l r) = merge l r++branch :: Ord a => a -> Heap a -> Heap a -> Heap a+branch x l r | npl l <= npl r = Branch (npl l + 1) x l r+ | otherwise = Branch (npl r + 1) x r l++merge :: Ord a => Heap a -> Heap a -> Heap a+merge Nil h = h+merge h Nil = h+merge h1@(Branch _ x1 l1 r1) h2@(Branch _ x2 l2 r2)+ | x1 <= x2 = branch x1 (merge l1 h2) r1+ | otherwise = merge h2 h1++npl :: Heap a -> Int+npl Nil = 0+npl (Branch n _ _ _) = n
+ bench/Set.hs view
@@ -0,0 +1,243 @@+-- A list-based library for programming with sets.+-- Colin Runciman, June 2007 to April 2008.++module Set (Set, elemList, set, emptyS, singleS, pairS, insertS, deleteS, + sizeS, sizeAtMostS, sizeExactlyS, sizeAtLeastS,+ isEmptyS, nonEmptyS, minS, choiceS, (<~),+ (\/), (/\), (\\), unionS, interS, subS, disjointS,+ elemSubsetsOf, powerS, partitionsS, subsetPartitionsS,+ (<|), allS, anyS, exactly, forAll, thereExists, forExactly,+ minimalS, mapS, mapMonoS, unionMapS, regular) where++import Data.List (nub, sort, intersperse)++infixl 7 /\+infixl 6 \/+infixr 5 `elemSubsetsOf`, `subsetPartitionsS`, <|+infix 4 <~, `subS`++data Set a = S {elemList :: [a]}++instance (Ord a, Eq a) => Eq (Set a)+ where+ S xs == S ys = xs == ys++instance Ord a => Ord (Set a)+ where+ compare (S xs) (S ys) = compare xs ys++instance (Ord a, Show a) => Show (Set a)+ where+ show (S xs) =+ "{"++concat (intersperse "," (map show xs))++"}"++set :: Ord a => [a] -> Set a+set = S . nub . sort++emptyS :: Ord a => Set a+emptyS = S []++singleS :: Ord a => a -> Set a+singleS e = S [e]++pairS :: Ord a => a -> a -> Set a+pairS e1 e2 = set [e1,e2]++insertS :: Ord a => a -> Set a -> Set a+insertS e = S . insertList e . elemList+ where+ insertList e [] = [e]+ insertList e xs@(x:xs') = case compare e x of+ LT -> e : xs+ EQ -> xs+ GT -> x : insertList e xs'++deleteS :: Ord a => a -> Set a -> Set a+deleteS e = S . deleteList e . elemList+ where+ deleteList e [] = []+ deleteList e xs@(x:xs') = case compare e x of+ LT -> xs+ EQ -> xs'+ GT -> x : deleteList e xs'++sizeS :: Ord a => Set a -> Int+sizeS = length . elemList++sizeExactlyS :: Ord a => Int -> Set a -> Bool+sizeExactlyS n = lengthExactly n . elemList+ where+ lengthExactly 0 xs = null xs+ lengthExactly n [] = False+ lengthExactly n (x:xs) = lengthExactly (n-1) xs++sizeAtLeastS :: Ord a => Int -> Set a -> Bool+sizeAtLeastS n = lengthAtLeast n . elemList+ where+ lengthAtLeast 0 xs = True+ lengthAtLeast n [] = False+ lengthAtLeast n (x:xs) = lengthAtLeast (n-1) xs++sizeAtMostS :: Ord a => Int -> Set a -> Bool+sizeAtMostS n = lengthAtMost n . elemList+ where+ lengthAtMost 0 xs = null xs+ lengthAtMost n [] = True+ lengthAtMost n (x:xs) = lengthAtMost (n-1) xs++isEmptyS :: Ord a => Set a -> Bool+isEmptyS = null . elemList++nonEmptyS :: Ord a => Set a -> Bool+nonEmptyS = not . isEmptyS++minS :: Ord a => Set a -> a+minS = head . elemList++choiceS :: Ord a => Set a -> Set (a, Set a)+choiceS = S . choice . elemList+ where+ choice xs = [(x, S (xs1++xs2)) | (xs1,x:xs2) <- splits xs] ++splits :: [a] -> [([a],[a])]+splits [] = [([],[])]+splits (x:xs) = ([],x:xs) : [(x:xs1, xs2) | (xs1,xs2) <- splits xs]++(<~) :: Ord a => a -> Set a -> Bool+(<~) e = ordElem e . elemList+ where+ ordElem e [] = False+ ordElem e (x:xs) = case compare e x of+ LT -> False+ EQ -> True+ GT -> ordElem e xs++(\/) :: Ord a => Set a -> Set a -> Set a+S xs \/ S ys = S (join xs ys)+ where+ join [] ys = ys+ join xs [] = xs+ join xs@(x:xs') ys@(y:ys') =+ case compare x y of+ LT -> x : join xs' ys+ EQ -> x : join xs' ys'+ GT -> y : join xs ys'++(/\) :: Ord a => Set a -> Set a -> Set a+S xs /\ S ys = S (meet xs ys)++meet [] _ = []+meet _ [] = []+meet xs@(x:xs') ys@(y:ys') =+ case compare x y of+ LT -> meet xs' ys+ EQ -> x : meet xs' ys'+ GT -> meet xs ys'++(\\) :: Ord a => Set a -> Set a -> Set a+S xs \\ S ys = S (diff xs ys)++diff [] _ = []+diff xs [] = xs+diff xs@(x:xs') ys@(y:ys') =+ case compare x y of+ LT -> x : diff xs' ys+ EQ -> diff xs' ys'+ GT -> diff xs ys'++unionS :: Ord a => Set (Set a) -> Set a+unionS = foldr (\/) emptyS . elemList++interS :: Ord a => Set (Set a) -> Set a+interS = foldr1 (/\) . elemList++disjointS :: Ord a => Set a -> Set a -> Bool+disjointS (S xs) (S ys) = null (meet xs ys)++subS :: Ord a => Set a -> Set a -> Bool+subS (S xs) (S ys) = null (diff xs ys)++elemSubsetsOf :: Ord a => Int -> Set a -> Set (Set a)+elemSubsetsOf n =+ S . map S . sublistsOf n . elemList+ where+ sublistsOf 0 _ = [[]]+ sublistsOf _ [] = []+ sublistsOf n (x:xs) =+ map (x:) (sublistsOf (n-1) xs) ++ sublistsOf n xs++powerS :: Ord a => Set a -> Set (Set a)+powerS = + S . map S . ([]:) . nonEmptySublists . elemList+ where+ nonEmptySublists [] = []+ nonEmptySublists (x:xs) =+ [x] : map (x:) ss ++ ss+ where+ ss = nonEmptySublists xs++-- outer 'set' used to be 'S' but then ordering between+-- partitions can be wrong+-- TO DO: instead reorder partitionsList computation?+partitionsS :: Ord a => Set a -> Set (Set (Set a))+partitionsS = set . map (S . map S) . partitionsList . elemList+ where+ partitionsList [] = [[]]+ partitionsList (x:xs) =+ [[x] : p | p <- ps] +++ [(x:xs') : xss ++ xss' | p <- ps, (xss,xs':xss') <- splits p]+ where+ ps = partitionsList xs++subsetPartitionsS :: Ord a => Int -> Set a -> Set (Set (Set a))+subsetPartitionsS n = S . map (S . map S) . sublistPartitionsList n . elemList+ where+ sublistPartitionsList n [] = [[] | n == 0]+ sublistPartitionsList n (x:xs) =+ [ [x] : p+ | n > 0, p <- sublistPartitionsList (n-1) xs ] +++ [ (x:xs') : xss ++ xss'+ | n > 0, p <- sublistPartitionsList n xs, (xss,xs':xss') <- splits p ]++(<|) :: Ord a => (a -> Bool) -> Set a -> Set a+(<|) p = S . filter p . elemList++allS, anyS :: Ord a => (a -> Bool) -> Set a -> Bool+allS p = all p . elemList+anyS p = any p . elemList++exactly ::+ Ord a => Int -> (a->Bool) -> Set a -> Bool+exactly n p =+ exactlyList n p . elemList+ where+ exactlyList 0 p xs = not (any p xs)+ exactlyList n p [] = False+ exactlyList n p (x:xs) = exactlyList + (if p x then n-1 else n) p xs++forAll, thereExists :: Ord a => Set a -> (a->Bool) -> Bool+forAll s p = allS p s+thereExists s p = anyS p s++forExactly :: Ord a => Int -> Set a -> (a->Bool) -> Bool+forExactly n s p = exactly n p s++mapS :: (Ord a, Ord b) => (a -> b) -> Set a -> Set b+mapS f = set . map f . elemList++-- more efficient variant when f is monotonic+mapMonoS :: (Ord a, Ord b) => (a -> b) -> Set a -> Set b+mapMonoS f = S . map f . elemList++unionMapS :: (Ord a, Ord b) => (a -> Set b) -> Set a -> Set b+unionMapS f = foldr (\/) emptyS . map f . elemList++minimalS :: Ord a => (Set a -> Bool) -> Set a -> Bool+minimalS p s = (p <| powerS s) == set [s]++regular :: Ord a => Int -> Set (Set a) -> Bool+regular d ss =+ -- every element occurs in exactly d sets+ forAll (unionS ss) $ \e ->+ forExactly d ss $ \s -> e <~ s
fitspec.cabal view
@@ -1,5 +1,5 @@ name: fitspec-version: 0.4.2+version: 0.4.3 synopsis: refining property sets for testing Haskell programs description: FitSpec provides automated assistance in the task of refining test properties@@ -38,7 +38,7 @@ source-repository this type: git location: https://github.com/rudymatela/fitspec- tag: v0.4.2+ tag: v0.4.3 library@@ -91,6 +91,7 @@ benchmark avltrees main-is: avltrees.hs+ other-modules: AVLTree build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell hs-source-dirs: src, bench default-language: Haskell2010@@ -105,6 +106,7 @@ benchmark digraphs main-is: digraphs.hs+ other-modules: Digraph build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell hs-source-dirs: src, bench default-language: Haskell2010@@ -130,6 +132,7 @@ benchmark heaps main-is: heaps.hs+ other-modules: Heap build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell hs-source-dirs: src, bench default-language: Haskell2010@@ -165,6 +168,7 @@ benchmark sets main-is: sets.hs+ other-modules: Set build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell hs-source-dirs: src, bench default-language: Haskell2010@@ -172,6 +176,7 @@ benchmark setsofsets main-is: setsofsets.hs+ other-modules: Set build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell hs-source-dirs: src, bench default-language: Haskell2010