PHeap.hs

{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-}
{-# OPTIONS -fno-liberate-case #-}

{- |
This module implements the functionality of a /monoid queue/, which is essentially a priority queue that merges values with equal keys.  
Several implementations were considered:

* A pairing heap which, as part of its merging operation, merges any identical-keyed values it encounters.
	This may result in partial merging of equal-keyed values for several different keys during a single 
	delete-min operation, decreasing the number of nodes in the queue without costing any additional 
	comparisons (and -- since the merged values are stored lazily -- the actual merged value is not computed
	until it actually gets demanded).  Various specialized implementations of bulk merging operations are also
	possible.
* A skew heap constructed along the same lines: an extremely simple, vanilla implementation of a heap fundamentally
	based on its merge operation, modified appropriately.
* A considerably simpler bootstrap on a vanilla @PQueue@, which keeps the totally merged value associated with its very minimum key and performs no partial merging until a
	key becomes the minimum. (The fact that no partial merging is performed allows an optimized and balanced 'mconcat' to be used on all the values associated with a key at once.)
* A simple wrapper over Data.Map, which includes a variant for every one of its methods to use a combination operation
	(i.e. sappend).

Each of these implementations are included in the Cabal distribution of queuelike.

-}
module Data.Queue.Fuse.PHeap (FusePHeap, extractSingle, replace) where

import Data.Queue.Class
import Data.Queue.QueueHelpers
import Data.Semigroup
import Data.Maybe

data PHeap k v = PH k v [PHeap k v] deriving (Show)
newtype FusePHeap k v = FPH (Point (PHeap k v)) deriving (Show, Monoid)

data Merge k v = Mrg k v [v] [PHeap k v]

extractSingle :: FusePHeap k v -> Maybe (k, v)
extractSingle (FPH (Pt (Just (PH k v [])))) = Just (k,v)
extractSingle _ = Nothing

replace :: v -> FusePHeap k v -> FusePHeap k v
replace v (FPH (Pt (Just (PH k _ ts)))) = fph (Just (PH k v ts))
replace _ h = h

instance (Ord k, Semigroup v) => Semigroup (PHeap k v) where
	sappend = mergePH
	sconcat = mergePHs
	sconcat_ = mergePHs_
	
mergePH :: (Ord k, Semigroup v) => Endo (PHeap k v)
h1@(PH k1 v1 hs1) `mergePH` h2@(PH k2 v2 hs2) = case compare k1 k2 of
	LT	-> PH k1 v1 (h2:hs1)
	EQ	-> PH k1 (v1 `sappend` v2) (hs1 ++ hs2)
	GT	-> PH k2 v2 (h1:hs2)

mergePHs :: (Ord k, Semigroup v) => [PHeap k v] -> Maybe (PHeap k v)
mergePHs [] = Nothing
mergePHs (h:hs) = Just (mergePHs_ h hs)

mergePHs_ :: (Ord k, Semigroup v) => PHeap k v -> [PHeap k v] -> PHeap k v
h@(PH k0 v0 hs0) `mergePHs_` hs = case hs of
	[]	-> h
	_	-> merger k0 v0 [] hs0 hs
	where	--{-# NOINLINE merger #-}
		{-# NOINLINE cmp #-}
		cmp = compare
		{-# NOINLINE (<<|) #-}
		(<<|) = sconcat_
		merger k0 v0 vs0 hs0 (h@(PH k v hs):hss) = case cmp k k0 of
			LT	-> merger k v [] (PH k0 (v0 <<| vs0) hs0:hs) hss
			EQ	-> merger k0 v0 (v:vs0) (hs ++ hs0) hss
			GT	-> merger k0 v0 vs0 (h:hs0) hss
		merger k v vs hs [] = PH k (v <<| vs) hs

instance (Ord k, Semigroup v) => IQueue (FusePHeap k v) where
	type QueueKey (FusePHeap k v) = (k, v)
	empty = FPH pNothing --mempty
	merge = mappend
	mergeAll = mconcat

	insertAll = mappend . fph . sconcat . map single
--	insertAll = mappend . fph . fusing . map single

	singleton = fph . Just . single
--	fromList = fph . fusing . map single
	fromList = fph . sconcat . map single

	top (FPH (Pt h)) = fmap peek' h where peek' (PH k v _) = (k, v)
	delete (FPH (Pt h)) = fmap delete' h where
		delete' (PH _ _ hs) = fph $ fusing hs

	null (FPH (Pt Nothing)) = True
	null _ = False

	toList_ (FPH (Pt h)) = maybe [] (unfoldList unHeap) h where
		unHeap (PH k v hs) = ((k, v), hs)

single :: (k, v) -> PHeap k v
single (k, v) = PH k v []

fph = FPH . Pt