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