module Data.PQueue.Prio.Internals (
MinPQueue(..),
BinomForest(..),
BinomHeap,
BinomTree(..),
Zero(..),
Succ(..),
CompF,
empty,
null,
size,
singleton,
insert,
insertBehind,
union,
getMin,
adjustMinWithKey,
updateMinWithKey,
minViewWithKey,
mapWithKey,
mapKeysMonotonic,
mapMaybeWithKey,
mapEitherWithKey,
foldrWithKey,
foldlWithKey,
insertMin,
foldrWithKeyU,
foldlWithKeyU,
traverseWithKeyU,
seqSpine,
mapForest
) where
import Control.Applicative (Applicative(..), (<$>))
import Control.Applicative.Identity (Identity(Identity, runIdentity))
import Control.DeepSeq (NFData(rnf), deepseq)
import Data.Monoid (Monoid (..))
import Prelude hiding (null)
#if __GLASGOW_HASKELL__
import Data.Data
instance (Data k, Data a, Ord k) => Data (MinPQueue k a) where
gfoldl f z m = z (foldr (uncurry' insertMin) empty) `f` foldrWithKey (curry (:)) [] m
toConstr _ = error "toConstr"
gunfold _ _ = error "gunfold"
dataTypeOf _ = mkNoRepType "Data.PQueue.Prio.Min.MinPQueue"
dataCast2 f = gcast2 f
#endif
(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
(f .: g) x y = f (g x y)
first' :: (a -> b) -> (a, c) -> (b, c)
first' f (a, c) = (f a, c)
second' :: (b -> c) -> (a, b) -> (a, c)
second' f (a, b) = (a, f b)
uncurry' :: (a -> b -> c) -> (a, b) -> c
uncurry' f (a, b) = f a b
infixr 8 .:
data MinPQueue k a = Empty | MinPQ !Int k a (BinomHeap k a)
#if __GLASGOW_HASKELL__
deriving (Typeable)
#endif
data BinomForest rk k a =
Nil |
Skip (BinomForest (Succ rk) k a) |
Cons !(BinomTree rk k a) (BinomForest (Succ rk) k a)
type BinomHeap = BinomForest Zero
data BinomTree rk k a = BinomTree k a (rk k a)
data Zero k a = Zero
data Succ rk k a = Succ !(BinomTree rk k a) (rk k a)
type CompF a = a -> a -> Bool
instance (Ord k, Eq a) => Eq (MinPQueue k a) where
MinPQ n1 k1 a1 ts1 == MinPQ n2 k2 a2 ts2 =
n1 == n2 && eqExtract k1 a1 ts1 k2 a2 ts2
Empty == Empty = True
_ == _ = False
eqExtract ::
(Ord k, Eq a) =>
k -> a -> BinomForest rk k a ->
k -> a -> BinomForest rk k a ->
Bool
eqExtract k10 a10 ts10 k20 a20 ts20 =
k10 == k20 && a10 == a20 &&
case (extract ts10, extract ts20) of
(Yes (Extract k1 a1 _ ts1'), Yes (Extract k2 a2 _ ts2'))
-> eqExtract k1 a1 ts1' k2 a2 ts2'
(No, No) -> True
_ -> False
(<>) :: Monoid m => m -> m -> m
(<>) = mappend
infixr 6 <>
instance (Ord k, Ord a) => Ord (MinPQueue k a) where
MinPQ _n1 k10 a10 ts10 `compare` MinPQ _n2 k20 a20 ts20 =
cmpExtract k10 a10 ts10 k20 a20 ts20
Empty `compare` Empty = EQ
Empty `compare` MinPQ{} = LT
MinPQ{} `compare` Empty = GT
cmpExtract ::
(Ord k, Ord a) =>
k -> a -> BinomForest rk k a ->
k -> a -> BinomForest rk k a ->
Ordering
cmpExtract k10 a10 ts10 k20 a20 ts20 =
k10 `compare` k20 <> a10 `compare` a20 <>
case (extract ts10, extract ts20) of
(Yes (Extract k1 a1 _ ts1'), Yes (Extract k2 a2 _ ts2'))
-> cmpExtract k1 a1 ts1' k2 a2 ts2'
(No, Yes{}) -> LT
(Yes{}, No) -> GT
(No, No) -> EQ
empty :: MinPQueue k a
empty = Empty
null :: MinPQueue k a -> Bool
null Empty = True
null _ = False
size :: MinPQueue k a -> Int
size Empty = 0
size (MinPQ n _ _ _) = n
singleton :: k -> a -> MinPQueue k a
singleton k a = MinPQ 1 k a Nil
insert :: Ord k => k -> a -> MinPQueue k a -> MinPQueue k a
insert = insert' (<=)
insertBehind :: Ord k => k -> a -> MinPQueue k a -> MinPQueue k a
insertBehind = insert' (<)
insert' :: CompF k -> k -> a -> MinPQueue k a -> MinPQueue k a
insert' _ k a Empty = singleton k a
insert' le k a (MinPQ n k' a' ts)
| k `le` k' = MinPQ (n+1) k a (incr le (tip k' a') ts)
| otherwise = MinPQ (n+1) k' a' (incr le (tip k a ) ts)
union :: Ord k => MinPQueue k a -> MinPQueue k a -> MinPQueue k a
union = union' (<=)
union' :: CompF k -> MinPQueue k a -> MinPQueue k a -> MinPQueue k a
union' le (MinPQ n1 k1 a1 ts1) (MinPQ n2 k2 a2 ts2)
| k1 `le` k2 = MinPQ (n1 + n2) k1 a1 (insMerge k2 a2)
| otherwise = MinPQ (n1 + n2) k2 a2 (insMerge k1 a1)
where insMerge k a = carryForest le (tip k a) ts1 ts2
union' _ Empty q2 = q2
union' _ q1 Empty = q1
getMin :: MinPQueue k a -> Maybe (k, a)
getMin (MinPQ _ k a _) = Just (k, a)
getMin _ = Nothing
adjustMinWithKey :: (k -> a -> a) -> MinPQueue k a -> MinPQueue k a
adjustMinWithKey _ Empty = Empty
adjustMinWithKey f (MinPQ n k a ts) = MinPQ n k (f k a) ts
updateMinWithKey :: Ord k => (k -> a -> Maybe a) -> MinPQueue k a -> MinPQueue k a
updateMinWithKey _ Empty = Empty
updateMinWithKey f (MinPQ n k a ts) = case f k a of
Nothing -> extractHeap (<=) n ts
Just a' -> MinPQ n k a' ts
minViewWithKey :: Ord k => MinPQueue k a -> Maybe ((k, a), MinPQueue k a)
minViewWithKey Empty = Nothing
minViewWithKey (MinPQ n k a ts) = Just ((k, a), extractHeap (<=) n ts)
mapWithKey :: (k -> a -> b) -> MinPQueue k a -> MinPQueue k b
mapWithKey f = runIdentity . traverseWithKeyU (Identity .: f)
mapKeysMonotonic :: (k -> k') -> MinPQueue k a -> MinPQueue k' a
mapKeysMonotonic _ Empty = Empty
mapKeysMonotonic f (MinPQ n k a ts) = MinPQ n (f k) a (mapKeysMonoF f (const Zero) ts)
mapMaybeWithKey :: Ord k => (k -> a -> Maybe b) -> MinPQueue k a -> MinPQueue k b
mapMaybeWithKey _ Empty = Empty
mapMaybeWithKey f (MinPQ _ k a ts) = maybe id (insert k) (f k a) (mapMaybeF (<=) f (const Empty) ts)
mapEitherWithKey :: Ord k => (k -> a -> Either b c) -> MinPQueue k a -> (MinPQueue k b, MinPQueue k c)
mapEitherWithKey _ Empty = (Empty, Empty)
mapEitherWithKey f (MinPQ _ k a ts) = either (first' . insert k) (second' . insert k) (f k a)
(mapEitherF (<=) f (const (Empty, Empty)) ts)
foldrWithKey :: Ord k => (k -> a -> b -> b) -> b -> MinPQueue k a -> b
foldrWithKey _ z Empty = z
foldrWithKey f z (MinPQ _ k0 a0 ts0) = f k0 a0 (foldF ts0) where
foldF ts = case extract ts of
Yes (Extract k a _ ts') -> f k a (foldF ts')
_ -> z
foldlWithKey :: Ord k => (b -> k -> a -> b) -> b -> MinPQueue k a -> b
foldlWithKey _ z Empty = z
foldlWithKey f z0 (MinPQ _ k0 a0 ts0) = foldF (f z0 k0 a0) ts0 where
foldF z ts = case extract ts of
Yes (Extract k a _ ts') -> foldF (f z k a) ts'
_ -> z
insertMin :: k -> a -> MinPQueue k a -> MinPQueue k a
insertMin k a Empty = MinPQ 1 k a Nil
insertMin k a (MinPQ n k' a' ts) = MinPQ (n+1) k a (incrMin (tip k' a') ts)
tip :: k -> a -> BinomTree Zero k a
tip k a = BinomTree k a Zero
meld :: CompF k -> BinomTree rk k a -> BinomTree rk k a -> BinomTree (Succ rk) k a
meld le t1@(BinomTree k1 v1 ts1) t2@(BinomTree k2 v2 ts2)
| k1 `le` k2 = BinomTree k1 v1 (Succ t2 ts1)
| otherwise = BinomTree k2 v2 (Succ t1 ts2)
mergeForest :: CompF k -> BinomForest rk k a -> BinomForest rk k a -> BinomForest rk k a
mergeForest le f1 f2 = case (f1, f2) of
(Skip ts1, Skip ts2) -> Skip (mergeForest le ts1 ts2)
(Skip ts1, Cons t2 ts2) -> Cons t2 (mergeForest le ts1 ts2)
(Cons t1 ts1, Skip ts2) -> Cons t1 (mergeForest le ts1 ts2)
(Cons t1 ts1, Cons t2 ts2) -> Skip (carryForest le (meld le t1 t2) ts1 ts2)
(Nil, _) -> f2
(_, Nil) -> f1
carryForest :: CompF k -> BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a -> BinomForest rk k a
carryForest le t0 f1 f2 = t0 `seq` case (f1, f2) of
(Cons t1 ts1, Cons t2 ts2) -> Cons t0 (carryMeld t1 t2 ts1 ts2)
(Cons t1 ts1, Skip ts2) -> Skip (carryMeld t0 t1 ts1 ts2)
(Skip ts1, Cons t2 ts2) -> Skip (carryMeld t0 t2 ts1 ts2)
(Skip ts1, Skip ts2) -> Cons t0 (mergeForest le ts1 ts2)
(Nil, _) -> incr le t0 f2
(_, Nil) -> incr le t0 f1
where carryMeld = carryForest le .: meld le
incr :: CompF k -> BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a
incr le t ts = t `seq` case ts of
Nil -> Cons t Nil
Skip ts' -> Cons t ts'
Cons t' ts' -> Skip (incr le (meld le t t') ts')
incrMin :: BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a
incrMin t@(BinomTree k a ts) tss = case tss of
Nil -> Cons t Nil
Skip tss' -> Cons t tss'
Cons t' tss' -> Skip (incrMin (BinomTree k a (Succ t' ts)) tss')
extractHeap :: CompF k -> Int -> BinomHeap k a -> MinPQueue k a
extractHeap le n ts = n `seq` case extractForest le ts of
No -> Empty
Yes (Extract k a _ ts') -> MinPQ (n1) k a ts'
data Extract rk k a = Extract k a (rk k a) (BinomForest rk k a)
data MExtract rk k a = No | Yes !(Extract rk k a)
incrExtract :: CompF k -> Maybe (BinomTree rk k a) -> Extract (Succ rk) k a -> Extract rk k a
incrExtract _ Nothing (Extract k a (Succ t ts) tss)
= Extract k a ts (Cons t tss)
incrExtract le (Just t) (Extract k a (Succ t' ts) tss)
= Extract k a ts (Skip (incr le (meld le t t') tss))
extractForest :: CompF k -> BinomForest rk k a -> MExtract rk k a
extractForest _ Nil = No
extractForest le (Skip tss) = case extractForest le tss of
No -> No
Yes ex -> Yes (incrExtract le Nothing ex)
extractForest le (Cons t@(BinomTree k a0 ts) tss) = Yes $ case extractForest le tss of
Yes ex@(Extract k' _ _ _)
| k' <? k -> incrExtract le (Just t) ex
_ -> Extract k a0 ts (Skip tss)
where
a <? b = not (b `le` a)
extract :: (Ord k) => BinomForest rk k a -> MExtract rk k a
extract = extractForest (<=)
mapForest :: (k -> a -> b) -> (rk k a -> rk k b) -> BinomForest rk k a -> BinomForest rk k b
mapForest f fCh ts0 = case ts0 of
Nil -> Nil
Skip ts' -> Skip (mapForest f fCh' ts')
Cons (BinomTree k a ts) tss
-> Cons (BinomTree k (f k a) (fCh ts)) (mapForest f fCh' tss)
where fCh' (Succ (BinomTree k a ts) tss)
= Succ (BinomTree k (f k a) (fCh ts)) (fCh tss)
mapMaybeF :: CompF k -> (k -> a -> Maybe b) -> (rk k a -> MinPQueue k b) ->
BinomForest rk k a -> MinPQueue k b
mapMaybeF le f fCh ts0 = case ts0 of
Nil -> Empty
Skip ts' -> mapMaybeF le f fCh' ts'
Cons (BinomTree k a ts) ts'
-> insF k a (fCh ts) (mapMaybeF le f fCh' ts')
where insF k a = maybe id (insert' le k) (f k a) .: union' le
fCh' (Succ (BinomTree k a ts) tss) =
insF k a (fCh ts) (fCh tss)
mapEitherF :: CompF k -> (k -> a -> Either b c) -> (rk k a -> (MinPQueue k b, MinPQueue k c)) ->
BinomForest rk k a -> (MinPQueue k b, MinPQueue k c)
mapEitherF le f0 fCh ts0 = case ts0 of
Nil -> (Empty, Empty)
Skip ts' -> mapEitherF le f0 fCh' ts'
Cons (BinomTree k a ts) ts'
-> insF k a (fCh ts) (mapEitherF le f0 fCh' ts')
where
insF k a = either (first' . insert' le k) (second' . insert' le k) (f0 k a) .:
(union' le `both` union' le)
fCh' (Succ (BinomTree k a ts) tss) =
insF k a (fCh ts) (fCh tss)
both f g (x1, x2) (y1, y2) = (f x1 y1, g x2 y2)
foldrWithKeyU :: (k -> a -> b -> b) -> b -> MinPQueue k a -> b
foldrWithKeyU _ z Empty = z
foldrWithKeyU f z (MinPQ _ k a ts) = f k a (foldrWithKeyF_ f (const id) ts z)
foldlWithKeyU :: (b -> k -> a -> b) -> b -> MinPQueue k a -> b
foldlWithKeyU _ z Empty = z
foldlWithKeyU f z0 (MinPQ _ k0 a0 ts) = foldlWithKeyF_ (\ k a z -> f z k a) (const id) ts (f z0 k0 a0)
traverseWithKeyU :: Applicative f => (k -> a -> f b) -> MinPQueue k a -> f (MinPQueue k b)
traverseWithKeyU _ Empty = pure Empty
traverseWithKeyU f (MinPQ n k a ts) = MinPQ n k <$> f k a <*> traverseForest f (const (pure Zero)) ts
traverseForest :: (Applicative f) => (k -> a -> f b) -> (rk k a -> f (rk k b)) -> BinomForest rk k a -> f (BinomForest rk k b)
traverseForest f fCh ts0 = case ts0 of
Nil -> pure Nil
Skip ts' -> Skip <$> traverseForest f fCh' ts'
Cons (BinomTree k a ts) tss
-> Cons <$> (BinomTree k <$> f k a <*> fCh ts) <*> traverseForest f fCh' tss
where
fCh' (Succ (BinomTree k a ts) tss)
= Succ <$> (BinomTree k <$> f k a <*> fCh ts) <*> fCh tss
foldrWithKeyF_ :: (k -> a -> b -> b) -> (rk k a -> b -> b) -> BinomForest rk k a -> b -> b
foldrWithKeyF_ f fCh ts0 z0 = case ts0 of
Nil -> z0
Skip ts' -> foldrWithKeyF_ f fCh' ts' z0
Cons (BinomTree k a ts) ts'
-> f k a (fCh ts (foldrWithKeyF_ f fCh' ts' z0))
where
fCh' (Succ (BinomTree k a ts) tss) z =
f k a (fCh ts (fCh tss z))
foldlWithKeyF_ :: (k -> a -> b -> b) -> (rk k a -> b -> b) -> BinomForest rk k a -> b -> b
foldlWithKeyF_ f fCh ts0 = case ts0 of
Nil -> id
Skip ts' -> foldlWithKeyF_ f fCh' ts'
Cons (BinomTree k a ts) ts'
-> foldlWithKeyF_ f fCh' ts' . fCh ts . f k a
where
fCh' (Succ (BinomTree k a ts) tss) =
fCh tss . fCh ts . f k a
mapKeysMonoF :: (k -> k') -> (rk k a -> rk k' a) -> BinomForest rk k a -> BinomForest rk k' a
mapKeysMonoF f fCh ts0 = case ts0 of
Nil -> Nil
Skip ts' -> Skip (mapKeysMonoF f fCh' ts')
Cons (BinomTree k a ts) ts'
-> Cons (BinomTree (f k) a (fCh ts)) (mapKeysMonoF f fCh' ts')
where
fCh' (Succ (BinomTree k a ts) tss) =
Succ (BinomTree (f k) a (fCh ts)) (fCh tss)
seqSpine :: MinPQueue k a -> b -> b
seqSpine Empty z0 = z0
seqSpine (MinPQ _ _ _ ts0) z0 = ts0 `seqSpineF` z0 where
seqSpineF :: BinomForest rk k a -> b -> b
seqSpineF ts z = case ts of
Nil -> z
Skip ts' -> seqSpineF ts' z
Cons _ ts' -> seqSpineF ts' z
class NFRank rk where
rnfRk :: (NFData k, NFData a) => rk k a -> ()
instance NFRank Zero where
rnfRk _ = ()
instance NFRank rk => NFRank (Succ rk) where
rnfRk (Succ t ts) = t `deepseq` rnfRk ts
instance (NFData k, NFData a, NFRank rk) => NFData (BinomTree rk k a) where
rnf (BinomTree k a ts) = k `deepseq` a `deepseq` rnfRk ts
instance (NFData k, NFData a, NFRank rk) => NFData (BinomForest rk k a) where
rnf Nil = ()
rnf (Skip tss) = rnf tss
rnf (Cons t tss) = t `deepseq` rnf tss
instance (NFData k, NFData a) => NFData (MinPQueue k a) where
rnf Empty = ()
rnf (MinPQ _ k a ts) = k `deepseq` a `deepseq` rnf ts