{-# LANGUAGE MagicHash, BangPatterns, NamedFieldPuns, ViewPatterns, FlexibleInstances, TypeFamilies, FlexibleContexts #-} {-# OPTIONS -fno-warn-overlapping-patterns -fno-warn-name-shadowing #-} {- | An alternate implementation of a priority queue based on a /Fibonacci heap/. Fibonacci heaps, while not quite as internally functional as pairing heaps, are generally less ad-hoc and may prove useful for some uses (as well as serving as a useful testbed). A Fibonacci heap can be thought of as a lazier binomial heap, designed to better take advantage of the fact that in a lazy language a series of modification operations will likely all be computed at once, preferably as late as possible. The Fibonacci heap supports all 'Queuelike' operations with the same time complexity as 'PQueue'. -} module Data.Queue.FibQueue (FQueue) where import Data.Queue.Class import Control.Monad.Array import GHC.Exts import Data.Bits import Data.Maybe import Data.Monoid import Data.Ord import Control.Monad data RkTree e = RkT {treeRk :: {-# UNPACK #-} !Int, treeMin :: e, _subForest :: [RkTree e]} data FQueue e = FQueue {elts, _maxRank :: {-# UNPACK #-} !Int, heap :: [RkTree e]} instance Ord e => Queuelike (FQueue e) where type QueueKey (FQueue e) = e FQueue n1 r1 h1 `merge` FQueue n2 r2 h2 = FQueue (n1 + n2) (max r1 r2) (case (h1, h2) of (t1:_, t2:_) | comparing treeMin t1 t2 == LT -> h1 ++ h2 | otherwise -> h2 ++ h1 (_, []) -> h1 ([], _) -> h2) empty = FQueue 0 0 [] singleton x = FQueue 1 0 [RkT 0 x []] toList_ = concatMap flatten . heap size = elts peek FQueue{heap} = fmap treeMin (listToMaybe heap) delete q = do FQueue (n+1) mR (RkT _ _ ts : tss) <- return q return $ uncurry (FQueue n) $ rebuild mR (ts ++ tss) fromList ts = let n = length ts in FQueue n (intLog n) (snd $ findMin $ fromListFQ n ts) instance Ord e => Monoid (FQueue e) where mempty = empty mappend = merge mconcat = mergeAll {-# INLINE flatten #-} flatten :: RkTree e -> [e] flatten t = build (\ c n -> flatten' c t n) where flatten' c (RkT _ x ts) n = x `c` foldr (flatten' c) n ts meldTree :: Ord e => RkTree e -> RkTree e -> RkTree e t1@(RkT d x1 ts1) `meldTree` t2@(RkT _ x2 ts2) | x1 <= x2 = RkT (d+1) x1 (t2:ts1) | otherwise = RkT (d+1) x2 (t1:ts2) -- The use of the ArrayM monad here considerably increases readability and efficiency. meld :: Ord e => RkTree e -> ArrayM s (Maybe (RkTree e)) () meld t@RkT{treeRk} = ensureSize (treeRk+2) >> readAt treeRk >>= maybe (writeAt treeRk (Just t)) (\ t' -> writeAt treeRk Nothing >> meld (t `meldTree` t')) data MergeAccum e = MA {-# UNPACK #-} !Int [RkTree e] {-# INLINE findMin #-} findMin :: Ord e => [RkTree e] -> (Int, [RkTree e]) findMin ts = case foldr (getMin (comparing treeMin)) (MA 0 []) ts of MA d ls -> (d, ls) ; where getMin !cmp t1 (MA d ts) = case ts of [] -> MA (treeRk t1) [t1] (t:ts) | cmp t1 t == LT -> MA (max d (treeRk t1)) (t1:t:ts) | otherwise -> MA (max d (treeRk t1)) (t:t1:ts) {-# INLINE rebuild #-} rebuild :: Ord e => Int -> [RkTree e] -> (Int, [RkTree e]) rebuild maxRank ts = runArrayM (maxRank + 1) Nothing $ mapM_ meld ts >> liftM (\ ts' -> findMin (catMaybes ts')) askElems fromPow2List :: Ord e => Int -> [e] -> RkTree e fromPow2List n ts = meldList 1 (map (\ x -> RkT 0 x []) ts) where fuse2 (t1:t2:ts) = t1 `meldTree` t2 : fuse2 ts fuse2 ts = ts meldList p ts | p < n = meldList (p + p) (fuse2 ts) | otherwise = head ts fromListFQ :: Ord e => Int -> [e] -> [RkTree e] fromListFQ 0 _ = [] fromListFQ n ts = let p = bit (intLog n); (ts1, ts2) = splitAt p ts in fromPow2List p ts1 : fromListFQ (n-p) ts2 intLog :: Int -> Int intLog 0 = 0 intLog 1 = 0 intLog (I# x) = {-# SCC "intLog" #-} I# (intLog1 (int2Word# x)) where intLog1 x# = let ans# = uncheckedShiftRL# x# 16# in if ans# `eqWord#` 0## then intLog2 x# else 16# +# intLog2 ans# intLog2 x# = let ans# = uncheckedShiftRL# x# 8# in if ans# `eqWord#` 0## then intLog3 x# else 8# +# intLog3 ans# intLog3 x# = let ans# = uncheckedShiftRL# x# 4# in if ans# `eqWord#` 0## then intLog4 x# else 4# +# intLog4 ans# intLog4 x# = let ans# = uncheckedShiftRL# x# 2# in if ans# `eqWord#` 0## then intLog5 x# else 2# +# intLog5 ans# intLog5 x# = if x# `leWord#` 1## then 0# else 1#