Ticket #3271: new-methods-for-data_sequence.4.dpatch

File new-methods-for-data_sequence.4.dpatch, 48.3 KB (added by LouisWasserman, 6 years ago)

This version contains the resolved-upon compromise, with a stable sort based on Data.List.sort for sort and sortBy and a speedy but unstable sort in unstableSort and unstableSortBy.

Line 
1Mon Jul 20 14:01:11 EDT 2009  [email protected]
2  * Ticket #3271: New methods for Data.Sequence
3
4New patches:
5
6[Ticket #3271: New methods for Data.Sequence
7[email protected]**20090720180111
8 Ignore-this: fcaaef7ef4a863a045a0bda5a5a12643
9] {
10hunk ./Data/Sequence.hs 39
11        -- * Construction
12        empty,          -- :: Seq a
13        singleton,      -- :: a -> Seq a
14+       replicate,      -- :: Int -> a -> Seq a
15        (<|),           -- :: a -> Seq a -> Seq a
16        (|>),           -- :: Seq a -> a -> Seq a
17        (><),           -- :: Seq a -> Seq a -> Seq a
18hunk ./Data/Sequence.hs 44
19        fromList,       -- :: [a] -> Seq a
20+       -- ** Sequential construction
21+       iterateN,       -- :: Int -> (a -> a) -> a -> Seq a
22+       unfoldr,        -- :: (b -> Maybe (a, b)) -> b -> Seq a
23        -- * Deconstruction
24        -- | Additional functions for deconstructing sequences are available
25        -- via the 'Foldable' instance of 'Seq'.
26hunk ./Data/Sequence.hs 59
27        viewl,          -- :: Seq a -> ViewL a
28        ViewR(..),
29        viewr,          -- :: Seq a -> ViewR a
30+       -- ** Scanning
31+       scanl,          -- :: (a -> b -> a) -> a -> Seq b -> Seq a
32+       scanl1,         -- :: (a -> a -> a) -> Seq a -> Seq a
33+       scanr,          -- :: (a -> b -> b) -> b -> Seq a -> Seq b
34+       scanr1,         -- :: (a -> a -> a) -> Seq a -> Seq a
35+       -- ** Sublists
36+       tails,          -- :: Seq a -> Seq (Seq a)
37+       inits,          -- :: Seq a -> Seq (Seq a)
38+       takeWhile,      -- :: (a -> Bool) -> Seq a -> Seq a
39+       dropWhile,      -- :: (a -> Bool) -> Seq a -> Seq a
40+       span,           -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
41+       break,          -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
42+       partition,      -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
43+       filter,         -- :: (a -> Bool) -> Seq a -> Seq a
44+       -- ** Sorts
45+       sort,           -- :: Ord a => Seq a -> Seq a
46+       sortBy,         -- :: (a -> a -> Ordering) -> Seq a -> Seq a
47+       unstableSort,   -- :: Ord a => Seq a -> Seq a
48+       unstableSortBy, -- :: (a -> a -> Ordering) -> Seq a -> Seq a
49        -- ** Indexing
50        index,          -- :: Seq a -> Int -> a
51        adjust,         -- :: (a -> a) -> Int -> Seq a -> Seq a
52hunk ./Data/Sequence.hs 87
53        splitAt,        -- :: Int -> Seq a -> (Seq a, Seq a)
54        -- * Transformations
55        reverse,        -- :: Seq a -> Seq a
56+       -- ** Zips
57+       zip,            -- :: Seq a -> Seq b -> Seq (a, b)
58+       zipWith,        -- :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
59+       zip3,           -- :: Seq a -> Seq b -> Seq c -> Seq (a, b, c)
60+       zipWith3,       -- :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
61+       zip4,           -- :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a, b, c, d)
62+       zipWith4,       -- :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e
63 #if TESTING
64        valid,
65 #endif
66hunk ./Data/Sequence.hs 100
67        ) where
68 
69 import Prelude hiding (
70-       null, length, take, drop, splitAt, foldl, foldl1, foldr, foldr1,
71-       reverse)
72-import qualified Data.List (foldl')
73-import Control.Applicative (Applicative(..), (<$>))
74-import Control.Monad (MonadPlus(..))
75+       null, length, take, drop, splitAt, foldl, foldl1, foldr, foldr1, span,
76+       scanl, scanl1, scanr, scanr1, replicate, zip, zipWith, zip3, zipWith3,
77+       takeWhile, dropWhile, break, iterate, reverse, filter, mapM)
78+import qualified Data.List (foldl', zipWith, sortBy)
79+import Control.Applicative (Applicative(..), (<$>), liftA, liftA2, liftA3)
80+import Control.Monad (MonadPlus(..), ap, liftM, liftM2, liftM3, liftM4)
81 import Data.Monoid (Monoid(..))
82 import Data.Foldable
83 import Data.Traversable
84hunk ./Data/Sequence.hs 122
85 #endif
86 
87 #if TESTING
88-import Control.Monad (liftM, liftM3, liftM4)
89-import Test.QuickCheck
90+import Test.QuickCheck hiding ((><))
91 #endif
92 
93 infixr 5 `consTree`
94hunk ./Data/Sequence.hs 127
95 infixl 5 `snocTree`
96+infixr 5 `consDigitToTree`
97+infixl 6 `snocDigitToTree`
98 
99 infixr 5 ><
100 infixr 5 <|, :<
101hunk ./Data/Sequence.hs 281
102                        traverse f sf
103 
104 {-# INLINE deep #-}
105-{-# SPECIALIZE deep :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
106-{-# SPECIALIZE deep :: Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}
107+{-# SPECIALIZE INLINE deep :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
108+{-# SPECIALIZE INLINE deep :: Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}
109 deep           :: Sized a => Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a
110 deep pr m sf   =  Deep (size pr + size m + size sf) pr m sf
111 
112hunk ./Data/Sequence.hs 322
113        fmap = fmapDefault
114 
115 instance Traversable Digit where
116+       {-# INLINE traverse #-}
117        traverse f (One a) = One <$> f a
118        traverse f (Two a b) = Two <$> f a <*> f b
119        traverse f (Three a b c) = Three <$> f a <*> f b <*> f c
120hunk ./Data/Sequence.hs 329
121        traverse f (Four a b c d) = Four <$> f a <*> f b <*> f c <*> f d
122 
123 instance Sized a => Sized (Digit a) where
124-       {-# SPECIALIZE instance Sized (Digit (Elem a)) #-}
125-       {-# SPECIALIZE instance Sized (Digit (Node a)) #-}
126-       size xs = foldl (\ i x -> i + size x) 0 xs
127+       {-# INLINE size #-}
128+       size = foldl1 (+) . fmap size
129 
130 {-# SPECIALIZE digitToTree :: Digit (Elem a) -> FingerTree (Elem a) #-}
131 {-# SPECIALIZE digitToTree :: Digit (Node a) -> FingerTree (Node a) #-}
132hunk ./Data/Sequence.hs 357
133        foldl f z (Node3 _ a b c) = ((z `f` a) `f` b) `f` c
134 
135 instance Functor Node where
136+       {-# INLINE fmap #-}
137        fmap = fmapDefault
138 
139 instance Traversable Node where
140hunk ./Data/Sequence.hs 361
141+       {-# INLINE traverse #-}
142        traverse f (Node2 v a b) = Node2 v <$> f a <*> f b
143        traverse f (Node3 v a b c) = Node3 v <$> f a <*> f b <*> f c
144 
145hunk ./Data/Sequence.hs 407
146        showsPrec p (Elem x) = showsPrec p x
147 #endif
148 
149+-- Applicative construction
150+
151+newtype Id a = Id {runId :: a}
152+
153+instance Functor Id where
154+       fmap f (Id x) = Id (f x)
155+
156+instance Monad Id where
157+       return = Id
158+       m >>= k = k (runId m)
159+
160+instance Applicative Id where
161+       pure = return
162+       (<*>) = ap
163+
164+-- | This is essentially a clone of Control.Monad.State.Strict.
165+newtype State s a = State {runState :: s -> (s, a)}
166+
167+instance Functor (State s) where
168+       fmap = liftA
169+
170+instance Monad (State s) where
171+       {-# INLINE return #-}
172+       {-# INLINE (>>=) #-}
173+       return x = State $ \ s -> (s, x)
174+       m >>= k = State $ \ s -> case runState m s of
175+               (s', x) -> runState (k x) s'
176+
177+instance Applicative (State s) where
178+       pure = return
179+       (<*>) = ap
180+
181+execState :: State s a -> s -> a
182+execState m x = snd (runState m x)
183+
184+-- | 'applicativeTree' takes an Applicative-wrapped construction of a piece of a FingerTree, assumed
185+-- to always have the same size (which is put in the second argument), and replicates it as many times
186+-- as specified.  This encapsulates the behavior of several procedures, most notably iterate and replicate.
187+
188+{-# SPECIALIZE applicativeTree :: Int -> Int -> State s a -> State s (FingerTree a) #-}
189+{-# SPECIALIZE applicativeTree :: Int -> Int -> Id a -> Id (FingerTree a) #-}
190+       -- Special note: the Id specialization automatically does node sharing, reducing memory usage of the
191+       -- resulting tree to /O(log n)/.
192+applicativeTree :: Applicative f => Int -> Int -> f a -> f (FingerTree a)
193+applicativeTree n mSize m = mSize `seq` case n of
194+       0       -> pure Empty
195+       1       -> liftA Single m
196+       2       -> deepA one empty one
197+       3       -> deepA two empty one
198+       4       -> deepA two empty two
199+       5       -> deepA three empty two
200+       6       -> deepA three empty three
201+       7       -> deepA four empty three
202+       8       -> deepA four empty four
203+       _       -> let (q, r) = n `quotRem` 3 in q `seq` case r of
204+               0       -> deepA three (applicativeTree (q - 2) mSize' n3) three
205+               1       -> deepA four (applicativeTree (q - 2) mSize' n3) three
206+               _       -> deepA four (applicativeTree (q - 2) mSize' n3) four
207+       where   one = liftA One m
208+               two = liftA2 Two m m
209+               three = liftA3 Three m m m
210+               four = liftA3 Four m m m <*> m
211+               deepA = liftA3 (Deep (n * mSize))
212+               mSize' = 3 * mSize
213+               n3 = liftA3 (Node3 mSize') m m m
214+               empty = pure Empty
215+
216 ------------------------------------------------------------------------
217 -- Construction
218 ------------------------------------------------------------------------
219hunk ./Data/Sequence.hs 486
220 singleton      :: a -> Seq a
221 singleton x    =  Seq (Single (Elem x))
222 
223+-- | /O(log n)/. @replicate n x@ is a sequence of length @n@ with @x@ the value of every element.
224+replicate      :: Int -> a -> Seq a
225+replicate n x  = Seq (runId (applicativeTree n 1 (Id (Elem x))))
226+
227 -- | /O(1)/. Add an element to the left end of a sequence.
228 -- Mnemonic: a triangle with the single element at the pointy end.
229 (<|)           :: a -> Seq a -> Seq a
230hunk ./Data/Sequence.hs 586
231 appendTree1 xs a Empty =
232        xs `snocTree` a
233 appendTree1 (Single x) a xs =
234-       x `consTree` a `consTree` xs
235+       Two x a `consDigitToTree` xs
236 appendTree1 xs a (Single x) =
237hunk ./Data/Sequence.hs 588
238-       xs `snocTree` a `snocTree` x
239+       xs `snocDigitToTree` Two a x
240 appendTree1 (Deep s1 pr1 m1 sf1) a (Deep s2 pr2 m2 sf2) =
241        Deep (s1 + size a + s2) pr1 (addDigits1 m1 sf1 a pr2 m2) sf2
242 
243hunk ./Data/Sequence.hs 628
244 
245 appendTree2 :: FingerTree (Node a) -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
246 appendTree2 Empty a b xs =
247-       a `consTree` b `consTree` xs
248+       Two a b `consDigitToTree` xs
249 appendTree2 xs a b Empty =
250hunk ./Data/Sequence.hs 630
251-       xs `snocTree` a `snocTree` b
252+       xs `snocDigitToTree` Two a b
253 appendTree2 (Single x) a b xs =
254hunk ./Data/Sequence.hs 632
255-       x `consTree` a `consTree` b `consTree` xs
256+       Three x a b `consDigitToTree` xs
257 appendTree2 xs a b (Single x) =
258hunk ./Data/Sequence.hs 634
259-       xs `snocTree` a `snocTree` b `snocTree` x
260+       xs `snocDigitToTree` Three a b x
261 appendTree2 (Deep s1 pr1 m1 sf1) a b (Deep s2 pr2 m2 sf2) =
262        Deep (s1 + size a + size b + s2) pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2
263 
264hunk ./Data/Sequence.hs 674
265 
266 appendTree3 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
267 appendTree3 Empty a b c xs =
268-       a `consTree` b `consTree` c `consTree` xs
269+       Three a b c `consDigitToTree` xs
270 appendTree3 xs a b c Empty =
271hunk ./Data/Sequence.hs 676
272-       xs `snocTree` a `snocTree` b `snocTree` c
273+       xs `snocDigitToTree` Three a b c
274 appendTree3 (Single x) a b c xs =
275hunk ./Data/Sequence.hs 678
276-       x `consTree` a `consTree` b `consTree` c `consTree` xs
277+       Four x a b c `consDigitToTree` xs
278 appendTree3 xs a b c (Single x) =
279hunk ./Data/Sequence.hs 680
280-       xs `snocTree` a `snocTree` b `snocTree` c `snocTree` x
281+       xs `snocDigitToTree` Four a b c x
282 appendTree3 (Deep s1 pr1 m1 sf1) a b c (Deep s2 pr2 m2 sf2) =
283        Deep (s1 + size a + size b + size c + s2) pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2
284 
285hunk ./Data/Sequence.hs 720
286 
287 appendTree4 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
288 appendTree4 Empty a b c d xs =
289-       a `consTree` b `consTree` c `consTree` d `consTree` xs
290+       Four a b c d `consDigitToTree` xs
291 appendTree4 xs a b c d Empty =
292hunk ./Data/Sequence.hs 722
293-       xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d
294+       xs `snocDigitToTree` Four a b c d
295 appendTree4 (Single x) a b c d xs =
296hunk ./Data/Sequence.hs 724
297-       x `consTree` a `consTree` b `consTree` c `consTree` d `consTree` xs
298+       x `consTree` Four a b c d `consDigitToTree` xs
299 appendTree4 xs a b c d (Single x) =
300hunk ./Data/Sequence.hs 726
301-       xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d `snocTree` x
302+       xs `snocDigitToTree` Four a b c d `snocTree` x
303 appendTree4 (Deep s1 pr1 m1 sf1) a b c d (Deep s2 pr2 m2 sf2) =
304        Deep (s1 + size a + size b + size c + size d + s2) pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2
305 
306hunk ./Data/Sequence.hs 764
307 addDigits4 m1 (Four a b c d) e f g h (Four i j k l) m2 =
308        appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2
309 
310+-- Cons and snoc for entire digits at once.  This code was automatically generated.
311+--
312+-- For general internal use, this is *considerably more efficient* than repeated use of
313+-- consTree or snocTree, which end up case'ing the appropriate digit once for every
314+-- insertion, while this code only does it once.
315+
316+{-# SPECIALIZE consDigitToTree :: Digit (Elem a) -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
317+{-# SPECIALIZE consDigitToTree :: Digit (Node a) -> FingerTree (Node a) -> FingerTree (Node a) #-}
318+consDigitToTree :: Sized a => Digit a -> FingerTree a -> FingerTree a
319+consDigitToTree dig Empty
320+       = digitToTree dig
321+consDigitToTree dig (Single a)
322+       = Deep (size dig + size a) dig Empty (One a)
323+consDigitToTree dig@(One a) (Deep n (One x) m sf)
324+       = Deep (n + size dig) (Two a x) m sf
325+consDigitToTree dig@(One a) (Deep n (Two x y) m sf)
326+       = Deep (n + size dig) (Three a x y) m sf
327+consDigitToTree dig@(One a) (Deep n (Three x y z) m sf)
328+       = Deep (n + size dig) (Four a x y z) m sf
329+consDigitToTree dig@(One a) (Deep n (Four x y z w) m sf)
330+       = Deep (n + size dig) (Two a x) ((node3 y z w) `consTree` m) sf
331+consDigitToTree dig@(Two a b) (Deep n (One x) m sf)
332+       = Deep (n + size dig) (Three a b x) m sf
333+consDigitToTree dig@(Two a b) (Deep n (Two x y) m sf)
334+       = Deep (n + size dig) (Four a b x y) m sf
335+consDigitToTree dig@(Two a b) (Deep n (Three x y z) m sf)
336+       = Deep (n + size dig) (Two a b) ((node3 x y z) `consTree` m) sf
337+consDigitToTree dig@(Two a b) (Deep n (Four x y z w) m sf)
338+       = Deep (n + size dig) (Three a b x) ((node3 y z w) `consTree` m) sf
339+consDigitToTree dig@(Three a b c) (Deep n (One x) m sf)
340+       = Deep (n + size dig) (Four a b c x) m sf
341+consDigitToTree dig@(Three a b c) (Deep n (Two x y) m sf)
342+       = Deep (n + size dig) (Two a b) ((node3 c x y) `consTree` m) sf
343+consDigitToTree dig@(Three a b c) (Deep n (Three x y z) m sf)
344+       = Deep (n + size dig) (Three a b c) ((node3 x y z) `consTree` m) sf
345+consDigitToTree dig@(Three a b c) (Deep n (Four x y z w) m sf)
346+       = Deep (n + size dig) (One a) (Two (node3 b c x) (node3 y z w) `consDigitToTree` m) sf
347+consDigitToTree dig@(Four a b c d) (Deep n (One x) m sf)
348+       = Deep (n + size dig) (Two a b) ((node3 c d x) `consTree` m) sf
349+consDigitToTree dig@(Four a b c d) (Deep n (Two x y) m sf)
350+       = Deep (n + size dig) (Three a b c) ((node3 d x y) `consTree` m) sf
351+consDigitToTree dig@(Four a b c d) (Deep n (Three x y z) m sf)
352+       = Deep (n + size dig) (One a) (Two (node3 b c d) (node3 x y z) `consDigitToTree` m) sf
353+consDigitToTree dig@(Four a b c d) (Deep n (Four x y z w) m sf)
354+       = Deep (n + size dig) (Two a b) (Two (node3 c d x) (node3 y z w) `consDigitToTree` m) sf
355+
356+{-# SPECIALIZE snocDigitToTree :: FingerTree (Elem a) -> Digit (Elem a) -> FingerTree (Elem a) #-}
357+{-# SPECIALIZE snocDigitToTree :: FingerTree (Node a) -> Digit (Node a) -> FingerTree (Node a) #-}
358+snocDigitToTree :: Sized a => FingerTree a -> Digit a -> FingerTree a
359+snocDigitToTree Empty dig
360+       = digitToTree dig
361+snocDigitToTree (Single a) dig
362+       = Deep (size a + size dig) (One a) Empty dig
363+snocDigitToTree (Deep n pr m (One a)) dig@(One x)
364+       = Deep (n + size dig) pr m (Two a x)
365+snocDigitToTree (Deep n pr m (One a)) dig@(Two x y)
366+       = Deep (n + size dig) pr m (Three a x y)
367+snocDigitToTree (Deep n pr m (One a)) dig@(Three x y z)
368+       = Deep (n + size dig) pr m (Four a x y z)
369+snocDigitToTree (Deep n pr m (One a)) dig@(Four x y z w)
370+       = Deep (n + size dig) pr (m `snocTree` (node3 a x y)) (Two z w)
371+snocDigitToTree (Deep n pr m (Two a b)) dig@(One x)
372+       = Deep (n + size dig) pr m (Three a b x)
373+snocDigitToTree (Deep n pr m (Two a b)) dig@(Two x y)
374+       = Deep (n + size dig) pr m (Four a b x y)
375+snocDigitToTree (Deep n pr m (Two a b)) dig@(Three x y z)
376+       = Deep (n + size dig) pr (m `snocTree` (node3 a b x)) (Two y z)
377+snocDigitToTree (Deep n pr m (Two a b)) dig@(Four x y z w)
378+       = Deep (n + size dig) pr (m `snocTree` (node3 a b x)) (Three y z w)
379+snocDigitToTree (Deep n pr m (Three a b c)) dig@(One x)
380+       = Deep (n + size dig) pr m (Four a b c x)
381+snocDigitToTree (Deep n pr m (Three a b c)) dig@(Two x y)
382+       = Deep (n + size dig) pr (m `snocTree` (node3 a b c)) (Two x y)
383+snocDigitToTree (Deep n pr m (Three a b c)) dig@(Three x y z)
384+       = Deep (n + size dig) pr (m `snocTree` (node3 a b c)) (Three x y z)
385+snocDigitToTree (Deep n pr m (Three a b c)) dig@(Four x y z w)
386+       = Deep (n + size dig) pr (m `snocDigitToTree` Two (node3 a b c) (node3 x y z)) (One w)
387+snocDigitToTree (Deep n pr m (Four a b c d)) dig@(One x)
388+       = Deep (n + size dig) pr (m `snocTree` (node3 a b c)) (Two d x)
389+snocDigitToTree (Deep n pr m (Four a b c d)) dig@(Two x y)
390+       = Deep (n + size dig) pr (m `snocTree` (node3 a b c)) (Three d x y)
391+snocDigitToTree (Deep n pr m (Four a b c d)) dig@(Three x y z)
392+       = Deep (n + size dig) pr (m `snocDigitToTree` Two (node3 a b c) (node3 d x y)) (One z)
393+snocDigitToTree (Deep n pr m (Four a b c d)) dig@(Four x y z w)
394+       = Deep (n + size dig) pr (m `snocDigitToTree` Two (node3 a b c) (node3 d x y)) (Two z w)
395+
396+-- | Builds a sequence from a seed value.  Takes time linear in the number of generated elements.  /WARNING: If the number of generated elements is infinite, this method will not terminate./
397+unfoldr :: (b -> Maybe (a, b)) -> b -> Seq a
398+unfoldr f b = unfoldr' empty b where
399+       -- uses tail recursion rather than, for instance, the List implementation.
400+       unfoldr' as b = case f b of
401+               Nothing         -> as
402+               Just (a, b')    -> unfoldr' (as |> a) b'
403+
404+-- | /O(n)/.  Constructs a sequence by repeated application of a function to a seed value.
405+--
406+-- > iterateN n f x = fromList (Prelude.take n (Prelude.iterate f x))
407+iterateN :: Int -> (a -> a) -> a -> Seq a
408+iterateN n f x
409+       | n < 0         = error "iterateN takes a nonnegative integer argument"
410+       | otherwise     = Seq (execState (applicativeTree n 1 run) x)
411+       where   run = State $ \ x -> (f x, Elem x)
412+
413 ------------------------------------------------------------------------
414 -- Deconstruction
415 ------------------------------------------------------------------------
416hunk ./Data/Sequence.hs 1001
417 viewRTree (Deep s pr m (Four w x y z)) =
418        Just2 (Deep (s - size z) pr m (Three w x y)) z
419 
420+------------------------------------------------------------------------
421+-- Scans
422+--
423+-- These are not particularly complex applications of the Traversable
424+-- functor, though making the correspondence with Data.List exact
425+-- requires the use of (<|) and (|>).
426+--
427+-- Note that save for the single (<|) or (|>), we maintain the original
428+-- structure of the Seq, not having to do any restructuring of our own.
429+--
430+-- [email protected], 5/23/09
431+------------------------------------------------------------------------
432+
433+-- | 'scanl' is similar to 'foldl', but returns a sequence of reduced values from the left:
434+--
435+-- > scanl f z (fromList [x1, x2, ...]) = fromList [z, z `f` x1, (z `f` x1) `f` x2, ...]
436+scanl :: (a -> b -> a) -> a -> Seq b -> Seq a
437+scanl f z0 xs = z0 <| snd (mapAccumL accum z0 xs)
438+       where accum x z = let x' = f x z in (x', x')
439+
440+-- | 'scanl1' is a variant of 'scanl' that has no starting value argument:
441+--
442+-- > scanl1 f (fromList [x1, x2, ...]) = fromList [x1, x1 `f` x2, ...]
443+scanl1 :: (a -> a -> a) -> Seq a -> Seq a
444+scanl1 f xs = case viewl xs of
445+       EmptyL          -> error "scanl1 takes a nonempty sequence as an argument"
446+       x :< xs'        -> scanl f x xs'
447+
448+-- | 'scanr' is the right-to-left dual of 'scanl'.
449+scanr :: (a -> b -> b) -> b -> Seq a -> Seq b
450+scanr f z0 xs = snd (mapAccumR accum z0 xs) |> z0
451+       where accum z x = let z' = f x z in (z', z')
452+
453+-- | 'scanr1' is a variant of 'scanr' that has no starting value argument.
454+scanr1 :: (a -> a -> a) -> Seq a -> Seq a
455+scanr1 f xs = case viewr xs of
456+       EmptyR          -> error "scanr1 takes a nonempty sequence as an argument"
457+       xs' :> x        -> scanr f x xs'
458+
459 -- Indexing
460 
461 -- | /O(log(min(i,n-i)))/. The element at the specified position,
462hunk ./Data/Sequence.hs 1190
463 splitAt i (Seq xs)     =  (Seq l, Seq r)
464   where        (l, r)          =  split i xs
465 
466+-- | /O(n)/.  Returns a sequence of all suffixes of this sequence, longest first.  For example,
467+--
468+-- > tails (fromList "abc") = fromList [fromList "abc", fromList "bc", fromList "c", fromList ""]
469+--
470+-- Evaluating the /i/th tail takes /O(log(min(i, n-i)))/, but evaluating every tail in the sequence
471+-- takes /O(n)/ due to sharing.
472+tails                  :: Seq a -> Seq (Seq a)
473+tails (Seq xs)         = Seq (tailsTree (Elem . Seq) xs) |> empty
474+{-
475+tails xs = iterateN (length xs + 1) tail' xs where
476+       tail' ys _ = case viewl ys of
477+               _ :< ys'        -> ys'
478+               _               -> error "Invariant failure in Data.Sequence.tails" -- should never happen
479+-}
480+
481+-- | /O(n)/.  Returns a sequence of all prefixes of this sequence, shortest first. For example,
482+--
483+-- > inits (fromList "abc") = fromList [fromList "", fromList "a", fromList "ab", fromList "abc"]
484+--
485+-- Evaluating the /i/th init takes /O(log(min(i, n-i)))/, but evaluating every init in the sequence
486+-- takes /O(n)/ due to sharing. 
487+inits                  :: Seq a -> Seq (Seq a)
488+inits (Seq xs)                 = empty <| Seq (initsTree (Elem . Seq) xs)
489+-- inits = scanl (|>) empty
490+
491+-- This implementation of tails (and, analogously, inits) has the following algorithmic advantages:
492+--     Evaluating each tail in the sequence takes linear total time, which is better than we could say for
493+--             @fromList [drop n xs | n <- [0..length xs]]@.
494+--     Evaluating any individual tail takes logarithmic time, which is better than we can say for either
495+--             @scanr (<|) empty xs@ or @iterateN (length xs + 1) (\ xs -> let _ :< xs' = viewl xs in xs') xs@.
496+--
497+-- Moreover, if we actually look at every tail in the sequence, the following benchmarks demonstrate that
498+-- this implementation is actually slightly faster than any of the above:
499+--
500+-- Times (ms)    min    mean    +/-sd  median    max
501+-- Seq.tails:  16.875  20.405   4.247  19.663  47.972
502+-- scanr:      68.429  76.948   6.505  75.264  99.650
503+-- iterateN:   17.571  22.231   1.031  22.251  23.917
504+--
505+-- The algorithm for tails (and, analogously, inits) is as follows:
506+--
507+-- A Node in the FingerTree of tails is constructed by evaluating the corresponding tail of the FingerTree
508+-- of Nodes, considering the first Node in this tail, and constructing a Node in which each tail of this
509+-- Node is made to be the prefix of the remaining tree.  This ends up working quite elegantly, as the remainder of
510+-- the tail of the FingerTree of Nodes becomes the middle of a new tail, the suffix of the Node is the
511+-- prefix, and the suffix of the original tree is retained.
512+--
513+-- In particular, evaluating the /i/th tail involves making as many partial evaluations as the Node depth of
514+-- the /i/th element.  In addition, when we evaluate the /i/th tail, and we also evaluate the /j/th tail,
515+-- and /m/ Nodes are on the path to both /i/ and /j/, each of those /m/ evaluations are shared between
516+-- the computation of the /i/th and /j/th tails.
517+--
518+-- [email protected], 7/16/09
519+
520+-- | Given the size of a digit and the digit itself, efficiently converts it to a FingerTree.
521+digitToTree' :: Int -> Digit a -> FingerTree a
522+digitToTree' n (Four a b c d) = Deep n (Two a b) Empty (Two c d)
523+digitToTree' n (Three a b c) = Deep n (Two a b) Empty (One c)
524+digitToTree' n (Two a b) = Deep n (One a) Empty (One b)
525+digitToTree' n (One a) = n `seq` Single a
526+
527+{-# INLINE scanlSize #-}
528+scanlSize :: (Traversable f, Sized a) => (b -> Int -> b) -> b -> f a -> f b
529+scanlSize f z d = snd (mapAccumL (\ acc x -> let ans = f acc (size x) in (ans, ans)) z d)
530+
531+{-# INLINE scanrSize #-}
532+scanrSize :: (Traversable f, Sized a) => (Int -> b -> b) -> b -> f a -> f b
533+scanrSize f z d = snd (mapAccumR (\ acc x -> let ans = size x `f` acc in (ans, ans)) z d)
534+
535+{-# INLINE tailPr #-}
536+-- | Given a Deep FingerTree, constructs the prefix of its tree of tails.
537+tailPr :: Sized a => Int -> Digit a -> FingerTree (Node a) -> Digit a -> Digit (FingerTree a)
538+tailPr n pr m sf = n `seq` let t = Deep n pr m sf in case (pr, scanlSize (-) n pr) of
539+       (One _, _)      -> One t
540+       (Two _ b, Two sza _)
541+                       -> sza `seq` Two t (Deep sza (One b) m sf)
542+       (Three _ b c, Three sza szb _)
543+                       -> szb `seq` Three t (Deep sza (Two b c) m sf) (Deep szb (One c) m sf)
544+       (Four _ b c d, Four sza szb szc _)
545+                       -> szc `seq` Four t (Deep sza (Three b c d) m sf) (Deep szb (Two c d) m sf)
546+                               (Deep szc (One d) m sf)
547+       _               -> error "The flatly impossible has occurred"
548+
549+{-# INLINE initPr #-}
550+-- | Constructs the inits of the specified digits.
551+initPr :: Sized a => Digit a -> Digit (FingerTree a)
552+initPr pr = case (pr, scanlSize (+) 0 pr) of
553+       (One a, _)      -> One (Single a)
554+       (Two a b, Two _ szb)
555+                       -> szb `seq` Two (Single a) (digitToTree' szb (Two a b))
556+       (Three a b c, Three _ szb szc)
557+                       -> szc `seq` Three (Single a) (digitToTree' szb (Two a b)) (digitToTree' szc (Three a b c))
558+       (Four a b c d, Four _ szb szc szd)
559+                       -> szd `seq` Four (Single a) (digitToTree' szb (Two a b)) (digitToTree' szc (Three a b c))
560+                               (digitToTree' szd (Four a b c d))
561+       _               -> error "The flatly impossible has occurred"
562+
563+{-# INLINE tailSf #-}
564+-- | Constructs the tails of the specified digit.
565+tailSf :: Sized a => Digit a -> Digit (FingerTree a)
566+tailSf sf = case (sf, scanrSize (+) 0 sf) of
567+       (One a, _)      -> One (Single a)
568+       (Two a b, Two sza _)
569+                       -> sza `seq` Two (digitToTree' sza (Two a b)) (Single b)
570+       (Three a b c, Three sza szb _)
571+                       -> sza `seq` Three (digitToTree' sza (Three a b c)) (digitToTree' szb (Two b c))
572+                               (Single c)
573+       (Four a b c d, Four sza szb szc _)
574+                       -> sza `seq` Four (digitToTree' sza (Four a b c d)) (digitToTree' szb (Three b c d))
575+                               (digitToTree' szc (Two c d)) (Single d)
576+       _               -> error "The flatly impossible has occurred"
577+
578+{-# INLINE initSf #-}
579+-- | Constructs the suffix of the tree of inits of the specified Deep tree.
580+initSf :: (Sized a) => Int -> Digit a -> FingerTree (Node a) -> Digit a -> Digit (FingerTree a)
581+initSf n pr m sf = n `seq` let t = Deep n pr m sf in case (sf, scanrSize subtract n sf) of
582+       (One _, _)      -> One t
583+       (Two a _, Two sza _)
584+                       -> sza `seq` Two (Deep sza pr m (One a)) t
585+       (Three a b _, Three sza szb _)
586+                       -> sza `seq` Three (Deep sza pr m (One a)) (Deep szb pr m (Two a b)) t
587+       (Four a b c _, Four sza szb szc _)
588+                       -> sza `seq` Four (Deep sza pr m (One a)) (Deep szb pr m (Two a b)) (Deep szc pr m (Three a b c)) t
589+       _               -> error "The flatly impossible has occurred"
590+
591+{-# SPECIALIZE tailsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-}
592+{-# SPECIALIZE tailsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-}
593+-- | Given a function to apply to tails of a tree, applies that function to every tail of the specified tree.
594+tailsTree :: (Sized a, Sized b) => (FingerTree a -> b) -> FingerTree a -> FingerTree b
595+tailsTree _ Empty = Empty
596+tailsTree f (Single x) = Single (f (Single x))
597+tailsTree f (Deep n pr m sf) = sfSize `seq`
598+       Deep n (fmap f (tailPr n pr m sf)) (tailsTree f' m) (fmap f (tailSf sf))
599+       where   sfSize = size sf
600+               f' ms = case viewLTree ms of
601+                       Nothing2 -> error "tailsTree should not encounter empty tails"
602+                       Just2 node@(Node2 n' a b) m' -> let Node2 _ sz2 sz = scanrSize (+) (size m' + sfSize) node in                           
603+                               sz2 `seq` Node2 n' (f (Deep sz2 (Two a b) m' sf))
604+                                       (f (Deep sz (One b) m' sf))
605+                       Just2 node@(Node3 n' a b c) m' -> let Node3 _ sz3 sz2 sz = scanrSize (+) (size m' + sfSize) node in
606+                                sz3 `seq` Node3 n' (f (Deep sz3 (Three a b c) m' sf))
607+                                               (f (Deep sz2 (Two b c) m' sf))
608+                                               (f (Deep sz (One c) m' sf))
609+
610+{-# SPECIALIZE initsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-}
611+{-# SPECIALIZE initsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-}
612+-- | Given a function to apply to inits of a tree, applies that function to every init of the specified tree.
613+initsTree :: (Sized a, Sized b) => (FingerTree a -> b) -> FingerTree a -> FingerTree b
614+initsTree _ Empty = Empty
615+initsTree f (Single x) = Single (f (Single x))
616+initsTree f (Deep n pr m sf) = prSize `seq`
617+       Deep n (fmap f (initPr pr)) (initsTree f' m) (fmap f (initSf n pr m sf))
618+       where   prSize = size pr
619+               f' ms = case viewRTree ms of
620+                       Nothing2 -> error "initsTree should not encounter empty inits"
621+                       Just2 m' node@(Node2 n' a b) -> let Node2 _ sza szb = scanlSize (+) (prSize + size m') node in
622+                               szb `seq` Node2 n' (f (Deep sza pr m' (One a)))
623+                                       (f (Deep szb pr m' (Two a b)))
624+                       Just2 m' node@(Node3 n' a b c) -> let Node3 _ sza szb szc = scanlSize (+) (prSize + size m') node in
625+                               szc `seq` Node3 n' (f (Deep sza pr m' (One a)))
626+                                               (f (Deep szb pr m' (Two a b)))
627+                                               (f (Deep szc pr m' (Three a b c)))
628+
629 split :: Int -> FingerTree (Elem a) ->
630        (FingerTree (Elem a), FingerTree (Elem a))
631 split i Empty  = i `seq` (Empty, Empty)
632hunk ./Data/Sequence.hs 1376
633                        Split l x r -> Split (maybe Empty digitToTree l) x (deepL r m sf)
634   | i < spm    = case splitTree im m of
635                        Split ml xs mr -> case splitNode (im - size ml) xs of
636-                           Split l x r -> Split (deepR pr  ml l) x (deepL r mr sf)
637+                           Split l x r -> Split (deepR pr ml l) x (deepL r mr sf)
638   | otherwise  = case splitDigit (i - spm) sf of
639hunk ./Data/Sequence.hs 1378
640-                       Split l x r -> Split (deepR pr  m  l) x (maybe Empty digitToTree r)
641+                       Split l x r -> Split (deepR pr m l) x (maybe Empty digitToTree r)
642   where        spr     = size pr
643        spm     = spr + size m
644        im      = i - spr
645hunk ./Data/Sequence.hs 1383
646 
647+{-# SPECIALIZE pullL :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> FingerTree (Elem a) #-}
648+{-# SPECIALIZE pullL :: Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node a) #-}
649+pullL :: Sized a => Digit a -> FingerTree (Node a) -> FingerTree a
650+pullL pr m = case viewRTree m of
651+       Nothing2        -> digitToTree pr
652+       Just2 m' sf     -> Deep (size pr + size m) pr m' (nodeToDigit sf)
653+
654+{-# SPECIALIZE pullR :: FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
655+{-# SPECIALIZE pullR :: FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}
656+pullR :: Sized a => FingerTree (Node a) -> Digit a -> FingerTree a
657+pullR m sf = case viewLTree m of
658+       Nothing2        -> digitToTree sf
659+       Just2 pr m'     -> Deep (size sf + size m) (nodeToDigit pr) m' sf
660+
661 {-# SPECIALIZE deepL :: Maybe (Digit (Elem a)) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
662 {-# SPECIALIZE deepL :: Maybe (Digit (Node a)) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}
663 deepL :: Sized a => Maybe (Digit a) -> FingerTree (Node a) -> Digit a -> FingerTree a
664hunk ./Data/Sequence.hs 1400
665-deepL Nothing m sf     = case viewLTree m of
666-       Nothing2        -> digitToTree sf
667-       Just2 a m'      -> Deep (size m + size sf) (nodeToDigit a) m' sf
668+deepL Nothing m sf     = pullR m sf
669 deepL (Just pr) m sf   = deep pr m sf
670 
671 {-# SPECIALIZE deepR :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Maybe (Digit (Elem a)) -> FingerTree (Elem a) #-}
672hunk ./Data/Sequence.hs 1406
673 {-# SPECIALIZE deepR :: Digit (Node a) -> FingerTree (Node (Node a)) -> Maybe (Digit (Node a)) -> FingerTree (Node a) #-}
674 deepR :: Sized a => Digit a -> FingerTree (Node a) -> Maybe (Digit a) -> FingerTree a
675-deepR pr m Nothing     = case viewRTree m of
676-       Nothing2        -> digitToTree pr
677-       Just2 m' a      -> Deep (size pr + size m) pr m' (nodeToDigit a)
678+deepR pr m Nothing     = pullL pr m
679 deepR pr m (Just sf)   = deep pr m sf
680 
681 {-# SPECIALIZE splitNode :: Int -> Node (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-}
682hunk ./Data/Sequence.hs 1446
683        sab     = sa + size b
684        sabc    = sab + size c
685 
686+-- | /O(i)/ where /i/ is the breakpoint index.  'takeWhile', applied to a predicate @p@ and a sequence @xs@, returns the longest prefix (possibly empty) of @xs@ of elements that satisfy @p@.
687+takeWhile :: (a -> Bool) -> Seq a -> Seq a
688+takeWhile p xs = fst (span p xs)
689+-- takeWhile p = foldr (\ x xs -> if p x then x <| xs else empty) empty
690+
691+-- | /O(i)/ where /i/ is the breakpoint index.  @'dropWhile' p xs@ returns the suffix remaining after @takeWhile p xs@.
692+dropWhile :: (a -> Bool) -> Seq a -> Seq a
693+dropWhile p xs = snd (span p xs)
694+
695+-- | /O(i)/ where /i/ is the breakpoint index.  'span', applied to a predicate @p@ and a sequence @xs@, returns a tuple whose first element is the longest prefix (possibly empty) of @xs@ of elements that satisfy @p@ and the second element is the remainder of the sequence.
696+span :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
697+-- This doesn't make any more of a traversal than is necessary, exploiting the laziness of foldr and the structure preservation of mapAccumL.
698+span p xs = splitAt (foldr (\ x z n -> n `seq` if p x then z (n+1) else n) (const (length xs)) xs 0) xs
699+
700+-- | /O(i)/ where /i/ is the breakpoint index.  'break', applied to a predicate @p@ and a sequence @xs@, returns a tuple whose first element is the longest prefix (possibly empty) of @xs@ of elements that /do not satisfy/ @p@ and the second element is the remainder of the sequence.
701+break :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
702+break p xs = span (not . p) xs
703+
704+-- | /O(n)/.  The 'partition' function takes a predicate @p@ and a sequence @xs@ and returns sequences of those elements which do and do not satisfy the predicate.
705+partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
706+partition p = foldl partition' (empty, empty) where
707+       partition' (xs, ys) x
708+               | p x           = (xs |> x, ys)
709+               | otherwise     = (xs, ys |> x)
710+
711+-- | /O(n)/.  The 'filter' function takes a predicate @p@ and a sequence @xs@ and returns a sequence of those elements which satisfy the predicate.
712+filter :: (a -> Bool) -> Seq a -> Seq a
713+filter p = foldl filter' empty where
714+       filter' ys x
715+               | p x           = ys |> x
716+               | otherwise     = ys
717+
718 ------------------------------------------------------------------------
719 -- Lists
720 ------------------------------------------------------------------------
721hunk ./Data/Sequence.hs 1504
722                (reverseTree (reverseNode f) m)
723                (reverseDigit f pr)
724 
725+{-# INLINE reverseDigit #-}
726 reverseDigit :: (a -> a) -> Digit a -> Digit a
727 reverseDigit f (One a) = One (f a)
728 reverseDigit f (Two a b) = Two (f b) (f a)
729hunk ./Data/Sequence.hs 1515
730 reverseNode f (Node2 s a b) = Node2 s (f b) (f a)
731 reverseNode f (Node3 s a b c) = Node3 s (f c) (f b) (f a)
732 
733+------------------------------------------------------------------------
734+-- Zipping
735+--
736+-- We implement zipping on sequences by zipping left and right digits simultaneously and
737+-- processing excess appropriately.  This allows several elements to be ``zipped''
738+-- in a single go, which is significantly faster than it might be for a linked-list approach,
739+-- where we'd have to do at least one dereference for each element.
740+------------------------------------------------------------------------
741+
742+-- | /O(n)/.  'zip' takes two sequences and returns a sequence of corresponding pairs. 
743+-- If one input is short, excess elements of the longer sequence are discarded.
744+zip :: Seq a -> Seq b -> Seq (a, b)
745+zip = zipWith (,)
746+
747+-- | /O(n)/.  'zipWith' generalizes 'zip' by zipping with the function given as the first argument,
748+-- instead of a tupling function.  For example, @zipWith (+)@ is applied to two sequences to take
749+-- the sequence of corresponding sums.
750+zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
751+zipWith f xs ys
752+       | length xs <= length ys        = zipWith' f xs ys
753+       | otherwise                     = zipWith' (flip f) ys xs
754+       where  zipWith' f xs ys =
755+               let zipper ys x = case viewl ys of
756+                       EmptyL  -> error "zipper should never encounter an empty second string"
757+                       y :< ys -> (ys, f x y)
758+                       in snd (mapAccumL zipper ys xs)
759+
760+zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)
761+zip3 = zipWith3 (,,)
762+
763+zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
764+zipWith3 f s1 s2 s3 = zipWith ($) (zipWith f s1 s2) s3
765+
766+zip4 :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a,b,c,d)
767+zip4 = zipWith4 (,,,)
768+
769+zipWith4 :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e
770+zipWith4 f s1 s2 s3 s4 = zipWith ($) (zipWith ($) (zipWith f s1 s2) s3) s4
771+
772+------------------------------------------------------------------------
773+-- Sorting
774+--
775+-- sort and sortBy are implemented by simple deforestations of
776+--     \ xs -> fromList2 (length xs) . Data.List.sortBy cmp . toList
777+-- which does not get deforested automatically, it would appear.
778+--
779+-- Unstable sorting is performed by a heap sort implementation based on pairing heaps.  Because the
780+-- internal structure of sequences is quite varied, it is difficult to get blocks of elements of
781+-- roughly the same length, which would improve merge sort performance.  Pairing heaps, on the other
782+-- hand, are relatively resistant to the effects of merging heaps of wildly different sizes, as
783+-- guaranteed by its amortized constant-time merge operation.  Moreover, extensive use of SpecConstr
784+-- transformations can be done on pairing heaps, especially when we're only constructing them
785+-- to immediately be unrolled.
786+--
787+-- On purely random sequences of length 50000, with no RTS options, I get the following statistics,
788+-- in which heapsort is about 42.5% faster:
789+--
790+-- Times (ms)            min      mean    +/-sd    median    max
791+-- to/from list:       103.802  108.572    7.487  106.436  143.339
792+-- unstable heapsort:   60.686   62.968    4.275   61.187   79.151
793+--
794+-- Heapsort, it would seem, is less of a memory hog than Data.List.sortBy.  The gap is narrowed
795+-- when more memory is available, but heapsort still wins, 15% faster, with +RTS -H128m:
796+--
797+-- Times (ms)            min    mean    +/-sd  median    max
798+-- to/from list:       42.692  45.074   2.596  44.600  56.601
799+-- unstable heapsort:  37.100  38.344   3.043  37.715  55.526
800+--
801+-- In addition, on strictly increasing sequences the gap is even wider than normal; heapsort is
802+-- 68.5% faster with no RTS options:
803+-- Times (ms)            min    mean    +/-sd  median    max
804+-- to/from list:       52.236  53.574   1.987  53.034  62.098
805+-- unstable heapsort:  16.433  16.919   0.931  16.681  21.622
806+--
807+-- This may be attributed to the elegant nature of the pairing heap.
808+--
809+-- [email protected], 7/20/09
810+------------------------------------------------------------------------
811+
812+-- | /O(n log n)/.  'sort' sorts the specified 'Seq' by the natural ordering of its elements.  The sort is stable.
813+-- If a stable sort is not required, 'unstableSort' can be considerably faster, and in particular uses less memory.
814+sort :: Ord a => Seq a -> Seq a
815+sort = sortBy compare
816+
817+-- | /O(n log n)/.  'sortBy' sorts the specified 'Seq' according to the specified comparator.  The sort is stable.
818+-- If a stable sort is not required, 'unstableSortBy' can be considerably faster, and in particular uses less memory.
819+sortBy :: (a -> a -> Ordering) -> Seq a -> Seq a
820+-- fromList . Data.List.sortBy cmp . toList doesn't actually deforest well, so I did so manually and got a moderate
821+-- performance boost.
822+sortBy cmp xs = case foldr (\ x -> ([x]:)) [] xs of
823+       []      -> empty
824+       ys:yss  -> fromList2 (length xs) (merger0 ys yss)
825+       where   xs@(x:xs1) <> ys@(y:ys1) = case cmp x y of
826+                       GT      -> y:(xs <> ys1)
827+                       _       -> x:(xs1 <> ys)
828+               [] <> ys = ys
829+               xs <> [] = xs
830+               merger (xs1:xs2:xss) = (xs1 <> xs2) : merger xss
831+               merger xss = xss
832+               merger0 xs1 (xs2:xss) = merger0 (xs1 <> xs2) (merger xss)
833+               merger0 xs [] = xs
834+
835+-- | /O(n log n)/.  'unstableSort' sorts the specified 'Seq' by the natural ordering of its elements, but the sort is not stable.
836+-- This algorithm is frequently faster and uses less memory than 'sort', and performs extremely well -- frequently twice as fast as
837+-- 'sort' -- when the sequence is already nearly sorted.
838+unstableSort :: Ord a => Seq a -> Seq a
839+unstableSort = unstableSortBy compare
840+
841+-- | /O(n log n)/.  A generalization of 'unstableSort', 'unstableSortBy' takes an arbitrary comparator and sorts the specified sequence. 
842+-- The sort is not stable.  This algorithm is frequently faster and uses less memory than 'sortBy', and performs extremely well --
843+-- frequently twice as fast as 'sortBy' -- when the sequence is already nearly sorted.
844+unstableSortBy :: (a -> a -> Ordering) -> Seq a -> Seq a
845+unstableSortBy cmp (Seq xs) = fromList2 (size xs) $ maybe [] (unrollPQ cmp) $ toPQ cmp (\ (Elem x) -> PQueue x Nil) xs
846+
847+fromList2 :: Int -> [a] -> Seq a
848+-- fromList2, given a list and its length, constructs a completely balanced Seq whose elements are that list
849+-- using the applicativeTree generalization.
850+fromList2 n xs = Seq (execState (applicativeTree n 1 (State run)) xs) where
851+       run (x:xs) = (xs, Elem x)
852+       run _ = error "The flatly impossible has occurred"
853+
854+-- | A 'PQueue' is a simple pairing heap.
855+data PQueue e = PQueue e (PQL e)
856+
857+data PQL e = Nil | {-# UNPACK #-} !(PQueue e) :& PQL e
858+       -- admittedly a glorified list of PQueues, but nevertheless encourages SpecConstr use
859+
860+infixr 8 :&
861+
862+#if TESTING
863+
864+instance Functor PQueue where
865+       fmap f (PQueue x ts) = PQueue (f x) (fmap f ts)
866+
867+instance Functor PQL where
868+       fmap f (q :& qs) = fmap f q :& fmap f qs
869+       fmap _ Nil = Nil
870+
871+instance Show e => Show (PQueue e) where
872+       show = unlines . draw . fmap show
873+
874+-- borrowed wholesale from Data.Tree, as Data.Tree actually depends on Data.Sequence
875+draw :: PQueue String -> [String]
876+draw (PQueue x ts0) = x : drawSubTrees ts0
877+  where drawSubTrees Nil = []
878+       drawSubTrees (t :& Nil) =
879+               "|" : shift "`- " "   " (draw t)
880+       drawSubTrees (t :& ts) =
881+               "|" : shift "+- " "|  " (draw t) ++ drawSubTrees ts
882+
883+       shift first other = Data.List.zipWith (++) (first : repeat other)
884+#endif
885+
886+-- | 'unrollPQ', given a comparator function, unrolls a 'PQueue' into a sorted list.
887+unrollPQ :: (e -> e -> Ordering) -> PQueue e -> [e]
888+unrollPQ cmp = unrollPQ' where
889+       {-# INLINE unrollPQ' #-}
890+       unrollPQ' (PQueue x ts) = x:mergePQs0 ts
891+       (<>) = mergePQ cmp
892+       mergePQs0 Nil = []
893+       mergePQs0 (t :& Nil) = unrollPQ' t
894+       mergePQs0 (t1 :& t2 :& ts) = mergePQs (t1 <> t2) ts
895+       mergePQs t ts = t `seq` case ts of
896+               Nil             -> unrollPQ' t
897+               t1 :& Nil       -> unrollPQ' (t <> t1)
898+               t1 :& t2 :& ts  -> mergePQs (t <> (t1 <> t2)) ts
899+
900+-- | 'toPQ', given an ordering function and a mechanism for queueifying elements, converts a 'FingerTree' to a 'PQueue'.
901+toPQ :: (e -> e -> Ordering) -> (a -> PQueue e) -> FingerTree a -> Maybe (PQueue e)
902+toPQ _ _ Empty = Nothing
903+toPQ _ f (Single x) = Just (f x)
904+toPQ cmp f (Deep _ pr m sf) = Just $ case toPQ cmp fNode m of
905+       Nothing -> fDig pr <> fDig sf
906+       Just m' -> fDig pr <> m' <> fDig sf
907+ where (<>) = mergePQ cmp
908+       joinDig (<>) d = case d of      One a           -> a
909+                                       Two a b         -> a <> b
910+                                       Three a b c     -> a <> b <> c
911+                                       Four a b c d    -> (a <> b) <> (c <> d)
912+       fNode = fDig . nodeToDigit
913+       {-# INLINE fDig #-}
914+       fDig = joinDig (<>) . fmap f
915+
916+-- | 'mergePQ' merges two 'PQueue's.
917+mergePQ :: (a -> a -> Ordering) -> PQueue a -> PQueue a -> PQueue a
918+mergePQ cmp (PQueue x1 ts1) (PQueue x2 ts2)
919+       | cmp x1 x2 == GT       = PQueue x2 (PQueue x1 ts1 :& ts2)
920+       | otherwise             = PQueue x1 (PQueue x2 ts2 :& ts1)
921+
922 #if TESTING
923 
924 ------------------------------------------------------------------------
925hunk ./Data/Sequence.hs 1712
926 
927 instance Arbitrary a => Arbitrary (Seq a) where
928        arbitrary = liftM Seq arbitrary
929-       coarbitrary (Seq x) = coarbitrary x
930+       shrink (Seq x) = map Seq (shrink x)
931 
932 instance Arbitrary a => Arbitrary (Elem a) where
933        arbitrary = liftM Elem arbitrary
934hunk ./Data/Sequence.hs 1716
935-       coarbitrary (Elem x) = coarbitrary x
936+       shrink _ = []
937 
938 instance (Arbitrary a, Sized a) => Arbitrary (FingerTree a) where
939        arbitrary = sized arb
940hunk ./Data/Sequence.hs 1725
941                arb 1 = liftM Single arbitrary
942                arb n = liftM3 deep arbitrary (arb (n `div` 2)) arbitrary
943 
944-       coarbitrary Empty = variant 0
945-       coarbitrary (Single x) = variant 1 . coarbitrary x
946-       coarbitrary (Deep _ pr m sf) =
947-               variant 2 . coarbitrary pr . coarbitrary m . coarbitrary sf
948+       shrink (Deep _ (One a) Empty (One b)) = [Single a, Single b]
949+       shrink (Deep _ pr m sf) = [deep pr' m sf | pr' <- shrink pr] ++ [deep pr m' sf | m' <- shrink m] ++ [deep pr m sf' | sf' <- shrink sf]
950+       shrink (Single x) = map Single (shrink x)
951+       shrink Empty = []
952 
953 instance (Arbitrary a, Sized a) => Arbitrary (Node a) where
954        arbitrary = oneof [
955hunk ./Data/Sequence.hs 1735
956                        liftM2 node2 arbitrary arbitrary,
957                        liftM3 node3 arbitrary arbitrary arbitrary]
958 
959-       coarbitrary (Node2 _ a b) = variant 0 . coarbitrary a . coarbitrary b
960-       coarbitrary (Node3 _ a b c) =
961-               variant 1 . coarbitrary a . coarbitrary b . coarbitrary c
962+       shrink (Node2 _ a b) = [node2 a' b | a' <- shrink a] ++ [node2 a b' | b' <- shrink b]
963+       shrink (Node3 _ a b c) = [node2 a b, node2 a c, node2 b c] ++
964+               [node3 a' b c | a' <- shrink a] ++ [node3 a b' c | b' <- shrink b] ++ [node3 a b c' | c' <- shrink c]
965 
966 instance Arbitrary a => Arbitrary (Digit a) where
967        arbitrary = oneof [
968hunk ./Data/Sequence.hs 1745
969                        liftM2 Two arbitrary arbitrary,
970                        liftM3 Three arbitrary arbitrary arbitrary,
971                        liftM4 Four arbitrary arbitrary arbitrary arbitrary]
972-
973-       coarbitrary (One a) = variant 0 . coarbitrary a
974-       coarbitrary (Two a b) = variant 1 . coarbitrary a . coarbitrary b
975-       coarbitrary (Three a b c) =
976-               variant 2 . coarbitrary a . coarbitrary b . coarbitrary c
977-       coarbitrary (Four a b c d) =
978-               variant 3 . coarbitrary a . coarbitrary b . coarbitrary c . coarbitrary d
979+       
980+       shrink (One a) = map One (shrink a)
981+       shrink (Two a b) = [One a, One b]
982+       shrink (Three a b c) = [Two a b, Two a c, Two b c]
983+       shrink (Four a b c d) = [Three a b c, Three a b d, Three a c d, Three b c d]
984 
985 ------------------------------------------------------------------------
986 -- Valid trees
987hunk ./containers.cabal 23
988     location: http://darcs.haskell.org/packages/containers/
989 
990 Library {
991-    build-depends: base, array
992+    build-depends: base >= 4.0.0.0, array
993     exposed-modules:
994         Data.Graph
995         Data.IntMap
996}
997
998Context:
999
1000[Use left/right rather than old/new to describe the arguments to unionWithKey
1001Ian Lynagh <[email protected]>**20090208192132
1002 Fixes trac #3002.
1003]
1004[help nhc98 by making import decl more explicit
1005[email protected]**20090203142144]
1006[Add instance Data.Traversable for IntMap
1007Matti Niemenmaa <[email protected]>**20090116190353
1008 Ignore-this: df88a286935926aecec3f8a5dd291699
1009]
1010[Require Cabal version >= 1.6
1011Ian Lynagh <[email protected]>**20090122011256]
1012[Add "bug-reports" and "source-repository" info to the Cabal file
1013Ian Lynagh <[email protected]>**20090121182106]
1014[Fix warnings in containers
1015Ian Lynagh <[email protected]>**20090116200251]
1016[optimize IntMap/IntSet findMin/findMax
1017[email protected]**20081002152055]
1018[O(n) fromAscList IntSet / IntMap
1019[email protected]**20080521195941
1020 
1021 Added algorithm by Scott Dillard and Bertram Felgenhauer to build IntSets and
1022 IntMaps from sorted input in linear time. Also changed quickcheck prop_Ordered
1023 (no longer a tautology!) to include negative and duplicate keys.
1024 
1025]
1026[correct type for IntMap.intersectionWith[Key]
1027[email protected]**20081002144828]
1028[Export mapAccumRWithKey from Map and IntMap (Trac #2769)
1029[email protected]**20081210160205]
1030[Bump the version number to 0.2.0.1, to work-around cabal-install problems
1031Ian Lynagh <[email protected]>**20081212201829]
1032[Fix #2760: change mkNorepType to mkNoRepType
1033'Jose Pedro Magalhaes <[email protected]>'**20081202083424]
1034[Doc fix, from hackage trac #378
1035Ian Lynagh <[email protected]>**20081024143949]
1036[import Data.Data instead of Data.Generics.*, eliminating the dependency on syb
1037Ross Paterson <[email protected]>**20081005002559]
1038[fixed typo in highestBitMask
1039[email protected]**20081002215438]
1040[export Data.Map.toDescList, foldlWithKey, and foldrWithKey (trac ticket 2580)
1041[email protected]**20080922213200
1042 
1043 toDescList was previously implemented, but not exported.
1044 
1045 foldlWithKey was previously implemented, but not exported.  It can be used to
1046 implement toDescList.
1047 
1048 foldrWithKey is already exported as foldWithKey, but foldrWithKey is explicitly
1049 the mirror of foldlWithKey, and foldWithKey kept for compatibility.
1050]
1051[Bump version number to 0.2.0.0
1052Ian Lynagh <[email protected]>**20080920160016]
1053[TAG 6.10 branch has been forked
1054Ian Lynagh <[email protected]>**20080919123438]
1055[Fixed typo in updateMinWithKey / updateMaxWithKey
1056[email protected]**20080704054350]
1057[follow library changes
1058Ian Lynagh <[email protected]>**20080903223610]
1059[add include/Typeable.h to extra-source-files
1060Ross Paterson <[email protected]>**20080831181402]
1061[fix cabal build-depends for nhc98
1062[email protected]**20080828104248]
1063[Add a dep on syb
1064Ian Lynagh <[email protected]>**20080825214314]
1065[add category field
1066Ross Paterson <[email protected]>**20080824003013]
1067[we depend on st, now split off from base
1068Ian Lynagh <[email protected]>**20080823223053]
1069[specialize functions that fail in a Monad to Maybe (proposal #2309)
1070Ross Paterson <[email protected]>**20080722154812
1071 
1072 Specialize functions signatures like
1073 
1074        lookup :: (Monad m, Ord k) => k -> Map k a -> m a
1075 to
1076        lookup :: (Ord k) => k -> Map k a -> Maybe a
1077 
1078 for simplicity and safety.  No information is lost, as each of these
1079 functions had only one use of fail, which is now changed to Nothing.
1080]
1081[tighter description of split (addresses #2447)
1082Ross Paterson <[email protected]>**20080717064838]
1083[Make warning-clean with GHC again
1084Ian Lynagh <[email protected]>**20080623232023
1085 With any luck we have now converged on a solution that works everywhere!
1086]
1087[Undo more Data.Typeable-related breakage for non-ghc.
1088[email protected]**20080623092757]
1089[Placate GHC with explicit import lists
1090Ian Lynagh <[email protected]>**20080620183926]
1091[undo breakage caused by -Wall cleaning
1092[email protected]**20080620093922
1093 The import of Data.Typeable is still required, at least for non-GHC.
1094]
1095[Make the package -Wall clean
1096Ian Lynagh <[email protected]>**20080618233627]
1097[List particular extensions rather than -fglasgow-exts
1098Ian Lynagh <[email protected]>**20080616232035]
1099[Avoid using deprecated flags
1100Ian Lynagh <[email protected]>**20080616145241]
1101[TAG 2008-05-28
1102Ian Lynagh <[email protected]>**20080528004309]
1103Patch bundle hash:
11048bcc287dd979f25c06fa0d7923b2a9685db488c5