-- | -- Module : Data.Edison.Coll.MinHeap -- Copyright : Copyright (c) 1999, 2008 Chris Okasaki -- License : MIT; see COPYRIGHT file for terms and conditions -- -- Maintainer : robdockins AT fastmail DOT fm -- Stability : stable -- Portability : GHC, Hugs (MPTC and FD) -- -- A generic adaptor for bags to keep the minimum element separately. module Data.Edison.Coll.MinHeap ( -- * Min heap adaptor type Min, -- instance of Coll/CollX, OrdColl/OrdCollX -- * CollX operations empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll, deleteSeq,null,size,member,count,strict,structuralInvariant, -- * Coll operations toSeq, lookup, lookupM, lookupAll, lookupWithDefault, fold, fold', fold1, fold1', filter, partition, strictWith, -- * OrdCollX operations deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq, unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE, partitionLE_GT,partitionLT_GT, -- * OrdColl operations minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl', foldr1,foldr1',foldl1,foldl1',toOrdSeq, unsafeMapMonotonic, -- * Other supported operations toColl,fromColl, -- * Documentation moduleName ) where import Prelude hiding (null,foldr,foldl,foldr1,foldl1,lookup,filter) import qualified Data.Edison.Coll as C import qualified Data.Edison.Seq as S import Data.Edison.Coll.Defaults import Data.Edison.Seq.Defaults (tokenMatch,maybeParens) import Data.Monoid import Control.Monad import Test.QuickCheck data Min h a = E | M a h deriving (Eq) moduleName :: String moduleName = "Data.Edison.Coll.MinHeap" structuralInvariant :: (Ord a,C.OrdColl h a) => Min h a -> Bool structuralInvariant E = True structuralInvariant (M x h) = if C.null h then True else x <= C.minElem h empty :: Min h a singleton :: (C.CollX h a,Ord a) => a -> Min h a fromSeq :: (C.OrdColl h a,Ord a,S.Sequence s) => s a -> Min h a insert :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a insertSeq :: (C.OrdColl h a,Ord a,S.Sequence s) => s a -> Min h a -> Min h a union :: (C.OrdCollX h a,Ord a) => Min h a -> Min h a -> Min h a unionSeq :: (C.OrdColl h a,Ord a,S.Sequence s) => s (Min h a) -> Min h a delete :: (C.OrdColl h a,Ord a) => a -> Min h a -> Min h a deleteAll :: (C.OrdColl h a,Ord a) => a -> Min h a -> Min h a deleteSeq :: (C.OrdColl h a,Ord a,S.Sequence s) => s a -> Min h a -> Min h a null :: Min h a -> Bool size :: C.CollX h a => Min h a -> Int member :: (C.CollX h a,Ord a) => a -> Min h a -> Bool count :: (C.CollX h a,Ord a) => a -> Min h a -> Int strict :: (C.CollX h a,Ord a) => Min h a -> Min h a toSeq :: (C.Coll h a,S.Sequence s) => Min h a -> s a lookup :: (C.Coll h a,Ord a) => a -> Min h a -> a lookupM :: (C.Coll h a,Ord a,Monad m) => a -> Min h a -> m a lookupAll :: (C.Coll h a,Ord a,S.Sequence s) => a -> Min h a -> s a lookupWithDefault :: (C.Coll h a,Ord a) => a -> a -> Min h a -> a fold :: (C.Coll h a) => (a -> b -> b) -> b -> Min h a -> b fold1 :: (C.Coll h a) => (a -> a -> a) -> Min h a -> a fold' :: (C.Coll h a) => (a -> b -> b) -> b -> Min h a -> b fold1' :: (C.Coll h a) => (a -> a -> a) -> Min h a -> a filter :: (C.OrdColl h a) => (a -> Bool) -> Min h a -> Min h a partition :: (C.OrdColl h a) => (a -> Bool) -> Min h a -> (Min h a, Min h a) strictWith :: (C.OrdColl h a) => (a -> b) -> Min h a -> Min h a deleteMin :: (C.OrdColl h a,Ord a) => Min h a -> Min h a deleteMax :: (C.OrdCollX h a,Ord a) => Min h a -> Min h a unsafeInsertMin :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a unsafeInsertMax :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a unsafeFromOrdSeq :: (C.OrdCollX h a,Ord a,S.Sequence s) => s a -> Min h a unsafeAppend :: (C.OrdCollX h a,Ord a) => Min h a -> Min h a -> Min h a filterLT :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a filterLE :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a filterGT :: (C.OrdColl h a,Ord a) => a -> Min h a -> Min h a filterGE :: (C.OrdColl h a,Ord a) => a -> Min h a -> Min h a partitionLT_GE :: (C.OrdColl h a,Ord a) => a -> Min h a -> (Min h a, Min h a) partitionLE_GT :: (C.OrdColl h a,Ord a) => a -> Min h a -> (Min h a, Min h a) partitionLT_GT :: (C.OrdColl h a,Ord a) => a -> Min h a -> (Min h a, Min h a) minView :: (C.OrdColl h a,Ord a,Monad m) => Min h a -> m (a, Min h a) minElem :: (C.OrdColl h a,Ord a) => Min h a -> a maxView :: (C.OrdColl h a,Ord a,Monad m) => Min h a -> m (a, Min h a) maxElem :: (C.OrdColl h a,Ord a) => Min h a -> a foldr :: (C.OrdColl h a,Ord a) => (a -> b -> b) -> b -> Min h a -> b foldl :: (C.OrdColl h a,Ord a) => (b -> a -> b) -> b -> Min h a -> b foldr1 :: (C.OrdColl h a,Ord a) => (a -> a -> a) -> Min h a -> a foldl1 :: (C.OrdColl h a,Ord a) => (a -> a -> a) -> Min h a -> a foldr' :: (C.OrdColl h a,Ord a) => (a -> b -> b) -> b -> Min h a -> b foldl' :: (C.OrdColl h a,Ord a) => (b -> a -> b) -> b -> Min h a -> b foldr1' :: (C.OrdColl h a,Ord a) => (a -> a -> a) -> Min h a -> a foldl1' :: (C.OrdColl h a,Ord a) => (a -> a -> a) -> Min h a -> a toOrdSeq :: (C.OrdColl h a,Ord a,S.Sequence s) => Min h a -> s a unsafeMapMonotonic :: (C.OrdColl h a,Ord a) => (a -> a) -> Min h a -> Min h a fromColl :: C.OrdColl h a => h -> Min h a fromColl = fromPrim toColl :: C.OrdColl h a => Min h a -> h toColl = toPrim fromPrim :: (C.OrdColl c a) => c -> Min c a fromPrim xs = case C.minView xs of Nothing -> E Just (x, xs') -> M x xs' toPrim :: (C.OrdCollX c a) => Min c a -> c toPrim E = C.empty toPrim (M x xs) = C.unsafeInsertMin x xs empty = E singleton x = M x C.empty fromSeq = fromPrim . C.fromSeq insert x E = M x C.empty insert x (M y xs) | x <= y = M x (C.unsafeInsertMin y xs) | otherwise = M y (C.insert x xs) insertSeq xs E = fromSeq xs insertSeq xs (M y ys) = case C.minView xs_ys of Nothing -> M y C.empty Just (x, rest) | x < y -> M x (C.insert y rest) | otherwise -> M y xs_ys where xs_ys = C.insertSeq xs ys union E ys = ys union xs E = xs union (M x xs) (M y ys) | x <= y = M x (C.union xs (C.unsafeInsertMin y ys)) | otherwise = M y (C.union (C.unsafeInsertMin x xs) ys) unionSeq = unionSeqUsingReduce delete _ E = E delete x m@(M y ys) | x > y = M y (C.delete x ys) | x == y = fromPrim ys | otherwise = m deleteAll _ E = E deleteAll x m@(M y ys) | x > y = M y (C.deleteAll x ys) | x == y = fromPrim (C.deleteAll x ys) | otherwise = m deleteSeq = deleteSeqUsingDelete null E = True null (M _ _) = False size E = 0 size (M _ xs) = 1 + C.size xs member _ E = False member x (M y ys) | x > y = C.member x ys | otherwise = (x == y) count _ E = 0 count x (M y ys) | x > y = C.count x ys | x == y = 1 + C.count x ys | otherwise = 0 toSeq E = S.empty toSeq (M x xs) = S.lcons x (C.toSeq xs) lookup x (M y ys) | x > y = C.lookup x ys | x == y = y lookup _ _ = error "MinHeap.lookup: empty heap" lookupM x (M y ys) | x > y = C.lookupM x ys | x == y = return y lookupM _ _ = fail "lookupM.lookup: XXX" lookupAll x (M y ys) | x > y = C.lookupAll x ys | x == y = S.lcons y (C.lookupAll x ys) lookupAll _ _ = S.empty lookupWithDefault d x (M y ys) | x > y = C.lookupWithDefault d x ys | x == y = y lookupWithDefault d _ _ = d fold _ e E = e fold f e (M x xs) = f x (C.fold f e xs) fold' _ e E = e fold' f e (M x xs) = f x $! (C.fold' f e xs) fold1 _ E = error "MinHeap.fold1: empty heap" fold1 f (M x xs) = C.fold f x xs fold1' _ E = error "MinHeap.fold1': empty heap" fold1' f (M x xs) = C.fold' f x xs filter _ E = E filter p (M x xs) | p x = M x (C.filter p xs) | otherwise = fromPrim (C.filter p xs) partition _ E = (E, E) partition p (M x xs) | p x = (M x ys, fromPrim zs) | otherwise = (fromPrim ys, M x zs) where (ys,zs) = C.partition p xs deleteMin E = E deleteMin (M _ xs) = fromPrim xs deleteMax E = E deleteMax (M x xs) | C.null xs = E | otherwise = M x (C.deleteMax xs) unsafeInsertMin x xs = M x (toPrim xs) unsafeInsertMax x E = M x C.empty unsafeInsertMax x (M y ys) = M y (C.unsafeInsertMax x ys) unsafeFromOrdSeq xs = case S.lview xs of Nothing -> E Just (x,xs') -> M x (C.unsafeFromOrdSeq xs') unsafeAppend E ys = ys unsafeAppend (M x xs) ys = M x (C.unsafeAppend xs (toPrim ys)) filterLT x (M y ys) | y < x = M y (C.filterLT x ys) filterLT _ _ = E filterLE x (M y ys) | y <= x = M y (C.filterLE x ys) filterLE _ _ = E filterGT x (M y ys) | y <= x = fromPrim (C.filterGT x ys) filterGT _ h = h filterGE x (M y ys) | y < x = fromPrim (C.filterGE x ys) filterGE _ h = h partitionLT_GE x (M y ys) | y < x = (M y lows, fromPrim highs) where (lows,highs) = C.partitionLT_GE x ys partitionLT_GE _ h = (E, h) partitionLE_GT x (M y ys) | y <= x = (M y lows, fromPrim highs) where (lows,highs) = C.partitionLE_GT x ys partitionLE_GT _ h = (E, h) partitionLT_GT x (M y ys) | y < x = let (lows,highs) = C.partitionLT_GT x ys in (M y lows, fromPrim highs) | y == x = (E, fromPrim (C.filterGT x ys)) partitionLT_GT _ h = (E, h) minView E = fail "MinHeap.minView: empty heap" minView (M x xs) = return (x, fromPrim xs) minElem E = error "MinHeap.minElem: empty heap" minElem (M x _) = x maxView E = fail "MinHeap.maxView: empty heap" maxView (M x xs) = case C.maxView xs of Nothing -> return (x, E) Just (y,ys) -> return (y, M x ys) maxElem E = error "MinHeap.minElem: empty heap" maxElem (M x xs) | C.null xs = x | otherwise = C.maxElem xs foldr _ e E = e foldr f e (M x xs) = f x (C.foldr f e xs) foldr' _ e E = e foldr' f e (M x xs) = f x $! (C.foldr' f e xs) foldl _ e E = e foldl f e (M x xs) = C.foldl f (f e x) xs foldl' _ e E = e foldl' f e (M x xs) = e `seq` C.foldl' f (f e x) xs foldr1 _ E = error "MinHeap.foldr1: empty heap" foldr1 f (M x xs) | C.null xs = x | otherwise = f x (C.foldr1 f xs) foldr1' _ E = error "MinHeap.foldr1': empty heap" foldr1' f (M x xs) | C.null xs = x | otherwise = f x $! (C.foldr1' f xs) foldl1 _ E = error "MinHeap.foldl1: empty heap" foldl1 f (M x xs) = C.foldl f x xs foldl1' _ E = error "MinHeap.foldl1': empty heap" foldl1' f (M x xs) = C.foldl' f x xs toOrdSeq E = S.empty toOrdSeq (M x xs) = S.lcons x (C.toOrdSeq xs) unsafeMapMonotonic = unsafeMapMonotonicUsingFoldr strict h@E = h strict h@(M _ xs) = C.strict xs `seq` h strictWith _ h@E = h strictWith f h@(M x xs) = f x `seq` C.strictWith f xs `seq` h -- instance declarations instance (C.OrdColl h a, Ord a) => C.CollX (Min h a) a where {singleton = singleton; fromSeq = fromSeq; insert = insert; insertSeq = insertSeq; unionSeq = unionSeq; delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq; null = null; size = size; member = member; count = count; strict = strict; structuralInvariant = structuralInvariant; instanceName _ = moduleName} instance (C.OrdColl h a, Ord a) => C.OrdCollX (Min h a) a where {deleteMin = deleteMin; deleteMax = deleteMax; unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax; unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; filterLT = filterLT; filterLE = filterLE; filterGT = filterGT; filterGE = filterGE; partitionLT_GE = partitionLT_GE; partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT} instance (C.OrdColl h a, Ord a) => C.Coll (Min h a) a where {toSeq = toSeq; lookup = lookup; lookupM = lookupM; lookupAll = lookupAll; lookupWithDefault = lookupWithDefault; fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; filter = filter; partition = partition; strictWith = strictWith} instance (C.OrdColl h a, Ord a) => C.OrdColl (Min h a) a where {minView = minView; minElem = minElem; maxView = maxView; maxElem = maxElem; foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq; unsafeMapMonotonic = unsafeMapMonotonic} -- instance Eq is derived instance (C.OrdColl h a, Show h) => Show (Min h a) where showsPrec i xs rest | i == 0 = concat [ moduleName,".fromColl ",showsPrec 10 (toColl xs) rest] | otherwise = concat ["(",moduleName,".fromColl ",showsPrec 10 (toColl xs) (')':rest)] instance (C.OrdColl h a, Read h) => Read (Min h a) where readsPrec _ xs = maybeParens p xs where p ys = tokenMatch (moduleName++".fromColl") ys >>= readsPrec 10 >>= \(coll,rest) -> return (fromColl coll,rest) instance (C.OrdColl h a,Arbitrary h,Arbitrary a) => Arbitrary (Min h a) where arbitrary = do xs <- arbitrary x <- arbitrary i <- arbitrary :: Gen Int return (if C.null xs || x <= C.minElem xs then M x xs else if odd i then M (C.minElem xs) xs else fromPrim xs) coarbitrary E = variant 0 coarbitrary (M x xs) = variant 1 . coarbitrary x . coarbitrary xs instance (C.OrdColl h a) => Monoid (Min h a) where mempty = empty mappend = union mconcat = unionSeq instance (Eq h, C.OrdColl h a) => Ord (Min h a) where compare = compareUsingToOrdList