Queue.hs

--------------------------------------------------------------------------------
{-| Module      :  Queue
    Copyright   :  (c) Daan Leijen 2002
    License     :  BSD-style

    Maintainer  :  daan@cs.uu.nl
    Stability   :  provisional
    Portability :  portable

  An efficient implementation of queues (FIFO buffers). Based on:

  * Chris Okasaki, \"/Simple and Efficient Purely Functional Queues and Deques/\",
    Journal of Functional Programming 5(4):583-592, October 1995.
-}
---------------------------------------------------------------------------------}
module Queue ( 
            -- * Queue type
              Queue          -- instance Eq,Show

            -- * Operators
            , (<>)
            
            -- * Query
            , isEmpty
            , length
            , head
            , tail
            , front

            -- * Construction
            , empty
            , single
            , insert
            , append
            
            -- * Filter
            , filter
            , partition

            -- * Fold
            , foldL
            , foldR
           
            -- * Conversion
            , elems

            -- ** List
            , toList
            , fromList
            ) where

import qualified Prelude as P (length,filter)
import Prelude   hiding       (length,head,tail,filter)
import qualified List

-- just for testing
-- import QuickCheck 

{--------------------------------------------------------------------
  Operators
--------------------------------------------------------------------}
infixr 5 <>

-- | /O(n)/. Append two queues, see 'append'.
(<>) :: Queue a -> Queue a -> Queue a
s <> t
  = append s t

{--------------------------------------------------------------------
  Queue.
  Invariants for @(Queue xs ys zs)@:
  * @length ys <= length xs@
  * @length zs == length xs - length ys@
--------------------------------------------------------------------}
-- A queue of elements @a@.
data Queue a  = Queue [a] [a] [a]

{--------------------------------------------------------------------
  Query
--------------------------------------------------------------------}

-- | /O(1)/. Is the queue empty?
isEmpty :: Queue a -> Bool
isEmpty (Queue xs ys zs)
  = null xs

-- | /O(n)/. The number of elements in the queue.
length :: Queue a -> Int
length (Queue xs ys zs)
  = P.length xs + P.length ys

-- | /O(1)/. The element in front of the queue. Raises an error
-- when the queue is empty.
head :: Queue a -> a
head (Queue xs ys zs)
  = case xs of
      (x:xx)  -> x
      []      -> error "Queue.head: empty queue"

-- | /O(1)/. The tail of the queue.
-- Raises an error when the queue is empty.
tail :: Queue a -> Queue a
tail (Queue xs ys zs)
  = case xs of
      (x:xx)  -> queue xx ys zs
      []      -> error "Queue.tail: empty queue"

-- | /O(1)/. The head and tail of the queue.
front :: Queue a -> Maybe (a,Queue a)
front (Queue xs ys zs)
  = case xs of
      (x:xx)  -> Just (x,queue xx ys zs)
      []      -> Nothing


{--------------------------------------------------------------------
  Construction  
--------------------------------------------------------------------}
-- | /O(1)/. The empty queue.
empty :: Queue a
empty 
  = Queue [] [] []

-- | /O(1)/. A queue of one element.
single :: a -> Queue a
single x
  = Queue [x] [] [x]

-- | /O(1)/. Insert an element at the back of a queue.
insert :: a -> Queue a -> Queue a
insert x (Queue xs ys zs)
  = queue xs (x:ys) zs


-- | /O(n)/. Append two queues.
append :: Queue a -> Queue a -> Queue a
append (Queue xs1 ys1 zs1) (Queue xs2 ys2 zs2)
  = Queue (xs1++xs2) (ys1++ys2) (zs1++zs2)

{--------------------------------------------------------------------
  Filter
--------------------------------------------------------------------}
-- | /O(n)/. Filter elements according to some predicate.
filter :: (a -> Bool) -> Queue a -> Queue a
filter pred (Queue xs ys zs)
  = balance xs' ys'
  where
    xs' = P.filter pred xs
    ys' = P.filter pred ys

-- | /O(n)/. Partition the elements according to some predicate.
partition :: (a -> Bool) -> Queue a -> (Queue a,Queue a)
partition pred (Queue xs ys zs)
  = (balance xs1 ys1, balance xs2 ys2)
  where
    (xs1,xs2) = List.partition pred xs
    (ys1,ys2) = List.partition pred ys


{--------------------------------------------------------------------
  Fold
--------------------------------------------------------------------}
-- | /O(n)/. Fold over the elements from left to right (ie. head to tail).
foldL :: (b -> a -> b) -> b -> Queue a -> b
foldL f z (Queue xs ys zs)
  = foldr (flip f) (foldl f z xs) ys

-- | /O(n)/. Fold over the elements from right to left (ie. tail to head).
foldR :: (a -> b -> b) -> b -> Queue a -> b
foldR f z (Queue xs ys zs)
  = foldr f (foldl (flip f) z ys) xs


{--------------------------------------------------------------------
  Conversion
--------------------------------------------------------------------}
-- | /O(n)/. The elements of a queue.
elems :: Queue a -> [a]
elems q
  = toList q

-- | /O(n)/. Convert to a list.
toList :: Queue a -> [a]
toList (Queue xs ys zs)
  = xs ++ reverse ys

-- | /O(n)/. Convert from a list.
fromList :: [a] -> Queue a
fromList xs
  = Queue xs [] xs


{--------------------------------------------------------------------
  instance Eq, Show
--------------------------------------------------------------------}
instance Eq a => Eq (Queue a) where
  q1 == q2  = toList q1 == toList q2

instance Show a => Show (Queue a) where
  showsPrec d q  = showsPrec d (toList q)


{--------------------------------------------------------------------
  Smart constructor:
  Note that @(queue xs ys zs)@ is always called with 
    @(length zs == length xs - length ys + 1)@. and thus
  @rotate@ is always called when @(length xs == length ys+1)@.
--------------------------------------------------------------------}
balance :: [a] -> [a] -> Queue a
balance xs ys
  = Queue qs [] qs
  where
    qs = xs ++ reverse ys

queue :: [a] -> [a] -> [a] -> Queue a
queue xs ys (z:zs) = Queue xs ys zs
queue xs ys []     = Queue qs [] qs
                   where
                     qs = rotate xs ys []

-- @(rotate xs ys []) == xs ++ reverse ys)@ 
rotate :: [a] -> [a] -> [a] -> [a]
rotate []     [y]    zs  = y:zs
rotate (x:xs) (y:ys) zs  = x:rotate xs ys (y:zs) 
rotate xs     ys     zs  = error "Queue.rotate: unbalanced queue"


valid :: Queue a -> Bool
valid (Queue xs ys zs)
  = (P.length zs == P.length xs - P.length ys) && (P.length ys <= P.length xs)

{-
{--------------------------------------------------------------------
  QuickCheck
--------------------------------------------------------------------}
qcheck prop
  = check config prop
  where
    config = Config
      { configMaxTest = 500
      , configMaxFail = 10000
      , configSize    = \n -> (div n 2 + 3)
      , configEvery   = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
      }


{--------------------------------------------------------------------
  Arbitrary, reasonably balanced queues
--------------------------------------------------------------------}
instance Arbitrary a => Arbitrary (Queue a) where
  arbitrary = do{ qs <- arbitrary
                ; let (ys,xs) = splitAt (P.length qs `div` 2) qs
                ; return (Queue xs ys (xs ++ reverse ys))
                }


prop_Valid :: Queue Int -> Bool
prop_Valid q
  = valid q

prop_InsertLast :: [Int] -> Property
prop_InsertLast xs
  = not (null xs) ==> head (foldr insert empty xs) == last xs

prop_InsertValid :: [Int] -> Bool
prop_InsertValid xs
  = valid (foldr insert empty xs)

prop_Queue :: [Int] -> Bool
prop_Queue xs
  = toList (foldl (flip insert) empty xs) == foldr (:) [] xs
  
prop_List :: [Int] -> Bool
prop_List xs
  = toList (fromList xs) == xs

prop_TailValid :: [Int] -> Bool
prop_TailValid xs
  = valid (tail (foldr insert empty (1:xs)))
-}