diff --git a/bench/AVLTree.hs b/bench/AVLTree.hs new file mode 100644 --- /dev/null +++ b/bench/AVLTree.hs @@ -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) + diff --git a/bench/Digraph.hs b/bench/Digraph.hs new file mode 100644 --- /dev/null +++ b/bench/Digraph.hs @@ -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] + diff --git a/bench/Heap.hs b/bench/Heap.hs new file mode 100644 --- /dev/null +++ b/bench/Heap.hs @@ -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 diff --git a/bench/Set.hs b/bench/Set.hs new file mode 100644 --- /dev/null +++ b/bench/Set.hs @@ -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 diff --git a/fitspec.cabal b/fitspec.cabal --- a/fitspec.cabal +++ b/fitspec.cabal @@ -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