{-# LANGUAGE CPP #-}
{- |
Module : Data.Dequeue
Description : A typeclass and an implementation for double-ended queues.
Copyright : (c) Henry Bucklow 2009-2010
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(..),
-- * Support for 'Read' and 'Show' instances
showDequeue,
readDequeue,
-- * QuickCheck properties for 'Dequeue' instances
prop_pushpop_front,
prop_pushpop_back,
prop_push_front,
prop_push_back,
prop_takeFront,
prop_takeBack,
prop_length_toList,
prop_fromList_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_takeFront_bq,
prop_takeBack_bq,
prop_length_toList_bq,
prop_fromList_toList_bq,
prop_push_front_bq_balance,
prop_push_back_bq_balance,
prop_pop_front_bq_balance,
prop_pop_back_bq_balance,
prop_read_show_bq
) 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
#if MIN_VERSION_QuickCheck(2,0,0)
#else
hiding (check)
#endif
import Safe
import qualified Data.Dequeue.Show
-- | A typeclass for double-ended queues.
class Foldable q => Dequeue q where
-- | Generates an empty queue.
empty :: q a
-- | Returns 'True' if this queue is empty.
null :: q a -> Bool
#if !MIN_VERSION_base(4,8,0)
-- | Returns the number of elements in this queue.
length :: q a -> Int
#endif
-- | 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, in the order
-- they would be popped.
takeFront :: Int -> q a -> [a]
-- | Returns the last n items from the end of the queue, in the order they
-- would be popped.
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
-- | Support to make generating 'Show' instances for 'Dequeue's easier. Use as
-- follows:
--
-- @
-- instance Show a => Show (MyDequeue a) where
-- show q = showDequeue q
-- @
--
-- The resulting 'Show' instance will be portable between 'Deqeue' instances,
-- and will not expose the details of how your 'Dequeue' instance is
-- constructed.
showDequeue :: (Foldable q, Dequeue q, Show a) => q a -> String
showDequeue q = show $ Data.Dequeue.Show.Dequeue (toList q)
-- | Support to make generating 'Read' instances for 'Dequeue's easier. Use as
-- follows:
--
-- @
-- instance Read a => Read (MyDequeue a) where
-- readsPrec i = readDequeue $ readsPrec i
-- @
--
-- The resulting 'Read' instance will be portable between 'Deqeue' instances,
-- and will not expose the details of how your 'Dequeue' instance is
-- constructed.
readDequeue :: (Dequeue q, Read a) => ReadS (Data.Dequeue.Show.Dequeue a) -> ReadS (q a)
readDequeue readsDefn = \ s -> map convert (readsDefn s)
where convert (Data.Dequeue.Show.Dequeue values, s) = (fromList values, s)
-- 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 Just (a', q') = popFront (pushFront q a) in
a' == 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 Just (a', q') = popBack (pushBack q a) in
a' == 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 last 'n' pushed elements are returned by takeFront.
prop_takeFront :: (Dequeue q, Eq a) => q a -> [a] -> Bool
prop_takeFront q as =
takeFront (List.length as) (foldr (flip pushFront) q as) == as
-- | Validates that the last 'n' pushed elements are returned by takeBack.
prop_takeBack :: (Dequeue q, Eq a) => q a -> [a] -> Bool
prop_takeBack q as =
takeBack (List.length as) (foldr (flip pushBack) q as) == as
-- | 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
-- | Validates that fromList . toList is the identity.
prop_fromList_toList :: (Dequeue q, Foldable q, Eq (q a)) => q a -> Bool
prop_fromList_toList q = (fromList . toList) q == 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)
#if MIN_VERSION_base(4,8,0)
length (BankersDequeue sizeF _ sizeR _) = sizeF + sizeR
#endif
instance Dequeue BankersDequeue where
empty = BankersDequeue 0 [] 0 []
null (BankersDequeue 0 [] 0 []) = True
null _ = False
#if !MIN_VERSION_base(4,8,0)
length (BankersDequeue sizeF _ sizeR _) = sizeF + sizeR
#endif
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) =
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
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
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 ++ reverse (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
#if MIN_VERSION_QuickCheck(2,0,0)
#else
coarbitrary (BankersDequeue _ front _ rear) =
variant 0 . coarbitrary front . coarbitrary rear
#endif
instance Eq a => Eq (BankersDequeue a) where
queue1 == queue2 = toList queue1 == toList queue2
instance Show a => Show (BankersDequeue a) where
show q = showDequeue q
instance Read a => Read (BankersDequeue a) where
readsPrec i = readDequeue $ readsPrec i
-- 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 last 'n' pushed elements are returned by takeFront.
prop_takeFront_bq :: BankersDequeue Int -> [Int] -> Bool
prop_takeFront_bq = prop_takeFront
-- | Validates that the last 'n' pushed elements are returned by takeBack.
prop_takeBack_bq :: BankersDequeue Int -> [Int] -> Bool
prop_takeBack_bq = prop_takeBack
-- | 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
-- | Validates that fromList . toList is the identity for a 'BankersDequeue'.
prop_fromList_toList_bq :: BankersDequeue Int -> Bool
prop_fromList_toList_bq = prop_fromList_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 -> Property
prop_push_front_bq_balance q count = count < qcLimit ==>
let push queue _ = pushFront queue 0
q' = foldl 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 -> Property
prop_push_back_bq_balance q count = count < qcLimit ==>
let push queue _ = pushBack queue 0
q' = foldl 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 -> Property
prop_pop_front_bq_balance q count = count < qcLimit ==>
let pop queue _ = (fromJustDef queue . liftM snd . popFront) queue
q' = foldl 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 -> Property
prop_pop_back_bq_balance q count = count < qcLimit ==>
let pop queue _ = (fromJustDef queue . liftM snd . popBack) queue
q' = foldl pop q [0 .. count] in
balanced q'
-- | Limit quickcheck tests to this size of dequeue, to keep test time and
-- memory usage reasonable.
qcLimit :: Int
qcLimit = 10 ^ (6 :: Int)
-- | Validates that a 'BankersDequeue' has read and show instances that are
-- the inverse of each other.
prop_read_show_bq :: BankersDequeue Int -> Bool
prop_read_show_bq q = (read . show) q == q