diff --git a/Data/Heap.hs b/Data/Heap.hs deleted file mode 100644 --- a/Data/Heap.hs +++ /dev/null @@ -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), --- --- --- 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 diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/runhaskell +> module Main (main) where + +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/heaps.cabal b/heaps.cabal --- a/heaps.cabal +++ b/heaps.cabal @@ -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 + diff --git a/src/Data/Heap.hs b/src/Data/Heap.hs new file mode 100644 --- /dev/null +++ b/src/Data/Heap.hs @@ -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), +-- +-- +-- 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 diff --git a/tests/doctests.hs b/tests/doctests.hs new file mode 100644 --- /dev/null +++ b/tests/doctests.hs @@ -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