diff --git a/Data/Heap.hs b/Data/Heap.hs new file mode 100644 --- /dev/null +++ b/Data/Heap.hs @@ -0,0 +1,604 @@ +{-# 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 + , meld -- 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 + , 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. +-- +-- > meld (fromList [1,3,5]) (fromList [6,4,2]) = fromList [1..6] +-- > meld (fromList [1,1,1]) (fromList [1,2,1]) = fromList [1,1,1,1,1,2] +meld :: Heap a -> Heap a -> Heap a +meld Empty q = q +meld q Empty = q +meld (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 (meld x x) (quot y 2) + | y == 1 = x + | otherwise = g (meld x x) (quot (y - 1) 2) x + g x y z + | even y = g (meld x x) (quot y 2) z + | y == 1 = meld x z + | otherwise = g (meld x x) (quot (y - 1) 2) (meld 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(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 + +instance Monoid (Heap a) where + mempty = empty + mappend = meld + +-- | /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 meld 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 melding 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 + +meldUniq :: (a -> a -> Bool) -> Forest a -> Forest a -> Forest a +meldUniq _ Nil ts = ts +meldUniq _ ts Nil = ts +meldUniq f tts1@(t1 `Cons` ts1) tts2@(t2 `Cons` ts2) = case compare (rank t1) (rank t2) of + LT -> t1 `Cons` meldUniq f ts1 tts2 + EQ -> ins f (link f t1 t2) (meldUniq f ts1 ts2) + GT -> t2 `Cons` meldUniq 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' = meldUniq 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/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2010, Edward Kmett +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Edward Kmett nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/heaps.cabal b/heaps.cabal new file mode 100644 --- /dev/null +++ b/heaps.cabal @@ -0,0 +1,19 @@ +name: heaps +version: 0.1 +license: BSD3 +license-file: LICENSE +author: Edward A. Kmett +maintainer: Edward A. Kmett +stability: experimental +homepage: http://comonad.com/reader/ +category: Data Structures +synopsis: Asymptotically optimal Brodal/Okasaki heaps. +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.2 + +library + exposed-modules: Data.Heap + build-depends: + base >= 4 && < 6