e27661f61f7857d5c63e3c5cc4866f77d6ad9883
[packages/containers.git] / Data / Sequence.hs
1 {-# LANGUAGE CPP, DeriveDataTypeable #-}
2 -----------------------------------------------------------------------------
3 -- |
4 -- Module : Data.Sequence
5 -- Copyright : (c) Ross Paterson 2005
6 -- (c) Louis Wasserman 2009
7 -- License : BSD-style
8 -- Maintainer : libraries@haskell.org
9 -- Stability : experimental
10 -- Portability : portable
11 --
12 -- General purpose finite sequences.
13 -- Apart from being finite and having strict operations, sequences
14 -- also differ from lists in supporting a wider variety of operations
15 -- efficiently.
16 --
17 -- An amortized running time is given for each operation, with /n/ referring
18 -- to the length of the sequence and /i/ being the integral index used by
19 -- some operations. These bounds hold even in a persistent (shared) setting.
20 --
21 -- The implementation uses 2-3 finger trees annotated with sizes,
22 -- as described in section 4.2 of
23 --
24 -- * Ralf Hinze and Ross Paterson,
25 -- \"Finger trees: a simple general-purpose data structure\",
26 -- /Journal of Functional Programming/ 16:2 (2006) pp 197-217.
27 -- <http://www.soi.city.ac.uk/~ross/papers/FingerTree.html>
28 --
29 -- /Note/: Many of these operations have the same names as similar
30 -- operations on lists in the "Prelude". The ambiguity may be resolved
31 -- using either qualification or the @hiding@ clause.
32 --
33 -----------------------------------------------------------------------------
34
35 module Data.Sequence (
36 Seq,
37 -- * Construction
38 empty, -- :: Seq a
39 singleton, -- :: a -> Seq a
40 (<|), -- :: a -> Seq a -> Seq a
41 (|>), -- :: Seq a -> a -> Seq a
42 (><), -- :: Seq a -> Seq a -> Seq a
43 fromList, -- :: [a] -> Seq a
44 -- ** Repetition
45 replicate, -- :: Int -> a -> Seq a
46 replicateA, -- :: Applicative f => Int -> f a -> f (Seq a)
47 replicateM, -- :: Monad m => Int -> m a -> m (Seq a)
48 -- ** Iterative construction
49 iterateN, -- :: Int -> (a -> a) -> a -> Seq a
50 unfoldr, -- :: (b -> Maybe (a, b)) -> b -> Seq a
51 unfoldl, -- :: (b -> Maybe (b, a)) -> b -> Seq a
52 -- * Deconstruction
53 -- | Additional functions for deconstructing sequences are available
54 -- via the 'Foldable' instance of 'Seq'.
55
56 -- ** Queries
57 null, -- :: Seq a -> Bool
58 length, -- :: Seq a -> Int
59 -- ** Views
60 ViewL(..),
61 viewl, -- :: Seq a -> ViewL a
62 ViewR(..),
63 viewr, -- :: Seq a -> ViewR a
64 -- * Scans
65 scanl, -- :: (a -> b -> a) -> a -> Seq b -> Seq a
66 scanl1, -- :: (a -> a -> a) -> Seq a -> Seq a
67 scanr, -- :: (a -> b -> b) -> b -> Seq a -> Seq b
68 scanr1, -- :: (a -> a -> a) -> Seq a -> Seq a
69 -- * Sublists
70 tails, -- :: Seq a -> Seq (Seq a)
71 inits, -- :: Seq a -> Seq (Seq a)
72 -- ** Sequential searches
73 takeWhileL, -- :: (a -> Bool) -> Seq a -> Seq a
74 takeWhileR, -- :: (a -> Bool) -> Seq a -> Seq a
75 dropWhileL, -- :: (a -> Bool) -> Seq a -> Seq a
76 dropWhileR, -- :: (a -> Bool) -> Seq a -> Seq a
77 spanl, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
78 spanr, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
79 breakl, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
80 breakr, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
81 partition, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
82 filter, -- :: (a -> Bool) -> Seq a -> Seq a
83 -- * Sorting
84 sort, -- :: Ord a => Seq a -> Seq a
85 sortBy, -- :: (a -> a -> Ordering) -> Seq a -> Seq a
86 unstableSort, -- :: Ord a => Seq a -> Seq a
87 unstableSortBy, -- :: (a -> a -> Ordering) -> Seq a -> Seq a
88 -- * Indexing
89 index, -- :: Seq a -> Int -> a
90 adjust, -- :: (a -> a) -> Int -> Seq a -> Seq a
91 update, -- :: Int -> a -> Seq a -> Seq a
92 take, -- :: Int -> Seq a -> Seq a
93 drop, -- :: Int -> Seq a -> Seq a
94 splitAt, -- :: Int -> Seq a -> (Seq a, Seq a)
95 -- ** Indexing with predicates
96 -- | These functions perform sequential searches from the left
97 -- or right ends of the sequence, returning indices of matching
98 -- elements.
99 elemIndexL, -- :: Eq a => a -> Seq a -> Maybe Int
100 elemIndicesL, -- :: Eq a => a -> Seq a -> [Int]
101 elemIndexR, -- :: Eq a => a -> Seq a -> Maybe Int
102 elemIndicesR, -- :: Eq a => a -> Seq a -> [Int]
103 findIndexL, -- :: (a -> Bool) -> Seq a -> Maybe Int
104 findIndicesL, -- :: (a -> Bool) -> Seq a -> [Int]
105 findIndexR, -- :: (a -> Bool) -> Seq a -> Maybe Int
106 findIndicesR, -- :: (a -> Bool) -> Seq a -> [Int]
107 -- * Folds
108 -- | General folds are available via the 'Foldable' instance of 'Seq'.
109 foldlWithIndex, -- :: (b -> Int -> a -> b) -> b -> Seq a -> b
110 foldrWithIndex, -- :: (Int -> a -> b -> b) -> b -> Seq a -> b
111 -- * Transformations
112 mapWithIndex, -- :: (Int -> a -> b) -> Seq a -> Seq b
113 reverse, -- :: Seq a -> Seq a
114 -- ** Zips
115 zip, -- :: Seq a -> Seq b -> Seq (a, b)
116 zipWith, -- :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
117 zip3, -- :: Seq a -> Seq b -> Seq c -> Seq (a, b, c)
118 zipWith3, -- :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
119 zip4, -- :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a, b, c, d)
120 zipWith4, -- :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e
121 #if TESTING
122 valid,
123 #endif
124 ) where
125
126 import Prelude hiding (
127 Functor(..),
128 null, length, take, drop, splitAt, foldl, foldl1, foldr, foldr1,
129 scanl, scanl1, scanr, scanr1, replicate, zip, zipWith, zip3, zipWith3,
130 takeWhile, dropWhile, iterate, reverse, filter, mapM, sum, all)
131 import qualified Data.List (foldl', sortBy)
132 import Control.Applicative (Applicative(..), (<$>), WrappedMonad(..), liftA, liftA2, liftA3)
133 import Control.Monad (MonadPlus(..), ap)
134 import Data.Monoid (Monoid(..))
135 import Data.Functor (Functor(..))
136 import Data.Foldable
137 import Data.Traversable
138 import Data.Typeable
139
140 #ifdef __GLASGOW_HASKELL__
141 import GHC.Exts (build)
142 import Text.Read (Lexeme(Ident), lexP, parens, prec,
143 readPrec, readListPrec, readListPrecDefault)
144 import Data.Data
145 #endif
146
147 #if TESTING
148 import qualified Data.List (zipWith)
149 import Test.QuickCheck hiding ((><))
150 #endif
151
152 infixr 5 `consTree`
153 infixl 5 `snocTree`
154
155 infixr 5 ><
156 infixr 5 <|, :<
157 infixl 5 |>, :>
158
159 class Sized a where
160 size :: a -> Int
161
162 -- | General-purpose finite sequences.
163 newtype Seq a = Seq (FingerTree (Elem a))
164
165 instance Functor Seq where
166 fmap f (Seq xs) = Seq (fmap (fmap f) xs)
167 #ifdef __GLASGOW_HASKELL__
168 x <$ s = replicate (length s) x
169 #endif
170
171 instance Foldable Seq where
172 foldr f z (Seq xs) = foldr (flip (foldr f)) z xs
173 foldl f z (Seq xs) = foldl (foldl f) z xs
174
175 foldr1 f (Seq xs) = getElem (foldr1 f' xs)
176 where f' (Elem x) (Elem y) = Elem (f x y)
177
178 foldl1 f (Seq xs) = getElem (foldl1 f' xs)
179 where f' (Elem x) (Elem y) = Elem (f x y)
180
181 instance Traversable Seq where
182 traverse f (Seq xs) = Seq <$> traverse (traverse f) xs
183
184 instance Monad Seq where
185 return = singleton
186 xs >>= f = foldl' add empty xs
187 where add ys x = ys >< f x
188
189 instance MonadPlus Seq where
190 mzero = empty
191 mplus = (><)
192
193 instance Eq a => Eq (Seq a) where
194 xs == ys = length xs == length ys && toList xs == toList ys
195
196 instance Ord a => Ord (Seq a) where
197 compare xs ys = compare (toList xs) (toList ys)
198
199 #if TESTING
200 instance Show a => Show (Seq a) where
201 showsPrec p (Seq x) = showsPrec p x
202 #else
203 instance Show a => Show (Seq a) where
204 showsPrec p xs = showParen (p > 10) $
205 showString "fromList " . shows (toList xs)
206 #endif
207
208 instance Read a => Read (Seq a) where
209 #ifdef __GLASGOW_HASKELL__
210 readPrec = parens $ prec 10 $ do
211 Ident "fromList" <- lexP
212 xs <- readPrec
213 return (fromList xs)
214
215 readListPrec = readListPrecDefault
216 #else
217 readsPrec p = readParen (p > 10) $ \ r -> do
218 ("fromList",s) <- lex r
219 (xs,t) <- reads s
220 return (fromList xs,t)
221 #endif
222
223 instance Monoid (Seq a) where
224 mempty = empty
225 mappend = (><)
226
227 #include "Typeable.h"
228 INSTANCE_TYPEABLE1(Seq,seqTc,"Seq")
229
230 #if __GLASGOW_HASKELL__
231 instance Data a => Data (Seq a) where
232 gfoldl f z s = case viewl s of
233 EmptyL -> z empty
234 x :< xs -> z (<|) `f` x `f` xs
235
236 gunfold k z c = case constrIndex c of
237 1 -> z empty
238 2 -> k (k (z (<|)))
239 _ -> error "gunfold"
240
241 toConstr xs
242 | null xs = emptyConstr
243 | otherwise = consConstr
244
245 dataTypeOf _ = seqDataType
246
247 dataCast1 f = gcast1 f
248
249 emptyConstr, consConstr :: Constr
250 emptyConstr = mkConstr seqDataType "empty" [] Prefix
251 consConstr = mkConstr seqDataType "<|" [] Infix
252
253 seqDataType :: DataType
254 seqDataType = mkDataType "Data.Sequence.Seq" [emptyConstr, consConstr]
255 #endif
256
257 -- Finger trees
258
259 data FingerTree a
260 = Empty
261 | Single a
262 | Deep {-# UNPACK #-} !Int !(Digit a) (FingerTree (Node a)) !(Digit a)
263 #if TESTING
264 deriving Show
265 #endif
266
267 instance Sized a => Sized (FingerTree a) where
268 {-# SPECIALIZE instance Sized (FingerTree (Elem a)) #-}
269 {-# SPECIALIZE instance Sized (FingerTree (Node a)) #-}
270 size Empty = 0
271 size (Single x) = size x
272 size (Deep v _ _ _) = v
273
274 instance Foldable FingerTree where
275 foldr _ z Empty = z
276 foldr f z (Single x) = x `f` z
277 foldr f z (Deep _ pr m sf) =
278 foldr f (foldr (flip (foldr f)) (foldr f z sf) m) pr
279
280 foldl _ z Empty = z
281 foldl f z (Single x) = z `f` x
282 foldl f z (Deep _ pr m sf) =
283 foldl f (foldl (foldl f) (foldl f z pr) m) sf
284
285 foldr1 _ Empty = error "foldr1: empty sequence"
286 foldr1 _ (Single x) = x
287 foldr1 f (Deep _ pr m sf) =
288 foldr f (foldr (flip (foldr f)) (foldr1 f sf) m) pr
289
290 foldl1 _ Empty = error "foldl1: empty sequence"
291 foldl1 _ (Single x) = x
292 foldl1 f (Deep _ pr m sf) =
293 foldl f (foldl (foldl f) (foldl1 f pr) m) sf
294
295 instance Functor FingerTree where
296 fmap _ Empty = Empty
297 fmap f (Single x) = Single (f x)
298 fmap f (Deep v pr m sf) =
299 Deep v (fmap f pr) (fmap (fmap f) m) (fmap f sf)
300
301 instance Traversable FingerTree where
302 traverse _ Empty = pure Empty
303 traverse f (Single x) = Single <$> f x
304 traverse f (Deep v pr m sf) =
305 Deep v <$> traverse f pr <*> traverse (traverse f) m <*>
306 traverse f sf
307
308 {-# INLINE deep #-}
309 {-# SPECIALIZE INLINE deep :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
310 {-# SPECIALIZE INLINE deep :: Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}
311 deep :: Sized a => Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a
312 deep pr m sf = Deep (size pr + size m + size sf) pr m sf
313
314 {-# INLINE pullL #-}
315 pullL :: Sized a => Int -> FingerTree (Node a) -> Digit a -> FingerTree a
316 pullL s m sf = case viewLTree m of
317 Nothing2 -> digitToTree' s sf
318 Just2 pr m' -> Deep s (nodeToDigit pr) m' sf
319
320 {-# INLINE pullR #-}
321 pullR :: Sized a => Int -> Digit a -> FingerTree (Node a) -> FingerTree a
322 pullR s pr m = case viewRTree m of
323 Nothing2 -> digitToTree' s pr
324 Just2 m' sf -> Deep s pr m' (nodeToDigit sf)
325
326 {-# SPECIALIZE deepL :: Maybe (Digit (Elem a)) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
327 {-# SPECIALIZE deepL :: Maybe (Digit (Node a)) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}
328 deepL :: Sized a => Maybe (Digit a) -> FingerTree (Node a) -> Digit a -> FingerTree a
329 deepL Nothing m sf = pullL (size m + size sf) m sf
330 deepL (Just pr) m sf = deep pr m sf
331
332 {-# SPECIALIZE deepR :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Maybe (Digit (Elem a)) -> FingerTree (Elem a) #-}
333 {-# SPECIALIZE deepR :: Digit (Node a) -> FingerTree (Node (Node a)) -> Maybe (Digit (Node a)) -> FingerTree (Node a) #-}
334 deepR :: Sized a => Digit a -> FingerTree (Node a) -> Maybe (Digit a) -> FingerTree a
335 deepR pr m Nothing = pullR (size m + size pr) pr m
336 deepR pr m (Just sf) = deep pr m sf
337
338 -- Digits
339
340 data Digit a
341 = One a
342 | Two a a
343 | Three a a a
344 | Four a a a a
345 #if TESTING
346 deriving Show
347 #endif
348
349 instance Foldable Digit where
350 foldr f z (One a) = a `f` z
351 foldr f z (Two a b) = a `f` (b `f` z)
352 foldr f z (Three a b c) = a `f` (b `f` (c `f` z))
353 foldr f z (Four a b c d) = a `f` (b `f` (c `f` (d `f` z)))
354
355 foldl f z (One a) = z `f` a
356 foldl f z (Two a b) = (z `f` a) `f` b
357 foldl f z (Three a b c) = ((z `f` a) `f` b) `f` c
358 foldl f z (Four a b c d) = (((z `f` a) `f` b) `f` c) `f` d
359
360 foldr1 _ (One a) = a
361 foldr1 f (Two a b) = a `f` b
362 foldr1 f (Three a b c) = a `f` (b `f` c)
363 foldr1 f (Four a b c d) = a `f` (b `f` (c `f` d))
364
365 foldl1 _ (One a) = a
366 foldl1 f (Two a b) = a `f` b
367 foldl1 f (Three a b c) = (a `f` b) `f` c
368 foldl1 f (Four a b c d) = ((a `f` b) `f` c) `f` d
369
370 instance Functor Digit where
371 {-# INLINE fmap #-}
372 fmap f (One a) = One (f a)
373 fmap f (Two a b) = Two (f a) (f b)
374 fmap f (Three a b c) = Three (f a) (f b) (f c)
375 fmap f (Four a b c d) = Four (f a) (f b) (f c) (f d)
376
377 instance Traversable Digit where
378 {-# INLINE traverse #-}
379 traverse f (One a) = One <$> f a
380 traverse f (Two a b) = Two <$> f a <*> f b
381 traverse f (Three a b c) = Three <$> f a <*> f b <*> f c
382 traverse f (Four a b c d) = Four <$> f a <*> f b <*> f c <*> f d
383
384 instance Sized a => Sized (Digit a) where
385 {-# INLINE size #-}
386 size = foldl1 (+) . fmap size
387
388 {-# SPECIALIZE digitToTree :: Digit (Elem a) -> FingerTree (Elem a) #-}
389 {-# SPECIALIZE digitToTree :: Digit (Node a) -> FingerTree (Node a) #-}
390 digitToTree :: Sized a => Digit a -> FingerTree a
391 digitToTree (One a) = Single a
392 digitToTree (Two a b) = deep (One a) Empty (One b)
393 digitToTree (Three a b c) = deep (Two a b) Empty (One c)
394 digitToTree (Four a b c d) = deep (Two a b) Empty (Two c d)
395
396 -- | Given the size of a digit and the digit itself, efficiently converts
397 -- it to a FingerTree.
398 digitToTree' :: Int -> Digit a -> FingerTree a
399 digitToTree' n (Four a b c d) = Deep n (Two a b) Empty (Two c d)
400 digitToTree' n (Three a b c) = Deep n (Two a b) Empty (One c)
401 digitToTree' n (Two a b) = Deep n (One a) Empty (One b)
402 digitToTree' n (One a) = n `seq` Single a
403
404 -- Nodes
405
406 data Node a
407 = Node2 {-# UNPACK #-} !Int a a
408 | Node3 {-# UNPACK #-} !Int a a a
409 #if TESTING
410 deriving Show
411 #endif
412
413 instance Foldable Node where
414 foldr f z (Node2 _ a b) = a `f` (b `f` z)
415 foldr f z (Node3 _ a b c) = a `f` (b `f` (c `f` z))
416
417 foldl f z (Node2 _ a b) = (z `f` a) `f` b
418 foldl f z (Node3 _ a b c) = ((z `f` a) `f` b) `f` c
419
420 instance Functor Node where
421 {-# INLINE fmap #-}
422 fmap f (Node2 v a b) = Node2 v (f a) (f b)
423 fmap f (Node3 v a b c) = Node3 v (f a) (f b) (f c)
424
425 instance Traversable Node where
426 {-# INLINE traverse #-}
427 traverse f (Node2 v a b) = Node2 v <$> f a <*> f b
428 traverse f (Node3 v a b c) = Node3 v <$> f a <*> f b <*> f c
429
430 instance Sized (Node a) where
431 size (Node2 v _ _) = v
432 size (Node3 v _ _ _) = v
433
434 {-# INLINE node2 #-}
435 {-# SPECIALIZE node2 :: Elem a -> Elem a -> Node (Elem a) #-}
436 {-# SPECIALIZE node2 :: Node a -> Node a -> Node (Node a) #-}
437 node2 :: Sized a => a -> a -> Node a
438 node2 a b = Node2 (size a + size b) a b
439
440 {-# INLINE node3 #-}
441 {-# SPECIALIZE node3 :: Elem a -> Elem a -> Elem a -> Node (Elem a) #-}
442 {-# SPECIALIZE node3 :: Node a -> Node a -> Node a -> Node (Node a) #-}
443 node3 :: Sized a => a -> a -> a -> Node a
444 node3 a b c = Node3 (size a + size b + size c) a b c
445
446 nodeToDigit :: Node a -> Digit a
447 nodeToDigit (Node2 _ a b) = Two a b
448 nodeToDigit (Node3 _ a b c) = Three a b c
449
450 -- Elements
451
452 newtype Elem a = Elem { getElem :: a }
453
454 instance Sized (Elem a) where
455 size _ = 1
456
457 instance Functor Elem where
458 fmap f (Elem x) = Elem (f x)
459
460 instance Foldable Elem where
461 foldr f z (Elem x) = f x z
462 foldl f z (Elem x) = f z x
463
464 instance Traversable Elem where
465 traverse f (Elem x) = Elem <$> f x
466
467 #ifdef TESTING
468 instance (Show a) => Show (Elem a) where
469 showsPrec p (Elem x) = showsPrec p x
470 #endif
471
472 -------------------------------------------------------
473 -- Applicative construction
474 -------------------------------------------------------
475
476 newtype Id a = Id {runId :: a}
477
478 instance Functor Id where
479 fmap f (Id x) = Id (f x)
480
481 instance Monad Id where
482 return = Id
483 m >>= k = k (runId m)
484
485 instance Applicative Id where
486 pure = return
487 (<*>) = ap
488
489 -- | This is essentially a clone of Control.Monad.State.Strict.
490 newtype State s a = State {runState :: s -> (s, a)}
491
492 instance Functor (State s) where
493 fmap = liftA
494
495 instance Monad (State s) where
496 {-# INLINE return #-}
497 {-# INLINE (>>=) #-}
498 return x = State $ \ s -> (s, x)
499 m >>= k = State $ \ s -> case runState m s of
500 (s', x) -> runState (k x) s'
501
502 instance Applicative (State s) where
503 pure = return
504 (<*>) = ap
505
506 execState :: State s a -> s -> a
507 execState m x = snd (runState m x)
508
509 -- | A helper method: a strict version of mapAccumL.
510 mapAccumL' :: Traversable t => (a -> b -> (a, c)) -> a -> t b -> (a, t c)
511 mapAccumL' f s t = runState (traverse (State . flip f) t) s
512
513 -- | 'applicativeTree' takes an Applicative-wrapped construction of a
514 -- piece of a FingerTree, assumed to always have the same size (which
515 -- is put in the second argument), and replicates it as many times as
516 -- specified. This is a generalization of 'replicateA', which itself
517 -- is a generalization of many Data.Sequence methods.
518 {-# SPECIALIZE applicativeTree :: Int -> Int -> State s a -> State s (FingerTree a) #-}
519 {-# SPECIALIZE applicativeTree :: Int -> Int -> Id a -> Id (FingerTree a) #-}
520 -- Special note: the Id specialization automatically does node sharing,
521 -- reducing memory usage of the resulting tree to /O(log n)/.
522 applicativeTree :: Applicative f => Int -> Int -> f a -> f (FingerTree a)
523 applicativeTree n mSize m = mSize `seq` case n of
524 0 -> pure Empty
525 1 -> liftA Single m
526 2 -> deepA one emptyTree one
527 3 -> deepA two emptyTree one
528 4 -> deepA two emptyTree two
529 5 -> deepA three emptyTree two
530 6 -> deepA three emptyTree three
531 7 -> deepA four emptyTree three
532 8 -> deepA four emptyTree four
533 _ -> let (q, r) = n `quotRem` 3 in q `seq` case r of
534 0 -> deepA three (applicativeTree (q - 2) mSize' n3) three
535 1 -> deepA four (applicativeTree (q - 2) mSize' n3) three
536 _ -> deepA four (applicativeTree (q - 2) mSize' n3) four
537 where
538 one = liftA One m
539 two = liftA2 Two m m
540 three = liftA3 Three m m m
541 four = liftA3 Four m m m <*> m
542 deepA = liftA3 (Deep (n * mSize))
543 mSize' = 3 * mSize
544 n3 = liftA3 (Node3 mSize') m m m
545 emptyTree = pure Empty
546
547 ------------------------------------------------------------------------
548 -- Construction
549 ------------------------------------------------------------------------
550
551 -- | /O(1)/. The empty sequence.
552 empty :: Seq a
553 empty = Seq Empty
554
555 -- | /O(1)/. A singleton sequence.
556 singleton :: a -> Seq a
557 singleton x = Seq (Single (Elem x))
558
559 -- | /O(log n)/. @replicate n x@ is a sequence consisting of @n@ copies of @x@.
560 replicate :: Int -> a -> Seq a
561 replicate n x
562 | n >= 0 = runId (replicateA n (Id x))
563 | otherwise = error "replicate takes a nonnegative integer argument"
564
565 -- | 'replicateA' is an 'Applicative' version of 'replicate', and makes
566 -- /O(log n)/ calls to '<*>' and 'pure'.
567 --
568 -- > replicateA n x = sequenceA (replicate n x)
569 replicateA :: Applicative f => Int -> f a -> f (Seq a)
570 replicateA n x
571 | n >= 0 = Seq <$> applicativeTree n 1 (Elem <$> x)
572 | otherwise = error "replicateA takes a nonnegative integer argument"
573
574 -- | 'replicateM' is a sequence counterpart of 'Control.Monad.replicateM'.
575 --
576 -- > replicateM n x = sequence (replicate n x)
577 replicateM :: Monad m => Int -> m a -> m (Seq a)
578 replicateM n x
579 | n >= 0 = unwrapMonad (replicateA n (WrapMonad x))
580 | otherwise = error "replicateM takes a nonnegative integer argument"
581
582 -- | /O(1)/. Add an element to the left end of a sequence.
583 -- Mnemonic: a triangle with the single element at the pointy end.
584 (<|) :: a -> Seq a -> Seq a
585 x <| Seq xs = Seq (Elem x `consTree` xs)
586
587 {-# SPECIALIZE consTree :: Elem a -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
588 {-# SPECIALIZE consTree :: Node a -> FingerTree (Node a) -> FingerTree (Node a) #-}
589 consTree :: Sized a => a -> FingerTree a -> FingerTree a
590 consTree a Empty = Single a
591 consTree a (Single b) = deep (One a) Empty (One b)
592 consTree a (Deep s (Four b c d e) m sf) = m `seq`
593 Deep (size a + s) (Two a b) (node3 c d e `consTree` m) sf
594 consTree a (Deep s (Three b c d) m sf) =
595 Deep (size a + s) (Four a b c d) m sf
596 consTree a (Deep s (Two b c) m sf) =
597 Deep (size a + s) (Three a b c) m sf
598 consTree a (Deep s (One b) m sf) =
599 Deep (size a + s) (Two a b) m sf
600
601 -- | /O(1)/. Add an element to the right end of a sequence.
602 -- Mnemonic: a triangle with the single element at the pointy end.
603 (|>) :: Seq a -> a -> Seq a
604 Seq xs |> x = Seq (xs `snocTree` Elem x)
605
606 {-# SPECIALIZE snocTree :: FingerTree (Elem a) -> Elem a -> FingerTree (Elem a) #-}
607 {-# SPECIALIZE snocTree :: FingerTree (Node a) -> Node a -> FingerTree (Node a) #-}
608 snocTree :: Sized a => FingerTree a -> a -> FingerTree a
609 snocTree Empty a = Single a
610 snocTree (Single a) b = deep (One a) Empty (One b)
611 snocTree (Deep s pr m (Four a b c d)) e = m `seq`
612 Deep (s + size e) pr (m `snocTree` node3 a b c) (Two d e)
613 snocTree (Deep s pr m (Three a b c)) d =
614 Deep (s + size d) pr m (Four a b c d)
615 snocTree (Deep s pr m (Two a b)) c =
616 Deep (s + size c) pr m (Three a b c)
617 snocTree (Deep s pr m (One a)) b =
618 Deep (s + size b) pr m (Two a b)
619
620 -- | /O(log(min(n1,n2)))/. Concatenate two sequences.
621 (><) :: Seq a -> Seq a -> Seq a
622 Seq xs >< Seq ys = Seq (appendTree0 xs ys)
623
624 -- The appendTree/addDigits gunk below is machine generated
625
626 appendTree0 :: FingerTree (Elem a) -> FingerTree (Elem a) -> FingerTree (Elem a)
627 appendTree0 Empty xs =
628 xs
629 appendTree0 xs Empty =
630 xs
631 appendTree0 (Single x) xs =
632 x `consTree` xs
633 appendTree0 xs (Single x) =
634 xs `snocTree` x
635 appendTree0 (Deep s1 pr1 m1 sf1) (Deep s2 pr2 m2 sf2) =
636 Deep (s1 + s2) pr1 (addDigits0 m1 sf1 pr2 m2) sf2
637
638 addDigits0 :: FingerTree (Node (Elem a)) -> Digit (Elem a) -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> FingerTree (Node (Elem a))
639 addDigits0 m1 (One a) (One b) m2 =
640 appendTree1 m1 (node2 a b) m2
641 addDigits0 m1 (One a) (Two b c) m2 =
642 appendTree1 m1 (node3 a b c) m2
643 addDigits0 m1 (One a) (Three b c d) m2 =
644 appendTree2 m1 (node2 a b) (node2 c d) m2
645 addDigits0 m1 (One a) (Four b c d e) m2 =
646 appendTree2 m1 (node3 a b c) (node2 d e) m2
647 addDigits0 m1 (Two a b) (One c) m2 =
648 appendTree1 m1 (node3 a b c) m2
649 addDigits0 m1 (Two a b) (Two c d) m2 =
650 appendTree2 m1 (node2 a b) (node2 c d) m2
651 addDigits0 m1 (Two a b) (Three c d e) m2 =
652 appendTree2 m1 (node3 a b c) (node2 d e) m2
653 addDigits0 m1 (Two a b) (Four c d e f) m2 =
654 appendTree2 m1 (node3 a b c) (node3 d e f) m2
655 addDigits0 m1 (Three a b c) (One d) m2 =
656 appendTree2 m1 (node2 a b) (node2 c d) m2
657 addDigits0 m1 (Three a b c) (Two d e) m2 =
658 appendTree2 m1 (node3 a b c) (node2 d e) m2
659 addDigits0 m1 (Three a b c) (Three d e f) m2 =
660 appendTree2 m1 (node3 a b c) (node3 d e f) m2
661 addDigits0 m1 (Three a b c) (Four d e f g) m2 =
662 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
663 addDigits0 m1 (Four a b c d) (One e) m2 =
664 appendTree2 m1 (node3 a b c) (node2 d e) m2
665 addDigits0 m1 (Four a b c d) (Two e f) m2 =
666 appendTree2 m1 (node3 a b c) (node3 d e f) m2
667 addDigits0 m1 (Four a b c d) (Three e f g) m2 =
668 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
669 addDigits0 m1 (Four a b c d) (Four e f g h) m2 =
670 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
671
672 appendTree1 :: FingerTree (Node a) -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
673 appendTree1 Empty a xs =
674 a `consTree` xs
675 appendTree1 xs a Empty =
676 xs `snocTree` a
677 appendTree1 (Single x) a xs =
678 x `consTree` a `consTree` xs
679 appendTree1 xs a (Single x) =
680 xs `snocTree` a `snocTree` x
681 appendTree1 (Deep s1 pr1 m1 sf1) a (Deep s2 pr2 m2 sf2) =
682 Deep (s1 + size a + s2) pr1 (addDigits1 m1 sf1 a pr2 m2) sf2
683
684 addDigits1 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
685 addDigits1 m1 (One a) b (One c) m2 =
686 appendTree1 m1 (node3 a b c) m2
687 addDigits1 m1 (One a) b (Two c d) m2 =
688 appendTree2 m1 (node2 a b) (node2 c d) m2
689 addDigits1 m1 (One a) b (Three c d e) m2 =
690 appendTree2 m1 (node3 a b c) (node2 d e) m2
691 addDigits1 m1 (One a) b (Four c d e f) m2 =
692 appendTree2 m1 (node3 a b c) (node3 d e f) m2
693 addDigits1 m1 (Two a b) c (One d) m2 =
694 appendTree2 m1 (node2 a b) (node2 c d) m2
695 addDigits1 m1 (Two a b) c (Two d e) m2 =
696 appendTree2 m1 (node3 a b c) (node2 d e) m2
697 addDigits1 m1 (Two a b) c (Three d e f) m2 =
698 appendTree2 m1 (node3 a b c) (node3 d e f) m2
699 addDigits1 m1 (Two a b) c (Four d e f g) m2 =
700 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
701 addDigits1 m1 (Three a b c) d (One e) m2 =
702 appendTree2 m1 (node3 a b c) (node2 d e) m2
703 addDigits1 m1 (Three a b c) d (Two e f) m2 =
704 appendTree2 m1 (node3 a b c) (node3 d e f) m2
705 addDigits1 m1 (Three a b c) d (Three e f g) m2 =
706 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
707 addDigits1 m1 (Three a b c) d (Four e f g h) m2 =
708 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
709 addDigits1 m1 (Four a b c d) e (One f) m2 =
710 appendTree2 m1 (node3 a b c) (node3 d e f) m2
711 addDigits1 m1 (Four a b c d) e (Two f g) m2 =
712 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
713 addDigits1 m1 (Four a b c d) e (Three f g h) m2 =
714 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
715 addDigits1 m1 (Four a b c d) e (Four f g h i) m2 =
716 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
717
718 appendTree2 :: FingerTree (Node a) -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
719 appendTree2 Empty a b xs =
720 a `consTree` b `consTree` xs
721 appendTree2 xs a b Empty =
722 xs `snocTree` a `snocTree` b
723 appendTree2 (Single x) a b xs =
724 x `consTree` a `consTree` b `consTree` xs
725 appendTree2 xs a b (Single x) =
726 xs `snocTree` a `snocTree` b `snocTree` x
727 appendTree2 (Deep s1 pr1 m1 sf1) a b (Deep s2 pr2 m2 sf2) =
728 Deep (s1 + size a + size b + s2) pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2
729
730 addDigits2 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
731 addDigits2 m1 (One a) b c (One d) m2 =
732 appendTree2 m1 (node2 a b) (node2 c d) m2
733 addDigits2 m1 (One a) b c (Two d e) m2 =
734 appendTree2 m1 (node3 a b c) (node2 d e) m2
735 addDigits2 m1 (One a) b c (Three d e f) m2 =
736 appendTree2 m1 (node3 a b c) (node3 d e f) m2
737 addDigits2 m1 (One a) b c (Four d e f g) m2 =
738 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
739 addDigits2 m1 (Two a b) c d (One e) m2 =
740 appendTree2 m1 (node3 a b c) (node2 d e) m2
741 addDigits2 m1 (Two a b) c d (Two e f) m2 =
742 appendTree2 m1 (node3 a b c) (node3 d e f) m2
743 addDigits2 m1 (Two a b) c d (Three e f g) m2 =
744 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
745 addDigits2 m1 (Two a b) c d (Four e f g h) m2 =
746 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
747 addDigits2 m1 (Three a b c) d e (One f) m2 =
748 appendTree2 m1 (node3 a b c) (node3 d e f) m2
749 addDigits2 m1 (Three a b c) d e (Two f g) m2 =
750 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
751 addDigits2 m1 (Three a b c) d e (Three f g h) m2 =
752 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
753 addDigits2 m1 (Three a b c) d e (Four f g h i) m2 =
754 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
755 addDigits2 m1 (Four a b c d) e f (One g) m2 =
756 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
757 addDigits2 m1 (Four a b c d) e f (Two g h) m2 =
758 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
759 addDigits2 m1 (Four a b c d) e f (Three g h i) m2 =
760 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
761 addDigits2 m1 (Four a b c d) e f (Four g h i j) m2 =
762 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
763
764 appendTree3 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
765 appendTree3 Empty a b c xs =
766 a `consTree` b `consTree` c `consTree` xs
767 appendTree3 xs a b c Empty =
768 xs `snocTree` a `snocTree` b `snocTree` c
769 appendTree3 (Single x) a b c xs =
770 x `consTree` a `consTree` b `consTree` c `consTree` xs
771 appendTree3 xs a b c (Single x) =
772 xs `snocTree` a `snocTree` b `snocTree` c `snocTree` x
773 appendTree3 (Deep s1 pr1 m1 sf1) a b c (Deep s2 pr2 m2 sf2) =
774 Deep (s1 + size a + size b + size c + s2) pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2
775
776 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))
777 addDigits3 m1 (One a) b c d (One e) m2 =
778 appendTree2 m1 (node3 a b c) (node2 d e) m2
779 addDigits3 m1 (One a) b c d (Two e f) m2 =
780 appendTree2 m1 (node3 a b c) (node3 d e f) m2
781 addDigits3 m1 (One a) b c d (Three e f g) m2 =
782 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
783 addDigits3 m1 (One a) b c d (Four e f g h) m2 =
784 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
785 addDigits3 m1 (Two a b) c d e (One f) m2 =
786 appendTree2 m1 (node3 a b c) (node3 d e f) m2
787 addDigits3 m1 (Two a b) c d e (Two f g) m2 =
788 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
789 addDigits3 m1 (Two a b) c d e (Three f g h) m2 =
790 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
791 addDigits3 m1 (Two a b) c d e (Four f g h i) m2 =
792 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
793 addDigits3 m1 (Three a b c) d e f (One g) m2 =
794 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
795 addDigits3 m1 (Three a b c) d e f (Two g h) m2 =
796 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
797 addDigits3 m1 (Three a b c) d e f (Three g h i) m2 =
798 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
799 addDigits3 m1 (Three a b c) d e f (Four g h i j) m2 =
800 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
801 addDigits3 m1 (Four a b c d) e f g (One h) m2 =
802 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
803 addDigits3 m1 (Four a b c d) e f g (Two h i) m2 =
804 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
805 addDigits3 m1 (Four a b c d) e f g (Three h i j) m2 =
806 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
807 addDigits3 m1 (Four a b c d) e f g (Four h i j k) m2 =
808 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
809
810 appendTree4 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
811 appendTree4 Empty a b c d xs =
812 a `consTree` b `consTree` c `consTree` d `consTree` xs
813 appendTree4 xs a b c d Empty =
814 xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d
815 appendTree4 (Single x) a b c d xs =
816 x `consTree` a `consTree` b `consTree` c `consTree` d `consTree` xs
817 appendTree4 xs a b c d (Single x) =
818 xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d `snocTree` x
819 appendTree4 (Deep s1 pr1 m1 sf1) a b c d (Deep s2 pr2 m2 sf2) =
820 Deep (s1 + size a + size b + size c + size d + s2) pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2
821
822 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))
823 addDigits4 m1 (One a) b c d e (One f) m2 =
824 appendTree2 m1 (node3 a b c) (node3 d e f) m2
825 addDigits4 m1 (One a) b c d e (Two f g) m2 =
826 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
827 addDigits4 m1 (One a) b c d e (Three f g h) m2 =
828 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
829 addDigits4 m1 (One a) b c d e (Four f g h i) m2 =
830 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
831 addDigits4 m1 (Two a b) c d e f (One g) m2 =
832 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
833 addDigits4 m1 (Two a b) c d e f (Two g h) m2 =
834 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
835 addDigits4 m1 (Two a b) c d e f (Three g h i) m2 =
836 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
837 addDigits4 m1 (Two a b) c d e f (Four g h i j) m2 =
838 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
839 addDigits4 m1 (Three a b c) d e f g (One h) m2 =
840 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
841 addDigits4 m1 (Three a b c) d e f g (Two h i) m2 =
842 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
843 addDigits4 m1 (Three a b c) d e f g (Three h i j) m2 =
844 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
845 addDigits4 m1 (Three a b c) d e f g (Four h i j k) m2 =
846 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
847 addDigits4 m1 (Four a b c d) e f g h (One i) m2 =
848 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
849 addDigits4 m1 (Four a b c d) e f g h (Two i j) m2 =
850 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
851 addDigits4 m1 (Four a b c d) e f g h (Three i j k) m2 =
852 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
853 addDigits4 m1 (Four a b c d) e f g h (Four i j k l) m2 =
854 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2
855
856 -- | Builds a sequence from a seed value. Takes time linear in the
857 -- number of generated elements. /WARNING:/ If the number of generated
858 -- elements is infinite, this method will not terminate.
859 unfoldr :: (b -> Maybe (a, b)) -> b -> Seq a
860 unfoldr f = unfoldr' empty
861 -- uses tail recursion rather than, for instance, the List implementation.
862 where unfoldr' as b = maybe as (\ (a, b') -> unfoldr' (as |> a) b') (f b)
863
864 -- | @'unfoldl' f x@ is equivalent to @'reverse' ('unfoldr' ('fmap' swap . f) x)@.
865 unfoldl :: (b -> Maybe (b, a)) -> b -> Seq a
866 unfoldl f = unfoldl' empty
867 where unfoldl' as b = maybe as (\ (b', a) -> unfoldl' (a <| as) b') (f b)
868
869 -- | /O(n)/. Constructs a sequence by repeated application of a function
870 -- to a seed value.
871 --
872 -- > iterateN n f x = fromList (Prelude.take n (Prelude.iterate f x))
873 iterateN :: Int -> (a -> a) -> a -> Seq a
874 iterateN n f x
875 | n >= 0 = replicateA n (State (\ y -> (f y, y))) `execState` x
876 | otherwise = error "iterateN takes a nonnegative integer argument"
877
878 ------------------------------------------------------------------------
879 -- Deconstruction
880 ------------------------------------------------------------------------
881
882 -- | /O(1)/. Is this the empty sequence?
883 null :: Seq a -> Bool
884 null (Seq Empty) = True
885 null _ = False
886
887 -- | /O(1)/. The number of elements in the sequence.
888 length :: Seq a -> Int
889 length (Seq xs) = size xs
890
891 -- Views
892
893 data Maybe2 a b = Nothing2 | Just2 a b
894
895 -- | View of the left end of a sequence.
896 data ViewL a
897 = EmptyL -- ^ empty sequence
898 | a :< Seq a -- ^ leftmost element and the rest of the sequence
899 #if __GLASGOW_HASKELL__
900 deriving (Eq, Ord, Show, Read, Data)
901 #else
902 deriving (Eq, Ord, Show, Read)
903 #endif
904
905 INSTANCE_TYPEABLE1(ViewL,viewLTc,"ViewL")
906
907 instance Functor ViewL where
908 {-# INLINE fmap #-}
909 fmap _ EmptyL = EmptyL
910 fmap f (x :< xs) = f x :< fmap f xs
911
912 instance Foldable ViewL where
913 foldr _ z EmptyL = z
914 foldr f z (x :< xs) = f x (foldr f z xs)
915
916 foldl _ z EmptyL = z
917 foldl f z (x :< xs) = foldl f (f z x) xs
918
919 foldl1 _ EmptyL = error "foldl1: empty view"
920 foldl1 f (x :< xs) = foldl f x xs
921
922 instance Traversable ViewL where
923 traverse _ EmptyL = pure EmptyL
924 traverse f (x :< xs) = (:<) <$> f x <*> traverse f xs
925
926 -- | /O(1)/. Analyse the left end of a sequence.
927 viewl :: Seq a -> ViewL a
928 viewl (Seq xs) = case viewLTree xs of
929 Nothing2 -> EmptyL
930 Just2 (Elem x) xs' -> x :< Seq xs'
931
932 {-# SPECIALIZE viewLTree :: FingerTree (Elem a) -> Maybe2 (Elem a) (FingerTree (Elem a)) #-}
933 {-# SPECIALIZE viewLTree :: FingerTree (Node a) -> Maybe2 (Node a) (FingerTree (Node a)) #-}
934 viewLTree :: Sized a => FingerTree a -> Maybe2 a (FingerTree a)
935 viewLTree Empty = Nothing2
936 viewLTree (Single a) = Just2 a Empty
937 viewLTree (Deep s (One a) m sf) = Just2 a (pullL (s - size a) m sf)
938 viewLTree (Deep s (Two a b) m sf) =
939 Just2 a (Deep (s - size a) (One b) m sf)
940 viewLTree (Deep s (Three a b c) m sf) =
941 Just2 a (Deep (s - size a) (Two b c) m sf)
942 viewLTree (Deep s (Four a b c d) m sf) =
943 Just2 a (Deep (s - size a) (Three b c d) m sf)
944
945 -- | View of the right end of a sequence.
946 data ViewR a
947 = EmptyR -- ^ empty sequence
948 | Seq a :> a -- ^ the sequence minus the rightmost element,
949 -- and the rightmost element
950 #if __GLASGOW_HASKELL__
951 deriving (Eq, Ord, Show, Read, Data)
952 #else
953 deriving (Eq, Ord, Show, Read)
954 #endif
955
956 INSTANCE_TYPEABLE1(ViewR,viewRTc,"ViewR")
957
958 instance Functor ViewR where
959 {-# INLINE fmap #-}
960 fmap _ EmptyR = EmptyR
961 fmap f (xs :> x) = fmap f xs :> f x
962
963 instance Foldable ViewR where
964 foldr _ z EmptyR = z
965 foldr f z (xs :> x) = foldr f (f x z) xs
966
967 foldl _ z EmptyR = z
968 foldl f z (xs :> x) = foldl f z xs `f` x
969
970 foldr1 _ EmptyR = error "foldr1: empty view"
971 foldr1 f (xs :> x) = foldr f x xs
972
973 instance Traversable ViewR where
974 traverse _ EmptyR = pure EmptyR
975 traverse f (xs :> x) = (:>) <$> traverse f xs <*> f x
976
977 -- | /O(1)/. Analyse the right end of a sequence.
978 viewr :: Seq a -> ViewR a
979 viewr (Seq xs) = case viewRTree xs of
980 Nothing2 -> EmptyR
981 Just2 xs' (Elem x) -> Seq xs' :> x
982
983 {-# SPECIALIZE viewRTree :: FingerTree (Elem a) -> Maybe2 (FingerTree (Elem a)) (Elem a) #-}
984 {-# SPECIALIZE viewRTree :: FingerTree (Node a) -> Maybe2 (FingerTree (Node a)) (Node a) #-}
985 viewRTree :: Sized a => FingerTree a -> Maybe2 (FingerTree a) a
986 viewRTree Empty = Nothing2
987 viewRTree (Single z) = Just2 Empty z
988 viewRTree (Deep s pr m (One z)) = Just2 (pullR (s - size z) pr m) z
989 viewRTree (Deep s pr m (Two y z)) =
990 Just2 (Deep (s - size z) pr m (One y)) z
991 viewRTree (Deep s pr m (Three x y z)) =
992 Just2 (Deep (s - size z) pr m (Two x y)) z
993 viewRTree (Deep s pr m (Four w x y z)) =
994 Just2 (Deep (s - size z) pr m (Three w x y)) z
995
996 ------------------------------------------------------------------------
997 -- Scans
998 --
999 -- These are not particularly complex applications of the Traversable
1000 -- functor, though making the correspondence with Data.List exact
1001 -- requires the use of (<|) and (|>).
1002 --
1003 -- Note that save for the single (<|) or (|>), we maintain the original
1004 -- structure of the Seq, not having to do any restructuring of our own.
1005 --
1006 -- wasserman.louis@gmail.com, 5/23/09
1007 ------------------------------------------------------------------------
1008
1009 -- | 'scanl' is similar to 'foldl', but returns a sequence of reduced
1010 -- values from the left:
1011 --
1012 -- > scanl f z (fromList [x1, x2, ...]) = fromList [z, z `f` x1, (z `f` x1) `f` x2, ...]
1013 scanl :: (a -> b -> a) -> a -> Seq b -> Seq a
1014 scanl f z0 xs = z0 <| snd (mapAccumL (\ x z -> let x' = f x z in (x', x')) z0 xs)
1015
1016 -- | 'scanl1' is a variant of 'scanl' that has no starting value argument:
1017 --
1018 -- > scanl1 f (fromList [x1, x2, ...]) = fromList [x1, x1 `f` x2, ...]
1019 scanl1 :: (a -> a -> a) -> Seq a -> Seq a
1020 scanl1 f xs = case viewl xs of
1021 EmptyL -> error "scanl1 takes a nonempty sequence as an argument"
1022 x :< xs' -> scanl f x xs'
1023
1024 -- | 'scanr' is the right-to-left dual of 'scanl'.
1025 scanr :: (a -> b -> b) -> b -> Seq a -> Seq b
1026 scanr f z0 xs = snd (mapAccumR (\ z x -> let z' = f x z in (z', z')) z0 xs) |> z0
1027
1028 -- | 'scanr1' is a variant of 'scanr' that has no starting value argument.
1029 scanr1 :: (a -> a -> a) -> Seq a -> Seq a
1030 scanr1 f xs = case viewr xs of
1031 EmptyR -> error "scanr1 takes a nonempty sequence as an argument"
1032 xs' :> x -> scanr f x xs'
1033
1034 -- Indexing
1035
1036 -- | /O(log(min(i,n-i)))/. The element at the specified position,
1037 -- counting from 0. The argument should thus be a non-negative
1038 -- integer less than the size of the sequence.
1039 -- If the position is out of range, 'index' fails with an error.
1040 index :: Seq a -> Int -> a
1041 index (Seq xs) i
1042 | 0 <= i && i < size xs = case lookupTree i xs of
1043 Place _ (Elem x) -> x
1044 | otherwise = error "index out of bounds"
1045
1046 data Place a = Place {-# UNPACK #-} !Int a
1047 #if TESTING
1048 deriving Show
1049 #endif
1050
1051 {-# SPECIALIZE lookupTree :: Int -> FingerTree (Elem a) -> Place (Elem a) #-}
1052 {-# SPECIALIZE lookupTree :: Int -> FingerTree (Node a) -> Place (Node a) #-}
1053 lookupTree :: Sized a => Int -> FingerTree a -> Place a
1054 lookupTree _ Empty = error "lookupTree of empty tree"
1055 lookupTree i (Single x) = Place i x
1056 lookupTree i (Deep _ pr m sf)
1057 | i < spr = lookupDigit i pr
1058 | i < spm = case lookupTree (i - spr) m of
1059 Place i' xs -> lookupNode i' xs
1060 | otherwise = lookupDigit (i - spm) sf
1061 where
1062 spr = size pr
1063 spm = spr + size m
1064
1065 {-# SPECIALIZE lookupNode :: Int -> Node (Elem a) -> Place (Elem a) #-}
1066 {-# SPECIALIZE lookupNode :: Int -> Node (Node a) -> Place (Node a) #-}
1067 lookupNode :: Sized a => Int -> Node a -> Place a
1068 lookupNode i (Node2 _ a b)
1069 | i < sa = Place i a
1070 | otherwise = Place (i - sa) b
1071 where
1072 sa = size a
1073 lookupNode i (Node3 _ a b c)
1074 | i < sa = Place i a
1075 | i < sab = Place (i - sa) b
1076 | otherwise = Place (i - sab) c
1077 where
1078 sa = size a
1079 sab = sa + size b
1080
1081 {-# SPECIALIZE lookupDigit :: Int -> Digit (Elem a) -> Place (Elem a) #-}
1082 {-# SPECIALIZE lookupDigit :: Int -> Digit (Node a) -> Place (Node a) #-}
1083 lookupDigit :: Sized a => Int -> Digit a -> Place a
1084 lookupDigit i (One a) = Place i a
1085 lookupDigit i (Two a b)
1086 | i < sa = Place i a
1087 | otherwise = Place (i - sa) b
1088 where
1089 sa = size a
1090 lookupDigit i (Three a b c)
1091 | i < sa = Place i a
1092 | i < sab = Place (i - sa) b
1093 | otherwise = Place (i - sab) c
1094 where
1095 sa = size a
1096 sab = sa + size b
1097 lookupDigit i (Four a b c d)
1098 | i < sa = Place i a
1099 | i < sab = Place (i - sa) b
1100 | i < sabc = Place (i - sab) c
1101 | otherwise = Place (i - sabc) d
1102 where
1103 sa = size a
1104 sab = sa + size b
1105 sabc = sab + size c
1106
1107 -- | /O(log(min(i,n-i)))/. Replace the element at the specified position.
1108 -- If the position is out of range, the original sequence is returned.
1109 update :: Int -> a -> Seq a -> Seq a
1110 update i x = adjust (const x) i
1111
1112 -- | /O(log(min(i,n-i)))/. Update the element at the specified position.
1113 -- If the position is out of range, the original sequence is returned.
1114 adjust :: (a -> a) -> Int -> Seq a -> Seq a
1115 adjust f i (Seq xs)
1116 | 0 <= i && i < size xs = Seq (adjustTree (const (fmap f)) i xs)
1117 | otherwise = Seq xs
1118
1119 {-# SPECIALIZE adjustTree :: (Int -> Elem a -> Elem a) -> Int -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
1120 {-# SPECIALIZE adjustTree :: (Int -> Node a -> Node a) -> Int -> FingerTree (Node a) -> FingerTree (Node a) #-}
1121 adjustTree :: Sized a => (Int -> a -> a) ->
1122 Int -> FingerTree a -> FingerTree a
1123 adjustTree _ _ Empty = error "adjustTree of empty tree"
1124 adjustTree f i (Single x) = Single (f i x)
1125 adjustTree f i (Deep s pr m sf)
1126 | i < spr = Deep s (adjustDigit f i pr) m sf
1127 | i < spm = Deep s pr (adjustTree (adjustNode f) (i - spr) m) sf
1128 | otherwise = Deep s pr m (adjustDigit f (i - spm) sf)
1129 where
1130 spr = size pr
1131 spm = spr + size m
1132
1133 {-# SPECIALIZE adjustNode :: (Int -> Elem a -> Elem a) -> Int -> Node (Elem a) -> Node (Elem a) #-}
1134 {-# SPECIALIZE adjustNode :: (Int -> Node a -> Node a) -> Int -> Node (Node a) -> Node (Node a) #-}
1135 adjustNode :: Sized a => (Int -> a -> a) -> Int -> Node a -> Node a
1136 adjustNode f i (Node2 s a b)
1137 | i < sa = Node2 s (f i a) b
1138 | otherwise = Node2 s a (f (i - sa) b)
1139 where
1140 sa = size a
1141 adjustNode f i (Node3 s a b c)
1142 | i < sa = Node3 s (f i a) b c
1143 | i < sab = Node3 s a (f (i - sa) b) c
1144 | otherwise = Node3 s a b (f (i - sab) c)
1145 where
1146 sa = size a
1147 sab = sa + size b
1148
1149 {-# SPECIALIZE adjustDigit :: (Int -> Elem a -> Elem a) -> Int -> Digit (Elem a) -> Digit (Elem a) #-}
1150 {-# SPECIALIZE adjustDigit :: (Int -> Node a -> Node a) -> Int -> Digit (Node a) -> Digit (Node a) #-}
1151 adjustDigit :: Sized a => (Int -> a -> a) -> Int -> Digit a -> Digit a
1152 adjustDigit f i (One a) = One (f i a)
1153 adjustDigit f i (Two a b)
1154 | i < sa = Two (f i a) b
1155 | otherwise = Two a (f (i - sa) b)
1156 where
1157 sa = size a
1158 adjustDigit f i (Three a b c)
1159 | i < sa = Three (f i a) b c
1160 | i < sab = Three a (f (i - sa) b) c
1161 | otherwise = Three a b (f (i - sab) c)
1162 where
1163 sa = size a
1164 sab = sa + size b
1165 adjustDigit f i (Four a b c d)
1166 | i < sa = Four (f i a) b c d
1167 | i < sab = Four a (f (i - sa) b) c d
1168 | i < sabc = Four a b (f (i - sab) c) d
1169 | otherwise = Four a b c (f (i- sabc) d)
1170 where
1171 sa = size a
1172 sab = sa + size b
1173 sabc = sab + size c
1174
1175 -- | A generalization of 'fmap', 'mapWithIndex' takes a mapping function
1176 -- that also depends on the element's index, and applies it to every
1177 -- element in the sequence.
1178 mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b
1179 mapWithIndex f xs = snd (mapAccumL' (\ i x -> (i + 1, f i x)) 0 xs)
1180
1181 -- Splitting
1182
1183 -- | /O(log(min(i,n-i)))/. The first @i@ elements of a sequence.
1184 -- If @i@ is negative, @'take' i s@ yields the empty sequence.
1185 -- If the sequence contains fewer than @i@ elements, the whole sequence
1186 -- is returned.
1187 take :: Int -> Seq a -> Seq a
1188 take i = fst . splitAt i
1189
1190 -- | /O(log(min(i,n-i)))/. Elements of a sequence after the first @i@.
1191 -- If @i@ is negative, @'drop' i s@ yields the whole sequence.
1192 -- If the sequence contains fewer than @i@ elements, the empty sequence
1193 -- is returned.
1194 drop :: Int -> Seq a -> Seq a
1195 drop i = snd . splitAt i
1196
1197 -- | /O(log(min(i,n-i)))/. Split a sequence at a given position.
1198 -- @'splitAt' i s = ('take' i s, 'drop' i s)@.
1199 splitAt :: Int -> Seq a -> (Seq a, Seq a)
1200 splitAt i (Seq xs) = (Seq l, Seq r)
1201 where (l, r) = split i xs
1202
1203 split :: Int -> FingerTree (Elem a) ->
1204 (FingerTree (Elem a), FingerTree (Elem a))
1205 split i Empty = i `seq` (Empty, Empty)
1206 split i xs
1207 | size xs > i = (l, consTree x r)
1208 | otherwise = (xs, Empty)
1209 where Split l x r = splitTree i xs
1210
1211 data Split t a = Split t a t
1212 #if TESTING
1213 deriving Show
1214 #endif
1215
1216 {-# SPECIALIZE splitTree :: Int -> FingerTree (Elem a) -> Split (FingerTree (Elem a)) (Elem a) #-}
1217 {-# SPECIALIZE splitTree :: Int -> FingerTree (Node a) -> Split (FingerTree (Node a)) (Node a) #-}
1218 splitTree :: Sized a => Int -> FingerTree a -> Split (FingerTree a) a
1219 splitTree _ Empty = error "splitTree of empty tree"
1220 splitTree i (Single x) = i `seq` Split Empty x Empty
1221 splitTree i (Deep _ pr m sf)
1222 | i < spr = case splitDigit i pr of
1223 Split l x r -> Split (maybe Empty digitToTree l) x (deepL r m sf)
1224 | i < spm = case splitTree im m of
1225 Split ml xs mr -> case splitNode (im - size ml) xs of
1226 Split l x r -> Split (deepR pr ml l) x (deepL r mr sf)
1227 | otherwise = case splitDigit (i - spm) sf of
1228 Split l x r -> Split (deepR pr m l) x (maybe Empty digitToTree r)
1229 where
1230 spr = size pr
1231 spm = spr + size m
1232 im = i - spr
1233
1234 {-# SPECIALIZE splitNode :: Int -> Node (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-}
1235 {-# SPECIALIZE splitNode :: Int -> Node (Node a) -> Split (Maybe (Digit (Node a))) (Node a) #-}
1236 splitNode :: Sized a => Int -> Node a -> Split (Maybe (Digit a)) a
1237 splitNode i (Node2 _ a b)
1238 | i < sa = Split Nothing a (Just (One b))
1239 | otherwise = Split (Just (One a)) b Nothing
1240 where
1241 sa = size a
1242 splitNode i (Node3 _ a b c)
1243 | i < sa = Split Nothing a (Just (Two b c))
1244 | i < sab = Split (Just (One a)) b (Just (One c))
1245 | otherwise = Split (Just (Two a b)) c Nothing
1246 where
1247 sa = size a
1248 sab = sa + size b
1249
1250 {-# SPECIALIZE splitDigit :: Int -> Digit (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-}
1251 {-# SPECIALIZE splitDigit :: Int -> Digit (Node a) -> Split (Maybe (Digit (Node a))) (Node a) #-}
1252 splitDigit :: Sized a => Int -> Digit a -> Split (Maybe (Digit a)) a
1253 splitDigit i (One a) = i `seq` Split Nothing a Nothing
1254 splitDigit i (Two a b)
1255 | i < sa = Split Nothing a (Just (One b))
1256 | otherwise = Split (Just (One a)) b Nothing
1257 where
1258 sa = size a
1259 splitDigit i (Three a b c)
1260 | i < sa = Split Nothing a (Just (Two b c))
1261 | i < sab = Split (Just (One a)) b (Just (One c))
1262 | otherwise = Split (Just (Two a b)) c Nothing
1263 where
1264 sa = size a
1265 sab = sa + size b
1266 splitDigit i (Four a b c d)
1267 | i < sa = Split Nothing a (Just (Three b c d))
1268 | i < sab = Split (Just (One a)) b (Just (Two c d))
1269 | i < sabc = Split (Just (Two a b)) c (Just (One d))
1270 | otherwise = Split (Just (Three a b c)) d Nothing
1271 where
1272 sa = size a
1273 sab = sa + size b
1274 sabc = sab + size c
1275
1276 -- | /O(n)/. Returns a sequence of all suffixes of this sequence,
1277 -- longest first. For example,
1278 --
1279 -- > tails (fromList "abc") = fromList [fromList "abc", fromList "bc", fromList "c", fromList ""]
1280 --
1281 -- Evaluating the /i/th suffix takes /O(log(min(i, n-i)))/, but evaluating
1282 -- every suffix in the sequence takes /O(n)/ due to sharing.
1283 tails :: Seq a -> Seq (Seq a)
1284 tails (Seq xs) = Seq (tailsTree (Elem . Seq) xs) |> empty
1285
1286 -- | /O(n)/. Returns a sequence of all prefixes of this sequence,
1287 -- shortest first. For example,
1288 --
1289 -- > inits (fromList "abc") = fromList [fromList "", fromList "a", fromList "ab", fromList "abc"]
1290 --
1291 -- Evaluating the /i/th prefix takes /O(log(min(i, n-i)))/, but evaluating
1292 -- every prefix in the sequence takes /O(n)/ due to sharing.
1293 inits :: Seq a -> Seq (Seq a)
1294 inits (Seq xs) = empty <| Seq (initsTree (Elem . Seq) xs)
1295
1296 -- This implementation of tails (and, analogously, inits) has the
1297 -- following algorithmic advantages:
1298 -- Evaluating each tail in the sequence takes linear total time,
1299 -- which is better than we could say for
1300 -- @fromList [drop n xs | n <- [0..length xs]]@.
1301 -- Evaluating any individual tail takes logarithmic time, which is
1302 -- better than we can say for either
1303 -- @scanr (<|) empty xs@ or @iterateN (length xs + 1) (\ xs -> let _ :< xs' = viewl xs in xs') xs@.
1304 --
1305 -- Moreover, if we actually look at every tail in the sequence, the
1306 -- following benchmarks demonstrate that this implementation is modestly
1307 -- faster than any of the above:
1308 --
1309 -- Times (ms)
1310 -- min mean +/-sd median max
1311 -- Seq.tails: 21.986 24.961 10.169 22.417 86.485
1312 -- scanr: 85.392 87.942 2.488 87.425 100.217
1313 -- iterateN: 29.952 31.245 1.574 30.412 37.268
1314 --
1315 -- The algorithm for tails (and, analogously, inits) is as follows:
1316 --
1317 -- A Node in the FingerTree of tails is constructed by evaluating the
1318 -- corresponding tail of the FingerTree of Nodes, considering the first
1319 -- Node in this tail, and constructing a Node in which each tail of this
1320 -- Node is made to be the prefix of the remaining tree. This ends up
1321 -- working quite elegantly, as the remainder of the tail of the FingerTree
1322 -- of Nodes becomes the middle of a new tail, the suffix of the Node is
1323 -- the prefix, and the suffix of the original tree is retained.
1324 --
1325 -- In particular, evaluating the /i/th tail involves making as
1326 -- many partial evaluations as the Node depth of the /i/th element.
1327 -- In addition, when we evaluate the /i/th tail, and we also evaluate
1328 -- the /j/th tail, and /m/ Nodes are on the path to both /i/ and /j/,
1329 -- each of those /m/ evaluations are shared between the computation of
1330 -- the /i/th and /j/th tails.
1331 --
1332 -- wasserman.louis@gmail.com, 7/16/09
1333
1334 tailsDigit :: Digit a -> Digit (Digit a)
1335 tailsDigit (One a) = One (One a)
1336 tailsDigit (Two a b) = Two (Two a b) (One b)
1337 tailsDigit (Three a b c) = Three (Three a b c) (Two b c) (One c)
1338 tailsDigit (Four a b c d) = Four (Four a b c d) (Three b c d) (Two c d) (One d)
1339
1340 initsDigit :: Digit a -> Digit (Digit a)
1341 initsDigit (One a) = One (One a)
1342 initsDigit (Two a b) = Two (One a) (Two a b)
1343 initsDigit (Three a b c) = Three (One a) (Two a b) (Three a b c)
1344 initsDigit (Four a b c d) = Four (One a) (Two a b) (Three a b c) (Four a b c d)
1345
1346 tailsNode :: Node a -> Node (Digit a)
1347 tailsNode (Node2 s a b) = Node2 s (Two a b) (One b)
1348 tailsNode (Node3 s a b c) = Node3 s (Three a b c) (Two b c) (One c)
1349
1350 initsNode :: Node a -> Node (Digit a)
1351 initsNode (Node2 s a b) = Node2 s (One a) (Two a b)
1352 initsNode (Node3 s a b c) = Node3 s (One a) (Two a b) (Three a b c)
1353
1354 {-# SPECIALIZE tailsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-}
1355 {-# SPECIALIZE tailsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-}
1356 -- | Given a function to apply to tails of a tree, applies that function
1357 -- to every tail of the specified tree.
1358 tailsTree :: (Sized a, Sized b) => (FingerTree a -> b) -> FingerTree a -> FingerTree b
1359 tailsTree _ Empty = Empty
1360 tailsTree f (Single x) = Single (f (Single x))
1361 tailsTree f (Deep n pr m sf) =
1362 Deep n (fmap (\ pr' -> f (deep pr' m sf)) (tailsDigit pr))
1363 (tailsTree f' m)
1364 (fmap (f . digitToTree) (tailsDigit sf))
1365 where
1366 f' ms = let Just2 node m' = viewLTree ms in
1367 fmap (\ pr' -> f (deep pr' m' sf)) (tailsNode node)
1368
1369 {-# SPECIALIZE initsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-}
1370 {-# SPECIALIZE initsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-}
1371 -- | Given a function to apply to inits of a tree, applies that function
1372 -- to every init of the specified tree.
1373 initsTree :: (Sized a, Sized b) => (FingerTree a -> b) -> FingerTree a -> FingerTree b
1374 initsTree _ Empty = Empty
1375 initsTree f (Single x) = Single (f (Single x))
1376 initsTree f (Deep n pr m sf) =
1377 Deep n (fmap (f . digitToTree) (initsDigit pr))
1378 (initsTree f' m)
1379 (fmap (f . deep pr m) (initsDigit sf))
1380 where
1381 f' ms = let Just2 m' node = viewRTree ms in
1382 fmap (\ sf' -> f (deep pr m' sf')) (initsNode node)
1383
1384 {-# INLINE foldlWithIndex #-}
1385 -- | 'foldlWithIndex' is a version of 'foldl' that also provides access
1386 -- to the index of each element.
1387 foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b
1388 foldlWithIndex f z xs = foldl (\ g x i -> i `seq` f (g (i - 1)) i x) (const z) xs (length xs - 1)
1389
1390 {-# INLINE foldrWithIndex #-}
1391 -- | 'foldrWithIndex' is a version of 'foldr' that also provides access
1392 -- to the index of each element.
1393 foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b
1394 foldrWithIndex f z xs = foldr (\ x g i -> i `seq` f i x (g (i+1))) (const z) xs 0
1395
1396 {-# INLINE listToMaybe' #-}
1397 -- 'listToMaybe\'' is a good consumer version of 'listToMaybe'.
1398 listToMaybe' :: [a] -> Maybe a
1399 listToMaybe' = foldr (\ x _ -> Just x) Nothing
1400
1401 -- | /O(i)/ where /i/ is the prefix length. 'takeWhileL', applied
1402 -- to a predicate @p@ and a sequence @xs@, returns the longest prefix
1403 -- (possibly empty) of @xs@ of elements that satisfy @p@.
1404 takeWhileL :: (a -> Bool) -> Seq a -> Seq a
1405 takeWhileL p = fst . spanl p
1406
1407 -- | /O(i)/ where /i/ is the suffix length. 'takeWhileR', applied
1408 -- to a predicate @p@ and a sequence @xs@, returns the longest suffix
1409 -- (possibly empty) of @xs@ of elements that satisfy @p@.
1410 --
1411 -- @'takeWhileR' p xs@ is equivalent to @'reverse' ('takeWhileL' p ('reverse' xs))@.
1412 takeWhileR :: (a -> Bool) -> Seq a -> Seq a
1413 takeWhileR p = fst . spanr p
1414
1415 -- | /O(i)/ where /i/ is the prefix length. @'dropWhileL' p xs@ returns
1416 -- the suffix remaining after @'takeWhileL' p xs@.
1417 dropWhileL :: (a -> Bool) -> Seq a -> Seq a
1418 dropWhileL p = snd . spanl p
1419
1420 -- | /O(i)/ where /i/ is the suffix length. @'dropWhileR' p xs@ returns
1421 -- the prefix remaining after @'takeWhileR' p xs@.
1422 --
1423 -- @'dropWhileR' p xs@ is equivalent to @'reverse' ('dropWhileL' p ('reverse' xs))@.
1424 dropWhileR :: (a -> Bool) -> Seq a -> Seq a
1425 dropWhileR p = snd . spanr p
1426
1427 -- | /O(i)/ where /i/ is the prefix length. 'spanl', applied to
1428 -- a predicate @p@ and a sequence @xs@, returns a pair whose first
1429 -- element is the longest prefix (possibly empty) of @xs@ of elements that
1430 -- satisfy @p@ and the second element is the remainder of the sequence.
1431 spanl :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
1432 spanl p = breakl (not . p)
1433
1434 -- | /O(i)/ where /i/ is the suffix length. 'spanr', applied to a
1435 -- predicate @p@ and a sequence @xs@, returns a pair whose /first/ element
1436 -- is the longest /suffix/ (possibly empty) of @xs@ of elements that
1437 -- satisfy @p@ and the second element is the remainder of the sequence.
1438 spanr :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
1439 spanr p = breakr (not . p)
1440
1441 {-# INLINE breakl #-}
1442 -- | /O(i)/ where /i/ is the breakpoint index. 'breakl', applied to a
1443 -- predicate @p@ and a sequence @xs@, returns a pair whose first element
1444 -- is the longest prefix (possibly empty) of @xs@ of elements that
1445 -- /do not satisfy/ @p@ and the second element is the remainder of
1446 -- the sequence.
1447 --
1448 -- @'breakl' p@ is equivalent to @'spanl' (not . p)@.
1449 breakl :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
1450 breakl p xs = foldr (\ i _ -> splitAt i xs) (xs, empty) (findIndicesL p xs)
1451
1452 {-# INLINE breakr #-}
1453 -- | @'breakr' p@ is equivalent to @'spanr' (not . p)@.
1454 breakr :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
1455 breakr p xs = foldr (\ i _ -> flipPair (splitAt (i + 1) xs)) (xs, empty) (findIndicesR p xs)
1456 where flipPair (x, y) = (y, x)
1457
1458 -- | /O(n)/. The 'partition' function takes a predicate @p@ and a
1459 -- sequence @xs@ and returns sequences of those elements which do and
1460 -- do not satisfy the predicate.
1461 partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
1462 partition p = foldl part (empty, empty)
1463 where
1464 part (xs, ys) x
1465 | p x = (xs |> x, ys)
1466 | otherwise = (xs, ys |> x)
1467
1468 -- | /O(n)/. The 'filter' function takes a predicate @p@ and a sequence
1469 -- @xs@ and returns a sequence of those elements which satisfy the
1470 -- predicate.
1471 filter :: (a -> Bool) -> Seq a -> Seq a
1472 filter p = foldl (\ xs x -> if p x then xs |> x else xs) empty
1473
1474 -- Indexing sequences
1475
1476 -- | 'elemIndexL' finds the leftmost index of the specified element,
1477 -- if it is present, and otherwise 'Nothing'.
1478 elemIndexL :: Eq a => a -> Seq a -> Maybe Int
1479 elemIndexL x = findIndexL (x ==)
1480
1481 -- | 'elemIndexR' finds the rightmost index of the specified element,
1482 -- if it is present, and otherwise 'Nothing'.
1483 elemIndexR :: Eq a => a -> Seq a -> Maybe Int
1484 elemIndexR x = findIndexR (x ==)
1485
1486 -- | 'elemIndicesL' finds the indices of the specified element, from
1487 -- left to right (i.e. in ascending order).
1488 elemIndicesL :: Eq a => a -> Seq a -> [Int]
1489 elemIndicesL x = findIndicesL (x ==)
1490
1491 -- | 'elemIndicesR' finds the indices of the specified element, from
1492 -- right to left (i.e. in descending order).
1493 elemIndicesR :: Eq a => a -> Seq a -> [Int]
1494 elemIndicesR x = findIndicesR (x ==)
1495
1496 -- | @'findIndexL' p xs@ finds the index of the leftmost element that
1497 -- satisfies @p@, if any exist.
1498 findIndexL :: (a -> Bool) -> Seq a -> Maybe Int
1499 findIndexL p = listToMaybe' . findIndicesL p
1500
1501 -- | @'findIndexR' p xs@ finds the index of the rightmost element that
1502 -- satisfies @p@, if any exist.
1503 findIndexR :: (a -> Bool) -> Seq a -> Maybe Int
1504 findIndexR p = listToMaybe' . findIndicesR p
1505
1506 {-# INLINE findIndicesL #-}
1507 -- | @'findIndicesL' p@ finds all indices of elements that satisfy @p@,
1508 -- in ascending order.
1509 findIndicesL :: (a -> Bool) -> Seq a -> [Int]
1510 #if __GLASGOW_HASKELL__
1511 findIndicesL p xs = build (\ c n -> let g i x z = if p x then c i z else z in
1512 foldrWithIndex g n xs)
1513 #else
1514 findIndicesL p xs = foldrWithIndex g [] xs
1515 where g i x is = if p x then i:is else is
1516 #endif
1517
1518 {-# INLINE findIndicesR #-}
1519 -- | @'findIndicesR' p@ finds all indices of elements that satisfy @p@,
1520 -- in descending order.
1521 findIndicesR :: (a -> Bool) -> Seq a -> [Int]
1522 #if __GLASGOW_HASKELL__
1523 findIndicesR p xs = build (\ c n ->
1524 let g z i x = if p x then c i z else z in foldlWithIndex g n xs)
1525 #else
1526 findIndicesR p xs = foldlWithIndex g [] xs
1527 where g is i x = if p x then i:is else is
1528 #endif
1529
1530 ------------------------------------------------------------------------
1531 -- Lists
1532 ------------------------------------------------------------------------
1533
1534 -- | /O(n)/. Create a sequence from a finite list of elements.
1535 -- There is a function 'toList' in the opposite direction for all
1536 -- instances of the 'Foldable' class, including 'Seq'.
1537 fromList :: [a] -> Seq a
1538 fromList = Data.List.foldl' (|>) empty
1539
1540 ------------------------------------------------------------------------
1541 -- Reverse
1542 ------------------------------------------------------------------------
1543
1544 -- | /O(n)/. The reverse of a sequence.
1545 reverse :: Seq a -> Seq a
1546 reverse (Seq xs) = Seq (reverseTree id xs)
1547
1548 reverseTree :: (a -> a) -> FingerTree a -> FingerTree a
1549 reverseTree _ Empty = Empty
1550 reverseTree f (Single x) = Single (f x)
1551 reverseTree f (Deep s pr m sf) =
1552 Deep s (reverseDigit f sf)
1553 (reverseTree (reverseNode f) m)
1554 (reverseDigit f pr)
1555
1556 {-# INLINE reverseDigit #-}
1557 reverseDigit :: (a -> a) -> Digit a -> Digit a
1558 reverseDigit f (One a) = One (f a)
1559 reverseDigit f (Two a b) = Two (f b) (f a)
1560 reverseDigit f (Three a b c) = Three (f c) (f b) (f a)
1561 reverseDigit f (Four a b c d) = Four (f d) (f c) (f b) (f a)
1562
1563 reverseNode :: (a -> a) -> Node a -> Node a
1564 reverseNode f (Node2 s a b) = Node2 s (f b) (f a)
1565 reverseNode f (Node3 s a b c) = Node3 s (f c) (f b) (f a)
1566
1567 ------------------------------------------------------------------------
1568 -- Zipping
1569 ------------------------------------------------------------------------
1570
1571 -- | /O(min(n1,n2))/. 'zip' takes two sequences and returns a sequence
1572 -- of corresponding pairs. If one input is short, excess elements are
1573 -- discarded from the right end of the longer sequence.
1574 zip :: Seq a -> Seq b -> Seq (a, b)
1575 zip = zipWith (,)
1576
1577 -- | /O(min(n1,n2))/. 'zipWith' generalizes 'zip' by zipping with the
1578 -- function given as the first argument, instead of a tupling function.
1579 -- For example, @zipWith (+)@ is applied to two sequences to take the
1580 -- sequence of corresponding sums.
1581 zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
1582 zipWith f xs ys
1583 | length xs <= length ys = zipWith' f xs ys
1584 | otherwise = zipWith' (flip f) ys xs
1585
1586 -- like 'zipWith', but assumes length xs <= length ys
1587 zipWith' :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
1588 zipWith' f xs ys = snd (mapAccumL k ys xs)
1589 where
1590 k kys x = case viewl kys of
1591 (z :< zs) -> (zs, f x z)
1592 EmptyL -> error "zipWith': unexpected EmptyL"
1593
1594 -- | /O(min(n1,n2,n3))/. 'zip3' takes three sequences and returns a
1595 -- sequence of triples, analogous to 'zip'.
1596 zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)
1597 zip3 = zipWith3 (,,)
1598
1599 -- | /O(min(n1,n2,n3))/. 'zipWith3' takes a function which combines
1600 -- three elements, as well as three sequences and returns a sequence of
1601 -- their point-wise combinations, analogous to 'zipWith'.
1602 zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
1603 zipWith3 f s1 s2 s3 = zipWith ($) (zipWith f s1 s2) s3
1604
1605 -- | /O(min(n1,n2,n3,n4))/. 'zip4' takes four sequences and returns a
1606 -- sequence of quadruples, analogous to 'zip'.
1607 zip4 :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a,b,c,d)
1608 zip4 = zipWith4 (,,,)
1609
1610 -- | /O(min(n1,n2,n3,n4))/. 'zipWith4' takes a function which combines
1611 -- four elements, as well as four sequences and returns a sequence of
1612 -- their point-wise combinations, analogous to 'zipWith'.
1613 zipWith4 :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e
1614 zipWith4 f s1 s2 s3 s4 = zipWith ($) (zipWith ($) (zipWith f s1 s2) s3) s4
1615
1616 ------------------------------------------------------------------------
1617 -- Sorting
1618 --
1619 -- sort and sortBy are implemented by simple deforestations of
1620 -- \ xs -> fromList2 (length xs) . Data.List.sortBy cmp . toList
1621 -- which does not get deforested automatically, it would appear.
1622 --
1623 -- Unstable sorting is performed by a heap sort implementation based on
1624 -- pairing heaps. Because the internal structure of sequences is quite
1625 -- varied, it is difficult to get blocks of elements of roughly the same
1626 -- length, which would improve merge sort performance. Pairing heaps,
1627 -- on the other hand, are relatively resistant to the effects of merging
1628 -- heaps of wildly different sizes, as guaranteed by its amortized
1629 -- constant-time merge operation. Moreover, extensive use of SpecConstr
1630 -- transformations can be done on pairing heaps, especially when we're
1631 -- only constructing them to immediately be unrolled.
1632 --
1633 -- On purely random sequences of length 50000, with no RTS options,
1634 -- I get the following statistics, in which heapsort is about 42.5%
1635 -- faster: (all comparisons done with -O2)
1636 --
1637 -- Times (ms) min mean +/-sd median max
1638 -- to/from list: 103.802 108.572 7.487 106.436 143.339
1639 -- unstable heapsort: 60.686 62.968 4.275 61.187 79.151
1640 --
1641 -- Heapsort, it would seem, is less of a memory hog than Data.List.sortBy.
1642 -- The gap is narrowed when more memory is available, but heapsort still
1643 -- wins, 15% faster, with +RTS -H128m:
1644 --
1645 -- Times (ms) min mean +/-sd median max
1646 -- to/from list: 42.692 45.074 2.596 44.600 56.601
1647 -- unstable heapsort: 37.100 38.344 3.043 37.715 55.526
1648 --
1649 -- In addition, on strictly increasing sequences the gap is even wider
1650 -- than normal; heapsort is 68.5% faster with no RTS options:
1651 -- Times (ms) min mean +/-sd median max
1652 -- to/from list: 52.236 53.574 1.987 53.034 62.098
1653 -- unstable heapsort: 16.433 16.919 0.931 16.681 21.622
1654 --
1655 -- This may be attributed to the elegant nature of the pairing heap.
1656 --
1657 -- wasserman.louis@gmail.com, 7/20/09
1658 ------------------------------------------------------------------------
1659
1660 -- | /O(n log n)/. 'sort' sorts the specified 'Seq' by the natural
1661 -- ordering of its elements. The sort is stable.
1662 -- If stability is not required, 'unstableSort' can be considerably
1663 -- faster, and in particular uses less memory.
1664 sort :: Ord a => Seq a -> Seq a
1665 sort = sortBy compare
1666
1667 -- | /O(n log n)/. 'sortBy' sorts the specified 'Seq' according to the
1668 -- specified comparator. The sort is stable.
1669 -- If stability is not required, 'unstableSortBy' can be considerably
1670 -- faster, and in particular uses less memory.
1671 sortBy :: (a -> a -> Ordering) -> Seq a -> Seq a
1672 sortBy cmp xs = fromList2 (length xs) (Data.List.sortBy cmp (toList xs))
1673
1674 -- | /O(n log n)/. 'unstableSort' sorts the specified 'Seq' by
1675 -- the natural ordering of its elements, but the sort is not stable.
1676 -- This algorithm is frequently faster and uses less memory than 'sort',
1677 -- and performs extremely well -- frequently twice as fast as 'sort' --
1678 -- when the sequence is already nearly sorted.
1679 unstableSort :: Ord a => Seq a -> Seq a
1680 unstableSort = unstableSortBy compare
1681
1682 -- | /O(n log n)/. A generalization of 'unstableSort', 'unstableSortBy'
1683 -- takes an arbitrary comparator and sorts the specified sequence.
1684 -- The sort is not stable. This algorithm is frequently faster and
1685 -- uses less memory than 'sortBy', and performs extremely well --
1686 -- frequently twice as fast as 'sortBy' -- when the sequence is already
1687 -- nearly sorted.
1688 unstableSortBy :: (a -> a -> Ordering) -> Seq a -> Seq a
1689 unstableSortBy cmp (Seq xs) =
1690 fromList2 (size xs) $ maybe [] (unrollPQ cmp) $
1691 toPQ cmp (\ (Elem x) -> PQueue x Nil) xs
1692
1693 -- | fromList2, given a list and its length, constructs a completely
1694 -- balanced Seq whose elements are that list using the applicativeTree
1695 -- generalization.
1696 fromList2 :: Int -> [a] -> Seq a
1697 fromList2 n = execState (replicateA n (State ht))
1698 where
1699 ht (x:xs) = (xs, x)
1700 ht [] = error "fromList2: short list"
1701
1702 -- | A 'PQueue' is a simple pairing heap.
1703 data PQueue e = PQueue e (PQL e)
1704 data PQL e = Nil | {-# UNPACK #-} !(PQueue e) :& PQL e
1705
1706 infixr 8 :&
1707
1708 #if TESTING
1709
1710 instance Functor PQueue where
1711 fmap f (PQueue x ts) = PQueue (f x) (fmap f ts)
1712
1713 instance Functor PQL where
1714 fmap f (q :& qs) = fmap f q :& fmap f qs
1715 fmap _ Nil = Nil
1716
1717 instance Show e => Show (PQueue e) where
1718 show = unlines . draw . fmap show
1719
1720 -- borrowed wholesale from Data.Tree, as Data.Tree actually depends
1721 -- on Data.Sequence
1722 draw :: PQueue String -> [String]
1723 draw (PQueue x ts0) = x : drawSubTrees ts0
1724 where
1725 drawSubTrees Nil = []
1726 drawSubTrees (t :& Nil) =
1727 "|" : shift "`- " " " (draw t)
1728 drawSubTrees (t :& ts) =
1729 "|" : shift "+- " "| " (draw t) ++ drawSubTrees ts
1730
1731 shift first other = Data.List.zipWith (++) (first : repeat other)
1732 #endif
1733
1734 -- | 'unrollPQ', given a comparator function, unrolls a 'PQueue' into
1735 -- a sorted list.
1736 unrollPQ :: (e -> e -> Ordering) -> PQueue e -> [e]
1737 unrollPQ cmp = unrollPQ'
1738 where
1739 {-# INLINE unrollPQ' #-}
1740 unrollPQ' (PQueue x ts) = x:mergePQs0 ts
1741 (<>) = mergePQ cmp
1742 mergePQs0 Nil = []
1743 mergePQs0 (t :& Nil) = unrollPQ' t
1744 mergePQs0 (t1 :& t2 :& ts) = mergePQs (t1 <> t2) ts
1745 mergePQs t ts = t `seq` case ts of
1746 Nil -> unrollPQ' t
1747 t1 :& Nil -> unrollPQ' (t <> t1)
1748 t1 :& t2 :& ts' -> mergePQs (t <> (t1 <> t2)) ts'
1749
1750 -- | 'toPQ', given an ordering function and a mechanism for queueifying
1751 -- elements, converts a 'FingerTree' to a 'PQueue'.
1752 toPQ :: (e -> e -> Ordering) -> (a -> PQueue e) -> FingerTree a -> Maybe (PQueue e)
1753 toPQ _ _ Empty = Nothing
1754 toPQ _ f (Single x) = Just (f x)
1755 toPQ cmp f (Deep _ pr m sf) = Just (maybe (pr' <> sf') ((pr' <> sf') <>) (toPQ cmp fNode m))
1756 where
1757 fDigit digit = case fmap f digit of
1758 One a -> a
1759 Two a b -> a <> b
1760 Three a b c -> a <> b <> c
1761 Four a b c d -> (a <> b) <> (c <> d)
1762 (<>) = mergePQ cmp
1763 fNode = fDigit . nodeToDigit
1764 pr' = fDigit pr
1765 sf' = fDigit sf
1766
1767 -- | 'mergePQ' merges two 'PQueue's.
1768 mergePQ :: (a -> a -> Ordering) -> PQueue a -> PQueue a -> PQueue a
1769 mergePQ cmp q1@(PQueue x1 ts1) q2@(PQueue x2 ts2)
1770 | cmp x1 x2 == GT = PQueue x2 (q1 :& ts2)
1771 | otherwise = PQueue x1 (q2 :& ts1)
1772
1773 #if TESTING
1774
1775 ------------------------------------------------------------------------
1776 -- QuickCheck
1777 ------------------------------------------------------------------------
1778
1779 instance Arbitrary a => Arbitrary (Seq a) where
1780 arbitrary = Seq <$> arbitrary
1781 shrink (Seq x) = map Seq (shrink x)
1782
1783 instance Arbitrary a => Arbitrary (Elem a) where
1784 arbitrary = Elem <$> arbitrary
1785
1786 instance (Arbitrary a, Sized a) => Arbitrary (FingerTree a) where
1787 arbitrary = sized arb
1788 where
1789 arb :: (Arbitrary a, Sized a) => Int -> Gen (FingerTree a)
1790 arb 0 = return Empty
1791 arb 1 = Single <$> arbitrary
1792 arb n = deep <$> arbitrary <*> arb (n `div` 2) <*> arbitrary
1793
1794 shrink (Deep _ (One a) Empty (One b)) = [Single a, Single b]
1795 shrink (Deep _ pr m sf) =
1796 [deep pr' m sf | pr' <- shrink pr] ++
1797 [deep pr m' sf | m' <- shrink m] ++
1798 [deep pr m sf' | sf' <- shrink sf]
1799 shrink (Single x) = map Single (shrink x)
1800 shrink Empty = []
1801
1802 instance (Arbitrary a, Sized a) => Arbitrary (Node a) where
1803 arbitrary = oneof [
1804 node2 <$> arbitrary <*> arbitrary,
1805 node3 <$> arbitrary <*> arbitrary <*> arbitrary]
1806
1807 shrink (Node2 _ a b) =
1808 [node2 a' b | a' <- shrink a] ++
1809 [node2 a b' | b' <- shrink b]
1810 shrink (Node3 _ a b c) =
1811 [node2 a b, node2 a c, node2 b c] ++
1812 [node3 a' b c | a' <- shrink a] ++
1813 [node3 a b' c | b' <- shrink b] ++
1814 [node3 a b c' | c' <- shrink c]
1815
1816 instance Arbitrary a => Arbitrary (Digit a) where
1817 arbitrary = oneof [
1818 One <$> arbitrary,
1819 Two <$> arbitrary <*> arbitrary,
1820 Three <$> arbitrary <*> arbitrary <*> arbitrary,
1821 Four <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary]
1822
1823 shrink (One a) = map One (shrink a)
1824 shrink (Two a b) = [One a, One b]
1825 shrink (Three a b c) = [Two a b, Two a c, Two b c]
1826 shrink (Four a b c d) = [Three a b c, Three a b d, Three a c d, Three b c d]
1827
1828 ------------------------------------------------------------------------
1829 -- Valid trees
1830 ------------------------------------------------------------------------
1831
1832 class Valid a where
1833 valid :: a -> Bool
1834
1835 instance Valid (Elem a) where
1836 valid _ = True
1837
1838 instance Valid (Seq a) where
1839 valid (Seq xs) = valid xs
1840
1841 instance (Sized a, Valid a) => Valid (FingerTree a) where
1842 valid Empty = True
1843 valid (Single x) = valid x
1844 valid (Deep s pr m sf) =
1845 s == size pr + size m + size sf && valid pr && valid m && valid sf
1846
1847 instance (Sized a, Valid a) => Valid (Node a) where
1848 valid node = size node == sum (fmap size node) && all valid node
1849
1850 instance Valid a => Valid (Digit a) where
1851 valid = all valid
1852
1853 #endif