packages feed

heap 0.6.0 → 1.0.0

raw patch · 11 files changed

+943/−454 lines, 11 filesdep +QuickCheckdep ~basesetup-changednew-component:exe:heap-tests

Dependencies added: QuickCheck

Dependency ranges changed: base

Files

Data/Heap.hs view
@@ -1,8 +1,7 @@-{-# LANGUAGE CPP, EmptyDataDecls, FlexibleInstances, MultiParamTypeClasses #-}---- | A flexible implementation of min-, max- and custom-priority heaps based on--- the leftist-heaps from Chris Okasaki's book \"Purely Functional Data--- Structures\", Cambridge University Press, 1998, chapter 3.1.+-- | A flexible implementation of min-, max-, min-priority, max-priority and+-- custom-priority heaps based on the leftist-heaps from Chris Okasaki's book+-- \"Purely Functional Data Structures\", Cambridge University Press, 1998,+-- chapter 3.1. -- -- There are different flavours of 'Heap's, each of them following a different -- strategy when ordering its elements:@@ -12,30 +11,33 @@ -- --  * If you wish to manually annotate a value with a priority, e. g. an @IO ()@ --    action with an 'Int' use 'MinPrioHeap' or 'MaxPrioHeap'. They manage---    @(priority, value)@ tuples so that only the priority (and not the value)+--    @(prio, val)@ tuples so that only the priority (and not the value) --    influences the order of elements. -- --  * If you still need something different, define a custom order for the heap---    elements by implementing a 'HeapPolicy' and let the maintainer know,---    what's missing.+--    elements by implementing an instance of 'HeapItem' and let the maintainer+--    know what's missing. ----- This module is best imported @qualified@ in order to prevent name clashes--- with other modules.+-- All sorts of heaps mentioned above ('MinHeap', 'MaxHeap', 'MinPrioHeap' and+-- 'MaxPrioHeap') are built on the same underlying type: @'HeapT' prio val@. It is+-- a simple minimum priority heap. The trick is, that you never insert @(prio,+-- val)@ pairs directly: You only insert an \"external representation\", usually+-- called @item@, and an appropriate 'HeapItem' instance is used to 'split' the+-- @item@ to a @(prio, val)@ pair. For details refer to the documentation of+-- 'HeapItem'. module Data.Heap     ( -- * Types       -- ** Various heap flavours-#ifdef __DEBUG__-      Heap(..), rank, policy-#else-      Heap-#endif+      HeapT, Heap     , MinHeap, MaxHeap, MinPrioHeap, MaxPrioHeap-      -- ** Ordering policies-    , HeapPolicy(..), MinPolicy, MaxPolicy, FstMinPolicy, FstMaxPolicy+      -- ** Ordering strategies+    , HeapItem(..), MinPolicy, MaxPolicy, FstMinPolicy, FstMaxPolicy       -- * Query-    , null, isEmpty, size, head, tail, view, extractHead+    , I.isEmpty, null, I.size       -- * Construction-    , empty, singleton, insert, union, unions+    , I.empty, singleton, insert, I.union, I.unions+      -- * Deconstruction+    , view, viewHead, viewTail       -- * Filter     , filter, partition       -- * Subranges@@ -43,327 +45,124 @@     , takeWhile, dropWhile, span, break       -- * Conversion       -- ** List-    , fromList, toList, elems+    , fromList, toList       -- ** Ordered list     , fromAscList, toAscList     , fromDescList, toDescList     ) where -import Data.Foldable ( foldl' )-import Data.List ( sortBy )-import Data.Monoid ( Monoid(..) )-import Data.Ord ( comparing )-import Prelude hiding ( break, drop, dropWhile, filter, head, null, tail, span-                      , splitAt, take, takeWhile )-#ifdef __GLASGOW_HASKELL__-import Text.Read-#endif---- | The basic 'Heap' type.-data Heap p a-    = Empty -- rank, size, elem, left, right-    | Tree {-# UNPACK #-} !Int {-# UNPACK #-} !Int a !(Heap p a) !(Heap p a)---- | A 'Heap' which will always extract the minimum first.-type MinHeap a = Heap MinPolicy a---- | A 'Heap' which will always extract the maximum first.-type MaxHeap a = Heap MaxPolicy a---- | A 'Heap' storing priority-value-associations. It only regards the priority--- for determining the order of elements, the tuple with minimal 'fst' value--- (i. e. priority) will always be the head of the 'Heap'.-type MinPrioHeap priority value = Heap FstMinPolicy (priority, value)---- | A 'Heap' storing priority-value-associations. It only regards the priority--- for determining the order of elements, the tuple with maximal 'fst' value--- (i. e. priority) will always be the head of the 'Heap'.-type MaxPrioHeap priority value = Heap FstMaxPolicy (priority, value)--instance (Show a) => Show (Heap p a) where-    show = ("fromList " ++) . show . toList--instance (HeapPolicy p a, Read a) => Read (Heap p a) where-#ifdef __GLASGOW_HASKELL__-    readPrec = parens $ prec 10 $ do-        Ident "fromList" <- lexP-        xs               <- readPrec-        return (fromList xs)-    readListPrec = readListPrecDefault-#else-    readsPrec p = readParen (p > 10) $ \r -> do-        ("fromList", s) <- lex r-        (xs, t)         <- reads s-        return (fromList xs, t)-#endif--instance (HeapPolicy p a) => Eq (Heap p a) where-    h1 == h2 = EQ == compare h1 h2--instance (HeapPolicy p a) => Ord (Heap p a) where-    compare h1 h2 = compareBy (heapCompare (policy h1)) (toAscList h1) (toAscList h2)-        where-        compareBy :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering-        compareBy _   []     []     = EQ-        compareBy _   []     _      = LT-        compareBy _   _      []     = GT-        compareBy cmp (x:xs) (y:ys) = mappend (cmp x y) (compareBy cmp xs ys)--instance (HeapPolicy p a) => Monoid (Heap p a) where-    mempty  = empty-    mappend = union-    mconcat = unions---- | The 'HeapPolicy' class defines an order on the elements contained within--- a 'Heap'.-class HeapPolicy p a where-    -- | Compare two elements, just like 'compare' of the 'Ord' class, so this-    -- function has to define a mathematical ordering. When using a 'HeapPolicy'-    -- for a 'Heap', the minimal value (defined by this order) will be the head-    -- of the 'Heap'.-    heapCompare :: p -- ^ /Must not be evaluated/.-        -> a         -- ^ Compared to 3rd parameter.-        -> a         -- ^ Compared to 2nd parameter.-        -> Ordering  -- ^ Result of the comparison.---- | Policy type for a 'MinHeap'.-data MinPolicy--instance (Ord a) => HeapPolicy MinPolicy a where-    heapCompare = const compare---- | Policy type for a 'MaxHeap'.-data MaxPolicy--instance (Ord a) => HeapPolicy MaxPolicy a where-    heapCompare = const (flip compare)---- | Policy type for a @(priority, value)@ 'MinPrioHeap'.-data FstMinPolicy--instance (Ord priority) => HeapPolicy FstMinPolicy (priority, value) where-    heapCompare = const (comparing fst)---- | Policy type for a @(priority, value)@ 'MaxPrioHeap'.-data FstMaxPolicy--instance (Ord priority) => HeapPolicy FstMaxPolicy (priority, value) where-    heapCompare = const (flip (comparing fst))---- | /O(1)/. Is the 'Heap' empty?-null :: Heap p a -> Bool-null Empty = True-null _     = False---- | /O(1)/. Is the 'Heap' empty?-isEmpty :: Heap p a -> Bool-isEmpty = null---- | /O(1)/. Calculate the rank of a 'Heap'.-rank :: Heap p a -> Int-rank Empty            = 0-rank (Tree r _ _ _ _) = r---- | /O(1)/. The number of elements in the 'Heap'.-size :: Heap p a -> Int-size Empty            = 0-size (Tree _ s _ _ _) = s---- | This function is 'undefined' and just used as a type-helper to determine--- the first parameter of 'heapCompare'.-policy :: Heap p a -> p-policy = undefined+import Data.Heap.Item+import Data.Heap.Internal ( HeapT )+import qualified Data.Heap.Internal as I+import Prelude hiding+    ( break, drop, dropWhile, filter, null, span, splitAt, take, takeWhile ) --- | /O(1)/. Returns the first item of the 'Heap', according to its 'HeapPolicy'.------ /Warning:/ This function issues an 'error' for empty 'Heap's, please consider--- using the 'view' function instead, it's safe.-head :: (HeapPolicy p a) => Heap p a -> a-head = fst . extractHead+-- | /O(1)/. Is the 'HeapT' empty?+null :: HeapT prio val -> Bool+null = I.isEmpty --- | /O(log n)/. Returns the 'Heap' with the 'head' removed.------ /Warning:/ This function issues an 'error' for empty 'Heap's, please consider--- using the 'view' function instead, it's safe.-tail :: (HeapPolicy p a) => Heap p a -> Heap p a-tail = snd . extractHead+-- | /O(1)/. Create a singleton 'HeapT'.+singleton :: (HeapItem pol item) => item -> Heap pol item+singleton = (uncurry I.singleton) . split --- | /O(log n)/ for the tail, /O(1)/ for the head. Find the minimum (depending--- on the 'HeapPolicy') and delete it from the 'Heap' (i. e. find head and tail--- of a heap) if it is not empty. Otherwise, 'Nothing' is returned.-view :: (HeapPolicy p a) => Heap p a -> Maybe (a, Heap p a)-view Empty            = Nothing-view (Tree _ _ x l r) = Just (x, union l r)-{-# INLINE view #-}+-- | /O(log n)/. Insert a single item into the 'HeapT'.+insert :: (HeapItem pol item) => item -> Heap pol item -> Heap pol item+insert = I.union . singleton --- | /O(log n)/. Returns 'head' and 'tail' of a 'Heap'.------ /Warning:/ This function issues an 'error' for empty 'Heap's, please consider--- using the 'view' function instead, it's safe.-extractHead :: (HeapPolicy p a) => Heap p a -> (a, Heap p a)-extractHead heap = maybe (error (__FILE__ ++ ": empty heap in extractHead")) id (view heap)+-- | /O(1)/ for the head, /O(log n)/ for the tail. Find the item with minimal+-- associated priority and remove it from the 'Heap' (i. e. find head and tail+-- of the heap) if it is not empty. Otherwise, 'Nothing' is returned.+view :: (HeapItem pol item) => Heap pol item -> Maybe (item, Heap pol item)+view = fmap (\(p, v, h) -> (merge (p, v), h)) . I.view --- | /O(1)/. Constructs an empty 'Heap'.-empty :: Heap p a-empty = Empty+-- | /O(1)/. Find the item with minimal associated priority on the 'Heap' (i. e.+-- its head) if it is not empty. Otherwise, 'Nothing' is returned.+viewHead :: (HeapItem pol item) => Heap pol item -> Maybe item+viewHead = fmap fst . view --- | /O(1)/. Create a singleton 'Heap'.-singleton :: a -> Heap p a-singleton x = Tree 1 1 x empty empty+-- | /O(log n)/. Remove the item with minimal associated priority and from the+-- 'Heap' (i. e. its tail) if it is not empty. Otherwise, 'Nothing' is returned.+viewTail :: (HeapItem pol item) => Heap pol item -> Maybe (Heap pol item)+viewTail = fmap snd . view --- | /O(log n)/. Insert an element in the 'Heap'.-insert :: (HeapPolicy p a) => a -> Heap p a -> Heap p a-insert x h = union h (singleton x)+-- | Remove all items from a 'HeapT' not fulfilling a predicate.+filter :: (HeapItem pol item) => (item -> Bool) -> Heap pol item -> Heap pol item+filter p = fst . (partition p) --- | /O(1)/. Insert an element into the 'Heap' that is smaller than all elements--- currently in the 'Heap' (according to the 'HeapPolicy'), i. e. an element--- that will be the new 'head' of the 'Heap'.------ /The precondition is not checked/.-insertMin :: (HeapPolicy p a) => a -> Heap p a -> Heap p a-insertMin h hs = Tree 1 (1 + size hs) h hs empty+-- | Partition the 'Heap' into two. @'partition' p h = (h1, h2)@: All items in+-- @h1@ fulfil the predicate @p@, those in @h2@ don't. @'union' h1 h2 = h@.+partition :: (HeapItem pol item)+    => (item -> Bool) -> Heap pol item -> (Heap pol item, Heap pol item)+partition = I.partition . splitF --- | Take the lowest @n@ elements in ascending order of the 'Heap' (according--- to the 'HeapPolicy').-take :: (HeapPolicy p a) => Int -> Heap p a -> [a]-take n = fst . (splitAt n)+-- | Take the first @n@ items from the 'Heap'.+take :: (HeapItem pol item) => Int -> Heap pol item -> [item]+take n = fst . splitAt n --- | Remove the lowest (according to the 'HeapPolicy') @n@ elements--- from the 'Heap'.-drop :: (HeapPolicy p a) => Int -> Heap p a -> Heap p a-drop n = snd . (splitAt n)+-- | Remove first @n@ items from the 'Heap'.+drop :: (HeapItem pol item) => Int -> Heap pol item -> Heap pol item+drop n = snd . splitAt n --- | @'splitAt' n h@ returns an ascending list of the lowest @n@ elements of @h@--- (according to its 'HeapPolicy') and a 'Heap' like @h@, lacking those elements.-splitAt :: (HeapPolicy p a) => Int -> Heap p a -> ([a], Heap p a)-splitAt n heap-    | n > 0     = case view heap of-        Nothing      -> ([], empty)-        Just (h, hs) -> let (xs, heap') = splitAt (n-1) hs in (h:xs, heap')-    | otherwise = ([], heap)+-- | @'splitAt' n h@: Return a list of the first @n@ items of @h@ and @h@, with+-- those elements removed.+splitAt :: (HeapItem pol item) => Int -> Heap pol item -> ([item], Heap pol item)+splitAt n heap = let (xs, heap') = I.splitAt n heap in (fmap merge xs, heap') --- | @'takeWhile' p h@ lists the longest prefix of elements in ascending order--- (according to its 'HeapPolicy') of @h@ that satisfy @p@.-takeWhile :: (HeapPolicy p a) => (a -> Bool) -> Heap p a -> [a]+-- | @'takeWhile' p h@: List the longest prefix of items in @h@ that satisfy @p@.+takeWhile :: (HeapItem pol item) => (item -> Bool) -> Heap pol item -> [item] takeWhile p = fst . (span p) --- | @'dropWhile' p h@ removes the longest prefix of elements from @h@ that--- satisfy @p@.-dropWhile :: (HeapPolicy p a) => (a -> Bool) -> Heap p a -> Heap p a+-- | @'dropWhile' p h@: Remove the longest prefix of items in @h@ that satisfy+-- @p@.+dropWhile :: (HeapItem pol item)+    => (item -> Bool) -> Heap pol item -> Heap pol item dropWhile p = snd . (span p) --- | @'span' p h@ returns the longest prefix of elements in ascending order--- (according to its 'HeapPolicy') of @h@ that satisfy @p@ and a 'Heap' like+-- | @'span' p h@: Return the longest prefix of items in @h@ that satisfy @p@ and -- @h@, with those elements removed.-span :: (HeapPolicy p a) => (a -> Bool) -> Heap p a -> ([a], Heap p a)-span p heap = case view heap of-    Nothing      -> ([], empty)-    Just (h, hs) -> if p h-        then let (xs, heap') = span p hs in (h:xs, heap')-        else ([], heap)+span :: (HeapItem pol item)+    => (item -> Bool) -> Heap pol item -> ([item], Heap pol item)+span p heap = let (xs, heap') = I.span (splitF p) heap in (fmap merge xs, heap') --- | @'break' p h@ returns the longest prefix of elements in ascending order--- (according to its 'HeapPolicy') of @h@ that do /not/ satisfy @p@ and a 'Heap'--- like @h@, with those elements removed.-break :: (HeapPolicy p a) => (a -> Bool) -> Heap p a -> ([a], Heap p a)+-- | @'break' p h@: The longest prefix of items in @h@ that do /not/ satisfy @p@+-- and @h@, with those elements removed.+break :: (HeapItem pol item)+    => (item -> Bool) -> Heap pol item -> ([item], Heap pol item) break p = span (not . p) --- | /O(log max(n, m))/. The union of two 'Heap's.-union :: (HeapPolicy p a) => Heap p a -> Heap p a -> Heap p a-union h Empty = h-union Empty h = h-union heap1@(Tree _ _ x l1 r1) heap2@(Tree _ _ y l2 r2) =-    if LT == heapCompare (policy heap1) x y-        then makeT x l1 (union r1 heap2) -- keep smallest number on top and merge the other-        else makeT y l2 (union r2 heap1) -- heap into the right branch, it's shorter---- | Combines a value @x@ and two 'Heap's to one 'Heap'. Therefore, @x@ has to--- be less or equal the minima (depending on the 'HeapPolicy') of both 'Heap'--- parameters.------ /The precondition is not checked/.-makeT :: a -> Heap p a -> Heap p a -> Heap p a-makeT x a b = let-    ra = rank a-    rb = rank b-    s  = size a + size b + 1-    in if ra > rb-        then Tree (rb + 1) s x a b-        else Tree (ra + 1) s x b a-{-# INLINE makeT #-}---- | Builds the union over all given 'Heap's.-unions :: (HeapPolicy p a) => [Heap p a] -> Heap p a-unions heaps = case tournamentFold' heaps of-    []  -> empty-    [h] -> h-    hs  -> unions hs-    where-    tournamentFold' :: (Monoid m) => [m] -> [m]-    tournamentFold' (x1:x2:xs) = (: tournamentFold' xs) $! mappend x1 x2-    tournamentFold' xs         = xs-    {-# INLINE tournamentFold' #-}---- | Removes all elements from a given 'Heap' that do not fulfil the predicate.-filter :: (HeapPolicy p a) => (a -> Bool) -> Heap p a -> Heap p a-filter p = fst . (partition p)---- | Partition the 'Heap' into two. @'partition' p h = (h1, h2)@: All elements--- in @h1@ fulfil the predicate @p@, those in @h2@ don't. @'union' h1 h2 = h@.-partition :: (HeapPolicy p a) => (a -> Bool) -> Heap p a -> (Heap p a, Heap p a)-partition _ Empty = (empty, empty)-partition p (Tree _ _ x l r)-    | p x       = (makeT x l1 r1, union l2 r2)-    | otherwise = (union l1 r1, makeT x l2 r2)-    where-    (l1, l2) = partition p l-    (r1, r2) = partition p r---- | Builds a 'Heap' from the given elements. Assuming you have a sorted list,--- you may want to use 'fromDescList' or 'fromAscList', they are both faster--- than this function.-fromList :: (HeapPolicy p a) => [a] -> Heap p a-fromList xs = let-    heap = fromDescList $ sortBy (flip (heapCompare (policy heap))) xs-    in heap---- | /O(n)/. Lists elements of the 'Heap' in no specific order.-toList :: Heap p a -> [a]-toList Empty            = []-toList (Tree _ _ x l r) = x : if size r < size l-    then toList r ++ toList l-    else toList l ++ toList r+-- | /O(n log n)/. Build a 'Heap' from the given items. Assuming you have a+-- sorted list, you probably want to use 'fromDescList' or 'fromAscList', they+-- are faster than this function.+fromList :: (HeapItem pol item) => [item] -> Heap pol item+fromList = I.fromList . fmap split --- | /O(n)/. Lists elements of the 'Heap' in no specific order.-elems :: Heap p a -> [a]-elems = toList+-- | /O(n log n)/. List all items of the 'Heap' in no specific order.+toList :: (HeapItem pol item) => Heap pol item -> [item]+toList = fmap merge . I.toList --- | /O(n)/. Creates a 'Heap' from an ascending list. Note that the list has to--- be ascending corresponding to the 'HeapPolicy', not to its 'Ord' instance--- declaration (if there is one). This function is faster than 'fromList' but--- not as fast as 'fromDescList'.+-- | /O(n)/. Create a 'Heap' from a list providing its items in ascending order+-- of priority (i. e. in the same order they will be removed from the 'Heap').+-- This function is faster than 'fromList' but not as fast as 'fromDescList'. -- -- /The precondition is not checked/.-fromAscList :: (HeapPolicy p a) => [a] -> Heap p a+fromAscList :: (HeapItem pol item) => [item] -> Heap pol item fromAscList = fromDescList . reverse --- | /O(n)/. Lists elements of the 'Heap' in ascending order (corresponding to--- the 'HeapPolicy').-toAscList :: (HeapPolicy p a) => Heap p a -> [a]-toAscList = takeWhile (const True)+-- | /O(n log n)/. List the items of the 'Heap' in ascending order of priority.+toAscList :: (HeapItem pol item) => Heap pol item -> [item]+toAscList = fmap merge . I.toAscList --- | /O(n)/. Create a 'Heap' from a descending list. Note that the list has to--- be descending corresponding to the 'HeapPolicy', not to its 'Ord' instance--- declaration (if there is one). This function is provided, because it is much--- faster than 'fromList' and 'fromAscList'.+-- | /O(n)/. Create a 'Heap' from a list providing its items in descending order+-- of priority (i. e. they will be removed inversely from the 'Heap'). Prefer+-- this function over 'fromList' and 'fromAscList', it's faster. -- -- /The precondition is not checked/.-fromDescList :: (HeapPolicy p a) => [a] -> Heap p a-fromDescList = foldl' (flip insertMin) empty+fromDescList :: (HeapItem pol item) => [item] -> Heap pol item+fromDescList = I.fromDescList . fmap split --- | /O(n)/. Lists the elements on the 'Heap' in descending order (corresponding--- to the 'HeapPolicy'). Note that this function is not especially efficient (it--- is implemented as @'reverse' . 'toAscList'@), it is just provided as a--- counterpart of the very efficient 'fromDescList' function.-toDescList :: (HeapPolicy p a) => Heap p a -> [a]+-- | /O(n log n)/. List the items of the 'Heap' in descending order of priority.+-- Note that this function is not especially efficient (it is implemented in+-- terms of 'reverse' and 'toAscList'), it is provided as a counterpart of the+-- efficient 'fromDescList' function.+toDescList :: (HeapItem pol item) => Heap pol item -> [item] toDescList = reverse . toAscList
+ Data/Heap/Internal.hs view
@@ -0,0 +1,255 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- | This module provides a simple leftist-heap implementation based on Chris+-- Okasaki's book \"Purely Functional Data Structures\", Cambridge University+-- Press, 1998, chapter 3.1.+--+-- A @'HeapT' prio val@ associates a priority @prio@ to a value @val@. A+-- priority-value pair with minimum priority will always be the head of the+-- 'HeapT', so this module implements minimum priority heaps. Note that the value+-- associated to the priority has no influence on the ordering of elements, only+-- the priority does.+module Data.Heap.Internal+    ( -- * A basic heap type+      HeapT(..)+      -- * Query+    , isEmpty, rank, size+      -- * Construction+    , empty, singleton, union, unions+      -- * Deconstruction+    , view+      -- * Filter+    , partition+      -- * Subranges+    , splitAt, span+      -- * Conversion+    , fromList, toList+    , fromDescList, toAscList+    ) where++import Control.Exception+import Data.Foldable ( Foldable(..), foldl' )+import Data.List ( groupBy, sortBy )+import Data.Monoid+import Data.Ord+import Data.Typeable+import Prelude hiding ( foldl, span, splitAt )+import Text.Read++-- | The basic heap type. It stores priority-value pairs @(prio, val)@ and+-- always keeps the pair with minimal priority on top. The value associated to+-- the priority does not have any influence on the ordering of elements.+data HeapT prio val+    = Empty  -- ^ An empty 'HeapT'.+    | Tree { _rank     :: {-# UNPACK #-} !Int -- ^ Rank of the leftist heap.+           , _size     :: {-# UNPACK #-} !Int -- ^ Number of elements in the heap.+           , _priority :: !prio               -- ^ Priority of the entry.+           , _value    :: val                 -- ^ Value of the entry.+           , _left     :: !(HeapT prio val)   -- ^ Left subtree.+           , _right    :: !(HeapT prio val)   -- ^ Right subtree.+           } -- ^ A tree node of a non-empty 'HeapT'.+    deriving (Typeable)++instance (Read prio, Read val, Ord prio) => Read (HeapT prio val) where+    readPrec     = parens $ prec 10 $ do+        Ident "fromList" <- lexP+        fmap fromList readPrec+    readListPrec = readListPrecDefault++instance (Show prio, Show val) => Show (HeapT prio val) where+    showsPrec d heap = showParen (d > 10)+        $ showString "fromList " . (showsPrec 11 (toList heap))++instance (Ord prio, Ord val) => Eq (HeapT prio val) where+    heap1 == heap2 = size heap1 == size heap2 && EQ == compare heap1 heap2++instance (Ord prio, Ord val) => Ord (HeapT prio val) where+    compare = comparing toPairAscList++instance (Ord prio) => Monoid (HeapT prio val) where+    mempty  = empty+    mappend = union+    mconcat = unions++instance Functor (HeapT prio) where+    fmap _ Empty = Empty+    fmap f heap  = heap { _value = f (_value heap)+                        , _left  = fmap f (_left heap)+                        , _right = fmap f (_right heap)+                        }++instance (Ord prio) => Foldable (HeapT prio) where+    foldMap f = foldMap f . fmap snd . toAscList+    foldr f z = foldl (flip f) z . fmap snd . reverse . toAscList+    foldl f z = foldl f z . fmap snd . toAscList++-- | /O(1)/. Is the 'HeapT' empty?+isEmpty :: HeapT prio val -> Bool+isEmpty Empty = True+isEmpty _     = False++-- | /O(1)/. Find the rank of a 'HeapT' (the length of its right spine).+rank :: HeapT prio val -> Int+rank Empty = 0+rank heap  = _rank heap++-- | /O(1)/. The total number of elements in the 'HeapT'.+size :: HeapT prio val -> Int+size Empty = 0+size heap  = _size heap++-- | /O(1)/. Construct an empty 'HeapT'.+empty :: HeapT prio val+empty = Empty++-- | /O(1)/. Create a singleton 'HeapT'.+singleton :: prio -> val -> HeapT prio val+singleton p v = Tree { _rank     = 1+                     , _size     = 1+                     , _priority = p+                     , _value    = v+                     , _left     = empty+                     , _right    = empty+                     }+{-# INLINE singleton #-}++-- | /O(1)/. Insert an priority-value pair into the 'HeapT', whose /priority is+-- less or equal/ to all other priorities on the 'HeapT', i. e. a pair that is a+-- valid head of the 'HeapT'.+--+-- /The precondition is not checked/.+uncheckedCons :: (Ord prio) => prio -> val -> HeapT prio val -> HeapT prio val+uncheckedCons p v heap = assert (maybe True (\(p', _, _) -> p <= p') (view heap))+    Tree { _rank     = 1+         , _size     = 1 + size heap+         , _priority = p+         , _value    = v+         , _left     = heap+         , _right    = empty+         }+{-# INLINE uncheckedCons #-}++-- | /O(log max(n, m))/. Form the union of two 'HeapT's.+union :: (Ord prio) => HeapT prio val -> HeapT prio val -> HeapT prio val+union heap  Empty = heap+union Empty heap  = heap+union heap1 heap2 = let+    p1 = _priority heap1+    p2 = _priority heap2+    in if p1 < p2+        then makeT p1 (_value heap1) (_left heap1) (union (_right heap1) heap2)+        else makeT p2 (_value heap2) (_left heap2) (union (_right heap2) heap1)++-- | Build a 'HeapT' from a priority, a value and two more 'HeapT's. Therefore,+-- the /priority has to be less or equal/ than all priorities in both 'HeapT'+-- parameters.+--+-- /The precondition is not checked/.+makeT :: (Ord prio) => prio -> val -> HeapT prio val -> HeapT prio val -> HeapT prio val+makeT p v a b = let+    ra = rank a+    rb = rank b+    s  = size a + size b + 1+    in assert (checkPrio a && checkPrio b) $ if ra > rb+        then Tree (rb + 1) s p v a b+        else Tree (ra + 1) s p v b a+    where+    checkPrio = maybe True (\(p', _, _) -> p <= p') . view+{-# INLINE makeT #-}++-- | Build the union of all given 'HeapT's.+unions :: (Ord prio) => [HeapT prio val] -> HeapT prio val+unions heaps = case tournamentFold' heaps of+    []  -> empty+    [h] -> h+    hs  -> unions hs+    where+    tournamentFold' :: (Monoid m) => [m] -> [m]+    tournamentFold' (x1:x2:xs) = (: tournamentFold' xs) $! mappend x1 x2+    tournamentFold' xs         = xs++-- | /O(log n)/ for the tail, /O(1)/ for the head. Find the priority-value pair+-- with minimal priority and delete it from the 'HeapT' (i. e. find head and tail+-- of the heap) if it is not empty. Otherwise, 'Nothing' is returned.+view :: (Ord prio) => HeapT prio val -> Maybe (prio, val, HeapT prio val)+view Empty = Nothing+view heap  = Just (_priority heap, _value heap, union (_left heap) (_right heap))+{-# INLINE view #-}++-- | Partition the 'HeapT' into two. @'partition' p h = (h1, h2)@: All+-- priority-value pairs in @h1@ fulfil the predicate @p@, those in @h2@ don't.+-- @'union' h1 h2 = h@.+partition :: (Ord prio) => ((prio, val) -> Bool) -> HeapT prio val+    -> (HeapT prio val, HeapT prio val)+partition _ Empty  = (empty, empty)+partition f heap+    | f (p, v)  = (makeT p v l1 r1, union l2 r2)+    | otherwise = (union l1 r1, makeT p v l2 r2)+    where+    (p, v)   = (_priority heap, _value heap)+    (l1, l2) = partition f (_left heap)+    (r1, r2) = partition f (_right heap)+{-# INLINE partition #-}++-- | @'splitAt' n h@: A list of the lowest @n@ priority-value pairs of @h@, in+--  ascending order of priority, and @h@, with those elements removed.+splitAt :: (Ord prio) => Int -> HeapT prio val -> ([(prio, val)], HeapT prio val)+splitAt n heap+    | n > 0     = case view heap of+        Nothing         -> ([], empty)+        Just (p, v, hs) -> let (xs, heap') = splitAt (n-1) hs in ((p, v):xs, heap')+    | otherwise = ([], heap)+{-# INLINE splitAt #-}++-- | @'span' p h@: The longest prefix of priority-value pairs of @h@, in+-- ascending order of priority, that satisfy @p@ and @h@, with those elements+-- removed.+span :: (Ord prio) => ((prio, val) -> Bool) -> HeapT prio val+     -> ([(prio, val)], HeapT prio val)+span f heap = case view heap of+    Nothing         -> ([], empty)+    Just (p, v, hs) -> let pv = (p, v)+        in if f pv+            then let (xs, heap') = span f hs in (pv:xs, heap')+            else ([], heap)+{-# INLINE span #-}++-- | /O(n log n)/. Build a 'HeapT' from the given priority-value pairs.+fromList :: (Ord prio) => [(prio, val)] -> HeapT prio val+fromList = fromDescList . sortBy (flip (comparing fst))+{-# INLINE fromList #-}++-- | /O(n log n)/. List all priority-value pairs of the 'HeapT' in no specific+-- order.+toList :: HeapT prio val -> [(prio, val)]+toList Empty = []+toList heap  = let+    left  = _left heap+    right = _right heap+    in+    (_priority heap, _value heap) : if (size right) < (size left)+        then toList right ++ toList left+        else toList left  ++ toList right+{-# INLINE toList #-}++-- | /O(n)/. Create a 'HeapT' from a list providing its priority-value pairs in+-- descending order of priority.+--+-- /The precondition is not checked/.+fromDescList :: (Ord prio) => [(prio, val)] -> HeapT prio val+fromDescList = foldl' (\h (p, v) -> uncheckedCons p v h) empty+{-# INLINE fromDescList #-}++-- | /O(n log n)/. List the priority-value pairs of the 'HeapT' in ascending+-- order of priority.+toAscList :: (Ord prio) => HeapT prio val -> [(prio, val)]+toAscList = fst . span (const True)+{-# INLINE toAscList #-}++-- | List the priority-value pairs of the 'HeapT' just like 'toAscList' does,+-- but don't ignore the value @val@ when sorting.+toPairAscList :: (Ord prio, Ord val) => HeapT prio val -> [(prio, val)]+toPairAscList = concat+    . fmap (sortBy (comparing snd))+    . groupBy (\x y -> fst x == fst y)+    . toAscList
+ Data/Heap/Item.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE EmptyDataDecls, FlexibleContexts, FlexibleInstances+  , MultiParamTypeClasses, TypeFamilies+  #-}++-- | This module provides the 'HeapItem' type family along with necessary+-- instance declarations used to translate between inserted items and the+-- priority-value pairs needed by the minimum priority heap of the module+-- "Data.Heap.Internal".+module Data.Heap.Item+    ( -- * Type aliases+      Heap, MinHeap, MaxHeap, MinPrioHeap, MaxPrioHeap+      -- * The HeapItem type family+    , HeapItem(..)+    , MinPolicy, MaxPolicy, FstMinPolicy, FstMaxPolicy+      -- * Auxiliary functions+    , splitF+    ) where++import Data.Heap.Internal+import Text.Read++-- | This type alias is an abbreviation for a 'HeapT' which uses the 'HeapItem'+-- instance of @pol item@ to organise its elements.+type Heap pol item = HeapT (Prio pol item) (Val pol item)++-- | A 'Heap' which will always extract the minimum first.+type MinHeap a = Heap MinPolicy a++-- | A 'Heap' which will always extract the maximum first.+type MaxHeap a = Heap MaxPolicy a++-- | A 'Heap' storing priority-value pairs @(prio, val)@. The order of elements+-- is solely determined by the priority @prio@, the value @val@ has no influence.+-- The priority-value pair with minmal priority will always be extracted first.+type MinPrioHeap prio val = Heap FstMinPolicy (prio, val)++-- | A 'Heap' storing priority-value pairs @(prio, val)@. The order of elements+-- is solely determined by the priority @prio@, the value @val@ has no influence.+-- The priority-value pair with maximum priority will always be extracted first.+type MaxPrioHeap prio val = Heap FstMaxPolicy (prio, val)++-- | @'HeapItem' pol item@ is a type class for items that can be stored in a+-- 'HeapT'. A raw @'HeapT' prio val@ only provides a minimum priority heap (i. e.+-- @val@ doesn't influence the ordering of elements and the pair with minimal+-- @prio@ will be extracted first, see 'HeapT' documentation). The job of this+-- class is to translate between arbitrary @item@s and priority-value pairs+-- @('Prio' pol item, 'Val' pol item)@, depending on the policy @pol@ to be used.+-- This way, we are able to use 'HeapT' not only as 'MinPrioHeap', but also as+-- 'MinHeap', 'MaxHeap', 'MaxPrioHeap' or a custom implementation. In short: The+-- job of this class is to deconstruct arbitrary @item@s into a @(prio, val)@+-- pairs that can be handled by a minimum priority 'HeapT'.+--+-- Example: Consider you want to use @'HeapT' prio val@ as a @'MaxHeap' a@. You+-- would have to invert the order of @a@ (e. g. by introducing @newtype InvOrd a+-- = InvOrd a@ along with an apropriate 'Ord' instance for it) and then use a+-- @type 'MaxHeap' a = 'HeapT' (InvOrd a) ()@. You'd also have to translate+-- every @x@ to @(InvOrd x, ())@ before insertion and back after removal in+-- order to retrieve your original type @a@.+--+-- This functionality is provided by the 'HeapItem' class. In the above example,+-- you'd use a 'MaxHeap'. The according instance declaration is of course+-- already provided and looks like this (simplified):+--+-- @data 'MaxPolicy'+--+-- instance ('Ord' a) => 'HeapItem' 'MaxPolicy' a where+--     newtype 'Prio' 'MaxPolicy' a = MaxP a deriving ('Eq')+--     type    'Val'  'MaxPolicy' a = ()+--     'split' x           = (MaxP x, ())+--     'merge' (MaxP x, _) = x+--+-- instance ('Ord' a) => 'Ord' ('Prio' 'MaxPolicy' a) where+--     'compare' (MaxP x) (MaxP y) = 'compare' y x+-- @+--+-- 'MaxPolicy' is a phantom type describing which 'HeapItem' instance is actually+-- meant (e. g. we have to distinguish between 'MinHeap' and 'MaxHeap', which is+-- done via 'MinPolicy' and 'MaxPolicy', respectively) and @MaxP@ inverts the+-- ordering of @a@, so that the maximum will be on top of the 'HeapT'.+--+-- The conversion functions 'split' and 'merge' have to make sure that+--+-- (1) @forall p v. 'split' ('merge' (p, v)) == (p, v)@ ('merge' and 'split'+--     don't remove, add or alter anything)+--+-- (2) @forall p v f. 'fst' ('split' ('merge' (p, f v)) == 'fst' ('split'+--     ('merge' (p, v)))@ (modifying the associated value @v@ doesn't alter the+--      priority @p@)+class (Ord (Prio pol item)) => HeapItem pol item where+    -- | The part of @item@ that determines the order of elements on a 'HeapT'.+    data Prio pol item :: *+    -- | Everything not part of @'Prio' pol item@+    type Val  pol item :: *++    -- | Translate an @item@ into a priority-value pair.+    split :: item -> (Prio pol item, Val pol item)+    -- | Restore the @item@ from a priority-value pair.+    merge :: (Prio pol item, Val pol item) -> item+{-# RULES "split/merge" forall x. split (merge x) = x #-}++-- | Policy type for a 'MinHeap'.+data MinPolicy++instance (Ord a) => HeapItem MinPolicy a where+    newtype Prio MinPolicy a = MinP { unMinP :: a } deriving (Eq, Ord)+    type    Val  MinPolicy a = ()++    split x           = (MinP x, ())+    merge (MinP x, _) = x++instance (Read a) => Read (Prio MinPolicy a) where+    readPrec     = fmap MinP readPrec+    readListPrec = fmap (fmap MinP) readListPrec++instance (Show a) => Show (Prio MinPolicy a) where+    show        = show . unMinP+    showsPrec d = showsPrec d . unMinP+    showList    = showList . (fmap unMinP)++-- | Policy type for a 'MaxHeap'.+data MaxPolicy++instance (Ord a) => HeapItem MaxPolicy a where+    newtype Prio MaxPolicy a = MaxP { unMaxP :: a } deriving (Eq)+    type    Val  MaxPolicy a = ()++    split x           = (MaxP x, ())+    merge (MaxP x, _) = x++instance (Ord a) => Ord (Prio MaxPolicy a) where+    compare (MaxP x) (MaxP y) = compare y x++instance (Read a) => Read (Prio MaxPolicy a) where+    readPrec     = fmap MaxP readPrec+    readListPrec = fmap (fmap MaxP) readListPrec++instance (Show a) => Show (Prio MaxPolicy a) where+    show        = show . unMaxP+    showsPrec d = showsPrec d . unMaxP+    showList    = showList . (fmap unMaxP)++-- | Policy type for a @(prio, val)@ 'MinPrioHeap'.+data FstMinPolicy++instance (Ord prio) => HeapItem FstMinPolicy (prio, val) where+    newtype Prio FstMinPolicy (prio, val) = FMinP { unFMinP :: prio } deriving (Eq, Ord)+    type    Val  FstMinPolicy (prio, val) = val++    split (p,       v) = (FMinP p, v)+    merge (FMinP p, v) = (p,       v)++instance (Read prio) => Read (Prio FstMinPolicy (prio, val)) where+    readPrec     = fmap FMinP readPrec+    readListPrec = fmap (fmap FMinP) readListPrec++instance (Show prio) => Show (Prio FstMinPolicy (prio, val)) where+    show        = show . unFMinP+    showsPrec d = showsPrec d . unFMinP+    showList    = showList . (fmap unFMinP)++-- | Policy type for a @(prio, val)@ 'MaxPrioHeap'.+data FstMaxPolicy++instance (Ord prio) => HeapItem FstMaxPolicy (prio, val) where+    newtype Prio FstMaxPolicy (prio, val) = FMaxP { unFMaxP :: prio } deriving (Eq)+    type    Val  FstMaxPolicy (prio, val) = val++    split (p,       v) = (FMaxP p, v)+    merge (FMaxP p, v) = (p,       v)++instance (Ord prio) => Ord (Prio FstMaxPolicy (prio, val)) where+    compare (FMaxP x) (FMaxP y) = compare y x++instance (Read prio) => Read (Prio FstMaxPolicy (prio, val)) where+    readPrec     = fmap FMaxP readPrec+    readListPrec = fmap (fmap FMaxP) readListPrec++instance (Show prio) => Show (Prio FstMaxPolicy (prio, val)) where+    show        = show . unFMaxP+    showsPrec d = showsPrec d . unFMaxP+    showList    = showList . (fmap unFMaxP)++-- | 'split' a function on @item@s to one on priority-value pairs.+splitF :: (HeapItem pol item) => (item -> a) -> (Prio pol item, Val pol item) -> a+splitF f pv = f (merge pv)+{-# INLINE splitF #-}+{-# RULES "splitF/split" forall f x. splitF f (split x) = f x #-}
Setup.lhs view
@@ -1,6 +1,6 @@ #! /usr/bin/env runhaskell -> module Main where+> module Main ( main ) where > > import Distribution.Simple >
+ Test.hs view
@@ -0,0 +1,19 @@+module Main where++import Control.Exception ( assert )+import qualified Test.Heap as Heap+import qualified Test.Heap.Internal as Internal+import qualified Test.Heap.Item as Item+import Test.QuickCheck++main :: IO ()+main = do+    putStrLn "Ensuring assertions are not ignored:"+    result <- quickCheckWithResult (Args Nothing 1 1 1) $ expectFailure (assert False True)+    putStrLn ""+    case result of+        (Success _) -> do+            putStrLn "Tests for Data.Heap.Internal:" >> Internal.runTests >> putStrLn ""+            putStrLn "Tests for Data.Heap.Item:"     >> Item.runTests     >> putStrLn ""+            putStrLn "Tests for Data.Heap:"          >> Heap.runTests+        _           -> return ()
− Test.lhs 
@@ -1,11 +0,0 @@-#! /usr/bin/runghc -D__DEBUG__-->-> module Main where->-> import Test.Heap->-> main :: IO ()-> main = testHeap->-
Test/Heap.hs view
@@ -1,138 +1,90 @@+{-# LANGUAGE FlexibleContexts #-}+ module Test.Heap-    ( testHeap+    ( runTests     ) where -import Data.Heap as Heap-import Data.List as List-import Test.QuickCheck--testHeap :: IO ()-testHeap = do-    qc "Leftist property of MinHeap Int" (leftistHeapProperty :: MinHeap Int -> Bool)-    qc "Leftist property of MaxHeap Int" (leftistHeapProperty :: MaxHeap Int -> Bool)-    qc "Size property" sizeProperty-    qc "Order property" orderProperty-    qc "head/tail property" headTailProperty-    qc "take/drop/splitAt" (takeDropSplitAtProperty :: Int -> MinHeap Int -> Bool)-    qc "takeWhile/span/break" takeWhileSpanBreakProperty-    qc "read . show === id" (readShowProperty :: MinHeap Int -> Bool)-    qc "{from,to}{,Asc,Desc}List" (listProperty :: [Int] -> Bool)-    qc "toList === elems" (toListProperty :: MaxHeap Int -> Bool)-    qc "partition and filter" (partitionFilterProperty testProperty :: MinHeap Int -> Bool)-    qc "ordering property" (orderingProperty :: MinHeap Int -> MinHeap Int -> Bool)-    where-    testProperty x = x `mod` 2 == 0+import Data.Char+import Data.Heap+import Prelude hiding ( break, null, span, splitAt )+import Test.Heap.Common+import Test.Heap.Internal hiding ( runTests )+import Test.Heap.Item () -qc :: (Testable prop) => String -> prop -> IO ()-qc msg prop = quickCheck-    $ whenFail (putStrLn msg)-    $ label msg prop+runTests :: IO ()+runTests = do+    qc "list conversions for MinHeap" (listProperty :: MinHeap Int -> Bool)+    qc "list conversions for MaxHeap" (listProperty :: MaxHeap Int -> Bool)+    qc "list conversions for MinPrioHeap" (listProperty :: MinPrioHeap Int Char -> Bool)+    qc "list conversions for MaxPrioHeap" (listProperty :: MaxPrioHeap Int Char -> Bool) -instance (Arbitrary a, HeapPolicy p a) => Arbitrary (Heap p a) where-    arbitrary = do-        len  <- choose (0, 100)-        list <- vector len-        return (Heap.fromList list)+    qc "view for MinHeap" (headTailViewProperty :: MinHeap Int -> Bool)+    qc "view for MaxHeap" (headTailViewProperty :: MaxHeap Int -> Bool)+    qc "view for MinPrioHeap" (headTailViewProperty :: MinPrioHeap Int Char -> Bool)+    qc "view for MaxPrioHeap" (headTailViewProperty :: MaxPrioHeap Int Char -> Bool) -leftistHeapProperty :: (HeapPolicy p a) => Heap p a -> Bool-leftistHeapProperty Empty                     = True-leftistHeapProperty h@(Tree r s x left right) = let-    leftRank  = rank left-    rightRank = rank right-    in-    (maybe True (\(lHead, _) -> LT /= heapCompare (policy h) lHead x) (view left))-        && (maybe True (\(rHead, _) -> LT /= heapCompare (policy h) rHead x) (view right))-        && r == 1 + rightRank              -- rank == length of right spine-        && leftRank >= rightRank           -- leftist property-        && s == 1 + size left + size right -- check size-        && leftistHeapProperty left-        && leftistHeapProperty right+    qc "partition for MinHeap" (partitionProperty even :: MinHeap Int -> Bool)+    qc "partition for MaxHeap" (partitionProperty even :: MaxHeap Int -> Bool)+    qc "partition for MinPrioHeap" (partitionProperty testProp :: MinPrioHeap Int Char -> Bool)+    qc "partition for MaxPrioHeap" (partitionProperty testProp :: MaxPrioHeap Int Char -> Bool) -sizeProperty :: Int -> Bool-sizeProperty n = let-    n' = abs n `mod` 100-    h  = Heap.fromList [1..n'] :: MaxHeap Int-    in-    Heap.size h == n' && (if n' == 0 then Heap.isEmpty h && Heap.null h else True)+    qc "splitAt for MinHeap" (splitAtProperty :: Int -> MinHeap Int -> Bool)+    qc "splitAt for MaxHeap" (splitAtProperty :: Int -> MaxHeap Int -> Bool)+    qc "splitAt for MinPrioHeap" (splitAtProperty :: Int -> MinPrioHeap Int Char -> Bool)+    qc "splitAt for MaxPrioHeap" (splitAtProperty :: Int -> MaxPrioHeap Int Char -> Bool) -orderProperty :: Int -> [Int] -> Bool-orderProperty n list = let-    n'          = signum n * (n `mod` 100)-    heap        = Heap.fromList list :: MaxHeap Int-    (a,  b)     = List.splitAt n' (sortBy (heapCompare (policy heap)) list)-    (a', heap') = Heap.splitAt n' heap-    in-    (Heap.fromList b == heap') && equal heap a a'+    qc "span for MinHeap" (spanProperty even :: MinHeap Int -> Bool)+    qc "span for MaxHeap" (spanProperty even :: MaxHeap Int -> Bool)+    qc "span for MinPrioHeap" (spanProperty testProp :: MinPrioHeap Int Char -> Bool)+    qc "span for MaxPrioHeap" (spanProperty testProp :: MaxPrioHeap Int Char -> Bool)     where-    equal _ [] [] = True-    equal _ _  [] = False-    equal _ [] _  = False-    equal h (x:xs) (y:ys) = EQ == heapCompare (policy h) x y && equal h xs ys--headTailProperty :: [Int] -> Bool-headTailProperty []   = True-headTailProperty list = let-    heap  = fromList list :: MaxHeap Int-    list' = sortBy (heapCompare (policy heap)) list-    in case view heap of-        Nothing      -> False -- list is not empty-        Just (h, hs) -> h == List.head list' && hs == (fromAscList (List.tail list'))--takeDropSplitAtProperty :: (Ord a) => Int -> MinHeap a -> Bool-takeDropSplitAtProperty n heap = let-    n'           = signum n * (n `mod` 100)-    (begin, end) = Heap.splitAt n heap-    begin'       = Heap.take n heap-    end'         = Heap.drop n heap-    in-    begin == begin' && end == end'--takeWhileSpanBreakProperty :: Int -> Int -> Bool-takeWhileSpanBreakProperty len index = let-    length'      = abs (len `mod` 100)-    index'       = abs (index `mod` 100)-    xs           = [1..(max length' index')]-    heap         = Heap.fromAscList xs :: MinHeap Int-    p1 x         = x <= index'-    p2 x         = x > index'-    (xs', heap') = Heap.span p1 heap-    in-    xs' == Heap.takeWhile p1 heap-        && heap' == Heap.dropWhile p1 heap-        && (xs', heap') == Heap.break p2 heap--readShowProperty :: (HeapPolicy p a, Show a, Read a) => Heap p a -> Bool-readShowProperty heap = heap == read (show heap)+    testProp :: (Int, Char) -> Bool+    testProp (i, c) = even i /= isLetter c -listProperty :: [Int] -> Bool-listProperty xs = let-    xsAsc  = sort xs-    xsDesc = reverse xsAsc-    h1     = fromList xs         :: MinHeap Int-    h2     = fromAscList xsAsc   :: MinHeap Int-    h3     = fromDescList xsDesc :: MinHeap Int-    in-    (h1 == h2) && (h2 == h3)-        && (and (map leftistHeapProperty [h1, h2, h3]))-        && (and (map ((== xsAsc) . toAscList) [h1, h2, h3]))-        && (and (map ((== xsDesc) . toDescList) [h1, h2, h3]))+listProperty :: (HeapItem pol item, Ord (Val pol item)) => Heap pol item -> Bool+listProperty heap = let+    pairs = toList heap+    asc   = toAscList heap+    desc  = toDescList heap+    heap2 = fromList pairs+    heap3 = fromAscList asc+    heap4 = fromDescList desc+    in and (fmap leftistHeapProperty [heap2, heap3, heap4])+        && heap == heap2+        && heap == heap3+        && heap == heap4 -toListProperty :: (HeapPolicy p a, Eq a) => Heap p a -> Bool-toListProperty heap = toList heap == elems heap+headTailViewProperty :: (HeapItem pol item, Eq item, Ord (Val pol item))+    => Heap pol item -> Bool+headTailViewProperty heap = if null heap+    then isEmpty heap+        && Nothing == view heap+        && Nothing == viewHead heap+        && Nothing == viewTail heap+    else case view heap of+        Just (h, heap') -> viewHead heap == Just h && viewTail heap == Just heap'+        Nothing         -> False -partitionFilterProperty :: (HeapPolicy p a) => (a -> Bool) -> Heap p a -> Bool-partitionFilterProperty p heap = let-    (yes,  no)  = Heap.partition p heap-    (yes', no') = List.partition p (toList heap)-    in-    yes == fromList yes'-        && no == fromList no'-        && (Heap.filter p heap) == fromList yes'+partitionProperty :: (HeapItem pol item, Ord (Val pol item))+    => (item -> Bool) -> Heap pol item -> Bool+partitionProperty p heap = let+    (yes, no) = partition p heap+    in and (fmap p (toList yes))+        && and (fmap (not . p) (toList no))+        && heap == yes `union` no -orderingProperty :: (Ord a) => MinHeap a -> MinHeap a -> Bool-orderingProperty heap1 heap2 = let-    list1 = toAscList heap1-    list2 = toAscList heap2-    in-    compare heap1 heap2 == compare list1 list2+splitAtProperty :: (HeapItem pol item, Ord (Val pol item))+    => Int -> Heap pol item -> Bool+splitAtProperty n heap = let+    (before, after) = splitAt n heap+    in n < 0 || length before == n || isEmpty after+        && heap == fromAscList before `union` after +spanProperty :: (HeapItem pol item) => (item -> Bool) -> Heap pol item -> Bool+spanProperty p heap = let+    (yes, heap') = span p heap+    (no, heap'') = break p heap+    in and (fmap p yes)+        && and (fmap (not . p) no)+        && maybe True (not . p) (viewHead heap')+        && maybe True p (viewHead heap'')
+ Test/Heap/Common.hs view
@@ -0,0 +1,53 @@+module Test.Heap.Common+    ( qc+    , eqProperty, ordProperty+    , readShowProperty+    , monoidProperty+    , functorProperty+    , foldableProperty+    ) where++import Data.Foldable ( Foldable(..) )+import Data.Monoid+import Prelude hiding ( foldl, foldr )+import Test.QuickCheck++qc :: (Testable prop) => String -> prop -> IO ()+qc msg prop = quickCheck+    $ whenFail (putStrLn msg)+    $ label msg prop++eqProperty :: (Eq a) => a -> a -> a -> Bool+eqProperty x y z = (x == y) == (y == x)+    && ((not (x == y && y == z)) || x == z)++ordProperty :: (Ord a) => a -> a -> a -> Bool+ordProperty x y z = let+    _min = minimum [x, y, z]+    _max = maximum [x, y, z]+    in case compare x y of+            LT -> x < y && x <= y && not (x > y) && not (x >= y)+            EQ -> x == y && x <= y && x >= y && not (x < y) && not (x > y)+            GT -> x > y && x >= y && not (x < y) && not (x <= y)+        && _min <= x && _min <= y && _min <= z+        && _max >= x && _max >= y && _max >= z++readShowProperty :: (Read a, Show a, Eq a) => [a] -> Bool+readShowProperty x = x == read (show x)+    && (null x || head x == read (show (head x)))++monoidProperty :: (Monoid m, Eq m) => m -> m -> m -> Bool+monoidProperty m1 m2 m3 = let+    result = mconcat [m1, m2, m3]+    in+    result == (m1 `mappend` m2) `mappend` m3+        && result == m1 `mappend` (m2 `mappend` m3)+        && m1 == mempty `mappend` m1+        && m1 == m1 `mappend` mempty++functorProperty :: (Functor f, Eq (f a), Eq (f c)) => (b -> c) -> (a -> b) -> f a -> Bool+functorProperty f g fun = fun == fmap id fun+    && fmap (f . g) fun == fmap f (fmap g fun)++foldableProperty :: (Foldable f, Eq a) => f a -> Bool+foldableProperty xs = foldl (flip (:)) [] xs == reverse (foldr (:) [] xs)
+ Test/Heap/Internal.hs view
@@ -0,0 +1,127 @@+module Test.Heap.Internal+    ( runTests+    , leftistHeapProperty+    ) where++import Data.Char+import Data.Heap.Internal as Heap+import qualified Data.List as List+import Test.Heap.Common+import Test.QuickCheck++runTests :: IO ()+runTests = do+    qc "Eq" (eqProperty :: HeapT Int Char -> HeapT Int Char -> HeapT Int Char -> Bool)+    qc "Ord" (ordProperty :: HeapT Int Char -> HeapT Int Char -> HeapT Int Char -> Bool)+    qc "leftist heap" (leftistHeapProperty :: HeapT Int Char -> Bool)+    qc "read/show" (readShowProperty :: [HeapT Int Char] -> Bool)+    qc "Monoid" (monoidProperty :: HeapT Int Char -> HeapT Int Char -> HeapT Int Char -> Bool)+    qc "union" (unionProperty :: HeapT Int Char -> HeapT Int Char -> Bool)+    qc "Functor" (functorProperty (subtract 1000) (*42) :: HeapT Char Int -> Bool)+    qc "fmap" (fmapProperty (subtract 1000) :: HeapT Char Int -> Bool)+    qc "Foldable" (foldableProperty :: HeapT Char Int -> Bool)+    qc "size" sizeProperty+    qc "view" viewProperty+    qc "singleton" (singletonProperty :: Char -> Int -> Bool)+    qc "partition" (partitionProperty testProp :: HeapT Char Int -> Bool)+    qc "splitAt" splitAtProperty+    qc "span" spanProperty+    qc "fromList/toList" (listProperty :: [Char] -> Bool)+    qc "fromDescList/toAscList" (sortedListProperty :: [Char] -> Bool)+    where+    testProp :: Char -> Int -> Bool+    testProp c i = even i && isLetter c++instance (Arbitrary prio, Arbitrary val, Ord prio) => Arbitrary (HeapT prio val) where+    arbitrary = fmap (fromList . take 100) arbitrary+    shrink    = fmap fromList . shrink . toList++leftistHeapProperty :: (Ord prio) => HeapT prio val -> Bool+leftistHeapProperty Empty = True+leftistHeapProperty heap  =+    (maybe True (\(p, _, _) -> p >= _priority heap) (view (_left heap)))+        && (maybe True (\(p, _, _) -> p >= _priority heap) (view (_right heap)))+        && _rank heap == 1 + rank (_right heap)    -- rank == length of right spine+        && rank (_left heap) >= rank (_right heap) -- leftist property+        && _size heap == 1 + size (_left heap) + size (_right heap)+        && leftistHeapProperty (_left heap)+        && leftistHeapProperty (_right heap)++unionProperty :: (Ord prio, Ord val) => HeapT prio val -> HeapT prio val -> Bool+unionProperty a b = let ab = a `union` b+    in leftistHeapProperty ab && size ab == size a + size b+        && ab == ab `union` empty+        && ab == empty `union` ab+        && a == unions (fmap (uncurry singleton) (toList a))++fmapProperty :: (Ord prio) => (val -> val) -> HeapT prio val -> Bool+fmapProperty f = leftistHeapProperty . fmap f++sizeProperty :: Int -> Bool+sizeProperty n = let+    n' = abs n `mod` 100+    h  = fromList (zip [1..n'] (repeat ())) :: HeapT Int ()+    in+    size h == n' && if n' == 0 then isEmpty h else not (isEmpty h)++viewProperty :: [Int] -> Bool+viewProperty []   = True+viewProperty list = let+    heap = fromList (zip list (repeat ()))+    m    = minimum list+    in case view heap of+        Nothing          -> False -- list is not empty+        Just (p, (), hs) -> p == m+            && heap == union (singleton p ()) hs+            && viewProperty (tail list)++singletonProperty :: (Ord prio, Ord val) => prio -> val -> Bool+singletonProperty p v = let+    heap = singleton p v+    in+    leftistHeapProperty heap && size heap == 1 && view heap == Just (p, v, empty)++partitionProperty :: (Ord prio, Ord val) => (prio -> val -> Bool) -> HeapT prio val -> Bool+partitionProperty p heap = let+    (yes,  no)  = partition (uncurry p) heap+    (yes', no') = List.partition (uncurry p) (toList heap)+    in+    (heap, empty) == partition (const True) heap+        && (empty, heap) == partition (const False) heap+        && yes == fromList yes'+        && no == fromList no'+        && yes `union` no == heap -- nothing gets lost++splitAtProperty :: Int -> Int -> Bool+splitAtProperty i n = let+    i'     = i `mod` 100+    n'     = n `mod` 100+    ab     = [1..n']+    (a, b) = List.splitAt i' ab+    heap   = fromList $ zip ab (repeat ())+    in+    Heap.splitAt i' heap == (zip a (repeat ()), fromList (zip b (repeat ())))++spanProperty :: Int -> Int -> Bool+spanProperty i n = let+    i'      = i `mod` 100+    n'      = n `mod` 100+    ab      = [1..n']+    (a, b)  = List.span (<= i') ab+    (a', h) = Heap.span ((<=i') . fst) $ fromList (zip ab (repeat ()))+    in+    a == (fmap fst a') && h == fromList (zip b (repeat ()))++listProperty :: (Ord prio) => [prio] -> Bool+listProperty xs = let+    list = List.sort xs+    heap = fromList (zip xs [(1 :: Int) ..])+    in+    list == fmap fst (List.sort (toList heap))++sortedListProperty :: (Ord prio) => [prio] -> Bool+sortedListProperty xs = let+    list = List.sort xs+    heap = fromDescList (zip (reverse list) [(1 :: Int) ..])+    in+    list == fmap fst (toAscList heap)
+ Test/Heap/Item.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE FlexibleContexts #-}++module Test.Heap.Item+    ( runTests+    ) where++import Data.Heap.Item+import Test.Heap.Common+import Test.QuickCheck++runTests :: IO ()+runTests = do+    qc "Eq for MinPolicy" (eqProperty+        :: Prio MinPolicy Int -> Prio MinPolicy Int -> Prio MinPolicy Int -> Bool)+    qc "Eq for MaxPolicy" (eqProperty+        :: Prio MaxPolicy Int -> Prio MaxPolicy Int -> Prio MaxPolicy Int -> Bool)+    qc "Eq for FstMinPolicy" (eqProperty+        :: Prio FstMinPolicy (Int, Char) -> Prio FstMinPolicy (Int, Char)+        -> Prio FstMinPolicy (Int, Char) -> Bool)+    qc "Eq for FstMaxPolicy" (eqProperty+        :: Prio FstMaxPolicy (Int, Char) -> Prio FstMaxPolicy (Int, Char)+        -> Prio FstMaxPolicy (Int, Char) -> Bool)+    qc "Ord for MinPolicy" (ordProperty+        :: Prio MinPolicy Int -> Prio MinPolicy Int -> Prio MinPolicy Int -> Bool)+    qc "Ord for MaxPolicy" (ordProperty+        :: Prio MaxPolicy Int -> Prio MaxPolicy Int -> Prio MaxPolicy Int -> Bool)+    qc "Ord for FstMinPolicy" (ordProperty+        :: Prio FstMinPolicy (Int, Char) -> Prio FstMinPolicy (Int, Char)+        -> Prio FstMinPolicy (Int, Char) -> Bool)+    qc "Ord for FstMaxPolicy" (ordProperty+        :: Prio FstMaxPolicy (Int, Char) -> Prio FstMaxPolicy (Int, Char)+        -> Prio FstMaxPolicy (Int, Char) -> Bool)++    qc "read/show for MinPolicy" (readShowProperty :: [Prio MinPolicy Int] -> Bool)+    qc "read/show for MaxPolicy" (readShowProperty :: [Prio MaxPolicy Int] -> Bool)+    qc "read/show for FstMinPolicy" (readShowProperty :: [Prio FstMinPolicy (Int, Char)] -> Bool)+    qc "read/show for FstMaxPolicy" (readShowProperty :: [Prio FstMaxPolicy (Int, Char)] -> Bool)++    qc "split/merge for MinPolicy" (splitMergeProperty+        :: Prio MinPolicy Int -> Val MinPolicy Int -> Bool)+    qc "split/merge for MaxPolicy" (splitMergeProperty+        :: Prio MaxPolicy Int -> Val MaxPolicy Int -> Bool)+    qc "split/merge for FstMinPolicy" (splitMergeProperty+        :: Prio FstMinPolicy (Int, Char) -> Val FstMinPolicy (Int, Char) -> Bool)+    qc "split/merge for FstMaxPolicy" (splitMergeProperty+        :: Prio FstMaxPolicy (Int, Char) -> Val FstMaxPolicy (Int, Char) -> Bool)++    qc "priority/value for MinPolicy" (priorityValueProperty succ+        :: Prio MinPolicy Int -> Val MinPolicy Int -> Bool)+    qc "priority/value for MaxPolicy" (priorityValueProperty succ+        :: Prio MaxPolicy Int -> Val MaxPolicy Int -> Bool)+    qc "priority/value for FstMinPolicy" (priorityValueProperty succ+        :: Prio FstMinPolicy (Int, Char) -> Val FstMinPolicy (Int, Char) -> Bool)+    qc "priority/value for FstMaxPolicy" (priorityValueProperty succ+        :: Prio FstMaxPolicy (Int, Char) -> Val FstMaxPolicy (Int, Char) -> Bool)++    qc "splitF for MinPolicy" (splitFProperty (\x -> 4 * x - 7)+        :: Prio MinPolicy Int -> Val MinPolicy Int -> Bool)+    qc "splitF for MaxPolicy" (splitFProperty (\x -> 4 * x - 7)+        :: Prio MaxPolicy Int -> Val MaxPolicy Int -> Bool)+    qc "splitF for FstMinPolicy" (splitFProperty (\(x, y) -> (pred x, succ y))+        :: Prio FstMinPolicy (Int, Char) -> Val FstMinPolicy (Int, Char) -> Bool)+    qc "splitF for FstMaxPolicy" (splitFProperty (\(x, y) -> (pred x, succ y))+        :: Prio FstMaxPolicy (Int, Char) -> Val FstMaxPolicy (Int, Char) -> Bool)++instance (Arbitrary item, HeapItem pol item) => Arbitrary (Prio pol item) where+    arbitrary = fmap (fst . split) arbitrary++splitMergeProperty :: (HeapItem pol item, Eq (Prio pol item), Eq (Val pol item))+    => Prio pol item -> Val pol item -> Bool+splitMergeProperty p v = (p, v) == split (merge (p, v))++priorityValueProperty :: (HeapItem pol item, Eq (Prio pol item))+    => (Val pol item -> Val pol item) -> Prio pol item -> Val pol item -> Bool+priorityValueProperty f p v = p == fst (split (merge (p, v)))+    && p == fst (split (merge (p, f v)))++splitFProperty :: (HeapItem pol item, Eq a)+    => (item -> a) -> Prio pol item -> Val pol item -> Bool+splitFProperty f p v = f (merge (p, v)) == splitF f (p, v)
heap.cabal view
@@ -1,27 +1,55 @@- Name:                heap-Version:             0.6.0-Stability:           beta+Version:             1.0.0  Category:            Data Structures Synopsis:            Heaps in Haskell-Description:         A flexible Haskell heap implementation+Description:         A flexible Haskell implementation of minimum, maximum,+                     minimum-priority, maximum-priority and custom-ordered+                     heaps.  License:             BSD3 License-File:        LICENSE Copyright:           (c) 2008-2009, Stephan Friedrichs- Author:              Stephan Friedrichs Maintainer:          Stephan Friedrichs (deduktionstheorem at web dot de)  Build-Type:          Simple-Cabal-Version:       >= 1.2-Extra-Source-Files:  Test.lhs, Test/Heap.hs-Tested-With:         GHC, Hugs+Cabal-Version:       >= 1.2.3+Tested-With:         GHC == 6.10.2, GHC == 6.10.3 +Flag Test+  Description:       Build a binary running test cases+  Default:           False+ Library-  Build-Depends:     base-  Exposed-Modules:   Data.Heap+  Build-Depends:     base >= 3 && < 5+  Exposed-Modules:+      Data.Heap+  Other-Modules:+      Data.Heap.Internal+    , Data.Heap.Item   GHC-Options:       -Wall -fwarn-tabs-  Extensions:        CPP, EmptyDataDecls, FlexibleInstances, MultiParamTypeClasses+  Extensions:+      DeriveDataTypeable+    , EmptyDataDecls+    , FlexibleContexts+    , FlexibleInstances+    , MultiParamTypeClasses+    , TypeFamilies +Executable heap-tests+  if !flag( Test )+    Buildable:       False+  Main-Is:+      Test.hs+  Other-Modules:+      Data.Heap+    , Data.Heap.Internal+    , Data.Heap.Item+    , Test.Heap+    , Test.Heap.Common+    , Test.Heap.Internal+    , Test.Heap.Item+  Build-Depends:     QuickCheck >= 2 && < 3+  CPP-Options:       -D__TEST__+  GHC-Options:       -Wall -fwarn-tabs -fno-ignore-asserts