--------------------------------------------------------------------------------
{-| Module      :  Seq
    Copyright   :  (c) The AQUA Project, Glasgow University, 1993-1998
                   
    License     :  BSD-style

    Maintainer  :  N/A
    Stability   :  proposal
    Portability :  portable

  An implementation of catenable sequences.

  Read general notes in the root module: "DData"

  A lazy sequence @Seq a@ can be concatenated in /O(1)/ time. After
  construction, the sequence is converted in /O(n)/ time into a list.
  It shall be noted that sequences should not be used as queues (interleaving 'snoc' and 'tail'),
  when performance is a concern. "DData.Queue" exists for this purpose.

  Originally based on GHC \'OrdList\'.

-}

{-

Compared to GHC 'OrdList', I have the additional invariant that sublists are not empty. This makes some algorithms more simple, but hurts laziness somewhat.

I did my best to be friendly to infinite lists. For example, this is ok:

> inf = fromList [1..]
>
> double = inf `append` reverse inf
>
> chopped = init $ tail $ double
>
> head chopped == 2
> last chopped == 2

-}


module DData.Seq 
    ( -- * Type
      Seq
      
      -- * Query
      , head
      , last
      , tail
      , init
      , null
      , length

      -- * Subsequences
      , drop
      , take
      , inits
      , tails

      -- * Construction
      , empty
      , singleton
      , cons
      , snoc
      , append
      , concat
      --, concat'
      , unfoldr
      , unfoldl

      -- * Transformation
      , map
      , reverse

      -- * Reducing sequences (folds)
      , foldr
      , foldl

      -- * Predicates
      , isPrefixOf
      , isSuffixOf

      -- * Conversion
      , toList
      , fromList
      ) where

import Prelude hiding (foldl, foldr, length, null, map,
		       concat, init, head, last, tail,
		       reverse, drop, take)
import qualified Data.List as List
import Data.Monoid
import Debug.QuickCheck       
import Control.Monad
	
{--------------------------------------------------------------------
  Operators
--------------------------------------------------------------------}
infixr 5  `append`
infixl 5  `snoc`
infixr 5  `cons`

{--------------------------------------------------------------------
  Type
--------------------------------------------------------------------}
-- | Sequences of values @a@.
data Seq a
  = Many [a]
  | Two (Seq a) (Seq a) -- Two !(Seq a) !(Seq a) 
  | One  a
  | Cons a (Seq a)
  | Snoc (Seq a) a
  | None
--    deriving Show
{--------------------------------------------------------------------
  Query
--------------------------------------------------------------------}

-- | /O(n)/. Extract the first element of a sequence, which must be non-empty.
head :: Seq a -> a
head s = head' "Seq.head: empty sequence" (toList s)

head' err [] = error err
head' err (h:_) = h

-- | /O(n)/. Extract the last element of a sequence, which must be non-empty.
last :: Seq a -> a
last s = head' "Seq.last: empty sequence" (toList $ reverse s)


-- |  /O(n)/. Extract the elements after the head of a sequence, which must be non-empty.
tail :: Seq a -> Seq a
tail = drop 1

-- |  /O(n)/. Return all the elements of a list except the last one, which must be non-empty.
init :: Seq a -> Seq a
init = reverse . drop 1 . reverse


-- | /O(1)/. Is this the empty sequence?
null :: Seq a -> Bool
null None        = True
null (Two as bs) = null as && null bs
null (Many xs)   = List.null xs
null _           = False

-- | /O(n)/. The length of the sequence.
length :: Seq a -> Int
length None        = 0
length (One _)     = 1
length (Two as bs) = length as + length bs
length (Many xs)   = List.length xs
length (Snoc xs x) = 1 + length xs
length (Cons x xs) = 1 + length xs

{--------------------------------------------------------------------
  Construction
--------------------------------------------------------------------}
-- | /O(1)/. The empty sequence.
empty :: Seq a
empty        = None

-- | /O(1)/. Create a sequence of one element.
singleton :: a -> Seq a
singleton as = One as

-- | /O(1)/. Put a value in front of a sequence.
snoc :: Seq a -> a -> Seq a
snoc = Snoc
--snoc as b = as `append` (One b)

-- | /O(1)/. Put a value at the back of a sequence.
cons :: a -> Seq a -> Seq a
cons = Cons
--cons a bs = (One a) `append` bs


-- | /O(n)/. Conatenates the given sequences. 
concat' :: [Seq a] -> Seq a
concat' aas = List.foldr append None aas

-- | /O(n)/. Conatenates the given sequences. 
concat :: Seq (Seq a) -> Seq a
concat aas = foldr append None aas


-- | /O(1)/. Append two sequences.
--   `append` is meant infix, that is, the following holds:
-- 
-- > toList (s1 `append` s2) == toList s1 ++ toList s2
append :: Seq a -> Seq a -> Seq a
append as   bs   = Two as bs

-- | The 'unfoldr' function is a \'dual\' to 'foldr': while 'foldr'
-- reduces a sequence to a summary value, 'unfoldr' builds a sequence from
-- a seed value.  The function takes the element and returns 'Nothing'
-- if it is done producing the sequence or returns 'Just' @(a,b)@, in which
-- case, @a@ is a prepended to the sequence and @b@ is used as the next
-- element in a recursive call.
--
-- In some cases, 'unfoldr' can undo a 'foldr' operation:
--
-- > unfoldr f' (foldr f z xs) == xs
--
-- if the following holds:
--
-- > f' (f x y) = Just (x,y)
-- > f' z       = Nothing
unfoldr :: (b -> Maybe (a, b)) -> b -> Seq a
unfoldr f i 
    = case f i of
        Nothing -> None
	Just (a,b) -> a `cons` unfoldr f b

-- | The converse of 'unfoldr'.
unfoldl :: (b -> Maybe (b, a)) -> b -> Seq a
unfoldl f i
    = case f i of
        Nothing -> None
	Just (b,a) -> unfoldl f b `snoc` a

-- | The isPrefixOf function takes two sequences and returns True iff the first sequence is a prefix of the second.
isPrefixOf :: Eq a => Seq a -> Seq a -> Bool
isPrefixOf s1 s2 = List.isPrefixOf (toList s1) (toList s2)

-- | The isSuffixOf function takes two sequences and returns True iff the first sequence is a suffix of the second.
isSuffixOf :: Eq a => Seq a -> Seq a -> Bool
isSuffixOf s1 s2 = isPrefixOf (reverse s1) (reverse s2)


{--------------------------------------------------------------------
  Traversal
--------------------------------------------------------------------}

-- | /O(n)/. foldr, applied to a binary operator, 
-- a starting value (typically the right-identity 
-- of the operator), and a sequence, reduces the list 
-- using the binary operator, from right to left:
--
-- > foldr f z l == x1 `f` (x2 `f` ... (xn `f` z)...)
-- >    where [x1, x2, ..., xn] = toList l

foldr :: (a->b->b) -> b -> Seq a -> b
foldr k z None        = z
foldr k z (One x)     = k x z
foldr k z (Two b1 b2) = foldr k (foldr k z b2) b1
foldr k z (Many xs)   = List.foldr k z xs
foldr k z (Cons x xs) = x `k` (foldr k z xs)
foldr k z (Snoc xs x) = (foldr k (x `k` z) xs)

-- | /O(n)/. foldl, applied to a binary operator, 
-- a starting value (typically the left-identity 
-- of the operator), and a sequence, reduces the list 
-- using the binary operator, from left to right
--
-- > foldl f z l == (...((z `f` x1) `f` x2) `f`...) `f` xn
-- >    where [x1, x2, ..., xn] = toList l

foldl :: (b->a->b) -> b -> Seq a -> b
foldl k z None        = z
foldl k z (One x)     = k z x
foldl k z (Two b1 b2) = foldl k (foldl k z b1) b2
foldl k z (Many xs)   = List.foldl k z xs
foldl k z (Cons x xs) = (foldl k (z `k` x) xs)
foldl k z (Snoc xs x) = (foldl k z xs) `k` x


-- | /O(n)/ @map f xs@ is the list obtained by applying @f@ to each element of @xs@, i.e.,
--
-- > finite l ==> map f $ fromList l == fromList $ List.map f l
map :: (a -> b) -> (Seq a -> Seq b)
map f None = None
map f (One x) = One (f x)
map f (Two as bs) = Two (map f as) (map f bs)
map f (Many xs) = Many (List.map f xs)
map f (Cons x xs) = Cons (f x) (map f xs)
map f (Snoc xs x) = Snoc (map f xs) (f x)


-- | @reverse xs@ returns the elements of xs in reverse order.

reverse :: Seq a -> Seq a
reverse None = None
reverse (One x) = One x
reverse (Two as bs) = (Two (reverse bs) (reverse as))
reverse (Many xs) = fromReverseList xs -- handle lists lazily
reverse (Cons x xs) = Snoc (reverse xs) x
reverse (Snoc xs x) = Cons x (reverse xs)

{------------------------------------------
  Subsequences
-------------------------------------------}

-- | The 'inits' function returns all initial segments of the argument,
-- shortest first.
inits :: Seq a -> Seq (Seq a)
inits s1 = empty `cons` unfoldl gen s1
    where gen s
	      | null s = Nothing
	      | otherwise = Just (init s, s)

-- | The 'tails' function returns all final segments of the argument,
-- longest first.
tails :: Seq a -> Seq (Seq a)
tails s1 = unfoldr gen s1 `snoc` empty
    where gen s
	      | null s = Nothing
	      | otherwise = Just (s, tail s)

-- | 'take' @n@, applied to a sequence @xs@, returns the prefix of @xs@
-- of length @n@, or @xs@ itself if @n > 'length' xs@.

take :: Int -> Seq a -> Seq a
take n s = fromList $ List.take n $ toList s


-- | 'drop' @n xs@ returns the suffix of @xs@
-- after the first @n@ elements, or @empty@ if @n > 'length' xs@.

drop :: Int -> Seq a -> Seq a
drop n s = drop' n s None 
    where -- drop' n s1 s2 drops n elements from (s1 `append` s2)
          drop' 0 s rest = s `append` rest
          drop' n None None = None
          drop' n None rest = drop' n rest None
          drop' n (One x) rest = drop' (n-1) rest None
	  drop' n (Two as bs) rest = drop' n as (bs `appendClever` rest)
	  drop' n (Many xs) rest = dropList n xs rest 
	  drop' n (Cons x xs) rest = drop' (n-1) xs rest
	  drop' n (Snoc xs x) rest = drop' n xs (x `cons` rest)
	  dropList 0 l rest = Many l `append` rest
	  dropList n [] rest = drop n rest
	  dropList n (x:xs) rest = dropList (n-1) xs rest
	  appendClever None bs = bs
	  appendClever (One a) bs = Cons a bs
	  appendClever as bs = Two as bs
{--------------------------------------------------------------------
  Conversion
--------------------------------------------------------------------}

-- | /O(n)/. Convert a sequence to a list.
toList :: Seq a -> [a]
toList ol 
   = flat ol []
     where
        flat None      rest = rest
        flat (One x)   rest = x:rest
        flat (Two a b) rest = flat a (flat b rest)
	flat (Many xs) rest = xs ++ rest
	flat (Cons x xs) rest = x:flat xs rest
	flat (Snoc xs x) rest = flat xs (x:rest)


-- | /O(n)/. Create a sequence from a list.
fromList :: [a] -> Seq a
fromList xs = Many xs

-- | /O(n)/. Create a sequence from a list, in reverse order.
-- This function is lazy.
fromReverseList xs = unfoldl gen xs
    where gen [] = Nothing
	  gen (x:xs) = Just (xs, x)


{--------------------------------------------------------------------
  Eq
--------------------------------------------------------------------}

instance Eq a => Eq (Seq a) where
    as == bs = toList as == toList bs


{--------------------------------------------------------------------
  Ord 
--------------------------------------------------------------------}

instance Ord a => Ord (Seq a) where
    compare q1 q2 = compare (toList q1) (toList q2)


{--------------------------------------------------------------------
  Show
--------------------------------------------------------------------}

instance Show a => Show (Seq a) where
    show s = show (toList s)



{--------------------------------------------------------------------
  Monoid 
--------------------------------------------------------------------}

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

{--------------------------------------------------------------------
  Functor 
--------------------------------------------------------------------}

instance Functor Seq where
    fmap = map

{--------------------------------------------------------------------
  Monad 
--------------------------------------------------------------------}

instance Monad Seq where
    return = singleton
    k >>= f = concat (map f k)
    fail err = empty

{--------------------------------------------------------------------
  MonadPlus
--------------------------------------------------------------------}

instance MonadPlus Seq where
    mzero = empty
    mplus = append

{--------------------------------------------------------------------
  Arbitrary (finite) sequences
--------------------------------------------------------------------}
instance Arbitrary a => Arbitrary (Seq a) where
  arbitrary = sized arbSeq
  coarbitrary (Many xs) = variant 0 . coarbitrary xs
  coarbitrary (Two as bs) = variant 1 . coarbitrary as . coarbitrary bs
  coarbitrary (One x) = variant 2 . coarbitrary x
  coarbitrary (Cons x xs) = variant 3 . coarbitrary x . coarbitrary xs
  coarbitrary (Snoc xs x) = variant 4 . coarbitrary xs . coarbitrary x
  coarbitrary (None) = variant 5

arbSeq :: Arbitrary a => Int -> Gen (Seq a)
arbSeq n = frequency [(1, (return . fromList) =<< arbList n),
		      (19, arbSeq' n)]

arbSeq' n 
    | n <= 0        = return None
    | n == 1        = do x <- arbitrary
			 return (One x)
    | otherwise     = do{ asize  <- choose (0, n); 
			  -- I want to test empty sublists...
			  -- Safe, because, it is stochastically impossible to 
			  --recurse indefinitely. 
			  as <- arbSeq asize;
			  bs <- arbSeq (n-asize);
			  return (as `append` bs)
			}

arbList 0 = return []
arbList n = do x <- arbitrary
	       xs <- arbList (n-1)
	       return (x:xs)
	   

{--------------------------------------------------------------------
  QuickCheck properties
--------------------------------------------------------------------}


forSeq :: Testable b => (Seq Int -> b) -> Property
forSeq f = forAll arbitrary $ \s -> f s

forSeqSeq :: Testable b => (Seq (Seq Int) -> b) -> Property
forSeqSeq f = forAll arbitrary $ \s -> f s

forInt :: Testable b => (Int -> b) -> Property
forInt = forAll arbitrary

prop_Valid = forSeq valid



-- Check everything wrt. toList, asserting Data.List is correct.
-- Ready? Go!

prop_head = forSeq $ \s-> not (null s) ==> head s == List.head (toList s)
prop_last = forSeq $ \s-> not (null s) ==> head s == List.head (toList s)
prop_init = forSeq $ \s-> not (null s) ==> toList (init s) == List.init (toList s)
prop_tail = forSeq $ \s-> not (null s) ==> toList (tail s) == List.tail (toList s)

prop_null = forSeq $ \s-> null s == List.null (toList s)
prop_length = forSeq $ \s-> length s == List.length (toList s)

prop_inits = forSeq $ \s-> List.map toList (toList (inits s)) == List.inits (toList s)
prop_tails = forSeq $ \s-> List.map toList (toList (tails s)) == List.tails (toList s)

prop_empty = List.null (toList empty)

prop_singleton = forInt $ \x-> toList (singleton x) == [x]

prop_cons = forInt $ \x->
	    forSeq $ \xs-> 
	    toList (x `cons` xs) == x:toList xs

prop_snoc = forInt $ \x->
	    forSeq $ \xs-> 
	    toList (xs `snoc` x) == toList xs ++ [x]

prop_append = forSeq $ \as->
	      forSeq $ \bs->
	      toList (as `append` bs) == toList as ++ toList bs

prop_concat = forSeqSeq $ \ss->
	      toList (concat ss) == List.concat (List.map toList $ toList $ ss)

prop_isPrefixOf = forSeq $ \as->
		  forSeq $ \bs->
		  isPrefixOf as bs == List.isPrefixOf (toList as) (toList bs)

prop_isSuffixOf = forSeq $ \as->
		  forSeq $ \bs->
		  isSuffixOf as bs == List.isSuffixOf (toList as) (toList bs)

prop_Eq = forSeq $ \as->
	  forSeq $ \bs->
	  (as == bs) == (toList as == toList bs)

prop_fromList = forSeq $ \s->
		s == fromList (toList s)

prop_reverse = forSeq $ \s->
	       toList (reverse s) == List.reverse (toList s)

prop_drop = forSeq $ \s->
	    forAll (choose (0, length s + 1)) $ \n ->
	    toList (drop n s) == List.drop n (toList s)

prop_take = forSeq $ \s->
	    forAll (choose (0, length s + 1)) $ \n ->
	    toList (take n s) == List.take n (toList s)


prop_foldr :: (Int -> Int -> Int) -> Int -> Seq Int -> Bool
prop_foldr f i s = foldr f i s == List.foldr f i (toList s)

prop_foldl :: (Int -> Int -> Int) -> Int -> Seq Int -> Bool
prop_foldl f i s = foldl f i s == List.foldl f i (toList s)

prop_map :: (Int -> Int) -> Seq Int -> Bool
prop_map f s = toList (map f s) == List.map f (toList s)

{-

instance Show (a -> b)
    where show _ = "<fct>"


instance Arbitrary a => Arbitrary (Maybe a) where
    arbitrary = oneof [return Nothing,
		       do {x <- arbitrary
		          ;return (Just x)
			  }]		      
    
prop_unfoldr :: Int -> (Int -> Maybe (Int, Int)) -> Int -> Bool
prop_unfoldr n f s = List.take n (toList (unfoldr f s)) == 
		     List.take n (List.unfoldr f s)


-}