```{-# 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#
```