Dequeue.hs

{- |
Module      :  Data.Dequeue
Description :  A typeclass and an implementation for double-ended queues.
Copyright   :  (c) Henry Bucklow 2009
License     :  BSD3

Maintainer  :  henry@elsie.org.uk
Stability   :  provisional
Portability :  portable

A typeclass for double-ended queues, and an implementation of Banker's
Dequeues, as described in Chris Okasaki's Purely Functional Data Structures.
-}
module Data.Dequeue (
    -- * The 'Dequeue' type class.
    Dequeue(..),
    -- * QuickCheck properties for 'Dequeue' instances
    prop_pushpop_front,
    prop_pushpop_back,
    prop_push_front,
    prop_push_back,
    prop_length_toList,
    -- * Banker's Dequeues
    BankersDequeue,
    -- * QuickCheck properties for 'BankersDequeue'
    prop_pushpop_front_bq,
    prop_pushpop_back_bq,
    prop_push_front_bq,
    prop_push_back_bq,
    prop_length_toList_bq,
    prop_push_front_bq_balance,
    prop_push_back_bq_balance,
    prop_pop_front_bq_balance,
    prop_pop_back_bq_balance
) where

import Prelude hiding (foldl, foldr, foldl1, foldr1, length, last)

import Control.Monad
import Data.Foldable
import qualified Data.List as List
import Test.QuickCheck hiding (check)

import Safe

-- | A typeclass for double-ended queues.
class Dequeue q where
    -- | Generates an empty queue.
    empty :: q a
    -- | Returns 'True' if this queue is empty.
    null :: q a -> Bool
    -- | Returns the number of elements in this queue.
    length :: q a -> Int
    -- | Returns the item on the front of the queue.
    first :: q a -> Maybe a
    -- | Returns the item on the end of the queue.
    last :: q a -> Maybe a
    -- | Returns the first n items from the front of the queue.
    takeFront :: Int -> q a -> [a]
    -- | Returns the last n items from the end of the queue.
    takeBack :: Int -> q a -> [a]
    -- | Pushes an item onto the front of the queue.
    pushFront :: q a -> a -> q a
    -- | Pops an item from the front of the queue.
    popFront :: q a -> (Maybe a, q a)
    -- | Pushes an item onto the back of the queue.
    pushBack :: q a -> a -> q a
    -- | Pops an item from the back of the queue.
    popBack :: q a -> (Maybe a, q a)
    -- | Converts a list into a queue.
    fromList :: [a] -> q a

-- QuickCheck properties for Dequeue instances.

-- | Validates that if you push, then pop, the front of the queue,
--   you get the same queue.
prop_pushpop_front :: (Dequeue q, Eq a, Eq (q a)) => q a -> a -> Bool
prop_pushpop_front q a =
    let (a', q') = popFront (pushFront q a) in
    a' == Just a && q' == q

-- | Validates that if you push, then pop, the back of the queue,
--   you get the same queue.
prop_pushpop_back :: (Dequeue q, Eq a, Eq (q a)) => q a -> a -> Bool
prop_pushpop_back q a =
    let (a', q') = popBack (pushBack q a) in
    a' == Just a && q' == q

-- | Validates that 'first' returns the last 'pushFront''d element.
prop_push_front :: (Dequeue q, Eq a) => q a -> a -> Bool
prop_push_front q a = first (pushFront q a) == Just a

-- | Validates that 'last' returns the last 'pushBack''d element.
prop_push_back :: (Dequeue q, Eq a) => q a -> a -> Bool
prop_push_back q a = last (pushBack q a) == Just a

-- | Validates that the length of a queue is the same as the length of the
--   list generated from the queue.
prop_length_toList :: (Dequeue q, Foldable q) => q a -> Bool
prop_length_toList q = List.length (toList q) == length q

-- | An implementation of Banker's Dequeues, as described in Chris Okasaki's
--   Purely Functional Data Structures. The functions for the 'Dequeue'
--   instance have the following complexities (where n is the 'length' of the
--   queue):
--
--    * 'length': O(1)
--
--    * 'first': O(1)
--
--    * 'last': O(1)
--
--    * 'takeFront': O(n)
--
--    * 'takeBack': O(n)
--
--    * 'pushFront': O(1) amortised
--
--    * 'popFront': O(1) amortised
--
--    * 'pushBack': O(1) amortised
--
--    * 'popBack': O(1) amortised
--
--    * 'fromList': O(n)
data BankersDequeue a = BankersDequeue Int [a] Int [a]

instance Functor BankersDequeue where
    fmap f (BankersDequeue sizeF front sizeR rear) =
        BankersDequeue sizeF (fmap f front) sizeR (fmap f rear)

instance Foldable BankersDequeue where
    fold (BankersDequeue _ front _ rear) = fold (front ++ reverse rear)
    foldMap f (BankersDequeue _ front _ rear) = foldMap f (front ++ reverse rear)
    foldr f a (BankersDequeue _ front _ rear) = foldr f a (front ++ reverse rear)
    foldl f a (BankersDequeue _ front _ rear) = foldl f a (front ++ reverse rear)
    foldr1 f (BankersDequeue _ front _ rear) = foldr1 f (front ++ reverse rear)
    foldl1 f (BankersDequeue _ front _ rear) = foldl1 f (front ++ reverse rear)

instance Dequeue BankersDequeue where
    empty = BankersDequeue 0 [] 0 []
    null (BankersDequeue 0 [] 0 []) = True
    null _ = False
    length (BankersDequeue sizeF _ sizeR _) = sizeF + sizeR
    first (BankersDequeue _ [] _ [x]) = Just x
    first (BankersDequeue _ front _ _) =  headMay front
    last (BankersDequeue _ [x] _ []) = Just x
    last (BankersDequeue _ _ _ rear) = headMay rear
    takeFront i (BankersDequeue sizeF front _ rear) =
        take i front ++ take (i - sizeF) (reverse rear)
    takeBack i (BankersDequeue _ front sizeR rear) =
        reverse $ take i rear ++ take (i - sizeR) (reverse front)
    pushFront (BankersDequeue sizeF front sizeR rear) x =
        check $ BankersDequeue (sizeF + 1) (x : front) sizeR rear
    popFront (BankersDequeue _ [] _ []) = (Nothing, empty)
    popFront (BankersDequeue _ [] _ [x]) = (Just x, empty)
    popFront (BankersDequeue _ [] _ _) = error "Queue is too far unbalanced."
    popFront (BankersDequeue sizeF (f : fs) sizeR rear) =
        (Just f, check $ BankersDequeue (sizeF - 1) fs sizeR rear)
    pushBack (BankersDequeue sizeF front sizeR rear) x =
        check $ BankersDequeue sizeF front (sizeR + 1) (x : rear)
    popBack (BankersDequeue _ [] _ []) = (Nothing, empty)
    popBack (BankersDequeue _ [x] _ []) = (Just x, empty)
    popBack (BankersDequeue _ _ _ []) = error "Queue is too far unbalanced."
    popBack (BankersDequeue sizeF front sizeR (r : rs)) =
        (Just r, check $ BankersDequeue sizeF front (sizeR - 1) rs)
    fromList list = check $ BankersDequeue (List.length list) list 0 []

-- | The maximum number of times longer one half of a 'BankersDequeue' is
--   permitted to be relative to the other.
bqBalance :: Int
bqBalance = 4

-- | Checks to see if the queue is too far out of balance. If it is, it
--   rebalances it.
check :: BankersDequeue a -> BankersDequeue a
check q@(BankersDequeue sizeF front sizeR rear)
    | sizeF > c * sizeR + 1 =
        let front' = take size1 front
            rear' = rear ++ drop size1 front
        in
        BankersDequeue size1 front' size2 rear'
    | sizeR > c * sizeF + 1 =
        let front' = front ++ reverse (drop size1 rear)
            rear' = take size1 rear
        in
        BankersDequeue size2 front' size1 rear'
    | otherwise = q
    where
        size1 = (sizeF + sizeR) `div` 2
        size2 = (sizeF + sizeR) - size1
        c = bqBalance

instance (Arbitrary a) => Arbitrary (BankersDequeue a) where
    arbitrary = (liftM fromList) arbitrary
    coarbitrary (BankersDequeue _ front _ rear) =
        variant 0 . coarbitrary front . coarbitrary rear

instance Eq a => Eq (BankersDequeue a) where
    queue1 == queue2 = toList queue1 == toList queue2

instance Show a => Show (BankersDequeue a) where
    show q = "BankersDequeue " ++ show (toList q)

-- QuickCheck properties for BankersDequeue.

-- | Validates that if you push, then pop, the front of a 'BankersQueue',
--   you get the same queue.
prop_pushpop_front_bq :: BankersDequeue Int -> Int -> Bool
prop_pushpop_front_bq = prop_pushpop_front

-- | Validates that if you push, then pop, the back of a 'BankersDequeue',
--   you get the same queue.
prop_pushpop_back_bq :: BankersDequeue Int -> Int -> Bool
prop_pushpop_back_bq = prop_pushpop_back

-- | Validates that 'first' returns the last 'pushFront''d element.
prop_push_front_bq :: BankersDequeue Int -> Int -> Bool
prop_push_front_bq = prop_push_front

-- | Validates that 'last' returns the last 'pushBack''d element.
prop_push_back_bq :: BankersDequeue Int -> Int -> Bool
prop_push_back_bq = prop_push_back

-- | Validates that the length of a 'BankersDequeue' is the same as the length
--   of the list generated from the queue.
prop_length_toList_bq :: BankersDequeue Int -> Bool
prop_length_toList_bq = prop_length_toList

balanced :: BankersDequeue a -> Bool
balanced (BankersDequeue 0 _ 0 _) = True
balanced (BankersDequeue 1 _ 0 _) = True
balanced (BankersDequeue 0 _ 1 _) = True
balanced (BankersDequeue sizeF _ sizeR _) =
    sizeF <= bqBalance * sizeR + 1 && sizeR <= bqBalance * sizeF + 1

-- | Validates that a 'BankersDequeue' remains balanced despite repeated
--   pushes to the front.
prop_push_front_bq_balance :: BankersDequeue Int -> Int -> Bool
prop_push_front_bq_balance q count =
    let push _ = (flip pushFront) 0
        q' = foldr push q [0 .. count] in
    balanced q'

-- | Validates that a 'BankersDequeue' remains balanced despite repeated
--   pushes to the back.
prop_push_back_bq_balance :: BankersDequeue Int -> Int -> Bool
prop_push_back_bq_balance q count =
    let push _ = (flip pushBack) 0
        q' = foldr push q [0 .. count] in
    balanced q'

-- | Validates that a 'BankersDequeue' remains balanced despite repeated
--   pops from the front.
prop_pop_front_bq_balance :: BankersDequeue Int -> Int -> Bool
prop_pop_front_bq_balance q count =
    let pop _ queue = let (_, queue') = popFront queue in queue'
        q' = foldr pop q [0 .. count] in
    balanced q'

-- | Validates that a 'BankersDequeue' remains balanced despite repeated
--   pops from the back.
prop_pop_back_bq_balance :: BankersDequeue Int -> Int -> Bool
prop_pop_back_bq_balance q count =
    let pop _ queue = let (_, queue') = popBack queue in queue'
        q' = foldr pop q [0 .. count] in
    balanced q'