Ticket #3909: containers-pqueue.5.patch

File containers-pqueue.5.patch, 47.8 KB (added by LouisWasserman, 4 years ago)

Contains both lazy pairing heap and binomial queue in separate patches. Gets rid of the ViewQ nonsense.

Line 
1Tue Mar  9 15:54:55 CST 2010  wasserman.louis@gmail.com
2  * Priority queues for containers
3
4Tue Mar  9 15:55:17 CST 2010  wasserman.louis@gmail.com
5  * Pairing queues for containers
6
7New patches:
8
9[Priority queues for containers
10wasserman.louis@gmail.com**20100309215455
11 Ignore-this: f653aaa1e6587a5836431bc2f05a9bec
12] {
13adddir ./Data/PQueue
14addfile ./Data/PQueue/Max.hs
15hunk ./Data/PQueue/Max.hs 1
16+{-# LANGUAGE CPP #-}
17hunk ./Data/PQueue/Max.hs 3
18+-----------------------------------------------------------------------------
19+-- |
20+-- Module      :  Data.PQueue.Max
21+-- Copyright   :  (c) Louis Wasserman 2010
22+-- License     :  BSD-style
23+-- Maintainer  :  libraries@haskell.org
24+-- Stability   :  experimental
25+-- Portability :  portable
26+--
27+-- General purpose priority queue, supporting extract-maximum operations.
28+--
29+-- An amortized running time is given for each operation, with /n/ referring
30+-- to the length of the sequence and /i/ being the integral index used by
31+-- some operations.  These bounds hold even in a persistent (shared) setting.
32+--
33+-- This implementation is based on a binomial heap augmented with a global root.
34+-- The spine of the heap is maintained strictly, ensuring that computations happen
35+-- as they are performed.  Note that this module is a small wrapper around
36+-- "Data.PQueue.Min".
37+--
38+-- /WARNING:/ 'toList' and 'toDescList' are /not/ equivalent, unlike for example
39+-- "Data.Map".
40+-----------------------------------------------------------------------------
41+module Data.PQueue.Max(
42+       MaxQueue,
43+       -- * Basic operations
44+       empty,
45+       null,
46+       size,
47+       -- * Query operations
48+       top,
49+       delete,
50+       extract,
51+       -- * Construction operations
52+       singleton,
53+       insert,
54+       union,
55+       unions,
56+       -- * Extracting elements
57+       (!!),
58+       take,
59+       drop,
60+       splitAt,
61+       takeWhile,
62+       dropWhile,
63+       span,
64+       break,
65+       filter,
66+       partition,
67+       -- * Fold\/Functor\/Traversable variations
68+       mapMonotonic,
69+       foldrDesc,
70+       foldlDesc,
71+       traverseMonotonic,
72+       -- * List operations
73+       toList,
74+       toDescList,
75+       fromList,
76+       fromDescList) where
77+
78+import Control.Applicative (Applicative(..), (<$>))
79+
80+import Data.Monoid
81+import Data.Foldable hiding (toList)
82+import Data.Traversable
83+import Data.Ord
84+
85+import qualified Data.PQueue.Min as Min
86+
87+import Prelude hiding (null, foldr, foldl, take, drop, takeWhile, dropWhile, splitAt, span, break, (!!), filter)
88+
89+#ifdef __GLASGOW_HASKELL__
90+import GHC.Exts (build)
91+import Text.Read (Lexeme(Ident), lexP, parens, prec,
92+       readPrec, readListPrec, readListPrecDefault)
93+#endif
94+
95+-- | A priority queue implementation.  Implemented as a wrapper around "Data.PQueue.Min".
96+-- /Warning/: the 'Functor', 'Foldable', and 'Traversable' instances of this type /ignore ordering/.
97+-- For 'Functor', it is guaranteed that if @f@ is a monotonic function, then @'fmap' f@ on a valid
98+-- 'MaxQueue' will return a valid 'MaxQueue'.  An analogous guarantee holds for 'traverse'.  (Note:
99+-- if passed constant-time operations, every function in 'Functor', 'Foldable', and 'Traversable'
100+-- will run in /O(n)/.)
101+--
102+-- If you wish to perform folds on a priority queue that respect order, use 'foldrDesc' or
103+-- 'foldlDesc'.
104+newtype MaxQueue a = MaxQ {unMaxQ :: Min.MinQueue (Down a)}
105+newtype Down a = Down {unDown :: a} deriving (Eq)
106+
107+instance Ord a => Ord (Down a) where
108+       Down x `compare` Down y = compare y x
109+       Down x <= Down y = y <= x
110+       Down x < Down y = y < x
111+       Down x >= Down y = y >= x
112+       Down x > Down y = y > x
113+
114+instance Ord a => Eq (MaxQueue a) where
115+       MaxQ q1 == MaxQ q2 = q1 == q2
116+
117+instance Ord a => Ord (MaxQueue a) where
118+       MaxQ q1 `compare` MaxQ q2 = q1 `compare` q2
119+
120+instance (Ord a, Show a) => Show (MaxQueue a) where
121+       showsPrec p xs = showParen (p > 10) $
122+               showString "fromDescList " . shows (toDescList xs)
123+               
124+instance Read a => Read (MaxQueue a) where
125+#ifdef __GLASGOW_HASKELL__
126+       readPrec = parens $ prec 10 $ do
127+               Ident "fromDescList" <- lexP
128+               xs <- readPrec
129+               return (fromDescList xs)
130+
131+       readListPrec = readListPrecDefault
132+#else
133+       readsPrec p = readParen (p > 10) $ \ r -> do
134+               ("fromDescList",s) <- lex r
135+               (xs,t) <- reads s
136+               return (fromDescList xs,t)
137+#endif
138+
139+instance Ord a => Monoid (MaxQueue a) where
140+       mempty = empty
141+       mappend = union
142+
143+-- | /O(1)/.  The empty priority queue.
144+empty :: MaxQueue a
145+empty = MaxQ Min.empty
146+
147+-- | /O(1)/.  Is this the empty priority queue?
148+null :: MaxQueue a -> Bool
149+null (MaxQ q) = Min.null q
150+
151+-- | /O(1)/.  The number of elements in the queue.
152+size :: MaxQueue a -> Int
153+size (MaxQ q) = Min.size q
154+
155+-- | /O(log n)/.  The top (maximum) element of the queue, if there is one.
156+top :: Ord a => MaxQueue a -> Maybe a
157+top = fmap fst . extract
158+
159+-- | /O(log n)/.  Extract the top (maximum) element of the sequence, if there is one.
160+extract :: Ord a => MaxQueue a -> Maybe (a, MaxQueue a)
161+extract (MaxQ q) = case Min.extract q of
162+       Nothing -> Nothing
163+       Just (Down x, q')
164+               -> Just (x, MaxQ q')
165+               
166+-- | /O(log n)/.  Delete the top (maximum) element of the sequence, if there is one.
167+delete :: Ord a => MaxQueue a -> Maybe (MaxQueue a)
168+delete = fmap snd . extract
169+
170+-- | /O(1)/.  Construct a priority queue with a single element.
171+singleton :: a -> MaxQueue a
172+singleton = MaxQ . Min.singleton . Down
173+
174+-- | /O(1)/.  Insert an element into the priority queue. 
175+insert :: Ord a => a -> MaxQueue a -> MaxQueue a
176+insert x (MaxQ q) = MaxQ (Min.insert (Down x) q)
177+
178+-- | /O(log (min(n,m)))/.  Take the union of two priority queues.
179+union :: Ord a => MaxQueue a -> MaxQueue a -> MaxQueue a
180+MaxQ q1 `union` MaxQ q2 = MaxQ (Min.union q1 q2)
181+
182+-- | Takes the union of a list of priority queues.  Equivalent to @'foldl' 'union' 'empty'@.
183+unions :: Ord a => [MaxQueue a] -> MaxQueue a
184+unions = foldl union empty
185+
186+-- | /O(k log n)/.  Returns the @(k+1)@th largest element of the queue.
187+(!!) :: Ord a => MaxQueue a -> Int -> a
188+MaxQ q !! n = unDown ((Min.!!) q n)
189+
190+{-# INLINE take #-}
191+-- | /O(k log n)/.  Returns the list of the @k@ largest elements of the queue, in descending order, or
192+-- all elements of the queue, if @k >= n@.
193+take :: Ord a => Int -> MaxQueue a -> [a]
194+take k (MaxQ q) = [a | Down a <- Min.take k q]
195+
196+-- | /O(k log n)/.  Returns the queue with the @k@ largest elements deleted, or the empty queue if @k >= n@.
197+drop :: Ord a => Int -> MaxQueue a -> MaxQueue a
198+drop k (MaxQ q) = MaxQ (Min.drop k q)
199+
200+-- | /O(k log n)/.  Equivalent to @(take k queue, drop k queue)@.
201+splitAt :: Ord a => Int -> MaxQueue a -> ([a], MaxQueue a)
202+splitAt k (MaxQ q) = (map unDown xs, MaxQ q') where
203+       (xs, q') = Min.splitAt k q
204+       
205+-- | 'takeWhile', applied to a predicate @p@ and a queue @queue@, returns the
206+-- longest prefix (possibly empty) of @queue@ of elements that satisfy @p@.
207+takeWhile :: Ord a => (a -> Bool) -> MaxQueue a -> [a]
208+takeWhile p (MaxQ q) = map unDown (Min.takeWhile (p . unDown) q)
209+
210+-- | 'dropWhile' @p queue@ returns the queue remaining after 'takeWhile' @p queue@.
211+--
212+dropWhile :: Ord a => (a -> Bool) -> MaxQueue a -> MaxQueue a
213+dropWhile p (MaxQ q) = MaxQ (Min.dropWhile (p . unDown) q)
214+
215+-- | 'span', applied to a predicate @p@ and a queue @queue@, returns a tuple where
216+-- first element is longest prefix (possibly empty) of @queue@ of elements that
217+-- satisfy @p@ and second element is the remainder of the queue.
218+--
219+span :: Ord a => (a -> Bool) -> MaxQueue a -> ([a], MaxQueue a)
220+span p (MaxQ q) = (map unDown xs, MaxQ q') where
221+       (xs, q') = Min.span (p . unDown) q
222+
223+-- | 'break', applied to a predicate @p@ and a queue @queue@, returns a tuple where
224+-- first element is longest prefix (possibly empty) of @queue@ of elements that
225+-- /do not satisfy/ @p@ and second element is the remainder of the queue.
226+break :: Ord a => (a -> Bool) -> MaxQueue a -> ([a], MaxQueue a)
227+break p = span (not . p)
228+
229+filter :: Ord a => (a -> Bool) -> MaxQueue a -> MaxQueue a
230+filter p (MaxQ q) = MaxQ (Min.filter (p . unDown) q)
231+
232+partition :: Ord a => (a -> Bool) -> MaxQueue a -> (MaxQueue a, MaxQueue a)
233+partition p (MaxQ q) = (MaxQ q0, MaxQ q1)
234+       where   (q0, q1) = Min.partition (p . unDown) q
235+
236+-- | /O(n)/.  Assumes that the function it is given is monotonic, and applies this function to every element of the priority queue,
237+-- as in 'fmap'.  If it is not, the result is undefined.
238+mapMonotonic :: (a -> b) -> MaxQueue a -> MaxQueue b
239+mapMonotonic = fmap
240+
241+-- | /O(n)/.  Assumes that the function it is given is monotonic, in some sense, and performs the 'traverse' operation.
242+-- If the function is not monotonic, the result is undefined.
243+traverseMonotonic :: Applicative f => (a -> f b) -> MaxQueue a -> f (MaxQueue b)
244+traverseMonotonic = traverse
245+
246+instance Functor Down where
247+       fmap f (Down a) = Down (f a)
248+
249+instance Foldable Down where
250+       foldr f z (Down a) = a `f` z
251+       foldl f z (Down a) = z `f` a
252+
253+instance Traversable Down where
254+       traverse f (Down a) = Down <$> f a
255+
256+instance Functor MaxQueue where
257+       fmap f (MaxQ q) = MaxQ (fmap (fmap f) q)
258+
259+instance Foldable MaxQueue where
260+       foldr f z (MaxQ q) = foldr (flip (foldr f)) z q
261+       foldl f z (MaxQ q) = foldl (foldl f) z q
262+
263+instance Traversable MaxQueue where
264+       traverse f (MaxQ q) = MaxQ <$> traverse (traverse f) q
265+
266+-- | /O(n log n)/.  Performs a right-fold on the elements of a priority queue in descending order.
267+foldrDesc :: Ord a => (a -> b -> b) -> b -> MaxQueue a -> b
268+foldrDesc f z (MaxQ q) = Min.foldrAsc (flip (foldr f)) z q
269+
270+-- | /O(n log n)/.  Performs a left-fold on the elements of a priority queue in descending order.
271+foldlDesc :: Ord a => (b -> a -> b) -> b -> MaxQueue a -> b
272+foldlDesc f z (MaxQ q) = Min.foldlAsc (foldl f) z q
273+
274+{-# INLINE toDescList #-}
275+-- | /O(n log n)/.  Extracts the elements of the priority queue in descending order.
276+toDescList :: Ord a => MaxQueue a -> [a]
277+#ifdef __GLASGOW_HASKELL__
278+toDescList q = build (\ c nil -> foldrDesc c nil q)
279+#else
280+toDescList = foldrDesc (:) []
281+#endif
282+
283+{-# INLINE toList #-}
284+-- | /O(n)/.  Returns the elements of the priority queue in no particular order.
285+toList :: MaxQueue a -> [a]
286+#ifdef __GLASGOW_HASKELL__
287+toList q = build (\ c nil -> foldr c nil q)
288+#else
289+toList = foldr (:) []
290+#endif
291+
292+{-# INLINE fromDescList #-}
293+-- | /O(n)/.  Constructs a priority queue from an descending list.  /Warning/: Does not check the precondition.
294+fromDescList :: [a] -> MaxQueue a
295+fromDescList = MaxQ . Min.fromAscList . map Down
296+
297+{-# INLINE fromList #-}
298+-- | /O(n log n)/.  Constructs a priority queue from an unordered list.
299+fromList :: Ord a => [a] -> MaxQueue a
300+fromList = foldr insert empty
301addfile ./Data/PQueue/Min.hs
302hunk ./Data/PQueue/Min.hs 1
303+{-# LANGUAGE CPP #-}
304hunk ./Data/PQueue/Min.hs 3
305+-----------------------------------------------------------------------------
306+-- |
307+-- Module      :  Data.PQueue.Min
308+-- Copyright   :  (c) Louis Wasserman 2010
309+-- License     :  BSD-style
310+-- Maintainer  :  libraries@haskell.org
311+-- Stability   :  experimental
312+-- Portability :  portable
313+--
314+-- General purpose priority queue, supporting extract-minimum operations.
315+--
316+-- An amortized running time is given for each operation, with /n/ referring
317+-- to the length of the sequence and /i/ being the integral index used by
318+-- some operations.  These bounds hold even in a persistent (shared) setting.
319+--
320+-- This implementation is based on a binomial heap augmented with a global root.
321+-- The spine of the heap is maintained strictly, ensuring that computations happen
322+-- as they are performed.
323+--
324+-- /WARNING:/ 'toList' and 'toAscList' are /not/ equivalent, unlike for example
325+-- "Data.Map".
326+-----------------------------------------------------------------------------
327+module Data.PQueue.Min (
328+       MinQueue,
329+       -- * Basic operations
330+       empty,
331+       null,
332+       size,
333+       -- * Query operations
334+       top,
335+       delete,
336+       extract,
337+       -- * Construction operations
338+       singleton,
339+       insert,
340+       union,
341+       unions,
342+       -- * Extracting elements
343+       (!!),
344+       take,
345+       drop,
346+       splitAt,
347+       takeWhile,
348+       dropWhile,
349+       span,
350+       break,
351+       filter,
352+       partition,
353+       -- * Fold\/Functor\/Traversable variations
354+       mapMonotonic,
355+       foldrAsc,
356+       foldlAsc,
357+       traverseMonotonic,
358+       -- * List operations
359+       toList,
360+       toAscList,
361+       fromList,
362+       fromAscList) where
363+
364+import Prelude hiding (null, foldr, foldl, take, drop, takeWhile, dropWhile, splitAt, span, break, (!!), filter)
365+
366+import Control.Applicative (Applicative(..), (<$>))
367+
368+import Data.Monoid
369+import Data.Foldable hiding (toList)
370+import Data.Traversable
371+
372+import qualified Data.List as List
373+
374+#ifdef __GLASGOW_HASKELL__
375+import GHC.Exts (build)
376+import Text.Read (Lexeme(Ident), lexP, parens, prec,
377+       readPrec, readListPrec, readListPrecDefault)
378+#else
379+
380+build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a]
381+build f = f (:) []
382+
383+#endif
384+
385+-- | A priority queue implementation.  Implemented as a find-min wrapper around a binomial heap.
386+-- /Warning/: the 'Functor', 'Foldable', and 'Traversable' instances of this type /ignore ordering/.
387+-- For 'Functor', it is guaranteed that if @f@ is a monotonic function, then @'fmap' f@ on a valid
388+-- 'MinQueue' will return a valid 'MinQueue'.  An analogous guarantee holds for 'traverse'.  (Note:
389+-- if passed constant-time operations, every function in 'Functor', 'Foldable', and 'Traversable'
390+-- will run in /O(n)/.)
391+--
392+-- If you wish to perform folds on a priority queue that respect order, use 'foldrAsc' or
393+-- 'foldlAsc'.
394+--
395+-- For any operation @op@ in 'Eq' or 'Ord', @queue1 `op` queue2@ is equivalent to
396+-- @toAscList queue1 `op` toAscList queue2@.
397+data MinQueue a = Empty | MinQueue {-# UNPACK #-} !Int a !(BinomHeap a)
398+type BinomHeap a = BinomForest a Zero
399+
400+instance Ord a => Eq (MinQueue a) where
401+       Empty == Empty = True
402+       MinQueue n1 x1 q1 == MinQueue n2 x2 q2
403+               = n1 == n2 && x1 == x2 && foldr (&&) True
404+                       (zipWith (==) (heapToList q1) (heapToList q2))
405+       _ == _ = False
406+
407+instance Ord a => Ord (MinQueue a) where
408+       Empty `compare` Empty = EQ
409+       Empty `compare` _ = LT
410+       _ `compare` Empty = GT
411+       MinQueue n1 x1 q1 `compare` MinQueue n2 x2 q2 =
412+               compare x1 x2 `mappend` foldr mappend (compare n1 n2) (zipWith compare (heapToList q1) (heapToList q1))
413+               -- We compare their first elements, then their other elements up to the smaller queue's length,
414+               -- and then the longer queue wins.
415+               -- This is equivalent to @comparing toAscList@, except it fuses much more nicely.
416+
417+heapToList :: Ord a => BinomHeap a -> [a]
418+heapToList q = build (\ c nil -> foldrUnfold c nil extractHeap q)
419+
420+instance (Ord a, Show a) => Show (MinQueue a) where
421+       showsPrec p xs = showParen (p > 10) $
422+               showString "fromAscList " . shows (toAscList xs)
423+
424+instance Read a => Read (MinQueue a) where
425+#ifdef __GLASGOW_HASKELL__
426+       readPrec = parens $ prec 10 $ do
427+               Ident "fromAscList" <- lexP
428+               xs <- readPrec
429+               return (fromAscList xs)
430+
431+       readListPrec = readListPrecDefault
432+#else
433+       readsPrec p = readParen (p > 10) $ \ r -> do
434+               ("fromAscList",s) <- lex r
435+               (xs,t) <- reads s
436+               return (fromAscList xs,t)
437+#endif
438+
439+instance Ord a => Monoid (MinQueue a) where
440+       mempty = Empty
441+       mappend = union
442+       mconcat = unions
443+
444+-- We implement tree ranks in the type system with a nicely elegant approach, as follows.
445+-- The goal is to have the type system automatically guarantee that our binomial forest
446+-- has the correct binomial structure.
447+--
448+-- In the traditional set-theoretic construction of the natural numbers, we define
449+-- each number to be the set of numbers less than it, and zero to be the empty set,
450+-- as follows:
451+--
452+-- 0 = {}      1 = {0}         2 = {0, 1}      3={0, 1, 2} ...
453+--
454+-- Binomial trees have a similar structure: a tree of rank @k@ has one child of each
455+-- rank less than @k@.  Let's define the type @rk@ corresponding to rank @k@ to refer
456+-- to a collection of binomial trees of ranks @0..k-1@.  Then we can say that
457+--
458+-- > data Succ e rk = Succ (BinomTree e rk) rk
459+--
460+-- and this behaves exactly as the successor operator for ranks should behave.  Furthermore,
461+-- we immediately obtain that
462+--
463+-- > data BinomTree e rk = BinomTree e rk
464+--
465+-- which is nice and compact.
466+data BinomForest e rk = Nil | Skip !(BinomForest' e rk) | Cons {-# UNPACK #-} !(BinomTree e rk) !(BinomForest' e rk)
467+type BinomForest' e rk = BinomForest e (Succ e rk)
468+
469+data BinomTree e rk = BinomTree e rk
470+type BinomTree' e rk = BinomTree e (Succ e rk)
471+data Succ e rk = Succ {-# UNPACK #-} !(BinomTree e rk) rk
472+type Zero = ()
473+
474+-- basics
475+
476+-- | /O(1)/.  The empty priority queue.
477+empty :: MinQueue a
478+empty = Empty
479+
480+-- | /O(1)/.  Is this the empty priority queue?
481+null :: MinQueue a -> Bool
482+null Empty = True
483+null _ = False
484+
485+-- | /O(1)/.  The number of elements in the queue.
486+size :: MinQueue a -> Int
487+size Empty = 0
488+size (MinQueue n _ _) = n
489+
490+-- queries
491+-- | /O(1)/.  View the top (minimum) element of the queue, if there is one.
492+top :: Ord a => MinQueue a -> Maybe a
493+top = fmap fst . extract
494+
495+-- | /O(log n)/.  Delete the top element of the sequence, if there is one.
496+delete :: Ord a => MinQueue a -> Maybe (MinQueue a)
497+delete = fmap snd . extract
498+
499+-- | /O(log n)/.  Extract the top (minimum) element of the sequence, if there is one.
500+extract :: Ord a => MinQueue a -> Maybe (a, MinQueue a)
501+extract Empty = Nothing
502+extract (MinQueue n x ts) = Just (x, case extractBin (<=) ts of
503+       NoExtract               -> Empty
504+       YesExtract x' _ ts'     -> MinQueue (n-1) x' ts')
505+
506+-- | /O(1)/.  Construct a priority queue with a single element.
507+singleton :: a -> MinQueue a
508+singleton x = MinQueue 1 x Nil
509+
510+-- | /O(1)/.  Insert an element into the priority queue. 
511+insert :: Ord a => a -> MinQueue a -> MinQueue a
512+insert x' (MinQueue n x f)
513+       | x' <= x       = MinQueue (n+1) x' (insertBin x f)
514+       | otherwise     = MinQueue (n+1) x (insertBin x' f)
515+       where   insertBin = carry1 (<=) . tip
516+insert x Empty = singleton x
517+
518+-- | /O(log (min(n,m)))/.  Take the union of two priority queues.
519+union :: Ord a => MinQueue a -> MinQueue a -> MinQueue a
520+union = union' (<=)
521+
522+-- | Takes the union of a list of priority queues.  Equivalent to @'foldl' 'union' 'empty'@.
523+unions :: Ord a => [MinQueue a] -> MinQueue a
524+unions = foldl union Empty
525+
526+-- | Index (subscript) operator, starting from 0.  @queue !! k@ returns the @(k+1)@th smallest element in the queue.
527+(!!) :: Ord a => MinQueue a -> Int -> a
528+q !! n | n >= size q
529+               = error "Data.PQueue.Min.!!: index too large"
530+q !! n = (List.!!) (toAscList q) n
531+
532+{-# INLINE takeWhile #-}
533+-- | 'takeWhile', applied to a predicate @p@ and a queue @queue@, returns the
534+-- longest prefix (possibly empty) of @queue@ of elements that satisfy @p@.
535+takeWhile :: Ord a => (a -> Bool) -> MinQueue a -> [a]
536+takeWhile p queue = foldWhileFB p (toAscList queue)
537+
538+{-# INLINE foldWhileFB #-}
539+foldWhileFB :: (a -> Bool) -> [a] -> [a]
540+foldWhileFB p xs = build (\ c nil -> let
541+       consWhile x xs
542+               | p x           = x `c` xs
543+               | otherwise     = nil
544+       in foldr consWhile nil xs)
545+
546+-- | 'dropWhile' @p queue@ returns the queue remaining after 'takeWhile' @p queue@.
547+dropWhile :: Ord a => (a -> Bool) -> MinQueue a -> MinQueue a
548+dropWhile p = drop' where
549+       drop' q = case extract q of
550+         Just (x, q')
551+               | p x   -> drop' q'
552+         _             -> q
553+
554+-- | 'span', applied to a predicate @p@ and a queue @queue@, returns a tuple where
555+-- first element is longest prefix (possibly empty) of @queue@ of elements that
556+-- satisfy @p@ and second element is the remainder of the queue.
557+span :: Ord a => (a -> Bool) -> MinQueue a -> ([a], MinQueue a)
558+span p queue = case extract queue of
559+       Just (x, q') | p x     
560+                       -> let (ys, q'') = span p q' in (x:ys, q'')
561+       _               -> ([], queue)
562+
563+-- | 'break', applied to a predicate @p@ and a queue @queue@, returns a tuple where
564+-- first element is longest prefix (possibly empty) of @queue@ of elements that
565+-- /do not satisfy/ @p@ and second element is the remainder of the queue.
566+break :: Ord a => (a -> Bool) -> MinQueue a -> ([a], MinQueue a)
567+break p = span (not . p)
568+
569+{-# INLINE take #-}
570+-- | /O(k log n)/. 'take' @k@, applied to a queue @queue@, returns a list of the smallest @k@ elements of @queue@,
571+-- or all elements of @queue@ itself if @k >= 'size' queue@.
572+take :: Ord a => Int -> MinQueue a -> [a]
573+take n = List.take n . toAscList
574+
575+-- | /O(k log n)/.  'drop' @k@, applied to a queue @queue@, returns @queue@ with the smallest @k@ elements deleted,
576+-- or an empty queue if @k >= size 'queue'@.
577+drop :: Ord a => Int -> MinQueue a -> MinQueue a
578+drop n queue = n `seq` case delete queue of
579+       Just queue'
580+         | n > 0       -> drop (n-1) queue'
581+       _               -> queue
582+
583+-- | /O(k log n)/.  Equivalent to @('take' k queue, 'drop' k queue)@.
584+splitAt :: Ord a => Int -> MinQueue a -> ([a], MinQueue a)
585+splitAt n queue = n `seq` case extract queue of
586+       Just (x, queue')
587+         | n > 0       -> let (xs, queue'') = splitAt (n-1) queue' in (x:xs, queue'')
588+       _               -> ([], queue)
589+
590+-- | /O(n)/.  Returns the queue with all elements not satisfying @p@ removed.
591+filter :: Ord a => (a -> Bool) -> MinQueue a -> MinQueue a
592+filter _ Empty = Empty
593+filter p (MinQueue _ x ts) = if p x then insertMinQ x q' else q'
594+       where   q' = filterQueue p (<=) (const Empty) Empty ts
595+
596+partition :: Ord a => (a -> Bool) -> MinQueue a -> (MinQueue a, MinQueue a)
597+partition _ Empty = (Empty, Empty)
598+partition p (MinQueue _ x ts) = case partitionQueue p (<=) (const (Empty, Empty)) (Empty, Empty) ts of
599+       (q0, q1)  | p x         -> (insertMinQ x q0, q1)
600+                 | otherwise   -> (q0, insertMinQ x q1)
601+
602+-- | /O(n)/.  Assumes that the function it is given is monotonic, and applies this function to every element of the priority queue,
603+-- as in 'fmap'.  If it is not, the result is undefined.
604+mapMonotonic :: (a -> b) -> MinQueue a -> MinQueue b
605+mapMonotonic = fmap
606+
607+-- | /O(n)/.  Assumes that the function it is given is monotonic, in some sense, and performs the 'traverse' operation.
608+-- If the function is not monotonic, the result is undefined.
609+traverseMonotonic :: Applicative f => (a -> f b) -> MinQueue a -> f (MinQueue b)
610+traverseMonotonic = traverse
611+
612+{-# INLINE toAscList #-}
613+-- | /O(n log n)/.  Extracts the elements of the priority queue in ascending order.
614+toAscList :: Ord a => MinQueue a -> [a]
615+toAscList queue = build (\ c nil -> foldrAsc c nil queue)
616+
617+{-# INLINE toList #-}
618+-- | /O(n)/.  Returns the elements of the priority queue in no particular order.
619+toList :: MinQueue a -> [a]
620+toList q = build (\ c nil -> foldr c nil q)
621+
622+{-# INLINE foldrAsc #-}
623+-- | /O(n log n)/.  Performs a right-fold on the elements of a priority queue in ascending order.
624+foldrAsc :: Ord a => (a -> b -> b) -> b -> MinQueue a -> b
625+foldrAsc f z q = case q of
626+       Empty           -> z
627+       MinQueue _ x ts -> x `f` foldrUnfold f z extractHeap ts
628+
629+{-# INLINE foldrUnfold #-}
630+foldrUnfold :: (a -> c -> c) -> c -> (b -> Maybe (a, b)) -> b -> c
631+foldrUnfold c nil suc s0 = unf s0 where
632+       unf x = case suc x of
633+               Nothing         -> nil
634+               Just (a, x')    -> a `c` unf x'
635+
636+-- | /O(n log n)/.  Performs a left-fold on the elements of a priority queue in ascending order.
637+foldlAsc :: Ord a => (b -> a -> b) -> b -> MinQueue a -> b
638+foldlAsc f z q = case extract q of
639+       Nothing         -> z
640+       Just (x, q')    -> foldlAsc f (z `f` x) q'
641+
642+{-# INLINE fromList #-}
643+-- | /O(n)/.  Constructs a priority queue from an unordered list.
644+fromList :: Ord a => [a] -> MinQueue a
645+fromList = foldr insert Empty
646+
647+{-# INLINE fromAscList #-}
648+-- | /O(n)/.  Constructs a priority queue from an ascending list.  /Warning/: Does not check the precondition.
649+fromAscList :: [a] -> MinQueue a
650+fromAscList = foldr insertMinQ Empty
651+
652+{-# INLINE union' #-}
653+union' :: (a -> a -> Bool) -> MinQueue a -> MinQueue a -> MinQueue a
654+union' _ Empty q = q
655+union' _ q Empty = q
656+union' (<=) (MinQueue n1 x1 f1) (MinQueue n2 x2 f2)
657+       | x1 <= x2      = MinQueue (n1 + n2) x1 (carry (<=) (tip x2) f1 f2)
658+       | otherwise     = MinQueue (n1 + n2) x2 (carry (<=) (tip x1) f1 f2)
659+
660+-- | Takes a size and a binomial forest and produces a priority queue with a distinguished global root.
661+extractHeap :: Ord a => BinomHeap a -> Maybe (a, BinomHeap a)
662+extractHeap ts = case extractBin (<=) ts of
663+       NoExtract       -> Nothing
664+       YesExtract x _ ts'
665+                       -> Just (x, ts')
666+
667+-- | A specialized type intended to organize the return of extract-min queries
668+-- from a binomial forest.  We walk all the way through the forest, and then
669+-- walk backwards.  @Extract e rk@ is the result type of an extract-min
670+-- operation that has walked as far backwards of rank @rk@ -- that is, it
671+-- has visited every root of rank @>= rk@.
672+--
673+-- The interpretation of @YesExtract minKey children forest@ is
674+--
675+--     * @minKey@ is the key of the minimum root visited so far.  It may have
676+--             any rank @>= rk@.  We will denote the root corresponding to
677+--             @minKey@ as @minRoot@.
678+--     
679+--     * @children@ is those children of @minRoot@ which have not yet been
680+--             merged with the rest of the forest. Specifically, these are
681+--             the children with rank @< rk@.
682+--     
683+--     * @forest@ is an accumulating parameter that maintains the partial
684+--             reconstruction of the binomial forest without @minRoot@. It is
685+--             the union of all old roots with rank @>= rk@ (except @minRoot@),
686+--             with the set of all children of @minRoot@ with rank @>= rk@. 
687+--             Note that @forest@ is lazy, so if we discover a smaller key
688+--             than @minKey@ later, we haven't wasted significant work.
689+data Extract e rk = NoExtract | YesExtract e rk (BinomForest e rk)
690+
691+-- | Walks backward from the biggest key in the forest, as far as rank @rk@.
692+-- Returns its progress.  Each successive application of @extractBin@ takes
693+-- amortized /O(1)/ time, so applying it from the beginning takes /O(log n)/ time.
694+extractBin :: (e -> e -> Bool) -> BinomForest e rk -> Extract e rk
695+extractBin _ Nil = NoExtract
696+extractBin (<=) (Skip f) = case extractBin (<=) f of
697+       NoExtract -> NoExtract
698+       YesExtract minKey (Succ kChild kChildren) f' ->
699+               YesExtract minKey kChildren (Cons kChild f')
700+extractBin (<=) (Cons t@(BinomTree x ts) f) = case extractBin (<=) f of
701+       YesExtract minKey (Succ kChild kChildren) f'
702+               | minKey < x    -> YesExtract minKey kChildren (Skip (carry1 (<=) (t `cat` kChild) f'))
703+       _                       -> YesExtract x ts (Skip f)
704+       where   cat = joinBin (<=)
705+               a < b = not (b <= a)
706+
707+filterQueue :: (a -> Bool) -> (a -> a -> Bool) -> (rk -> MinQueue a) -> MinQueue a -> BinomForest a rk -> MinQueue a
708+filterQueue p (<=) fCh q0 forest = q0 `seq` case forest of
709+       Nil             -> q0
710+       Skip forest'    -> filterQueue p (<=) fCh' q0 forest'
711+       Cons t forest'  -> filterQueue p (<=) fCh' (union' (<=) (filterT t) q0) forest'
712+       where   fCh' (Succ t tss) = union' (<=) (filterT t) (fCh tss)
713+               filterT (BinomTree x ts)
714+                       | p x           = insertMinQ x (fCh ts)
715+                       | otherwise     = fCh ts
716+
717+type Partition a = (MinQueue a, MinQueue a)
718+
719+partitionQueue :: (a -> Bool) -> (a -> a -> Bool) -> (rk -> Partition a) -> Partition a ->
720+       BinomForest a rk -> Partition a
721+partitionQueue p (<=) fCh (q0, q1) forest = q0 `seq` q1 `seq` case forest of
722+       Nil             -> (q0, q1)
723+       Skip forest'    -> partitionQueue p (<=) fCh' (q0, q1) forest'
724+       Cons t forest'  -> partitionQueue p (<=) fCh' (both (union' (<=)) (partitionT t) (q0, q1)) forest'
725+       where   both f (x1, x2) (y1, y2) = (f x1 y1, f x2 y2)
726+               fCh' (Succ t tss) = both (union' (<=)) (partitionT t) (fCh tss)
727+               partitionT (BinomTree x ts) = case fCh ts of
728+                       (q0, q1)
729+                               | p x           -> (insertMinQ x q0, q1)
730+                               | otherwise     -> (q0, insertMinQ x q1)
731+
732+{-# INLINE tip #-}
733+-- | Constructs a binomial tree of rank 0.
734+tip :: e -> BinomTree e ()
735+tip x = BinomTree x ()
736+
737+-- | Given two binomial forests starting at rank @rk@, takes their union.
738+-- Each successive application of this function costs /O(1)/, so applying it
739+-- from the beginning costs /O(log n)/.
740+merge :: (e -> e -> Bool) -> BinomForest e rk -> BinomForest e rk -> BinomForest e rk
741+merge (<=) f1 f2 = case (f1, f2) of
742+       (Nil, _)        -> f2
743+       (_, Nil)        -> f1
744+       (Skip f1', Skip f2')
745+                       -> Skip (merge (<=) f1' f2')
746+       (Skip f1', Cons t2 f2')
747+                       -> Cons t2 (merge (<=) f1' f2')
748+       (Cons t1 f1', Skip f2')
749+                       -> Cons t1 (merge (<=) f1' f2')
750+       (Cons t1 f1', Cons t2 f2')
751+                       -> Skip (carry (<=) (t1 `cat` t2) f1' f2')
752+       where   cat = joinBin (<=)
753+
754+-- | Merges two binomial forests with another tree. If we are thinking of the trees
755+-- in the binomial forest as binary digits, this corresponds to a carry operation.
756+-- Each call to this function takes /O(1)/ time, so in total, it costs /O(log n)/.
757+carry :: (e -> e -> Bool) -> BinomTree e rk -> BinomForest e rk -> BinomForest e rk -> BinomForest e rk
758+carry (<=) t0 f1 f2 = t0 `seq` case (f1, f2) of
759+       (Nil, Nil)              -> Cons t0 Nil
760+       (Nil, Skip f2')         -> Cons t0 f2'
761+       (Skip f1', Nil)         -> Cons t0 f1'
762+       (Nil, Cons t2 f2')      -> Skip (carry1 (<=) (t0 `cat` t2) f2')
763+       (Cons t1 f1', Nil)      -> Skip (carry1 (<=) (t0 `cat` t1) f1')
764+       (Skip f1', Skip f2')    -> Cons t0 (merge (<=) f1' f2')
765+       (Skip f1', Cons t2 f2') -> Skip (mergeCarry t0 t2 f1' f2')
766+       (Cons t1 f1', Skip f2') -> Skip (mergeCarry t0 t1 f1' f2')
767+       (Cons t1 f1', Cons t2 f2')
768+                               -> Cons t0 (mergeCarry t1 t2 f1' f2')
769+       where   cat = joinBin (<=)
770+               mergeCarry tA tB f1 f2 = carry (<=) (tA `cat` tB) f1 f2
771+
772+-- | Merges a binomial tree into a binomial forest.  If we are thinking
773+-- of the trees in the binomial forest as binary digits, this corresponds
774+-- to adding a power of 2.  This costs amortized /O(1)/ time.
775+carry1 :: (e -> e -> Bool) -> BinomTree e rk -> BinomForest e rk -> BinomForest e rk
776+carry1 (<=) t f = t `seq` case f of
777+       Nil     -> Cons t Nil
778+       Skip f  -> Cons t f
779+       Cons t' f' -> Skip (carry1 (<=) (t `cat` t') f')
780+       where   cat = joinBin (<=)
781+
782+-- | The carrying operation: takes two binomial heaps of the same rank @k@
783+-- and returns one of rank @k+1@.  Takes /O(1)/ time.
784+joinBin :: (e -> e -> Bool) -> BinomTree e rk -> BinomTree e rk -> BinomTree' e rk
785+joinBin (<=) t1@(BinomTree x1 ts1) t2@(BinomTree x2 ts2)
786+       | x1 <= x2      = BinomTree x1 (Succ t2 ts1)
787+       | otherwise     = BinomTree x2 (Succ t1 ts2)
788+
789+instance Functor MinQueue where
790+       fmap _ Empty = Empty
791+       fmap f (MinQueue n x forest) = MinQueue n (f x) (fmap2 f (const ()) forest)
792+
793+class Bifunctor f where
794+       fmap2 :: (x -> x') -> (y -> y') -> f x y -> f x' y'
795+
796+instance Bifunctor BinomForest where
797+       fmap2 f g ts = case ts of
798+               Nil             -> Nil
799+               Skip ts'        -> Skip (fmap2 f g' ts')
800+               Cons t ts'      -> Cons (fmap2 f g t) (fmap2 f g' ts')
801+               where   g' = fmap2 f g
802+
803+instance Bifunctor BinomTree where
804+       fmap2 f g (BinomTree x ts) = BinomTree (f x) (g ts)
805+
806+instance Bifunctor Succ where
807+       fmap2 f g (Succ t ts) = Succ (fmap2 f g t) (g ts)
808+
809+instance Foldable MinQueue where
810+       foldr _ z Empty = z
811+       foldr f z (MinQueue _ x ts) = x `f` foldr2 f (const id) z ts
812+       foldl _ z Empty = z
813+       foldl f z (MinQueue _ x ts) = foldl2 f const (z `f` x) ts
814+       foldl1 f Empty = error "Error: foldl1 called on an empty queue"
815+       foldl1 f (MinQueue _ x ts) = foldl2 f const x ts
816+
817+class Bifoldable f where
818+       foldr2 :: (a -> c -> c) -> (b -> c -> c) -> c -> f a b -> c
819+       foldl2 :: (c -> a -> c) -> (c -> b -> c) -> c -> f a b -> c
820+
821+instance Bifoldable BinomForest where
822+       foldr2 f g z ts = case ts of
823+               Nil             -> z
824+               Skip ts'        -> foldr2 f g' z ts'
825+               Cons t ts'      -> foldr2 f g (foldr2 f g' z ts') t
826+               where   g' = flip (foldr2 f g)
827+       foldl2 f g z ts = case ts of
828+               Nil             -> z
829+               Skip ts'        -> foldl2 f g' z ts'
830+               Cons t ts'      -> foldl2 f g' (foldl2 f g z t) ts'
831+               where   g' = foldl2 f g
832+
833+instance Bifoldable BinomTree where
834+       foldr2 f g z (BinomTree x ts) = x `f` (ts `g` z)
835+       foldl2 f g z (BinomTree x ts) = z `f` x `g` ts
836+
837+instance Bifoldable Succ where
838+       foldr2 f g z (Succ t ts) = foldr2 f g (ts `g` z) t
839+       foldl2 f g z (Succ t ts) = foldl2 f g z t `g` ts
840+
841+instance Traversable MinQueue where
842+       traverse _ Empty = pure Empty
843+       traverse f (MinQueue n x ts) = MinQueue n <$> f x <*> traverse2 f (const (pure ())) ts
844+
845+class Bitraversable t where
846+       traverse2 :: Applicative f => (a -> f a') -> (b -> f b') ->
847+               t a b -> f (t a' b')
848+
849+instance Bitraversable BinomForest where
850+       traverse2 f g ts = case ts of
851+               Nil             -> pure Nil
852+               Skip ts'        -> Skip <$> traverse2 f g' ts'
853+               Cons t ts'      -> Cons <$> traverse2 f g t <*> traverse2 f g' ts'
854+               where   g' = traverse2 f g
855+
856+instance Bitraversable BinomTree where
857+       traverse2 f g (BinomTree x ts) = BinomTree <$> f x <*> g ts
858+
859+instance Bitraversable Succ where
860+       traverse2 f g (Succ t ts) = Succ <$> traverse2 f g t <*> g ts
861+
862+insertMinQ :: a -> MinQueue a -> MinQueue a
863+insertMinQ x Empty = singleton x
864+insertMinQ x (MinQueue n x' f) = MinQueue (n+1) x (insertMin (tip x') f)
865+
866+-- | @insertMin t f@ assumes that the root of @t@ compares as less than
867+-- every other root in @f@, and merges accordingly.
868+insertMin :: BinomTree e rk -> BinomForest e rk -> BinomForest e rk
869+insertMin t Nil = Cons t Nil
870+insertMin t (Skip f) = Cons t f
871+insertMin (BinomTree x ts) (Cons t' f) = Skip (insertMin (BinomTree x (Succ t' ts)) f)
872hunk ./containers.cabal 36
873             Data.Graph
874             Data.Sequence
875             Data.Tree
876+            Data.PQueue.Min
877+            Data.PQueue.Max
878+            Data.PQueue
879     }
880     if impl(ghc) {
881         extensions: DeriveDataTypeable, MagicHash, Rank2Types
882}
883[Pairing queues for containers
884wasserman.louis@gmail.com**20100309215517
885 Ignore-this: a6590ad2ef6609ca45ead31548efbf3c
886] {
887addfile ./Data/PQueue/Pairing.hs
888hunk ./Data/PQueue/Pairing.hs 1
889-
890+{-# LANGUAGE CPP #-}
891+
892+-----------------------------------------------------------------------------
893+-- |
894+-- Module      :  Data.PQueue.Pairing
895+-- Copyright   :  (c) Louis Wasserman 2010
896+-- License     :  BSD-style
897+-- Maintainer  :  libraries@haskell.org
898+-- Stability   :  experimental
899+-- Portability :  portable
900+--
901+-- General-purpose priority queue implementation built on a min-pairing-heap.
902+--
903+-- This implementation is extremely speedy, especially when used in a single-threaded
904+-- fashion.  However, the amortized bounds are only valid in a single-threaded context,
905+-- and the worst-case performance of |deleteMin| is /O(n)/.  However, when used in
906+-- a single-threaded context, this can be twice as fast as the binomial heap implementation.
907+--
908+-----------------------------------------------------------------------------
909+module Data.PQueue.Pairing (
910+       PQueue,
911+       -- * Basic operations
912+       empty,
913+       null,
914+       size,
915+       -- * Query operations
916+       top,
917+       delete,
918+       extract,
919+       -- * Construction operations
920+       singleton,
921+       insert,
922+       union,
923+       unions,
924+--     intersection,
925+--     difference,
926+       -- * Extracting elements
927+       (!!),
928+       take,
929+       drop,
930+       splitAt,
931+       takeWhile,
932+       dropWhile,
933+       span,
934+       break,
935+       -- * Fold\/Functor\/Traversable variations
936+       mapMonotonic,
937+       foldrAsc,
938+       foldlAsc,
939+       traverseMonotonic,
940+       -- * Filter
941+       filter,
942+       partition,
943+       -- * List operations
944+       toList,
945+       toAscList,
946+       fromList,
947+       fromAscList) where
948+
949+import Control.Applicative hiding (empty)
950+
951+import Data.Maybe
952+import Data.Monoid
953+import Data.Foldable hiding (toList, foldl')
954+import Data.Traversable
955+
956+import qualified Data.List as List
957+
958+import Prelude hiding (null, foldr, foldl, foldl1, take, drop, takeWhile, dropWhile, splitAt, span, break, (!!),
959+       filter)
960+
961+#ifdef __GLASGOW_HASKELL__
962+import GHC.Exts (build)
963+import Text.Read (Lexeme(Ident), lexP, parens, prec,
964+       readPrec, readListPrec, readListPrecDefault)
965+#else
966+
967+build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a]
968+build f = f (:) []
969+
970+#endif
971+
972+data PQueue a = Empty | PairQ {-# UNPACK #-} !Int {-# UNPACK #-} !(PHeap a)
973+data PHeap a = PHeap a (PChildren a)
974+data PChildren a = Zero | One {-# UNPACK #-} !(PHeap a) | Two {-# UNPACK #-} !(PHeap a) {-# UNPACK #-} !(PHeap a)
975+
976+instance Ord a => Eq (PQueue a) where
977+       Empty == Empty = True
978+       PairQ n1 t1 == PairQ n2 t2 = n1 == n2 && foldr (&&) True (zipWith (==) (heapToList t1) (heapToList t2))
979+               -- This is a compromise between unrolling the entire thing by hand, and allocating unnecessary
980+               -- lists.
981+       _ == _ = False
982+
983+instance Ord a => Ord (PQueue a) where
984+       compare Empty Empty = EQ
985+       compare Empty PairQ{} = LT
986+       compare PairQ{} Empty = GT
987+       compare (PairQ n1 t1) (PairQ n2 t2)
988+               = foldr mappend (compare n1 n2) (zipWith compare (heapToList t1) (heapToList t2))
989+               -- This is a compromise between unrolling the entire thing by hand, and allocating unnecessary
990+               -- lists.
991+
992+heapToList :: Ord a => PHeap a -> [a]
993+heapToList t = build (\ c nil -> foldrAscH (<=) c nil t)
994+
995+instance Ord a => Monoid (PQueue a) where
996+       mempty = empty
997+       mappend = union
998+       mconcat = unions
999+
1000+instance (Ord a, Show a) => Show (PQueue a) where
1001+       showsPrec p xs = showParen (p > 10) $
1002+               showString "fromAscList " . shows (toAscList xs)
1003+
1004+instance Read a => Read (PQueue a) where
1005+#ifdef __GLASGOW_HASKELL__
1006+       readPrec = parens $ prec 10 $ do
1007+               Ident "fromAscList" <- lexP
1008+               xs <- readPrec
1009+               return (fromAscList xs)
1010+
1011+       readListPrec = readListPrecDefault
1012+#else
1013+       readsPrec p = readParen (p > 10) $ \ r -> do
1014+               ("fromAscList",s) <- lex r
1015+               (xs,t) <- reads s
1016+               return (fromAscList xs,t)
1017+#endif
1018+
1019+instance Functor PHeap where
1020+       fmap f (PHeap x ts) = PHeap (f x) (fmap f ts)
1021+
1022+instance Functor PChildren where
1023+       fmap _ Zero = Zero
1024+       fmap f (One t) = One (fmap f t)
1025+       fmap f (Two t1 t2) = Two (fmap f t1) (fmap f t2)
1026+
1027+instance Functor PQueue where
1028+       fmap _ Empty = Empty
1029+       fmap f (PairQ n t) = PairQ n (fmap f t)
1030+
1031+instance Foldable PHeap where
1032+       foldr f z (PHeap x ts) = x `f` foldr f z ts
1033+       foldl f z (PHeap x ts) = foldl f (z `f` x) ts
1034+       foldl1 f (PHeap x ts) = foldl f x ts
1035+
1036+instance Foldable PChildren where
1037+       foldr f z ts = case ts of
1038+               Zero            -> z
1039+               One t           -> foldr f z t
1040+               Two t1 t2       -> foldr f (foldr f z t2) t1
1041+
1042+instance Foldable PQueue where
1043+       foldr _ z Empty = z
1044+       foldr f z (PairQ _ t) = foldr f z t
1045+       foldl _ z Empty = z
1046+       foldl f z (PairQ _ t) = foldl f z t
1047+       foldl1 f (PairQ _ t) = foldl1 f t
1048+       foldl1 _ _ = error "Error: foldl1 called on empty queue"
1049+
1050+instance Traversable PHeap where
1051+       traverse f (PHeap x t) = PHeap <$> f x <*> traverse f t
1052+
1053+instance Traversable PChildren where
1054+       traverse f ts = case ts of
1055+               Zero            -> pure Zero
1056+               One t           -> One <$> traverse f t
1057+               Two t1 t2       -> Two <$> traverse f t1 <*> traverse f t2
1058+
1059+instance Traversable PQueue where
1060+       traverse _ Empty = pure Empty
1061+       traverse f (PairQ n t) = PairQ n <$> traverse f t
1062+
1063+-- | /O(1)/.  The empty priority queue.
1064+empty :: PQueue a
1065+empty = Empty
1066+
1067+-- | /O(1)/.  Is this the empty priority queue?
1068+null :: PQueue a -> Bool
1069+null Empty = True
1070+null _ = False
1071+
1072+-- | /O(1)/.  The number of elements in the queue.
1073+size :: PQueue a -> Int
1074+size Empty = 0
1075+size (PairQ n _) = n
1076+
1077+-- | /O(1)/.  Construct a priority queue with a single element.
1078+singleton :: a -> PQueue a
1079+singleton = PairQ 1 . tip
1080+
1081+-- | /O(1)/.  Insert an element into the priority queue. 
1082+insert :: Ord a => a -> PQueue a -> PQueue a
1083+insert x Empty = singleton x
1084+insert x (PairQ n q) = PairQ (n+1) (meldHeap (<=) (tip x) q)
1085+
1086+-- | /O(1)/.  Take the union of two priority queues.
1087+union :: Ord a => PQueue a -> PQueue a -> PQueue a
1088+Empty `union` q = q
1089+q `union` Empty        = q
1090+PairQ n1 q1 `union` PairQ n2 q2 = PairQ (n1 + n2) (meldHeap (<=) q1 q2)
1091+
1092+-- | /O(n)/.  Takes the union of a list of priority queues.  Produces a better-balanced
1093+-- priority queue than /foldr union empty/,
1094+unions :: Ord e => [PQueue e] -> PQueue e
1095+unions = makeUnion0 (<=)
1096+  where        makeUnion0 _ []                 = Empty
1097+       makeUnion0 (<=) (Empty:qs)      = makeUnion0 (<=) qs
1098+       makeUnion0 (<=) (PairQ n t:qs)  = makeUnion10 n t qs where
1099+               makeUnion10 n t qs = n `seq` t `seq` case qs of
1100+                       Empty:qs'       -> makeUnion10 n t qs'
1101+                       PairQ n' t':qs' -> makeUnion11 (n + n') t t' qs'
1102+                       []              -> PairQ n t
1103+               makeUnion11 n t0 t1 qs = n `seq` t0 `seq` t1 `seq` case qs of
1104+                       Empty:qs'       -> makeUnion11 n t0 t1 qs'
1105+                       PairQ n2 t2:qs' -> makeUnion10 (n + n2) (t0 `meld` (t1 `meld` t2)) qs'
1106+                       []              -> PairQ n (t0 `meld` t1)
1107+               meld = meldHeap (<=)
1108+
1109+-- | /O(1)/.  View the top (minimum) element of the queue, if there is one.
1110+top :: Ord a => PQueue a -> Maybe a
1111+top = fmap fst . extract
1112+
1113+-- | /O(log n)/.  Extract the top (minimum) element of the sequence, if there is one.
1114+extract :: Ord a => PQueue a -> Maybe (a, PQueue a)
1115+extract Empty = Nothing
1116+extract (PairQ n (PHeap x ts)) =
1117+       Just (x, case meldAll (<=) ts of
1118+               Nothing -> Empty
1119+               Just q' -> PairQ (n-1) q')
1120+
1121+-- | /O(log n)/.  Delete the top element of the sequence, if there is one.
1122+delete :: Ord a => PQueue a -> Maybe (PQueue a)
1123+delete = fmap snd . extract
1124+
1125+tip :: e -> PHeap e
1126+tip x = PHeap x Zero
1127+
1128+meldHeap :: (e -> e -> Bool) -> PHeap e -> PHeap e -> PHeap e
1129+meldHeap (<=) = meld where
1130+       t1@(PHeap x1 ts1) `meld` t2@(PHeap x2 ts2)
1131+               | x1 <= x2      = PHeap x1 (cons t2 ts1)
1132+               | otherwise     = PHeap x2 (cons t1 ts2)
1133+       cons t Zero = One t
1134+       cons t1 (One t0) = Two t0 t1
1135+       cons t2 (Two t0 t1) = One ((t1 `meld` t2) `meld` t0)
1136+
1137+{-# INLINE meldAll #-}
1138+meldAll :: (e -> e -> Bool) -> PChildren e -> Maybe (PHeap e)
1139+meldAll _ Zero = Nothing
1140+meldAll _ (One t) = Just t
1141+meldAll (<=) (Two t0 t1) = Just $ meldHeap (<=) t0 t1
1142+
1143+{-# INLINE fromAscList #-}
1144+-- | /O(n)/.  Constructs a priority queue from an ascending list.  /Warning/: Does not check the precondition.
1145+fromAscList :: [a] -> PQueue a
1146+fromAscList = foldr insMin empty
1147+
1148+insMin :: a -> PQueue a -> PQueue a
1149+insMin x Empty = singleton x
1150+insMin x (PairQ n t) = PairQ n (PHeap x (One t))
1151+
1152+-- | /O(n)/.  Produces a priority queue from an unordered list.  Produces a slightly more balanced pairing
1153+-- heap then @'foldr' 'insert' 'empty'@.
1154+fromList :: Ord a => [a] -> PQueue a
1155+fromList [] = Empty
1156+fromList (x:xs) = fromListHelper (<=) x xs
1157+
1158+{-# NOINLINE fromListHelper #-}
1159+fromListHelper :: (a -> a -> Bool) -> a -> [a] -> PQueue a
1160+fromListHelper _ x [] = singleton x
1161+fromListHelper (<=) x1 (x2:xs) = fromList0 2 (tip x1 `meld` tip x2) xs where
1162+       fromList0 n t xs = n `seq` t `seq` case xs of
1163+               []      -> PairQ n t
1164+               x:xs    -> fromList1 (n+1) t x xs
1165+       fromList1 n t0 x1 xs = n `seq` t0 `seq` case xs of
1166+               []      -> PairQ (n+1) (tip x1 `meld` t0)
1167+               x2:xs   -> fromList0 (n+1) ((tip x1 `meld` tip x2) `meld` t0) xs
1168+       meld = meldHeap (<=)
1169+
1170+-- | /O(n log n)/.  Performs a right-fold on the elements of a priority queue in ascending order.
1171+foldrAsc :: Ord a => (a -> b -> b) -> b -> PQueue a -> b
1172+foldrAsc f z (PairQ _ t) = foldrAscH (<=) f z t
1173+foldrAsc _ z _ = z
1174+
1175+foldrAscH :: (a -> a -> Bool) -> (a -> b -> b) -> b -> PHeap a -> b
1176+foldrAscH (<=) f = flip foldrHelper where
1177+       foldrHelper (PHeap x ts) z = x `f` foldr foldrHelper z (meldAll (<=) ts)
1178+
1179+-- | /O(n log n)/.  Performs a left-fold on the elements of a priority queue in ascending order.
1180+foldlAsc :: Ord a => (b -> a -> b) -> b -> PQueue a -> b
1181+foldlAsc f z (PairQ _ t) = foldlAscH (<=) f z t
1182+foldlAsc _ z _ = z
1183+
1184+foldlAscH :: (a -> a -> Bool) -> (b -> a -> b) -> b -> PHeap a -> b
1185+foldlAscH (<=) f = foldlHelper where
1186+       foldlHelper z (PHeap x ts) = foldl foldlHelper (z `f` x) (meldAll (<=) ts)
1187+
1188+{-# INLINE toAscList #-}
1189+-- | /O(n log n)/.  Extracts the elements of the priority queue in ascending order.
1190+toAscList :: Ord a => PQueue a -> [a]
1191+toAscList q = build (\ c nil -> foldrAsc c nil q)
1192+
1193+{-# INLINE toList #-}
1194+-- | /O(n)/.  Returns the elements of the priority queue in no particular order.
1195+toList :: PQueue a -> [a]
1196+toList q = build (\ c nil -> foldr c nil q)
1197+
1198+-- data Filter a = EmptyF | Filter {-# UNPACK #-} !Int {-# UNPACK #-} !(PHeap a) (PChildren a)
1199+
1200+filter :: Ord a => (a -> Bool) -> PQueue a -> PQueue a
1201+filter _ Empty = Empty
1202+filter p (PairQ _ t) = filterT t where
1203+       filterT (PHeap x ts) = (if p x then insMin x else id) $ case ts of
1204+               Zero    -> Empty
1205+               One t   -> filterT t
1206+               Two t0 t1 -> filterT t0 `union` filterT t1
1207+
1208+partition :: Ord a => (a -> Bool) -> PQueue a -> (PQueue a, PQueue a)
1209+partition _ Empty = (Empty, Empty)
1210+partition p (PairQ _ t) = partitionT t where
1211+       partitionT (PHeap x ts) = case partitionCh ts of
1212+               (q0, q1)
1213+                       | p x           -> (insMin x q0, q1)
1214+                       | otherwise     -> (q0, insMin x q1)
1215+       partitionCh Zero = (Empty, Empty)
1216+       partitionCh (One t) = partitionT t
1217+       partitionCh (Two t0 t1) = case (partitionT t0, partitionT t1) of
1218+               ((q00, q01), (q10, q11)) ->
1219+                       (q00 `union` q10, q01 `union` q11)
1220+                       
1221+-- | Index (subscript) operator, starting from 0.  @queue !! k@ returns the @(k+1)@th smallest element in the queue.
1222+(!!) :: Ord a => PQueue a -> Int -> a
1223+q !! n = (List.!!) (toAscList q) n
1224+
1225+{-# INLINE takeWhile #-}
1226+-- | 'takeWhile', applied to a predicate @p@ and a queue @queue@, returns the
1227+-- longest prefix (possibly empty) of @queue@ of elements that satisfy @p@.
1228+takeWhile :: Ord a => (a -> Bool) -> PQueue a -> [a]
1229+takeWhile p = List.takeWhile p . toAscList
1230+
1231+-- | 'dropWhile' @p queue@ returns the queue remaining after 'takeWhile' @p queue@.
1232+dropWhile :: Ord a => (a -> Bool) -> PQueue a -> PQueue a
1233+dropWhile p = dropWhileHelper where
1234+       dropWhileHelper q = case extract q of
1235+               Just (x, q') | p x      -> dropWhile p q'
1236+               _                       -> q
1237+
1238+-- | 'span', applied to a predicate @p@ and a queue @queue@, returns a tuple where
1239+-- first element is longest prefix (possibly empty) of @queue@ of elements that
1240+-- satisfy @p@ and second element is the remainder of the queue.
1241+span :: Ord a => (a -> Bool) -> PQueue a -> ([a], PQueue a)
1242+span p queue = case extract queue of
1243+       Just (x, q') | p x      -> let (ys, q'') = span p q' in (x:ys, q'')
1244+       _                       -> ([], queue)
1245+
1246+-- | 'break', applied to a predicate @p@ and a queue @queue@, returns a tuple where
1247+-- first element is longest prefix (possibly empty) of @queue@ of elements that
1248+-- /do not satisfy/ @p@ and second element is the remainder of the queue.
1249+break :: Ord a => (a -> Bool) -> PQueue a -> ([a], PQueue a)
1250+break p = span (not . p)
1251+
1252+{-# INLINE take #-}
1253+-- | /O(k log n)/. 'take' @k@, applied to a queue @queue@, returns a list of the smallest @k@ elements of @queue@,
1254+-- or all elements of @queue@ itself if @k >= 'size' queue@.
1255+take :: Ord a => Int -> PQueue a -> [a]
1256+take n = List.take n . toAscList
1257+
1258+-- | /O(k log n)/.  'drop' @k@, applied to a queue @queue@, returns @queue@ with the smallest @k@ elements deleted,
1259+-- or an empty queue if @k >= size 'queue'@.
1260+drop :: Ord a => Int -> PQueue a -> PQueue a
1261+drop n queue
1262+       | n <= 0        = queue
1263+       | otherwise     = case delete queue of
1264+               Nothing         -> empty
1265+               Just queue'     -> drop (n-1) queue'
1266+
1267+-- | /O(k log n)/.  Equivalent to @('take' k queue, 'drop' k queue)@.
1268+splitAt :: Ord a => Int -> PQueue a -> ([a], PQueue a)
1269+splitAt n queue
1270+       | n <= 0        = ([], queue)
1271+       | otherwise     = case extract queue of
1272+               Nothing          -> ([], queue)
1273+               Just (x, queue') -> let (xs, queue'') = splitAt (n-1) queue' in (x:xs, queue'')
1274+
1275+-- | /O(n)/.  Assumes that the function it is given is monotonic, and applies this function to every element of the priority queue,
1276+-- as in 'fmap'.  If it is not, the result is undefined.
1277+mapMonotonic :: (a -> b) -> PQueue a -> PQueue b
1278+mapMonotonic = fmap
1279+
1280+-- | /O(n)/.  Assumes that the function it is given is monotonic, in some sense, and performs the 'traverse' operation.
1281+-- If the function is not monotonic, the result is undefined.
1282+traverseMonotonic :: Applicative f => (a -> f b) -> PQueue a -> f (PQueue b)
1283+traverseMonotonic = traverse
1284}
1285
1286Context:
1287
1288[Tweak layout to work with the alternative layout rule
1289Ian Lynagh <igloo@earth.li>**20091129154519]
1290[Disable building Data.Sequence (and dependents) for nhc98.
1291Malcolm.Wallace@cs.york.ac.uk**20091124025653
1292 There is some subtlety of polymorphically recursive datatypes and
1293 type-class defaulting that nhc98's type system barfs over.
1294]
1295[Fix another instance of non-ghc breakage.
1296Malcolm.Wallace@cs.york.ac.uk**20091123092637]
1297[Add #ifdef around ghc-only (<$) as member of Functor class.
1298Malcolm.Wallace@cs.york.ac.uk**20091123085155]
1299[Fix broken code in non-GHC branch of an ifdef.
1300Malcolm.Wallace@cs.york.ac.uk**20091123084824]
1301[doc bugfix: correct description of index argument
1302Ross Paterson <ross@soi.city.ac.uk>**20091028105532
1303 Ignore-this: 9790e7bf422c4cb528722c03cfa4fed9
1304 
1305 As noted by iaefai on the libraries list.
1306 
1307 Please merge to STABLE.
1308]
1309[Bump version to 0.3.0.0
1310Ian Lynagh <igloo@earth.li>**20090920141847]
1311[update base dependency
1312Ross Paterson <ross@soi.city.ac.uk>**20090916073125
1313 Ignore-this: ad382ffc6c6a18c15364e6c072f19edb
1314 
1315 The package uses mkNoRepType and Data.Functor, which were not in the
1316 stable branch of base-4.
1317]
1318[add fast version of <$ for Seq
1319Ross Paterson <ross@soi.city.ac.uk>**20090916072812
1320 Ignore-this: 5a39a7d31d39760ed589790b1118d240
1321]
1322[new methods for Data.Sequence (proposal #3271)
1323Ross Paterson <ross@soi.city.ac.uk>**20090915173324
1324 Ignore-this: cf17bedd709a6ab3448fd718dcdf62e7
1325 
1326 Adds a lot of new methods to Data.Sequence, mostly paralleling those
1327 in Data.List.  Several of these are significantly faster than versions
1328 implemented with the previous public interface.  In particular, replicate
1329 takes O(log n) time and space instead of O(n).
1330 (by Louis Wasserman)
1331]
1332[Fix "Cabal check" warnings
1333Ian Lynagh <igloo@earth.li>**20090811215900]
1334[TAG 2009-06-25
1335Ian Lynagh <igloo@earth.li>**20090625160202]
1336Patch bundle hash:
13379d207dcfbee69b4f5f0f7ed78038ae96109a6940