-- |
--   Module      :  Data.Edison.Seq.BankersQueue
--   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)
--
--   This module implements Banker's Queues. It has the standard running
--   times from "Data.Edison.Seq" except for the following:
--
--   * rcons, size, inBounds   @O( 1 )@
--
--   /References:/
--
--   * Chris Okasaki, /Purely Functional Data Structures/,
--     1998, sections 6.3.2 and 8.4.1.
--
--   * Chris Okasaki, \"Simple and efficient purely functional
--     queues and deques\", /Journal of Function Programming/
--     5(4):583-592, October 1995.

module Data.Edison.Seq.BankersQueue (
    -- * 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,
                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,
                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)

import qualified Data.Edison.Seq as S ( Sequence(..) )
import Data.Edison.Seq.Defaults
import qualified Data.Edison.Seq.ListSeq as L
import Data.Monoid
import Control.Monad.Identity
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          :: (Monad m) => Seq a -> m (a, Seq a)
lhead          :: Seq a -> a
lheadM         :: (Monad m) => Seq a -> m a
ltail          :: Seq a -> Seq a
ltailM         :: (Monad m) => Seq a -> m (Seq a)
rview          :: (Monad m) => Seq a -> m (a, Seq a)
rhead          :: Seq a -> a
rheadM         :: (Monad m) => Seq a -> m a
rtail          :: Seq a -> Seq a
rtailM         :: (Monad 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        :: (Monad 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.BankersQueue"


data Seq a = Q !Int [a] [a] !Int

-- invariant: front at least as long as rear
structuralInvariant (Q x f r y) =
    length f == x && length r == y && x >= y


-- not exported
makeQ :: Int -> [a] -> [a] -> Int -> Seq a
makeQ i xs ys j
  | j > i     = Q (i + j) (xs ++ L.reverse ys) [] 0
  | otherwise = Q i xs ys j

empty = Q 0 [] [] 0
singleton x = Q 1 [x] [] 0
lcons x (Q i xs ys j) = Q (i+1) (x:xs) ys j
rcons y (Q i xs ys j) = makeQ i xs (y:ys) (j+1)

append (Q i1 xs1 ys1 j1) (Q i2 xs2 ys2 j2) =
    Q (i1 + j1 + i2) (xs1 ++ L.reverseOnto ys1 xs2) ys2 j2

lview (Q _ [] _ _) = fail "BankersQueue.lview: empty sequence"
lview (Q i (x:xs) ys j) = return (x, makeQ (i-1) xs ys j)

lhead (Q _ [] _ _) = error "BankersQueue.lhead: empty sequence"
lhead (Q _ (x:_) _ _) = x

lheadM (Q _ [] _ _) = fail "BankersQueue.lheadM: empty sequence"
lheadM (Q _ (x:_) _ _) = return x

ltail (Q i (_:xs) ys j) = makeQ (i-1) xs ys j
ltail _ = error "BankersQueue.ltail: empty sequence"

ltailM (Q i (_:xs) ys j) = return (makeQ (i-1) xs ys j)
ltailM _ = fail "BankersQueue.ltail: empty sequence"

rview (Q i xs (y:ys) j) = return (y, Q i xs ys (j-1))
rview (Q i xs [] _) =
  case L.rview xs of
    Nothing      -> fail "BankersQueue.rview: empty sequence"
    Just (x,xs') -> return (x, Q (i-1) xs' [] 0)

rhead (Q _ _ (y:_) _) = y
rhead (Q _ [] [] _) = error "BankersQueue.rhead: empty sequence"
rhead (Q _ xs [] _) = L.rhead xs

rheadM (Q _ _ (y:_) _) = return y
rheadM (Q _ [] [] _) = fail "BankersQueue.rheadM: empty sequence"
rheadM (Q _ xs [] _) = return (L.rhead xs)

rtail (Q i xs (_:ys) j) = Q i xs ys (j-1)
rtail (Q _ [] [] _) = error "BankersQueue.rtail: empty sequence"
rtail (Q i xs [] _) = Q (i-1) (L.rtail xs) [] 0

rtailM (Q i xs (_:ys) j) = return (Q i xs ys (j-1))
rtailM (Q _ [] [] _) = fail "BankersQueue.rtailM: empty sequence"
rtailM (Q i xs [] _) = return (Q (i-1) (L.rtail xs) [] 0)

null (Q i _ _ _) = (i == 0)
size (Q i _ _ j) = i + j
reverse (Q i xs ys j) = makeQ j ys xs i

reverseOnto (Q i1 xs1 ys1 j1) (Q i2 xs2 ys2 j2) =
    Q (i1 + j1 + i2) (ys1 ++ L.reverseOnto xs1 xs2) ys2 j2

fromList xs = Q (length xs) xs [] 0

toList (Q _ xs ys j)
  | j == 0 = xs
  | otherwise = xs ++ L.reverse ys

map f (Q i xs ys j) = Q i (L.map f xs) (L.map f ys) j

-- local fn on lists
revfoldr :: (t -> t1 -> t1) -> t1 -> [t] -> t1
revfoldr _ e [] = e
revfoldr f e (x:xs) = revfoldr f (f x e) xs

revfoldr' :: (t -> a -> a) -> a -> [t] -> a
revfoldr' _ e [] = e
revfoldr' f e (x:xs) = e `seq` revfoldr' f (f x e) xs

-- local fn on lists
revfoldl :: (t -> t1 -> t) -> t -> [t1] -> t
revfoldl _ e [] = e
revfoldl f e (x:xs) = f (revfoldl f e xs) x

revfoldl' :: (b -> t -> b) -> b -> [t] -> b
revfoldl' _ e [] = e
revfoldl' f e (x:xs) = (\z -> f z x) $! (revfoldl f e xs)

fold  f e (Q _ xs ys _) = L.foldr f (L.foldr f e ys) xs
fold' f e (Q _ xs ys _) = (L.foldl' (flip f) $! (L.foldl' (flip f) e ys)) xs
fold1  = fold1UsingFold
fold1' = fold1'UsingFold'

foldr  f e (Q _ xs ys _) = L.foldr  f (revfoldr  f e ys) xs
foldr' f e (Q _ xs ys _) = L.foldr' f (revfoldr' f e ys) xs
foldl  f e (Q _ xs ys _) = revfoldl  f (L.foldl  f e xs) ys
foldl' f e (Q _ xs ys _) = revfoldl' f (L.foldl' f e xs) ys

foldr1 f (Q _ xs (y:ys) _) = L.foldr f (revfoldr f y ys) xs
foldr1 f (Q i xs [] _)
  | i == 0 = error "BankersQueue.foldr1: empty sequence"
  | otherwise = L.foldr1 f xs

foldr1' f (Q _ xs (y:ys) _) = L.foldr' f (revfoldr' f y ys) xs
foldr1' f (Q i xs [] _)
  | i == 0 = error "BankersQueue.foldr1': empty sequence"
  | otherwise = L.foldr1' f xs

foldl1 f (Q _ (x:xs) ys _) = revfoldl f (L.foldl f x xs) ys
foldl1 _ _ = error "BankersQueue.foldl1: empty sequence"

foldl1' f (Q _ (x:xs) ys _) = revfoldl' f (L.foldl' f x xs) ys
foldl1' _ _ = error "BankersQueue.foldl1': empty sequence"

copy n x
  | n < 0     = empty
  | otherwise = Q n (L.copy n x) [] 0

-- reduce1: given sizes could do more effective job of dividing evenly!

lookup idx q = runIdentity (lookupM idx q)

lookupM idx (Q i xs ys j)
  | idx < i   = L.lookupM idx xs
  | otherwise = L.lookupM (j - (idx - i) - 1) ys

lookupWithDefault d idx (Q i xs ys j)
  | idx < i   = L.lookupWithDefault d idx xs
  | otherwise = L.lookupWithDefault d (j - (idx - i) - 1) ys

update idx e q@(Q i xs ys j)
  | idx < i = if idx < 0 then q
             else Q i (L.update idx e xs) ys j
  | otherwise = let k' = j - (idx - i) - 1
                in if k' < 0 then q
                   else Q i xs (L.update k' e ys) j

adjust f idx q@(Q i xs ys j)
  | idx < i = if idx < 0 then q
             else Q i (L.adjust f idx xs) ys j
  | otherwise = let k' = j - (idx - i) - 1
                in if k' < 0 then q
                   else Q i xs (L.adjust f k' ys) j

{-
could do
  mapWithIndex   :: (Int -> a -> b) -> s a -> s b
  foldrWithIndex :: (Int -> a -> b -> b) -> b -> s a -> b
  foldlWithIndex :: (b -> Int -> a -> b) -> b -> s a -> b
but don't bother for now
-}

take len q@(Q i xs ys j) =
  if len <= i then
    if len <= 0 then empty
    else Q len (L.take len xs) [] 0
  else let len' = len - i in
    if len' >= j then q
    else Q i xs (L.drop (j - len') ys) len'

drop len q@(Q i xs ys j) =
  if len <= i then
    if len <= 0 then q
    else makeQ (i - len) (L.drop len xs) ys j
  else let len' = len - i in
    if len' >= j then empty
    else Q (j - len') (L.reverse (L.take (j - len') ys)) [] 0
  -- could write more efficient version of reverse (take ...)

splitAt idx q@(Q i xs ys j) =
  if idx <= i then
    if idx <= 0 then (empty, q)
    else let (xs',xs'') = L.splitAt idx xs
         in (Q idx xs' [] 0, makeQ (i - idx) xs'' ys j)
  else let idx' = idx - i in
    if idx' >= j then (q, empty)
    else let (ys', ys'') = L.splitAt (j - idx') ys
         in (Q i xs ys'' idx', Q (j - idx') (L.reverse ys') [] 0)
      -- could do splitAt followed by reverse more efficiently...


strict l@(Q _ xs ys _) = L.strict xs `seq` L.strict ys `seq` l
strictWith f l@(Q _ xs ys _) = L.strictWith f xs `seq` L.strictWith f ys `seq` l

-- the remaining functions all use defaults

concat = concatUsingFoldr
concatMap = concatMapUsingFoldr
reducer = reducerUsingReduce1
reducel = reducelUsingReduce1
reduce1 = reduce1UsingLists
reducer' = reducer'UsingReduce1'
reducel' = reducel'UsingReduce1'
reduce1' = reduce1'UsingLists
inBounds = inBoundsUsingSize
mapWithIndex = mapWithIndexUsingLists
foldrWithIndex  = foldrWithIndexUsingLists
foldrWithIndex' = foldrWithIndex'UsingLists
foldlWithIndex  = foldlWithIndexUsingLists
foldlWithIndex' = foldlWithIndex'UsingLists
subseq = subseqDefault
filter = filterUsingLists
partition = partitionUsingLists
takeWhile = takeWhileUsingLview
dropWhile = dropWhileUsingLview
splitWhile = splitWhileUsingLview
zip = zipUsingLists
zip3 = zip3UsingLists
zipWith = zipWithUsingLists
zipWith3 = zipWith3UsingLists
unzip = unzipUsingLists
unzip3 = unzip3UsingLists
unzipWith = unzipWithUsingLists
unzipWith3 = unzipWith3UsingLists

-- 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; foldlWithIndex = foldlWithIndex;
   foldrWithIndex' = foldrWithIndex'; 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 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
  q1 == q2 =
    (size q1 == size q2) && (toList q1 == toList q2)

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
       ys <- arbitrary
       return (let i = L.size xs
                   j = L.size ys
               in if i >= j then Q i xs ys j else Q j ys xs i)

  coarbitrary (Q _ xs ys _) = coarbitrary xs . coarbitrary ys

instance Monoid (Seq a) where
  mempty  = empty
  mappend = append