content: -- |
  --   Module      :  Data.Edison.Seq.BraunSeq
  --   Copyright   :  Copyright (c) 1998-1999, 2008 Chris Okasaki
  --   License     :  MIT; see COPYRIGHT file for terms and conditions
  --
  --   Maintainer  :  robdockins AT fastmail DOT fm
  --   Stability   :  stable
  --   Portability :  GHC, Hugs (MPTC and FD)
  --
  --   One-sided Braun sequences.  All running times are as listed in
  --   "Data.Edison.Seq" except the following:
  --
  --   * lview, lcons, ltail*   @O( log n )@
  --
  --   * rcons, rview, rhead*, rtail*, size   @O( log^2 n )@
  --
  --   * copy, inBounds, lookup*, update, adjust  @O( log i )@
  --
  --   * append            @O( n1 log n2 )@
  --
  --   * concat            @O( n + m log m )@
  --
  --   * drop, splitAt     @O( i log n )@
  --
  --   * subseq            @O( i log n + len )@
  --
  --   * reverseOnto       @O( n1 log n2 )@
  --
  --   * concatMap, (>>=)  @O( n * t + m log m )@, where @n@ is the length of the input sequence
  --                                               @m@ is the length of the output sequence and @t@
  --                                               is the running time of @f@
  --
  --   By keeping track of the size, we could get rcons, rview, rhead*, and rtail*
  --   down to @O(log n)@ as well; furthermore, size would be @O( 1 )@.
  --
  --   /References:/
  --
  --   * Rob Hoogerwoord. \"A symmetric set of efficient list operations\".
  --     /Journal of Functional Programming/, 2(4):505--513, 1992.
  --
  --   * Rob Hoogerwoord. \"A Logarithmic Implementation of Flexible Arrays\".
  --     /Mathematics of Program Construction/ (MPC'92), pages 191-207.
  --
  --   * Chris Okasaki. \"Three algorithms on Braun Trees\".
  --     /Journal of Function Programming/ 7(6):661-666. Novemebr 1997.
  
  module Data.Edison.Seq.BraunSeq (
      -- * Sequence Type
      Seq, -- instance of Sequence, Functor, Monad, MonadPlus
  
      -- * Sequence Operations
      empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,
      lheadM,ltailM,rheadM,rtailM,
      null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,
      fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',
      reducer,reducer',reducel,reducel',reduce1,reduce1',
      copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,
      mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex',
      take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,
      zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,
      strict, strictWith,
  
      -- * Unit testing
      structuralInvariant,
  
      -- * Documentation
      moduleName
  ) where
  
  import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl',
                         filter,takeWhile,dropWhile,lookup,take,drop,splitAt,
                         zip,zip3,zipWith,zipWith3,unzip,unzip3,null)
  
  import qualified Control.Applicative as App
  import qualified Control.Monad.Fail as Fail
  import Control.Monad
  import Data.Maybe
  import Data.Monoid
  import Data.Semigroup as SG
  import Test.QuickCheck
  
  
  import Data.Edison.Prelude ( runFail_ )
  import qualified Data.Edison.Seq as S ( Sequence(..) )
  import Data.Edison.Seq.Defaults
  import qualified Data.Edison.Seq.ListSeq as L
  
  
  -- signatures for exported functions
  moduleName     :: String
  empty          :: Seq a
  singleton      :: a -> Seq a
  lcons          :: a -> Seq a -> Seq a
  rcons          :: a -> Seq a -> Seq a
  append         :: Seq a -> Seq a -> Seq a
  lview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)
  lhead          :: Seq a -> a
  lheadM         :: (Fail.MonadFail m) => Seq a -> m a
  ltail          :: Seq a -> Seq a
  ltailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)
  rview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)
  rhead          :: Seq a -> a
  rheadM         :: (Fail.MonadFail m) => Seq a -> m a
  rtail          :: Seq a -> Seq a
  rtailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)
  null           :: Seq a -> Bool
  size           :: Seq a -> Int
  concat         :: Seq (Seq a) -> Seq a
  reverse        :: Seq a -> Seq a
  reverseOnto    :: Seq a -> Seq a -> Seq a
  fromList       :: [a] -> Seq a
  toList         :: Seq a -> [a]
  map            :: (a -> b) -> Seq a -> Seq b
  concatMap      :: (a -> Seq b) -> Seq a -> Seq b
  fold           :: (a -> b -> b) -> b -> Seq a -> b
  fold'          :: (a -> b -> b) -> b -> Seq a -> b
  fold1          :: (a -> a -> a) -> Seq a -> a
  fold1'         :: (a -> a -> a) -> Seq a -> a
  foldr          :: (a -> b -> b) -> b -> Seq a -> b
  foldl          :: (b -> a -> b) -> b -> Seq a -> b
  foldr1         :: (a -> a -> a) -> Seq a -> a
  foldl1         :: (a -> a -> a) -> Seq a -> a
  reducer        :: (a -> a -> a) -> a -> Seq a -> a
  reducel        :: (a -> a -> a) -> a -> Seq a -> a
  reduce1        :: (a -> a -> a) -> Seq a -> a
  foldr'         :: (a -> b -> b) -> b -> Seq a -> b
  foldl'         :: (b -> a -> b) -> b -> Seq a -> b
  foldr1'        :: (a -> a -> a) -> Seq a -> a
  foldl1'        :: (a -> a -> a) -> Seq a -> a
  reducer'       :: (a -> a -> a) -> a -> Seq a -> a
  reducel'       :: (a -> a -> a) -> a -> Seq a -> a
  reduce1'       :: (a -> a -> a) -> Seq a -> a
  copy           :: Int -> a -> Seq a
  inBounds       :: Int -> Seq a -> Bool
  lookup         :: Int -> Seq a -> a
  lookupM        :: (Fail.MonadFail m) => Int -> Seq a -> m a
  lookupWithDefault :: a -> Int -> Seq a -> a
  update         :: Int -> a -> Seq a -> Seq a
  adjust         :: (a -> a) -> Int -> Seq a -> Seq a
  mapWithIndex   :: (Int -> a -> b) -> Seq a -> Seq b
  foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b
  foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b
  foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b
  foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b
  take           :: Int -> Seq a -> Seq a
  drop           :: Int -> Seq a -> Seq a
  splitAt        :: Int -> Seq a -> (Seq a, Seq a)
  subseq         :: Int -> Int -> Seq a -> Seq a
  filter         :: (a -> Bool) -> Seq a -> Seq a
  partition      :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
  takeWhile      :: (a -> Bool) -> Seq a -> Seq a
  dropWhile      :: (a -> Bool) -> Seq a -> Seq a
  splitWhile     :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
  zip            :: Seq a -> Seq b -> Seq (a,b)
  zip3           :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)
  zipWith        :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
  zipWith3       :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
  unzip          :: Seq (a,b) -> (Seq a, Seq b)
  unzip3         :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)
  unzipWith      :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)
  unzipWith3     :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)
  strict         :: Seq a -> Seq a
  strictWith     :: (a -> b) -> Seq a -> Seq a
  structuralInvariant :: Seq a -> Bool
  
  moduleName = "Data.Edison.Seq.BraunSeq"
  
  
  data Seq a = E | B a (Seq a) (Seq a)    deriving (Eq)
  
  half :: Int -> Int
  half n = n `quot` 2  -- use a shift?
  
  empty = E
  singleton x = B x E E
  
  lcons x E = singleton x
  lcons x (B y a b) = B x (lcons y b) a
  
  rcons y ys = insAt (size ys) ys
    where insAt 0 _ = singleton y
          insAt i (B x a b)
            | odd i     = B x (insAt (half i) a) b
            | otherwise = B x a (insAt (half i - 1) b)
          insAt _ _ = error "BraunSeq.rcons: bug.  Impossible case!"
  
  append xs E = xs
  append xs ys = app (size xs) xs ys
    where app 0 _ ys = ys
          app _ xs E = xs
          app n (B x a b) (B y c d)
              | odd n     = B x (app m a (lcons y d)) (app m b c)
              | otherwise = B x (app m a c) (app (m-1) b (lcons y d))
            where m = half n
          app _ _ _ = error "BraunSeq.append: bug!"
    -- how does it compare to converting to/from lists?
  
  lview E = fail "BraunSeq.lview: empty sequence"
  lview (B x a b) = return (x, combine a b)
  
  -- not exported
  combine :: Seq a -> Seq a -> Seq a
  combine E _ = E
  combine (B x a b) c = B x c (combine a b)
  
  lhead E = error "BraunSeq.lhead: empty sequence"
  lhead (B x _ _) = x
  
  lheadM E = fail "BraunSeq.lheadM: empty sequence"
  lheadM (B x _ _) = return x
  
  ltail E = error "BraunSeq.ltail: empty sequence"
  ltail (B _ a b) = combine a b
  
  ltailM E = fail "BraunSeq.ltailM: empty sequence"
  ltailM (B _ a b) = return (combine a b)
  
  -- not exported
  -- precondition: i >= 0
  delAt :: Int -> Seq a -> Seq a
  delAt 0 _ = E
  delAt i (B x a b)
    | odd i     = B x (delAt (half i) a) b
    | otherwise = B x a (delAt (half i - 1) b)
  delAt _ _ = error "BraunSeq.delAt: bug.  Impossible case!"
  
  rview E = fail "BraunSeq.rview: empty sequence"
  rview xs = return (lookup m xs, delAt m xs)
    where m = size xs - 1
  
  rhead E = error "BraunSeq.rhead: empty sequence"
  rhead xs = lookup (size xs - 1) xs
  
  rheadM E = fail  "BraunSeq.rheadM: empty sequence"
  rheadM xs = return (lookup (size xs - 1) xs)
  
  rtail E = error "BraunSeq.rtail: empty sequence"
  rtail xs = delAt (size xs - 1) xs
  
  rtailM E = fail "BraunSeq.rtailM: empty sequence"
  rtailM xs = return (delAt (size xs - 1) xs)
  
  null E = True
  null _ = False
  
  size E = 0
  size (B _ a b) = 1 + n + n + diff n a
    where n = size b
  
          diff 0 E = 0
          diff 0 (B _ _ _) = 1
          diff i (B _ a b)
            | odd i     = diff (half i) a
            | otherwise = diff (half i - 1) b
          diff _ _ = error "BraunSeq.size: bug. Impossible case in diff!"
  
  reverse xs = rev00 (size xs) xs
    where
      rev00 n xs
        | n <= 1 = xs
      rev00 n (B x a b)
        | odd n     = let a'      = rev00 m a
                          (x',b') = rev11 m x b      in B x' a' b'
        | otherwise = let (x',a') = rev01 m a
                          b'      = rev10 (m-1) x b  in B x' b' a'
        where m = half n
      rev00 _ _ = error "BraunSeq.reverse: bug!"
  
      rev11 _ x E = (x,E)
      rev11 n x (B y a b)
        | odd n     = let (x',a') = rev11 m x a
                          (y',b') = rev11 m y b      in (y', B x' b' a')
        | otherwise = let (x',a') = rev11 m x a
                          (y',b') = rev11 (m-1) y b  in (x', B y' a' b')
        where m = half n
  
      rev01 _ E = error "BraunSeq.reverse: bug!"
      rev01 n (B x a b)
        | n == 1    = (x, E)
        | odd n     = let (y',a') = rev01 m a
                          (x',b') = rev11 m x b      in (x', B y' b' a')
        | otherwise = let (y',a') = rev01 m a
                          (x',b') = rev11 (m-1) x b  in (y', B x' a' b')
        where m = half n
  
      rev10 _ x E = B x E E
      rev10 n x (B y a b)
        | odd n     = let a'      = rev10 m x a
                          (y',b') = rev11 m y b      in B y' a' b'
        | otherwise = let (x',a') = rev11 m x a
                          b'      = rev10 (m-1) y b  in B x' b' a'
        where m = half n
  
  fromList = L.lhead . L.foldr build [E] . rows 1
    where rows _ [] = []
          rows k xs = (k, ys) : rows (k+k) zs
            where (ys,zs) = L.splitAt k xs
  
          build (k,xs) ts = zipWithB xs ts1 ts2
            where (ts1, ts2) = L.splitAt k ts
  
          zipWithB [] _ _ = []
          zipWithB (x:xs) [] _ = singleton x : L.map singleton xs
          zipWithB (x:xs) (t:ts) [] = B x t E : zipWithB xs ts []
          zipWithB (x:xs) (t1:ts1) (t2:ts2) = B x t1 t2 : zipWithB xs ts1 ts2
  
  toList E = []
  toList t = tol [t]
    where tol [] = []
          tol ts = xs ++ tol (ts1 ++ ts2)
            where xs = L.map root ts
                  (ts1,ts2) = children ts
  
                  children [] = ([],[])
                  children (B _ E _ : _) = ([],[])
                  children (B _ a E : ts) = (a : leftChildren ts, [])
                  children (B _ a b : ts) = (a : ts1, b : ts2)
                    where (ts1, ts2) = children ts
                  children _ = error "BraunSeq.toList: bug!"
  
                  leftChildren [] = []
                  leftChildren (B _ E _ : _) = []
                  leftChildren (B _ a _ : ts) = a : leftChildren ts
                  leftChildren _ = error "BraunSeq.toList: bug!"
  
                  root (B x _ _) = x
                  root _ = error "BraunSeq.toList: bug!"
  
                  (B _ a _) = a
  --                (left _) = error "BraunSeq.toList: bug!"
  
  map _ E = E
  map f (B x a b) = B (f x) (map f a) (map f b)
  
  copy n x = if n <= 0 then empty else fst (copy2 n)
    where copy2 n
              | odd n     = (B x a a, B x b a)
              | n == 0    = (E, singleton x)
              | otherwise = (B x b a, B x b b)
            where (a, b) = copy2 (half (n-1))
  
  inBounds i xs = (i >= 0) && inb xs i
    where inb E _ = False
          inb (B _ a b) i
            | odd i     = inb a (half i)
            | i == 0    = True
            | otherwise = inb b (half i - 1)
  
  lookup i xs = runFail_ (lookupM i xs)
  
  lookupM i xs
    | i < 0     = fail "BraunSeq.lookupM: bad subscript"
    | otherwise = look xs i
    where look E _ = nothing
          look (B x a b) i
            | odd i     = look a (half i)
            | i == 0    = return x
            | otherwise = look b (half i - 1)
          nothing = fail "BraunSeq.lookupM: not found"
  
  lookupWithDefault d i xs = if i < 0 then d
                             else look xs i
    where look E _ = d
          look (B x a b) i
            | odd i     = look a (half i)
            | i == 0    = x
            | otherwise = look b (half i - 1)
  
  update i y xs = if i < 0 then xs else upd i xs
    where upd _ E = E
          upd i (B x a b)
            | odd i     = B x (upd (half i) a) b
            | i == 0    = B y a b
            | otherwise = B x a (upd (half i - 1) b)
  
  adjust f i xs = if i < 0 then xs else adj i xs
    where adj _ E = E
          adj i (B x a b)
            | odd i     = B x (adj (half i) a) b
            | i == 0    = B (f x) a b
            | otherwise = B x a (adj (half i - 1) b)
  
  mapWithIndex f xs = mwi 0 1 xs
    where mwi _ _ E = E
          mwi i d (B x a b) = B (f i x) (mwi (i+d) dd a) (mwi (i+dd) dd b)
            where dd = d+d
  
  take n xs = if n <= 0 then E else ta n xs
    where ta _ E = E
          ta n (B x a b)
              | odd n     = B x (ta m a) (ta m b)
              | n == 0    = E
              | otherwise = B x (ta m a) (ta (m-1) b)
            where m = half n
  
  drop n xs = if n <= 0 then xs else dr n xs
    where dr _ E = E
          dr n t@(B _ a b)
              | odd n     = combine (dr m a) (dr m b)
              | n == 0    = t
              | otherwise = combine (dr (m-1) b) (dr m a)
            where m = half n
  
  zip (B x a b) (B y c d) = B (x,y) (zip a c) (zip b d)
  zip _ _ = E
  
  zip3 (B x a b) (B y c d) (B z e f) = B (x,y,z) (zip3 a c e) (zip3 b d f)
  zip3 _ _ _ = E
  
  zipWith f (B x a b) (B y c d) = B (f x y) (zipWith f a c) (zipWith f b d)
  zipWith _ _ _ = E
  
  zipWith3 fn (B x a b) (B y c d) (B z e f) =
      B (fn x y z) (zipWith3 fn a c e) (zipWith3 fn b d f)
  zipWith3 _ _ _ _ = E
  
  unzip E = (E, E)
  unzip (B (x,y) a b) = (B x a1 b1, B y a2 b2)
    where (a1,a2) = unzip a
          (b1,b2) = unzip b
  
  unzip3 E = (E, E, E)
  unzip3 (B (x,y,z) a b) = (B x a1 b1, B y a2 b2, B z a3 b3)
    where (a1,a2,a3) = unzip3 a
          (b1,b2,b3) = unzip3 b
  
  unzipWith _ _ E = (E, E)
  unzipWith f g (B x a b) = (B (f x) a1 b1, B (g x) a2 b2)
    where (a1,a2) = unzipWith f g a
          (b1,b2) = unzipWith f g b
  
  unzipWith3 _ _ _ E = (E, E, E)
  unzipWith3 f g h (B x a b) = (B (f x) a1 b1, B (g x) a2 b2, B (h x) a3 b3)
    where (a1,a2,a3) = unzipWith3 f g h a
          (b1,b2,b3) = unzipWith3 f g h b
  
  
  strict s@E = s
  strict s@(B _ l r) = strict l `seq` strict r `seq` s
  
  strictWith _ s@E = s
  strictWith f s@(B x l r) = f x `seq` strictWith f l `seq` strictWith f r `seq` s
  
  -- invariants:
  --   * Left subtree is exactily the same size as the right
  --     subtree, or one element larger
  
  -- structuralInvariant :: Seq a -> Bool
  structuralInvariant E         = True
  structuralInvariant (B _ l r) = isJust (check l r)
  
    where check :: Seq a -> Seq a -> Maybe Int
          check E           E           = Just 1
          check (B _ E E)   E           = Just 2
          check (B _ l1 l2) (B _ r1 r2) = do
             x <- check l1 l2
             y <- check r1 r2
             if (x == y) || (x == y + 1)
                then return (x+y+1)
                else fail "unbalanced tree"
          check _ _ = fail "unbalanced tree"
  
  
  -- the remaining functions all use defaults
  
  concat = concatUsingFoldr
  reverseOnto = reverseOntoUsingReverse
  concatMap = concatMapUsingFoldr
  fold = foldrUsingLists
  fold' f = foldl'UsingLists (flip f)
  fold1 = fold1UsingFold
  fold1' = fold1'UsingFold'
  foldr = foldrUsingLists
  foldr' = foldr'UsingLists
  foldl = foldlUsingLists
  foldl' = foldl'UsingLists
  foldr1 = foldr1UsingLists
  foldr1' = foldr1'UsingLists
  foldl1 = foldl1UsingLists
  foldl1' = foldl1UsingLists
  reducer = reducerUsingReduce1
  reducer' = reducer'UsingReduce1'
  reducel = reducelUsingReduce1
  reducel' = reducel'UsingReduce1'
  reduce1 = reduce1UsingLists
  reduce1' = reduce1'UsingLists
  foldrWithIndex  = foldrWithIndexUsingLists
  foldrWithIndex' = foldrWithIndex'UsingLists
  foldlWithIndex  = foldlWithIndexUsingLists
  foldlWithIndex' = foldlWithIndex'UsingLists
  splitAt = splitAtDefault
  subseq = subseqDefault
  filter = filterUsingLists
  partition = partitionUsingLists
  takeWhile = takeWhileUsingLview
  dropWhile = dropWhileUsingLview
  splitWhile = splitWhileUsingLview
  
  
  -- instances
  
  instance S.Sequence Seq where
    {lcons = lcons; rcons = rcons;
     lview = lview; lhead = lhead; ltail = ltail;
     lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;
     rview = rview; rhead = rhead; rtail = rtail; null = null;
     size = size; concat = concat; reverse = reverse;
     reverseOnto = reverseOnto; fromList = fromList; toList = toList;
     fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';
     foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';
     foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';
     reducer = reducer; reducer' = reducer'; reducel = reducel;
     reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1';
     copy = copy; inBounds = inBounds; lookup = lookup;
     lookupM = lookupM; lookupWithDefault = lookupWithDefault;
     update = update; adjust = adjust; mapWithIndex = mapWithIndex;
     foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex';
     foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex';
     take = take; drop = drop; splitAt = splitAt; subseq = subseq;
     filter = filter; partition = partition; takeWhile = takeWhile;
     dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;
     zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;
     unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;
     strict = strict; strictWith = strictWith;
     structuralInvariant = structuralInvariant; instanceName _ = moduleName}
  
  instance Functor Seq where
    fmap = map
  
  instance App.Alternative Seq where
    empty = empty
    (<|>) = append
  
  instance App.Applicative Seq where
    pure = return
    x <*> y = do
       x' <- x
       y' <- y
       return (x' y')
  
  instance Monad Seq where
    return = singleton
    xs >>= k = concatMap k xs
  
  instance MonadPlus Seq where
    mplus = append
    mzero = empty
  
  -- instance Eq (Seq a) is derived
  
  instance Ord a => Ord (Seq a) where
    compare = defaultCompare
  
  instance Show a => Show (Seq a) where
    showsPrec = showsPrecUsingToList
  
  instance Read a => Read (Seq a) where
    readsPrec = readsPrecUsingFromList
  
  instance Arbitrary a => Arbitrary (Seq a) where
    arbitrary = arbitrary >>= (return . fromList)
  
  instance CoArbitrary a => CoArbitrary (Seq a) where
    coarbitrary xs = coarbitrary (toList xs)
  
  instance Semigroup (Seq a) where
    (<>) = append
  instance Monoid (Seq a) where
    mempty  = empty
    mappend = (SG.<>)
  