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