SkewQueue.hs

{-# LANGUAGE NamedFieldPuns, FlexibleInstances, GeneralizedNewtypeDeriving, TypeFamilies #-}
{-# OPTIONS -fno-warn-missing-methods -fno-warn-name-shadowing #-}

{- | A standard, compact implementation of a skew queue, which offers merging, insertion, and deletion in amortized logarithmic time and size and peek-min in constant time.  Moderately less lazy than "Data.Queue.PQueue".
-}
module Data.Queue.SkewQueue (SkewQueue) where

import Data.Queue.Class
import Data.Queue.QueueHelpers

import GHC.Exts

import Data.Monoid
import Data.Ord

-- Confession: This is as much a toy implementation as anything else, due to the sheer sexy compactness with which skew queues can be implemented in Haskell, especially with the automatically provided monoid structure from QueueHelpers.  The meat of the skew queue implementation is entirely contained in the Monoid instance; everything else is deliciously brief boilerplate.

data BTree e = Tr {treeMin :: e, _left, _right :: Maybe (BTree e)}
newtype SkewQueue e = SQ (HeapQ (BTree e)) deriving (Monoid)

instance Ord e => Monoid (BTree e) where
	mappend = let t1 `meld` t2 = case order (comparing treeMin) t1 t2 of
			(Tr x l r, t') -> Tr x (endoMaybe meld r (Just t')) l
		in meld

instance Ord e => Queuelike (SkewQueue e) where
	{-# INLINE mergeAll #-}
	type QueueKey (SkewQueue e) = e

	empty = mempty
	singleton = SQ . single
	fromList xs = SQ $ fuseMerge (map single xs)

	merge = mappend
	mergeAll = mconcat

	extract (SQ (HQ n t)) = fmap (\ (Tr x l r) -> (x, SQ (HQ n (l `mappend` r)))) t
	size (SQ HQ{elts}) = elts
	toList_ (SQ HQ{heap}) = flatten heap

single :: e -> HeapQ (BTree e)
single x =  HQ 1 $ Just (Tr x Nothing Nothing)

flatten :: Maybe (BTree e) -> [e]
flatten h = build (flattenFB h) where
	flattenFB h c n = maybe n (\ (Tr x l r) -> x `c` flattenFB l c (flattenFB r c n)) h