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