content: {-# LANGUAGE UndecidableInstances #-}
  -----------------------------------------------------------------------------
  -- |
  -- Module      :  Data.Edison.Concrete.FingerTree
  -- Copyright   :  (c) Ross Paterson, Ralf Hinze 2006
  -- License     :  BSD-style
  -- Maintainer  :  robdockins AT fastmail DOT fm
  -- Stability   :  internal (non-stable)
  -- Portability :  non-portable (MPTCs and functional dependencies)
  --
  -- A general sequence representation with arbitrary annotations, for
  -- use as a base for implementations of various collection types, as
  -- described in section 4 of
  --
  --    * Ralf Hinze and Ross Paterson,
  --      \"Finger trees: a simple general-purpose data structure\",
  --      /Journal of Functional Programming/ 16:2 (2006) pp 197-217.
  --      <https://www.cs.tufts.edu/~nr/cs257/archive/ralf-hinze/finger-trees.pdf>
  --
  -- This data structure forms the basis of the "Data.Edison.Seq.FingerSeq"
  -- sequence data structure.
  --
  -- An amortized running time is given for each operation, with /n/
  -- referring to the length of the sequence.  These bounds hold even in
  -- a persistent (shared) setting.
  --
  -----------------------------------------------------------------------------
  
  {------------------------------------------------------------------
  
  Copyright 2004, 2008, The University Court of the University of Glasgow.
  All rights reserved.
  
  Redistribution and use in source and binary forms, with or without
  modification, are permitted provided that the following conditions are met:
  
  - Redistributions of source code must retain the above copyright notice,
  this list of conditions and the following disclaimer.
  
  - Redistributions in binary form must reproduce the above copyright notice,
  this list of conditions and the following disclaimer in the documentation
  and/or other materials provided with the distribution.
  
  - Neither name of the University nor the names of its contributors may be
  used to endorse or promote products derived from this software without
  specific prior written permission.
  
  THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
  GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
  INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
  FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
  FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
  CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
  DAMAGE.
  
  -----------------------------------------------------------------------------}
  
  
  module Data.Edison.Concrete.FingerTree (
          FingerTree,
          Split(..),
  
          empty, singleton, lcons, rcons, append,
          fromList, toList, null, size, lview, rview,
          split, takeUntil, dropUntil, splitTree,
          reverse, mapTree, foldFT, reduce1, reduce1',
          strict, strictWith, structuralInvariant
  
          -- traverse'
          ) where
  
  import Prelude hiding (null, reverse)
  import Data.Monoid
  import Test.QuickCheck
  
  import Data.Edison.Prelude
  
  import Control.Monad (liftM2, liftM3, liftM4)
  import qualified Control.Monad.Fail as Fail
  
  
  infixr 5 `lcons`
  infixl 5 `rcons0`
  
  data Digit a
          = One a
          | Two a a
          | Three a a a
          | Four a a a a
          deriving Show
  
  foldDigit :: (b -> b -> b) -> (a -> b) -> Digit a -> b
  foldDigit _ f (One a) = f a
  foldDigit mapp f (Two a b) = f a `mapp` f b
  foldDigit mapp f (Three a b c) = f a `mapp` f b `mapp` f c
  foldDigit mapp f (Four a b c d) = f a `mapp` f b `mapp` f c `mapp` f d
  
  reduceDigit :: (b -> b -> b) -> (a -> b) -> Digit a -> b
  reduceDigit _ f (One a) = f a
  reduceDigit mapp f (Two a b) = f a `mapp` f b
  reduceDigit mapp f (Three a b c) = f a `mapp` f b `mapp` f c
  reduceDigit mapp f (Four a b c d) = (f a `mapp` f b) `mapp` (f c `mapp` f d)
  
  digitToList :: Digit a -> [a] -> [a]
  digitToList (One a)        xs = a : xs
  digitToList (Two a b)      xs = a : b : xs
  digitToList (Three a b c)  xs = a : b : c : xs
  digitToList (Four a b c d) xs = a : b : c : d : xs
  
  sizeDigit :: (a -> Int) -> Digit a -> Int
  sizeDigit f (One x)        = f x
  sizeDigit f (Two x y)      = f x + f y
  sizeDigit f (Three x y z)  = f x + f y + f z
  sizeDigit f (Four x y z w) = f x + f y + f z + f w
  
  instance (Measured v a) => Measured v (Digit a) where
          measure = foldDigit mappend measure
  
  data Node v a = Node2 !v a a | Node3 !v a a a
          deriving Show
  
  sizeNode :: (a -> Int) -> Node v a -> Int
  sizeNode f (Node2 _ x y)   = f x + f y
  sizeNode f (Node3 _ x y z) = f x + f y + f z
  
  foldNode :: (b -> b -> b) -> (a -> b) -> Node v a -> b
  foldNode mapp f (Node2 _ a b)   = f a `mapp` f b
  foldNode mapp f (Node3 _ a b c) = f a `mapp` f b `mapp` f c
  
  nodeToList :: Node v a -> [a] -> [a]
  nodeToList (Node2 _ a b)   xs = a : b : xs
  nodeToList (Node3 _ a b c) xs = a : b : c : xs
  
  node2        ::  (Measured v a) => a -> a -> Node v a
  node2 a b    =   Node2 (measure a `mappend` measure b) a b
  
  node3        ::  (Measured v a) => a -> a -> a -> Node v a
  node3 a b c  =   Node3 (measure a `mappend` measure b `mappend` measure c) a b c
  
  instance (Monoid v) => Measured v (Node v a) where
          measure (Node2 v _ _)    =  v
          measure (Node3 v _ _ _)  =  v
  
  nodeToDigit :: Node v a -> Digit a
  nodeToDigit (Node2 _ a b) = Two a b
  nodeToDigit (Node3 _ a b c) = Three a b c
  
  
  -- | Finger trees with element type @a@, annotated with measures of type @v@.
  -- The operations enforce the constraint @'Measured' v a@.
  data FingerTree v a
          = Empty
          | Single a
          | Deep !v !(Digit a) (FingerTree v (Node v a)) !(Digit a)
  
  deep ::  (Measured v a) =>
           Digit a -> FingerTree v (Node v a) -> Digit a -> FingerTree v a
  deep pr m sf  =   Deep ((measure pr `mappendVal` m) `mappend` measure sf) pr m sf
  
  structuralInvariant :: (Eq v, Measured v a) => FingerTree v a -> Bool
  structuralInvariant Empty      = True
  structuralInvariant (Single _) = True
  structuralInvariant (Deep v pr m sf) =
       v == foldDigit mappend measure pr `mappend`
            foldFT    mempty mappend (foldNode mappend measure) m `mappend`
            foldDigit mappend measure sf
  
  instance (Measured v a) => Measured v (FingerTree v a) where
          measure Empty           =  mempty
          measure (Single x)      =  measure x
          measure (Deep v _ _ _)  =  v
  
  sizeFT :: (a -> Int) -> FingerTree v a -> Int
  sizeFT _ Empty            = 0
  sizeFT f (Single x)       = f x
  sizeFT f (Deep _ d1 m d2) = sizeDigit f d1 + sizeFT (sizeNode f) m + sizeDigit f d2
  
  size :: FingerTree v a -> Int
  size = sizeFT (const 1)
  
  foldFT :: b -> (b -> b -> b) -> (a -> b) -> FingerTree v a -> b
  foldFT mz _ _ Empty      = mz
  foldFT _ _ f (Single x) = f x
  foldFT mz mapp f (Deep _ pr m sf) =
               foldDigit  mapp f pr `mapp` foldFT mz mapp (foldNode mapp f) m `mapp` foldDigit mapp f sf
  
  ftToList :: FingerTree v a -> [a] -> [a]
  ftToList Empty xs             = xs
  ftToList (Single a) xs        = a : xs
  ftToList (Deep _ d1 ft d2) xs = digitToList d1 (foldr nodeToList [] . ftToList ft $ []) ++ (digitToList d2 xs)
  
  toList :: FingerTree v a -> [a]
  toList ft = ftToList ft []
  
  reduce1_aux :: (b -> b -> b) -> (a -> b) -> Digit a -> FingerTree v (Node v a) -> Digit a -> b
  reduce1_aux mapp f pr Empty sf =
       (reduceDigit mapp f pr) `mapp`
       (reduceDigit mapp f sf)
  
  reduce1_aux mapp f pr (Single x) sf =
       (reduceDigit mapp f pr) `mapp`
       (foldNode mapp f x)     `mapp`
       (reduceDigit mapp f sf)
  
  reduce1_aux mapp f pr (Deep _ pr' m sf') sf =
       (reduceDigit mapp f pr) `mapp`
       (reduce1_aux mapp
          (foldNode mapp f)
              pr' m sf')       `mapp`
       (reduceDigit mapp f sf)
  
  reduce1 :: (a -> a -> a) -> FingerTree v a -> a
  reduce1 _ Empty             = error "FingerTree.reduce1: empty tree"
  reduce1 _ (Single x)        = x
  reduce1 mapp (Deep _ pr m sf)  = reduce1_aux mapp id pr m sf
  
  reduce1' :: (a -> a -> a) -> FingerTree v a -> a
  reduce1' _ Empty            = error "FingerTree.reduce1': empty tree"
  reduce1' _ (Single x)       = x
  reduce1' mapp (Deep _ pr m sf) = reduce1_aux mapp' id pr m sf
    where mapp' x y = x `seq` y `seq` mapp x y
  
  
  strict :: FingerTree v a -> FingerTree v a
  strict xs = foldFT () seq (const ()) xs `seq` xs
  
  strictWith :: (a -> b) -> FingerTree v a -> FingerTree v a
  strictWith f xs = foldFT () seq (\x -> f x `seq` ()) xs `seq` xs
  
  instance (Measured v a, Eq a) => Eq (FingerTree v a) where
          xs == ys = toList xs == toList ys
  
  instance (Measured v a, Ord a) => Ord (FingerTree v a) where
          compare xs ys = compare (toList xs) (toList ys)
  
  instance (Measured v a, Show a) => Show (FingerTree v a) where
          showsPrec p xs = showParen (p > 10) $
                  showString "fromList " . shows (toList xs)
  
  mapTree :: (Measured v2 a2) =>
          (a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2
  mapTree _ Empty = Empty
  mapTree f (Single x) = Single (f x)
  mapTree f (Deep _ pr m sf) =
          deep (mapDigit f pr) (mapTree (mapNode f) m) (mapDigit f sf)
  
  mapNode :: (Measured v2 a2) =>
          (a1 -> a2) -> Node v1 a1 -> Node v2 a2
  mapNode f (Node2 _ a b) = node2 (f a) (f b)
  mapNode f (Node3 _ a b c) = node3 (f a) (f b) (f c)
  
  mapDigit :: (a -> b) -> Digit a -> Digit b
  mapDigit f (One a) = One (f a)
  mapDigit f (Two a b) = Two (f a) (f b)
  mapDigit f (Three a b c) = Three (f a) (f b) (f c)
  mapDigit f (Four a b c d) = Four (f a) (f b) (f c) (f d)
  
  
  {-
  -- | Like 'traverse', but with a more constrained type.
  traverse' :: (Measured v1 a1, Measured v2 a2, Applicative f) =>
          (a1 -> f a2) -> FingerTree v1 a1 -> f (FingerTree v2 a2)
  traverse' = traverseTree
  
  traverseTree :: (Measured v2 a2, Applicative f) =>
          (a1 -> f a2) -> FingerTree v1 a1 -> f (FingerTree v2 a2)
  traverseTree _ Empty = pure Empty
  traverseTree f (Single x) = Single <$> f x
  traverseTree f (Deep _ pr m sf) =
          deep <$> traverseDigit f pr <*> traverseTree (traverseNode f) m <*> traverseDigit f sf
  
  traverseNode :: (Measured v2 a2, Applicative f) =>
          (a1 -> f a2) -> Node v1 a1 -> f (Node v2 a2)
  traverseNode f (Node2 _ a b) = node2 <$> f a <*> f b
  traverseNode f (Node3 _ a b c) = node3 <$> f a <*> f b <*> f c
  
  traverseDigit :: (Applicative f) => (a -> f b) -> Digit a -> f (Digit b)
  traverseDigit f (One a) = One <$> f a
  traverseDigit f (Two a b) = Two <$> f a <*> f b
  traverseDigit f (Three a b c) = Three <$> f a <*> f b <*> f c
  traverseDigit f (Four a b c d) = Four <$> f a <*> f b <*> f c <*> f d
  -}
  
  -- | /O(1)/. The empty sequence.
  empty :: Measured v a => FingerTree v a
  empty = Empty
  
  -- | /O(1)/. A singleton sequence.
  singleton :: Measured v a => a -> FingerTree v a
  singleton = Single
  
  -- | /O(n)/. Create a sequence from a finite list of elements.
  fromList :: (Measured v a) => [a] -> FingerTree v a
  fromList = foldr lcons Empty
  
  -- | /O(1)/. Add an element to the left end of a sequence.
  lcons :: (Measured v a) => a -> FingerTree v a -> FingerTree v a
  a `lcons` Empty         =  Single a
  a `lcons` Single b              =  deep (One a) Empty (One b)
  a `lcons` Deep _ (Four b c d e) m sf = m `seq`
          deep (Two a b) (node3 c d e `lcons` m) sf
  a `lcons` Deep _ pr m sf        =  deep (consDigit a pr) m sf
  
  consDigit :: a -> Digit a -> Digit a
  consDigit a (One b) = Two a b
  consDigit a (Two b c) = Three a b c
  consDigit a (Three b c d) = Four a b c d
  consDigit _ _ = error "FingerTree.consDigit: bug!"
  
  -- | /O(1)/. Add an element to the right end of a sequence.
  rcons ::  (Measured v a) => a -> FingerTree v a -> FingerTree v a
  rcons = flip rcons0
  
  rcons0 :: (Measured v a) => FingerTree v a -> a -> FingerTree v a
  Empty `rcons0` a                =  Single a
  Single a `rcons0` b             =  deep (One a) Empty (One b)
  Deep _ pr m (Four a b c d) `rcons0` e = m `seq`
          deep pr (m `rcons0` node3 a b c) (Two d e)
  Deep _ pr m sf `rcons0` x       =  deep pr m (snocDigit sf x)
  
  snocDigit :: Digit a -> a -> Digit a
  snocDigit (One a) b = Two a b
  snocDigit (Two a b) c = Three a b c
  snocDigit (Three a b c) d = Four a b c d
  snocDigit _ _ = error "FingerTree.snocDigit: bug!"
  
  -- | /O(1)/. Is this the empty sequence?
  null :: (Measured v a) => FingerTree v a -> Bool
  null Empty = True
  null _ = False
  
  -- | /O(1)/. Analyse the left end of a sequence.
  lview :: (Measured v a, Fail.MonadFail m) => FingerTree v a -> m (a,FingerTree v a)
  lview Empty                 =  fail "FingerTree.lview: empty tree"
  lview (Single x)            =  return (x, Empty)
  lview (Deep _ (One x) m sf) =  return . (,) x $
          case lview m of
            Nothing     -> digitToTree sf
            Just (a,m') -> deep (nodeToDigit a) m' sf
  
  lview (Deep _ pr m sf)      =  return (lheadDigit pr, deep (ltailDigit pr) m sf)
  
  lheadDigit :: Digit a -> a
  lheadDigit (One a) = a
  lheadDigit (Two a _) = a
  lheadDigit (Three a _ _) = a
  lheadDigit (Four a _ _ _) = a
  
  ltailDigit :: Digit a -> Digit a
  ltailDigit (Two _ b) = One b
  ltailDigit (Three _ b c) = Two b c
  ltailDigit (Four _ b c d) = Three b c d
  ltailDigit _ = error "FingerTree.ltailDigit: bug!"
  
  -- | /O(1)/. Analyse the right end of a sequence.
  rview :: (Measured v a, Fail.MonadFail m) => FingerTree v a -> m (a, FingerTree v a)
  rview Empty                  = fail "FingerTree.rview: empty tree"
  rview (Single x)             = return (x, Empty)
  rview (Deep _ pr m (One x))  = return . (,) x $
          case rview m of
             Nothing      -> digitToTree pr
             Just (a,m')  -> deep pr m' (nodeToDigit a)
  
  rview (Deep _ pr m sf)       =  return (rheadDigit sf, deep pr m (rtailDigit sf))
  
  
  rheadDigit :: Digit a -> a
  rheadDigit (One a) = a
  rheadDigit (Two _ b) = b
  rheadDigit (Three _ _ c) = c
  rheadDigit (Four _ _ _ d) = d
  
  rtailDigit :: Digit a -> Digit a
  rtailDigit (Two a _) = One a
  rtailDigit (Three a b _) = Two a b
  rtailDigit (Four a b c _) = Three a b c
  rtailDigit _ = error "FingerTree.rtailDigit: bug!"
  
  digitToTree :: (Measured v a) => Digit a -> FingerTree v a
  digitToTree (One a) = Single a
  digitToTree (Two a b) = deep (One a) Empty (One b)
  digitToTree (Three a b c) = deep (Two a b) Empty (One c)
  digitToTree (Four a b c d) = deep (Two a b) Empty (Two c d)
  
  
  -- | /O(log(min(n1,n2)))/. Concatenate two sequences.
  append :: (Measured v a) => FingerTree v a -> FingerTree v a -> FingerTree v a
  append =  appendTree0
  
  appendTree0 :: (Measured v a) => FingerTree v a -> FingerTree v a -> FingerTree v a
  appendTree0 Empty xs =
          xs
  appendTree0 xs Empty =
          xs
  appendTree0 (Single x) xs =
          x `lcons` xs
  appendTree0 xs (Single x) =
          xs `rcons0` x
  appendTree0 (Deep _ pr1 m1 sf1) (Deep _ pr2 m2 sf2) =
          deep pr1 (addDigits0 m1 sf1 pr2 m2) sf2
  
  addDigits0 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)
  addDigits0 m1 (One a) (One b) m2 =
          appendTree1 m1 (node2 a b) m2
  addDigits0 m1 (One a) (Two b c) m2 =
          appendTree1 m1 (node3 a b c) m2
  addDigits0 m1 (One a) (Three b c d) m2 =
          appendTree2 m1 (node2 a b) (node2 c d) m2
  addDigits0 m1 (One a) (Four b c d e) m2 =
          appendTree2 m1 (node3 a b c) (node2 d e) m2
  addDigits0 m1 (Two a b) (One c) m2 =
          appendTree1 m1 (node3 a b c) m2
  addDigits0 m1 (Two a b) (Two c d) m2 =
          appendTree2 m1 (node2 a b) (node2 c d) m2
  addDigits0 m1 (Two a b) (Three c d e) m2 =
          appendTree2 m1 (node3 a b c) (node2 d e) m2
  addDigits0 m1 (Two a b) (Four c d e f) m2 =
          appendTree2 m1 (node3 a b c) (node3 d e f) m2
  addDigits0 m1 (Three a b c) (One d) m2 =
          appendTree2 m1 (node2 a b) (node2 c d) m2
  addDigits0 m1 (Three a b c) (Two d e) m2 =
          appendTree2 m1 (node3 a b c) (node2 d e) m2
  addDigits0 m1 (Three a b c) (Three d e f) m2 =
          appendTree2 m1 (node3 a b c) (node3 d e f) m2
  addDigits0 m1 (Three a b c) (Four d e f g) m2 =
          appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
  addDigits0 m1 (Four a b c d) (One e) m2 =
          appendTree2 m1 (node3 a b c) (node2 d e) m2
  addDigits0 m1 (Four a b c d) (Two e f) m2 =
          appendTree2 m1 (node3 a b c) (node3 d e f) m2
  addDigits0 m1 (Four a b c d) (Three e f g) m2 =
          appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
  addDigits0 m1 (Four a b c d) (Four e f g h) m2 =
          appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
  
  appendTree1 :: (Measured v a) => FingerTree v a -> a -> FingerTree v a -> FingerTree v a
  appendTree1 Empty a xs =
          a `lcons` xs
  appendTree1 xs a Empty =
          xs `rcons0` a
  appendTree1 (Single x) a xs =
          x `lcons` (a `lcons` xs)
  appendTree1 xs a (Single x) =
          xs `rcons0` a `rcons0` x
  appendTree1 (Deep _ pr1 m1 sf1) a (Deep _ pr2 m2 sf2) =
          deep pr1 (addDigits1 m1 sf1 a pr2 m2) sf2
  
  addDigits1 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)
  addDigits1 m1 (One a) b (One c) m2 =
          appendTree1 m1 (node3 a b c) m2
  addDigits1 m1 (One a) b (Two c d) m2 =
          appendTree2 m1 (node2 a b) (node2 c d) m2
  addDigits1 m1 (One a) b (Three c d e) m2 =
          appendTree2 m1 (node3 a b c) (node2 d e) m2
  addDigits1 m1 (One a) b (Four c d e f) m2 =
          appendTree2 m1 (node3 a b c) (node3 d e f) m2
  addDigits1 m1 (Two a b) c (One d) m2 =
          appendTree2 m1 (node2 a b) (node2 c d) m2
  addDigits1 m1 (Two a b) c (Two d e) m2 =
          appendTree2 m1 (node3 a b c) (node2 d e) m2
  addDigits1 m1 (Two a b) c (Three d e f) m2 =
          appendTree2 m1 (node3 a b c) (node3 d e f) m2
  addDigits1 m1 (Two a b) c (Four d e f g) m2 =
          appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
  addDigits1 m1 (Three a b c) d (One e) m2 =
          appendTree2 m1 (node3 a b c) (node2 d e) m2
  addDigits1 m1 (Three a b c) d (Two e f) m2 =
          appendTree2 m1 (node3 a b c) (node3 d e f) m2
  addDigits1 m1 (Three a b c) d (Three e f g) m2 =
          appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
  addDigits1 m1 (Three a b c) d (Four e f g h) m2 =
          appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
  addDigits1 m1 (Four a b c d) e (One f) m2 =
          appendTree2 m1 (node3 a b c) (node3 d e f) m2
  addDigits1 m1 (Four a b c d) e (Two f g) m2 =
          appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
  addDigits1 m1 (Four a b c d) e (Three f g h) m2 =
          appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
  addDigits1 m1 (Four a b c d) e (Four f g h i) m2 =
          appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
  
  appendTree2 :: (Measured v a) => FingerTree v a -> a -> a -> FingerTree v a -> FingerTree v a
  appendTree2 Empty a b xs =
          a `lcons` (b `lcons` xs)
  appendTree2 xs a b Empty =
          xs `rcons0` a `rcons0` b
  appendTree2 (Single x) a b xs =
          x `lcons` (a `lcons` (b `lcons` xs))
  appendTree2 xs a b (Single x) =
          xs `rcons0` a `rcons0` b `rcons0` x
  appendTree2 (Deep _ pr1 m1 sf1) a b (Deep _ pr2 m2 sf2) =
          deep pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2
  
  addDigits2 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)
  addDigits2 m1 (One a) b c (One d) m2 =
          appendTree2 m1 (node2 a b) (node2 c d) m2
  addDigits2 m1 (One a) b c (Two d e) m2 =
          appendTree2 m1 (node3 a b c) (node2 d e) m2
  addDigits2 m1 (One a) b c (Three d e f) m2 =
          appendTree2 m1 (node3 a b c) (node3 d e f) m2
  addDigits2 m1 (One a) b c (Four d e f g) m2 =
          appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
  addDigits2 m1 (Two a b) c d (One e) m2 =
          appendTree2 m1 (node3 a b c) (node2 d e) m2
  addDigits2 m1 (Two a b) c d (Two e f) m2 =
          appendTree2 m1 (node3 a b c) (node3 d e f) m2
  addDigits2 m1 (Two a b) c d (Three e f g) m2 =
          appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
  addDigits2 m1 (Two a b) c d (Four e f g h) m2 =
          appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
  addDigits2 m1 (Three a b c) d e (One f) m2 =
          appendTree2 m1 (node3 a b c) (node3 d e f) m2
  addDigits2 m1 (Three a b c) d e (Two f g) m2 =
          appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
  addDigits2 m1 (Three a b c) d e (Three f g h) m2 =
          appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
  addDigits2 m1 (Three a b c) d e (Four f g h i) m2 =
          appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
  addDigits2 m1 (Four a b c d) e f (One g) m2 =
          appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
  addDigits2 m1 (Four a b c d) e f (Two g h) m2 =
          appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
  addDigits2 m1 (Four a b c d) e f (Three g h i) m2 =
          appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
  addDigits2 m1 (Four a b c d) e f (Four g h i j) m2 =
          appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
  
  appendTree3 :: (Measured v a) => FingerTree v a -> a -> a -> a -> FingerTree v a -> FingerTree v a
  appendTree3 Empty a b c xs =
          a `lcons` (b `lcons` (c `lcons` xs))
  appendTree3 xs a b c Empty =
          xs `rcons0` a `rcons0` b `rcons0` c
  appendTree3 (Single x) a b c xs =
          x `lcons` (a `lcons` (b `lcons` (c `lcons` xs)))
  appendTree3 xs a b c (Single x) =
          xs `rcons0` a `rcons0` b `rcons0` c `rcons0` x
  appendTree3 (Deep _ pr1 m1 sf1) a b c (Deep _ pr2 m2 sf2) =
          deep pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2
  
  addDigits3 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)
  addDigits3 m1 (One a) b c d (One e) m2 =
          appendTree2 m1 (node3 a b c) (node2 d e) m2
  addDigits3 m1 (One a) b c d (Two e f) m2 =
          appendTree2 m1 (node3 a b c) (node3 d e f) m2
  addDigits3 m1 (One a) b c d (Three e f g) m2 =
          appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
  addDigits3 m1 (One a) b c d (Four e f g h) m2 =
          appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
  addDigits3 m1 (Two a b) c d e (One f) m2 =
          appendTree2 m1 (node3 a b c) (node3 d e f) m2
  addDigits3 m1 (Two a b) c d e (Two f g) m2 =
          appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
  addDigits3 m1 (Two a b) c d e (Three f g h) m2 =
          appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
  addDigits3 m1 (Two a b) c d e (Four f g h i) m2 =
          appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
  addDigits3 m1 (Three a b c) d e f (One g) m2 =
          appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
  addDigits3 m1 (Three a b c) d e f (Two g h) m2 =
          appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
  addDigits3 m1 (Three a b c) d e f (Three g h i) m2 =
          appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
  addDigits3 m1 (Three a b c) d e f (Four g h i j) m2 =
          appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
  addDigits3 m1 (Four a b c d) e f g (One h) m2 =
          appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
  addDigits3 m1 (Four a b c d) e f g (Two h i) m2 =
          appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
  addDigits3 m1 (Four a b c d) e f g (Three h i j) m2 =
          appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
  addDigits3 m1 (Four a b c d) e f g (Four h i j k) m2 =
          appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
  
  appendTree4 :: (Measured v a) => FingerTree v a -> a -> a -> a -> a -> FingerTree v a -> FingerTree v a
  appendTree4 Empty a b c d xs =
          a `lcons` b `lcons` c `lcons` d `lcons` xs
  appendTree4 xs a b c d Empty =
          xs `rcons0` a `rcons0` b `rcons0` c `rcons0` d
  appendTree4 (Single x) a b c d xs =
          x `lcons` a `lcons` b `lcons` c `lcons` d `lcons` xs
  appendTree4 xs a b c d (Single x) =
          xs `rcons0` a `rcons0` b `rcons0` c `rcons0` d `rcons0` x
  appendTree4 (Deep _ pr1 m1 sf1) a b c d (Deep _ pr2 m2 sf2) =
          deep pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2
  
  addDigits4 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)
  addDigits4 m1 (One a) b c d e (One f) m2 =
          appendTree2 m1 (node3 a b c) (node3 d e f) m2
  addDigits4 m1 (One a) b c d e (Two f g) m2 =
          appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
  addDigits4 m1 (One a) b c d e (Three f g h) m2 =
          appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
  addDigits4 m1 (One a) b c d e (Four f g h i) m2 =
          appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
  addDigits4 m1 (Two a b) c d e f (One g) m2 =
          appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
  addDigits4 m1 (Two a b) c d e f (Two g h) m2 =
          appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
  addDigits4 m1 (Two a b) c d e f (Three g h i) m2 =
          appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
  addDigits4 m1 (Two a b) c d e f (Four g h i j) m2 =
          appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
  addDigits4 m1 (Three a b c) d e f g (One h) m2 =
          appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
  addDigits4 m1 (Three a b c) d e f g (Two h i) m2 =
          appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
  addDigits4 m1 (Three a b c) d e f g (Three h i j) m2 =
          appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
  addDigits4 m1 (Three a b c) d e f g (Four h i j k) m2 =
          appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
  addDigits4 m1 (Four a b c d) e f g h (One i) m2 =
          appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
  addDigits4 m1 (Four a b c d) e f g h (Two i j) m2 =
          appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
  addDigits4 m1 (Four a b c d) e f g h (Three i j k) m2 =
          appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
  addDigits4 m1 (Four a b c d) e f g h (Four i j k l) m2 =
          appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2
  
  
  -- | /O(log(min(i,n-i)))/. Split a sequence at a point where the predicate
  -- on the accumulated measure changes from 'False' to 'True'.
  split ::  (Measured v a) =>
            (v -> Bool) -> FingerTree v a -> (FingerTree v a, FingerTree v a)
  split _p Empty  =  (Empty, Empty)
  split p xs
    | p (measure xs) =  (l, x `lcons` r)
    | otherwise   =  (xs, Empty)
    where Split l x r = splitTree p mempty xs
  
  takeUntil :: (Measured v a) => (v -> Bool) -> FingerTree v a -> FingerTree v a
  takeUntil p  =  fst . split p
  
  dropUntil :: (Measured v a) => (v -> Bool) -> FingerTree v a -> FingerTree v a
  dropUntil p  =  snd . split p
  
  data Split t a = Split t a t
  
  splitTree ::    (Measured v a) =>
                  (v -> Bool) -> v -> FingerTree v a -> Split (FingerTree v a) a
  splitTree _ _ Empty = error "FingerTree.splitTree: bug!"
  splitTree _p _i (Single x) = Split Empty x Empty
  splitTree p i (Deep _ pr m sf)
    | p vpr       =  let  Split l x r     =  splitDigit p i pr
                     in   Split (maybe Empty digitToTree l) x (deepL r m sf)
    | p vm        =  let  Split ml xs mr  =  splitTree p vpr m
                          Split l x r     =  splitNode p (vpr `mappendVal` ml) xs
                     in   Split (deepR pr  ml l) x (deepL r mr sf)
    | otherwise   =  let  Split l x r     =  splitDigit p vm sf
                     in   Split (deepR pr  m  l) x (maybe Empty digitToTree r)
    where vpr     =  i    `mappend`  measure pr
          vm      =  vpr  `mappendVal` m
  
  mappendVal :: (Measured v a) => v -> FingerTree v a -> v
  mappendVal v Empty = v
  mappendVal v t = v `mappend` measure t
  
  deepL          ::  (Measured v a) =>
          Maybe (Digit a) -> FingerTree v (Node v a) -> Digit a -> FingerTree v a
  deepL Nothing m sf      =   case lview m of
          Nothing     ->  digitToTree sf
          Just (a,m') ->  deep (nodeToDigit a) m' sf
  deepL (Just pr) m sf    =   deep pr m sf
  
  deepR          ::  (Measured v a) =>
          Digit a -> FingerTree v (Node v a) -> Maybe (Digit a) -> FingerTree v a
  deepR pr m Nothing      =   case rview m of
          Nothing     ->  digitToTree pr
          Just (a,m') ->  deep pr m' (nodeToDigit a)
  deepR pr m (Just sf)    =   deep pr m sf
  
  splitNode :: (Measured v a) => (v -> Bool) -> v -> Node v a ->
                  Split (Maybe (Digit a)) a
  splitNode p i (Node2 _ a b)
    | p va        = Split Nothing a (Just (One b))
    | otherwise   = Split (Just (One a)) b Nothing
    where va      = i `mappend` measure a
  splitNode p i (Node3 _ a b c)
    | p va        = Split Nothing a (Just (Two b c))
    | p vab       = Split (Just (One a)) b (Just (One c))
    | otherwise   = Split (Just (Two a b)) c Nothing
    where va      = i `mappend` measure a
          vab     = va `mappend` measure b
  
  splitDigit :: (Measured v a) => (v -> Bool) -> v -> Digit a ->
                  Split (Maybe (Digit a)) a
  splitDigit _ i (One a) = i `seq` Split Nothing a Nothing
  splitDigit p i (Two a b)
    | p va        = Split Nothing a (Just (One b))
    | otherwise   = Split (Just (One a)) b Nothing
    where va      = i `mappend` measure a
  splitDigit p i (Three a b c)
    | p va        = Split Nothing a (Just (Two b c))
    | p vab       = Split (Just (One a)) b (Just (One c))
    | otherwise   = Split (Just (Two a b)) c Nothing
    where va      = i `mappend` measure a
          vab     = va `mappend` measure b
  splitDigit p i (Four a b c d)
    | p va        = Split Nothing a (Just (Three b c d))
    | p vab       = Split (Just (One a)) b (Just (Two c d))
    | p vabc      = Split (Just (Two a b)) c (Just (One d))
    | otherwise   = Split (Just (Three a b c)) d Nothing
    where va      = i `mappend` measure a
          vab     = va `mappend` measure b
          vabc    = vab `mappend` measure c
  
  
  -- | /O(n)/. The reverse of a sequence.
  reverse :: (Measured v a) => FingerTree v a -> FingerTree v a
  reverse = reverseTree id
  
  reverseTree :: (Measured v2 a2) => (a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2
  reverseTree _ Empty = Empty
  reverseTree f (Single x) = Single (f x)
  reverseTree f (Deep _ pr m sf) =
          deep (reverseDigit f sf) (reverseTree (reverseNode f) m) (reverseDigit f pr)
  
  reverseNode :: (Measured v2 a2) => (a1 -> a2) -> Node v1 a1 -> Node v2 a2
  reverseNode f (Node2 _ a b) = node2 (f b) (f a)
  reverseNode f (Node3 _ a b c) = node3 (f c) (f b) (f a)
  
  reverseDigit :: (a -> b) -> Digit a -> Digit b
  reverseDigit f (One a) = One (f a)
  reverseDigit f (Two a b) = Two (f b) (f a)
  reverseDigit f (Three a b c) = Three (f c) (f b) (f a)
  reverseDigit f (Four a b c d) = Four (f d) (f c) (f b) (f a)
  
  two :: Monad m => m a -> m (a, a)
  two m = liftM2 (,) m m
  
  three :: Monad m => m a -> m (a, a, a)
  three m = liftM3 (,,) m m m
  
  four :: Monad m => m a -> m (a, a, a, a)
  four m = liftM4 (,,,) m m m m
  
  instance (Arbitrary a) => Arbitrary (Digit a) where
    arbitrary = oneof
                [ arbitrary       >>= \x         -> return (One x)
                , two arbitrary   >>= \(x,y)     -> return (Two x y)
                , three arbitrary >>= \(x,y,z)   -> return (Three x y z)
                , four arbitrary  >>= \(x,y,z,w) -> return (Four x y z w)
                ]
  
  
  instance (CoArbitrary a) => CoArbitrary (Digit a) where
    coarbitrary p = case p of
        One x        -> variant 0 . coarbitrary x
        Two x y      -> variant 1 . coarbitrary x . coarbitrary y
        Three x y z  -> variant 2 . coarbitrary x . coarbitrary y
                        . coarbitrary z
        Four x y z w -> variant 3 . coarbitrary x . coarbitrary y
                        . coarbitrary z . coarbitrary w
  
  
  instance (Measured v a, Arbitrary a) => Arbitrary (Node v a) where
    arbitrary = oneof
                [ two arbitrary   >>= \(x,y)     -> return (node2 x y)
                , three arbitrary >>= \(x,y,z)   -> return (node3 x y z)
                ]
  
  instance (Measured v a, CoArbitrary a) => CoArbitrary (Node v a) where
    coarbitrary p = case p of
         Node2 _ x y   -> variant 0 . coarbitrary x . coarbitrary y
         Node3 _ x y z -> variant 1 . coarbitrary x . coarbitrary y . coarbitrary z
  
  
  instance (Measured v a, Arbitrary a) => Arbitrary (FingerTree v a) where
    arbitrary = oneof
                 [ return Empty
                 , arbitrary >>= return . Single
                 , do
                     pf <- arbitrary
                     m  <- arbitrary
                     sf <- arbitrary
                     return (deep pf m sf)
                 ]
  
  instance (Measured v a, CoArbitrary a) => CoArbitrary (FingerTree v a) where
    coarbitrary p = case p of
           Empty          -> variant 0
           Single x       -> variant 1 . coarbitrary x
           Deep _ sf m pf -> variant 2 . coarbitrary sf . coarbitrary m . coarbitrary pf
  