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