module Data.NonEmpty.Set ( T, insert, singleton, member, size, fromList, fromAscList, toAscList, fetch, flatten, union, unionLeft, unionRight, findMin, findMax, delete, deleteMin, deleteMax, deleteFindMin, deleteFindMax, minView, maxView, ) where import qualified Data.NonEmpty.Class as C import qualified Data.NonEmpty as NonEmpty import qualified Data.Set as Set import Data.Set (Set, ) import Control.Monad (mzero, ) import Control.DeepSeq (NFData, rnf, ) import Data.Maybe (fromMaybe, ) import Data.Tuple.HT (forcePair, mapSnd, ) {- The first field will always contain the smallest element. We do not use the NonEmpty data type here since it is easy to break this invariant using NonEmpty.!:. The custom type is also consistent with Map. -} data T a = Cons a (Set a) deriving (Eq, Ord) instance (Show a) => Show (T a) where showsPrec p xs = showParen (p>10) $ showString "NonEmptySet.fromList " . showsPrec 11 (toAscList xs) instance (NFData a) => NFData (T a) where rnf = C.rnf instance C.NFData T where rnf (Cons x xs) = rnf (x, C.rnf xs) {- | We cannot have a reasonable @instance Insert Set@, since the @instance Insert (NonEmpty Set)@ would preserve duplicate leading elements, whereas 'Set' does not. However, the @instance Insert NonEmpty@ is not the problem. A general type like > insertSet :: (Insert f, Ord a) => a -> f a -> NonEmpty f a cannot work, since it can be instantiated to > insertSet :: (Ord a) => a -> NonEmpty Set a -> NonEmpty (NonEmpty Set) a and this is obviously wrong: @insertSet x (singleton x)@ has only one element, not two. -} insert :: Ord a => a -> Set a -> T a insert = insertGen fst insertGen :: Ord a => ((a,a) -> a) -> a -> Set a -> T a insertGen select y xt = uncurry Cons $ fromMaybe (y, xt) $ do (x,xs) <- Set.minView xt case compare y x of GT -> return (x, Set.insert y xs) EQ -> return (select (y,x), xs) LT -> mzero singleton :: a -> T a singleton a = Cons a Set.empty member :: (Ord a) => a -> T a -> Bool member y (Cons x xs) = y==x || Set.member y xs size :: T a -> Int size (Cons _ xs) = 1 + Set.size xs findMin :: T a -> a findMin (Cons x _) = x findMax :: T a -> a findMax (Cons x xs) = if Set.null xs then x else Set.findMax xs delete :: (Ord k) => k -> T k -> Set k delete y (Cons x xs) = if y == x then xs else Set.insert x $ Set.delete y xs deleteMin :: T a -> Set a deleteMin (Cons _ xs) = xs deleteMax :: (Ord a) => T a -> Set a deleteMax (Cons x xs) = if Set.null xs then Set.empty else Set.insert x $ Set.deleteMax xs deleteFindMin :: T a -> (a, Set a) deleteFindMin (Cons x xs) = (x, xs) deleteFindMax :: (Ord a) => T a -> (a, Set a) deleteFindMax (Cons x xs) = if Set.null xs then (x, Set.empty) else mapSnd (Set.insert x) $ Set.deleteFindMax xs minView :: T a -> (a, Set a) minView (Cons x xs) = (x,xs) maxView :: (Ord a) => T a -> (a, Set a) maxView (Cons x xs) = forcePair $ case Set.maxView xs of Nothing -> (x,xs) Just (y,ys) -> (y, Set.insert x ys) fromList :: (Ord a) => NonEmpty.T [] a -> T a fromList (NonEmpty.Cons x xs) = insert x $ Set.fromList xs fromAscList :: (Ord a) => NonEmpty.T [] a -> T a fromAscList (NonEmpty.Cons x xs) = Cons x $ Set.fromAscList xs toAscList :: T a -> NonEmpty.T [] a toAscList (Cons x xs) = NonEmpty.Cons x $ Set.toAscList xs fetch :: (Ord a) => Set a -> Maybe (T a) fetch = fmap (uncurry Cons) . Set.minView flatten :: (Ord a) => T a -> Set a flatten (Cons x xs) = Set.insert x xs union :: (Ord a) => T a -> T a -> T a union (Cons x xs) (Cons y ys) = uncurry Cons $ case Set.union xs ys of zs -> case compare x y of LT -> (x, Set.union zs $ Set.singleton y) GT -> (y, Set.insert x zs) EQ -> (x, zs) unionLeft :: (Ord a) => Set a -> T a -> T a unionLeft xs (Cons y ys) = insertGen snd y $ Set.union xs ys unionRight :: (Ord a) => T a -> Set a -> T a unionRight (Cons x xs) ys = insertGen fst x $ Set.union xs ys {- According Set functions are only available since containers-0.5.2, i.e. GHC-7.8. elemAt :: Int -> T a -> a elemAt k (Cons x xs) = if k==0 then x else Set.elemAt (pred k) xs deleteAt :: Int -> T a -> Set a deleteAt k (Cons _ xs) = if k==0 then xs else Set.deleteAt (pred k) xs -}