[project @ 2005-11-29 14:31:59 by ross]
[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 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 = fmapDefault
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 = gcast1
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 Traversable FingerTree where
227 traverse _ Empty = pure Empty
228 traverse f (Single x) = Single <$> f x
229 traverse f (Deep v pr m sf) =
230 Deep v <$> traverse f pr <*> traverse (traverse f) m <*>
231 traverse f sf
232
233 {-# INLINE deep #-}
234 {-# SPECIALIZE deep :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
235 {-# SPECIALIZE deep :: Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}
236 deep :: Sized a => Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a
237 deep pr m sf = Deep (size pr + size m + size sf) pr m sf
238
239 -- Digits
240
241 data Digit a
242 = One a
243 | Two a a
244 | Three a a a
245 | Four a a a a
246 #if TESTING
247 deriving Show
248 #endif
249
250 instance Foldable Digit where
251 foldr f z (One a) = a `f` z
252 foldr f z (Two a b) = a `f` (b `f` z)
253 foldr f z (Three a b c) = a `f` (b `f` (c `f` z))
254 foldr f z (Four a b c d) = a `f` (b `f` (c `f` (d `f` z)))
255
256 foldl f z (One a) = z `f` a
257 foldl f z (Two a b) = (z `f` a) `f` b
258 foldl f z (Three a b c) = ((z `f` a) `f` b) `f` c
259 foldl f z (Four a b c d) = (((z `f` a) `f` b) `f` c) `f` d
260
261 foldr1 f (One a) = a
262 foldr1 f (Two a b) = a `f` b
263 foldr1 f (Three a b c) = a `f` (b `f` c)
264 foldr1 f (Four a b c d) = a `f` (b `f` (c `f` d))
265
266 foldl1 f (One a) = a
267 foldl1 f (Two a b) = a `f` b
268 foldl1 f (Three a b c) = (a `f` b) `f` c
269 foldl1 f (Four a b c d) = ((a `f` b) `f` c) `f` d
270
271 instance Traversable Digit where
272 traverse f (One a) = One <$> f a
273 traverse f (Two a b) = Two <$> f a <*> f b
274 traverse f (Three a b c) = Three <$> f a <*> f b <*> f c
275 traverse f (Four a b c d) = Four <$> f a <*> f b <*> f c <*> f d
276
277 instance Sized a => Sized (Digit a) where
278 {-# SPECIALIZE instance Sized (Digit (Elem a)) #-}
279 {-# SPECIALIZE instance Sized (Digit (Node a)) #-}
280 size xs = foldl (\ i x -> i + size x) 0 xs
281
282 {-# SPECIALIZE digitToTree :: Digit (Elem a) -> FingerTree (Elem a) #-}
283 {-# SPECIALIZE digitToTree :: Digit (Node a) -> FingerTree (Node a) #-}
284 digitToTree :: Sized a => Digit a -> FingerTree a
285 digitToTree (One a) = Single a
286 digitToTree (Two a b) = deep (One a) Empty (One b)
287 digitToTree (Three a b c) = deep (Two a b) Empty (One c)
288 digitToTree (Four a b c d) = deep (Two a b) Empty (Two c d)
289
290 -- Nodes
291
292 data Node a
293 = Node2 {-# UNPACK #-} !Int a a
294 | Node3 {-# UNPACK #-} !Int a a a
295 #if TESTING
296 deriving Show
297 #endif
298
299 instance Foldable Node where
300 foldr f z (Node2 _ a b) = a `f` (b `f` z)
301 foldr f z (Node3 _ a b c) = a `f` (b `f` (c `f` z))
302
303 foldl f z (Node2 _ a b) = (z `f` a) `f` b
304 foldl f z (Node3 _ a b c) = ((z `f` a) `f` b) `f` c
305
306 instance Traversable Node where
307 traverse f (Node2 v a b) = Node2 v <$> f a <*> f b
308 traverse f (Node3 v a b c) = Node3 v <$> f a <*> f b <*> f c
309
310 instance Sized (Node a) where
311 size (Node2 v _ _) = v
312 size (Node3 v _ _ _) = v
313
314 {-# INLINE node2 #-}
315 {-# SPECIALIZE node2 :: Elem a -> Elem a -> Node (Elem a) #-}
316 {-# SPECIALIZE node2 :: Node a -> Node a -> Node (Node a) #-}
317 node2 :: Sized a => a -> a -> Node a
318 node2 a b = Node2 (size a + size b) a b
319
320 {-# INLINE node3 #-}
321 {-# SPECIALIZE node3 :: Elem a -> Elem a -> Elem a -> Node (Elem a) #-}
322 {-# SPECIALIZE node3 :: Node a -> Node a -> Node a -> Node (Node a) #-}
323 node3 :: Sized a => a -> a -> a -> Node a
324 node3 a b c = Node3 (size a + size b + size c) a b c
325
326 nodeToDigit :: Node a -> Digit a
327 nodeToDigit (Node2 _ a b) = Two a b
328 nodeToDigit (Node3 _ a b c) = Three a b c
329
330 -- Elements
331
332 newtype Elem a = Elem { getElem :: a }
333
334 instance Sized (Elem a) where
335 size _ = 1
336
337 instance Functor Elem where
338 fmap f (Elem x) = Elem (f x)
339
340 instance Foldable Elem where
341 foldr f z (Elem x) = f x z
342 foldl f z (Elem x) = f z x
343
344 instance Traversable Elem where
345 traverse f (Elem x) = Elem <$> f x
346
347 #ifdef TESTING
348 instance (Show a) => Show (Elem a) where
349 showsPrec p (Elem x) = showsPrec p x
350 #endif
351
352 ------------------------------------------------------------------------
353 -- Construction
354 ------------------------------------------------------------------------
355
356 -- | /O(1)/. The empty sequence.
357 empty :: Seq a
358 empty = Seq Empty
359
360 -- | /O(1)/. A singleton sequence.
361 singleton :: a -> Seq a
362 singleton x = Seq (Single (Elem x))
363
364 -- | /O(1)/. Add an element to the left end of a sequence.
365 -- Mnemonic: a triangle with the single element at the pointy end.
366 (<|) :: a -> Seq a -> Seq a
367 x <| Seq xs = Seq (Elem x `consTree` xs)
368
369 {-# SPECIALIZE consTree :: Elem a -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
370 {-# SPECIALIZE consTree :: Node a -> FingerTree (Node a) -> FingerTree (Node a) #-}
371 consTree :: Sized a => a -> FingerTree a -> FingerTree a
372 consTree a Empty = Single a
373 consTree a (Single b) = deep (One a) Empty (One b)
374 consTree a (Deep s (Four b c d e) m sf) = m `seq`
375 Deep (size a + s) (Two a b) (node3 c d e `consTree` m) sf
376 consTree a (Deep s (Three b c d) m sf) =
377 Deep (size a + s) (Four a b c d) m sf
378 consTree a (Deep s (Two b c) m sf) =
379 Deep (size a + s) (Three a b c) m sf
380 consTree a (Deep s (One b) m sf) =
381 Deep (size a + s) (Two a b) m sf
382
383 -- | /O(1)/. Add an element to the right end of a sequence.
384 -- Mnemonic: a triangle with the single element at the pointy end.
385 (|>) :: Seq a -> a -> Seq a
386 Seq xs |> x = Seq (xs `snocTree` Elem x)
387
388 {-# SPECIALIZE snocTree :: FingerTree (Elem a) -> Elem a -> FingerTree (Elem a) #-}
389 {-# SPECIALIZE snocTree :: FingerTree (Node a) -> Node a -> FingerTree (Node a) #-}
390 snocTree :: Sized a => FingerTree a -> a -> FingerTree a
391 snocTree Empty a = Single a
392 snocTree (Single a) b = deep (One a) Empty (One b)
393 snocTree (Deep s pr m (Four a b c d)) e = m `seq`
394 Deep (s + size e) pr (m `snocTree` node3 a b c) (Two d e)
395 snocTree (Deep s pr m (Three a b c)) d =
396 Deep (s + size d) pr m (Four a b c d)
397 snocTree (Deep s pr m (Two a b)) c =
398 Deep (s + size c) pr m (Three a b c)
399 snocTree (Deep s pr m (One a)) b =
400 Deep (s + size b) pr m (Two a b)
401
402 -- | /O(log(min(n1,n2)))/. Concatenate two sequences.
403 (><) :: Seq a -> Seq a -> Seq a
404 Seq xs >< Seq ys = Seq (appendTree0 xs ys)
405
406 -- The appendTree/addDigits gunk below is machine generated
407
408 appendTree0 :: FingerTree (Elem a) -> FingerTree (Elem a) -> FingerTree (Elem a)
409 appendTree0 Empty xs =
410 xs
411 appendTree0 xs Empty =
412 xs
413 appendTree0 (Single x) xs =
414 x `consTree` xs
415 appendTree0 xs (Single x) =
416 xs `snocTree` x
417 appendTree0 (Deep s1 pr1 m1 sf1) (Deep s2 pr2 m2 sf2) =
418 Deep (s1 + s2) pr1 (addDigits0 m1 sf1 pr2 m2) sf2
419
420 addDigits0 :: FingerTree (Node (Elem a)) -> Digit (Elem a) -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> FingerTree (Node (Elem a))
421 addDigits0 m1 (One a) (One b) m2 =
422 appendTree1 m1 (node2 a b) m2
423 addDigits0 m1 (One a) (Two b c) m2 =
424 appendTree1 m1 (node3 a b c) m2
425 addDigits0 m1 (One a) (Three b c d) m2 =
426 appendTree2 m1 (node2 a b) (node2 c d) m2
427 addDigits0 m1 (One a) (Four b c d e) m2 =
428 appendTree2 m1 (node3 a b c) (node2 d e) m2
429 addDigits0 m1 (Two a b) (One c) m2 =
430 appendTree1 m1 (node3 a b c) m2
431 addDigits0 m1 (Two a b) (Two c d) m2 =
432 appendTree2 m1 (node2 a b) (node2 c d) m2
433 addDigits0 m1 (Two a b) (Three c d e) m2 =
434 appendTree2 m1 (node3 a b c) (node2 d e) m2
435 addDigits0 m1 (Two a b) (Four c d e f) m2 =
436 appendTree2 m1 (node3 a b c) (node3 d e f) m2
437 addDigits0 m1 (Three a b c) (One d) m2 =
438 appendTree2 m1 (node2 a b) (node2 c d) m2
439 addDigits0 m1 (Three a b c) (Two d e) m2 =
440 appendTree2 m1 (node3 a b c) (node2 d e) m2
441 addDigits0 m1 (Three a b c) (Three d e f) m2 =
442 appendTree2 m1 (node3 a b c) (node3 d e f) m2
443 addDigits0 m1 (Three a b c) (Four d e f g) m2 =
444 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
445 addDigits0 m1 (Four a b c d) (One e) m2 =
446 appendTree2 m1 (node3 a b c) (node2 d e) m2
447 addDigits0 m1 (Four a b c d) (Two e f) m2 =
448 appendTree2 m1 (node3 a b c) (node3 d e f) m2
449 addDigits0 m1 (Four a b c d) (Three e f g) m2 =
450 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
451 addDigits0 m1 (Four 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
454 appendTree1 :: FingerTree (Node a) -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
455 appendTree1 Empty a xs =
456 a `consTree` xs
457 appendTree1 xs a Empty =
458 xs `snocTree` a
459 appendTree1 (Single x) a xs =
460 x `consTree` a `consTree` xs
461 appendTree1 xs a (Single x) =
462 xs `snocTree` a `snocTree` x
463 appendTree1 (Deep s1 pr1 m1 sf1) a (Deep s2 pr2 m2 sf2) =
464 Deep (s1 + size a + s2) pr1 (addDigits1 m1 sf1 a pr2 m2) sf2
465
466 addDigits1 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
467 addDigits1 m1 (One a) b (One c) m2 =
468 appendTree1 m1 (node3 a b c) m2
469 addDigits1 m1 (One a) b (Two c d) m2 =
470 appendTree2 m1 (node2 a b) (node2 c d) m2
471 addDigits1 m1 (One a) b (Three c d e) m2 =
472 appendTree2 m1 (node3 a b c) (node2 d e) m2
473 addDigits1 m1 (One a) b (Four c d e f) m2 =
474 appendTree2 m1 (node3 a b c) (node3 d e f) m2
475 addDigits1 m1 (Two a b) c (One d) m2 =
476 appendTree2 m1 (node2 a b) (node2 c d) m2
477 addDigits1 m1 (Two a b) c (Two d e) m2 =
478 appendTree2 m1 (node3 a b c) (node2 d e) m2
479 addDigits1 m1 (Two a b) c (Three d e f) m2 =
480 appendTree2 m1 (node3 a b c) (node3 d e f) m2
481 addDigits1 m1 (Two a b) c (Four d e f g) m2 =
482 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
483 addDigits1 m1 (Three a b c) d (One e) m2 =
484 appendTree2 m1 (node3 a b c) (node2 d e) m2
485 addDigits1 m1 (Three a b c) d (Two e f) m2 =
486 appendTree2 m1 (node3 a b c) (node3 d e f) m2
487 addDigits1 m1 (Three a b c) d (Three e f g) m2 =
488 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
489 addDigits1 m1 (Three 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 addDigits1 m1 (Four a b c d) e (One f) m2 =
492 appendTree2 m1 (node3 a b c) (node3 d e f) m2
493 addDigits1 m1 (Four a b c d) e (Two f g) m2 =
494 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
495 addDigits1 m1 (Four 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 addDigits1 m1 (Four 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
500 appendTree2 :: FingerTree (Node a) -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
501 appendTree2 Empty a b xs =
502 a `consTree` b `consTree` xs
503 appendTree2 xs a b Empty =
504 xs `snocTree` a `snocTree` b
505 appendTree2 (Single x) a b xs =
506 x `consTree` a `consTree` b `consTree` xs
507 appendTree2 xs a b (Single x) =
508 xs `snocTree` a `snocTree` b `snocTree` x
509 appendTree2 (Deep s1 pr1 m1 sf1) a b (Deep s2 pr2 m2 sf2) =
510 Deep (s1 + size a + size b + s2) pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2
511
512 addDigits2 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
513 addDigits2 m1 (One a) b c (One d) m2 =
514 appendTree2 m1 (node2 a b) (node2 c d) m2
515 addDigits2 m1 (One a) b c (Two d e) m2 =
516 appendTree2 m1 (node3 a b c) (node2 d e) m2
517 addDigits2 m1 (One a) b c (Three d e f) m2 =
518 appendTree2 m1 (node3 a b c) (node3 d e f) m2
519 addDigits2 m1 (One a) b c (Four d e f g) m2 =
520 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
521 addDigits2 m1 (Two a b) c d (One e) m2 =
522 appendTree2 m1 (node3 a b c) (node2 d e) m2
523 addDigits2 m1 (Two a b) c d (Two e f) m2 =
524 appendTree2 m1 (node3 a b c) (node3 d e f) m2
525 addDigits2 m1 (Two a b) c d (Three e f g) m2 =
526 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
527 addDigits2 m1 (Two 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 addDigits2 m1 (Three a b c) d e (One f) m2 =
530 appendTree2 m1 (node3 a b c) (node3 d e f) m2
531 addDigits2 m1 (Three a b c) d e (Two f g) m2 =
532 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
533 addDigits2 m1 (Three 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 addDigits2 m1 (Three 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 addDigits2 m1 (Four a b c d) e f (One g) m2 =
538 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
539 addDigits2 m1 (Four 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 addDigits2 m1 (Four 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 addDigits2 m1 (Four 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
546 appendTree3 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
547 appendTree3 Empty a b c xs =
548 a `consTree` b `consTree` c `consTree` xs
549 appendTree3 xs a b c Empty =
550 xs `snocTree` a `snocTree` b `snocTree` c
551 appendTree3 (Single x) a b c xs =
552 x `consTree` a `consTree` b `consTree` c `consTree` xs
553 appendTree3 xs a b c (Single x) =
554 xs `snocTree` a `snocTree` b `snocTree` c `snocTree` x
555 appendTree3 (Deep s1 pr1 m1 sf1) a b c (Deep s2 pr2 m2 sf2) =
556 Deep (s1 + size a + size b + size c + s2) pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2
557
558 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))
559 addDigits3 m1 (One a) b c d (One e) m2 =
560 appendTree2 m1 (node3 a b c) (node2 d e) m2
561 addDigits3 m1 (One a) b c d (Two e f) m2 =
562 appendTree2 m1 (node3 a b c) (node3 d e f) m2
563 addDigits3 m1 (One a) b c d (Three e f g) m2 =
564 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
565 addDigits3 m1 (One a) b c d (Four e f g h) m2 =
566 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
567 addDigits3 m1 (Two a b) c d e (One f) m2 =
568 appendTree2 m1 (node3 a b c) (node3 d e f) m2
569 addDigits3 m1 (Two a b) c d e (Two f g) m2 =
570 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
571 addDigits3 m1 (Two 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 addDigits3 m1 (Two 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 addDigits3 m1 (Three a b c) d e f (One g) m2 =
576 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
577 addDigits3 m1 (Three 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 addDigits3 m1 (Three 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 addDigits3 m1 (Three 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 addDigits3 m1 (Four 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 addDigits3 m1 (Four 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 addDigits3 m1 (Four 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 addDigits3 m1 (Four 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
592 appendTree4 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
593 appendTree4 Empty a b c d xs =
594 a `consTree` b `consTree` c `consTree` d `consTree` xs
595 appendTree4 xs a b c d Empty =
596 xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d
597 appendTree4 (Single x) a b c d xs =
598 x `consTree` a `consTree` b `consTree` c `consTree` d `consTree` xs
599 appendTree4 xs a b c d (Single x) =
600 xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d `snocTree` x
601 appendTree4 (Deep s1 pr1 m1 sf1) a b c d (Deep s2 pr2 m2 sf2) =
602 Deep (s1 + size a + size b + size c + size d + s2) pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2
603
604 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))
605 addDigits4 m1 (One a) b c d e (One f) m2 =
606 appendTree2 m1 (node3 a b c) (node3 d e f) m2
607 addDigits4 m1 (One a) b c d e (Two f g) m2 =
608 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
609 addDigits4 m1 (One a) b c d e (Three f g h) m2 =
610 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
611 addDigits4 m1 (One a) b c d e (Four f g h i) m2 =
612 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
613 addDigits4 m1 (Two a b) c d e f (One g) m2 =
614 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
615 addDigits4 m1 (Two a b) c d e f (Two g h) m2 =
616 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
617 addDigits4 m1 (Two a b) c d e f (Three g h i) m2 =
618 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
619 addDigits4 m1 (Two a b) c d e f (Four g h i j) m2 =
620 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
621 addDigits4 m1 (Three a b c) d e f g (One h) m2 =
622 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
623 addDigits4 m1 (Three a b c) d e f g (Two h i) m2 =
624 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
625 addDigits4 m1 (Three a b c) d e f g (Three h i j) m2 =
626 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
627 addDigits4 m1 (Three a b c) d e f g (Four h i j k) m2 =
628 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
629 addDigits4 m1 (Four a b c d) e f g h (One i) m2 =
630 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
631 addDigits4 m1 (Four a b c d) e f g h (Two i j) m2 =
632 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
633 addDigits4 m1 (Four a b c d) e f g h (Three i j k) m2 =
634 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
635 addDigits4 m1 (Four a b c d) e f g h (Four i j k l) m2 =
636 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2
637
638 ------------------------------------------------------------------------
639 -- Deconstruction
640 ------------------------------------------------------------------------
641
642 -- | /O(1)/. Is this the empty sequence?
643 null :: Seq a -> Bool
644 null (Seq Empty) = True
645 null _ = False
646
647 -- | /O(1)/. The number of elements in the sequence.
648 length :: Seq a -> Int
649 length (Seq xs) = size xs
650
651 -- Views
652
653 data Maybe2 a b = Nothing2 | Just2 a b
654
655 -- | View of the left end of a sequence.
656 data ViewL a
657 = EmptyL -- ^ empty sequence
658 | a :< Seq a -- ^ leftmost element and the rest of the sequence
659 #ifndef __HADDOCK__
660 # if __GLASGOW_HASKELL__
661 deriving (Eq, Ord, Show, Read, Data)
662 # else
663 deriving (Eq, Ord, Show, Read)
664 # endif
665 #else
666 instance Eq a => Eq (ViewL a)
667 instance Ord a => Ord (ViewL a)
668 instance Show a => Show (ViewL a)
669 instance Read a => Read (ViewL a)
670 instance Data a => Data (ViewL a)
671 #endif
672
673 INSTANCE_TYPEABLE1(ViewL,viewLTc,"ViewL")
674
675 instance Functor ViewL where
676 fmap = fmapDefault
677
678 instance Foldable ViewL where
679 foldr f z EmptyL = z
680 foldr f z (x :< xs) = f x (foldr f z xs)
681
682 foldl f z EmptyL = z
683 foldl f z (x :< xs) = foldl f (f z x) xs
684
685 foldl1 f EmptyL = error "foldl1: empty view"
686 foldl1 f (x :< xs) = foldl f x xs
687
688 instance Traversable ViewL where
689 traverse _ EmptyL = pure EmptyL
690 traverse f (x :< xs) = (:<) <$> f x <*> traverse f xs
691
692 -- | /O(1)/. Analyse the left end of a sequence.
693 viewl :: Seq a -> ViewL a
694 viewl (Seq xs) = case viewLTree xs of
695 Nothing2 -> EmptyL
696 Just2 (Elem x) xs' -> x :< Seq xs'
697
698 {-# SPECIALIZE viewLTree :: FingerTree (Elem a) -> Maybe2 (Elem a) (FingerTree (Elem a)) #-}
699 {-# SPECIALIZE viewLTree :: FingerTree (Node a) -> Maybe2 (Node a) (FingerTree (Node a)) #-}
700 viewLTree :: Sized a => FingerTree a -> Maybe2 a (FingerTree a)
701 viewLTree Empty = Nothing2
702 viewLTree (Single a) = Just2 a Empty
703 viewLTree (Deep s (One a) m sf) = Just2 a (case viewLTree m of
704 Nothing2 -> digitToTree sf
705 Just2 b m' -> Deep (s - size a) (nodeToDigit b) m' sf)
706 viewLTree (Deep s (Two a b) m sf) =
707 Just2 a (Deep (s - size a) (One b) m sf)
708 viewLTree (Deep s (Three a b c) m sf) =
709 Just2 a (Deep (s - size a) (Two b c) m sf)
710 viewLTree (Deep s (Four a b c d) m sf) =
711 Just2 a (Deep (s - size a) (Three b c d) m sf)
712
713 -- | View of the right end of a sequence.
714 data ViewR a
715 = EmptyR -- ^ empty sequence
716 | Seq a :> a -- ^ the sequence minus the rightmost element,
717 -- and the rightmost element
718 #ifndef __HADDOCK__
719 # if __GLASGOW_HASKELL__
720 deriving (Eq, Ord, Show, Read, Data)
721 # else
722 deriving (Eq, Ord, Show, Read)
723 # endif
724 #else
725 instance Eq a => Eq (ViewR a)
726 instance Ord a => Ord (ViewR a)
727 instance Show a => Show (ViewR a)
728 instance Read a => Read (ViewR a)
729 instance Data a => Data (ViewR a)
730 #endif
731
732 INSTANCE_TYPEABLE1(ViewR,viewRTc,"ViewR")
733
734 instance Functor ViewR where
735 fmap = fmapDefault
736
737 instance Foldable ViewR where
738 foldr f z EmptyR = z
739 foldr f z (xs :> x) = foldr f (f x z) xs
740
741 foldl f z EmptyR = z
742 foldl f z (xs :> x) = f (foldl f z xs) x
743
744 foldr1 f EmptyR = error "foldr1: empty view"
745 foldr1 f (xs :> x) = foldr f x xs
746
747 instance Traversable ViewR where
748 traverse _ EmptyR = pure EmptyR
749 traverse f (xs :> x) = (:>) <$> traverse f xs <*> f x
750
751 -- | /O(1)/. Analyse the right end of a sequence.
752 viewr :: Seq a -> ViewR a
753 viewr (Seq xs) = case viewRTree xs of
754 Nothing2 -> EmptyR
755 Just2 xs' (Elem x) -> Seq xs' :> x
756
757 {-# SPECIALIZE viewRTree :: FingerTree (Elem a) -> Maybe2 (FingerTree (Elem a)) (Elem a) #-}
758 {-# SPECIALIZE viewRTree :: FingerTree (Node a) -> Maybe2 (FingerTree (Node a)) (Node a) #-}
759 viewRTree :: Sized a => FingerTree a -> Maybe2 (FingerTree a) a
760 viewRTree Empty = Nothing2
761 viewRTree (Single z) = Just2 Empty z
762 viewRTree (Deep s pr m (One z)) = Just2 (case viewRTree m of
763 Nothing2 -> digitToTree pr
764 Just2 m' y -> Deep (s - size z) pr m' (nodeToDigit y)) z
765 viewRTree (Deep s pr m (Two y z)) =
766 Just2 (Deep (s - size z) pr m (One y)) z
767 viewRTree (Deep s pr m (Three x y z)) =
768 Just2 (Deep (s - size z) pr m (Two x y)) z
769 viewRTree (Deep s pr m (Four w x y z)) =
770 Just2 (Deep (s - size z) pr m (Three w x y)) z
771
772 -- Indexing
773
774 -- | /O(log(min(i,n-i)))/. The element at the specified position
775 index :: Seq a -> Int -> a
776 index (Seq xs) i
777 | 0 <= i && i < size xs = case lookupTree (-i) xs of
778 Place _ (Elem x) -> x
779 | otherwise = error "index out of bounds"
780
781 data Place a = Place {-# UNPACK #-} !Int a
782 #if TESTING
783 deriving Show
784 #endif
785
786 {-# SPECIALIZE lookupTree :: Int -> FingerTree (Elem a) -> Place (Elem a) #-}
787 {-# SPECIALIZE lookupTree :: Int -> FingerTree (Node a) -> Place (Node a) #-}
788 lookupTree :: Sized a => Int -> FingerTree a -> Place a
789 lookupTree _ Empty = error "lookupTree of empty tree"
790 lookupTree i (Single x) = Place i x
791 lookupTree i (Deep _ pr m sf)
792 | vpr > 0 = lookupDigit i pr
793 | vm > 0 = case lookupTree vpr m of
794 Place i' xs -> lookupNode i' xs
795 | otherwise = lookupDigit vm sf
796 where vpr = i + size pr
797 vm = vpr + size m
798
799 {-# SPECIALIZE lookupNode :: Int -> Node (Elem a) -> Place (Elem a) #-}
800 {-# SPECIALIZE lookupNode :: Int -> Node (Node a) -> Place (Node a) #-}
801 lookupNode :: Sized a => Int -> Node a -> Place a
802 lookupNode i (Node2 _ a b)
803 | va > 0 = Place i a
804 | otherwise = Place va b
805 where va = i + size a
806 lookupNode i (Node3 _ a b c)
807 | va > 0 = Place i a
808 | vab > 0 = Place va b
809 | otherwise = Place vab c
810 where va = i + size a
811 vab = va + size b
812
813 {-# SPECIALIZE lookupDigit :: Int -> Digit (Elem a) -> Place (Elem a) #-}
814 {-# SPECIALIZE lookupDigit :: Int -> Digit (Node a) -> Place (Node a) #-}
815 lookupDigit :: Sized a => Int -> Digit a -> Place a
816 lookupDigit i (One a) = Place i a
817 lookupDigit i (Two a b)
818 | va > 0 = Place i a
819 | otherwise = Place va b
820 where va = i + size a
821 lookupDigit i (Three a b c)
822 | va > 0 = Place i a
823 | vab > 0 = Place va b
824 | otherwise = Place vab c
825 where va = i + size a
826 vab = va + size b
827 lookupDigit i (Four a b c d)
828 | va > 0 = Place i a
829 | vab > 0 = Place va b
830 | vabc > 0 = Place vab c
831 | otherwise = Place vabc d
832 where va = i + size a
833 vab = va + size b
834 vabc = vab + size c
835
836 -- | /O(log(min(i,n-i)))/. Replace the element at the specified position
837 update :: Int -> a -> Seq a -> Seq a
838 update i x = adjust (const x) i
839
840 -- | /O(log(min(i,n-i)))/. Update the element at the specified position
841 adjust :: (a -> a) -> Int -> Seq a -> Seq a
842 adjust f i (Seq xs)
843 | 0 <= i && i < size xs = Seq (adjustTree (const (fmap f)) (-i) xs)
844 | otherwise = Seq xs
845
846 {-# SPECIALIZE adjustTree :: (Int -> Elem a -> Elem a) -> Int -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
847 {-# SPECIALIZE adjustTree :: (Int -> Node a -> Node a) -> Int -> FingerTree (Node a) -> FingerTree (Node a) #-}
848 adjustTree :: Sized a => (Int -> a -> a) ->
849 Int -> FingerTree a -> FingerTree a
850 adjustTree _ _ Empty = error "adjustTree of empty tree"
851 adjustTree f i (Single x) = Single (f i x)
852 adjustTree f i (Deep s pr m sf)
853 | vpr > 0 = Deep s (adjustDigit f i pr) m sf
854 | vm > 0 = Deep s pr (adjustTree (adjustNode f) vpr m) sf
855 | otherwise = Deep s pr m (adjustDigit f vm sf)
856 where vpr = i + size pr
857 vm = vpr + size m
858
859 {-# SPECIALIZE adjustNode :: (Int -> Elem a -> Elem a) -> Int -> Node (Elem a) -> Node (Elem a) #-}
860 {-# SPECIALIZE adjustNode :: (Int -> Node a -> Node a) -> Int -> Node (Node a) -> Node (Node a) #-}
861 adjustNode :: Sized a => (Int -> a -> a) -> Int -> Node a -> Node a
862 adjustNode f i (Node2 s a b)
863 | va > 0 = Node2 s (f i a) b
864 | otherwise = Node2 s a (f va b)
865 where va = i + size a
866 adjustNode f i (Node3 s a b c)
867 | va > 0 = Node3 s (f i a) b c
868 | vab > 0 = Node3 s a (f va b) c
869 | otherwise = Node3 s a b (f vab c)
870 where va = i + size a
871 vab = va + size b
872
873 {-# SPECIALIZE adjustDigit :: (Int -> Elem a -> Elem a) -> Int -> Digit (Elem a) -> Digit (Elem a) #-}
874 {-# SPECIALIZE adjustDigit :: (Int -> Node a -> Node a) -> Int -> Digit (Node a) -> Digit (Node a) #-}
875 adjustDigit :: Sized a => (Int -> a -> a) -> Int -> Digit a -> Digit a
876 adjustDigit f i (One a) = One (f i a)
877 adjustDigit f i (Two a b)
878 | va > 0 = Two (f i a) b
879 | otherwise = Two a (f va b)
880 where va = i + size a
881 adjustDigit f i (Three a b c)
882 | va > 0 = Three (f i a) b c
883 | vab > 0 = Three a (f va b) c
884 | otherwise = Three a b (f vab c)
885 where va = i + size a
886 vab = va + size b
887 adjustDigit f i (Four a b c d)
888 | va > 0 = Four (f i a) b c d
889 | vab > 0 = Four a (f va b) c d
890 | vabc > 0 = Four a b (f vab c) d
891 | otherwise = Four a b c (f vabc d)
892 where va = i + size a
893 vab = va + size b
894 vabc = vab + size c
895
896 -- Splitting
897
898 -- | /O(log(min(i,n-i)))/. The first @i@ elements of a sequence.
899 take :: Int -> Seq a -> Seq a
900 take i = fst . splitAt i
901
902 -- | /O(log(min(i,n-i)))/. Elements of a sequence after the first @i@.
903 drop :: Int -> Seq a -> Seq a
904 drop i = snd . splitAt i
905
906 -- | /O(log(min(i,n-i)))/. Split a sequence at a given position.
907 splitAt :: Int -> Seq a -> (Seq a, Seq a)
908 splitAt i (Seq xs) = (Seq l, Seq r)
909 where (l, r) = split i xs
910
911 split :: Int -> FingerTree (Elem a) ->
912 (FingerTree (Elem a), FingerTree (Elem a))
913 split i Empty = i `seq` (Empty, Empty)
914 split i xs
915 | size xs > i = (l, consTree x r)
916 | otherwise = (xs, Empty)
917 where Split l x r = splitTree (-i) xs
918
919 data Split t a = Split t a t
920 #if TESTING
921 deriving Show
922 #endif
923
924 {-# SPECIALIZE splitTree :: Int -> FingerTree (Elem a) -> Split (FingerTree (Elem a)) (Elem a) #-}
925 {-# SPECIALIZE splitTree :: Int -> FingerTree (Node a) -> Split (FingerTree (Node a)) (Node a) #-}
926 splitTree :: Sized a => Int -> FingerTree a -> Split (FingerTree a) a
927 splitTree _ Empty = error "splitTree of empty tree"
928 splitTree i (Single x) = i `seq` Split Empty x Empty
929 splitTree i (Deep _ pr m sf)
930 | vpr > 0 = case splitDigit i pr of
931 Split l x r -> Split (maybe Empty digitToTree l) x (deepL r m sf)
932 | vm > 0 = case splitTree vpr m of
933 Split ml xs mr -> case splitNode (vpr + size ml) xs of
934 Split l x r -> Split (deepR pr ml l) x (deepL r mr sf)
935 | otherwise = case splitDigit vm sf of
936 Split l x r -> Split (deepR pr m l) x (maybe Empty digitToTree r)
937 where vpr = i + size pr
938 vm = vpr + size m
939
940 {-# SPECIALIZE deepL :: Maybe (Digit (Elem a)) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
941 {-# SPECIALIZE deepL :: Maybe (Digit (Node a)) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}
942 deepL :: Sized a => Maybe (Digit a) -> FingerTree (Node a) -> Digit a -> FingerTree a
943 deepL Nothing m sf = case viewLTree m of
944 Nothing2 -> digitToTree sf
945 Just2 a m' -> deep (nodeToDigit a) m' sf
946 deepL (Just pr) m sf = deep pr m sf
947
948 {-# SPECIALIZE deepR :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Maybe (Digit (Elem a)) -> FingerTree (Elem a) #-}
949 {-# SPECIALIZE deepR :: Digit (Node a) -> FingerTree (Node (Node a)) -> Maybe (Digit (Node a)) -> FingerTree (Node a) #-}
950 deepR :: Sized a => Digit a -> FingerTree (Node a) -> Maybe (Digit a) -> FingerTree a
951 deepR pr m Nothing = case viewRTree m of
952 Nothing2 -> digitToTree pr
953 Just2 m' a -> deep pr m' (nodeToDigit a)
954 deepR pr m (Just sf) = deep pr m sf
955
956 {-# SPECIALIZE splitNode :: Int -> Node (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-}
957 {-# SPECIALIZE splitNode :: Int -> Node (Node a) -> Split (Maybe (Digit (Node a))) (Node a) #-}
958 splitNode :: Sized a => Int -> Node a -> Split (Maybe (Digit a)) a
959 splitNode i (Node2 _ a b)
960 | va > 0 = Split Nothing a (Just (One b))
961 | otherwise = Split (Just (One a)) b Nothing
962 where va = i + size a
963 splitNode i (Node3 _ a b c)
964 | va > 0 = Split Nothing a (Just (Two b c))
965 | vab > 0 = Split (Just (One a)) b (Just (One c))
966 | otherwise = Split (Just (Two a b)) c Nothing
967 where va = i + size a
968 vab = va + size b
969
970 {-# SPECIALIZE splitDigit :: Int -> Digit (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-}
971 {-# SPECIALIZE splitDigit :: Int -> Digit (Node a) -> Split (Maybe (Digit (Node a))) (Node a) #-}
972 splitDigit :: Sized a => Int -> Digit a -> Split (Maybe (Digit a)) a
973 splitDigit i (One a) = i `seq` Split Nothing a Nothing
974 splitDigit i (Two a b)
975 | va > 0 = Split Nothing a (Just (One b))
976 | otherwise = Split (Just (One a)) b Nothing
977 where va = i + size a
978 splitDigit i (Three a b c)
979 | va > 0 = Split Nothing a (Just (Two b c))
980 | vab > 0 = Split (Just (One a)) b (Just (One c))
981 | otherwise = Split (Just (Two a b)) c Nothing
982 where va = i + size a
983 vab = va + size b
984 splitDigit i (Four a b c d)
985 | va > 0 = Split Nothing a (Just (Three b c d))
986 | vab > 0 = Split (Just (One a)) b (Just (Two c d))
987 | vabc > 0 = Split (Just (Two a b)) c (Just (One d))
988 | otherwise = Split (Just (Three a b c)) d Nothing
989 where va = i + size a
990 vab = va + size b
991 vabc = vab + size c
992
993 ------------------------------------------------------------------------
994 -- Lists
995 ------------------------------------------------------------------------
996
997 -- | /O(n)/. Create a sequence from a finite list of elements.
998 fromList :: [a] -> Seq a
999 fromList = Data.List.foldl' (|>) empty
1000
1001 ------------------------------------------------------------------------
1002 -- Reverse
1003 ------------------------------------------------------------------------
1004
1005 -- | /O(n)/. The reverse of a sequence.
1006 reverse :: Seq a -> Seq a
1007 reverse (Seq xs) = Seq (reverseTree id xs)
1008
1009 reverseTree :: (a -> a) -> FingerTree a -> FingerTree a
1010 reverseTree _ Empty = Empty
1011 reverseTree f (Single x) = Single (f x)
1012 reverseTree f (Deep s pr m sf) =
1013 Deep s (reverseDigit f sf)
1014 (reverseTree (reverseNode f) m)
1015 (reverseDigit f pr)
1016
1017 reverseDigit :: (a -> a) -> Digit a -> Digit a
1018 reverseDigit f (One a) = One (f a)
1019 reverseDigit f (Two a b) = Two (f b) (f a)
1020 reverseDigit f (Three a b c) = Three (f c) (f b) (f a)
1021 reverseDigit f (Four a b c d) = Four (f d) (f c) (f b) (f a)
1022
1023 reverseNode :: (a -> a) -> Node a -> Node a
1024 reverseNode f (Node2 s a b) = Node2 s (f b) (f a)
1025 reverseNode f (Node3 s a b c) = Node3 s (f c) (f b) (f a)
1026
1027 #if TESTING
1028
1029 ------------------------------------------------------------------------
1030 -- QuickCheck
1031 ------------------------------------------------------------------------
1032
1033 instance Arbitrary a => Arbitrary (Seq a) where
1034 arbitrary = liftM Seq arbitrary
1035 coarbitrary (Seq x) = coarbitrary x
1036
1037 instance Arbitrary a => Arbitrary (Elem a) where
1038 arbitrary = liftM Elem arbitrary
1039 coarbitrary (Elem x) = coarbitrary x
1040
1041 instance (Arbitrary a, Sized a) => Arbitrary (FingerTree a) where
1042 arbitrary = sized arb
1043 where arb :: (Arbitrary a, Sized a) => Int -> Gen (FingerTree a)
1044 arb 0 = return Empty
1045 arb 1 = liftM Single arbitrary
1046 arb n = liftM3 deep arbitrary (arb (n `div` 2)) arbitrary
1047
1048 coarbitrary Empty = variant 0
1049 coarbitrary (Single x) = variant 1 . coarbitrary x
1050 coarbitrary (Deep _ pr m sf) =
1051 variant 2 . coarbitrary pr . coarbitrary m . coarbitrary sf
1052
1053 instance (Arbitrary a, Sized a) => Arbitrary (Node a) where
1054 arbitrary = oneof [
1055 liftM2 node2 arbitrary arbitrary,
1056 liftM3 node3 arbitrary arbitrary arbitrary]
1057
1058 coarbitrary (Node2 _ a b) = variant 0 . coarbitrary a . coarbitrary b
1059 coarbitrary (Node3 _ a b c) =
1060 variant 1 . coarbitrary a . coarbitrary b . coarbitrary c
1061
1062 instance Arbitrary a => Arbitrary (Digit a) where
1063 arbitrary = oneof [
1064 liftM One arbitrary,
1065 liftM2 Two arbitrary arbitrary,
1066 liftM3 Three arbitrary arbitrary arbitrary,
1067 liftM4 Four arbitrary arbitrary arbitrary arbitrary]
1068
1069 coarbitrary (One a) = variant 0 . coarbitrary a
1070 coarbitrary (Two a b) = variant 1 . coarbitrary a . coarbitrary b
1071 coarbitrary (Three a b c) =
1072 variant 2 . coarbitrary a . coarbitrary b . coarbitrary c
1073 coarbitrary (Four a b c d) =
1074 variant 3 . coarbitrary a . coarbitrary b . coarbitrary c . coarbitrary d
1075
1076 ------------------------------------------------------------------------
1077 -- Valid trees
1078 ------------------------------------------------------------------------
1079
1080 class Valid a where
1081 valid :: a -> Bool
1082
1083 instance Valid (Elem a) where
1084 valid _ = True
1085
1086 instance Valid (Seq a) where
1087 valid (Seq xs) = valid xs
1088
1089 instance (Sized a, Valid a) => Valid (FingerTree a) where
1090 valid Empty = True
1091 valid (Single x) = valid x
1092 valid (Deep s pr m sf) =
1093 s == size pr + size m + size sf && valid pr && valid m && valid sf
1094
1095 instance (Sized a, Valid a) => Valid (Node a) where
1096 valid (Node2 s a b) = s == size a + size b && valid a && valid b
1097 valid (Node3 s a b c) =
1098 s == size a + size b + size c && valid a && valid b && valid c
1099
1100 instance Valid a => Valid (Digit a) where
1101 valid (One a) = valid a
1102 valid (Two a b) = valid a && valid b
1103 valid (Three a b c) = valid a && valid b && valid c
1104 valid (Four a b c d) = valid a && valid b && valid c && valid d
1105
1106 #endif