content: -- |
  --   Module      :  Data.Edison.Seq.MyersStack
  --   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)
  --
  --   Meyers Stacks.  All operations are as listed in "Data.Edison.Seq" except
  --   the following:
  --
  -- * lookup, inBounds, drop  @O( min(i, log n) )@
  --
  -- * rhead*, size  @O( log n )@
  --
  -- * subseq        @O( min (i, log n) + len )@
  --
  --   /References:/
  --
  -- * Eugene Myers. \"An applicative random-access stack\". /Information
  --   Processing Letters/, 17(5):241-248, December 1983.
  
  module Data.Edison.Seq.MyersStack (
      -- * 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 Data.Edison.Prelude ( runFail_ )
  import qualified Data.Edison.Seq as S ( Sequence(..) )
  import Data.Edison.Seq.Defaults
  import qualified Control.Monad.Fail as Fail
  import Control.Monad
  import Data.Monoid
  import Data.Semigroup as SG
  import Test.QuickCheck
  
  -- 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.MyersStack"
  
  
  data Seq a = E | C !Int a (Seq a) (Seq a)
    -- what about strictness flags on tail and jump-tail?
  
  -- auxiliary function
  jump :: Seq t -> Seq t
  jump (C _ _ _ (C _ _ _ xs')) = xs'
  jump _ = error "MyersStack.jump: bug!"
  
  empty = E
  singleton x = C 1 x E E
  
  lcons x xs@(C i _  _  (C j _ _ xs'))
      | i == j = C (1 + i + j) x xs xs'
  lcons x xs = C 1 x xs xs
  
  lview E = fail "MyersStack.lview: empty sequence"
  lview (C _ x xs _) = return (x, xs)
  
  lhead E = error "MyersStack.lhead: empty sequence"
  lhead (C _ x _ _) = x
  
  lheadM E = fail "MyersStack.lheadM: empty sequence"
  lheadM (C _ x _ _) = return x
  
  ltail E = error "MyersStack.ltail: empty sequence"
  ltail (C _ _ xs _) = xs
  
  ltailM E = fail "MyersStack.ltailM: empty sequence"
  ltailM (C _ _ xs _) = return xs
  
  rview E = fail "MyersStack.rview: empty sequence"
  rview xs = return (rhead xs, rtail xs)
  
  rhead E = error "MyersStack.rhead: empty sequence"
  rhead (C _ x xs xs') = rh x xs xs'
    where rh _ _ (C _ y ys ys') = rh y ys ys'
          rh _ (C _ y ys ys') E = rh y ys ys'
          rh x E E = x
  
  rheadM E = fail "MyersStack.rheadM: empty sequence"
  rheadM (C _ x xs xs') = return (rh x xs xs')
    where rh _ _ (C _ y ys ys') = rh y ys ys'
          rh _ (C _ y ys ys') E = rh y ys ys'
          rh x E E = x
  
  rtail E = error "MyersStack.rtail: empty sequence"
  rtail (C _ x xs _) = rt x xs
    where rt _ E = E
          rt y (C _ x xs _) = lcons y (rt x xs)
  
  rtailM E = fail "MyersStack.rtailM: empty sequence"
  rtailM (C _ x xs _) = return (rt x xs)
    where rt _ E = E
          rt y (C _ x xs _) = lcons y (rt x xs)
  
  null E = True
  null _ = False
  
  size xs = go xs
    where go E = (0::Int)
          go (C j _ _ xs') = j + size xs'
  
  reverseOnto E ys = ys
  reverseOnto (C _ x xs _) ys = reverseOnto xs (lcons x ys)
  
  map _ E = E
  map f (C j x xs _')
      | j == 1    = C j (f x) ys ys
      | otherwise = C j (f x) ys (jump ys)
    where ys = map f xs
  
  fold  = foldr
  fold' f = foldl' (flip f)
  fold1  = fold1UsingFold
  fold1' = fold1'UsingFold'
  
  foldr _ e E = e
  foldr f e (C _ x xs _) = f x (foldr f e xs)
  
  foldr' _ e E = e
  foldr' f e (C _ x xs _) = f x $! (foldr' f e xs)
  
  foldl _ e E = e
  foldl f e (C _ x xs _) = foldl f (f e x) xs
  
  foldl' _ e E = e
  foldl' f e (C _ x xs _) = e `seq` foldl' f (f e x) xs
  
  foldr1 _ E = error "MyersStack.foldr1: empty sequence"
  foldr1 f (C _ x xs _) = fr x xs
    where fr y E = y
          fr y (C _ x xs _) = f y (fr x xs)
  
  foldr1' _ E = error "MyersStack.foldr1': empty sequence"
  foldr1' f (C _ x xs _) = fr x xs
    where fr y E = y
          fr y (C _ x xs _) = f y $! (fr x xs)
  
  foldl1 _ E = error "MyersStack.foldl1: empty sequence"
  foldl1 f (C _ x xs _) = foldl f x xs
  
  foldl1' _ E = error "MyersStack.foldl1': empty sequence"
  foldl1' f (C _ x xs _ ) = foldl' f x xs
  
  inBounds i xs = inb xs i
    where inb E _ = False
          inb (C j _ _ xs') i
            | i < j     = (i >= 0)
            | otherwise = inb xs' (i - j)
  
  lookup i xs = runFail_ (lookupM i xs)
  
  lookupM i xs = look xs i
    where look E _ = fail "MyersStack.lookup: bad subscript"
          look (C j x xs xs') i
            | i >= j   = look xs' (i - j)
            | i > 0    = look xs  (i - 1)
            | i == 0   = return x
            | otherwise = nothing
          nothing = fail "MyersStack.lookup: not found"
  
  lookupWithDefault d i xs = look xs i
    where look E _ = d
          look (C j x xs xs') i
            | i >= j   = look xs' (i - j)
            | i > 0    = look xs  (i - 1)
            | i == 0   = x
            | otherwise = d
  
  update i y xs = upd i xs
    where upd _ E = E
          upd 0 (C j _ xs xs') = C j y xs xs'
          upd i (C j x xs _)
              | j == 1    = C j x ys ys
              | otherwise = C j x ys (jump ys)
            where ys = upd (i - 1) xs
  
  adjust f i xs = adj i xs
    where adj _ E = E
          adj 0 (C j x xs xs') = C j (f x) xs xs'
          adj i (C j x xs _)
              | j == 1    = C j x ys ys
              | otherwise = C j x ys (jump ys)
            where ys = adj (i - (1::Int)) xs
  
  drop n xs = drp n xs
    where drp n xs | n <= 0 = xs
          drp _ E = E
          drp n (C j _ xs xs')
            | n < j     = drp (n - 1) xs
            | otherwise = drp (n - j) xs'
  
  unzip E = (E, E)
  unzip (C j (x,y) ps _')
      | j == 1    = (C j x xs xs, C j y ys ys)
      | otherwise = (C j x xs (jump xs), C j y ys (jump ys))
    where (xs,ys) = unzip ps
  
  unzip3 E = (E, E, E)
  unzip3 (C j (x,y,z) ts _')
      | j == 1    = (C j x xs xs, C j y ys ys, C j z zs zs)
      | otherwise = (C j x xs (jump xs), C j y ys (jump ys), C j z zs (jump zs))
    where (xs,ys,zs) = unzip3 ts
  
  unzipWith _ _ E = (E, E)
  unzipWith f g (C j x xs _)
      | j == 1    = (C j (f x) as as, C j (g x) bs bs)
      | otherwise = (C j (f x) as (jump as), C j (g x) bs (jump bs))
    where (as,bs) = unzipWith f g xs
  
  unzipWith3 _ _ _ E = (E, E, E)
  unzipWith3 f g h (C j x xs _)
      | j == 1    = (C j (f x) as as, C j (g x) bs bs, C j (h x) cs cs)
      | otherwise = (C j (f x) as (jump as), C j (g x) bs (jump bs),
                     C j (h x) cs (jump cs))
    where (as,bs,cs) = unzipWith3 f g h xs
  
  strict s@E = s
  strict s@(C _ _ xs _) = strict xs `seq` s
  
  strictWith _ s@E = s
  strictWith f s@(C _ x xs _) = f x `seq` strictWith f xs `seq` s
  
  -- the remaining functions all use defaults
  
  rcons = rconsUsingFoldr
  append = appendUsingFoldr
  concat = concatUsingFoldr
  reverse = reverseUsingReverseOnto
  fromList = fromListUsingCons
  toList = toListUsingFoldr
  concatMap = concatMapUsingFoldr
  reducer  = reducerUsingReduce1
  reducer' = reducer'UsingReduce1'
  reducel  = reducelUsingReduce1
  reducel' = reducel'UsingReduce1'
  reduce1  = reduce1UsingLists
  reduce1' = reduce1'UsingLists
  copy = copyUsingLists
  mapWithIndex = mapWithIndexUsingLists
  foldrWithIndex  = foldrWithIndexUsingLists
  foldrWithIndex' = foldrWithIndex'UsingLists
  foldlWithIndex  = foldlWithIndexUsingLists
  foldlWithIndex' = foldlWithIndex'UsingLists
  take = takeUsingLists
  splitAt = splitAtDefault
  filter = filterUsingFoldr
  partition = partitionUsingFoldr
  subseq = subseqDefault
  takeWhile = takeWhileUsingLview
  dropWhile = dropWhileUsingLview
  splitWhile = splitWhileUsingLview
  
  -- for zips, could optimize by calculating which one is shorter and
  -- retaining its shape
  
  zip = zipUsingLists
  zip3 = zip3UsingLists
  zipWith = zipWithUsingLists
  zipWith3 = zipWith3UsingLists
  
  -- FIXME what are the structural invariants?
  structuralInvariant = const True
  
  -- 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 a => Eq (Seq a) where
    xs == ys =
      (size xs == size ys) && (toList xs == toList ys)
  
  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 = do xs <- arbitrary
                   return (fromList xs)
  
  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.<>)
  
  -------------
  
  {-
  questions:
    - any benefit to
        E | C1 x xs | CJ Int# x xs xs'
  
    - any benefit to length instead of delta?
  
    - any benefit to delta not counting x (i.e., base 0 instead of base 1)?
  
  I don't believe any will do any better, except possibly the first
  -}
  