[project @ 2005-10-20 23:28:42 by ross]
[packages/old-time.git] / Data / Sequence.hs
1 {-# OPTIONS -cpp -fglasgow-exts #-}
2 -----------------------------------------------------------------------------
3 -- |
4 -- Module : Data.Sequence
5 -- Copyright : (c) Ross Paterson 2005
6 -- License : BSD-style
7 -- Maintainer : ross@soi.city.ac.uk
8 -- Stability : experimental
9 -- Portability : portable
10 --
11 -- General purpose finite sequences.
12 -- Apart from being finite and having strict operations, sequences
13 -- also differ from lists in supporting a wider variety of operations
14 -- efficiently.
15 --
16 -- An amortized running time is given for each operation, with /n/ referring
17 -- to the length of the sequence and /i/ being the integral index used by
18 -- some operations. These bounds hold even in a persistent (shared) setting.
19 --
20 -- The implementation uses 2-3 finger trees annotated with sizes,
21 -- as described in section 4.2 of
22 --
23 -- * Ralf Hinze and Ross Paterson,
24 -- \"Finger trees: a simple general-purpose data structure\",
25 -- to appear in /Journal of Functional Programming/.
26 -- <http://www.soi.city.ac.uk/~ross/papers/FingerTree.html>
27 --
28 -- /Note/: Many of these operations have the same names as similar
29 -- operations on lists in the "Prelude". The ambiguity may be resolved
30 -- using either qualification or the @hiding@ clause.
31 --
32 -----------------------------------------------------------------------------
33
34 module Data.Sequence (
35 Seq,
36 -- * Construction
37 empty, -- :: Seq a
38 singleton, -- :: a -> Seq a
39 (<|), -- :: a -> Seq a -> Seq a
40 (|>), -- :: Seq a -> a -> Seq a
41 (><), -- :: Seq a -> Seq a -> Seq a
42 -- * Deconstruction
43 -- ** Queries
44 null, -- :: Seq a -> Bool
45 length, -- :: Seq a -> Int
46 -- ** Views
47 ViewL(..),
48 viewl, -- :: Seq a -> ViewL a
49 ViewR(..),
50 viewr, -- :: Seq a -> ViewR a
51 -- ** Indexing
52 index, -- :: Seq a -> Int -> a
53 adjust, -- :: (a -> a) -> Int -> Seq a -> Seq a
54 update, -- :: Int -> a -> Seq a -> Seq a
55 take, -- :: Int -> Seq a -> Seq a
56 drop, -- :: Int -> Seq a -> Seq a
57 splitAt, -- :: Int -> Seq a -> (Seq a, Seq a)
58 -- * Lists
59 fromList, -- :: [a] -> Seq a
60 toList, -- :: Seq a -> [a]
61 -- * Folds
62 -- ** Right associative
63 foldr, -- :: (a -> b -> b) -> b -> Seq a -> b
64 foldr1, -- :: (a -> a -> a) -> Seq a -> a
65 foldr', -- :: (a -> b -> b) -> b -> Seq a -> b
66 foldrM, -- :: Monad m => (a -> b -> m b) -> b -> Seq a -> m b
67 -- ** Left associative
68 foldl, -- :: (a -> b -> a) -> a -> Seq b -> a
69 foldl1, -- :: (a -> a -> a) -> Seq a -> a
70 foldl', -- :: (a -> b -> a) -> a -> Seq b -> a
71 foldlM, -- :: Monad m => (a -> b -> m a) -> a -> Seq b -> m a
72 -- * Transformations
73 reverse, -- :: Seq a -> Seq a
74 #if TESTING
75 valid,
76 #endif
77 ) where
78
79 import Prelude hiding (
80 null, length, take, drop, splitAt, foldl, foldl1, foldr, foldr1,
81 reverse)
82 import qualified Prelude (foldr)
83 import qualified Data.List (foldl', intersperse)
84 import Control.Monad (MonadPlus(..))
85 import Data.FunctorM
86 import Data.Typeable
87
88 #ifdef __GLASGOW_HASKELL__
89 import GHC.Exts (build)
90 import Text.ParserCombinators.ReadP (char, skipSpaces, between, sepBy, (+++))
91 import Text.Read (readPrec, readPrec_to_P, readP_to_Prec, minPrec)
92 import Control.Monad (liftM)
93 import Data.Generics.Basics (Data(..), Fixity(..),
94 constrIndex, mkConstr, mkDataType)
95 #else
96 import Data.Char (isSpace)
97 #endif
98
99 #if TESTING
100 import Control.Monad (liftM, liftM2, liftM3, liftM4)
101 import Test.QuickCheck
102 #endif
103
104 infixr 5 `consTree`
105 infixl 5 `snocTree`
106
107 infixr 5 ><
108 infixr 5 <|, :<
109 infixl 5 |>, :>
110
111 class Sized a where
112 size :: a -> Int
113
114 -- | General-purpose finite sequences.
115 newtype Seq a = Seq (FingerTree (Elem a))
116
117 instance Functor Seq where
118 fmap f (Seq xs) = Seq (fmap (fmap f) xs)
119
120 instance Monad Seq where
121 return = singleton
122 xs >>= f = foldl' add empty xs
123 where add ys x = ys >< f x
124
125 instance MonadPlus Seq where
126 mzero = empty
127 mplus = (><)
128
129 instance FunctorM Seq where
130 fmapM f = foldlM f' empty
131 where f' ys x = do
132 y <- f x
133 return $! (ys |> y)
134 fmapM_ f = foldlM f' ()
135 where f' _ x = f x >> return ()
136
137 instance Eq a => Eq (Seq a) where
138 xs == ys = length xs == length ys && toList xs == toList ys
139
140 instance Ord a => Ord (Seq a) where
141 compare xs ys = compare (toList xs) (toList ys)
142
143 #if TESTING
144 instance Show a => Show (Seq a) where
145 showsPrec p (Seq x) = showsPrec p x
146 #else
147 instance Show a => Show (Seq a) where
148 showsPrec _ xs = showChar '<' .
149 flip (Prelude.foldr ($)) (Data.List.intersperse (showChar ',')
150 (map shows (toList xs))) .
151 showChar '>'
152 #endif
153
154 instance Read a => Read (Seq a) where
155 -- avoid lex, as < or > might be followed by symbol characters.
156 #ifdef __GLASGOW_HASKELL__
157 readPrec = readP_to_Prec $ const $
158 parens $
159 between (litChar '<') (litChar '>') $
160 liftM fromList $
161 readPrec_to_P readPrec minPrec `sepBy` litChar ','
162 where parens p = p +++ between (litChar '(') (litChar ')') (parens p)
163 litChar c = skipSpaces >> char c
164 #else
165 readsPrec _ = readParen False $ \ r ->
166 case dropWhile isSpace r of
167 ('<':s) -> case dropWhile isSpace s of
168 ('>':t) -> return (empty,t)
169 _ -> readRest empty s
170 _ -> []
171 where readRest xs s = do
172 (x,t) <- reads s
173 let xs' = xs |> x
174 case dropWhile isSpace t of
175 ('>':u) -> return (xs',u)
176 (',':u) -> readRest xs' u
177 _ -> []
178 #endif
179
180 #include "Typeable.h"
181 INSTANCE_TYPEABLE1(Seq,seqTc,"Seq")
182
183 #if __GLASGOW_HASKELL__
184 instance Data a => Data (Seq a) where
185 gfoldl f z s = case viewl s of
186 EmptyL -> z empty
187 x :< xs -> z (<|) `f` x `f` xs
188
189 gunfold k z c = case constrIndex c of
190 1 -> z empty
191 2 -> k (k (z (<|)))
192 _ -> error "gunfold"
193
194 toConstr xs
195 | null xs = emptyConstr
196 | otherwise = consConstr
197
198 dataTypeOf _ = seqDataType
199
200 dataCast1 = gcast1
201
202 emptyConstr = mkConstr seqDataType "empty" [] Prefix
203 consConstr = mkConstr seqDataType "<|" [] Infix
204 seqDataType = mkDataType "Data.Sequence.Seq" [emptyConstr, consConstr]
205 #endif
206
207 -- Finger trees
208
209 data FingerTree a
210 = Empty
211 | Single a
212 | Deep {-# UNPACK #-} !Int !(Digit a) (FingerTree (Node a)) !(Digit a)
213 #if TESTING
214 deriving Show
215 #endif
216
217 instance Sized a => Sized (FingerTree a) where
218 {-# SPECIALIZE instance Sized (FingerTree (Elem a)) #-}
219 {-# SPECIALIZE instance Sized (FingerTree (Node a)) #-}
220 size Empty = 0
221 size (Single x) = size x
222 size (Deep v _ _ _) = v
223
224 instance Functor FingerTree where
225 fmap _ Empty = Empty
226 fmap f (Single x) = Single (f x)
227 fmap f (Deep v pr m sf) =
228 Deep v (fmap f pr) (fmap (fmap f) m) (fmap f sf)
229
230 {-# INLINE deep #-}
231 {-# SPECIALIZE deep :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
232 {-# SPECIALIZE deep :: Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}
233 deep :: Sized a => Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a
234 deep pr m sf = Deep (size pr + size m + size sf) pr m sf
235
236 -- Digits
237
238 data Digit a
239 = One a
240 | Two a a
241 | Three a a a
242 | Four a a a a
243 #if TESTING
244 deriving Show
245 #endif
246
247 instance Functor Digit where
248 fmap f (One a) = One (f a)
249 fmap f (Two a b) = Two (f a) (f b)
250 fmap f (Three a b c) = Three (f a) (f b) (f c)
251 fmap f (Four a b c d) = Four (f a) (f b) (f c) (f d)
252
253 instance Sized a => Sized (Digit a) where
254 {-# SPECIALIZE instance Sized (Digit (Elem a)) #-}
255 {-# SPECIALIZE instance Sized (Digit (Node a)) #-}
256 size xs = foldlDigit (\ i x -> i + size x) 0 xs
257
258 {-# SPECIALIZE digitToTree :: Digit (Elem a) -> FingerTree (Elem a) #-}
259 {-# SPECIALIZE digitToTree :: Digit (Node a) -> FingerTree (Node a) #-}
260 digitToTree :: Sized a => Digit a -> FingerTree a
261 digitToTree (One a) = Single a
262 digitToTree (Two a b) = deep (One a) Empty (One b)
263 digitToTree (Three a b c) = deep (Two a b) Empty (One c)
264 digitToTree (Four a b c d) = deep (Two a b) Empty (Two c d)
265
266 -- Nodes
267
268 data Node a
269 = Node2 {-# UNPACK #-} !Int a a
270 | Node3 {-# UNPACK #-} !Int a a a
271 #if TESTING
272 deriving Show
273 #endif
274
275 instance Functor (Node) where
276 fmap f (Node2 v a b) = Node2 v (f a) (f b)
277 fmap f (Node3 v a b c) = Node3 v (f a) (f b) (f c)
278
279 instance Sized (Node a) where
280 size (Node2 v _ _) = v
281 size (Node3 v _ _ _) = v
282
283 {-# INLINE node2 #-}
284 {-# SPECIALIZE node2 :: Elem a -> Elem a -> Node (Elem a) #-}
285 {-# SPECIALIZE node2 :: Node a -> Node a -> Node (Node a) #-}
286 node2 :: Sized a => a -> a -> Node a
287 node2 a b = Node2 (size a + size b) a b
288
289 {-# INLINE node3 #-}
290 {-# SPECIALIZE node3 :: Elem a -> Elem a -> Elem a -> Node (Elem a) #-}
291 {-# SPECIALIZE node3 :: Node a -> Node a -> Node a -> Node (Node a) #-}
292 node3 :: Sized a => a -> a -> a -> Node a
293 node3 a b c = Node3 (size a + size b + size c) a b c
294
295 nodeToDigit :: Node a -> Digit a
296 nodeToDigit (Node2 _ a b) = Two a b
297 nodeToDigit (Node3 _ a b c) = Three a b c
298
299 -- Elements
300
301 newtype Elem a = Elem { getElem :: a }
302
303 instance Sized (Elem a) where
304 size _ = 1
305
306 instance Functor Elem where
307 fmap f (Elem x) = Elem (f x)
308
309 #ifdef TESTING
310 instance (Show a) => Show (Elem a) where
311 showsPrec p (Elem x) = showsPrec p x
312 #endif
313
314 ------------------------------------------------------------------------
315 -- Construction
316 ------------------------------------------------------------------------
317
318 -- | /O(1)/. The empty sequence.
319 empty :: Seq a
320 empty = Seq Empty
321
322 -- | /O(1)/. A singleton sequence.
323 singleton :: a -> Seq a
324 singleton x = Seq (Single (Elem x))
325
326 -- | /O(1)/. Add an element to the left end of a sequence.
327 -- Mnemonic: a triangle with the single element at the pointy end.
328 (<|) :: a -> Seq a -> Seq a
329 x <| Seq xs = Seq (Elem x `consTree` xs)
330
331 {-# SPECIALIZE consTree :: Elem a -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
332 {-# SPECIALIZE consTree :: Node a -> FingerTree (Node a) -> FingerTree (Node a) #-}
333 consTree :: Sized a => a -> FingerTree a -> FingerTree a
334 consTree a Empty = Single a
335 consTree a (Single b) = deep (One a) Empty (One b)
336 consTree a (Deep s (Four b c d e) m sf) = m `seq`
337 Deep (size a + s) (Two a b) (node3 c d e `consTree` m) sf
338 consTree a (Deep s (Three b c d) m sf) =
339 Deep (size a + s) (Four a b c d) m sf
340 consTree a (Deep s (Two b c) m sf) =
341 Deep (size a + s) (Three a b c) m sf
342 consTree a (Deep s (One b) m sf) =
343 Deep (size a + s) (Two a b) m sf
344
345 -- | /O(1)/. Add an element to the right end of a sequence.
346 -- Mnemonic: a triangle with the single element at the pointy end.
347 (|>) :: Seq a -> a -> Seq a
348 Seq xs |> x = Seq (xs `snocTree` Elem x)
349
350 {-# SPECIALIZE snocTree :: FingerTree (Elem a) -> Elem a -> FingerTree (Elem a) #-}
351 {-# SPECIALIZE snocTree :: FingerTree (Node a) -> Node a -> FingerTree (Node a) #-}
352 snocTree :: Sized a => FingerTree a -> a -> FingerTree a
353 snocTree Empty a = Single a
354 snocTree (Single a) b = deep (One a) Empty (One b)
355 snocTree (Deep s pr m (Four a b c d)) e = m `seq`
356 Deep (s + size e) pr (m `snocTree` node3 a b c) (Two d e)
357 snocTree (Deep s pr m (Three a b c)) d =
358 Deep (s + size d) pr m (Four a b c d)
359 snocTree (Deep s pr m (Two a b)) c =
360 Deep (s + size c) pr m (Three a b c)
361 snocTree (Deep s pr m (One a)) b =
362 Deep (s + size b) pr m (Two a b)
363
364 -- | /O(log(min(n1,n2)))/. Concatenate two sequences.
365 (><) :: Seq a -> Seq a -> Seq a
366 Seq xs >< Seq ys = Seq (appendTree0 xs ys)
367
368 -- The appendTree/addDigits gunk below is machine generated
369
370 appendTree0 :: FingerTree (Elem a) -> FingerTree (Elem a) -> FingerTree (Elem a)
371 appendTree0 Empty xs =
372 xs
373 appendTree0 xs Empty =
374 xs
375 appendTree0 (Single x) xs =
376 x `consTree` xs
377 appendTree0 xs (Single x) =
378 xs `snocTree` x
379 appendTree0 (Deep s1 pr1 m1 sf1) (Deep s2 pr2 m2 sf2) =
380 Deep (s1 + s2) pr1 (addDigits0 m1 sf1 pr2 m2) sf2
381
382 addDigits0 :: FingerTree (Node (Elem a)) -> Digit (Elem a) -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> FingerTree (Node (Elem a))
383 addDigits0 m1 (One a) (One b) m2 =
384 appendTree1 m1 (node2 a b) m2
385 addDigits0 m1 (One a) (Two b c) m2 =
386 appendTree1 m1 (node3 a b c) m2
387 addDigits0 m1 (One a) (Three b c d) m2 =
388 appendTree2 m1 (node2 a b) (node2 c d) m2
389 addDigits0 m1 (One a) (Four b c d e) m2 =
390 appendTree2 m1 (node3 a b c) (node2 d e) m2
391 addDigits0 m1 (Two a b) (One c) m2 =
392 appendTree1 m1 (node3 a b c) m2
393 addDigits0 m1 (Two a b) (Two c d) m2 =
394 appendTree2 m1 (node2 a b) (node2 c d) m2
395 addDigits0 m1 (Two a b) (Three c d e) m2 =
396 appendTree2 m1 (node3 a b c) (node2 d e) m2
397 addDigits0 m1 (Two a b) (Four c d e f) m2 =
398 appendTree2 m1 (node3 a b c) (node3 d e f) m2
399 addDigits0 m1 (Three a b c) (One d) m2 =
400 appendTree2 m1 (node2 a b) (node2 c d) m2
401 addDigits0 m1 (Three a b c) (Two d e) m2 =
402 appendTree2 m1 (node3 a b c) (node2 d e) m2
403 addDigits0 m1 (Three a b c) (Three d e f) m2 =
404 appendTree2 m1 (node3 a b c) (node3 d e f) m2
405 addDigits0 m1 (Three a b c) (Four d e f g) m2 =
406 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
407 addDigits0 m1 (Four a b c d) (One e) m2 =
408 appendTree2 m1 (node3 a b c) (node2 d e) m2
409 addDigits0 m1 (Four a b c d) (Two e f) m2 =
410 appendTree2 m1 (node3 a b c) (node3 d e f) m2
411 addDigits0 m1 (Four a b c d) (Three e f g) m2 =
412 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
413 addDigits0 m1 (Four a b c d) (Four e f g h) m2 =
414 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
415
416 appendTree1 :: FingerTree (Node a) -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
417 appendTree1 Empty a xs =
418 a `consTree` xs
419 appendTree1 xs a Empty =
420 xs `snocTree` a
421 appendTree1 (Single x) a xs =
422 x `consTree` a `consTree` xs
423 appendTree1 xs a (Single x) =
424 xs `snocTree` a `snocTree` x
425 appendTree1 (Deep s1 pr1 m1 sf1) a (Deep s2 pr2 m2 sf2) =
426 Deep (s1 + size a + s2) pr1 (addDigits1 m1 sf1 a pr2 m2) sf2
427
428 addDigits1 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
429 addDigits1 m1 (One a) b (One c) m2 =
430 appendTree1 m1 (node3 a b c) m2
431 addDigits1 m1 (One a) b (Two c d) m2 =
432 appendTree2 m1 (node2 a b) (node2 c d) m2
433 addDigits1 m1 (One a) b (Three c d e) m2 =
434 appendTree2 m1 (node3 a b c) (node2 d e) m2
435 addDigits1 m1 (One a) b (Four c d e f) m2 =
436 appendTree2 m1 (node3 a b c) (node3 d e f) m2
437 addDigits1 m1 (Two a b) c (One d) m2 =
438 appendTree2 m1 (node2 a b) (node2 c d) m2
439 addDigits1 m1 (Two a b) c (Two d e) m2 =
440 appendTree2 m1 (node3 a b c) (node2 d e) m2
441 addDigits1 m1 (Two a b) c (Three d e f) m2 =
442 appendTree2 m1 (node3 a b c) (node3 d e f) m2
443 addDigits1 m1 (Two a b) c (Four d e f g) m2 =
444 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
445 addDigits1 m1 (Three a b c) d (One e) m2 =
446 appendTree2 m1 (node3 a b c) (node2 d e) m2
447 addDigits1 m1 (Three a b c) d (Two e f) m2 =
448 appendTree2 m1 (node3 a b c) (node3 d e f) m2
449 addDigits1 m1 (Three a b c) d (Three e f g) m2 =
450 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
451 addDigits1 m1 (Three a b c) d (Four e f g h) m2 =
452 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
453 addDigits1 m1 (Four a b c d) e (One f) m2 =
454 appendTree2 m1 (node3 a b c) (node3 d e f) m2
455 addDigits1 m1 (Four a b c d) e (Two f g) m2 =
456 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
457 addDigits1 m1 (Four a b c d) e (Three f g h) m2 =
458 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
459 addDigits1 m1 (Four a b c d) e (Four f g h i) m2 =
460 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
461
462 appendTree2 :: FingerTree (Node a) -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
463 appendTree2 Empty a b xs =
464 a `consTree` b `consTree` xs
465 appendTree2 xs a b Empty =
466 xs `snocTree` a `snocTree` b
467 appendTree2 (Single x) a b xs =
468 x `consTree` a `consTree` b `consTree` xs
469 appendTree2 xs a b (Single x) =
470 xs `snocTree` a `snocTree` b `snocTree` x
471 appendTree2 (Deep s1 pr1 m1 sf1) a b (Deep s2 pr2 m2 sf2) =
472 Deep (s1 + size a + size b + s2) pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2
473
474 addDigits2 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
475 addDigits2 m1 (One a) b c (One d) m2 =
476 appendTree2 m1 (node2 a b) (node2 c d) m2
477 addDigits2 m1 (One a) b c (Two d e) m2 =
478 appendTree2 m1 (node3 a b c) (node2 d e) m2
479 addDigits2 m1 (One a) b c (Three d e f) m2 =
480 appendTree2 m1 (node3 a b c) (node3 d e f) m2
481 addDigits2 m1 (One a) b c (Four d e f g) m2 =
482 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
483 addDigits2 m1 (Two a b) c d (One e) m2 =
484 appendTree2 m1 (node3 a b c) (node2 d e) m2
485 addDigits2 m1 (Two a b) c d (Two e f) m2 =
486 appendTree2 m1 (node3 a b c) (node3 d e f) m2
487 addDigits2 m1 (Two a b) c d (Three e f g) m2 =
488 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
489 addDigits2 m1 (Two a b) c d (Four e f g h) m2 =
490 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
491 addDigits2 m1 (Three a b c) d e (One f) m2 =
492 appendTree2 m1 (node3 a b c) (node3 d e f) m2
493 addDigits2 m1 (Three a b c) d e (Two f g) m2 =
494 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
495 addDigits2 m1 (Three a b c) d e (Three f g h) m2 =
496 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
497 addDigits2 m1 (Three a b c) d e (Four f g h i) m2 =
498 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
499 addDigits2 m1 (Four a b c d) e f (One g) m2 =
500 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
501 addDigits2 m1 (Four a b c d) e f (Two g h) m2 =
502 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
503 addDigits2 m1 (Four a b c d) e f (Three g h i) m2 =
504 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
505 addDigits2 m1 (Four a b c d) e f (Four g h i j) m2 =
506 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
507
508 appendTree3 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
509 appendTree3 Empty a b c xs =
510 a `consTree` b `consTree` c `consTree` xs
511 appendTree3 xs a b c Empty =
512 xs `snocTree` a `snocTree` b `snocTree` c
513 appendTree3 (Single x) a b c xs =
514 x `consTree` a `consTree` b `consTree` c `consTree` xs
515 appendTree3 xs a b c (Single x) =
516 xs `snocTree` a `snocTree` b `snocTree` c `snocTree` x
517 appendTree3 (Deep s1 pr1 m1 sf1) a b c (Deep s2 pr2 m2 sf2) =
518 Deep (s1 + size a + size b + size c + s2) pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2
519
520 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))
521 addDigits3 m1 (One a) b c d (One e) m2 =
522 appendTree2 m1 (node3 a b c) (node2 d e) m2
523 addDigits3 m1 (One a) b c d (Two e f) m2 =
524 appendTree2 m1 (node3 a b c) (node3 d e f) m2
525 addDigits3 m1 (One a) b c d (Three e f g) m2 =
526 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
527 addDigits3 m1 (One a) b c d (Four e f g h) m2 =
528 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
529 addDigits3 m1 (Two a b) c d e (One f) m2 =
530 appendTree2 m1 (node3 a b c) (node3 d e f) m2
531 addDigits3 m1 (Two a b) c d e (Two f g) m2 =
532 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
533 addDigits3 m1 (Two a b) c d e (Three f g h) m2 =
534 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
535 addDigits3 m1 (Two a b) c d e (Four f g h i) m2 =
536 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
537 addDigits3 m1 (Three a b c) d e f (One g) m2 =
538 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
539 addDigits3 m1 (Three a b c) d e f (Two g h) m2 =
540 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
541 addDigits3 m1 (Three a b c) d e f (Three g h i) m2 =
542 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
543 addDigits3 m1 (Three a b c) d e f (Four g h i j) m2 =
544 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
545 addDigits3 m1 (Four a b c d) e f g (One h) m2 =
546 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
547 addDigits3 m1 (Four a b c d) e f g (Two h i) m2 =
548 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
549 addDigits3 m1 (Four a b c d) e f g (Three h i j) m2 =
550 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
551 addDigits3 m1 (Four a b c d) e f g (Four h i j k) m2 =
552 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
553
554 appendTree4 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
555 appendTree4 Empty a b c d xs =
556 a `consTree` b `consTree` c `consTree` d `consTree` xs
557 appendTree4 xs a b c d Empty =
558 xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d
559 appendTree4 (Single x) a b c d xs =
560 x `consTree` a `consTree` b `consTree` c `consTree` d `consTree` xs
561 appendTree4 xs a b c d (Single x) =
562 xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d `snocTree` x
563 appendTree4 (Deep s1 pr1 m1 sf1) a b c d (Deep s2 pr2 m2 sf2) =
564 Deep (s1 + size a + size b + size c + size d + s2) pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2
565
566 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))
567 addDigits4 m1 (One a) b c d e (One f) m2 =
568 appendTree2 m1 (node3 a b c) (node3 d e f) m2
569 addDigits4 m1 (One a) b c d e (Two f g) m2 =
570 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
571 addDigits4 m1 (One a) b c d e (Three f g h) m2 =
572 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
573 addDigits4 m1 (One a) b c d e (Four f g h i) m2 =
574 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
575 addDigits4 m1 (Two a b) c d e f (One g) m2 =
576 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
577 addDigits4 m1 (Two a b) c d e f (Two g h) m2 =
578 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
579 addDigits4 m1 (Two a b) c d e f (Three g h i) m2 =
580 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
581 addDigits4 m1 (Two a b) c d e f (Four g h i j) m2 =
582 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
583 addDigits4 m1 (Three a b c) d e f g (One h) m2 =
584 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
585 addDigits4 m1 (Three a b c) d e f g (Two h i) m2 =
586 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
587 addDigits4 m1 (Three a b c) d e f g (Three h i j) m2 =
588 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
589 addDigits4 m1 (Three a b c) d e f g (Four h i j k) m2 =
590 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
591 addDigits4 m1 (Four a b c d) e f g h (One i) m2 =
592 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
593 addDigits4 m1 (Four a b c d) e f g h (Two i j) m2 =
594 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
595 addDigits4 m1 (Four a b c d) e f g h (Three i j k) m2 =
596 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
597 addDigits4 m1 (Four a b c d) e f g h (Four i j k l) m2 =
598 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2
599
600 ------------------------------------------------------------------------
601 -- Deconstruction
602 ------------------------------------------------------------------------
603
604 -- | /O(1)/. Is this the empty sequence?
605 null :: Seq a -> Bool
606 null (Seq Empty) = True
607 null _ = False
608
609 -- | /O(1)/. The number of elements in the sequence.
610 length :: Seq a -> Int
611 length (Seq xs) = size xs
612
613 -- Views
614
615 data Maybe2 a b = Nothing2 | Just2 a b
616
617 -- | View of the left end of a sequence.
618 data ViewL a
619 = EmptyL -- ^ empty sequence
620 | a :< Seq a -- ^ leftmost element and the rest of the sequence
621 #ifndef __HADDOCK__
622 deriving (Eq, Show)
623 #else
624 instance Eq a => Eq (ViewL a)
625 instance Show a => Show (ViewL a)
626 #endif
627
628
629 instance Functor ViewL where
630 fmap _ EmptyL = EmptyL
631 fmap f (x :< xs) = f x :< fmap f xs
632
633 -- | /O(1)/. Analyse the left end of a sequence.
634 viewl :: Seq a -> ViewL a
635 viewl (Seq xs) = case viewLTree xs of
636 Nothing2 -> EmptyL
637 Just2 (Elem x) xs' -> x :< Seq xs'
638
639 {-# SPECIALIZE viewLTree :: FingerTree (Elem a) -> Maybe2 (Elem a) (FingerTree (Elem a)) #-}
640 {-# SPECIALIZE viewLTree :: FingerTree (Node a) -> Maybe2 (Node a) (FingerTree (Node a)) #-}
641 viewLTree :: Sized a => FingerTree a -> Maybe2 a (FingerTree a)
642 viewLTree Empty = Nothing2
643 viewLTree (Single a) = Just2 a Empty
644 viewLTree (Deep s (One a) m sf) = Just2 a (case viewLTree m of
645 Nothing2 -> digitToTree sf
646 Just2 b m' -> Deep (s - size a) (nodeToDigit b) m' sf)
647 viewLTree (Deep s (Two a b) m sf) =
648 Just2 a (Deep (s - size a) (One b) m sf)
649 viewLTree (Deep s (Three a b c) m sf) =
650 Just2 a (Deep (s - size a) (Two b c) m sf)
651 viewLTree (Deep s (Four a b c d) m sf) =
652 Just2 a (Deep (s - size a) (Three b c d) m sf)
653
654 -- | View of the right end of a sequence.
655 data ViewR a
656 = EmptyR -- ^ empty sequence
657 | Seq a :> a -- ^ the sequence minus the rightmost element,
658 -- and the rightmost element
659 #ifndef __HADDOCK__
660 deriving (Eq, Show)
661 #else
662 instance Eq a => Eq (ViewR a)
663 instance Show a => Show (ViewR a)
664 #endif
665
666 instance Functor ViewR where
667 fmap _ EmptyR = EmptyR
668 fmap f (xs :> x) = fmap f xs :> f x
669
670 -- | /O(1)/. Analyse the right end of a sequence.
671 viewr :: Seq a -> ViewR a
672 viewr (Seq xs) = case viewRTree xs of
673 Nothing2 -> EmptyR
674 Just2 xs' (Elem x) -> Seq xs' :> x
675
676 {-# SPECIALIZE viewRTree :: FingerTree (Elem a) -> Maybe2 (FingerTree (Elem a)) (Elem a) #-}
677 {-# SPECIALIZE viewRTree :: FingerTree (Node a) -> Maybe2 (FingerTree (Node a)) (Node a) #-}
678 viewRTree :: Sized a => FingerTree a -> Maybe2 (FingerTree a) a
679 viewRTree Empty = Nothing2
680 viewRTree (Single z) = Just2 Empty z
681 viewRTree (Deep s pr m (One z)) = Just2 (case viewRTree m of
682 Nothing2 -> digitToTree pr
683 Just2 m' y -> Deep (s - size z) pr m' (nodeToDigit y)) z
684 viewRTree (Deep s pr m (Two y z)) =
685 Just2 (Deep (s - size z) pr m (One y)) z
686 viewRTree (Deep s pr m (Three x y z)) =
687 Just2 (Deep (s - size z) pr m (Two x y)) z
688 viewRTree (Deep s pr m (Four w x y z)) =
689 Just2 (Deep (s - size z) pr m (Three w x y)) z
690
691 -- Indexing
692
693 -- | /O(log(min(i,n-i)))/. The element at the specified position
694 index :: Seq a -> Int -> a
695 index (Seq xs) i
696 | 0 <= i && i < size xs = case lookupTree (-i) xs of
697 Place _ (Elem x) -> x
698 | otherwise = error "index out of bounds"
699
700 data Place a = Place {-# UNPACK #-} !Int a
701 #if TESTING
702 deriving Show
703 #endif
704
705 {-# SPECIALIZE lookupTree :: Int -> FingerTree (Elem a) -> Place (Elem a) #-}
706 {-# SPECIALIZE lookupTree :: Int -> FingerTree (Node a) -> Place (Node a) #-}
707 lookupTree :: Sized a => Int -> FingerTree a -> Place a
708 lookupTree _ Empty = error "lookupTree of empty tree"
709 lookupTree i (Single x) = Place i x
710 lookupTree i (Deep _ pr m sf)
711 | vpr > 0 = lookupDigit i pr
712 | vm > 0 = case lookupTree vpr m of
713 Place i' xs -> lookupNode i' xs
714 | otherwise = lookupDigit vm sf
715 where vpr = i + size pr
716 vm = vpr + size m
717
718 {-# SPECIALIZE lookupNode :: Int -> Node (Elem a) -> Place (Elem a) #-}
719 {-# SPECIALIZE lookupNode :: Int -> Node (Node a) -> Place (Node a) #-}
720 lookupNode :: Sized a => Int -> Node a -> Place a
721 lookupNode i (Node2 _ a b)
722 | va > 0 = Place i a
723 | otherwise = Place va b
724 where va = i + size a
725 lookupNode i (Node3 _ a b c)
726 | va > 0 = Place i a
727 | vab > 0 = Place va b
728 | otherwise = Place vab c
729 where va = i + size a
730 vab = va + size b
731
732 {-# SPECIALIZE lookupDigit :: Int -> Digit (Elem a) -> Place (Elem a) #-}
733 {-# SPECIALIZE lookupDigit :: Int -> Digit (Node a) -> Place (Node a) #-}
734 lookupDigit :: Sized a => Int -> Digit a -> Place a
735 lookupDigit i (One a) = Place i a
736 lookupDigit i (Two a b)
737 | va > 0 = Place i a
738 | otherwise = Place va b
739 where va = i + size a
740 lookupDigit i (Three a b c)
741 | va > 0 = Place i a
742 | vab > 0 = Place va b
743 | otherwise = Place vab c
744 where va = i + size a
745 vab = va + size b
746 lookupDigit i (Four a b c d)
747 | va > 0 = Place i a
748 | vab > 0 = Place va b
749 | vabc > 0 = Place vab c
750 | otherwise = Place vabc d
751 where va = i + size a
752 vab = va + size b
753 vabc = vab + size c
754
755 -- | /O(log(min(i,n-i)))/. Replace the element at the specified position
756 update :: Int -> a -> Seq a -> Seq a
757 update i x = adjust (const x) i
758
759 -- | /O(log(min(i,n-i)))/. Update the element at the specified position
760 adjust :: (a -> a) -> Int -> Seq a -> Seq a
761 adjust f i (Seq xs)
762 | 0 <= i && i < size xs = Seq (adjustTree (const (fmap f)) (-i) xs)
763 | otherwise = Seq xs
764
765 {-# SPECIALIZE adjustTree :: (Int -> Elem a -> Elem a) -> Int -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
766 {-# SPECIALIZE adjustTree :: (Int -> Node a -> Node a) -> Int -> FingerTree (Node a) -> FingerTree (Node a) #-}
767 adjustTree :: Sized a => (Int -> a -> a) ->
768 Int -> FingerTree a -> FingerTree a
769 adjustTree _ _ Empty = error "adjustTree of empty tree"
770 adjustTree f i (Single x) = Single (f i x)
771 adjustTree f i (Deep s pr m sf)
772 | vpr > 0 = Deep s (adjustDigit f i pr) m sf
773 | vm > 0 = Deep s pr (adjustTree (adjustNode f) vpr m) sf
774 | otherwise = Deep s pr m (adjustDigit f vm sf)
775 where vpr = i + size pr
776 vm = vpr + size m
777
778 {-# SPECIALIZE adjustNode :: (Int -> Elem a -> Elem a) -> Int -> Node (Elem a) -> Node (Elem a) #-}
779 {-# SPECIALIZE adjustNode :: (Int -> Node a -> Node a) -> Int -> Node (Node a) -> Node (Node a) #-}
780 adjustNode :: Sized a => (Int -> a -> a) -> Int -> Node a -> Node a
781 adjustNode f i (Node2 s a b)
782 | va > 0 = Node2 s (f i a) b
783 | otherwise = Node2 s a (f va b)
784 where va = i + size a
785 adjustNode f i (Node3 s a b c)
786 | va > 0 = Node3 s (f i a) b c
787 | vab > 0 = Node3 s a (f va b) c
788 | otherwise = Node3 s a b (f vab c)
789 where va = i + size a
790 vab = va + size b
791
792 {-# SPECIALIZE adjustDigit :: (Int -> Elem a -> Elem a) -> Int -> Digit (Elem a) -> Digit (Elem a) #-}
793 {-# SPECIALIZE adjustDigit :: (Int -> Node a -> Node a) -> Int -> Digit (Node a) -> Digit (Node a) #-}
794 adjustDigit :: Sized a => (Int -> a -> a) -> Int -> Digit a -> Digit a
795 adjustDigit f i (One a) = One (f i a)
796 adjustDigit f i (Two a b)
797 | va > 0 = Two (f i a) b
798 | otherwise = Two a (f va b)
799 where va = i + size a
800 adjustDigit f i (Three a b c)
801 | va > 0 = Three (f i a) b c
802 | vab > 0 = Three a (f va b) c
803 | otherwise = Three a b (f vab c)
804 where va = i + size a
805 vab = va + size b
806 adjustDigit f i (Four a b c d)
807 | va > 0 = Four (f i a) b c d
808 | vab > 0 = Four a (f va b) c d
809 | vabc > 0 = Four a b (f vab c) d
810 | otherwise = Four a b c (f vabc d)
811 where va = i + size a
812 vab = va + size b
813 vabc = vab + size c
814
815 -- Splitting
816
817 -- | /O(log(min(i,n-i)))/. The first @i@ elements of a sequence.
818 take :: Int -> Seq a -> Seq a
819 take i = fst . splitAt i
820
821 -- | /O(log(min(i,n-i)))/. Elements of a sequence after the first @i@.
822 drop :: Int -> Seq a -> Seq a
823 drop i = snd . splitAt i
824
825 -- | /O(log(min(i,n-i)))/. Split a sequence at a given position.
826 splitAt :: Int -> Seq a -> (Seq a, Seq a)
827 splitAt i (Seq xs) = (Seq l, Seq r)
828 where (l, r) = split i xs
829
830 split :: Int -> FingerTree (Elem a) ->
831 (FingerTree (Elem a), FingerTree (Elem a))
832 split i Empty = i `seq` (Empty, Empty)
833 split i xs
834 | size xs > i = (l, consTree x r)
835 | otherwise = (xs, Empty)
836 where Split l x r = splitTree (-i) xs
837
838 data Split t a = Split t a t
839 #if TESTING
840 deriving Show
841 #endif
842
843 {-# SPECIALIZE splitTree :: Int -> FingerTree (Elem a) -> Split (FingerTree (Elem a)) (Elem a) #-}
844 {-# SPECIALIZE splitTree :: Int -> FingerTree (Node a) -> Split (FingerTree (Node a)) (Node a) #-}
845 splitTree :: Sized a => Int -> FingerTree a -> Split (FingerTree a) a
846 splitTree _ Empty = error "splitTree of empty tree"
847 splitTree i (Single x) = i `seq` Split Empty x Empty
848 splitTree i (Deep _ pr m sf)
849 | vpr > 0 = case splitDigit i pr of
850 Split l x r -> Split (maybe Empty digitToTree l) x (deepL r m sf)
851 | vm > 0 = case splitTree vpr m of
852 Split ml xs mr -> case splitNode (vpr + size ml) xs of
853 Split l x r -> Split (deepR pr ml l) x (deepL r mr sf)
854 | otherwise = case splitDigit vm sf of
855 Split l x r -> Split (deepR pr m l) x (maybe Empty digitToTree r)
856 where vpr = i + size pr
857 vm = vpr + size m
858
859 {-# SPECIALIZE deepL :: Maybe (Digit (Elem a)) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
860 {-# SPECIALIZE deepL :: Maybe (Digit (Node a)) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}
861 deepL :: Sized a => Maybe (Digit a) -> FingerTree (Node a) -> Digit a -> FingerTree a
862 deepL Nothing m sf = case viewLTree m of
863 Nothing2 -> digitToTree sf
864 Just2 a m' -> deep (nodeToDigit a) m' sf
865 deepL (Just pr) m sf = deep pr m sf
866
867 {-# SPECIALIZE deepR :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Maybe (Digit (Elem a)) -> FingerTree (Elem a) #-}
868 {-# SPECIALIZE deepR :: Digit (Node a) -> FingerTree (Node (Node a)) -> Maybe (Digit (Node a)) -> FingerTree (Node a) #-}
869 deepR :: Sized a => Digit a -> FingerTree (Node a) -> Maybe (Digit a) -> FingerTree a
870 deepR pr m Nothing = case viewRTree m of
871 Nothing2 -> digitToTree pr
872 Just2 m' a -> deep pr m' (nodeToDigit a)
873 deepR pr m (Just sf) = deep pr m sf
874
875 {-# SPECIALIZE splitNode :: Int -> Node (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-}
876 {-# SPECIALIZE splitNode :: Int -> Node (Node a) -> Split (Maybe (Digit (Node a))) (Node a) #-}
877 splitNode :: Sized a => Int -> Node a -> Split (Maybe (Digit a)) a
878 splitNode i (Node2 _ a b)
879 | va > 0 = Split Nothing a (Just (One b))
880 | otherwise = Split (Just (One a)) b Nothing
881 where va = i + size a
882 splitNode i (Node3 _ a b c)
883 | va > 0 = Split Nothing a (Just (Two b c))
884 | vab > 0 = Split (Just (One a)) b (Just (One c))
885 | otherwise = Split (Just (Two a b)) c Nothing
886 where va = i + size a
887 vab = va + size b
888
889 {-# SPECIALIZE splitDigit :: Int -> Digit (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-}
890 {-# SPECIALIZE splitDigit :: Int -> Digit (Node a) -> Split (Maybe (Digit (Node a))) (Node a) #-}
891 splitDigit :: Sized a => Int -> Digit a -> Split (Maybe (Digit a)) a
892 splitDigit i (One a) = i `seq` Split Nothing a Nothing
893 splitDigit i (Two a b)
894 | va > 0 = Split Nothing a (Just (One b))
895 | otherwise = Split (Just (One a)) b Nothing
896 where va = i + size a
897 splitDigit i (Three a b c)
898 | va > 0 = Split Nothing a (Just (Two b c))
899 | vab > 0 = Split (Just (One a)) b (Just (One c))
900 | otherwise = Split (Just (Two a b)) c Nothing
901 where va = i + size a
902 vab = va + size b
903 splitDigit i (Four a b c d)
904 | va > 0 = Split Nothing a (Just (Three b c d))
905 | vab > 0 = Split (Just (One a)) b (Just (Two c d))
906 | vabc > 0 = Split (Just (Two a b)) c (Just (One d))
907 | otherwise = Split (Just (Three a b c)) d Nothing
908 where va = i + size a
909 vab = va + size b
910 vabc = vab + size c
911
912 ------------------------------------------------------------------------
913 -- Lists
914 ------------------------------------------------------------------------
915
916 -- | /O(n)/. Create a sequence from a finite list of elements.
917 fromList :: [a] -> Seq a
918 fromList = Data.List.foldl' (|>) empty
919
920 -- | /O(n)/. List of elements of the sequence.
921 toList :: Seq a -> [a]
922 #ifdef __GLASGOW_HASKELL__
923 {-# INLINE toList #-}
924 toList xs = build (\ c n -> foldr c n xs)
925 #else
926 toList = foldr (:) []
927 #endif
928
929 ------------------------------------------------------------------------
930 -- Folds
931 ------------------------------------------------------------------------
932
933 -- | /O(n*t)/. Fold over the elements of a sequence,
934 -- associating to the right.
935 foldr :: (a -> b -> b) -> b -> Seq a -> b
936 foldr f z (Seq xs) = foldrTree f' z xs
937 where f' (Elem x) y = f x y
938
939 foldrTree :: (a -> b -> b) -> b -> FingerTree a -> b
940 foldrTree _ z Empty = z
941 foldrTree f z (Single x) = x `f` z
942 foldrTree f z (Deep _ pr m sf) =
943 foldrDigit f (foldrTree (flip (foldrNode f)) (foldrDigit f z sf) m) pr
944
945 foldrDigit :: (a -> b -> b) -> b -> Digit a -> b
946 foldrDigit f z (One a) = a `f` z
947 foldrDigit f z (Two a b) = a `f` (b `f` z)
948 foldrDigit f z (Three a b c) = a `f` (b `f` (c `f` z))
949 foldrDigit f z (Four a b c d) = a `f` (b `f` (c `f` (d `f` z)))
950
951 foldrNode :: (a -> b -> b) -> b -> Node a -> b
952 foldrNode f z (Node2 _ a b) = a `f` (b `f` z)
953 foldrNode f z (Node3 _ a b c) = a `f` (b `f` (c `f` z))
954
955 -- | /O(n*t)/. A variant of 'foldr' that has no base case,
956 -- and thus may only be applied to non-empty sequences.
957 foldr1 :: (a -> a -> a) -> Seq a -> a
958 foldr1 f (Seq xs) = getElem (foldr1Tree f' xs)
959 where f' (Elem x) (Elem y) = Elem (f x y)
960
961 foldr1Tree :: (a -> a -> a) -> FingerTree a -> a
962 foldr1Tree _ Empty = error "foldr1: empty sequence"
963 foldr1Tree _ (Single x) = x
964 foldr1Tree f (Deep _ pr m sf) =
965 foldrDigit f (foldrTree (flip (foldrNode f)) (foldr1Digit f sf) m) pr
966
967 foldr1Digit :: (a -> a -> a) -> Digit a -> a
968 foldr1Digit f (One a) = a
969 foldr1Digit f (Two a b) = a `f` b
970 foldr1Digit f (Three a b c) = a `f` (b `f` c)
971 foldr1Digit f (Four a b c d) = a `f` (b `f` (c `f` d))
972
973 -- | /O(n*t)/. Fold over the elements of a sequence,
974 -- associating to the left.
975 foldl :: (a -> b -> a) -> a -> Seq b -> a
976 foldl f z (Seq xs) = foldlTree f' z xs
977 where f' x (Elem y) = f x y
978
979 foldlTree :: (a -> b -> a) -> a -> FingerTree b -> a
980 foldlTree _ z Empty = z
981 foldlTree f z (Single x) = z `f` x
982 foldlTree f z (Deep _ pr m sf) =
983 foldlDigit f (foldlTree (foldlNode f) (foldlDigit f z pr) m) sf
984
985 foldlDigit :: (a -> b -> a) -> a -> Digit b -> a
986 foldlDigit f z (One a) = z `f` a
987 foldlDigit f z (Two a b) = (z `f` a) `f` b
988 foldlDigit f z (Three a b c) = ((z `f` a) `f` b) `f` c
989 foldlDigit f z (Four a b c d) = (((z `f` a) `f` b) `f` c) `f` d
990
991 foldlNode :: (a -> b -> a) -> a -> Node b -> a
992 foldlNode f z (Node2 _ a b) = (z `f` a) `f` b
993 foldlNode f z (Node3 _ a b c) = ((z `f` a) `f` b) `f` c
994
995 -- | /O(n*t)/. A variant of 'foldl' that has no base case,
996 -- and thus may only be applied to non-empty sequences.
997 foldl1 :: (a -> a -> a) -> Seq a -> a
998 foldl1 f (Seq xs) = getElem (foldl1Tree f' xs)
999 where f' (Elem x) (Elem y) = Elem (f x y)
1000
1001 foldl1Tree :: (a -> a -> a) -> FingerTree a -> a
1002 foldl1Tree _ Empty = error "foldl1: empty sequence"
1003 foldl1Tree _ (Single x) = x
1004 foldl1Tree f (Deep _ pr m sf) =
1005 foldlDigit f (foldlTree (foldlNode f) (foldl1Digit f pr) m) sf
1006
1007 foldl1Digit :: (a -> a -> a) -> Digit a -> a
1008 foldl1Digit f (One a) = a
1009 foldl1Digit f (Two a b) = a `f` b
1010 foldl1Digit f (Three a b c) = (a `f` b) `f` c
1011 foldl1Digit f (Four a b c d) = ((a `f` b) `f` c) `f` d
1012
1013 ------------------------------------------------------------------------
1014 -- Derived folds
1015 ------------------------------------------------------------------------
1016
1017 -- | /O(n*t)/. Fold over the elements of a sequence,
1018 -- associating to the right, but strictly.
1019 foldr' :: (a -> b -> b) -> b -> Seq a -> b
1020 foldr' f z xs = foldl f' id xs z
1021 where f' k x z = k $! f x z
1022
1023 -- | /O(n*t)/. Monadic fold over the elements of a sequence,
1024 -- associating to the right, i.e. from right to left.
1025 foldrM :: Monad m => (a -> b -> m b) -> b -> Seq a -> m b
1026 foldrM f z xs = foldl f' return xs z
1027 where f' k x z = f x z >>= k
1028
1029 -- | /O(n*t)/. Fold over the elements of a sequence,
1030 -- associating to the left, but strictly.
1031 foldl' :: (a -> b -> a) -> a -> Seq b -> a
1032 foldl' f z xs = foldr f' id xs z
1033 where f' x k z = k $! f z x
1034
1035 -- | /O(n*t)/. Monadic fold over the elements of a sequence,
1036 -- associating to the left, i.e. from left to right.
1037 foldlM :: Monad m => (a -> b -> m a) -> a -> Seq b -> m a
1038 foldlM f z xs = foldr f' return xs z
1039 where f' x k z = f z x >>= k
1040
1041 ------------------------------------------------------------------------
1042 -- Reverse
1043 ------------------------------------------------------------------------
1044
1045 -- | /O(n)/. The reverse of a sequence.
1046 reverse :: Seq a -> Seq a
1047 reverse (Seq xs) = Seq (reverseTree id xs)
1048
1049 reverseTree :: (a -> a) -> FingerTree a -> FingerTree a
1050 reverseTree _ Empty = Empty
1051 reverseTree f (Single x) = Single (f x)
1052 reverseTree f (Deep s pr m sf) =
1053 Deep s (reverseDigit f sf)
1054 (reverseTree (reverseNode f) m)
1055 (reverseDigit f pr)
1056
1057 reverseDigit :: (a -> a) -> Digit a -> Digit a
1058 reverseDigit f (One a) = One (f a)
1059 reverseDigit f (Two a b) = Two (f b) (f a)
1060 reverseDigit f (Three a b c) = Three (f c) (f b) (f a)
1061 reverseDigit f (Four a b c d) = Four (f d) (f c) (f b) (f a)
1062
1063 reverseNode :: (a -> a) -> Node a -> Node a
1064 reverseNode f (Node2 s a b) = Node2 s (f b) (f a)
1065 reverseNode f (Node3 s a b c) = Node3 s (f c) (f b) (f a)
1066
1067 #if TESTING
1068
1069 ------------------------------------------------------------------------
1070 -- QuickCheck
1071 ------------------------------------------------------------------------
1072
1073 instance Arbitrary a => Arbitrary (Seq a) where
1074 arbitrary = liftM Seq arbitrary
1075 coarbitrary (Seq x) = coarbitrary x
1076
1077 instance Arbitrary a => Arbitrary (Elem a) where
1078 arbitrary = liftM Elem arbitrary
1079 coarbitrary (Elem x) = coarbitrary x
1080
1081 instance (Arbitrary a, Sized a) => Arbitrary (FingerTree a) where
1082 arbitrary = sized arb
1083 where arb :: (Arbitrary a, Sized a) => Int -> Gen (FingerTree a)
1084 arb 0 = return Empty
1085 arb 1 = liftM Single arbitrary
1086 arb n = liftM3 deep arbitrary (arb (n `div` 2)) arbitrary
1087
1088 coarbitrary Empty = variant 0
1089 coarbitrary (Single x) = variant 1 . coarbitrary x
1090 coarbitrary (Deep _ pr m sf) =
1091 variant 2 . coarbitrary pr . coarbitrary m . coarbitrary sf
1092
1093 instance (Arbitrary a, Sized a) => Arbitrary (Node a) where
1094 arbitrary = oneof [
1095 liftM2 node2 arbitrary arbitrary,
1096 liftM3 node3 arbitrary arbitrary arbitrary]
1097
1098 coarbitrary (Node2 _ a b) = variant 0 . coarbitrary a . coarbitrary b
1099 coarbitrary (Node3 _ a b c) =
1100 variant 1 . coarbitrary a . coarbitrary b . coarbitrary c
1101
1102 instance Arbitrary a => Arbitrary (Digit a) where
1103 arbitrary = oneof [
1104 liftM One arbitrary,
1105 liftM2 Two arbitrary arbitrary,
1106 liftM3 Three arbitrary arbitrary arbitrary,
1107 liftM4 Four arbitrary arbitrary arbitrary arbitrary]
1108
1109 coarbitrary (One a) = variant 0 . coarbitrary a
1110 coarbitrary (Two a b) = variant 1 . coarbitrary a . coarbitrary b
1111 coarbitrary (Three a b c) =
1112 variant 2 . coarbitrary a . coarbitrary b . coarbitrary c
1113 coarbitrary (Four a b c d) =
1114 variant 3 . coarbitrary a . coarbitrary b . coarbitrary c . coarbitrary d
1115
1116 ------------------------------------------------------------------------
1117 -- Valid trees
1118 ------------------------------------------------------------------------
1119
1120 class Valid a where
1121 valid :: a -> Bool
1122
1123 instance Valid (Elem a) where
1124 valid _ = True
1125
1126 instance Valid (Seq a) where
1127 valid (Seq xs) = valid xs
1128
1129 instance (Sized a, Valid a) => Valid (FingerTree a) where
1130 valid Empty = True
1131 valid (Single x) = valid x
1132 valid (Deep s pr m sf) =
1133 s == size pr + size m + size sf && valid pr && valid m && valid sf
1134
1135 instance (Sized a, Valid a) => Valid (Node a) where
1136 valid (Node2 s a b) = s == size a + size b && valid a && valid b
1137 valid (Node3 s a b c) =
1138 s == size a + size b + size c && valid a && valid b && valid c
1139
1140 instance Valid a => Valid (Digit a) where
1141 valid (One a) = valid a
1142 valid (Two a b) = valid a && valid b
1143 valid (Three a b c) = valid a && valid b && valid c
1144 valid (Four a b c d) = valid a && valid b && valid c && valid d
1145
1146 #endif