PHeap2.hs

{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-}

module Data.Queue.Fuse.PHeap2 (FusePHeap, extractSingle, replace) where

import Data.Queue.Class
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 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 Functor (PHeap k) where
	fmap f (PH k v hs) = PH k (f v) (map (fmap f) hs)

instance Semigroup (Merge k v) where
	Mrg v1 vs1 qs1 `sappend` Mrg v2 vs2 qs2 = Mrg v1 (v2:vs1 ++ vs2) (qs1 ++ qs2)

merger :: (v -> v -> v) -> v -> [v] -> v
merger (><) h hs = case merger' h hs of (h', hs') -> foldl (><) h' hs ; where
	merger' h [] = (h, [])
	merger' h1 (h2:hs) = (h1 >< h2, case hs of
		[]	-> []
		(h3:hs)	-> case merger' h3 hs of (h, hs) -> h:hs)

instance (Ord k, Semigroup v) => Semigroup (PHeap k v) where
	sappend = mergePH
	sconcat_ = merger mergePH
	sconcat [] = Nothing
	sconcat (h:hs) = Just (merger mergePH h hs)

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)
	--sconcat = fusePHs sconcat_

{-# NOINLINE fusePHs #-}
fusePHs :: (Ord k) => (v -> [v] -> v) -> Fusion (PHeap k v)
fusePHs scat hs = {-cmp hs `seq`-} fmap fromMrg (fusing [single (k, Mrg v [] qs) | PH k v qs <- hs]) where
	fromMrg (PH k (Mrg v vs qs) qs0) = PH k (scat v vs) (map fromMrg qs0 ++ qs)
	cmp :: Ord k => [PHeap k v] -> k -> k -> Ordering
	cmp _ = compare

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 = merge . fph . fusing . map single
	singleton = fph . Just . single
	fromList = fph . fusing . map single
	
	{-# INLINE extract #-}
	extract (FPH (Pt h)) = fmap extract' h where extract' (PH k v hs) = ((k, v), fph $ fusing hs)
--	top (FPH (Pt h)) = fmap top' h where top' (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

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

fph = FPH . Pt