heaps 0.2.1.1 → 0.2.2
raw patch · 6 files changed
+758/−664 lines, 6 filesdep +directorydep +doctestdep +filepathdep ~basesetup-changedPVP ok
version bump matches the API change (PVP)
Dependencies added: directory, doctest, filepath
Dependency ranges changed: base
API changes (from Hackage documentation)
Files
- Data/Heap.hs +0/−660
- Setup.hs +0/−2
- Setup.lhs +7/−0
- heaps.cabal +18/−2
- src/Data/Heap.hs +705/−0
- tests/doctests.hs +28/−0
− Data/Heap.hs
@@ -1,660 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}--------------------------------------------------------------------------------- |--- Module : Data.Heap--- Copyright : (c) Edward Kmett 2010--- License : BSD-style--- Maintainer : ekmett@gmail.com--- Stability : experimental--- Portability : portable------ An efficient, asymptotically optimal, implementation of a priority queues--- extended with support for efficient size, and `Data.Foldable`------ /Note/: Since many function names (but not the type name) clash with--- "Prelude" names, this module is usually imported @qualified@, e.g.------ > import Data.Heap (Heap)--- > import qualified Data.Heap as Heap------ The implementation of 'Heap' is based on /bootstrapped skew binomial heaps/ --- as described by:------ * G. Brodal and C. Okasaki , \"/Optimal Purely Functional Priority Queues/\",--- /Journal of Functional Programming/ 6:839-857 (1996),--- <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.48.973>------ All time bounds are worst-case.--------------------------------------------------------------------------------module Data.Heap- ( - -- * Heap Type- Heap -- instance Eq,Ord,Show,Read,Data,Typeable- -- * Entry type- , Entry(..) -- instance Eq,Ord,Show,Read,Data,Typeable- -- * Basic functions- , empty -- O(1) :: Heap a - , null -- O(1) :: Heap a -> Bool- , size -- O(1) :: Heap a -> Int- , singleton -- O(1) :: Ord a => a -> Heap a- , insert -- O(1) :: Ord a => a -> Heap a -> Heap a- , minimum -- O(1) (/partial/) :: Ord a => Heap a -> a- , deleteMin -- O(log n) :: Heap a -> Heap a- , union -- O(1) :: Heap a -> Heap a -> Heap a- , uncons, viewMin -- O(1)\/O(log n) :: Heap a -> Maybe (a, Heap a)- -- * Transformations- , mapMonotonic -- O(n) :: Ord b => (a -> b) -> Heap a -> Heap b - , map -- O(n) :: Ord b => (a -> b) -> Heap a -> Heap b- -- * To/From Lists- , toUnsortedList -- O(n) :: Heap a -> [a]- , fromList -- O(n) :: Ord a => [a] -> Heap a - , sort -- O(n log n) :: Ord a => [a] -> [a]- , traverse -- O(n log n) :: (Applicative t, Ord b) => (a -> t b) -> Heap a -> t (Heap b)- , mapM -- O(n log n) :: (Monad m, Ord b) => (a -> m b) -> Heap a -> m (Heap b)- , concatMap -- O(n) :: Ord b => Heap a -> (a -> Heap b) -> Heap b- -- * Filtering- , filter -- O(n) :: (a -> Bool) -> Heap a -> Heap a- , partition -- O(n) :: (a -> Bool) -> Heap a -> (Heap a, Heap a)- , split -- O(n) :: a -> Heap a -> (Heap a, Heap a, Heap a)- , break -- O(n log n) :: (a -> Bool) -> Heap a -> (Heap a, Heap a)- , span -- O(n log n) :: (a -> Bool) -> Heap a -> (Heap a, Heap a)- , take -- O(n log n) :: Int -> Heap a -> Heap a- , drop -- O(n log n) :: Int -> Heap a -> Heap a- , splitAt -- O(n log n) :: Int -> Heap a -> (Heap a, Heap a)- , takeWhile -- O(n log n) :: (a -> Bool) -> Heap a -> Heap a- , dropWhile -- O(n log n) :: (a -> Bool) -> Heap a -> Heap a- -- * Grouping- , group -- O(n log n) :: Heap a -> Heap (Heap a)- , groupBy -- O(n log n) :: (a -> a -> Bool) -> Heap a -> Heap (Heap a)- , nub -- O(n log n) :: Heap a -> Heap a- -- * Intersection- , intersect -- O(n log n + m log m) :: Heap a -> Heap a -> Heap a- , intersectWith -- O(n log n + m log m) :: Ord b => (a -> a -> b) -> Heap a -> Heap a -> Heap b- -- * Duplication- , replicate -- O(log n) :: Ord a => a -> Int -> Heap a - ) where--import Prelude hiding - ( map, null- , span, dropWhile, takeWhile, break, filter, take, drop, splitAt- , foldr, minimum, replicate, mapM- , concatMap- )-import qualified Data.List as L-import Control.Applicative (Applicative(pure))-import Control.Monad (liftM)-import Data.Monoid (Monoid(mappend, mempty))-import Data.Foldable hiding (minimum, concatMap)-import Data.Data (DataType, Constr, mkConstr, mkDataType, Fixity(Prefix), Data(..), constrIndex)-import Data.Typeable (Typeable)-import Text.Read-import Text.Show-import qualified Data.Traversable as Traversable-import Data.Traversable (Traversable)---- The implementation of Heap must internally hold onto the dictionary entry for (<=), --- so that it can be made Foldable. Confluence in the absence of incoherent instances--- is provided by the fact that we only ever build these from instances of Ord a (except in the case of groupBy)----- | A min-heap of values @a@.-data Heap a - = Empty - | Heap {-# UNPACK #-} !Int (a -> a -> Bool) {-# UNPACK #-} !(Tree a)- deriving (Typeable)--instance Show a => Show (Heap a) where- showsPrec _ Empty = showString "fromList []"- showsPrec d (Heap _ _ t) = showParen (d > 10) $ - showString "fromList " . - showsPrec 11 (toList t)--instance (Ord a, Read a) => Read (Heap a) where- readPrec = parens $ prec 10 $ do- Ident "fromList" <- lexP- fromList `fmap` step readPrec--instance (Ord a, Data a) => Data (Heap a) where- gfoldl k z h = z fromList `k` toUnsortedList h- toConstr _ = fromListConstr- dataTypeOf _ = heapDataType- gunfold k z c = case constrIndex c of- 1 -> k (z fromList)- _ -> error "gunfold"---heapDataType :: DataType-heapDataType = mkDataType "Data.Heap.Heap" [fromListConstr]--fromListConstr :: Constr-fromListConstr = mkConstr heapDataType "fromList" [] Prefix--instance Eq (Heap a) where- Empty == Empty = True- Empty == Heap{} = False- Heap{} == Empty = False- a@(Heap s1 leq _) == b@(Heap s2 _ _) = s1 == s2 && go leq (toList a) (toList b)- where- go f (x:xs) (y:ys) = f x y && f y x && go f xs ys- go _ [] [] = True- go _ _ _ = False--instance Ord (Heap a) where- Empty `compare` Empty = EQ- Empty `compare` Heap{} = LT- Heap{} `compare` Empty = GT- a@(Heap _ leq _) `compare` b = go leq (toList a) (toList b)- where- go f (x:xs) (y:ys) = - if f x y - then if f y x - then go f xs ys - else LT- else GT- go f [] [] = EQ- go f [] (_:_) = LT- go f (_:_) [] = GT-- --- | /O(1)/. Is the heap empty?------ > Data.Heap.null empty == True--- > Data.Heap.null (singleton 1) == False-null :: Heap a -> Bool-null Empty = True-null _ = False---- | /O(1)/. The number of elements in the heap.--- --- > size empty == 0--- > size (singleton 1) == 1--- > size (fromList [4,1,2]) == 3-size :: Heap a -> Int-size Empty = 0-size (Heap s _ _) = s---- | /O(1)/. The empty heap--- --- > empty == fromList []--- > size empty == 0-empty :: Heap a -empty = Empty---- | /O(1)/. A heap with a single element------ > singleton 1 == fromList [1]--- > singleton 1 == insert 1 empty--- > size (singleton 1) == 1-singleton :: Ord a => a -> Heap a-singleton = singletonWith (<=)--singletonWith :: (a -> a -> Bool) -> a -> Heap a -singletonWith f a = Heap 1 f (Node 0 a Nil)---- | /O(1)/. Insert a new value into the heap.--- --- > insert 2 (fromList [1,3]) == fromList [3,2,1]--- > insert 5 empty == singleton 5--- > size (insert "Item" xs) == 1 + size xs-insert :: Ord a => a -> Heap a -> Heap a-insert = insertWith (<=)--insertWith :: (a -> a -> Bool) -> a -> Heap a -> Heap a-insertWith leq x Empty = singletonWith leq x-insertWith leq x (Heap s _ t@(Node _ y f)) - | leq x y = Heap (s+1) leq (Node 0 x (t `Cons` Nil))- | otherwise = Heap (s+1) leq (Node 0 y (skewInsert leq (Node 0 x Nil) f))---- | /O(1)/. Meld the values from two heaps into one heap.------ > union (fromList [1,3,5]) (fromList [6,4,2]) = fromList [1..6]--- > union (fromList [1,1,1]) (fromList [1,2,1]) = fromList [1,1,1,1,1,2]-union :: Heap a -> Heap a -> Heap a -union Empty q = q-union q Empty = q-union (Heap s1 leq t1@(Node _ x1 f1)) (Heap s2 _ t2@(Node _ x2 f2))- | leq x1 x2 = Heap (s1 + s2) leq (Node 0 x1 (skewInsert leq t2 f1))- | otherwise = Heap (s1 + s2) leq (Node 0 x2 (skewInsert leq t1 f2))---- | /O(log n)/. Create a heap consisting of multiple copies of the same value.------ > replicate 'a' 10 == fromList "aaaaaaaaaa"-replicate :: Ord a => a -> Int -> Heap a -replicate x0 y0 - | y0 < 0 = error "Heap.replicate: negative length"- | y0 == 0 = mempty- | otherwise = f (singleton x0) y0- where- f x y - | even y = f (union x x) (quot y 2)- | y == 1 = x- | otherwise = g (union x x) (quot (y - 1) 2) x- g x y z - | even y = g (union x x) (quot y 2) z- | y == 1 = union x z- | otherwise = g (union x x) (quot (y - 1) 2) (union x z)---- | /O(1)/ access to the minimum element. --- /O(log n)/ access to the remainder of the heap --- same operation as 'viewMin'------ > uncons (fromList [2,1,3]) == Just (1, fromList [3,2])-uncons :: Ord a => Heap a -> Maybe (a, Heap a)-uncons Empty = Nothing-uncons l@(Heap _ _ t) = Just (root t, deleteMin l)---- | Same as 'uncons'-viewMin :: Ord a => Heap a -> Maybe (a, Heap a)-viewMin = uncons---- | /O(1)/. Assumes the argument is a non-'null' heap.------ > minimum (fromList [3,1,2]) == 1-minimum :: Heap a -> a-minimum Empty = error "Heap.minimum: empty heap"-minimum (Heap _ _ t) = root t --trees :: Forest a -> [Tree a]-trees (a `Cons` as) = a : trees as-trees Nil = []---- | /O(log n)/. Delete the minimum key from the heap and return the resulting heap.--- --- > deleteMin (fromList [3,1,2]) == fromList [2,3]-deleteMin :: Heap a -> Heap a -deleteMin Empty = Empty-deleteMin (Heap _ _ (Node _ _ Nil)) = Empty-deleteMin (Heap s leq (Node _ _ f0)) = Heap (s - 1) leq (Node 0 x f3)- where- (Node r x cf, ts2) = getMin leq f0- (zs, ts1, f1) = splitForest r Nil Nil cf - f2 = skewMeld leq (skewMeld leq ts1 ts2) f1- f3 = foldr (skewInsert leq) f2 (trees zs)---- | /O(log n)/. Adjust the minimum key in the heap and return the resulting heap.-adjustMin :: (a -> a) -> Heap a -> Heap a-adjustMin _ Empty = Empty-adjustMin f (Heap s leq (Node r x xs)) = Heap s leq (heapify leq (Node r (f x) xs))--type ForestZipper a = (Forest a, Forest a)--zipper :: Forest a -> ForestZipper a -zipper xs = (Nil, xs)--emptyZ :: ForestZipper a-emptyZ = (Nil, Nil)---- leftZ :: ForestZipper a -> ForestZipper a --- leftZ (x :> path, xs) = (path, x :> xs)--rightZ :: ForestZipper a -> ForestZipper a-rightZ (path, x `Cons` xs) = (x `Cons` path, xs)--adjustZ :: (Tree a -> Tree a) -> ForestZipper a -> ForestZipper a -adjustZ f (path, x `Cons` xs) = (path, f x `Cons` xs)-adjustZ _ z = z--rezip :: ForestZipper a -> Forest a-rezip (Nil, xs) = xs-rezip (x `Cons` path, xs) = rezip (path, x `Cons` xs)---- assumes non-empty zipper-rootZ :: ForestZipper a -> a-rootZ (_ , x `Cons` _) = root x-rootZ _ = error "Heap.rootZ: empty zipper"--minZ :: (a -> a -> Bool) -> Forest a -> ForestZipper a -minZ _ Nil = emptyZ-minZ f xs = minZ' f z z- where z = zipper xs--minZ' :: (a -> a -> Bool) -> ForestZipper a -> ForestZipper a -> ForestZipper a -minZ' _ lo (_, Nil) = lo-minZ' leq lo z = minZ' leq (if leq (rootZ lo) (rootZ z) then lo else z) (rightZ z)--heapify :: (a -> a -> Bool) -> Tree a -> Tree a -heapify _ n@(Node _ _ Nil) = n-heapify leq n@(Node r a as) - | leq a a' = n- | otherwise = Node r a' (rezip (left, heapify leq (Node r' a as') `Cons` right))- where- (left, Node r' a' as' `Cons` right) = minZ leq as- ---- | /O(n)/. Build a heap from a list of values.------ > size (fromList [1,5,3]) == 3--- > fromList . toList = id--- > toList . fromList = sort-fromList :: Ord a => [a] -> Heap a-fromList = foldr insert mempty--fromListWith :: (a -> a -> Bool) -> [a] -> Heap a-fromListWith f = foldr (insertWith f) mempty---- | /O(n log n)/. Perform a heap sort-sort :: Ord a => [a] -> [a]-sort = toList . fromList --instance Monoid (Heap a) where- mempty = empty- mappend = union---- | /O(n)/. Returns the elements in the heap in some arbitrary, very likely unsorted, order.--- --- > toUnsortedList (fromList [3,1,2]) == [1,3,2]--- > fromList . toUnsortedList == id-toUnsortedList :: Heap a -> [a]-toUnsortedList Empty = []-toUnsortedList (Heap _ _ t) = foldMap return t--instance Foldable Heap where- foldMap _ Empty = mempty- foldMap f l@(Heap _ _ t) = f (root t) `mappend` foldMap f (deleteMin l)---- | /O(n)/. Map a function over the heap, returning a new heap ordered appropriately for its fresh contents------ > map negate (fromList [3,1,2]) == fromList [-2,-3,-1]-map :: Ord b => (a -> b) -> Heap a -> Heap b-map _ Empty = Empty-map f (Heap _ _ t) = foldMap (singleton . f) t---- | /O(n)/. Map a monotone increasing function over the heap. --- Provides a better constant factor for performance than 'map', but no checking is performed that the function provided is monotone increasing. Misuse of this function can cause a Heap to violate the heap property.------ > map (+1) (fromList [1,2,3]) = fromList [2,3,4]--- > map (*2) (fromList [1,2,3]) = fromList [2,4,6]-mapMonotonic :: Ord b => (a -> b) -> Heap a -> Heap b-mapMonotonic _ Empty = Empty-mapMonotonic f (Heap s _ t) = Heap s (<=) (fmap f t) ---- * Filter---- | /O(n)/. Filter the heap, retaining only values that satisfy the predicate.--- --- > filter (>'a') (fromList "ab") == singleton 'b'--- > filter (>'x') (fromList "ab") == empty--- > filter (<'a') (fromList "ab") == empty-filter :: (a -> Bool) -> Heap a -> Heap a-filter _ Empty = Empty-filter p (Heap _ leq t) = foldMap f t - where- f x | p x = singletonWith leq x- | otherwise = Empty---- | /O(n)/. Partition the heap according to a predicate. The first heap contains all elements that satisfy the predicate, the second all elements that fail the predicate. See also 'split'.--- --- > partition (>'a') (fromList "ab") (singleton 'b', singleton 'a')-partition :: (a -> Bool) -> Heap a -> (Heap a, Heap a)-partition _ Empty = (Empty, Empty)-partition p (Heap _ leq t) = foldMap f t- where - f x | p x = (singletonWith leq x, mempty)- | otherwise = (mempty, singletonWith leq x) ---- | /O(n)/. Partition the heap into heaps of the elements that are less than, equal to, and greater than a given value.--- --- > split 'h' (fromList "hello") == (singleton 'e', singleton 'h', fromList "lol")--split :: a -> Heap a -> (Heap a, Heap a, Heap a)-split a Empty = (Empty, Empty, Empty)-split a (Heap s leq t) = foldMap f t - where- f x = if leq x a - then if leq a x - then (mempty, singletonWith leq x, mempty)- else (singletonWith leq x, mempty, mempty)- else (mempty, mempty, singletonWith leq x)---- * Subranges---- | /O(n log n)/. Return a heap consisting of the least @n@ elements of a given heap.--- --- > take 3 (fromList [10,2,4,1,9,8,2]) == fromList [1,2,2]-take :: Int -> Heap a -> Heap a-take = withList . L.take---- | /O(n log n)/. Return a heap consisting of all members of given heap except for the @n@ least elements.-drop :: Int -> Heap a -> Heap a-drop = withList . L.drop---- | /O(n log n)/. Split a heap into two heaps, the first containing the @n@ least elements, the latter consisting of all members of the heap except for those elements.-splitAt :: Int -> Heap a -> (Heap a, Heap a)-splitAt = splitWithList . L.splitAt---- | /O(n log n)/. 'break' applied to a predicate @p@ and a heap @xs@ returns a tuple where the first element is a heap consisting of the--- longest prefix the least elements of @xs@ that /do not satisfy/ p and the second element is the remainder of the elements in the heap.--- --- > break (\x -> x `mod` 4 == 0) (fromList [3,5,7,12,13,16]) == (fromList [3,5,7], fromList [12,13,16])------ 'break' @p@ is equivalent to @'span' ('not' . p)@.-break :: (a -> Bool) -> Heap a -> (Heap a, Heap a)-break = splitWithList . L.break---- | /O(n log n)/. 'span' applied to a predicate @p@ and a heap @xs@ returns a tuple where the first element is a heap consisting of the--- longest prefix the least elements of xs that satisfy @p@ and the second element is the remainder of the elements in the heap.--- --- > span (\x -> x `mod` 4 == 0) (fromList [4,8,12,14,16]) == (fromList [4,8,12],fromList [14,16])------ 'span' @p xs@ is equivalent to @('takeWhile' p xs, 'dropWhile p xs)@--span :: (a -> Bool) -> Heap a -> (Heap a, Heap a)-span = splitWithList . L.span---- | /O(n log n)/. 'takeWhile' applied to a predicate @p@ and a heap @xs@ returns a heap consisting of the--- longest prefix the least elements of @xs@ that satisfy @p@.--- --- > takeWhile (\x -> x `mod` 4 == 0) (fromList [4,8,12,14,16]) == fromList [4,8,12]-takeWhile :: (a -> Bool) -> Heap a -> Heap a-takeWhile = withList . L.takeWhile---- | /O(n log n)/. 'dropWhile' @p xs@ returns the suffix of the heap remaining after 'takeWhile' @p xs@.--- --- > dropWhile (\x -> x `mod` 4 == 0) (fromList [4,8,12,14,16]) == fromList [14,16]-dropWhile :: (a -> Bool) -> Heap a -> Heap a-dropWhile = withList . L.dropWhile---- | /O(n log n)/. Remove duplicate entries from the heap.--- --- > nub (fromList [1,1,2,6,6]) == fromList [1,2,6]-nub :: Heap a -> Heap a-nub Empty = Empty-nub h@(Heap _ leq t) = insertWith leq x (nub zs)- where- x = root t - xs = deleteMin h- zs = dropWhile (`leq` x) xs---- | /O(n)/. Construct heaps from each element in another heap, and union them together.------ concatMap (\a -> fromList [a,a+1]) (fromList [1,4]) == fromList [1,2,4,5]-concatMap :: Ord b => (a -> Heap b) -> Heap a -> Heap b -concatMap _ Empty = Empty -concatMap f h@(Heap _ _ t) = foldMap f t---- | /O(n log n)/. Group a heap into a heap of heaps, by unioning together duplicates.--- --- > group (fromList "hello") == fromList [fromList "h", fromList "e", fromList "ll", fromList "o"]-group :: Heap a -> Heap (Heap a)-group Empty = Empty-group h@(Heap _ leq _) = groupBy (flip leq) h---- | /O(n log n)/. Group using a user supplied function.-groupBy :: (a -> a -> Bool) -> Heap a -> Heap (Heap a)-groupBy f Empty = Empty -groupBy f h@(Heap _ leq t) = insert (insertWith leq x ys) (groupBy f zs) - where - x = root t - xs = deleteMin h- (ys,zs) = span (f x) xs---- | /O(n log n + m log m)/. Intersect the values in two heaps, returning the value in the left heap that compares as equal-intersect :: Heap a -> Heap a -> Heap a-intersect Empty _ = Empty-intersect _ Empty = Empty-intersect a@(Heap _ leq _) b = go leq (toList a) (toList b)- where- go leq' xxs@(x:xs) yys@(y:ys) =- if leq' x y - then if leq' y x - then insertWith leq' x (go leq' xs ys)- else go leq' xs yys- else go leq' xxs ys - go _ [] _ = empty- go _ _ [] = empty---- | /O(n log n + m log m)/. Intersect the values in two heaps using a function to generate the elements in the right heap.-intersectWith :: Ord b => (a -> a -> b) -> Heap a -> Heap a -> Heap b-intersectWith _ Empty _ = Empty-intersectWith _ _ Empty = Empty-intersectWith f a@(Heap _ leq _) b = go leq f (toList a) (toList b)- where - go :: Ord b => (a -> a -> Bool) -> (a -> a -> b) -> [a] -> [a] -> Heap b- go leq' f' xxs@(x:xs) yys@(y:ys) - | leq' x y = - if leq' y x - then insert (f' x y) (go leq' f' xs ys)- else go leq' f' xs yys- | otherwise = go leq' f' xxs ys - go _ _ [] _ = empty- go _ _ _ [] = empty---- | /O(n log n)/. Traverse the elements of the heap in sorted order and produce a new heap using 'Applicative' side-effects.-traverse :: (Applicative t, Ord b) => (a -> t b) -> Heap a -> t (Heap b)-traverse f = fmap fromList . Traversable.traverse f . toList---- | /O(n log n)/. Traverse the elements of the heap in sorted order and produce a new heap using 'Monad'ic side-effects.-mapM :: (Monad m, Ord b) => (a -> m b) -> Heap a -> m (Heap b)-mapM f = liftM fromList . Traversable.mapM f . toList --both :: (a -> b) -> (a, a) -> (b, b)-both f (a,b) = (f a, f b)--on :: (b -> b -> c) -> (a -> b) -> a -> a -> c-on f g a b = f (g a) (g b)---- we hold onto the children counts in the nodes for O(1) size-data Tree a = Node - { rank :: {-# UNPACK #-} !Int- , root :: a- , _forest :: !(Forest a) - } deriving (Show,Read,Typeable)--data Forest a = !(Tree a) `Cons` !(Forest a) | Nil- deriving (Show,Read,Typeable)-infixr 5 `Cons`--instance Functor Tree where- fmap f (Node r a as) = Node r (f a) (fmap f as)--instance Functor Forest where- fmap f (a `Cons` as) = fmap f a `Cons` fmap f as- fmap _ Nil = Nil---- internal foldable instances that should only be used over commutative monoids-instance Foldable Tree where- foldMap f (Node _ a as) = f a `mappend` foldMap f as---- internal foldable instances that should only be used over commutative monoids-instance Foldable Forest where- foldMap f (a `Cons` as) = foldMap f a `mappend` foldMap f as- foldMap _ Nil = mempty--link :: (a -> a -> Bool) -> Tree a -> Tree a -> Tree a-link f t1@(Node r1 x1 cf1) t2@(Node r2 x2 cf2) -- assumes r1 == r2- | f x1 x2 = Node (r1+1) x1 (t2 `Cons` cf1)- | otherwise = Node (r2+1) x2 (t1 `Cons` cf2)--skewLink :: (a -> a -> Bool) -> Tree a -> Tree a -> Tree a -> Tree a -skewLink f t0@(Node _ x0 cf0) t1@(Node r1 x1 cf1) t2@(Node r2 x2 cf2)- | f x1 x0 && f x1 x2 = Node (r1+1) x1 (t0 `Cons` t2 `Cons` cf1)- | f x2 x0 && f x2 x1 = Node (r2+1) x2 (t0 `Cons` t1 `Cons` cf2)- | otherwise = Node (r1+1) x0 (t1 `Cons` t2 `Cons` cf0)--ins :: (a -> a -> Bool) -> Tree a -> Forest a -> Forest a -ins _ t Nil = t `Cons` Nil-ins f t (t' `Cons` ts) -- assumes rank t <= rank t'- | rank t < rank t' = t `Cons` t' `Cons` ts- | otherwise = ins f (link f t t') ts--uniqify :: (a -> a -> Bool) -> Forest a -> Forest a -uniqify _ Nil = Nil-uniqify f (t `Cons` ts) = ins f t ts--unionUniq :: (a -> a -> Bool) -> Forest a -> Forest a -> Forest a-unionUniq _ Nil ts = ts-unionUniq _ ts Nil = ts-unionUniq f tts1@(t1 `Cons` ts1) tts2@(t2 `Cons` ts2) = case compare (rank t1) (rank t2) of- LT -> t1 `Cons` unionUniq f ts1 tts2- EQ -> ins f (link f t1 t2) (unionUniq f ts1 ts2)- GT -> t2 `Cons` unionUniq f tts1 ts2--skewInsert :: (a -> a -> Bool) -> Tree a -> Forest a -> Forest a-skewInsert f t ts@(t1 `Cons` t2 `Cons`rest) - | rank t1 == rank t2 = skewLink f t t1 t2 `Cons` rest- | otherwise = t `Cons` ts-skewInsert _ t ts = t `Cons` ts--skewMeld :: (a -> a -> Bool) -> Forest a -> Forest a -> Forest a -skewMeld f ts ts' = unionUniq f (uniqify f ts) (uniqify f ts')--getMin :: (a -> a -> Bool) -> Forest a -> (Tree a, Forest a) -getMin _ (t `Cons` Nil) = (t, Nil)-getMin f (t `Cons` ts) - | f (root t) (root t') = (t, ts)- | otherwise = (t', t `Cons` ts')- where (t',ts') = getMin f ts-getMin _ Nil = error "Heap.getMin: empty forest"--splitForest :: Int -> Forest a -> Forest a -> Forest a -> (Forest a, Forest a, Forest a)-splitForest a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined-splitForest 0 zs ts f = (zs, ts, f)-splitForest 1 zs ts (t `Cons` Nil) = (zs, t `Cons` ts, Nil)-splitForest 1 zs ts (t1 `Cons` t2 `Cons` f) - -- rank t1 == 0- | rank t2 == 0 = (t1 `Cons` zs, t2 `Cons` ts, f)- | otherwise = (zs, t1 `Cons` ts, t2 `Cons` f) -splitForest r zs ts (t1 `Cons` t2 `Cons` cf) - -- r1 = r - 1 or r1 == 0- | r1 == r2 = (zs, t1 `Cons` t2 `Cons` ts, cf)- | r1 == 0 = splitForest (r-1) (t1 `Cons` zs) (t2 `Cons` ts) cf- | otherwise = splitForest (r-1) zs (t1 `Cons` ts) (t2 `Cons` cf)- where - r1 = rank t1- r2 = rank t2-splitForest _ _ _ _ = error "Heap.splitForest: invalid arguments"--withList :: ([a] -> [a]) -> Heap a -> Heap a -withList _ Empty = Empty-withList f hp@(Heap _ leq _) = fromListWith leq (f (toList hp))--splitWithList :: ([a] -> ([a],[a])) -> Heap a -> (Heap a, Heap a)-splitWithList _ Empty = (Empty, Empty)-splitWithList f hp@(Heap _ leq _) = both (fromListWith leq) (f (toList hp))---- explicit priority/payload tuples--data Entry p a = Entry { priority :: p, payload :: a }- deriving (Read,Show,Data,Typeable)--instance Functor (Entry p) where- fmap f (Entry p a) = Entry p (f a)--instance Foldable (Entry p) where- foldMap f (Entry _ a) = f a--instance Traversable (Entry p) where- traverse f (Entry p a) = Entry p `fmap` f a---- instance Copointed (Entry p) where --- extract (Entry _ a) = a---- instance Comonad (Entry p) where --- extend f pa@(Entry p _) Entry p (f pa)--instance Eq p => Eq (Entry p a) where- (==) = (==) `on` priority--instance Ord p => Ord (Entry p a) where- compare = compare `on` priority
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
+ Setup.lhs view
@@ -0,0 +1,7 @@+#!/usr/bin/runhaskell+> module Main (main) where++> import Distribution.Simple++> main :: IO ()+> main = defaultMain
heaps.cabal view
@@ -1,5 +1,5 @@ name: heaps-version: 0.2.1.1+version: 0.2.2 license: BSD3 license-file: LICENSE author: Edward A. Kmett@@ -12,7 +12,7 @@ description: Asymptotically optimal Brodal/Okasaki bootstrapped skew-binomial heaps from the paper \"Optimal Purely Functional Priority Queues\", extended with a Foldable interface. copyright: (c) 2010 Edward A. Kmett build-type: Simple-cabal-version: >=1.6+cabal-version: >=1.8 extra-source-files: .travis.yml source-repository head@@ -23,3 +23,19 @@ exposed-modules: Data.Heap build-depends: base >= 4 && < 6+ hs-source-dirs: src++-- Verify the results of the examples+test-suite doctests+ type: exitcode-stdio-1.0+ main-is: doctests.hs+ build-depends:+ base,+ directory >= 1.0 && < 1.3,+ doctest >= 0.9 && <= 0.10,+ filepath+ ghc-options: -Wall+ if impl(ghc<7.6.1)+ ghc-options: -Werror+ hs-source-dirs: tests+
+ src/Data/Heap.hs view
@@ -0,0 +1,705 @@+{-# LANGUAGE DeriveDataTypeable #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Heap+-- Copyright : (c) Edward Kmett 2010+-- License : BSD-style+-- Maintainer : ekmett@gmail.com+-- Stability : experimental+-- Portability : portable+--+-- An efficient, asymptotically optimal, implementation of a priority queues+-- extended with support for efficient size, and `Data.Foldable`+--+-- /Note/: Since many function names (but not the type name) clash with+-- "Prelude" names, this module is usually imported @qualified@, e.g.+--+-- > import Data.Heap (Heap)+-- > import qualified Data.Heap as Heap+--+-- The implementation of 'Heap' is based on /bootstrapped skew binomial heaps/+-- as described by:+--+-- * G. Brodal and C. Okasaki , \"/Optimal Purely Functional Priority Queues/\",+-- /Journal of Functional Programming/ 6:839-857 (1996),+-- <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.48.973>+--+-- All time bounds are worst-case.+-----------------------------------------------------------------------------++module Data.Heap+ (+ -- * Heap Type+ Heap -- instance Eq,Ord,Show,Read,Data,Typeable+ -- * Entry type+ , Entry(..) -- instance Eq,Ord,Show,Read,Data,Typeable+ -- * Basic functions+ , empty -- O(1) :: Heap a+ , null -- O(1) :: Heap a -> Bool+ , size -- O(1) :: Heap a -> Int+ , singleton -- O(1) :: Ord a => a -> Heap a+ , insert -- O(1) :: Ord a => a -> Heap a -> Heap a+ , minimum -- O(1) (/partial/) :: Ord a => Heap a -> a+ , deleteMin -- O(log n) :: Heap a -> Heap a+ , union -- O(1) :: Heap a -> Heap a -> Heap a+ , uncons, viewMin -- O(1)\/O(log n) :: Heap a -> Maybe (a, Heap a)+ -- * Transformations+ , mapMonotonic -- O(n) :: Ord b => (a -> b) -> Heap a -> Heap b+ , map -- O(n) :: Ord b => (a -> b) -> Heap a -> Heap b+ -- * To/From Lists+ , toUnsortedList -- O(n) :: Heap a -> [a]+ , fromList -- O(n) :: Ord a => [a] -> Heap a+ , sort -- O(n log n) :: Ord a => [a] -> [a]+ , traverse -- O(n log n) :: (Applicative t, Ord b) => (a -> t b) -> Heap a -> t (Heap b)+ , mapM -- O(n log n) :: (Monad m, Ord b) => (a -> m b) -> Heap a -> m (Heap b)+ , concatMap -- O(n) :: Ord b => Heap a -> (a -> Heap b) -> Heap b+ -- * Filtering+ , filter -- O(n) :: (a -> Bool) -> Heap a -> Heap a+ , partition -- O(n) :: (a -> Bool) -> Heap a -> (Heap a, Heap a)+ , split -- O(n) :: a -> Heap a -> (Heap a, Heap a, Heap a)+ , break -- O(n log n) :: (a -> Bool) -> Heap a -> (Heap a, Heap a)+ , span -- O(n log n) :: (a -> Bool) -> Heap a -> (Heap a, Heap a)+ , take -- O(n log n) :: Int -> Heap a -> Heap a+ , drop -- O(n log n) :: Int -> Heap a -> Heap a+ , splitAt -- O(n log n) :: Int -> Heap a -> (Heap a, Heap a)+ , takeWhile -- O(n log n) :: (a -> Bool) -> Heap a -> Heap a+ , dropWhile -- O(n log n) :: (a -> Bool) -> Heap a -> Heap a+ -- * Grouping+ , group -- O(n log n) :: Heap a -> Heap (Heap a)+ , groupBy -- O(n log n) :: (a -> a -> Bool) -> Heap a -> Heap (Heap a)+ , nub -- O(n log n) :: Heap a -> Heap a+ -- * Intersection+ , intersect -- O(n log n + m log m) :: Heap a -> Heap a -> Heap a+ , intersectWith -- O(n log n + m log m) :: Ord b => (a -> a -> b) -> Heap a -> Heap a -> Heap b+ -- * Duplication+ , replicate -- O(log n) :: Ord a => a -> Int -> Heap a+ ) where++import Prelude hiding+ ( map, null+ , span, dropWhile, takeWhile, break, filter, take, drop, splitAt+ , foldr, minimum, replicate, mapM+ , concatMap+ )+import qualified Data.List as L+import Control.Applicative (Applicative(pure))+import Control.Monad (liftM)+import Data.Monoid (Monoid(mappend, mempty))+import Data.Foldable hiding (minimum, concatMap)+import Data.Data (DataType, Constr, mkConstr, mkDataType, Fixity(Prefix), Data(..), constrIndex)+import Data.Typeable (Typeable)+import Text.Read+import Text.Show+import qualified Data.Traversable as Traversable+import Data.Traversable (Traversable)++-- The implementation of 'Heap' must internally hold onto the dictionary entry for ('<='),+-- so that it can be made 'Foldable'. Confluence in the absence of incoherent instances+-- is provided by the fact that we only ever build these from instances of 'Ord' a (except in the case of 'groupBy')+++-- | A min-heap of values of type @a@.+data Heap a+ = Empty+ | Heap {-# UNPACK #-} !Int (a -> a -> Bool) {-# UNPACK #-} !(Tree a)+ deriving (Typeable)++instance Show a => Show (Heap a) where+ showsPrec _ Empty = showString "fromList []"+ showsPrec d (Heap _ _ t) = showParen (d > 10) $+ showString "fromList " .+ showsPrec 11 (toList t)++instance (Ord a, Read a) => Read (Heap a) where+ readPrec = parens $ prec 10 $ do+ Ident "fromList" <- lexP+ fromList `fmap` step readPrec++instance (Ord a, Data a) => Data (Heap a) where+ gfoldl k z h = z fromList `k` toUnsortedList h+ toConstr _ = fromListConstr+ dataTypeOf _ = heapDataType+ gunfold k z c = case constrIndex c of+ 1 -> k (z fromList)+ _ -> error "gunfold"+++heapDataType :: DataType+heapDataType = mkDataType "Data.Heap.Heap" [fromListConstr]++fromListConstr :: Constr+fromListConstr = mkConstr heapDataType "fromList" [] Prefix++instance Eq (Heap a) where+ Empty == Empty = True+ Empty == Heap{} = False+ Heap{} == Empty = False+ a@(Heap s1 leq _) == b@(Heap s2 _ _) = s1 == s2 && go leq (toList a) (toList b)+ where+ go f (x:xs) (y:ys) = f x y && f y x && go f xs ys+ go _ [] [] = True+ go _ _ _ = False++instance Ord (Heap a) where+ Empty `compare` Empty = EQ+ Empty `compare` Heap{} = LT+ Heap{} `compare` Empty = GT+ a@(Heap _ leq _) `compare` b = go leq (toList a) (toList b)+ where+ go f (x:xs) (y:ys) =+ if f x y+ then if f y x+ then go f xs ys+ else LT+ else GT+ go f [] [] = EQ+ go f [] (_:_) = LT+ go f (_:_) [] = GT+++-- | /O(1)/. Is the heap empty?+--+-- >>> null empty+-- True+--+-- >>> null (singleton "hello")+-- False+null :: Heap a -> Bool+null Empty = True+null _ = False++-- | /O(1)/. The number of elements in the heap.+--+-- >>> size empty+-- 0+-- >>> size (singleton "hello")+-- 1+-- >>> size (fromList [4,1,2])+-- 3+size :: Heap a -> Int+size Empty = 0+size (Heap s _ _) = s++-- | /O(1)/. The empty heap+--+-- @'empty' ≡ 'fromList' []@+--+-- >>> size empty+-- 0+empty :: Heap a+empty = Empty++-- | /O(1)/. A heap with a single element+--+-- @+-- 'singleton' x ≡ 'fromList' [x]+-- 'singleton' x ≡ 'insert' x 'empty'+-- @+--+-- >>> size (singleton "hello")+-- 1+singleton :: Ord a => a -> Heap a+singleton = singletonWith (<=)++singletonWith :: (a -> a -> Bool) -> a -> Heap a+singletonWith f a = Heap 1 f (Node 0 a Nil)++-- | /O(1)/. Insert a new value into the heap.+--+-- >>> insert 2 (fromList [1,3])+-- fromList [1,2,3]+--+-- @+-- 'insert' x 'empty' ≡ 'singleton' x+-- 'size' ('insert' x xs) ≡ 1 + 'size' xs+-- @+insert :: Ord a => a -> Heap a -> Heap a+insert = insertWith (<=)++insertWith :: (a -> a -> Bool) -> a -> Heap a -> Heap a+insertWith leq x Empty = singletonWith leq x+insertWith leq x (Heap s _ t@(Node _ y f))+ | leq x y = Heap (s+1) leq (Node 0 x (t `Cons` Nil))+ | otherwise = Heap (s+1) leq (Node 0 y (skewInsert leq (Node 0 x Nil) f))++-- | /O(1)/. Meld the values from two heaps into one heap.+--+-- >>> union (fromList [1,3,5]) (fromList [6,4,2])+-- fromList [1,2,6,4,3,5]+-- >>> union (fromList [1,1,1]) (fromList [1,2,1])+-- fromList [1,1,1,2,1,1]+union :: Heap a -> Heap a -> Heap a+union Empty q = q+union q Empty = q+union (Heap s1 leq t1@(Node _ x1 f1)) (Heap s2 _ t2@(Node _ x2 f2))+ | leq x1 x2 = Heap (s1 + s2) leq (Node 0 x1 (skewInsert leq t2 f1))+ | otherwise = Heap (s1 + s2) leq (Node 0 x2 (skewInsert leq t1 f2))++-- | /O(log n)/. Create a heap consisting of multiple copies of the same value.+--+-- >>> replicate 'a' 10+-- fromList "aaaaaaaaaa"+replicate :: Ord a => a -> Int -> Heap a+replicate x0 y0+ | y0 < 0 = error "Heap.replicate: negative length"+ | y0 == 0 = mempty+ | otherwise = f (singleton x0) y0+ where+ f x y+ | even y = f (union x x) (quot y 2)+ | y == 1 = x+ | otherwise = g (union x x) (quot (y - 1) 2) x+ g x y z+ | even y = g (union x x) (quot y 2) z+ | y == 1 = union x z+ | otherwise = g (union x x) (quot (y - 1) 2) (union x z)++-- | Provides both /O(1)/ access to the minimum element and /O(log n)/ access to the remainder of the heap.+-- This is the same operation as 'viewMin'+--+-- >>> uncons (fromList [2,1,3])+-- Just (1,fromList [2,3])+uncons :: Ord a => Heap a -> Maybe (a, Heap a)+uncons Empty = Nothing+uncons l@(Heap _ _ t) = Just (root t, deleteMin l)++-- | Same as 'uncons'+viewMin :: Ord a => Heap a -> Maybe (a, Heap a)+viewMin = uncons++-- | /O(1)/. Assumes the argument is a non-'null' heap.+--+-- >>> minimum (fromList [3,1,2])+-- 1+minimum :: Heap a -> a+minimum Empty = error "Heap.minimum: empty heap"+minimum (Heap _ _ t) = root t++trees :: Forest a -> [Tree a]+trees (a `Cons` as) = a : trees as+trees Nil = []++-- | /O(log n)/. Delete the minimum key from the heap and return the resulting heap.+--+-- >>> deleteMin (fromList [3,1,2])+-- fromList [2,3]+deleteMin :: Heap a -> Heap a+deleteMin Empty = Empty+deleteMin (Heap _ _ (Node _ _ Nil)) = Empty+deleteMin (Heap s leq (Node _ _ f0)) = Heap (s - 1) leq (Node 0 x f3)+ where+ (Node r x cf, ts2) = getMin leq f0+ (zs, ts1, f1) = splitForest r Nil Nil cf+ f2 = skewMeld leq (skewMeld leq ts1 ts2) f1+ f3 = foldr (skewInsert leq) f2 (trees zs)++-- | /O(log n)/. Adjust the minimum key in the heap and return the resulting heap.+--+-- >>> adjustMin (+1) (fromList [1,2,3])+-- fromList [2,2,3]+adjustMin :: (a -> a) -> Heap a -> Heap a+adjustMin _ Empty = Empty+adjustMin f (Heap s leq (Node r x xs)) = Heap s leq (heapify leq (Node r (f x) xs))++type ForestZipper a = (Forest a, Forest a)++zipper :: Forest a -> ForestZipper a+zipper xs = (Nil, xs)++emptyZ :: ForestZipper a+emptyZ = (Nil, Nil)++-- leftZ :: ForestZipper a -> ForestZipper a+-- leftZ (x :> path, xs) = (path, x :> xs)++rightZ :: ForestZipper a -> ForestZipper a+rightZ (path, x `Cons` xs) = (x `Cons` path, xs)++adjustZ :: (Tree a -> Tree a) -> ForestZipper a -> ForestZipper a+adjustZ f (path, x `Cons` xs) = (path, f x `Cons` xs)+adjustZ _ z = z++rezip :: ForestZipper a -> Forest a+rezip (Nil, xs) = xs+rezip (x `Cons` path, xs) = rezip (path, x `Cons` xs)++-- assumes non-empty zipper+rootZ :: ForestZipper a -> a+rootZ (_ , x `Cons` _) = root x+rootZ _ = error "Heap.rootZ: empty zipper"++minZ :: (a -> a -> Bool) -> Forest a -> ForestZipper a+minZ _ Nil = emptyZ+minZ f xs = minZ' f z z+ where z = zipper xs++minZ' :: (a -> a -> Bool) -> ForestZipper a -> ForestZipper a -> ForestZipper a+minZ' _ lo (_, Nil) = lo+minZ' leq lo z = minZ' leq (if leq (rootZ lo) (rootZ z) then lo else z) (rightZ z)++heapify :: (a -> a -> Bool) -> Tree a -> Tree a+heapify _ n@(Node _ _ Nil) = n+heapify leq n@(Node r a as)+ | leq a a' = n+ | otherwise = Node r a' (rezip (left, heapify leq (Node r' a as') `Cons` right))+ where+ (left, Node r' a' as' `Cons` right) = minZ leq as+++-- | /O(n)/. Build a heap from a list of values.+--+-- @+-- 'fromList' '.' 'toList' ≡ 'id'+-- 'toList' '.' 'fromList' ≡ 'sort'+-- @++-- >>> size (fromList [1,5,3])+-- 3++fromList :: Ord a => [a] -> Heap a+fromList = foldr insert mempty++fromListWith :: (a -> a -> Bool) -> [a] -> Heap a+fromListWith f = foldr (insertWith f) mempty++-- | /O(n log n)/. Perform a heap sort+sort :: Ord a => [a] -> [a]+sort = toList . fromList++instance Monoid (Heap a) where+ mempty = empty+ mappend = union++-- | /O(n)/. Returns the elements in the heap in some arbitrary, very likely unsorted, order.+--+-- >>> toUnsortedList (fromList [3,1,2])+-- [1,3,2]+--+-- @'fromList' '.' 'toUnsortedList' ≡ 'id'@+toUnsortedList :: Heap a -> [a]+toUnsortedList Empty = []+toUnsortedList (Heap _ _ t) = foldMap return t++instance Foldable Heap where+ foldMap _ Empty = mempty+ foldMap f l@(Heap _ _ t) = f (root t) `mappend` foldMap f (deleteMin l)++-- | /O(n)/. Map a function over the heap, returning a new heap ordered appropriately for its fresh contents+--+-- >>> map negate (fromList [3,1,2])+-- fromList [-3,-1,-2]+map :: Ord b => (a -> b) -> Heap a -> Heap b+map _ Empty = Empty+map f (Heap _ _ t) = foldMap (singleton . f) t++-- | /O(n)/. Map a monotone increasing function over the heap.+-- Provides a better constant factor for performance than 'map', but no checking is performed that the function provided is monotone increasing. Misuse of this function can cause a Heap to violate the heap property.+--+-- >>> map (+1) (fromList [1,2,3])+-- fromList [2,3,4]+-- >>> map (*2) (fromList [1,2,3])+-- fromList [2,4,6]+mapMonotonic :: Ord b => (a -> b) -> Heap a -> Heap b+mapMonotonic _ Empty = Empty+mapMonotonic f (Heap s _ t) = Heap s (<=) (fmap f t)++-- * Filter++-- | /O(n)/. Filter the heap, retaining only values that satisfy the predicate.+--+-- >>> filter (>'a') (fromList "ab")+-- fromList "b"+-- >>> filter (>'x') (fromList "ab")+-- fromList []+-- >>> filter (<'a') (fromList "ab")+-- fromList []+filter :: (a -> Bool) -> Heap a -> Heap a+filter _ Empty = Empty+filter p (Heap _ leq t) = foldMap f t+ where+ f x | p x = singletonWith leq x+ | otherwise = Empty++-- | /O(n)/. Partition the heap according to a predicate. The first heap contains all elements that satisfy the predicate, the second all elements that fail the predicate. See also 'split'.+--+-- >>> partition (>'a') (fromList "ab")+-- (fromList "b",fromList "a")+partition :: (a -> Bool) -> Heap a -> (Heap a, Heap a)+partition _ Empty = (Empty, Empty)+partition p (Heap _ leq t) = foldMap f t+ where+ f x | p x = (singletonWith leq x, mempty)+ | otherwise = (mempty, singletonWith leq x)++-- | /O(n)/. Partition the heap into heaps of the elements that are less than, equal to, and greater than a given value.+--+-- >>> split 'h' (fromList "hello")+-- (fromList "e",fromList "h",fromList "llo")+split :: a -> Heap a -> (Heap a, Heap a, Heap a)+split a Empty = (Empty, Empty, Empty)+split a (Heap s leq t) = foldMap f t+ where+ f x = if leq x a+ then if leq a x+ then (mempty, singletonWith leq x, mempty)+ else (singletonWith leq x, mempty, mempty)+ else (mempty, mempty, singletonWith leq x)++-- * Subranges++-- | /O(n log n)/. Return a heap consisting of the least @n@ elements of a given heap.+--+-- >>> take 3 (fromList [10,2,4,1,9,8,2])+-- fromList [1,2,2]+take :: Int -> Heap a -> Heap a+take = withList . L.take++-- | /O(n log n)/. Return a heap consisting of all members of given heap except for the @n@ least elements.+drop :: Int -> Heap a -> Heap a+drop = withList . L.drop++-- | /O(n log n)/. Split a heap into two heaps, the first containing the @n@ least elements, the latter consisting of all members of the heap except for those elements.+splitAt :: Int -> Heap a -> (Heap a, Heap a)+splitAt = splitWithList . L.splitAt++-- | /O(n log n)/. 'break' applied to a predicate @p@ and a heap @xs@ returns a tuple where the first element is a heap consisting of the+-- longest prefix the least elements of @xs@ that /do not satisfy/ p and the second element is the remainder of the elements in the heap.+--+-- >>> break (\x -> x `mod` 4 == 0) (fromList [3,5,7,12,13,16])+-- (fromList [3,5,7],fromList [12,13,16])+--+-- 'break' @p@ is equivalent to @'span' ('not' . p)@.+break :: (a -> Bool) -> Heap a -> (Heap a, Heap a)+break = splitWithList . L.break++-- | /O(n log n)/. 'span' applied to a predicate @p@ and a heap @xs@ returns a tuple where the first element is a heap consisting of the+-- longest prefix the least elements of xs that satisfy @p@ and the second element is the remainder of the elements in the heap.+--+-- >>> span (\x -> x `mod` 4 == 0) (fromList [4,8,12,14,16])+-- (fromList [4,8,12],fromList [14,16])+--+-- 'span' @p xs@ is equivalent to @('takeWhile' p xs, 'dropWhile p xs)@++span :: (a -> Bool) -> Heap a -> (Heap a, Heap a)+span = splitWithList . L.span++-- | /O(n log n)/. 'takeWhile' applied to a predicate @p@ and a heap @xs@ returns a heap consisting of the+-- longest prefix the least elements of @xs@ that satisfy @p@.+--+-- >>> takeWhile (\x -> x `mod` 4 == 0) (fromList [4,8,12,14,16])+-- fromList [4,8,12]+takeWhile :: (a -> Bool) -> Heap a -> Heap a+takeWhile = withList . L.takeWhile++-- | /O(n log n)/. 'dropWhile' @p xs@ returns the suffix of the heap remaining after 'takeWhile' @p xs@.+--+-- >>> dropWhile (\x -> x `mod` 4 == 0) (fromList [4,8,12,14,16])+-- fromList [14,16]+dropWhile :: (a -> Bool) -> Heap a -> Heap a+dropWhile = withList . L.dropWhile++-- | /O(n log n)/. Remove duplicate entries from the heap.+--+-- >>> nub (fromList [1,1,2,6,6])+-- fromList [1,2,6]+nub :: Heap a -> Heap a+nub Empty = Empty+nub h@(Heap _ leq t) = insertWith leq x (nub zs)+ where+ x = root t+ xs = deleteMin h+ zs = dropWhile (`leq` x) xs++-- | /O(n)/. Construct heaps from each element in another heap, and union them together.+--+-- >>> concatMap (\a -> fromList [a,a+1]) (fromList [1,4])+-- fromList [1,4,5,2]+concatMap :: Ord b => (a -> Heap b) -> Heap a -> Heap b+concatMap _ Empty = Empty+concatMap f h@(Heap _ _ t) = foldMap f t++-- | /O(n log n)/. Group a heap into a heap of heaps, by unioning together duplicates.+--+-- >>> group (fromList "hello")+-- fromList [fromList "e",fromList "h",fromList "ll",fromList "o"]+group :: Heap a -> Heap (Heap a)+group Empty = Empty+group h@(Heap _ leq _) = groupBy (flip leq) h++-- | /O(n log n)/. Group using a user supplied function.+groupBy :: (a -> a -> Bool) -> Heap a -> Heap (Heap a)+groupBy f Empty = Empty+groupBy f h@(Heap _ leq t) = insert (insertWith leq x ys) (groupBy f zs)+ where+ x = root t+ xs = deleteMin h+ (ys,zs) = span (f x) xs++-- | /O(n log n + m log m)/. Intersect the values in two heaps, returning the value in the left heap that compares as equal+intersect :: Heap a -> Heap a -> Heap a+intersect Empty _ = Empty+intersect _ Empty = Empty+intersect a@(Heap _ leq _) b = go leq (toList a) (toList b)+ where+ go leq' xxs@(x:xs) yys@(y:ys) =+ if leq' x y+ then if leq' y x+ then insertWith leq' x (go leq' xs ys)+ else go leq' xs yys+ else go leq' xxs ys+ go _ [] _ = empty+ go _ _ [] = empty++-- | /O(n log n + m log m)/. Intersect the values in two heaps using a function to generate the elements in the right heap.+intersectWith :: Ord b => (a -> a -> b) -> Heap a -> Heap a -> Heap b+intersectWith _ Empty _ = Empty+intersectWith _ _ Empty = Empty+intersectWith f a@(Heap _ leq _) b = go leq f (toList a) (toList b)+ where+ go :: Ord b => (a -> a -> Bool) -> (a -> a -> b) -> [a] -> [a] -> Heap b+ go leq' f' xxs@(x:xs) yys@(y:ys)+ | leq' x y =+ if leq' y x+ then insert (f' x y) (go leq' f' xs ys)+ else go leq' f' xs yys+ | otherwise = go leq' f' xxs ys+ go _ _ [] _ = empty+ go _ _ _ [] = empty++-- | /O(n log n)/. Traverse the elements of the heap in sorted order and produce a new heap using 'Applicative' side-effects.+traverse :: (Applicative t, Ord b) => (a -> t b) -> Heap a -> t (Heap b)+traverse f = fmap fromList . Traversable.traverse f . toList++-- | /O(n log n)/. Traverse the elements of the heap in sorted order and produce a new heap using 'Monad'ic side-effects.+mapM :: (Monad m, Ord b) => (a -> m b) -> Heap a -> m (Heap b)+mapM f = liftM fromList . Traversable.mapM f . toList++both :: (a -> b) -> (a, a) -> (b, b)+both f (a,b) = (f a, f b)++on :: (b -> b -> c) -> (a -> b) -> a -> a -> c+on f g a b = f (g a) (g b)++-- we hold onto the children counts in the nodes for /O(1)/ 'size'+data Tree a = Node+ { rank :: {-# UNPACK #-} !Int+ , root :: a+ , _forest :: !(Forest a)+ } deriving (Show,Read,Typeable)++data Forest a = !(Tree a) `Cons` !(Forest a) | Nil+ deriving (Show,Read,Typeable)+infixr 5 `Cons`++instance Functor Tree where+ fmap f (Node r a as) = Node r (f a) (fmap f as)++instance Functor Forest where+ fmap f (a `Cons` as) = fmap f a `Cons` fmap f as+ fmap _ Nil = Nil++-- internal foldable instances that should only be used over commutative monoids+instance Foldable Tree where+ foldMap f (Node _ a as) = f a `mappend` foldMap f as++-- internal foldable instances that should only be used over commutative monoids+instance Foldable Forest where+ foldMap f (a `Cons` as) = foldMap f a `mappend` foldMap f as+ foldMap _ Nil = mempty++link :: (a -> a -> Bool) -> Tree a -> Tree a -> Tree a+link f t1@(Node r1 x1 cf1) t2@(Node r2 x2 cf2) -- assumes r1 == r2+ | f x1 x2 = Node (r1+1) x1 (t2 `Cons` cf1)+ | otherwise = Node (r2+1) x2 (t1 `Cons` cf2)++skewLink :: (a -> a -> Bool) -> Tree a -> Tree a -> Tree a -> Tree a+skewLink f t0@(Node _ x0 cf0) t1@(Node r1 x1 cf1) t2@(Node r2 x2 cf2)+ | f x1 x0 && f x1 x2 = Node (r1+1) x1 (t0 `Cons` t2 `Cons` cf1)+ | f x2 x0 && f x2 x1 = Node (r2+1) x2 (t0 `Cons` t1 `Cons` cf2)+ | otherwise = Node (r1+1) x0 (t1 `Cons` t2 `Cons` cf0)++ins :: (a -> a -> Bool) -> Tree a -> Forest a -> Forest a+ins _ t Nil = t `Cons` Nil+ins f t (t' `Cons` ts) -- assumes rank t <= rank t'+ | rank t < rank t' = t `Cons` t' `Cons` ts+ | otherwise = ins f (link f t t') ts++uniqify :: (a -> a -> Bool) -> Forest a -> Forest a+uniqify _ Nil = Nil+uniqify f (t `Cons` ts) = ins f t ts++unionUniq :: (a -> a -> Bool) -> Forest a -> Forest a -> Forest a+unionUniq _ Nil ts = ts+unionUniq _ ts Nil = ts+unionUniq f tts1@(t1 `Cons` ts1) tts2@(t2 `Cons` ts2) = case compare (rank t1) (rank t2) of+ LT -> t1 `Cons` unionUniq f ts1 tts2+ EQ -> ins f (link f t1 t2) (unionUniq f ts1 ts2)+ GT -> t2 `Cons` unionUniq f tts1 ts2++skewInsert :: (a -> a -> Bool) -> Tree a -> Forest a -> Forest a+skewInsert f t ts@(t1 `Cons` t2 `Cons`rest)+ | rank t1 == rank t2 = skewLink f t t1 t2 `Cons` rest+ | otherwise = t `Cons` ts+skewInsert _ t ts = t `Cons` ts++skewMeld :: (a -> a -> Bool) -> Forest a -> Forest a -> Forest a+skewMeld f ts ts' = unionUniq f (uniqify f ts) (uniqify f ts')++getMin :: (a -> a -> Bool) -> Forest a -> (Tree a, Forest a)+getMin _ (t `Cons` Nil) = (t, Nil)+getMin f (t `Cons` ts)+ | f (root t) (root t') = (t, ts)+ | otherwise = (t', t `Cons` ts')+ where (t',ts') = getMin f ts+getMin _ Nil = error "Heap.getMin: empty forest"++splitForest :: Int -> Forest a -> Forest a -> Forest a -> (Forest a, Forest a, Forest a)+splitForest a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined+splitForest 0 zs ts f = (zs, ts, f)+splitForest 1 zs ts (t `Cons` Nil) = (zs, t `Cons` ts, Nil)+splitForest 1 zs ts (t1 `Cons` t2 `Cons` f)+ -- rank t1 == 0+ | rank t2 == 0 = (t1 `Cons` zs, t2 `Cons` ts, f)+ | otherwise = (zs, t1 `Cons` ts, t2 `Cons` f)+splitForest r zs ts (t1 `Cons` t2 `Cons` cf)+ -- r1 = r - 1 or r1 == 0+ | r1 == r2 = (zs, t1 `Cons` t2 `Cons` ts, cf)+ | r1 == 0 = splitForest (r-1) (t1 `Cons` zs) (t2 `Cons` ts) cf+ | otherwise = splitForest (r-1) zs (t1 `Cons` ts) (t2 `Cons` cf)+ where+ r1 = rank t1+ r2 = rank t2+splitForest _ _ _ _ = error "Heap.splitForest: invalid arguments"++withList :: ([a] -> [a]) -> Heap a -> Heap a+withList _ Empty = Empty+withList f hp@(Heap _ leq _) = fromListWith leq (f (toList hp))++splitWithList :: ([a] -> ([a],[a])) -> Heap a -> (Heap a, Heap a)+splitWithList _ Empty = (Empty, Empty)+splitWithList f hp@(Heap _ leq _) = both (fromListWith leq) (f (toList hp))++-- | explicit priority/payload tuples+data Entry p a = Entry { priority :: p, payload :: a }+ deriving (Read,Show,Data,Typeable)++instance Functor (Entry p) where+ fmap f (Entry p a) = Entry p (f a)++instance Foldable (Entry p) where+ foldMap f (Entry _ a) = f a++instance Traversable (Entry p) where+ traverse f (Entry p a) = Entry p `fmap` f a++-- instance Copointed (Entry p) where+-- extract (Entry _ a) = a++-- instance Comonad (Entry p) where+-- extend f pa@(Entry p _) Entry p (f pa)++instance Eq p => Eq (Entry p a) where+ (==) = (==) `on` priority++instance Ord p => Ord (Entry p a) where+ compare = compare `on` priority
+ tests/doctests.hs view
@@ -0,0 +1,28 @@+module Main where++import Test.DocTest+import System.Directory+import System.FilePath+import Control.Applicative+import Control.Monad+import Data.List++main :: IO ()+main = getSources >>= \sources -> doctest $+ "-isrc"+ : "-idist/build/autogen"+ : "-optP-include"+ : "-optPdist/build/autogen/cabal_macros.h"+ : sources++getSources :: IO [FilePath]+getSources = filter (isSuffixOf ".hs") <$> go "src"+ where+ go dir = do+ (dirs, files) <- getFilesAndDirectories dir+ (files ++) . concat <$> mapM go dirs++getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])+getFilesAndDirectories dir = do+ c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir+ (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c