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