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 :: !Int, treeMin :: e, _subForest :: [RkTree e]}
data FQueue e = FQueue {elts, _maxRank :: !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
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)
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 !Int [RkTree e]
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)
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 (np) ts2
intLog :: Int -> Int
intLog 0 = 0
intLog 1 = 0
intLog (I# x) = 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#