{-# 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 Data.Queue.QueueHelpers(order)
import Control.Monad.Array

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 FForest e = FF {_maxRk :: {-# UNPACK #-} !Int, trees :: [RkTree e]}	
data FQueue e = FQ {elts :: {-# UNPACK #-} !Int, forest :: {-# UNPACK #-} !(FForest e)}

instance Ord e => Monoid (FQueue e) where
	mempty = FQ 0 emptyFF
	FQ n1 f1 `mappend` FQ n2 f2 = FQ (n1 + n2) (f1 `mergeFF` f2)

emptyFF :: FForest e
emptyFF = FF 0 []

singleFF :: RkTree e -> FForest e
singleFF t@RkT{treeRk} = FF treeRk [t]

{-# INLINE mergeFF #-}
mergeFF :: Ord e => FForest e -> FForest e -> FForest e
FF r1 ts1 `mergeFF` FF r2 ts2 = let (f1, f2) = order cmp ts1 ts2 in
		FF (r1 `max` r2) (f1 ++ f2)
	where	(t1:_) `cmp` (t2:_) = comparing treeMin t1 t2
		[] `cmp` _ = LT
		_ `cmp` [] = GT

extractFF :: Ord e => FForest e -> Maybe (e, FForest e)
extractFF f = do	FF rk (RkT _ x ts : tss) <- return f
			return (x, rebuild $ FF rk (ts ++ tss))

instance Ord e => Queuelike (FQueue e) where
	type QueueKey (FQueue e) = e
	merge = mappend
	empty = mempty
	singleton x = FQ 1 $ singleFF (RkT 0 x [])
	toList_ FQ{forest} = concatMap flatten (trees forest)
	size = elts
	extract (FQ n f) = fmap (fmap (FQ (n-1))) (extractFF f)

{-# INLINE flatten #-}
flatten :: RkTree e -> [e]
flatten (RkT _ x ts) = [x] ++ concatMap flatten 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'))

{-# INLINE findMin #-}
findMin :: Ord e => [RkTree e] -> FForest e
findMin = foldr (mergeFF . singleFF) emptyFF

{-# INLINE rebuild #-}
rebuild :: Ord e => FForest e -> FForest e
rebuild (FF rk ts) = runArrayM (rk + 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#