{-# 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 Control.Monad.Array
import Data.Tree(Tree(..))
import Data.Maybe
import Control.Monad
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
	#-}