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