-- |
--   Module      :  Data.Edison.Seq.SimpleQueue
--   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)
--
--   Simple Queues.  All operations have running times as listed in
--   "Data.Edison.Seq" except for the following:
--
--   * rcons, fromList   @O( 1 )@
--
--   * lview, ltail*   @O( 1 )@ if single threaded, @O( n )@ otherwise
--
--   * inBounds, lookup, update, drop, splitAt  @O( n )@
--
--   /References:/
--
--   * Chris Okasaki. /Purely Functional Data Structures/. 1998.
--     Section 5.2.
--
--   * F. Warren Burton. \"An efficient functional implementation of FIFO queues\".
--     /Information Processing Letters/, 14(5):205-206, July 1982.

module Data.Edison.Seq.SimpleQueue (
    -- * 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,foldlWithIndex,foldrWithIndex',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 Control.Applicative as App

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
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.SimpleQueue"


data Seq a = Q [a] [a]
  -- invariant: front empty only if rear also empty

-- not exported
makeQ :: [a] -> [a] -> Seq a
makeQ [] ys = Q (L.reverse ys) []
makeQ xs ys = Q xs ys

empty = Q [] []
singleton x = Q [x] []
lcons x (Q xs ys) = Q (x:xs) ys

rcons y (Q [] _) = Q [y] []
rcons y (Q xs ys) = Q xs (y:ys)

append (Q xs1 ys1) (Q xs2 ys2) =
    Q (xs1 ++ L.reverseOnto ys1 xs2) ys2

lview (Q [] _) = fail "SimpleQueue.lview: empty sequence"
lview (Q [x] ys) = return (x, Q (L.reverse ys) [])
lview (Q (x:xs) ys) = return (x, Q xs ys)

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

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

ltail (Q [_] ys) = Q (L.reverse ys) []
ltail (Q (_:xs) ys) = Q xs ys
ltail (Q [] _) = error "SimpleQueue.ltail: empty sequence"

ltailM (Q [_] ys) = return (Q (L.reverse ys) [])
ltailM (Q (_:xs) ys) = return (Q xs ys)
ltailM (Q [] _) = fail "SimpleQueue.ltailM: empty sequence"

rview (Q xs (y:ys)) = return (y, Q xs ys)
rview (Q xs []) =
  case L.rview xs of
    Nothing      -> fail "SimpleQueue.rview: empty sequence"
    Just (x,xs') -> return (x, Q xs' [])

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

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

rtail (Q xs (_:ys)) = Q xs ys
rtail (Q [] []) = error "SimpleQueue.rtail: empty sequence"
rtail (Q xs []) = Q (L.rtail xs) []

rtailM (Q xs (_:ys)) = return (Q xs ys)
rtailM (Q [] []) = fail "SimpleQueue.rtailM: empty sequence"
rtailM (Q xs []) = return (Q (L.rtail xs) [])

null (Q [] _) = True
null _ = False

size (Q xs ys) = length xs + length ys

reverse (Q xs []) = Q (L.reverse xs) []
reverse (Q xs ys) = Q ys xs

reverseOnto (Q xs1 ys1) (Q xs2 ys2) =
    Q (ys1 ++ L.reverseOnto xs1 xs2) ys2

fromList xs = Q xs []

toList (Q xs []) = xs
toList (Q xs ys) = xs ++ L.reverse ys

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

-- 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' :: (a -> t -> a) -> a -> [t] -> a
revfoldl' _ e [] = e
revfoldl' f e (x:xs) = e `seq` f (revfoldl' f e xs) x

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  _ (Q [] []) = error "SimpleQueue.foldr1: empty sequence"
foldr1  f (Q xs []) = L.foldr1 f xs

foldr1' f (Q xs (y:ys)) = L.foldr' f (revfoldr' f y ys) xs
foldr1' _ (Q [] []) = error "SimpleQueye.foldr1': empty sequence"
foldr1' f (Q xs []) = L.foldr1' f xs

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

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

filter p (Q xs ys) = makeQ (L.filter p xs) (L.filter p ys)

partition p (Q xs ys)
  = (makeQ xsT ysT, makeQ xsF ysF)
 where
   (xsT,xsF) = L.partition p xs
   (ysT,ysF) = L.partition p ys

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

-- the remaining functions all use defaults

concat = concatUsingFoldr
concatMap = concatMapUsingFoldr
reducer  = reducerUsingReduce1
reducer' = reducer'UsingReduce1'
reducel  = reducelUsingReduce1
reducel' = reducel'UsingReduce1'
reduce1  = reduce1UsingLists
reduce1' = reduce1'UsingLists
copy = copyUsingLists
inBounds = inBoundsUsingLookupM
lookup = lookupUsingLookupM
lookupM = lookupMUsingDrop
lookupWithDefault = lookupWithDefaultUsingLookupM
update = updateUsingAdjust
adjust = adjustUsingLists
mapWithIndex = mapWithIndexUsingLists
foldrWithIndex  = foldrWithIndexUsingLists
foldrWithIndex' = foldrWithIndex'UsingLists
foldlWithIndex  = foldlWithIndexUsingLists
foldlWithIndex' = foldlWithIndex'UsingLists
take = takeUsingLists
drop = dropUsingLists
splitAt = splitAtDefault
subseq = subseqDefault
takeWhile = takeWhileUsingLview
dropWhile = dropWhileUsingLview
splitWhile = splitWhileUsingLview
zip = zipUsingLists
zip3 = zip3UsingLists
zipWith = zipWithUsingLists
zipWith3 = zipWith3UsingLists
unzip = unzipUsingLists
unzip3 = unzip3UsingLists
unzipWith = unzipWithUsingLists
unzipWith3 = unzipWith3UsingLists

-- invariant:
--   * front empty only if rear also empty

structuralInvariant (Q x y) = not (L.null x) || L.null y

-- 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
  q1 == 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 (if L.null xs then Q ys [] else Q xs ys)

instance CoArbitrary a => CoArbitrary (Seq a) where
  coarbitrary (Q xs ys) = coarbitrary xs . coarbitrary ys

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