Queue.hs

{-# LANGUAGE BangPatterns #-}
module Queue (Queue, empty, snoc, head, tail) where 
import Prelude hiding(head,tail)

-- invariant: 
--  length (frontList q) == length (tailList q) + length (thunk q)
data Queue a = 
    Queue { 
        frontList :: [a]  
      , tailList  :: [a] 
      , frontSize :: !Int
      , tailSize  :: !Int
      , thunkSize :: !Int
    }

empty :: Queue a
empty = Queue { frontList = []
              , tailList = []
              , frontSize = 0
              , tailSize = 0
              , thunkSize = 0 }

rotate :: [a] -> [a] -> [a]
rotate = go []
    where
    -- invariant: length xs + 1 == length ys
    go !a [] (y : _) = y : a
    go !a (x : xs) (y : ys) = x : go (y : a) xs ys

-- assumption: frontSize q - tailSize q - thunkSize q == - 1
-- return: frontSize q' - tailSize q' - thunkSize q' == 0
exec :: Queue a -> Queue a
exec q =
    if thunkSize q > 0 
    then
        q{ thunkSize = thunkSize q - 1 }
    else 
        Queue f' [] n 0 n
            where f' = rotate (frontList q) (tailList q)
                  n  = frontSize q + tailSize q

snoc :: Queue a -> a -> Queue a
snoc q x = exec $! (q{ tailList = x : tailList q
                     , tailSize = 1 + tailSize q})

head :: Queue a -> a
head q =
    case frontList q of
        [] -> error "emptyQueue"
        x : _ -> x

tail :: Queue a -> Queue a
tail q =
    case frontList q of
        [] -> error "emptyQueue"
        _ : f -> exec $! (q { frontList = f
                            , frontSize = frontSize q - 1})