{-# LANGUAGE GeneralizedNewtypeDeriving , DeriveFunctor , DeriveFoldable , DeriveTraversable , FlexibleContexts , MultiParamTypeClasses , OverloadedLists , TupleSections , FlexibleInstances #-} module Data.Set.Ordered.Many where import Data.Mergeable import Data.Foldable as Fold import Data.Traversable import Data.Maybe (fromJust, isJust, mapMaybe) import Data.Vector (Vector, (!?)) import qualified Data.Vector as Vector import Control.Applicative import Control.Monad.Fix import Control.Monad.State import Control.Monad.Base import Test.QuickCheck import System.IO.Unsafe (unsafePerformIO) -- | Ordered sets with duplicate elements. newtype OMSet a = OMSet {unOMSet :: Vector a} deriving ( Eq , Show , Functor , Applicative , Monad , Fold.Foldable , Traversable -- , MonadFix ) instance Mergeable OMSet where mergeMap f (OMSet xs) = mergeMap f xs instance MonadBase Gen Gen where liftBase = id instance (Arbitrary a, Ord a, Show a) => Arbitrary (OMSet a) where arbitrary = OMSet <$> sized go where -- go s = let xs = [1..s] -- in pure xs -- unsafePerformIO (print xs) `seq` (pure xs) go s = do x <- arbitrary xs <- go' s x let xss = Vector.cons x xs pure xss -- unsafePerformIO (print xss) `seq` (pure xss) go' :: (Ord a, Arbitrary a) => Int -> a -> Gen (Vector a) go' 0 _ = pure [] go' s' prev = do next <- arbitrary `suchThat` (>= prev) (Vector.cons next) <$> go' (s' - 1) next -- * Operators (\\) :: Eq a => OMSet a -> OMSet a -> OMSet a (\\) = difference -- * Query null :: Eq a => OMSet a -> Bool null (OMSet xs) = Vector.null xs size :: OMSet a -> Int size (OMSet xs) = Vector.length xs member :: Eq a => a -> OMSet a -> Bool member x (OMSet xs) = Vector.elem x xs notMember :: Eq a => a -> OMSet a -> Bool notMember x = not . member x lookup :: Eq a => a -> OMSet a -> Maybe a lookup x (OMSet xs) = Vector.find (== x) xs isSubsetOf :: Eq a => OMSet a -> OMSet a -> Bool isSubsetOf (OMSet xs) (OMSet ys) = Vector.all (`Vector.elem` ys) xs isProperSubsetOf :: Eq a => OMSet a -> OMSet a -> Bool isProperSubsetOf xs ys = xs /= ys && isSubsetOf xs ys -- * Construction -- | /O(1)/ empty :: OMSet a empty = OMSet Vector.empty -- | /O(1)/ singleton :: a -> OMSet a singleton = OMSet . Vector.singleton -- | /O(n)/ insert :: Ord a => a -> OMSet a -> OMSet a insert x (OMSet xs) = let (ps,ss) = Vector.span (<= x) xs in OMSet (ps <> Vector.singleton x <> ss) -- | /O(n)/ delete :: Eq a => a -> OMSet a -> OMSet a delete x (OMSet xs) = OMSet (Vector.filter (/= x) xs) -- * Combine -- | /O(min n m)/ union :: Ord a => OMSet a -> OMSet a -> OMSet a union xs ys = foldr insert xs ys -- | /O(n*m)/ difference :: Eq a => OMSet a -> OMSet a -> OMSet a difference (OMSet xs) (OMSet ys) = OMSet (Vector.foldr go [] xs) where go x soFar | Vector.elem x ys = soFar | otherwise = Vector.cons x soFar -- | /O(min(n,m))/ - Combines all elements of both intersection :: Ord a => OMSet a -> OMSet a -> OMSet a intersection (OMSet xs') (OMSet ys') = OMSet (go xs' ys') where go :: Ord a => Vector a -> Vector a -> Vector a go xss yss = case (,) <$> xss Vector.!? 0 <*> yss Vector.!? 0 of Nothing -> [] Just (x,y) | x < y -> go xss (Vector.drop 1 yss) | x == y -> [x,y] <> go (Vector.drop 1 xss) (Vector.drop 1 yss) | otherwise -> go (Vector.drop 1 xss) yss -- * Filter -- | /O(n)/ filter :: (a -> Bool) -> OMSet a -> OMSet a filter p (OMSet xs) = OMSet (Vector.filter p xs) -- | /O(n)/ partition :: (a -> Bool) -> OMSet a -> (OMSet a, OMSet a) partition p (OMSet xs) = let (l,r) = Vector.partition p xs in (OMSet l, OMSet r) -- * Map -- | /O(n)/ map :: (a -> b) -> OMSet a -> OMSet b map f (OMSet xs) = OMSet (Vector.map f xs) -- | /O(?)/ mapMaybe :: (a -> Maybe b) -> OMSet a -> OMSet b mapMaybe f (OMSet xs) = OMSet (Vector.mapMaybe f xs)