```{-# LANGUAGE RankNTypes, ViewPatterns, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ImpredicativeTypes #-}
{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}

{- |
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 Data.Tree(Tree(..))
import Data.Maybe
import GHC.Exts(build)
import Prelude hiding (getContents)

data Rk e = Rk {rk :: {-# UNPACK #-} !Int, lab :: e}
type RkTree e = Tree (Rk e)
data FQueue e = FQueue {elts :: {-# UNPACK #-} !Int, maxRank :: {-# UNPACK #-} !Int, heap :: [RkTree e]}

instance Ord e => Queuelike (FQueue e) e where
FQueue n1 r1 h1 `merge` FQueue n2 r2 h2 = FQueue (n1 + n2) (max r1 r2) (case (h1, h2) of
((treeMin -> x1):_, (treeMin -> x2):_) -> if x1 <= x2 then h1 ++ h2 else h2 ++ h1
(_, [])	-> h1
([], _)	-> h2)
empty = FQueue 0 0 []
singleton x = FQueue 1 0 [Node (Rk 0 x) []]
toList_ = concatMap (map lab . flatten) . heap
size = elts
peek = liftM treeMin . listToMaybe . heap
delete (FQueue n mR (Node (Rk _ x) ts : tss)) = Just \$ rebuild (MA (n-1) mR (mapM_ meld tss >> mapM_ meld ts))
delete _ = Nothing

treeMin :: RkTree e -> e
treeMin (Node (Rk _ x) _) = x

{-# INLINE flatten #-}
flatten :: Tree e -> [e]
flatten t = build (\ c n -> flatten' c t n) where
flatten' c (Node x ts) n = x `c` foldr (flatten' c) n ts

meldTree :: Ord e => RkTree e -> RkTree e -> RkTree e
t1@(Node (Rk d x1) ts1) `meldTree` t2@(Node (Rk _ x2) ts2)
| x1 <= x2	= Node (Rk (d+1) x1) (t2:ts1)
| otherwise	= Node (Rk (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@(rk . rootLabel -> d) =
ensureSize (d+2) >> readAt d >>= maybe (writeAt d (Just t)) (\ t' -> writeAt d Nothing >> meld (t `meldTree` t'))

extractMin :: Ord e => [Maybe (RkTree e)] -> (Int, [RkTree e])
extractMin ls = case foldr exM (Nothing, 0, []) ls of (mi, rk, ts) -> maybe (0, []) ((,) rk . (:ts)) mi ; where
exM Nothing p = p
exM (Just t@(Node (Rk d x) _)) (mi, rk, ts) = let rk' = max d rk in maybe (Just t, rk', ts)
(\ t'@(lab . rootLabel -> y) -> if x <= y then (Just t, rk', t':ts) else (Just t', rk', t:ts)) mi

rebuild :: Ord e => MergeAccum e -> FQueue e
rebuild (MA n mR melder) = runArrayM mR Nothing \$ melder >> liftM ((\ (mR', h') -> FQueue n mR' h') . extractMin) getContents

data MergeAccum e = MA {-# UNPACK #-} !Int {-# UNPACK #-} !Int (forall s . ArrayM s (Maybe (RkTree e)) ())

{-# INLINE mergeAllFH #-}
mergeAllFH :: Ord e => [FQueue e] -> FQueue e
mergeAllFH qs = rebuild (foldr merger (MA 0 0 (return ())) qs) where
merger :: Ord e => FQueue e -> MergeAccum e -> MergeAccum e
merger (FQueue n r ts) (MA m mR toMerge) = MA (n+m) (max r mR) (mapM_ meld ts >> toMerge)

{-# RULES
"mergeAll/FibHeap" forall (ts :: Ord e => [FQueue e]) . mergeAll ts = mergeAllFH ts
#-}
```