Data/Sequence.hs

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