diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,8 @@ +Version 0.4.4: (2010-12-24) + + * Simplified the implementation of `mergeAll` and `unionAll` based on + comments from Will Ness. + Version 0.4.3: (2010-03-02) * Improved the implementation of `nubSort`, mirroring the improvements made @@ -18,7 +23,9 @@ Version 0.4.1: (2010-02-17) * Simplified the implementation of `mergeAll` and `unionAll` thanks - to some pointers by Heinrich Apfelmus. + to some pointers by Heinrich Apfelmus. This introduced an infinite + non-productive loop into `unionAll`, which was later fixed without + giving up the simplifications. * Minor documentation fixes diff --git a/Data/List/Ordered.hs b/Data/List/Ordered.hs --- a/Data/List/Ordered.hs +++ b/Data/List/Ordered.hs @@ -37,8 +37,8 @@ , minus, minusBy , xunion, xunionBy , merge, mergeBy - , mergeAll, mergeAllBy - , unionAll, unionAllBy + , mergeAll , mergeAllBy + , unionAll , unionAllBy -- * Lists to Ordered Lists , nub, nubBy @@ -52,7 +52,7 @@ import Data.List(sort,sortBy) -- | The 'isSorted' predicate returns 'True' if the elements of a list occur in non-descending order, equivalent to @'isSortedBy' ('<=')@. -isSorted :: (Ord a) => [a] -> Bool +isSorted :: Ord a => [a] -> Bool isSorted = isSortedBy (<=) -- | The 'isSortedBy' function returns 'True' iff the predicate returns true @@ -66,7 +66,7 @@ -- | The 'member' function returns 'True' if the element appears in the -- ordered list. -member :: (Ord a) => a -> [a] -> Bool +member :: Ord a => a -> [a] -> Bool member = memberBy compare -- | The 'memberBy' function is the non-overloaded version of 'member'. @@ -82,7 +82,7 @@ -- | The 'has' function returns 'True' if the element appears in the list; -- it is equivalent to 'member' except the order of the arguments is reversed, -- making it a function from an ordered list to its characteristic function. -has :: (Ord a) => [a] -> a -> Bool +has :: Ord a => [a] -> a -> Bool has xs y = memberBy compare y xs -- | The 'hasBy' function is the non-overloaded version of 'has'. @@ -91,7 +91,7 @@ -- | The 'insertBag' function inserts an element into a list. If the element -- is already there, then another copy of the element is inserted. -insertBag :: (Ord a) => a -> [a] -> [a] +insertBag :: Ord a => a -> [a] -> [a] insertBag = insertBagBy compare -- | The 'insertBagBy' function is the non-overloaded version of 'insertBag'. @@ -107,7 +107,7 @@ -- | The 'insertSet' function inserts an element into an ordered list. -- If the element is already there, then the element replaces the existing -- element. -insertSet :: (Ord a) => a -> [a] -> [a] +insertSet :: Ord a => a -> [a] -> [a] insertSet = insertSetBy compare -- | The 'insertSetBy' function is the non-overloaded version of 'insertSet'. @@ -122,17 +122,17 @@ {- -- This function is moderately interesting, as it encompasses all the --- "venn diagram" functions on two sets. (though not merge; which isn't --- a set function) +-- "Venn diagram" functions on two sets. (though not merge; which isn't +-- a set function) -- However, it doesn't seem that useful, considering that of the 8 possible -- functions, there are only 4 interesting variations: isect, union, minus, --- and xunion. Due to interactions with GHC's optimizer, coded seperately, +-- and xunion. Due to interactions with GHC's optimizer, coded separately, -- these have a smaller combined object code size than the object code size -- for genSectBy. (Or, turn off certain optimizations and lose speed.) -- Each individual object code can be recovered from genSectBy via GHC's --- inliner and constant propogation; but this doesn't save much in terms +-- inliner and constant propagation; but this doesn't save much in terms -- of source code size and reduces portability. -- Note that the Static Argument Transformation is necessary for this to work @@ -145,28 +145,45 @@ -> [a] -> [a] -> [a] genSectBy cmp p = loop where - loop [] ys | p False True = ys - | otherwise = [] - loop xs [] | p True False = xs - | otherwise = [] - loop (x:xs) (y:ys) - = case cmp x y of + loop [] ys | p False True = ys + | otherwise = [] + loop xs [] | p True False = xs + | otherwise = [] + loop (x:xs) (y:ys) + = case cmp x y of LT | p True False -> x : loop xs (y:ys) | otherwise -> loop xs (y:ys) EQ | p True True -> x : loop xs ys | otherwise -> loop xs ys GT | p False True -> y : loop (x:xs) ys | otherwise -> loop (x:xs) ys + +-- Here's another variation that was suggested to me. It is more general +-- than genSectBy, as it can implement a merge; but it cannot implement +-- a left-biased merge + +foldrMergeBy :: (a -> b -> Ordering) + -> (a -> c -> c) -> (b -> c -> c) -> (a -> b -> c -> c) -> c + -> [a] -> [b] -> c +foldrMergeBy cmp addA addB unify z = loop + where + loop xs [] = foldr addA z xs + loop [] ys = foldr addB z ys + loop (x:xs) (y:ys) + = case cmp x y of + LT -> x `addA` loop xs (y:ys) + EQ -> unify x y (loop xs ys) + GT -> y `addB` loop (x:xs) ys -} -- | The 'isect' function computes the intersection of two ordered lists. -- An element occurs in the output as many times as the minimum number of --- occurences in either input. If either input is a set, then the output +-- occurrences in either input. If either input is a set, then the output -- is a set. -- -- > isect [ 1,2, 3,4 ] [ 3,4, 5,6 ] == [ 3,4 ] -- > isect [ 1, 2,2,2 ] [ 1,1,1, 2,2 ] == [ 1, 2,2 ] -isect :: (Ord a) => [a] -> [a] -> [a] +isect :: Ord a => [a] -> [a] -> [a] isect = isectBy compare -- | The 'isectBy' function is the non-overloaded version of 'isect'. @@ -183,12 +200,12 @@ -- | The 'union' function computes the union of two ordered lists. -- An element occurs in the output as many times as the maximum number --- of occurences in either input. If both inputs are sets, then the +-- of occurrences in either input. If both inputs are sets, then the -- output is a set. -- -- > union [ 1,2, 3,4 ] [ 3,4, 5,6 ] == [ 1,2, 3,4, 5,6 ] -- > union [ 1, 2,2,2 ] [ 1,1,1, 2,2 ] == [ 1,1,1, 2,2,2 ] -union :: (Ord a) => [a] -> [a] -> [a] +union :: Ord a => [a] -> [a] -> [a] union = unionBy compare -- | The 'unionBy' function is the non-overloaded version of 'union'. @@ -210,7 +227,7 @@ -- -- > minus [ 1,2, 3,4 ] [ 3,4, 5,6 ] == [ 1,2 ] -- > minus [ 1, 2,2,2 ] [ 1,1,1, 2,2 ] == [ 2 ] -minus :: (Ord a) => [a] -> [a] -> [a] +minus :: Ord a => [a] -> [a] -> [a] minus = minusBy compare -- | The 'minusBy' function is the non-overloaded version of 'minus'. @@ -232,7 +249,7 @@ -- -- > xunion [ 1,2, 3,4 ] [ 3,4, 5,6 ] == [ 1,2, 5,6 ] -- > xunion [ 1, 2,2,2 ] [ 1,1,1, 2,2 ] == [ 1,1, 2 ] -xunion :: (Ord a) => [a] -> [a] -> [a] +xunion :: Ord a => [a] -> [a] -> [a] xunion = xunionBy compare -- | The 'xunionBy' function is the non-overloaded version of 'xunion'. @@ -249,11 +266,11 @@ -- | The 'merge' function combines all elements of two ordered lists. -- An element occurs in the output as many times as the sum of the --- occurences in the lists. +-- occurrences in the lists. -- -- > merge [ 1,2, 3,4 ] [ 3,4, 5,6 ] == [ 1,2, 3,3,4,4, 5,6 ] -- > merge [ 1, 2,2,2 ] [ 1,1,1, 2,2 ] == [ 1,1,1,1, 2,2,2,2,2 ] -merge :: (Ord a) => [a] -> [a] -> [a] +merge :: Ord a => [a] -> [a] -> [a] merge = mergeBy compare -- | The 'mergeBy' function is the non-overloaded version of 'merge'. @@ -269,7 +286,7 @@ -- | The 'subset' function returns true if the first list is a sub-list -- of the second. -subset :: (Ord a) => [a] -> [a] -> Bool +subset :: Ord a => [a] -> [a] -> Bool subset = subsetBy compare -- | The 'subsetBy' function is the non-overloaded version of 'subset'. @@ -285,7 +302,7 @@ GT -> loop (x:xs) ys {- --- This is Ian Lynagh's mergesort implementation, which appears as +-- This is Ian Lynagh's mergesort implementation, which appeared as -- Data.List.sort, with the static argument transformation applied. -- It's not clear whether this modification is truly worthwhile or not. @@ -293,7 +310,7 @@ sort = sortBy compare sortBy :: (a -> a -> Ordering) -> [a] -> [a] -sortBy cmp = foldTree merge . map (\x -> [x]) +sortBy cmp = foldTree (mergeBy cmp) [] . map (\x -> [x]) -} -- | The 'sortOn' function provides the decorate-sort-undecorate idiom, @@ -317,12 +334,12 @@ -- | The 'nubSortBy' function is the non-overloaded version of 'nubSort'. nubSortBy :: (a -> a -> Ordering) -> [a] -> [a] -nubSortBy cmp = foldTree (unionBy cmp) . runs +nubSortBy cmp = foldTree' (unionBy cmp) [] . runs where -- 'runs' partitions the input into sublists that are monotonic, - -- contiguous, and non-overlapping. Descending runs are - -- reversed and adjacent duplicates are eliminated, so - -- every run returned is strictly ascending. + -- contiguous, and non-overlapping. Descending runs are reversed + -- and adjacent duplicates are eliminated, so every run returned is + -- strictly ascending. runs (a:b:xs) = case cmp a b of @@ -361,7 +378,7 @@ -- > nub [2,0,1,3,3] == [2,3] -- > nub = nubBy (<) -nub :: (Ord a) => [a] -> [a] +nub :: Ord a => [a] -> [a] nub = nubBy (<) -- | The 'nubBy' function is the greedy algorithm that returns a @@ -381,112 +398,92 @@ | p x y = y : loop y ys | otherwise = loop x ys --- Helper function used in nubSortBy +-- | The function @'foldTree'' plus zero@ computes the sum of a list +-- using a balanced tree of operations. 'foldTree'' necessarily diverges +-- on infinite lists, hence it is a stricter variant of 'foldTree'. +-- 'foldTree'' is used in the implementation of 'sort' and 'nubSort'. -foldTree _ [] = undefined -foldTree f xs = loop xs +foldTree' :: (a -> a -> a) -> a -> [a] -> a +foldTree' plus zero xs + = case xs of + [] -> zero + (_:_) -> loop xs where loop [x] = x loop xs = loop (pairs xs) - pairs (x:y:zs) = f x y : pairs zs - pairs zs = zs - --- Helper functions used in 'mergeAll' and 'unionAll' + pairs (x:y:zs) = plus x y : pairs zs + pairs zs = zs -data People a = VIP a (People a) | Crowd [a] +-- | The function @'foldTree' plus zero@ computes the sum of a list using +-- a sequence of balanced trees of operations. Given an appropriate @plus@ +-- operator, this function can be productive on an infinite list, hence it +-- is lazier than 'foldTree''. 'foldTree' is used in the implementation of +-- 'mergeAll' and 'unionAll'. -lazyFoldTree _ [] = Crowd [] -lazyFoldTree f xs = loop xs +foldTree :: (a -> a -> a) -> a -> [a] -> a +foldTree plus zero xs + = case xs of + [] -> zero + (_:_) -> loop xs where loop [x] = x - loop (x:xs) = x `f` loop (pairs xs) - - pairs (x:y:ys) = f x y : pairs ys - pairs xs = xs - -serve (VIP x xs) = x:serve xs -serve (Crowd xs) = xs + loop (x:xs) = x `plus` loop (pairs xs) -vips xss = [ VIP x (Crowd xs) | (x:xs) <- xss ] + pairs (x:y:zs) = plus x y : pairs zs + pairs zs = zs --- | The 'mergeAll' function generalizes @'foldr' 'merge' []@ to a --- (possibly infinite) list of (possibly infinite) ordered lists. To make --- this possible, it adds the assumption that the heads of the non-empty --- lists themselves form a sorted list. --- --- The implementation is based on the article \"Implicit Heaps\" by --- Heinrich Apfelmus, which simplifies an algorithm by Dave Bayer. --- --- --- --- The following definition is a simple and reasonably efficient implementation --- that is faster for inputs whose smallest elements are highly biased --- towards the first few lists: +-- | The 'mergeAll' function merges a (potentially) infinite number of +-- ordered lists, under the assumption that the heads of the inner lists +-- are sorted. An element is duplicated in the result as many times as +-- the total number of occurrences in all inner lists. -- --- > mergeAll' = foldr merge' [] --- > where merge' [] ys = ys --- > merge' (x:xs) ys = x : merge xs ys +-- The 'mergeAll' function is closely related to @'foldr' 'merge' []@. +-- The former does not assume that the outer list is finite, whereas +-- the latter makes no assumption about the heads of the inner lists. +-- When both sets of assumptions are met, these two functions are +-- equivalent. -- --- This simplification uses a linear chain of comparisons. The --- implementation provided uses a tree of comparisons, which is faster on a --- wide range of inputs. -mergeAll :: (Ord a) => [[a]] -> [a] +-- This implementation of 'mergeAll' uses a tree of comparisons, and is +-- based on input from Dave Bayer, Heinrich Apfelmus, Omar Antolin Camarena, +-- and Will Ness. +mergeAll :: Ord a => [[a]] -> [a] mergeAll = mergeAllBy compare -- | The 'mergeAllBy' function is the non-overloaded variant of the 'mergeAll' function. mergeAllBy :: (a -> a -> Ordering) -> [[a]] -> [a] -mergeAllBy cmp = serve . lazyFoldTree merge' . vips +mergeAllBy cmp = foldTree merge' [] where - merge' (VIP x xs) ys = VIP x (merge' xs ys) - merge' (Crowd []) ys = ys - merge' (Crowd xs) (Crowd ys) = Crowd (mergeBy cmp xs ys) - merge' xs@(Crowd (x:xt)) ys@(VIP y yt) - = case cmp x y of - GT -> VIP y (merge' xs yt) - _ -> VIP x (merge' (Crowd xt) ys) + merge' [] ys = ys + merge' (x:xs) ys = x : mergeBy cmp xs ys --- | The 'unionAll' function generalizes @'foldr' 'union' []@ to a --- (possibly infinite) list of (possibly infinite) ordered lists. --- To make this possible, it adds the assumption that the heads of the --- non-empty lists themselves form a sorted list. --- --- The library implementation is based on some of the same techniques --- as used in 'mergeAll'. However, the analogous simple definition --- is not entirely satisfactory, because --- --- > unionAll' = foldr union' [] --- > where union' [] ys = ys --- > union' (x:xs) ys = x : union xs ys --- > --- > unionAll' [[1,2],[1,2]] == [1,1,2] --- --- whereas we really want the result +-- | The 'unionAll' computes the union of a (potentially) infinite number +-- of lists, under the assumption that the heads of the inner lists +-- are sorted. The result will duplicate an element as many times as +-- the maximum number of occurrences in any single list. Thus, the result +-- is a set if and only if every inner list is a set. -- --- > unionAll [[1,2],[1,2]] == foldr union [] [[1,2],[1,2]] == [1,2] +-- Analogous to 'mergeAll', 'unionAll' is closely related to +-- @'foldr' 'union' []@; The outer does not assume that the outer list +-- is finite, whereas the right fold does not assume anything about the +-- heads of the inner lists. When both sets of assumptions are met, the +-- functions are equivalent. -- --- The first equality is only true when both sets of assumptions are met: --- @foldr union []@ assumes the outer list is finite, and 'unionAll' --- assumes that the heads of the inner lists are sorted. -unionAll :: (Ord a) => [[a]] -> [a] +-- This implementation is also based on implicit heaps, providing +-- a tree of comparisons. +unionAll :: Ord a => [[a]] -> [a] unionAll = unionAllBy compare -- | The 'unionAllBy' function is the non-overloaded variant of the 'unionAll' function. unionAllBy :: (a -> a -> Ordering) -> [[a]] -> [a] -unionAllBy cmp = serve . lazyFoldTree union' . vips +unionAllBy cmp = foldTree union' [] where msg = "Data.List.Ordered.unionAllBy: the heads of the lists are not sorted" - union' (VIP x xs) ys - = VIP x $ case ys of - Crowd _ -> union' xs ys - VIP y yt -> case cmp x y of - LT -> union' xs ys - EQ -> union' xs yt - GT -> error msg - union' (Crowd []) ys = ys - union' (Crowd xs) (Crowd ys) = Crowd (unionBy cmp xs ys) - union' xs@(Crowd (x:xt)) ys@(VIP y yt) - = case cmp x y of - LT -> VIP x (union' (Crowd xt) ys) - EQ -> VIP x (union' (Crowd xt) yt) - GT -> VIP y (union' xs yt) + + union' [] ys = ys + union' (x:xs) ys = x : case ys of + [] -> xs + (y:yt) -> case cmp x y of + LT -> unionBy cmp xs ys + EQ -> unionBy cmp xs yt + GT -> error msg diff --git a/data-ordlist.cabal b/data-ordlist.cabal --- a/data-ordlist.cabal +++ b/data-ordlist.cabal @@ -1,5 +1,5 @@ Name: data-ordlist -Version: 0.4.3 +Version: 0.4.4 Description: This module provides set and multiset operations on ordered lists. License: BSD3 @@ -22,4 +22,4 @@ source-repository this type: darcs location: http://patch-tag.com/r/lpsmith/data-ordlist/pullrepo - tag: 0.4.3 + tag: 0.4.4 diff --git a/test/Main.hs b/test/Main.hs deleted file mode 100644 --- a/test/Main.hs +++ /dev/null @@ -1,207 +0,0 @@ -import qualified Data.List as List -import Data.List.Ordered -import Test.QuickCheck -import Test.QuickCheck.Arbitrary - -prop_member :: NonNegative Int -> Positive Int -> Bool -prop_member (NonNegative n) (Positive d) - = member n [0,d..] == (n `mod` d == 0) - -prop_insertBag_sort :: [Int] -> Bool -prop_insertBag_sort xs = foldr insertBag [] xs == sort xs - -prop_insertSet_nubSort :: [Int] -> Bool -prop_insertSet_nubSort xs = foldr insertSet [] xs == nubSort xs - -prop_nub :: OrderedList Int -> Bool -prop_nub (Ordered xs) = List.nub xs == nub xs - -prop_nub_isSorted :: [Int] -> Bool -prop_nub_isSorted xs = isSortedBy (<) (nub xs) - -prop_nubSort_isSorted :: [Int] -> Bool -prop_nubSort_isSorted xs = isSortedBy (<) (nubSort xs) - -prop_isect_subset :: OrderedList Int -> OrderedList Int -> Bool -prop_isect_subset (Ordered xs) (Ordered ys) - = let zs = isect xs ys - in zs `subset` xs && zs `subset` ys - -prop_isect_examples - = isect [1,2,3,4] [3,4,5,6] == [3,4] - && isect [1,3,5] [2,4,6] == [] - && isect [2,4,6,8] [3,6,9] == [6] - && isect [1,2,2,2] [1,1,1,2,2] == [1,2,2] - -prop_union_subset :: OrderedList Int -> OrderedList Int -> Bool -prop_union_subset (Ordered xs) (Ordered ys) - = let zs = union xs ys - in xs `subset` zs && ys `subset` zs - -prop_isect_subset_union :: OrderedList Int -> OrderedList Int -> Bool -prop_isect_subset_union (Ordered xs) (Ordered ys) - = isect xs ys `subset` union xs ys - -prop_union_examples - = union [1,2,3,4] [3,4,5,6] == [1..6] - && union [1,3,5] [2,4,6] == [1..6] - && union [2,4,6,8] [3,6,9] == [2,3,4,6,8,9] - && union [1,2,2,2] [1,1,1,2,2] == [1,1,1,2,2,2] - -prop_minus_subset :: OrderedList Int -> OrderedList Int -> Bool -prop_minus_subset (Ordered xs) (Ordered ys) - = minus xs ys `subset` xs - -prop_minus_examples - = minus [1,2,3,4] [3,4,5,6] == [1,2] - && minus [1,3,5] [2,4,6] == [1,3,5] - && minus [2,4,6,8] [3,6,9] == [2,4,8] - && minus [1,2,2,2] [1,1,1,2,2] == [2] - -prop_xunion_subset_union :: OrderedList Int -> OrderedList Int -> Bool -prop_xunion_subset_union (Ordered xs) (Ordered ys) - = xunion xs ys `subset` union xs ys - -prop_merge_xunion_isect_union :: OrderedList Int -> OrderedList Int -> Bool -prop_merge_xunion_isect_union (Ordered xs) (Ordered ys) - = merge (xunion xs ys) (isect xs ys) == union xs ys - -prop_merge_union_isect_merge :: OrderedList Int -> OrderedList Int -> Bool -prop_merge_union_isect_merge (Ordered xs) (Ordered ys) - = merge (union xs ys) (isect xs ys) == merge xs ys - -prop_minus_merge_isect_union :: OrderedList Int -> OrderedList Int -> Bool -prop_minus_merge_isect_union (Ordered xs) (Ordered ys) - = minus (merge xs ys) (isect xs ys) == union xs ys - -prop_minus_union_isect_xunion :: OrderedList Int -> OrderedList Int -> Bool -prop_minus_union_isect_xunion (Ordered xs) (Ordered ys) - = minus (union xs ys) (isect xs ys) == xunion xs ys - -prop_xunion_examples - = xunion [1,2,3,4] [3,4,5,6] == [1,2,5,6] - && xunion [1,3,5] [2,4,6] == [1..6] - && xunion [2,4,6,8] [3,6,9] == [2,3,4,8,9] - && xunion [1,2,2,2] [1,1,1,2,2] == [1,1,2] - -prop_merge_subset :: OrderedList Int -> OrderedList Int -> Bool -prop_merge_subset (Ordered xs) (Ordered ys) - = union xs ys `subset` merge xs ys - -prop_merge_examples - = merge [1,2,3,4] [3,4,5,6] == [1,2,3,3,4,4,5,6] - && merge [1,3,5] [2,4,6] == [1,2,3,4,5,6] - && merge [2,4,6,8] [3,6,9] == [2,3,4,6,6,8,9] - && merge [1,2,2,2] [1,1,1,2,2] == [1,1,1,1,2,2,2,2,2] - -prop_nub_examples - = nub [1,1,1,2,2] == [1,2] - && nub [2,0,1,3,3] == [2,3] - -safeHead [] = Nothing -safeHead (a:_) = Just a - -newtype HeadOrderedLists x = HeadOrdered [[x]] deriving (Eq, Ord, Show, Read) - -instance (Ord a, Arbitrary a) => Arbitrary (HeadOrderedLists a) where - arbitrary = (HeadOrdered . sortOn' safeHead . map sort) `fmap` arbitrary - shrink _ = [] - -prop_mergeAll :: HeadOrderedLists Int -> Bool -prop_mergeAll (HeadOrdered xss) - = foldr merge [] xss == mergeAll xss - - -approxEq xs ys = take n xs == take n ys - where n = 1000 - -prop_mergeAll_productive = mergeAll [ [n..] | n <- [1..] ] `approxEq` triangle 1 - where - triangle n = replicate n n ++ triangle (n+1) - -prop_unionAll :: HeadOrderedLists Int -> Bool -prop_unionAll (HeadOrdered xss) - = foldr union [] xss == unionAll xss - -prop_unionAll_productive = unionAll [ [n..] | n <- [1..] ] `approxEq` [1..] - -quickCheckOnce = quickCheckWith (stdArgs {maxSuccess = 1}) - -main = do - putStr "\nprop_member\n" - quickCheck prop_member - - putStr "\nprop_insertBag_sort\n" - quickCheck prop_insertBag_sort - - putStr "\nprop_insertSet_nubSort\n" - quickCheck prop_insertSet_nubSort - - putStr "\nprop_nub\n" - quickCheck prop_nub - - putStr "\nprop_nub_isSorted\n" - quickCheck prop_nub_isSorted - - putStr "\nprop_nubSort_isSorted\n" - quickCheck prop_nubSort_isSorted - - putStr "\nprop_isect_subset\n" - quickCheck prop_isect_subset - - putStr "\nprop_isect_examples\n" - quickCheckOnce prop_isect_examples - - putStr "\nprop_union_subset\n" - quickCheck prop_union_subset - - putStr "\nprop_isect_subset_union\n" - quickCheck prop_isect_subset_union - - putStr "\nprop_union_examples\n" - quickCheckOnce prop_union_examples - - putStr "\nprop_minus_subset\n" - quickCheck prop_minus_subset - - putStr "\nprop_minus_examples\n" - quickCheckOnce prop_minus_examples - - putStr "\nprop_xunion_subset_union\n" - quickCheck prop_xunion_subset_union - - putStr "\nprop_merge_xunion_isect_union\n" - quickCheck prop_merge_xunion_isect_union - - putStr "\nprop_merge_union_isect_merge\n" - quickCheck prop_merge_union_isect_merge - - putStr "\nprop_minus_merge_isect_union\n" - quickCheck prop_minus_merge_isect_union - - putStr "\nprop_minus_union_isect_xunion\n" - quickCheck prop_minus_union_isect_xunion - - putStr "\nprop_xunion_examples\n" - quickCheckOnce prop_xunion_examples - - putStr "\nprop_merge_subset\n" - quickCheck prop_merge_subset - - putStr "\nprop_merge_examples\n" - quickCheckOnce prop_merge_examples - - putStr "\nprop_nub_examples\n" - quickCheckOnce prop_nub_examples - - putStr "\nprop_mergeAll\n" - quickCheck prop_mergeAll - - putStr "\nprop_mergeAll_productive\n" - quickCheckOnce prop_mergeAll_productive - - putStr "\nprop_unionAll\n" - quickCheck prop_unionAll - - putStr "\nprop_unionAll_productive\n" - quickCheckOnce prop_unionAll_productive diff --git a/test/data-list-ordered-tests.hs b/test/data-list-ordered-tests.hs new file mode 100644 --- /dev/null +++ b/test/data-list-ordered-tests.hs @@ -0,0 +1,208 @@ +module Main where + +import qualified Data.List as List +import Data.List.Ordered +import Test.QuickCheck +import Test.QuickCheck.Arbitrary + +prop_member :: NonNegative Int -> Positive Int -> Bool +prop_member (NonNegative n) (Positive d) + = member n [0,d..] == (n `mod` d == 0) + +prop_insertBag_sort :: [Int] -> Bool +prop_insertBag_sort xs = foldr insertBag [] xs == sort xs + +prop_insertSet_nubSort :: [Int] -> Bool +prop_insertSet_nubSort xs = foldr insertSet [] xs == nubSort xs + +prop_nub :: OrderedList Int -> Bool +prop_nub (Ordered xs) = List.nub xs == nub xs + +prop_nub_isSorted :: [Int] -> Bool +prop_nub_isSorted xs = isSortedBy (<) (nub xs) + +prop_nubSort_isSorted :: [Int] -> Bool +prop_nubSort_isSorted xs = isSortedBy (<) (nubSort xs) + +prop_isect_subset :: OrderedList Int -> OrderedList Int -> Bool +prop_isect_subset (Ordered xs) (Ordered ys) + = let zs = isect xs ys + in zs `subset` xs && zs `subset` ys + +prop_isect_examples + = isect [1,2,3,4] [3,4,5,6] == [3,4] + && isect [1,3,5] [2,4,6] == [] + && isect [2,4,6,8] [3,6,9] == [6] + && isect [1,2,2,2] [1,1,1,2,2] == [1,2,2] + +prop_union_subset :: OrderedList Int -> OrderedList Int -> Bool +prop_union_subset (Ordered xs) (Ordered ys) + = let zs = union xs ys + in xs `subset` zs && ys `subset` zs + +prop_isect_subset_union :: OrderedList Int -> OrderedList Int -> Bool +prop_isect_subset_union (Ordered xs) (Ordered ys) + = isect xs ys `subset` union xs ys + +prop_union_examples + = union [1,2,3,4] [3,4,5,6] == [1..6] + && union [1,3,5] [2,4,6] == [1..6] + && union [2,4,6,8] [3,6,9] == [2,3,4,6,8,9] + && union [1,2,2,2] [1,1,1,2,2] == [1,1,1,2,2,2] + +prop_minus_subset :: OrderedList Int -> OrderedList Int -> Bool +prop_minus_subset (Ordered xs) (Ordered ys) + = minus xs ys `subset` xs + +prop_minus_examples + = minus [1,2,3,4] [3,4,5,6] == [1,2] + && minus [1,3,5] [2,4,6] == [1,3,5] + && minus [2,4,6,8] [3,6,9] == [2,4,8] + && minus [1,2,2,2] [1,1,1,2,2] == [2] + +prop_xunion_subset_union :: OrderedList Int -> OrderedList Int -> Bool +prop_xunion_subset_union (Ordered xs) (Ordered ys) + = xunion xs ys `subset` union xs ys + +prop_merge_xunion_isect_union :: OrderedList Int -> OrderedList Int -> Bool +prop_merge_xunion_isect_union (Ordered xs) (Ordered ys) + = merge (xunion xs ys) (isect xs ys) == union xs ys + +prop_merge_union_isect_merge :: OrderedList Int -> OrderedList Int -> Bool +prop_merge_union_isect_merge (Ordered xs) (Ordered ys) + = merge (union xs ys) (isect xs ys) == merge xs ys + +prop_minus_merge_isect_union :: OrderedList Int -> OrderedList Int -> Bool +prop_minus_merge_isect_union (Ordered xs) (Ordered ys) + = minus (merge xs ys) (isect xs ys) == union xs ys + +prop_minus_union_isect_xunion :: OrderedList Int -> OrderedList Int -> Bool +prop_minus_union_isect_xunion (Ordered xs) (Ordered ys) + = minus (union xs ys) (isect xs ys) == xunion xs ys + +prop_xunion_examples + = xunion [1,2,3,4] [3,4,5,6] == [1,2,5,6] + && xunion [1,3,5] [2,4,6] == [1..6] + && xunion [2,4,6,8] [3,6,9] == [2,3,4,8,9] + && xunion [1,2,2,2] [1,1,1,2,2] == [1,1,2] + +prop_merge_subset :: OrderedList Int -> OrderedList Int -> Bool +prop_merge_subset (Ordered xs) (Ordered ys) + = union xs ys `subset` merge xs ys + +prop_merge_examples + = merge [1,2,3,4] [3,4,5,6] == [1,2,3,3,4,4,5,6] + && merge [1,3,5] [2,4,6] == [1,2,3,4,5,6] + && merge [2,4,6,8] [3,6,9] == [2,3,4,6,6,8,9] + && merge [1,2,2,2] [1,1,1,2,2] == [1,1,1,1,2,2,2,2,2] + +prop_nub_examples + = nub [1,1,1,2,2] == [1,2] + && nub [2,0,1,3,3] == [2,3] + +safeHead [] = Nothing +safeHead (a:_) = Just a + +newtype HeadOrderedLists x = HeadOrdered [[x]] deriving (Eq, Ord, Show, Read) + +instance (Ord a, Arbitrary a) => Arbitrary (HeadOrderedLists a) where + arbitrary = (HeadOrdered . sortOn' safeHead . map sort) `fmap` arbitrary + shrink _ = [] + +prop_mergeAll :: HeadOrderedLists Int -> Bool +prop_mergeAll (HeadOrdered xss) + = foldr merge [] xss == mergeAll xss + +approxEq xs ys = take n xs == take n ys + where n = 1000 + +triangle n = replicate n n ++ triangle (n+1) + +prop_mergeAll_productive = mergeAll [ [n..] | n <- [1..] ] `approxEq` triangle 1 + +prop_unionAll :: HeadOrderedLists Int -> Bool +prop_unionAll (HeadOrdered xss) + = foldr union [] xss == unionAll xss + +prop_unionAll_productive = unionAll [ [n..] | n <- [1..] ] `approxEq` [1..] + +quickCheckOnce = quickCheckWith (stdArgs {maxSuccess = 1}) + +main = do + putStr "\nprop_member\n" + quickCheck prop_member + + putStr "\nprop_insertBag_sort\n" + quickCheck prop_insertBag_sort + + putStr "\nprop_insertSet_nubSort\n" + quickCheck prop_insertSet_nubSort + + putStr "\nprop_nub\n" + quickCheck prop_nub + + putStr "\nprop_nub_isSorted\n" + quickCheck prop_nub_isSorted + + putStr "\nprop_nubSort_isSorted\n" + quickCheck prop_nubSort_isSorted + + putStr "\nprop_isect_subset\n" + quickCheck prop_isect_subset + + putStr "\nprop_isect_examples\n" + quickCheckOnce prop_isect_examples + + putStr "\nprop_union_subset\n" + quickCheck prop_union_subset + + putStr "\nprop_isect_subset_union\n" + quickCheck prop_isect_subset_union + + putStr "\nprop_union_examples\n" + quickCheckOnce prop_union_examples + + putStr "\nprop_minus_subset\n" + quickCheck prop_minus_subset + + putStr "\nprop_minus_examples\n" + quickCheckOnce prop_minus_examples + + putStr "\nprop_xunion_subset_union\n" + quickCheck prop_xunion_subset_union + + putStr "\nprop_merge_xunion_isect_union\n" + quickCheck prop_merge_xunion_isect_union + + putStr "\nprop_merge_union_isect_merge\n" + quickCheck prop_merge_union_isect_merge + + putStr "\nprop_minus_merge_isect_union\n" + quickCheck prop_minus_merge_isect_union + + putStr "\nprop_minus_union_isect_xunion\n" + quickCheck prop_minus_union_isect_xunion + + putStr "\nprop_xunion_examples\n" + quickCheckOnce prop_xunion_examples + + putStr "\nprop_merge_subset\n" + quickCheck prop_merge_subset + + putStr "\nprop_merge_examples\n" + quickCheckOnce prop_merge_examples + + putStr "\nprop_nub_examples\n" + quickCheckOnce prop_nub_examples + + putStr "\nprop_mergeAll\n" + quickCheck prop_mergeAll + + putStr "\nprop_mergeAll_productive\n" + quickCheckOnce prop_mergeAll_productive + + putStr "\nprop_unionAll\n" + quickCheck prop_unionAll + + putStr "\nprop_unionAll_productive\n" + quickCheckOnce prop_unionAll_productive