module Data.Queue.PQueue (PQueue) where
import Data.Monoid
import Data.Maybe
import Control.Monad
import Data.Tree
import Data.Queue.Class
import GHC.Exts
newtype Heap e = H (Maybe (Tree e)) deriving (Read, Show)
data PQueue e = PQ !Int !(Heap e) deriving (Read, Show)
instance Ord e => Monoid (Heap e) where
mempty = H Nothing
H (Just t1) `mappend` H (Just t2) = H (Just (t1 `meld` t2))
h1 `mappend` H Nothing = h1
H Nothing `mappend` h2 = h2
mconcat hs = fuse [t | H (Just t) <- hs]
instance Ord e => Monoid (PQueue e) where
mempty = PQ 0 mempty
PQ n1 h1 `mappend` PQ n2 h2 = PQ (n1 + n2) (h1 `mappend` h2)
mconcat qs = let (n, ts) = fuser 0 [] qs in PQ n (fuse ts) where
fuser !n ts qs = case qs of
[] -> (n, ts)
(PQ m (H h):qs) -> case h of Nothing -> fuser n ts qs
Just t -> fuser (n+m) (t:ts) qs
meld :: Ord e => Tree e -> Tree e -> Tree e
t1@(Node x1 ts1) `meld` t2@(Node x2 ts2) =
if x1 > x2 then Node x2 (t1:ts2) else Node x1 (t2:ts1)
fuse :: Ord e => [Tree e] -> Heap e
fuse [] = H Nothing
fuse [t] = H (Just t)
fuse ts = fuse (fuser ts) where
fuser (x1:x2:xs) = (x1 `meld` x2) : fuser xs
fuser xs = xs
instance Ord e => Queuelike (PQueue e) e where
singleton x = PQ 1 (H (Just (Node x [])))
extract (PQ n (H h)) = fmap (\ (Node x ts) -> (x, PQ (n1) $ fuse ts)) h
isEmpty (PQ _ (H h)) = isNothing h
size (PQ n _) = n
fromList xs = mconcat (map singleton xs)
toList_ (PQ _ (H h)) = maybe [] flatten h
merge = mappend
empty = mempty
xs `insertAll` q = q `merge` fromList xs
flattenFB :: Tree a -> (a -> b -> b) -> b -> b
flattenFB (Node x ts) c n = x `c` foldr (flip flattenFB c) n ts