11f1880a05fc8cf63736084a1cf4094b7682528e
[packages/containers.git] / Data / Sequence.hs
1 {-# LANGUAGE CPP #-}
2 #if __GLASGOW_HASKELL__
3 {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
4 #endif
5 #if __GLASGOW_HASKELL__ >= 703
6 {-# LANGUAGE Trustworthy #-}
7 #endif
8 #if __GLASGOW_HASKELL__ >= 708
9 {-# LANGUAGE TypeFamilies #-}
10 #endif
11
12 #include "containers.h"
13
14 -----------------------------------------------------------------------------
15 -- |
16 -- Module : Data.Sequence
17 -- Copyright : (c) Ross Paterson 2005
18 -- (c) Louis Wasserman 2009
19 -- (c) David Feuer, Ross Paterson, and Milan Straka 2014
20 -- License : BSD-style
21 -- Maintainer : libraries@haskell.org
22 -- Stability : experimental
23 -- Portability : portable
24 --
25 -- General purpose finite sequences.
26 -- Apart from being finite and having strict operations, sequences
27 -- also differ from lists in supporting a wider variety of operations
28 -- efficiently.
29 --
30 -- An amortized running time is given for each operation, with /n/ referring
31 -- to the length of the sequence and /i/ being the integral index used by
32 -- some operations. These bounds hold even in a persistent (shared) setting.
33 --
34 -- The implementation uses 2-3 finger trees annotated with sizes,
35 -- as described in section 4.2 of
36 --
37 -- * Ralf Hinze and Ross Paterson,
38 -- \"Finger trees: a simple general-purpose data structure\",
39 -- /Journal of Functional Programming/ 16:2 (2006) pp 197-217.
40 -- <http://staff.city.ac.uk/~ross/papers/FingerTree.html>
41 --
42 -- /Note/: Many of these operations have the same names as similar
43 -- operations on lists in the "Prelude". The ambiguity may be resolved
44 -- using either qualification or the @hiding@ clause.
45 --
46 -----------------------------------------------------------------------------
47
48 module Data.Sequence (
49 #if !defined(TESTING)
50 Seq,
51 #else
52 Seq(..), Elem(..), FingerTree(..), Node(..), Digit(..),
53 #endif
54 -- * Construction
55 empty, -- :: Seq a
56 singleton, -- :: a -> Seq a
57 (<|), -- :: a -> Seq a -> Seq a
58 (|>), -- :: Seq a -> a -> Seq a
59 (><), -- :: Seq a -> Seq a -> Seq a
60 fromList, -- :: [a] -> Seq a
61 fromFunction, -- :: Int -> (Int -> a) -> Seq a
62 fromArray, -- :: Ix i => Array i a -> Seq a
63 -- ** Repetition
64 replicate, -- :: Int -> a -> Seq a
65 replicateA, -- :: Applicative f => Int -> f a -> f (Seq a)
66 replicateM, -- :: Monad m => Int -> m a -> m (Seq a)
67 -- ** Iterative construction
68 iterateN, -- :: Int -> (a -> a) -> a -> Seq a
69 unfoldr, -- :: (b -> Maybe (a, b)) -> b -> Seq a
70 unfoldl, -- :: (b -> Maybe (b, a)) -> b -> Seq a
71 -- * Deconstruction
72 -- | Additional functions for deconstructing sequences are available
73 -- via the 'Foldable' instance of 'Seq'.
74
75 -- ** Queries
76 null, -- :: Seq a -> Bool
77 length, -- :: Seq a -> Int
78 -- ** Views
79 ViewL(..),
80 viewl, -- :: Seq a -> ViewL a
81 ViewR(..),
82 viewr, -- :: Seq a -> ViewR a
83 -- * Scans
84 scanl, -- :: (a -> b -> a) -> a -> Seq b -> Seq a
85 scanl1, -- :: (a -> a -> a) -> Seq a -> Seq a
86 scanr, -- :: (a -> b -> b) -> b -> Seq a -> Seq b
87 scanr1, -- :: (a -> a -> a) -> Seq a -> Seq a
88 -- * Sublists
89 tails, -- :: Seq a -> Seq (Seq a)
90 inits, -- :: Seq a -> Seq (Seq a)
91 -- ** Sequential searches
92 takeWhileL, -- :: (a -> Bool) -> Seq a -> Seq a
93 takeWhileR, -- :: (a -> Bool) -> Seq a -> Seq a
94 dropWhileL, -- :: (a -> Bool) -> Seq a -> Seq a
95 dropWhileR, -- :: (a -> Bool) -> Seq a -> Seq a
96 spanl, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
97 spanr, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
98 breakl, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
99 breakr, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
100 partition, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
101 filter, -- :: (a -> Bool) -> Seq a -> Seq a
102 -- * Sorting
103 sort, -- :: Ord a => Seq a -> Seq a
104 sortBy, -- :: (a -> a -> Ordering) -> Seq a -> Seq a
105 unstableSort, -- :: Ord a => Seq a -> Seq a
106 unstableSortBy, -- :: (a -> a -> Ordering) -> Seq a -> Seq a
107 -- * Indexing
108 index, -- :: Seq a -> Int -> a
109 adjust, -- :: (a -> a) -> Int -> Seq a -> Seq a
110 update, -- :: Int -> a -> Seq a -> Seq a
111 take, -- :: Int -> Seq a -> Seq a
112 drop, -- :: Int -> Seq a -> Seq a
113 splitAt, -- :: Int -> Seq a -> (Seq a, Seq a)
114 -- ** Indexing with predicates
115 -- | These functions perform sequential searches from the left
116 -- or right ends of the sequence, returning indices of matching
117 -- elements.
118 elemIndexL, -- :: Eq a => a -> Seq a -> Maybe Int
119 elemIndicesL, -- :: Eq a => a -> Seq a -> [Int]
120 elemIndexR, -- :: Eq a => a -> Seq a -> Maybe Int
121 elemIndicesR, -- :: Eq a => a -> Seq a -> [Int]
122 findIndexL, -- :: (a -> Bool) -> Seq a -> Maybe Int
123 findIndicesL, -- :: (a -> Bool) -> Seq a -> [Int]
124 findIndexR, -- :: (a -> Bool) -> Seq a -> Maybe Int
125 findIndicesR, -- :: (a -> Bool) -> Seq a -> [Int]
126 -- * Folds
127 -- | General folds are available via the 'Foldable' instance of 'Seq'.
128 foldlWithIndex, -- :: (b -> Int -> a -> b) -> b -> Seq a -> b
129 foldrWithIndex, -- :: (Int -> a -> b -> b) -> b -> Seq a -> b
130 -- * Transformations
131 mapWithIndex, -- :: (Int -> a -> b) -> Seq a -> Seq b
132 reverse, -- :: Seq a -> Seq a
133 -- ** Zips
134 zip, -- :: Seq a -> Seq b -> Seq (a, b)
135 zipWith, -- :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
136 zip3, -- :: Seq a -> Seq b -> Seq c -> Seq (a, b, c)
137 zipWith3, -- :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
138 zip4, -- :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a, b, c, d)
139 zipWith4, -- :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e
140 #if TESTING
141 Sized(..),
142 deep,
143 node2,
144 node3,
145 #endif
146 ) where
147
148 import Prelude hiding (
149 Functor(..),
150 #if MIN_VERSION_base(4,8,0)
151 Applicative, foldMap, Monoid,
152 #endif
153 null, length, take, drop, splitAt, foldl, foldl1, foldr, foldr1,
154 scanl, scanl1, scanr, scanr1, replicate, zip, zipWith, zip3, zipWith3,
155 takeWhile, dropWhile, iterate, reverse, filter, mapM, sum, all)
156 import qualified Data.List
157 import Control.Applicative (Applicative(..), (<$>), Alternative,
158 WrappedMonad(..), liftA, liftA2, liftA3)
159 import qualified Control.Applicative as Applicative (Alternative(..))
160 import Control.DeepSeq (NFData(rnf))
161 import Control.Monad (MonadPlus(..), ap)
162 import Data.Monoid (Monoid(..))
163 import Data.Functor (Functor(..))
164 import Data.Foldable (Foldable(foldl, foldl1, foldr, foldr1, foldMap), foldl', toList)
165 #if MIN_VERSION_base(4,8,0)
166 import Data.Foldable (foldr')
167 #endif
168 import Data.Traversable
169 import Data.Typeable
170
171 -- GHC specific stuff
172 #ifdef __GLASGOW_HASKELL__
173 import GHC.Exts (build)
174 import Text.Read (Lexeme(Ident), lexP, parens, prec,
175 readPrec, readListPrec, readListPrecDefault)
176 import Data.Data
177 #endif
178
179 -- Array stuff, with GHC.Arr on GHC
180 import Data.Array (Ix, Array)
181 #ifdef __GLASGOW_HASKELL__
182 import qualified GHC.Arr
183 #endif
184
185 -- Coercion on GHC 7.8+
186 #if __GLASGOW_HASKELL__ >= 708
187 import Data.Coerce
188 import qualified GHC.Exts
189 #else
190 #endif
191
192 -- Identity functor on base 4.8 (GHC 7.10+)
193 #if MIN_VERSION_base(4,8,0)
194 import Data.Functor.Identity (Identity(..))
195 #endif
196
197
198 infixr 5 `consTree`
199 infixl 5 `snocTree`
200 infixr 5 `appendTree0`
201
202 infixr 5 ><
203 infixr 5 <|, :<
204 infixl 5 |>, :>
205
206 class Sized a where
207 size :: a -> Int
208
209 -- | General-purpose finite sequences.
210 newtype Seq a = Seq (FingerTree (Elem a))
211
212 instance Functor Seq where
213 fmap = fmapSeq
214 #ifdef __GLASGOW_HASKELL__
215 x <$ s = replicate (length s) x
216 #endif
217
218 fmapSeq :: (a -> b) -> Seq a -> Seq b
219 fmapSeq f (Seq xs) = Seq (fmap (fmap f) xs)
220 #ifdef __GLASGOW_HASKELL__
221 {-# NOINLINE [1] fmapSeq #-}
222 {-# RULES
223 "fmapSeq/fmapSeq" forall f g xs . fmapSeq f (fmapSeq g xs) = fmapSeq (f . g) xs
224 #-}
225 #endif
226 #if __GLASGOW_HASKELL__ >= 709
227 -- Safe coercions were introduced in 7.8, but did not work well with RULES yet.
228 {-# RULES
229 "fmapSeq/coerce" fmapSeq coerce = coerce
230 #-}
231 #endif
232
233 instance Foldable Seq where
234 foldMap f (Seq xs) = foldMap (foldMap f) xs
235 foldr f z (Seq xs) = foldr (flip (foldr f)) z xs
236 foldl f z (Seq xs) = foldl (foldl f) z xs
237
238 foldr1 f (Seq xs) = getElem (foldr1 f' xs)
239 where f' (Elem x) (Elem y) = Elem (f x y)
240
241 foldl1 f (Seq xs) = getElem (foldl1 f' xs)
242 where f' (Elem x) (Elem y) = Elem (f x y)
243
244 #if MIN_VERSION_base(4,8,0)
245 length = length
246 {-# INLINE length #-}
247 null = null
248 {-# INLINE null #-}
249 #endif
250
251 instance Traversable Seq where
252 traverse f (Seq xs) = Seq <$> traverse (traverse f) xs
253
254 instance NFData a => NFData (Seq a) where
255 rnf (Seq xs) = rnf xs
256
257 instance Monad Seq where
258 return = singleton
259 xs >>= f = foldl' add empty xs
260 where add ys x = ys >< f x
261 (>>) = (*>)
262
263 instance Applicative Seq where
264 pure = singleton
265
266 Seq Empty <*> xs = xs `seq` empty
267 fs <*> Seq Empty = fs `seq` empty
268 fs <*> Seq (Single (Elem x)) = fmap ($ x) fs
269 fs <*> xs
270 | length fs < 4 = foldl' add empty fs
271 where add ys f = ys >< fmap f xs
272 fs <*> xs | length xs < 4 = apShort fs xs
273 fs <*> xs = apty fs xs
274
275 xs *> ys = replicateSeq (length xs) ys
276
277 -- <*> when the length of the first argument is at least two and
278 -- the length of the second is two or three.
279 apShort :: Seq (a -> b) -> Seq a -> Seq b
280 apShort (Seq fs) xs = Seq $ case toList xs of
281 [a,b] -> ap2FT fs (a,b)
282 [a,b,c] -> ap3FT fs (a,b,c)
283 _ -> error "apShort: not 2-3"
284
285 ap2FT :: FingerTree (Elem (a->b)) -> (a,a) -> FingerTree (Elem b)
286 ap2FT fs (x,y) = Deep (size fs * 2)
287 (Two (Elem $ firstf x) (Elem $ firstf y))
288 (mapMulFT 2 (\(Elem f) -> Node2 2 (Elem (f x)) (Elem (f y))) m)
289 (Two (Elem $ lastf x) (Elem $ lastf y))
290 where
291 (Elem firstf, m, Elem lastf) = trimTree fs
292
293 ap3FT :: FingerTree (Elem (a->b)) -> (a,a,a) -> FingerTree (Elem b)
294 ap3FT fs (x,y,z) = Deep (size fs * 3)
295 (Three (Elem $ firstf x) (Elem $ firstf y) (Elem $ firstf z))
296 (mapMulFT 3 (\(Elem f) -> Node3 3 (Elem (f x)) (Elem (f y)) (Elem (f z))) m)
297 (Three (Elem $ lastf x) (Elem $ lastf y) (Elem $ lastf z))
298 where
299 (Elem firstf, m, Elem lastf) = trimTree fs
300
301 -- <*> when the length of each argument is at least four.
302 apty :: Seq (a -> b) -> Seq a -> Seq b
303 apty (Seq fs) (Seq xs@Deep{}) = Seq $
304 Deep (s' * size fs)
305 (fmap (fmap firstf) pr')
306 (aptyMiddle (fmap firstf) (fmap lastf) fmap fs' xs')
307 (fmap (fmap lastf) sf')
308 where
309 (Elem firstf, fs', Elem lastf) = trimTree fs
310 xs'@(Deep s' pr' _m' sf') = rigidify xs
311 apty _ _ = error "apty: expects a Deep constructor"
312
313 -- | 'aptyMiddle' does most of the hard work of computing @fs<*>xs@.
314 -- It produces the center part of a finger tree, with a prefix corresponding
315 -- to the prefix of @xs@ and a suffix corresponding to the suffix of @xs@
316 -- omitted; the missing suffix and prefix are added by the caller.
317 -- For the recursive call, it squashes the prefix and the suffix into
318 -- the center tree. Once it gets to the bottom, it turns the tree into
319 -- a 2-3 tree, applies 'mapMulFT' to produce the main body, and glues all
320 -- the pieces together.
321 aptyMiddle
322 :: Sized c =>
323 (c -> d)
324 -> (c -> d)
325 -> ((a -> b) -> c -> d)
326 -> FingerTree (Elem (a -> b))
327 -> FingerTree c
328 -> FingerTree (Node d)
329 -- Not at the bottom yet
330 aptyMiddle firstf
331 lastf
332 map23
333 fs
334 (Deep s pr (Deep sm prm mm sfm) sf)
335 = Deep (sm + s * (size fs + 1)) -- note: sm = s - size pr - size sf
336 (fmap (fmap firstf) prm)
337 (aptyMiddle (fmap firstf)
338 (fmap lastf)
339 (\f -> fmap (map23 f))
340 fs
341 (Deep s (squashL pr prm) mm (squashR sfm sf)))
342 (fmap (fmap lastf) sfm)
343
344 -- At the bottom. Note that these appendTree0 calls are very cheap, because in
345 -- each case, one of the arguments is guaranteed to be Empty or Single.
346 aptyMiddle firstf
347 lastf
348 map23
349 fs
350 (Deep s pr m sf)
351 = fmap (fmap firstf) m `appendTree0`
352 ((fmap firstf (digitToNode sf)
353 `consTree` middle)
354 `snocTree` fmap lastf (digitToNode pr))
355 `appendTree0` fmap (fmap lastf) m
356 where middle = case trimTree $ mapMulFT s (\(Elem f) -> fmap (fmap (map23 f)) converted) fs of
357 (firstMapped, restMapped, lastMapped) ->
358 Deep (size firstMapped + size restMapped + size lastMapped)
359 (nodeToDigit firstMapped) restMapped (nodeToDigit lastMapped)
360 converted = case m of
361 Empty -> Node2 s lconv rconv
362 Single q -> Node3 s lconv q rconv
363 Deep{} -> error "aptyMiddle: impossible"
364 lconv = digitToNode pr
365 rconv = digitToNode sf
366
367 aptyMiddle _ _ _ _ _ = error "aptyMiddle: expected Deep finger tree"
368
369 {-# SPECIALIZE
370 aptyMiddle
371 :: (Node c -> d)
372 -> (Node c -> d)
373 -> ((a -> b) -> Node c -> d)
374 -> FingerTree (Elem (a -> b))
375 -> FingerTree (Node c)
376 -> FingerTree (Node d)
377 #-}
378 {-# SPECIALIZE
379 aptyMiddle
380 :: (Elem c -> d)
381 -> (Elem c -> d)
382 -> ((a -> b) -> Elem c -> d)
383 -> FingerTree (Elem (a -> b))
384 -> FingerTree (Elem c)
385 -> FingerTree (Node d)
386 #-}
387
388 digitToNode :: Sized a => Digit a -> Node a
389 digitToNode (Two a b) = node2 a b
390 digitToNode (Three a b c) = node3 a b c
391 digitToNode _ = error "digitToNode: not representable as a node"
392
393 type Digit23 = Digit
394 type Digit12 = Digit
395
396 -- Squash the first argument down onto the left side of the second.
397 squashL :: Sized a => Digit23 a -> Digit12 (Node a) -> Digit23 (Node a)
398 squashL (Two a b) (One n) = Two (node2 a b) n
399 squashL (Two a b) (Two n1 n2) = Three (node2 a b) n1 n2
400 squashL (Three a b c) (One n) = Two (node3 a b c) n
401 squashL (Three a b c) (Two n1 n2) = Three (node3 a b c) n1 n2
402 squashL _ _ = error "squashL: wrong digit types"
403
404 -- Squash the second argument down onto the right side of the first
405 squashR :: Sized a => Digit12 (Node a) -> Digit23 a -> Digit23 (Node a)
406 squashR (One n) (Two a b) = Two n (node2 a b)
407 squashR (Two n1 n2) (Two a b) = Three n1 n2 (node2 a b)
408 squashR (One n) (Three a b c) = Two n (node3 a b c)
409 squashR (Two n1 n2) (Three a b c) = Three n1 n2 (node3 a b c)
410 squashR _ _ = error "squashR: wrong digit types"
411
412 -- | /O(m*n)/ (incremental) Takes an /O(m)/ function and a finger tree of size
413 -- /n/ and maps the function over the tree leaves. Unlike the usual 'fmap', the
414 -- function is applied to the "leaves" of the 'FingerTree' (i.e., given a
415 -- @FingerTree (Elem a)@, it applies the function to elements of type @Elem
416 -- a@), replacing the leaves with subtrees of at least the same height, e.g.,
417 -- @Node(Node(Elem y))@. The multiplier argument serves to make the annotations
418 -- match up properly.
419 mapMulFT :: Int -> (a -> b) -> FingerTree a -> FingerTree b
420 mapMulFT _ _ Empty = Empty
421 mapMulFT _mul f (Single a) = Single (f a)
422 mapMulFT mul f (Deep s pr m sf) = Deep (mul * s) (fmap f pr) (mapMulFT mul (mapMulNode mul f) m) (fmap f sf)
423
424 mapMulNode :: Int -> (a -> b) -> Node a -> Node b
425 mapMulNode mul f (Node2 s a b) = Node2 (mul * s) (f a) (f b)
426 mapMulNode mul f (Node3 s a b c) = Node3 (mul * s) (f a) (f b) (f c)
427
428
429 trimTree :: Sized a => FingerTree a -> (a, FingerTree a, a)
430 trimTree Empty = error "trim: empty tree"
431 trimTree Single{} = error "trim: singleton"
432 trimTree t = case splitTree 0 t of
433 Split _ hd r ->
434 case splitTree (size r - 1) r of
435 Split m tl _ -> (hd, m, tl)
436
437 -- | /O(log n)/ (incremental) Takes the extra flexibility out of a 'FingerTree'
438 -- to make it a genuine 2-3 finger tree. The result of 'rigidify' will have
439 -- only 'Two' and 'Three' digits at the top level and only 'One' and 'Two'
440 -- digits elsewhere. It gives an error if the tree has fewer than four
441 -- elements.
442 rigidify :: Sized a => FingerTree a -> FingerTree a
443 -- Note that 'rigidify' may call itself, but it will do so at most
444 -- once: each call to 'rigidify' will either fix the whole tree or fix one digit
445 -- and leave the other alone. The patterns below just fix up the top level of
446 -- the tree; 'rigidify' delegates the hard work to 'thin'.
447
448 -- The top of the tree is fine.
449 rigidify (Deep s pr@Two{} m sf@Three{}) = Deep s pr (thin m) sf
450 rigidify (Deep s pr@Three{} m sf@Three{}) = Deep s pr (thin m) sf
451 rigidify (Deep s pr@Two{} m sf@Two{}) = Deep s pr (thin m) sf
452 rigidify (Deep s pr@Three{} m sf@Two{}) = Deep s pr (thin m) sf
453
454 -- One of the Digits is a Four.
455 rigidify (Deep s (Four a b c d) m sf) =
456 rigidify $ Deep s (Two a b) (node2 c d `consTree` m) sf
457 rigidify (Deep s pr m (Four a b c d)) =
458 rigidify $ Deep s pr (m `snocTree` node2 a b) (Two c d)
459
460 -- One of the Digits is a One. If the middle is empty, we can only rigidify the
461 -- tree if the other Digit is a Three.
462 rigidify (Deep s (One a) Empty (Three b c d)) = Deep s (Two a b) Empty (Two c d)
463 rigidify (Deep s (One a) m sf) = rigidify $ case viewLTree m of
464 Just2 (Node2 _ b c) m' -> Deep s (Three a b c) m' sf
465 Just2 (Node3 _ b c d) m' -> Deep s (Two a b) (node2 c d `consTree` m') sf
466 Nothing2 -> error "rigidify: small tree"
467 rigidify (Deep s (Three a b c) Empty (One d)) = Deep s (Two a b) Empty (Two c d)
468 rigidify (Deep s pr m (One e)) = rigidify $ case viewRTree m of
469 Just2 m' (Node2 _ a b) -> Deep s pr m' (Three a b e)
470 Just2 m' (Node3 _ a b c) -> Deep s pr (m' `snocTree` node2 a b) (Two c e)
471 Nothing2 -> error "rigidify: small tree"
472 rigidify Empty = error "rigidify: empty tree"
473 rigidify Single{} = error "rigidify: singleton"
474
475 -- | /O(log n)/ (incremental) Rejigger a finger tree so the digits are all ones
476 -- and twos.
477 thin :: Sized a => FingerTree a -> FingerTree a
478 -- Note that 'thin12' will produce a 'Deep' constructor immediately before
479 -- recursively calling 'thin'.
480 thin Empty = Empty
481 thin (Single a) = Single a
482 thin t@(Deep s pr m sf) =
483 case pr of
484 One{} -> thin12 t
485 Two{} -> thin12 t
486 Three a b c -> thin12 $ Deep s (One a) (node2 b c `consTree` m) sf
487 Four a b c d -> thin12 $ Deep s (Two a b) (node2 c d `consTree` m) sf
488
489 thin12 :: Sized a => FingerTree a -> FingerTree a
490 thin12 (Deep s pr m sf@One{}) = Deep s pr (thin m) sf
491 thin12 (Deep s pr m sf@Two{}) = Deep s pr (thin m) sf
492 thin12 (Deep s pr m (Three a b c)) = Deep s pr (thin $ m `snocTree` node2 a b) (One c)
493 thin12 (Deep s pr m (Four a b c d)) = Deep s pr (thin $ m `snocTree` node2 a b) (Two c d)
494 thin12 _ = error "thin12 expects a Deep FingerTree."
495
496
497 instance MonadPlus Seq where
498 mzero = empty
499 mplus = (><)
500
501 instance Alternative Seq where
502 empty = empty
503 (<|>) = (><)
504
505 instance Eq a => Eq (Seq a) where
506 xs == ys = length xs == length ys && toList xs == toList ys
507
508 instance Ord a => Ord (Seq a) where
509 compare xs ys = compare (toList xs) (toList ys)
510
511 #if TESTING
512 instance Show a => Show (Seq a) where
513 showsPrec p (Seq x) = showsPrec p x
514 #else
515 instance Show a => Show (Seq a) where
516 showsPrec p xs = showParen (p > 10) $
517 showString "fromList " . shows (toList xs)
518 #endif
519
520 instance Read a => Read (Seq a) where
521 #ifdef __GLASGOW_HASKELL__
522 readPrec = parens $ prec 10 $ do
523 Ident "fromList" <- lexP
524 xs <- readPrec
525 return (fromList xs)
526
527 readListPrec = readListPrecDefault
528 #else
529 readsPrec p = readParen (p > 10) $ \ r -> do
530 ("fromList",s) <- lex r
531 (xs,t) <- reads s
532 return (fromList xs,t)
533 #endif
534
535 instance Monoid (Seq a) where
536 mempty = empty
537 mappend = (><)
538
539 INSTANCE_TYPEABLE1(Seq,seqTc,"Seq")
540
541 #if __GLASGOW_HASKELL__
542 instance Data a => Data (Seq a) where
543 gfoldl f z s = case viewl s of
544 EmptyL -> z empty
545 x :< xs -> z (<|) `f` x `f` xs
546
547 gunfold k z c = case constrIndex c of
548 1 -> z empty
549 2 -> k (k (z (<|)))
550 _ -> error "gunfold"
551
552 toConstr xs
553 | null xs = emptyConstr
554 | otherwise = consConstr
555
556 dataTypeOf _ = seqDataType
557
558 dataCast1 f = gcast1 f
559
560 emptyConstr, consConstr :: Constr
561 emptyConstr = mkConstr seqDataType "empty" [] Prefix
562 consConstr = mkConstr seqDataType "<|" [] Infix
563
564 seqDataType :: DataType
565 seqDataType = mkDataType "Data.Sequence.Seq" [emptyConstr, consConstr]
566 #endif
567
568 -- Finger trees
569
570 data FingerTree a
571 = Empty
572 | Single a
573 | Deep {-# UNPACK #-} !Int !(Digit a) (FingerTree (Node a)) !(Digit a)
574 #if TESTING
575 deriving Show
576 #endif
577
578 instance Sized a => Sized (FingerTree a) where
579 {-# SPECIALIZE instance Sized (FingerTree (Elem a)) #-}
580 {-# SPECIALIZE instance Sized (FingerTree (Node a)) #-}
581 size Empty = 0
582 size (Single x) = size x
583 size (Deep v _ _ _) = v
584
585 instance Foldable FingerTree where
586 foldMap _ Empty = mempty
587 foldMap f (Single x) = f x
588 foldMap f (Deep _ pr m sf) =
589 foldMap f pr `mappend` (foldMap (foldMap f) m `mappend` foldMap f sf)
590
591 foldr _ z Empty = z
592 foldr f z (Single x) = x `f` z
593 foldr f z (Deep _ pr m sf) =
594 foldr f (foldr (flip (foldr f)) (foldr f z sf) m) pr
595
596 foldl _ z Empty = z
597 foldl f z (Single x) = z `f` x
598 foldl f z (Deep _ pr m sf) =
599 foldl f (foldl (foldl f) (foldl f z pr) m) sf
600
601 foldr1 _ Empty = error "foldr1: empty sequence"
602 foldr1 _ (Single x) = x
603 foldr1 f (Deep _ pr m sf) =
604 foldr f (foldr (flip (foldr f)) (foldr1 f sf) m) pr
605
606 foldl1 _ Empty = error "foldl1: empty sequence"
607 foldl1 _ (Single x) = x
608 foldl1 f (Deep _ pr m sf) =
609 foldl f (foldl (foldl f) (foldl1 f pr) m) sf
610
611 instance Functor FingerTree where
612 fmap _ Empty = Empty
613 fmap f (Single x) = Single (f x)
614 fmap f (Deep v pr m sf) =
615 Deep v (fmap f pr) (fmap (fmap f) m) (fmap f sf)
616
617 instance Traversable FingerTree where
618 traverse _ Empty = pure Empty
619 traverse f (Single x) = Single <$> f x
620 traverse f (Deep v pr m sf) =
621 Deep v <$> traverse f pr <*> traverse (traverse f) m <*>
622 traverse f sf
623
624 instance NFData a => NFData (FingerTree a) where
625 rnf (Empty) = ()
626 rnf (Single x) = rnf x
627 rnf (Deep _ pr m sf) = rnf pr `seq` rnf sf `seq` rnf m
628
629 {-# INLINE deep #-}
630 deep :: Sized a => Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a
631 deep pr m sf = Deep (size pr + size m + size sf) pr m sf
632
633 {-# INLINE pullL #-}
634 pullL :: Sized a => Int -> FingerTree (Node a) -> Digit a -> FingerTree a
635 pullL s m sf = case viewLTree m of
636 Nothing2 -> digitToTree' s sf
637 Just2 pr m' -> Deep s (nodeToDigit pr) m' sf
638
639 {-# INLINE pullR #-}
640 pullR :: Sized a => Int -> Digit a -> FingerTree (Node a) -> FingerTree a
641 pullR s pr m = case viewRTree m of
642 Nothing2 -> digitToTree' s pr
643 Just2 m' sf -> Deep s pr m' (nodeToDigit sf)
644
645 {-# SPECIALIZE deepL :: Maybe (Digit (Elem a)) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
646 {-# SPECIALIZE deepL :: Maybe (Digit (Node a)) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}
647 deepL :: Sized a => Maybe (Digit a) -> FingerTree (Node a) -> Digit a -> FingerTree a
648 deepL Nothing m sf = pullL (size m + size sf) m sf
649 deepL (Just pr) m sf = deep pr m sf
650
651 {-# SPECIALIZE deepR :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Maybe (Digit (Elem a)) -> FingerTree (Elem a) #-}
652 {-# SPECIALIZE deepR :: Digit (Node a) -> FingerTree (Node (Node a)) -> Maybe (Digit (Node a)) -> FingerTree (Node a) #-}
653 deepR :: Sized a => Digit a -> FingerTree (Node a) -> Maybe (Digit a) -> FingerTree a
654 deepR pr m Nothing = pullR (size m + size pr) pr m
655 deepR pr m (Just sf) = deep pr m sf
656
657 -- Digits
658
659 data Digit a
660 = One a
661 | Two a a
662 | Three a a a
663 | Four a a a a
664 #if TESTING
665 deriving Show
666 #endif
667
668 instance Foldable Digit where
669 foldMap f (One a) = f a
670 foldMap f (Two a b) = f a `mappend` f b
671 foldMap f (Three a b c) = f a `mappend` (f b `mappend` f c)
672 foldMap f (Four a b c d) = f a `mappend` (f b `mappend` (f c `mappend` f d))
673
674 foldr f z (One a) = a `f` z
675 foldr f z (Two a b) = a `f` (b `f` z)
676 foldr f z (Three a b c) = a `f` (b `f` (c `f` z))
677 foldr f z (Four a b c d) = a `f` (b `f` (c `f` (d `f` z)))
678
679 foldl f z (One a) = z `f` a
680 foldl f z (Two a b) = (z `f` a) `f` b
681 foldl f z (Three a b c) = ((z `f` a) `f` b) `f` c
682 foldl f z (Four a b c d) = (((z `f` a) `f` b) `f` c) `f` d
683
684 foldr1 _ (One a) = a
685 foldr1 f (Two a b) = a `f` b
686 foldr1 f (Three a b c) = a `f` (b `f` c)
687 foldr1 f (Four a b c d) = a `f` (b `f` (c `f` d))
688
689 foldl1 _ (One a) = a
690 foldl1 f (Two a b) = a `f` b
691 foldl1 f (Three a b c) = (a `f` b) `f` c
692 foldl1 f (Four a b c d) = ((a `f` b) `f` c) `f` d
693
694 instance Functor Digit where
695 {-# INLINE fmap #-}
696 fmap f (One a) = One (f a)
697 fmap f (Two a b) = Two (f a) (f b)
698 fmap f (Three a b c) = Three (f a) (f b) (f c)
699 fmap f (Four a b c d) = Four (f a) (f b) (f c) (f d)
700
701 instance Traversable Digit where
702 {-# INLINE traverse #-}
703 traverse f (One a) = One <$> f a
704 traverse f (Two a b) = Two <$> f a <*> f b
705 traverse f (Three a b c) = Three <$> f a <*> f b <*> f c
706 traverse f (Four a b c d) = Four <$> f a <*> f b <*> f c <*> f d
707
708 instance NFData a => NFData (Digit a) where
709 rnf (One a) = rnf a
710 rnf (Two a b) = rnf a `seq` rnf b
711 rnf (Three a b c) = rnf a `seq` rnf b `seq` rnf c
712 rnf (Four a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d
713
714 instance Sized a => Sized (Digit a) where
715 {-# INLINE size #-}
716 size = foldl1 (+) . fmap size
717
718 {-# SPECIALIZE digitToTree :: Digit (Elem a) -> FingerTree (Elem a) #-}
719 {-# SPECIALIZE digitToTree :: Digit (Node a) -> FingerTree (Node a) #-}
720 digitToTree :: Sized a => Digit a -> FingerTree a
721 digitToTree (One a) = Single a
722 digitToTree (Two a b) = deep (One a) Empty (One b)
723 digitToTree (Three a b c) = deep (Two a b) Empty (One c)
724 digitToTree (Four a b c d) = deep (Two a b) Empty (Two c d)
725
726 -- | Given the size of a digit and the digit itself, efficiently converts
727 -- it to a FingerTree.
728 digitToTree' :: Int -> Digit a -> FingerTree a
729 digitToTree' n (Four a b c d) = Deep n (Two a b) Empty (Two c d)
730 digitToTree' n (Three a b c) = Deep n (Two a b) Empty (One c)
731 digitToTree' n (Two a b) = Deep n (One a) Empty (One b)
732 digitToTree' n (One a) = n `seq` Single a
733
734 -- Nodes
735
736 data Node a
737 = Node2 {-# UNPACK #-} !Int a a
738 | Node3 {-# UNPACK #-} !Int a a a
739 #if TESTING
740 deriving Show
741 #endif
742
743 instance Foldable Node where
744 foldMap f (Node2 _ a b) = f a `mappend` f b
745 foldMap f (Node3 _ a b c) = f a `mappend` (f b `mappend` f c)
746
747 foldr f z (Node2 _ a b) = a `f` (b `f` z)
748 foldr f z (Node3 _ a b c) = a `f` (b `f` (c `f` z))
749
750 foldl f z (Node2 _ a b) = (z `f` a) `f` b
751 foldl f z (Node3 _ a b c) = ((z `f` a) `f` b) `f` c
752
753 instance Functor Node where
754 {-# INLINE fmap #-}
755 fmap f (Node2 v a b) = Node2 v (f a) (f b)
756 fmap f (Node3 v a b c) = Node3 v (f a) (f b) (f c)
757
758 instance Traversable Node where
759 {-# INLINE traverse #-}
760 traverse f (Node2 v a b) = Node2 v <$> f a <*> f b
761 traverse f (Node3 v a b c) = Node3 v <$> f a <*> f b <*> f c
762
763 instance NFData a => NFData (Node a) where
764 rnf (Node2 _ a b) = rnf a `seq` rnf b
765 rnf (Node3 _ a b c) = rnf a `seq` rnf b `seq` rnf c
766
767 instance Sized (Node a) where
768 size (Node2 v _ _) = v
769 size (Node3 v _ _ _) = v
770
771 {-# INLINE node2 #-}
772 node2 :: Sized a => a -> a -> Node a
773 node2 a b = Node2 (size a + size b) a b
774
775 {-# INLINE node3 #-}
776 node3 :: Sized a => a -> a -> a -> Node a
777 node3 a b c = Node3 (size a + size b + size c) a b c
778
779 nodeToDigit :: Node a -> Digit a
780 nodeToDigit (Node2 _ a b) = Two a b
781 nodeToDigit (Node3 _ a b c) = Three a b c
782
783 -- Elements
784
785 newtype Elem a = Elem { getElem :: a }
786 #if TESTING
787 deriving Show
788 #endif
789
790 instance Sized (Elem a) where
791 size _ = 1
792
793 instance Functor Elem where
794 #if __GLASGOW_HASKELL__ >= 708
795 -- This cuts the time for <*> by around a fifth.
796 fmap = coerce
797 #else
798 fmap f (Elem x) = Elem (f x)
799 #endif
800
801 instance Foldable Elem where
802 foldMap f (Elem x) = f x
803 foldr f z (Elem x) = f x z
804 foldl f z (Elem x) = f z x
805
806 instance Traversable Elem where
807 traverse f (Elem x) = Elem <$> f x
808
809 instance NFData a => NFData (Elem a) where
810 rnf (Elem x) = rnf x
811
812 -------------------------------------------------------
813 -- Applicative construction
814 -------------------------------------------------------
815 #if !MIN_VERSION_base(4,8,0)
816 newtype Identity a = Identity {runIdentity :: a}
817
818 instance Functor Identity where
819 fmap f (Identity x) = Identity (f x)
820
821 instance Applicative Identity where
822 pure = Identity
823 Identity f <*> Identity x = Identity (f x)
824 #endif
825
826 -- | This is essentially a clone of Control.Monad.State.Strict.
827 newtype State s a = State {runState :: s -> (s, a)}
828
829 instance Functor (State s) where
830 fmap = liftA
831
832 instance Monad (State s) where
833 {-# INLINE return #-}
834 {-# INLINE (>>=) #-}
835 return x = State $ \ s -> (s, x)
836 m >>= k = State $ \ s -> case runState m s of
837 (s', x) -> runState (k x) s'
838
839 instance Applicative (State s) where
840 pure = return
841 (<*>) = ap
842
843 execState :: State s a -> s -> a
844 execState m x = snd (runState m x)
845
846 -- | 'applicativeTree' takes an Applicative-wrapped construction of a
847 -- piece of a FingerTree, assumed to always have the same size (which
848 -- is put in the second argument), and replicates it as many times as
849 -- specified. This is a generalization of 'replicateA', which itself
850 -- is a generalization of many Data.Sequence methods.
851 {-# SPECIALIZE applicativeTree :: Int -> Int -> State s a -> State s (FingerTree a) #-}
852 {-# SPECIALIZE applicativeTree :: Int -> Int -> Identity a -> Identity (FingerTree a) #-}
853 -- Special note: the Identity specialization automatically does node sharing,
854 -- reducing memory usage of the resulting tree to /O(log n)/.
855 applicativeTree :: Applicative f => Int -> Int -> f a -> f (FingerTree a)
856 applicativeTree n mSize m = mSize `seq` case n of
857 0 -> pure Empty
858 1 -> fmap Single m
859 2 -> deepA one emptyTree one
860 3 -> deepA two emptyTree one
861 4 -> deepA two emptyTree two
862 5 -> deepA three emptyTree two
863 6 -> deepA three emptyTree three
864 _ -> case n `quotRem` 3 of
865 (q,0) -> deepA three (applicativeTree (q - 2) mSize' n3) three
866 (q,1) -> deepA two (applicativeTree (q - 1) mSize' n3) two
867 (q,_) -> deepA three (applicativeTree (q - 1) mSize' n3) two
868 where
869 one = fmap One m
870 two = liftA2 Two m m
871 three = liftA3 Three m m m
872 deepA = liftA3 (Deep (n * mSize))
873 mSize' = 3 * mSize
874 n3 = liftA3 (Node3 mSize') m m m
875 emptyTree = pure Empty
876
877 ------------------------------------------------------------------------
878 -- Construction
879 ------------------------------------------------------------------------
880
881 -- | /O(1)/. The empty sequence.
882 empty :: Seq a
883 empty = Seq Empty
884
885 -- | /O(1)/. A singleton sequence.
886 singleton :: a -> Seq a
887 singleton x = Seq (Single (Elem x))
888
889 -- | /O(log n)/. @replicate n x@ is a sequence consisting of @n@ copies of @x@.
890 replicate :: Int -> a -> Seq a
891 replicate n x
892 | n >= 0 = runIdentity (replicateA n (Identity x))
893 | otherwise = error "replicate takes a nonnegative integer argument"
894
895 -- | 'replicateA' is an 'Applicative' version of 'replicate', and makes
896 -- /O(log n)/ calls to '<*>' and 'pure'.
897 --
898 -- > replicateA n x = sequenceA (replicate n x)
899 replicateA :: Applicative f => Int -> f a -> f (Seq a)
900 replicateA n x
901 | n >= 0 = Seq <$> applicativeTree n 1 (Elem <$> x)
902 | otherwise = error "replicateA takes a nonnegative integer argument"
903
904 -- | 'replicateM' is a sequence counterpart of 'Control.Monad.replicateM'.
905 --
906 -- > replicateM n x = sequence (replicate n x)
907 replicateM :: Monad m => Int -> m a -> m (Seq a)
908 replicateM n x
909 | n >= 0 = unwrapMonad (replicateA n (WrapMonad x))
910 | otherwise = error "replicateM takes a nonnegative integer argument"
911
912 -- | @'replicateSeq' n xs@ concatenates @n@ copies of @xs@.
913 replicateSeq :: Int -> Seq a -> Seq a
914 replicateSeq n s
915 | n < 0 = error "replicateSeq takes a nonnegative integer argument"
916 | n == 0 = empty
917 | otherwise = go n s
918 where
919 -- Invariant: k >= 1
920 go 1 xs = xs
921 go k xs | even k = kxs
922 | otherwise = xs >< kxs
923 where kxs = go (k `quot` 2) $! (xs >< xs)
924
925 -- | /O(1)/. Add an element to the left end of a sequence.
926 -- Mnemonic: a triangle with the single element at the pointy end.
927 (<|) :: a -> Seq a -> Seq a
928 x <| Seq xs = Seq (Elem x `consTree` xs)
929
930 {-# SPECIALIZE consTree :: Elem a -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
931 {-# SPECIALIZE consTree :: Node a -> FingerTree (Node a) -> FingerTree (Node a) #-}
932 consTree :: Sized a => a -> FingerTree a -> FingerTree a
933 consTree a Empty = Single a
934 consTree a (Single b) = deep (One a) Empty (One b)
935 consTree a (Deep s (Four b c d e) m sf) = m `seq`
936 Deep (size a + s) (Two a b) (node3 c d e `consTree` m) sf
937 consTree a (Deep s (Three b c d) m sf) =
938 Deep (size a + s) (Four a b c d) m sf
939 consTree a (Deep s (Two b c) m sf) =
940 Deep (size a + s) (Three a b c) m sf
941 consTree a (Deep s (One b) m sf) =
942 Deep (size a + s) (Two a b) m sf
943
944 -- | /O(1)/. Add an element to the right end of a sequence.
945 -- Mnemonic: a triangle with the single element at the pointy end.
946 (|>) :: Seq a -> a -> Seq a
947 Seq xs |> x = Seq (xs `snocTree` Elem x)
948
949 {-# SPECIALIZE snocTree :: FingerTree (Elem a) -> Elem a -> FingerTree (Elem a) #-}
950 {-# SPECIALIZE snocTree :: FingerTree (Node a) -> Node a -> FingerTree (Node a) #-}
951 snocTree :: Sized a => FingerTree a -> a -> FingerTree a
952 snocTree Empty a = Single a
953 snocTree (Single a) b = deep (One a) Empty (One b)
954 snocTree (Deep s pr m (Four a b c d)) e = m `seq`
955 Deep (s + size e) pr (m `snocTree` node3 a b c) (Two d e)
956 snocTree (Deep s pr m (Three a b c)) d =
957 Deep (s + size d) pr m (Four a b c d)
958 snocTree (Deep s pr m (Two a b)) c =
959 Deep (s + size c) pr m (Three a b c)
960 snocTree (Deep s pr m (One a)) b =
961 Deep (s + size b) pr m (Two a b)
962
963 -- | /O(log(min(n1,n2)))/. Concatenate two sequences.
964 (><) :: Seq a -> Seq a -> Seq a
965 Seq xs >< Seq ys = Seq (appendTree0 xs ys)
966
967 -- The appendTree/addDigits gunk below is machine generated
968
969 {-# SPECIALIZE appendTree0 :: FingerTree (Elem a) -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
970 {-# SPECIALIZE appendTree0 :: FingerTree (Node a) -> FingerTree (Node a) -> FingerTree (Node a) #-}
971 appendTree0 :: Sized a => FingerTree a -> FingerTree a -> FingerTree a
972 appendTree0 Empty xs =
973 xs
974 appendTree0 xs Empty =
975 xs
976 appendTree0 (Single x) xs =
977 x `consTree` xs
978 appendTree0 xs (Single x) =
979 xs `snocTree` x
980 appendTree0 (Deep s1 pr1 m1 sf1) (Deep s2 pr2 m2 sf2) =
981 Deep (s1 + s2) pr1 (addDigits0 m1 sf1 pr2 m2) sf2
982
983 {-# SPECIALIZE addDigits0 :: FingerTree (Node (Elem a)) -> Digit (Elem a) -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> FingerTree (Node (Elem a)) #-}
984 {-# SPECIALIZE addDigits0 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a)) #-}
985 addDigits0 :: Sized a => FingerTree (Node a) -> Digit a -> Digit a -> FingerTree (Node a) -> FingerTree (Node a)
986 addDigits0 m1 (One a) (One b) m2 =
987 appendTree1 m1 (node2 a b) m2
988 addDigits0 m1 (One a) (Two b c) m2 =
989 appendTree1 m1 (node3 a b c) m2
990 addDigits0 m1 (One a) (Three b c d) m2 =
991 appendTree2 m1 (node2 a b) (node2 c d) m2
992 addDigits0 m1 (One a) (Four b c d e) m2 =
993 appendTree2 m1 (node3 a b c) (node2 d e) m2
994 addDigits0 m1 (Two a b) (One c) m2 =
995 appendTree1 m1 (node3 a b c) m2
996 addDigits0 m1 (Two a b) (Two c d) m2 =
997 appendTree2 m1 (node2 a b) (node2 c d) m2
998 addDigits0 m1 (Two a b) (Three c d e) m2 =
999 appendTree2 m1 (node3 a b c) (node2 d e) m2
1000 addDigits0 m1 (Two a b) (Four c d e f) m2 =
1001 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1002 addDigits0 m1 (Three a b c) (One d) m2 =
1003 appendTree2 m1 (node2 a b) (node2 c d) m2
1004 addDigits0 m1 (Three a b c) (Two d e) m2 =
1005 appendTree2 m1 (node3 a b c) (node2 d e) m2
1006 addDigits0 m1 (Three a b c) (Three d e f) m2 =
1007 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1008 addDigits0 m1 (Three a b c) (Four d e f g) m2 =
1009 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1010 addDigits0 m1 (Four a b c d) (One e) m2 =
1011 appendTree2 m1 (node3 a b c) (node2 d e) m2
1012 addDigits0 m1 (Four a b c d) (Two e f) m2 =
1013 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1014 addDigits0 m1 (Four a b c d) (Three e f g) m2 =
1015 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1016 addDigits0 m1 (Four a b c d) (Four e f g h) m2 =
1017 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1018
1019 appendTree1 :: FingerTree (Node a) -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
1020 appendTree1 Empty a xs =
1021 a `consTree` xs
1022 appendTree1 xs a Empty =
1023 xs `snocTree` a
1024 appendTree1 (Single x) a xs =
1025 x `consTree` a `consTree` xs
1026 appendTree1 xs a (Single x) =
1027 xs `snocTree` a `snocTree` x
1028 appendTree1 (Deep s1 pr1 m1 sf1) a (Deep s2 pr2 m2 sf2) =
1029 Deep (s1 + size a + s2) pr1 (addDigits1 m1 sf1 a pr2 m2) sf2
1030
1031 addDigits1 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
1032 addDigits1 m1 (One a) b (One c) m2 =
1033 appendTree1 m1 (node3 a b c) m2
1034 addDigits1 m1 (One a) b (Two c d) m2 =
1035 appendTree2 m1 (node2 a b) (node2 c d) m2
1036 addDigits1 m1 (One a) b (Three c d e) m2 =
1037 appendTree2 m1 (node3 a b c) (node2 d e) m2
1038 addDigits1 m1 (One a) b (Four c d e f) m2 =
1039 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1040 addDigits1 m1 (Two a b) c (One d) m2 =
1041 appendTree2 m1 (node2 a b) (node2 c d) m2
1042 addDigits1 m1 (Two a b) c (Two d e) m2 =
1043 appendTree2 m1 (node3 a b c) (node2 d e) m2
1044 addDigits1 m1 (Two a b) c (Three d e f) m2 =
1045 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1046 addDigits1 m1 (Two a b) c (Four d e f g) m2 =
1047 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1048 addDigits1 m1 (Three a b c) d (One e) m2 =
1049 appendTree2 m1 (node3 a b c) (node2 d e) m2
1050 addDigits1 m1 (Three a b c) d (Two e f) m2 =
1051 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1052 addDigits1 m1 (Three a b c) d (Three e f g) m2 =
1053 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1054 addDigits1 m1 (Three a b c) d (Four e f g h) m2 =
1055 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1056 addDigits1 m1 (Four a b c d) e (One f) m2 =
1057 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1058 addDigits1 m1 (Four a b c d) e (Two f g) m2 =
1059 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1060 addDigits1 m1 (Four a b c d) e (Three f g h) m2 =
1061 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1062 addDigits1 m1 (Four a b c d) e (Four f g h i) m2 =
1063 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
1064
1065 appendTree2 :: FingerTree (Node a) -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
1066 appendTree2 Empty a b xs =
1067 a `consTree` b `consTree` xs
1068 appendTree2 xs a b Empty =
1069 xs `snocTree` a `snocTree` b
1070 appendTree2 (Single x) a b xs =
1071 x `consTree` a `consTree` b `consTree` xs
1072 appendTree2 xs a b (Single x) =
1073 xs `snocTree` a `snocTree` b `snocTree` x
1074 appendTree2 (Deep s1 pr1 m1 sf1) a b (Deep s2 pr2 m2 sf2) =
1075 Deep (s1 + size a + size b + s2) pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2
1076
1077 addDigits2 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
1078 addDigits2 m1 (One a) b c (One d) m2 =
1079 appendTree2 m1 (node2 a b) (node2 c d) m2
1080 addDigits2 m1 (One a) b c (Two d e) m2 =
1081 appendTree2 m1 (node3 a b c) (node2 d e) m2
1082 addDigits2 m1 (One a) b c (Three d e f) m2 =
1083 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1084 addDigits2 m1 (One a) b c (Four d e f g) m2 =
1085 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1086 addDigits2 m1 (Two a b) c d (One e) m2 =
1087 appendTree2 m1 (node3 a b c) (node2 d e) m2
1088 addDigits2 m1 (Two a b) c d (Two e f) m2 =
1089 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1090 addDigits2 m1 (Two a b) c d (Three e f g) m2 =
1091 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1092 addDigits2 m1 (Two a b) c d (Four e f g h) m2 =
1093 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1094 addDigits2 m1 (Three a b c) d e (One f) m2 =
1095 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1096 addDigits2 m1 (Three a b c) d e (Two f g) m2 =
1097 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1098 addDigits2 m1 (Three a b c) d e (Three f g h) m2 =
1099 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1100 addDigits2 m1 (Three a b c) d e (Four f g h i) m2 =
1101 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
1102 addDigits2 m1 (Four a b c d) e f (One g) m2 =
1103 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1104 addDigits2 m1 (Four a b c d) e f (Two g h) m2 =
1105 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1106 addDigits2 m1 (Four a b c d) e f (Three g h i) m2 =
1107 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
1108 addDigits2 m1 (Four a b c d) e f (Four g h i j) m2 =
1109 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
1110
1111 appendTree3 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
1112 appendTree3 Empty a b c xs =
1113 a `consTree` b `consTree` c `consTree` xs
1114 appendTree3 xs a b c Empty =
1115 xs `snocTree` a `snocTree` b `snocTree` c
1116 appendTree3 (Single x) a b c xs =
1117 x `consTree` a `consTree` b `consTree` c `consTree` xs
1118 appendTree3 xs a b c (Single x) =
1119 xs `snocTree` a `snocTree` b `snocTree` c `snocTree` x
1120 appendTree3 (Deep s1 pr1 m1 sf1) a b c (Deep s2 pr2 m2 sf2) =
1121 Deep (s1 + size a + size b + size c + s2) pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2
1122
1123 addDigits3 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
1124 addDigits3 m1 (One a) b c d (One e) m2 =
1125 appendTree2 m1 (node3 a b c) (node2 d e) m2
1126 addDigits3 m1 (One a) b c d (Two e f) m2 =
1127 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1128 addDigits3 m1 (One a) b c d (Three e f g) m2 =
1129 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1130 addDigits3 m1 (One a) b c d (Four e f g h) m2 =
1131 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1132 addDigits3 m1 (Two a b) c d e (One f) m2 =
1133 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1134 addDigits3 m1 (Two a b) c d e (Two f g) m2 =
1135 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1136 addDigits3 m1 (Two a b) c d e (Three f g h) m2 =
1137 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1138 addDigits3 m1 (Two a b) c d e (Four f g h i) m2 =
1139 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
1140 addDigits3 m1 (Three a b c) d e f (One g) m2 =
1141 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1142 addDigits3 m1 (Three a b c) d e f (Two g h) m2 =
1143 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1144 addDigits3 m1 (Three a b c) d e f (Three g h i) m2 =
1145 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
1146 addDigits3 m1 (Three a b c) d e f (Four g h i j) m2 =
1147 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
1148 addDigits3 m1 (Four a b c d) e f g (One h) m2 =
1149 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1150 addDigits3 m1 (Four a b c d) e f g (Two h i) m2 =
1151 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
1152 addDigits3 m1 (Four a b c d) e f g (Three h i j) m2 =
1153 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
1154 addDigits3 m1 (Four a b c d) e f g (Four h i j k) m2 =
1155 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
1156
1157 appendTree4 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
1158 appendTree4 Empty a b c d xs =
1159 a `consTree` b `consTree` c `consTree` d `consTree` xs
1160 appendTree4 xs a b c d Empty =
1161 xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d
1162 appendTree4 (Single x) a b c d xs =
1163 x `consTree` a `consTree` b `consTree` c `consTree` d `consTree` xs
1164 appendTree4 xs a b c d (Single x) =
1165 xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d `snocTree` x
1166 appendTree4 (Deep s1 pr1 m1 sf1) a b c d (Deep s2 pr2 m2 sf2) =
1167 Deep (s1 + size a + size b + size c + size d + s2) pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2
1168
1169 addDigits4 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
1170 addDigits4 m1 (One a) b c d e (One f) m2 =
1171 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1172 addDigits4 m1 (One a) b c d e (Two f g) m2 =
1173 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1174 addDigits4 m1 (One a) b c d e (Three f g h) m2 =
1175 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1176 addDigits4 m1 (One a) b c d e (Four f g h i) m2 =
1177 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
1178 addDigits4 m1 (Two a b) c d e f (One g) m2 =
1179 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1180 addDigits4 m1 (Two a b) c d e f (Two g h) m2 =
1181 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1182 addDigits4 m1 (Two a b) c d e f (Three g h i) m2 =
1183 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
1184 addDigits4 m1 (Two a b) c d e f (Four g h i j) m2 =
1185 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
1186 addDigits4 m1 (Three a b c) d e f g (One h) m2 =
1187 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1188 addDigits4 m1 (Three a b c) d e f g (Two h i) m2 =
1189 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
1190 addDigits4 m1 (Three a b c) d e f g (Three h i j) m2 =
1191 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
1192 addDigits4 m1 (Three a b c) d e f g (Four h i j k) m2 =
1193 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
1194 addDigits4 m1 (Four a b c d) e f g h (One i) m2 =
1195 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
1196 addDigits4 m1 (Four a b c d) e f g h (Two i j) m2 =
1197 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
1198 addDigits4 m1 (Four a b c d) e f g h (Three i j k) m2 =
1199 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
1200 addDigits4 m1 (Four a b c d) e f g h (Four i j k l) m2 =
1201 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2
1202
1203 -- | Builds a sequence from a seed value. Takes time linear in the
1204 -- number of generated elements. /WARNING:/ If the number of generated
1205 -- elements is infinite, this method will not terminate.
1206 unfoldr :: (b -> Maybe (a, b)) -> b -> Seq a
1207 unfoldr f = unfoldr' empty
1208 -- uses tail recursion rather than, for instance, the List implementation.
1209 where unfoldr' as b = maybe as (\ (a, b') -> unfoldr' (as |> a) b') (f b)
1210
1211 -- | @'unfoldl' f x@ is equivalent to @'reverse' ('unfoldr' ('fmap' swap . f) x)@.
1212 unfoldl :: (b -> Maybe (b, a)) -> b -> Seq a
1213 unfoldl f = unfoldl' empty
1214 where unfoldl' as b = maybe as (\ (b', a) -> unfoldl' (a <| as) b') (f b)
1215
1216 -- | /O(n)/. Constructs a sequence by repeated application of a function
1217 -- to a seed value.
1218 --
1219 -- > iterateN n f x = fromList (Prelude.take n (Prelude.iterate f x))
1220 iterateN :: Int -> (a -> a) -> a -> Seq a
1221 iterateN n f x
1222 | n >= 0 = replicateA n (State (\ y -> (f y, y))) `execState` x
1223 | otherwise = error "iterateN takes a nonnegative integer argument"
1224
1225 ------------------------------------------------------------------------
1226 -- Deconstruction
1227 ------------------------------------------------------------------------
1228
1229 -- | /O(1)/. Is this the empty sequence?
1230 null :: Seq a -> Bool
1231 null (Seq Empty) = True
1232 null _ = False
1233
1234 -- | /O(1)/. The number of elements in the sequence.
1235 length :: Seq a -> Int
1236 length (Seq xs) = size xs
1237
1238 -- Views
1239
1240 data Maybe2 a b = Nothing2 | Just2 a b
1241
1242 -- | View of the left end of a sequence.
1243 data ViewL a
1244 = EmptyL -- ^ empty sequence
1245 | a :< Seq a -- ^ leftmost element and the rest of the sequence
1246 #if __GLASGOW_HASKELL__
1247 deriving (Eq, Ord, Show, Read, Data)
1248 #else
1249 deriving (Eq, Ord, Show, Read)
1250 #endif
1251
1252 INSTANCE_TYPEABLE1(ViewL,viewLTc,"ViewL")
1253
1254 instance Functor ViewL where
1255 {-# INLINE fmap #-}
1256 fmap _ EmptyL = EmptyL
1257 fmap f (x :< xs) = f x :< fmap f xs
1258
1259 instance Foldable ViewL where
1260 foldr _ z EmptyL = z
1261 foldr f z (x :< xs) = f x (foldr f z xs)
1262
1263 foldl _ z EmptyL = z
1264 foldl f z (x :< xs) = foldl f (f z x) xs
1265
1266 foldl1 _ EmptyL = error "foldl1: empty view"
1267 foldl1 f (x :< xs) = foldl f x xs
1268
1269 instance Traversable ViewL where
1270 traverse _ EmptyL = pure EmptyL
1271 traverse f (x :< xs) = (:<) <$> f x <*> traverse f xs
1272
1273 -- | /O(1)/. Analyse the left end of a sequence.
1274 viewl :: Seq a -> ViewL a
1275 viewl (Seq xs) = case viewLTree xs of
1276 Nothing2 -> EmptyL
1277 Just2 (Elem x) xs' -> x :< Seq xs'
1278
1279 {-# SPECIALIZE viewLTree :: FingerTree (Elem a) -> Maybe2 (Elem a) (FingerTree (Elem a)) #-}
1280 {-# SPECIALIZE viewLTree :: FingerTree (Node a) -> Maybe2 (Node a) (FingerTree (Node a)) #-}
1281 viewLTree :: Sized a => FingerTree a -> Maybe2 a (FingerTree a)
1282 viewLTree Empty = Nothing2
1283 viewLTree (Single a) = Just2 a Empty
1284 viewLTree (Deep s (One a) m sf) = Just2 a (pullL (s - size a) m sf)
1285 viewLTree (Deep s (Two a b) m sf) =
1286 Just2 a (Deep (s - size a) (One b) m sf)
1287 viewLTree (Deep s (Three a b c) m sf) =
1288 Just2 a (Deep (s - size a) (Two b c) m sf)
1289 viewLTree (Deep s (Four a b c d) m sf) =
1290 Just2 a (Deep (s - size a) (Three b c d) m sf)
1291
1292 -- | View of the right end of a sequence.
1293 data ViewR a
1294 = EmptyR -- ^ empty sequence
1295 | Seq a :> a -- ^ the sequence minus the rightmost element,
1296 -- and the rightmost element
1297 #if __GLASGOW_HASKELL__
1298 deriving (Eq, Ord, Show, Read, Data)
1299 #else
1300 deriving (Eq, Ord, Show, Read)
1301 #endif
1302
1303 INSTANCE_TYPEABLE1(ViewR,viewRTc,"ViewR")
1304
1305 instance Functor ViewR where
1306 {-# INLINE fmap #-}
1307 fmap _ EmptyR = EmptyR
1308 fmap f (xs :> x) = fmap f xs :> f x
1309
1310 instance Foldable ViewR where
1311 foldMap _ EmptyR = mempty
1312 foldMap f (xs :> x) = foldMap f xs `mappend` f x
1313
1314 foldr _ z EmptyR = z
1315 foldr f z (xs :> x) = foldr f (f x z) xs
1316
1317 foldl _ z EmptyR = z
1318 foldl f z (xs :> x) = foldl f z xs `f` x
1319
1320 foldr1 _ EmptyR = error "foldr1: empty view"
1321 foldr1 f (xs :> x) = foldr f x xs
1322 #if MIN_VERSION_base(4,8,0)
1323 -- The default definitions are sensible for ViewL, but not so much for
1324 -- ViewR.
1325 null EmptyR = True
1326 null (_ :> _) = False
1327
1328 length = foldr' (\_ k -> k+1) 0
1329 #endif
1330
1331 instance Traversable ViewR where
1332 traverse _ EmptyR = pure EmptyR
1333 traverse f (xs :> x) = (:>) <$> traverse f xs <*> f x
1334
1335 -- | /O(1)/. Analyse the right end of a sequence.
1336 viewr :: Seq a -> ViewR a
1337 viewr (Seq xs) = case viewRTree xs of
1338 Nothing2 -> EmptyR
1339 Just2 xs' (Elem x) -> Seq xs' :> x
1340
1341 {-# SPECIALIZE viewRTree :: FingerTree (Elem a) -> Maybe2 (FingerTree (Elem a)) (Elem a) #-}
1342 {-# SPECIALIZE viewRTree :: FingerTree (Node a) -> Maybe2 (FingerTree (Node a)) (Node a) #-}
1343 viewRTree :: Sized a => FingerTree a -> Maybe2 (FingerTree a) a
1344 viewRTree Empty = Nothing2
1345 viewRTree (Single z) = Just2 Empty z
1346 viewRTree (Deep s pr m (One z)) = Just2 (pullR (s - size z) pr m) z
1347 viewRTree (Deep s pr m (Two y z)) =
1348 Just2 (Deep (s - size z) pr m (One y)) z
1349 viewRTree (Deep s pr m (Three x y z)) =
1350 Just2 (Deep (s - size z) pr m (Two x y)) z
1351 viewRTree (Deep s pr m (Four w x y z)) =
1352 Just2 (Deep (s - size z) pr m (Three w x y)) z
1353
1354 ------------------------------------------------------------------------
1355 -- Scans
1356 --
1357 -- These are not particularly complex applications of the Traversable
1358 -- functor, though making the correspondence with Data.List exact
1359 -- requires the use of (<|) and (|>).
1360 --
1361 -- Note that save for the single (<|) or (|>), we maintain the original
1362 -- structure of the Seq, not having to do any restructuring of our own.
1363 --
1364 -- wasserman.louis@gmail.com, 5/23/09
1365 ------------------------------------------------------------------------
1366
1367 -- | 'scanl' is similar to 'foldl', but returns a sequence of reduced
1368 -- values from the left:
1369 --
1370 -- > scanl f z (fromList [x1, x2, ...]) = fromList [z, z `f` x1, (z `f` x1) `f` x2, ...]
1371 scanl :: (a -> b -> a) -> a -> Seq b -> Seq a
1372 scanl f z0 xs = z0 <| snd (mapAccumL (\ x z -> let x' = f x z in (x', x')) z0 xs)
1373
1374 -- | 'scanl1' is a variant of 'scanl' that has no starting value argument:
1375 --
1376 -- > scanl1 f (fromList [x1, x2, ...]) = fromList [x1, x1 `f` x2, ...]
1377 scanl1 :: (a -> a -> a) -> Seq a -> Seq a
1378 scanl1 f xs = case viewl xs of
1379 EmptyL -> error "scanl1 takes a nonempty sequence as an argument"
1380 x :< xs' -> scanl f x xs'
1381
1382 -- | 'scanr' is the right-to-left dual of 'scanl'.
1383 scanr :: (a -> b -> b) -> b -> Seq a -> Seq b
1384 scanr f z0 xs = snd (mapAccumR (\ z x -> let z' = f x z in (z', z')) z0 xs) |> z0
1385
1386 -- | 'scanr1' is a variant of 'scanr' that has no starting value argument.
1387 scanr1 :: (a -> a -> a) -> Seq a -> Seq a
1388 scanr1 f xs = case viewr xs of
1389 EmptyR -> error "scanr1 takes a nonempty sequence as an argument"
1390 xs' :> x -> scanr f x xs'
1391
1392 -- Indexing
1393
1394 -- | /O(log(min(i,n-i)))/. The element at the specified position,
1395 -- counting from 0. The argument should thus be a non-negative
1396 -- integer less than the size of the sequence.
1397 -- If the position is out of range, 'index' fails with an error.
1398 index :: Seq a -> Int -> a
1399 index (Seq xs) i
1400 | 0 <= i && i < size xs = case lookupTree i xs of
1401 Place _ (Elem x) -> x
1402 | otherwise = error "index out of bounds"
1403
1404 data Place a = Place {-# UNPACK #-} !Int a
1405 #if TESTING
1406 deriving Show
1407 #endif
1408
1409 {-# SPECIALIZE lookupTree :: Int -> FingerTree (Elem a) -> Place (Elem a) #-}
1410 {-# SPECIALIZE lookupTree :: Int -> FingerTree (Node a) -> Place (Node a) #-}
1411 lookupTree :: Sized a => Int -> FingerTree a -> Place a
1412 lookupTree _ Empty = error "lookupTree of empty tree"
1413 lookupTree i (Single x) = Place i x
1414 lookupTree i (Deep totalSize pr m sf)
1415 | i < spr = lookupDigit i pr
1416 | i < spm = case lookupTree (i - spr) m of
1417 Place i' xs -> lookupNode i' xs
1418 | otherwise = lookupDigit (i - spm) sf
1419 where
1420 spr = size pr
1421 spm = totalSize - size sf
1422
1423 {-# SPECIALIZE lookupNode :: Int -> Node (Elem a) -> Place (Elem a) #-}
1424 {-# SPECIALIZE lookupNode :: Int -> Node (Node a) -> Place (Node a) #-}
1425 lookupNode :: Sized a => Int -> Node a -> Place a
1426 lookupNode i (Node2 _ a b)
1427 | i < sa = Place i a
1428 | otherwise = Place (i - sa) b
1429 where
1430 sa = size a
1431 lookupNode i (Node3 _ a b c)
1432 | i < sa = Place i a
1433 | i < sab = Place (i - sa) b
1434 | otherwise = Place (i - sab) c
1435 where
1436 sa = size a
1437 sab = sa + size b
1438
1439 {-# SPECIALIZE lookupDigit :: Int -> Digit (Elem a) -> Place (Elem a) #-}
1440 {-# SPECIALIZE lookupDigit :: Int -> Digit (Node a) -> Place (Node a) #-}
1441 lookupDigit :: Sized a => Int -> Digit a -> Place a
1442 lookupDigit i (One a) = Place i a
1443 lookupDigit i (Two a b)
1444 | i < sa = Place i a
1445 | otherwise = Place (i - sa) b
1446 where
1447 sa = size a
1448 lookupDigit i (Three a b c)
1449 | i < sa = Place i a
1450 | i < sab = Place (i - sa) b
1451 | otherwise = Place (i - sab) c
1452 where
1453 sa = size a
1454 sab = sa + size b
1455 lookupDigit i (Four a b c d)
1456 | i < sa = Place i a
1457 | i < sab = Place (i - sa) b
1458 | i < sabc = Place (i - sab) c
1459 | otherwise = Place (i - sabc) d
1460 where
1461 sa = size a
1462 sab = sa + size b
1463 sabc = sab + size c
1464
1465 -- | /O(log(min(i,n-i)))/. Replace the element at the specified position.
1466 -- If the position is out of range, the original sequence is returned.
1467 update :: Int -> a -> Seq a -> Seq a
1468 update i x = adjust (const x) i
1469
1470 -- | /O(log(min(i,n-i)))/. Update the element at the specified position.
1471 -- If the position is out of range, the original sequence is returned.
1472 adjust :: (a -> a) -> Int -> Seq a -> Seq a
1473 adjust f i (Seq xs)
1474 | 0 <= i && i < size xs = Seq (adjustTree (const (fmap f)) i xs)
1475 | otherwise = Seq xs
1476
1477 {-# SPECIALIZE adjustTree :: (Int -> Elem a -> Elem a) -> Int -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
1478 {-# SPECIALIZE adjustTree :: (Int -> Node a -> Node a) -> Int -> FingerTree (Node a) -> FingerTree (Node a) #-}
1479 adjustTree :: Sized a => (Int -> a -> a) ->
1480 Int -> FingerTree a -> FingerTree a
1481 adjustTree _ _ Empty = error "adjustTree of empty tree"
1482 adjustTree f i (Single x) = Single (f i x)
1483 adjustTree f i (Deep s pr m sf)
1484 | i < spr = Deep s (adjustDigit f i pr) m sf
1485 | i < spm = Deep s pr (adjustTree (adjustNode f) (i - spr) m) sf
1486 | otherwise = Deep s pr m (adjustDigit f (i - spm) sf)
1487 where
1488 spr = size pr
1489 spm = spr + size m
1490
1491 {-# SPECIALIZE adjustNode :: (Int -> Elem a -> Elem a) -> Int -> Node (Elem a) -> Node (Elem a) #-}
1492 {-# SPECIALIZE adjustNode :: (Int -> Node a -> Node a) -> Int -> Node (Node a) -> Node (Node a) #-}
1493 adjustNode :: Sized a => (Int -> a -> a) -> Int -> Node a -> Node a
1494 adjustNode f i (Node2 s a b)
1495 | i < sa = Node2 s (f i a) b
1496 | otherwise = Node2 s a (f (i - sa) b)
1497 where
1498 sa = size a
1499 adjustNode f i (Node3 s a b c)
1500 | i < sa = Node3 s (f i a) b c
1501 | i < sab = Node3 s a (f (i - sa) b) c
1502 | otherwise = Node3 s a b (f (i - sab) c)
1503 where
1504 sa = size a
1505 sab = sa + size b
1506
1507 {-# SPECIALIZE adjustDigit :: (Int -> Elem a -> Elem a) -> Int -> Digit (Elem a) -> Digit (Elem a) #-}
1508 {-# SPECIALIZE adjustDigit :: (Int -> Node a -> Node a) -> Int -> Digit (Node a) -> Digit (Node a) #-}
1509 adjustDigit :: Sized a => (Int -> a -> a) -> Int -> Digit a -> Digit a
1510 adjustDigit f i (One a) = One (f i a)
1511 adjustDigit f i (Two a b)
1512 | i < sa = Two (f i a) b
1513 | otherwise = Two a (f (i - sa) b)
1514 where
1515 sa = size a
1516 adjustDigit f i (Three a b c)
1517 | i < sa = Three (f i a) b c
1518 | i < sab = Three a (f (i - sa) b) c
1519 | otherwise = Three a b (f (i - sab) c)
1520 where
1521 sa = size a
1522 sab = sa + size b
1523 adjustDigit f i (Four a b c d)
1524 | i < sa = Four (f i a) b c d
1525 | i < sab = Four a (f (i - sa) b) c d
1526 | i < sabc = Four a b (f (i - sab) c) d
1527 | otherwise = Four a b c (f (i- sabc) d)
1528 where
1529 sa = size a
1530 sab = sa + size b
1531 sabc = sab + size c
1532
1533 -- | /O(n)/. A generalization of 'fmap', 'mapWithIndex' takes a mapping
1534 -- function that also depends on the element's index, and applies it to every
1535 -- element in the sequence.
1536 mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b
1537 mapWithIndex f' (Seq xs') = Seq $ mapWithIndexTree (\s (Elem a) -> Elem (f' s a)) 0 xs'
1538 where
1539 {-# SPECIALIZE mapWithIndexTree :: (Int -> Elem y -> b) -> Int -> FingerTree (Elem y) -> FingerTree b #-}
1540 {-# SPECIALIZE mapWithIndexTree :: (Int -> Node y -> b) -> Int -> FingerTree (Node y) -> FingerTree b #-}
1541 mapWithIndexTree :: Sized a => (Int -> a -> b) -> Int -> FingerTree a -> FingerTree b
1542 mapWithIndexTree _ s Empty = s `seq` Empty
1543 mapWithIndexTree f s (Single xs) = Single $ f s xs
1544 mapWithIndexTree f s (Deep n pr m sf) = sPspr `seq` sPsprm `seq`
1545 Deep n
1546 (mapWithIndexDigit f s pr)
1547 (mapWithIndexTree (mapWithIndexNode f) sPspr m)
1548 (mapWithIndexDigit f sPsprm sf)
1549 where
1550 sPspr = s + size pr
1551 sPsprm = s + n - size sf
1552
1553 {-# SPECIALIZE mapWithIndexDigit :: (Int -> Elem y -> b) -> Int -> Digit (Elem y) -> Digit b #-}
1554 {-# SPECIALIZE mapWithIndexDigit :: (Int -> Node y -> b) -> Int -> Digit (Node y) -> Digit b #-}
1555 mapWithIndexDigit :: Sized a => (Int -> a -> b) -> Int -> Digit a -> Digit b
1556 mapWithIndexDigit f s (One a) = One (f s a)
1557 mapWithIndexDigit f s (Two a b) = sPsa `seq` Two (f s a) (f sPsa b)
1558 where
1559 sPsa = s + size a
1560 mapWithIndexDigit f s (Three a b c) = sPsa `seq` sPsab `seq`
1561 Three (f s a) (f sPsa b) (f sPsab c)
1562 where
1563 sPsa = s + size a
1564 sPsab = sPsa + size b
1565 mapWithIndexDigit f s (Four a b c d) = sPsa `seq` sPsab `seq` sPsabc `seq`
1566 Four (f s a) (f sPsa b) (f sPsab c) (f sPsabc d)
1567 where
1568 sPsa = s + size a
1569 sPsab = sPsa + size b
1570 sPsabc = sPsab + size c
1571
1572 {-# SPECIALIZE mapWithIndexNode :: (Int -> Elem y -> b) -> Int -> Node (Elem y) -> Node b #-}
1573 {-# SPECIALIZE mapWithIndexNode :: (Int -> Node y -> b) -> Int -> Node (Node y) -> Node b #-}
1574 mapWithIndexNode :: Sized a => (Int -> a -> b) -> Int -> Node a -> Node b
1575 mapWithIndexNode f s (Node2 ns a b) = sPsa `seq` Node2 ns (f s a) (f sPsa b)
1576 where
1577 sPsa = s + size a
1578 mapWithIndexNode f s (Node3 ns a b c) = sPsa `seq` sPsab `seq`
1579 Node3 ns (f s a) (f sPsa b) (f sPsab c)
1580 where
1581 sPsa = s + size a
1582 sPsab = sPsa + size b
1583
1584 #ifdef __GLASGOW_HASKELL__
1585 {-# NOINLINE [1] mapWithIndex #-}
1586 {-# RULES
1587 "mapWithIndex/mapWithIndex" forall f g xs . mapWithIndex f (mapWithIndex g xs) =
1588 mapWithIndex (\k a -> f k (g k a)) xs
1589 "mapWithIndex/fmapSeq" forall f g xs . mapWithIndex f (fmapSeq g xs) =
1590 mapWithIndex (\k a -> f k (g a)) xs
1591 "fmapSeq/mapWithIndex" forall f g xs . fmapSeq f (mapWithIndex g xs) =
1592 mapWithIndex (\k a -> f (g k a)) xs
1593 #-}
1594 #endif
1595
1596 -- | /O(n)/. Convert a given sequence length and a function representing that
1597 -- sequence into a sequence.
1598 fromFunction :: Int -> (Int -> a) -> Seq a
1599 fromFunction len f | len < 0 = error "Data.Sequence.fromFunction called with negative len"
1600 | len == 0 = empty
1601 | otherwise = Seq $ create (lift_elem f) 1 0 len
1602 where
1603 create :: (Int -> a) -> Int -> Int -> Int -> FingerTree a
1604 create b{-tree_builder-} s{-tree_size-} i{-start_index-} trees = i `seq` s `seq` case trees of
1605 1 -> Single $ b i
1606 2 -> Deep (2*s) (One (b i)) Empty (One (b (i+s)))
1607 3 -> Deep (3*s) (createTwo i) Empty (One (b (i+2*s)))
1608 4 -> Deep (4*s) (createTwo i) Empty (createTwo (i+2*s))
1609 5 -> Deep (5*s) (createThree i) Empty (createTwo (i+3*s))
1610 6 -> Deep (6*s) (createThree i) Empty (createThree (i+3*s))
1611 _ -> case trees `quotRem` 3 of
1612 (trees', 1) -> Deep (trees*s) (createTwo i)
1613 (create mb (3*s) (i+2*s) (trees'-1))
1614 (createTwo (i+(2+3*(trees'-1))*s))
1615 (trees', 2) -> Deep (trees*s) (createThree i)
1616 (create mb (3*s) (i+3*s) (trees'-1))
1617 (createTwo (i+(3+3*(trees'-1))*s))
1618 (trees', _) -> Deep (trees*s) (createThree i)
1619 (create mb (3*s) (i+3*s) (trees'-2))
1620 (createThree (i+(3+3*(trees'-2))*s))
1621 where
1622 createTwo j = Two (b j) (b (j + s))
1623 {-# INLINE createTwo #-}
1624 createThree j = Three (b j) (b (j + s)) (b (j + 2*s))
1625 {-# INLINE createThree #-}
1626 mb j = Node3 (3*s) (b j) (b (j + s)) (b (j + 2*s))
1627 {-# INLINE mb #-}
1628
1629 lift_elem :: (Int -> a) -> (Int -> Elem a)
1630 #if __GLASGOW_HASKELL__ >= 708
1631 lift_elem g = coerce g
1632 #else
1633 lift_elem g = Elem . g
1634 #endif
1635 {-# INLINE lift_elem #-}
1636
1637 -- | /O(n)/. Create a sequence consisting of the elements of an 'Array'.
1638 -- Note that the resulting sequence elements may be evaluated lazily (as on GHC),
1639 -- so you must force the entire structure to be sure that the original array
1640 -- can be garbage-collected.
1641 fromArray :: Ix i => Array i a -> Seq a
1642 #ifdef __GLASGOW_HASKELL__
1643 fromArray a = fromFunction (GHC.Arr.numElements a) (GHC.Arr.unsafeAt a)
1644 #else
1645 fromArray a = fromList2 (Data.Array.rangeSize (Data.Array.bounds a)) (Data.Array.elems a)
1646 #endif
1647
1648 -- Splitting
1649
1650 -- | /O(log(min(i,n-i)))/. The first @i@ elements of a sequence.
1651 -- If @i@ is negative, @'take' i s@ yields the empty sequence.
1652 -- If the sequence contains fewer than @i@ elements, the whole sequence
1653 -- is returned.
1654 take :: Int -> Seq a -> Seq a
1655 take i = fst . splitAt' i
1656
1657 -- | /O(log(min(i,n-i)))/. Elements of a sequence after the first @i@.
1658 -- If @i@ is negative, @'drop' i s@ yields the whole sequence.
1659 -- If the sequence contains fewer than @i@ elements, the empty sequence
1660 -- is returned.
1661 drop :: Int -> Seq a -> Seq a
1662 drop i = snd . splitAt' i
1663
1664 -- | /O(log(min(i,n-i)))/. Split a sequence at a given position.
1665 -- @'splitAt' i s = ('take' i s, 'drop' i s)@.
1666 splitAt :: Int -> Seq a -> (Seq a, Seq a)
1667 splitAt i (Seq xs) = (Seq l, Seq r)
1668 where (l, r) = split i xs
1669
1670 -- | /O(log(min(i,n-i))) A strict version of 'splitAt'.
1671 splitAt' :: Int -> Seq a -> (Seq a, Seq a)
1672 splitAt' i (Seq xs) = case split i xs of
1673 (l, r) -> (Seq l, Seq r)
1674
1675 split :: Int -> FingerTree (Elem a) ->
1676 (FingerTree (Elem a), FingerTree (Elem a))
1677 split i Empty = i `seq` (Empty, Empty)
1678 split i xs
1679 | size xs > i = case splitTree i xs of
1680 Split l x r -> (l, consTree x r)
1681 | otherwise = (xs, Empty)
1682
1683 data Split t a = Split t a t
1684 #if TESTING
1685 deriving Show
1686 #endif
1687
1688 {-# SPECIALIZE splitTree :: Int -> FingerTree (Elem a) -> Split (FingerTree (Elem a)) (Elem a) #-}
1689 {-# SPECIALIZE splitTree :: Int -> FingerTree (Node a) -> Split (FingerTree (Node a)) (Node a) #-}
1690 splitTree :: Sized a => Int -> FingerTree a -> Split (FingerTree a) a
1691 splitTree _ Empty = error "splitTree of empty tree"
1692 splitTree i (Single x) = i `seq` Split Empty x Empty
1693 splitTree i (Deep _ pr m sf)
1694 | i < spr = case splitDigit i pr of
1695 Split l x r -> Split (maybe Empty digitToTree l) x (deepL r m sf)
1696 | i < spm = case splitTree im m of
1697 Split ml xs mr -> case splitNode (im - size ml) xs of
1698 Split l x r -> Split (deepR pr ml l) x (deepL r mr sf)
1699 | otherwise = case splitDigit (i - spm) sf of
1700 Split l x r -> Split (deepR pr m l) x (maybe Empty digitToTree r)
1701 where
1702 spr = size pr
1703 spm = spr + size m
1704 im = i - spr
1705
1706 {-# SPECIALIZE splitNode :: Int -> Node (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-}
1707 {-# SPECIALIZE splitNode :: Int -> Node (Node a) -> Split (Maybe (Digit (Node a))) (Node a) #-}
1708 splitNode :: Sized a => Int -> Node a -> Split (Maybe (Digit a)) a
1709 splitNode i (Node2 _ a b)
1710 | i < sa = Split Nothing a (Just (One b))
1711 | otherwise = Split (Just (One a)) b Nothing
1712 where
1713 sa = size a
1714 splitNode i (Node3 _ a b c)
1715 | i < sa = Split Nothing a (Just (Two b c))
1716 | i < sab = Split (Just (One a)) b (Just (One c))
1717 | otherwise = Split (Just (Two a b)) c Nothing
1718 where
1719 sa = size a
1720 sab = sa + size b
1721
1722 {-# SPECIALIZE splitDigit :: Int -> Digit (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-}
1723 {-# SPECIALIZE splitDigit :: Int -> Digit (Node a) -> Split (Maybe (Digit (Node a))) (Node a) #-}
1724 splitDigit :: Sized a => Int -> Digit a -> Split (Maybe (Digit a)) a
1725 splitDigit i (One a) = i `seq` Split Nothing a Nothing
1726 splitDigit i (Two a b)
1727 | i < sa = Split Nothing a (Just (One b))
1728 | otherwise = Split (Just (One a)) b Nothing
1729 where
1730 sa = size a
1731 splitDigit i (Three a b c)
1732 | i < sa = Split Nothing a (Just (Two b c))
1733 | i < sab = Split (Just (One a)) b (Just (One c))
1734 | otherwise = Split (Just (Two a b)) c Nothing
1735 where
1736 sa = size a
1737 sab = sa + size b
1738 splitDigit i (Four a b c d)
1739 | i < sa = Split Nothing a (Just (Three b c d))
1740 | i < sab = Split (Just (One a)) b (Just (Two c d))
1741 | i < sabc = Split (Just (Two a b)) c (Just (One d))
1742 | otherwise = Split (Just (Three a b c)) d Nothing
1743 where
1744 sa = size a
1745 sab = sa + size b
1746 sabc = sab + size c
1747
1748 -- | /O(n)/. Returns a sequence of all suffixes of this sequence,
1749 -- longest first. For example,
1750 --
1751 -- > tails (fromList "abc") = fromList [fromList "abc", fromList "bc", fromList "c", fromList ""]
1752 --
1753 -- Evaluating the /i/th suffix takes /O(log(min(i, n-i)))/, but evaluating
1754 -- every suffix in the sequence takes /O(n)/ due to sharing.
1755 tails :: Seq a -> Seq (Seq a)
1756 tails (Seq xs) = Seq (tailsTree (Elem . Seq) xs) |> empty
1757
1758 -- | /O(n)/. Returns a sequence of all prefixes of this sequence,
1759 -- shortest first. For example,
1760 --
1761 -- > inits (fromList "abc") = fromList [fromList "", fromList "a", fromList "ab", fromList "abc"]
1762 --
1763 -- Evaluating the /i/th prefix takes /O(log(min(i, n-i)))/, but evaluating
1764 -- every prefix in the sequence takes /O(n)/ due to sharing.
1765 inits :: Seq a -> Seq (Seq a)
1766 inits (Seq xs) = empty <| Seq (initsTree (Elem . Seq) xs)
1767
1768 -- This implementation of tails (and, analogously, inits) has the
1769 -- following algorithmic advantages:
1770 -- Evaluating each tail in the sequence takes linear total time,
1771 -- which is better than we could say for
1772 -- @fromList [drop n xs | n <- [0..length xs]]@.
1773 -- Evaluating any individual tail takes logarithmic time, which is
1774 -- better than we can say for either
1775 -- @scanr (<|) empty xs@ or @iterateN (length xs + 1) (\ xs -> let _ :< xs' = viewl xs in xs') xs@.
1776 --
1777 -- Moreover, if we actually look at every tail in the sequence, the
1778 -- following benchmarks demonstrate that this implementation is modestly
1779 -- faster than any of the above:
1780 --
1781 -- Times (ms)
1782 -- min mean +/-sd median max
1783 -- Seq.tails: 21.986 24.961 10.169 22.417 86.485
1784 -- scanr: 85.392 87.942 2.488 87.425 100.217
1785 -- iterateN: 29.952 31.245 1.574 30.412 37.268
1786 --
1787 -- The algorithm for tails (and, analogously, inits) is as follows:
1788 --
1789 -- A Node in the FingerTree of tails is constructed by evaluating the
1790 -- corresponding tail of the FingerTree of Nodes, considering the first
1791 -- Node in this tail, and constructing a Node in which each tail of this
1792 -- Node is made to be the prefix of the remaining tree. This ends up
1793 -- working quite elegantly, as the remainder of the tail of the FingerTree
1794 -- of Nodes becomes the middle of a new tail, the suffix of the Node is
1795 -- the prefix, and the suffix of the original tree is retained.
1796 --
1797 -- In particular, evaluating the /i/th tail involves making as
1798 -- many partial evaluations as the Node depth of the /i/th element.
1799 -- In addition, when we evaluate the /i/th tail, and we also evaluate
1800 -- the /j/th tail, and /m/ Nodes are on the path to both /i/ and /j/,
1801 -- each of those /m/ evaluations are shared between the computation of
1802 -- the /i/th and /j/th tails.
1803 --
1804 -- wasserman.louis@gmail.com, 7/16/09
1805
1806 tailsDigit :: Digit a -> Digit (Digit a)
1807 tailsDigit (One a) = One (One a)
1808 tailsDigit (Two a b) = Two (Two a b) (One b)
1809 tailsDigit (Three a b c) = Three (Three a b c) (Two b c) (One c)
1810 tailsDigit (Four a b c d) = Four (Four a b c d) (Three b c d) (Two c d) (One d)
1811
1812 initsDigit :: Digit a -> Digit (Digit a)
1813 initsDigit (One a) = One (One a)
1814 initsDigit (Two a b) = Two (One a) (Two a b)
1815 initsDigit (Three a b c) = Three (One a) (Two a b) (Three a b c)
1816 initsDigit (Four a b c d) = Four (One a) (Two a b) (Three a b c) (Four a b c d)
1817
1818 tailsNode :: Node a -> Node (Digit a)
1819 tailsNode (Node2 s a b) = Node2 s (Two a b) (One b)
1820 tailsNode (Node3 s a b c) = Node3 s (Three a b c) (Two b c) (One c)
1821
1822 initsNode :: Node a -> Node (Digit a)
1823 initsNode (Node2 s a b) = Node2 s (One a) (Two a b)
1824 initsNode (Node3 s a b c) = Node3 s (One a) (Two a b) (Three a b c)
1825
1826 {-# SPECIALIZE tailsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-}
1827 {-# SPECIALIZE tailsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-}
1828 -- | Given a function to apply to tails of a tree, applies that function
1829 -- to every tail of the specified tree.
1830 tailsTree :: (Sized a, Sized b) => (FingerTree a -> b) -> FingerTree a -> FingerTree b
1831 tailsTree _ Empty = Empty
1832 tailsTree f (Single x) = Single (f (Single x))
1833 tailsTree f (Deep n pr m sf) =
1834 Deep n (fmap (\ pr' -> f (deep pr' m sf)) (tailsDigit pr))
1835 (tailsTree f' m)
1836 (fmap (f . digitToTree) (tailsDigit sf))
1837 where
1838 f' ms = let Just2 node m' = viewLTree ms in
1839 fmap (\ pr' -> f (deep pr' m' sf)) (tailsNode node)
1840
1841 {-# SPECIALIZE initsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-}
1842 {-# SPECIALIZE initsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-}
1843 -- | Given a function to apply to inits of a tree, applies that function
1844 -- to every init of the specified tree.
1845 initsTree :: (Sized a, Sized b) => (FingerTree a -> b) -> FingerTree a -> FingerTree b
1846 initsTree _ Empty = Empty
1847 initsTree f (Single x) = Single (f (Single x))
1848 initsTree f (Deep n pr m sf) =
1849 Deep n (fmap (f . digitToTree) (initsDigit pr))
1850 (initsTree f' m)
1851 (fmap (f . deep pr m) (initsDigit sf))
1852 where
1853 f' ms = let Just2 m' node = viewRTree ms in
1854 fmap (\ sf' -> f (deep pr m' sf')) (initsNode node)
1855
1856 {-# INLINE foldlWithIndex #-}
1857 -- | 'foldlWithIndex' is a version of 'foldl' that also provides access
1858 -- to the index of each element.
1859 foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b
1860 foldlWithIndex f z xs = foldl (\ g x i -> i `seq` f (g (i - 1)) i x) (const z) xs (length xs - 1)
1861
1862 {-# INLINE foldrWithIndex #-}
1863 -- | 'foldrWithIndex' is a version of 'foldr' that also provides access
1864 -- to the index of each element.
1865 foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b
1866 foldrWithIndex f z xs = foldr (\ x g i -> i `seq` f i x (g (i+1))) (const z) xs 0
1867
1868 {-# INLINE listToMaybe' #-}
1869 -- 'listToMaybe\'' is a good consumer version of 'listToMaybe'.
1870 listToMaybe' :: [a] -> Maybe a
1871 listToMaybe' = foldr (\ x _ -> Just x) Nothing
1872
1873 -- | /O(i)/ where /i/ is the prefix length. 'takeWhileL', applied
1874 -- to a predicate @p@ and a sequence @xs@, returns the longest prefix
1875 -- (possibly empty) of @xs@ of elements that satisfy @p@.
1876 takeWhileL :: (a -> Bool) -> Seq a -> Seq a
1877 takeWhileL p = fst . spanl p
1878
1879 -- | /O(i)/ where /i/ is the suffix length. 'takeWhileR', applied
1880 -- to a predicate @p@ and a sequence @xs@, returns the longest suffix
1881 -- (possibly empty) of @xs@ of elements that satisfy @p@.
1882 --
1883 -- @'takeWhileR' p xs@ is equivalent to @'reverse' ('takeWhileL' p ('reverse' xs))@.
1884 takeWhileR :: (a -> Bool) -> Seq a -> Seq a
1885 takeWhileR p = fst . spanr p
1886
1887 -- | /O(i)/ where /i/ is the prefix length. @'dropWhileL' p xs@ returns
1888 -- the suffix remaining after @'takeWhileL' p xs@.
1889 dropWhileL :: (a -> Bool) -> Seq a -> Seq a
1890 dropWhileL p = snd . spanl p
1891
1892 -- | /O(i)/ where /i/ is the suffix length. @'dropWhileR' p xs@ returns
1893 -- the prefix remaining after @'takeWhileR' p xs@.
1894 --
1895 -- @'dropWhileR' p xs@ is equivalent to @'reverse' ('dropWhileL' p ('reverse' xs))@.
1896 dropWhileR :: (a -> Bool) -> Seq a -> Seq a
1897 dropWhileR p = snd . spanr p
1898
1899 -- | /O(i)/ where /i/ is the prefix length. 'spanl', applied to
1900 -- a predicate @p@ and a sequence @xs@, returns a pair whose first
1901 -- element is the longest prefix (possibly empty) of @xs@ of elements that
1902 -- satisfy @p@ and the second element is the remainder of the sequence.
1903 spanl :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
1904 spanl p = breakl (not . p)
1905
1906 -- | /O(i)/ where /i/ is the suffix length. 'spanr', applied to a
1907 -- predicate @p@ and a sequence @xs@, returns a pair whose /first/ element
1908 -- is the longest /suffix/ (possibly empty) of @xs@ of elements that
1909 -- satisfy @p@ and the second element is the remainder of the sequence.
1910 spanr :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
1911 spanr p = breakr (not . p)
1912
1913 {-# INLINE breakl #-}
1914 -- | /O(i)/ where /i/ is the breakpoint index. 'breakl', applied to a
1915 -- predicate @p@ and a sequence @xs@, returns a pair whose first element
1916 -- is the longest prefix (possibly empty) of @xs@ of elements that
1917 -- /do not satisfy/ @p@ and the second element is the remainder of
1918 -- the sequence.
1919 --
1920 -- @'breakl' p@ is equivalent to @'spanl' (not . p)@.
1921 breakl :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
1922 breakl p xs = foldr (\ i _ -> splitAt i xs) (xs, empty) (findIndicesL p xs)
1923
1924 {-# INLINE breakr #-}
1925 -- | @'breakr' p@ is equivalent to @'spanr' (not . p)@.
1926 breakr :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
1927 breakr p xs = foldr (\ i _ -> flipPair (splitAt (i + 1) xs)) (xs, empty) (findIndicesR p xs)
1928 where flipPair (x, y) = (y, x)
1929
1930 -- | /O(n)/. The 'partition' function takes a predicate @p@ and a
1931 -- sequence @xs@ and returns sequences of those elements which do and
1932 -- do not satisfy the predicate.
1933 partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
1934 partition p = foldl part (empty, empty)
1935 where
1936 part (xs, ys) x
1937 | p x = (xs |> x, ys)
1938 | otherwise = (xs, ys |> x)
1939
1940 -- | /O(n)/. The 'filter' function takes a predicate @p@ and a sequence
1941 -- @xs@ and returns a sequence of those elements which satisfy the
1942 -- predicate.
1943 filter :: (a -> Bool) -> Seq a -> Seq a
1944 filter p = foldl (\ xs x -> if p x then xs |> x else xs) empty
1945
1946 -- Indexing sequences
1947
1948 -- | 'elemIndexL' finds the leftmost index of the specified element,
1949 -- if it is present, and otherwise 'Nothing'.
1950 elemIndexL :: Eq a => a -> Seq a -> Maybe Int
1951 elemIndexL x = findIndexL (x ==)
1952
1953 -- | 'elemIndexR' finds the rightmost index of the specified element,
1954 -- if it is present, and otherwise 'Nothing'.
1955 elemIndexR :: Eq a => a -> Seq a -> Maybe Int
1956 elemIndexR x = findIndexR (x ==)
1957
1958 -- | 'elemIndicesL' finds the indices of the specified element, from
1959 -- left to right (i.e. in ascending order).
1960 elemIndicesL :: Eq a => a -> Seq a -> [Int]
1961 elemIndicesL x = findIndicesL (x ==)
1962
1963 -- | 'elemIndicesR' finds the indices of the specified element, from
1964 -- right to left (i.e. in descending order).
1965 elemIndicesR :: Eq a => a -> Seq a -> [Int]
1966 elemIndicesR x = findIndicesR (x ==)
1967
1968 -- | @'findIndexL' p xs@ finds the index of the leftmost element that
1969 -- satisfies @p@, if any exist.
1970 findIndexL :: (a -> Bool) -> Seq a -> Maybe Int
1971 findIndexL p = listToMaybe' . findIndicesL p
1972
1973 -- | @'findIndexR' p xs@ finds the index of the rightmost element that
1974 -- satisfies @p@, if any exist.
1975 findIndexR :: (a -> Bool) -> Seq a -> Maybe Int
1976 findIndexR p = listToMaybe' . findIndicesR p
1977
1978 {-# INLINE findIndicesL #-}
1979 -- | @'findIndicesL' p@ finds all indices of elements that satisfy @p@,
1980 -- in ascending order.
1981 findIndicesL :: (a -> Bool) -> Seq a -> [Int]
1982 #if __GLASGOW_HASKELL__
1983 findIndicesL p xs = build (\ c n -> let g i x z = if p x then c i z else z in
1984 foldrWithIndex g n xs)
1985 #else
1986 findIndicesL p xs = foldrWithIndex g [] xs
1987 where g i x is = if p x then i:is else is
1988 #endif
1989
1990 {-# INLINE findIndicesR #-}
1991 -- | @'findIndicesR' p@ finds all indices of elements that satisfy @p@,
1992 -- in descending order.
1993 findIndicesR :: (a -> Bool) -> Seq a -> [Int]
1994 #if __GLASGOW_HASKELL__
1995 findIndicesR p xs = build (\ c n ->
1996 let g z i x = if p x then c i z else z in foldlWithIndex g n xs)
1997 #else
1998 findIndicesR p xs = foldlWithIndex g [] xs
1999 where g is i x = if p x then i:is else is
2000 #endif
2001
2002 ------------------------------------------------------------------------
2003 -- Lists
2004 ------------------------------------------------------------------------
2005
2006 -- The implementation below, by Ross Paterson, avoids the rebuilding
2007 -- the previous (|>)-based implementation suffered from.
2008
2009 -- | /O(n)/. Create a sequence from a finite list of elements.
2010 -- There is a function 'toList' in the opposite direction for all
2011 -- instances of the 'Foldable' class, including 'Seq'.
2012 fromList :: [a] -> Seq a
2013 fromList = Seq . mkTree 1 . map_elem
2014 where
2015 {-# SPECIALIZE mkTree :: Int -> [Elem a] -> FingerTree (Elem a) #-}
2016 {-# SPECIALIZE mkTree :: Int -> [Node a] -> FingerTree (Node a) #-}
2017 mkTree :: (Sized a) => Int -> [a] -> FingerTree a
2018 STRICT_1_OF_2(mkTree)
2019 mkTree _ [] = Empty
2020 mkTree _ [x1] = Single x1
2021 mkTree s [x1, x2] = Deep (2*s) (One x1) Empty (One x2)
2022 mkTree s [x1, x2, x3] = Deep (3*s) (One x1) Empty (Two x2 x3)
2023 mkTree s (x1:x2:x3:x4:xs) = case getNodes (3*s) x4 xs of
2024 (ns, sf) -> case mkTree (3*s) ns of
2025 m -> m `seq` Deep (3*size x1 + size m + size sf) (Three x1 x2 x3) m sf
2026
2027 getNodes :: Int -> a -> [a] -> ([Node a], Digit a)
2028 STRICT_1_OF_3(getNodes)
2029 getNodes _ x1 [] = ([], One x1)
2030 getNodes _ x1 [x2] = ([], Two x1 x2)
2031 getNodes _ x1 [x2, x3] = ([], Three x1 x2 x3)
2032 getNodes s x1 (x2:x3:x4:xs) = (Node3 s x1 x2 x3:ns, d)
2033 where (ns, d) = getNodes s x4 xs
2034
2035 map_elem :: [a] -> [Elem a]
2036 #if __GLASGOW_HASKELL__ >= 708
2037 map_elem xs = coerce xs
2038 #else
2039 map_elem xs = Data.List.map Elem xs
2040 #endif
2041 {-# INLINE map_elem #-}
2042
2043 #if __GLASGOW_HASKELL__ >= 708
2044 instance GHC.Exts.IsList (Seq a) where
2045 type Item (Seq a) = a
2046 fromList = fromList
2047 fromListN = fromList2
2048 toList = toList
2049 #endif
2050
2051 ------------------------------------------------------------------------
2052 -- Reverse
2053 ------------------------------------------------------------------------
2054
2055 -- | /O(n)/. The reverse of a sequence.
2056 reverse :: Seq a -> Seq a
2057 reverse (Seq xs) = Seq (reverseTree id xs)
2058
2059 reverseTree :: (a -> a) -> FingerTree a -> FingerTree a
2060 reverseTree _ Empty = Empty
2061 reverseTree f (Single x) = Single (f x)
2062 reverseTree f (Deep s pr m sf) =
2063 Deep s (reverseDigit f sf)
2064 (reverseTree (reverseNode f) m)
2065 (reverseDigit f pr)
2066
2067 {-# INLINE reverseDigit #-}
2068 reverseDigit :: (a -> a) -> Digit a -> Digit a
2069 reverseDigit f (One a) = One (f a)
2070 reverseDigit f (Two a b) = Two (f b) (f a)
2071 reverseDigit f (Three a b c) = Three (f c) (f b) (f a)
2072 reverseDigit f (Four a b c d) = Four (f d) (f c) (f b) (f a)
2073
2074 reverseNode :: (a -> a) -> Node a -> Node a
2075 reverseNode f (Node2 s a b) = Node2 s (f b) (f a)
2076 reverseNode f (Node3 s a b c) = Node3 s (f c) (f b) (f a)
2077
2078 ------------------------------------------------------------------------
2079 -- Mapping with a splittable value
2080 ------------------------------------------------------------------------
2081
2082 -- For zipping, it is useful to build a result by
2083 -- traversing a sequence while splitting up something else. For zipping, we
2084 -- traverse the first sequence while splitting up the second.
2085 --
2086 -- What makes all this crazy code a good idea:
2087 --
2088 -- Suppose we zip together two sequences of the same length:
2089 --
2090 -- zs = zip xs ys
2091 --
2092 -- We want to get reasonably fast indexing into zs immediately, rather than
2093 -- needing to construct the entire thing first, as the previous implementation
2094 -- required. The first aspect is that we build the result "outside-in" or
2095 -- "top-down", rather than left to right. That gives us access to both ends
2096 -- quickly. But that's not enough, by itself, to give immediate access to the
2097 -- center of zs. For that, we need to be able to skip over larger segments of
2098 -- zs, delaying their construction until we actually need them. The way we do
2099 -- this is to traverse xs, while splitting up ys according to the structure of
2100 -- xs. If we have a Deep _ pr m sf, we split ys into three pieces, and hand off
2101 -- one piece to the prefix, one to the middle, and one to the suffix of the
2102 -- result. The key point is that we don't need to actually do anything further
2103 -- with those pieces until we actually need them; the computations to split
2104 -- them up further and zip them with their matching pieces can be delayed until
2105 -- they're actually needed. We do the same thing for Digits (splitting into
2106 -- between one and four pieces) and Nodes (splitting into two or three). The
2107 -- ultimate result is that we can index into, or split at, any location in zs
2108 -- in polylogarithmic time *immediately*, while still being able to force all
2109 -- the thunks in O(n) time.
2110 --
2111 -- Benchmark info, and alternatives:
2112 --
2113 -- The old zipping code used mapAccumL to traverse the first sequence while
2114 -- cutting down the second sequence one piece at a time.
2115 --
2116 -- An alternative way to express that basic idea is to convert both sequences
2117 -- to lists, zip the lists, and then convert the result back to a sequence.
2118 -- I'll call this the "listy" implementation.
2119 --
2120 -- I benchmarked two operations: Each started by zipping two sequences
2121 -- constructed with replicate and/or fromList. The first would then immediately
2122 -- index into the result. The second would apply deepseq to force the entire
2123 -- result. The new implementation worked much better than either of the others
2124 -- on the immediate indexing test, as expected. It also worked better than the
2125 -- old implementation for all the deepseq tests. For short sequences, the listy
2126 -- implementation outperformed all the others on the deepseq test. However, the
2127 -- splitting implementation caught up and surpassed it once the sequences grew
2128 -- long enough. It seems likely that by avoiding rebuilding, it interacts
2129 -- better with the cache hierarchy.
2130 --
2131 -- David Feuer, with excellent guidance from Carter Schonwald, December 2014
2132
2133 -- | /O(n)/. Constructs a new sequence with the same structure as an existing
2134 -- sequence using a user-supplied mapping function along with a splittable
2135 -- value and a way to split it. The value is split up lazily according to the
2136 -- structure of the sequence, so one piece of the value is distributed to each
2137 -- element of the sequence. The caller should provide a splitter function that
2138 -- takes a number, @n@, and a splittable value, breaks off a chunk of size @n@
2139 -- from the value, and returns that chunk and the remainder as a pair. The
2140 -- following examples will hopefully make the usage clear:
2141 --
2142 -- > zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
2143 -- > zipWith f s1 s2 = splitMap splitAt (\b a -> f a (b `index` 0)) s2' s1'
2144 -- > where
2145 -- > minLen = min (length s1) (length s2)
2146 -- > s1' = take minLen s1
2147 -- > s2' = take minLen s2
2148 --
2149 -- > mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b
2150 -- > mapWithIndex f = splitMap (\n i -> (i, n+i)) f 0
2151 splitMap :: (Int -> s -> (s,s)) -> (s -> a -> b) -> s -> Seq a -> Seq b
2152 splitMap splt' = go
2153 where
2154 go f s (Seq xs) = Seq $ splitMapTree splt' (\s' (Elem a) -> Elem (f s' a)) s xs
2155
2156 {-# SPECIALIZE splitMapTree :: (Int -> s -> (s,s)) -> (s -> Elem y -> b) -> s -> FingerTree (Elem y) -> FingerTree b #-}
2157 {-# SPECIALIZE splitMapTree :: (Int -> s -> (s,s)) -> (s -> Node y -> b) -> s -> FingerTree (Node y) -> FingerTree b #-}
2158 splitMapTree :: Sized a => (Int -> s -> (s,s)) -> (s -> a -> b) -> s -> FingerTree a -> FingerTree b
2159 splitMapTree _ _ _ Empty = Empty
2160 splitMapTree _ f s (Single xs) = Single $ f s xs
2161 splitMapTree splt f s (Deep n pr m sf) = Deep n (splitMapDigit splt f prs pr) (splitMapTree splt (splitMapNode splt f) ms m) (splitMapDigit splt f sfs sf)
2162 where
2163 (prs, r) = splt (size pr) s
2164 (ms, sfs) = splt (n - size pr - size sf) r
2165
2166 {-# SPECIALIZE splitMapDigit :: (Int -> s -> (s,s)) -> (s -> Elem y -> b) -> s -> Digit (Elem y) -> Digit b #-}
2167 {-# SPECIALIZE splitMapDigit :: (Int -> s -> (s,s)) -> (s -> Node y -> b) -> s -> Digit (Node y) -> Digit b #-}
2168 splitMapDigit :: Sized a => (Int -> s -> (s,s)) -> (s -> a -> b) -> s -> Digit a -> Digit b
2169 splitMapDigit _ f s (One a) = One (f s a)
2170 splitMapDigit splt f s (Two a b) = Two (f first a) (f second b)
2171 where
2172 (first, second) = splt (size a) s
2173 splitMapDigit splt f s (Three a b c) = Three (f first a) (f second b) (f third c)
2174 where
2175 (first, r) = splt (size a) s
2176 (second, third) = splt (size b) r
2177 splitMapDigit splt f s (Four a b c d) = Four (f first a) (f second b) (f third c) (f fourth d)
2178 where
2179 (first, s') = splt (size a) s
2180 (middle, fourth) = splt (size b + size c) s'
2181 (second, third) = splt (size b) middle
2182
2183 {-# SPECIALIZE splitMapNode :: (Int -> s -> (s,s)) -> (s -> Elem y -> b) -> s -> Node (Elem y) -> Node b #-}
2184 {-# SPECIALIZE splitMapNode :: (Int -> s -> (s,s)) -> (s -> Node y -> b) -> s -> Node (Node y) -> Node b #-}
2185 splitMapNode :: Sized a => (Int -> s -> (s,s)) -> (s -> a -> b) -> s -> Node a -> Node b
2186 splitMapNode splt f s (Node2 ns a b) = Node2 ns (f first a) (f second b)
2187 where
2188 (first, second) = splt (size a) s
2189 splitMapNode splt f s (Node3 ns a b c) = Node3 ns (f first a) (f second b) (f third c)
2190 where
2191 (first, r) = splt (size a) s
2192 (second, third) = splt (size b) r
2193
2194 {-# INLINE splitMap #-}
2195
2196 getSingleton :: Seq a -> a
2197 getSingleton (Seq (Single (Elem a))) = a
2198 getSingleton (Seq Empty) = error "getSingleton: Empty"
2199 getSingleton _ = error "getSingleton: Not a singleton."
2200
2201 ------------------------------------------------------------------------
2202 -- Zipping
2203 ------------------------------------------------------------------------
2204
2205 -- | /O(min(n1,n2))/. 'zip' takes two sequences and returns a sequence
2206 -- of corresponding pairs. If one input is short, excess elements are
2207 -- discarded from the right end of the longer sequence.
2208 zip :: Seq a -> Seq b -> Seq (a, b)
2209 zip = zipWith (,)
2210
2211 -- | /O(min(n1,n2))/. 'zipWith' generalizes 'zip' by zipping with the
2212 -- function given as the first argument, instead of a tupling function.
2213 -- For example, @zipWith (+)@ is applied to two sequences to take the
2214 -- sequence of corresponding sums.
2215 zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
2216 zipWith f s1 s2 = zipWith' f s1' s2'
2217 where
2218 minLen = min (length s1) (length s2)
2219 s1' = take minLen s1
2220 s2' = take minLen s2
2221
2222 -- | A version of zipWith that assumes the sequences have the same length.
2223 zipWith' :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
2224 zipWith' f s1 s2 = splitMap splitAt' (\s a -> f a (getSingleton s)) s2 s1
2225
2226 -- | /O(min(n1,n2,n3))/. 'zip3' takes three sequences and returns a
2227 -- sequence of triples, analogous to 'zip'.
2228 zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)
2229 zip3 = zipWith3 (,,)
2230
2231 -- | /O(min(n1,n2,n3))/. 'zipWith3' takes a function which combines
2232 -- three elements, as well as three sequences and returns a sequence of
2233 -- their point-wise combinations, analogous to 'zipWith'.
2234 zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
2235 zipWith3 f s1 s2 s3 = zipWith' ($) (zipWith' f s1' s2') s3'
2236 where
2237 minLen = minimum [length s1, length s2, length s3]
2238 s1' = take minLen s1
2239 s2' = take minLen s2
2240 s3' = take minLen s3
2241
2242 zipWith3' :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
2243 zipWith3' f s1 s2 s3 = zipWith' ($) (zipWith' f s1 s2) s3
2244
2245 -- | /O(min(n1,n2,n3,n4))/. 'zip4' takes four sequences and returns a
2246 -- sequence of quadruples, analogous to 'zip'.
2247 zip4 :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a,b,c,d)
2248 zip4 = zipWith4 (,,,)
2249
2250 -- | /O(min(n1,n2,n3,n4))/. 'zipWith4' takes a function which combines
2251 -- four elements, as well as four sequences and returns a sequence of
2252 -- their point-wise combinations, analogous to 'zipWith'.
2253 zipWith4 :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e
2254 zipWith4 f s1 s2 s3 s4 = zipWith' ($) (zipWith3' f s1' s2' s3') s4'
2255 where
2256 minLen = minimum [length s1, length s2, length s3, length s4]
2257 s1' = take minLen s1
2258 s2' = take minLen s2
2259 s3' = take minLen s3
2260 s4' = take minLen s4
2261
2262 ------------------------------------------------------------------------
2263 -- Sorting
2264 --
2265 -- sort and sortBy are implemented by simple deforestations of
2266 -- \ xs -> fromList2 (length xs) . Data.List.sortBy cmp . toList
2267 -- which does not get deforested automatically, it would appear.
2268 --
2269 -- Unstable sorting is performed by a heap sort implementation based on
2270 -- pairing heaps. Because the internal structure of sequences is quite
2271 -- varied, it is difficult to get blocks of elements of roughly the same
2272 -- length, which would improve merge sort performance. Pairing heaps,
2273 -- on the other hand, are relatively resistant to the effects of merging
2274 -- heaps of wildly different sizes, as guaranteed by its amortized
2275 -- constant-time merge operation. Moreover, extensive use of SpecConstr
2276 -- transformations can be done on pairing heaps, especially when we're
2277 -- only constructing them to immediately be unrolled.
2278 --
2279 -- On purely random sequences of length 50000, with no RTS options,
2280 -- I get the following statistics, in which heapsort is about 42.5%
2281 -- faster: (all comparisons done with -O2)
2282 --
2283 -- Times (ms) min mean +/-sd median max
2284 -- to/from list: 103.802 108.572 7.487 106.436 143.339
2285 -- unstable heapsort: 60.686 62.968 4.275 61.187 79.151
2286 --
2287 -- Heapsort, it would seem, is less of a memory hog than Data.List.sortBy.
2288 -- The gap is narrowed when more memory is available, but heapsort still
2289 -- wins, 15% faster, with +RTS -H128m:
2290 --
2291 -- Times (ms) min mean +/-sd median max
2292 -- to/from list: 42.692 45.074 2.596 44.600 56.601
2293 -- unstable heapsort: 37.100 38.344 3.043 37.715 55.526
2294 --
2295 -- In addition, on strictly increasing sequences the gap is even wider
2296 -- than normal; heapsort is 68.5% faster with no RTS options:
2297 -- Times (ms) min mean +/-sd median max
2298 -- to/from list: 52.236 53.574 1.987 53.034 62.098
2299 -- unstable heapsort: 16.433 16.919 0.931 16.681 21.622
2300 --
2301 -- This may be attributed to the elegant nature of the pairing heap.
2302 --
2303 -- wasserman.louis@gmail.com, 7/20/09
2304 ------------------------------------------------------------------------
2305
2306 -- | /O(n log n)/. 'sort' sorts the specified 'Seq' by the natural
2307 -- ordering of its elements. The sort is stable.
2308 -- If stability is not required, 'unstableSort' can be considerably
2309 -- faster, and in particular uses less memory.
2310 sort :: Ord a => Seq a -> Seq a
2311 sort = sortBy compare
2312
2313 -- | /O(n log n)/. 'sortBy' sorts the specified 'Seq' according to the
2314 -- specified comparator. The sort is stable.
2315 -- If stability is not required, 'unstableSortBy' can be considerably
2316 -- faster, and in particular uses less memory.
2317 sortBy :: (a -> a -> Ordering) -> Seq a -> Seq a
2318 sortBy cmp xs = fromList2 (length xs) (Data.List.sortBy cmp (toList xs))
2319
2320 -- | /O(n log n)/. 'unstableSort' sorts the specified 'Seq' by
2321 -- the natural ordering of its elements, but the sort is not stable.
2322 -- This algorithm is frequently faster and uses less memory than 'sort',
2323 -- and performs extremely well -- frequently twice as fast as 'sort' --
2324 -- when the sequence is already nearly sorted.
2325 unstableSort :: Ord a => Seq a -> Seq a
2326 unstableSort = unstableSortBy compare
2327
2328 -- | /O(n log n)/. A generalization of 'unstableSort', 'unstableSortBy'
2329 -- takes an arbitrary comparator and sorts the specified sequence.
2330 -- The sort is not stable. This algorithm is frequently faster and
2331 -- uses less memory than 'sortBy', and performs extremely well --
2332 -- frequently twice as fast as 'sortBy' -- when the sequence is already
2333 -- nearly sorted.
2334 unstableSortBy :: (a -> a -> Ordering) -> Seq a -> Seq a
2335 unstableSortBy cmp (Seq xs) =
2336 fromList2 (size xs) $ maybe [] (unrollPQ cmp) $
2337 toPQ cmp (\ (Elem x) -> PQueue x Nil) xs
2338
2339 -- | fromList2, given a list and its length, constructs a completely
2340 -- balanced Seq whose elements are that list using the replicateA
2341 -- generalization.
2342 fromList2 :: Int -> [a] -> Seq a
2343 fromList2 n = execState (replicateA n (State ht))
2344 where
2345 ht (x:xs) = (xs, x)
2346 ht [] = error "fromList2: short list"
2347
2348 -- | A 'PQueue' is a simple pairing heap.
2349 data PQueue e = PQueue e (PQL e)
2350 data PQL e = Nil | {-# UNPACK #-} !(PQueue e) :& PQL e
2351
2352 infixr 8 :&
2353
2354 #if TESTING
2355
2356 instance Functor PQueue where
2357 fmap f (PQueue x ts) = PQueue (f x) (fmap f ts)
2358
2359 instance Functor PQL where
2360 fmap f (q :& qs) = fmap f q :& fmap f qs
2361 fmap _ Nil = Nil
2362
2363 instance Show e => Show (PQueue e) where
2364 show = unlines . draw . fmap show
2365
2366 -- borrowed wholesale from Data.Tree, as Data.Tree actually depends
2367 -- on Data.Sequence
2368 draw :: PQueue String -> [String]
2369 draw (PQueue x ts0) = x : drawSubTrees ts0
2370 where
2371 drawSubTrees Nil = []
2372 drawSubTrees (t :& Nil) =
2373 "|" : shift "`- " " " (draw t)
2374 drawSubTrees (t :& ts) =
2375 "|" : shift "+- " "| " (draw t) ++ drawSubTrees ts
2376
2377 shift first other = Data.List.zipWith (++) (first : repeat other)
2378 #endif
2379
2380 -- | 'unrollPQ', given a comparator function, unrolls a 'PQueue' into
2381 -- a sorted list.
2382 unrollPQ :: (e -> e -> Ordering) -> PQueue e -> [e]
2383 unrollPQ cmp = unrollPQ'
2384 where
2385 {-# INLINE unrollPQ' #-}
2386 unrollPQ' (PQueue x ts) = x:mergePQs0 ts
2387 (<>) = mergePQ cmp
2388 mergePQs0 Nil = []
2389 mergePQs0 (t :& Nil) = unrollPQ' t
2390 mergePQs0 (t1 :& t2 :& ts) = mergePQs (t1 <> t2) ts
2391 mergePQs t ts = t `seq` case ts of
2392 Nil -> unrollPQ' t
2393 t1 :& Nil -> unrollPQ' (t <> t1)
2394 t1 :& t2 :& ts' -> mergePQs (t <> (t1 <> t2)) ts'
2395
2396 -- | 'toPQ', given an ordering function and a mechanism for queueifying
2397 -- elements, converts a 'FingerTree' to a 'PQueue'.
2398 toPQ :: (e -> e -> Ordering) -> (a -> PQueue e) -> FingerTree a -> Maybe (PQueue e)
2399 toPQ _ _ Empty = Nothing
2400 toPQ _ f (Single x) = Just (f x)
2401 toPQ cmp f (Deep _ pr m sf) = Just (maybe (pr' <> sf') ((pr' <> sf') <>) (toPQ cmp fNode m))
2402 where
2403 fDigit digit = case fmap f digit of
2404 One a -> a
2405 Two a b -> a <> b
2406 Three a b c -> a <> b <> c
2407 Four a b c d -> (a <> b) <> (c <> d)
2408 (<>) = mergePQ cmp
2409 fNode = fDigit . nodeToDigit
2410 pr' = fDigit pr
2411 sf' = fDigit sf
2412
2413 -- | 'mergePQ' merges two 'PQueue's.
2414 mergePQ :: (a -> a -> Ordering) -> PQueue a -> PQueue a -> PQueue a
2415 mergePQ cmp q1@(PQueue x1 ts1) q2@(PQueue x2 ts2)
2416 | cmp x1 x2 == GT = PQueue x2 (q1 :& ts2)
2417 | otherwise = PQueue x1 (q2 :& ts1)