{-# LANGUAGE
GeneralizedNewtypeDeriving
, DeriveFunctor
, FlexibleContexts
, MultiParamTypeClasses
#-}
module Data.Set.Unordered.Unique where
import Data.Mergeable
import Data.List as List
import Data.Maybe (fromJust, isJust, mapMaybe)
import Control.Monad.State
import Control.Monad.Base
import Test.QuickCheck
newtype UUSet a = UUSet {unUUSet :: [a]}
deriving (Functor, Show)
instance Mergeable UUSet where
mergeMap f (UUSet xs) = mergeMap f xs
instance Eq a => Eq (UUSet a) where
(UUSet xs) == (UUSet ys) = case foldr go (Just xs) ys of
Just [] -> True
_ -> False
where
go _ Nothing = Nothing
go _ (Just []) = Nothing
go y (Just xs') | y `elem` xs' = Just $ List.delete y xs'
| otherwise = Nothing
instance MonadBase Gen Gen where
liftBase = id
instance (Arbitrary a, Eq a) => Arbitrary (UUSet a) where
arbitrary = UUSet <$> sized go
where go s = evalStateT (replicateM s go') []
go' :: ( MonadState [a] m
, MonadBase Gen m
, Eq a
, Arbitrary a
) => m a
go' = do
soFar <- get
x <- liftBase $ arbitrary `suchThat` (`notElem` soFar)
put $ x:soFar
return x
(\\) :: Eq a => UUSet a -> UUSet a -> UUSet a
(\\) = difference
null :: UUSet a -> Bool
null (UUSet xs) = List.null xs
size :: UUSet a -> Int
size (UUSet xs) = List.length xs
member :: Eq a => a -> UUSet a -> Bool
member x (UUSet xs) = List.elem x xs
notMember :: Eq a => a -> UUSet a -> Bool
notMember x = not . member x
lookup :: Eq a => a -> UUSet a -> Maybe a
lookup x' (UUSet xs') = lookup' x' xs'
where
lookup' _ [] = Nothing
lookup' x (y:ys) | x == y = Just y
| otherwise = lookup' x ys
isSubsetOf :: Eq a => UUSet a -> UUSet a -> Bool
isSubsetOf (UUSet xs) (UUSet ys) = foldr go True xs
where
go x b | List.elem x ys = b
| otherwise = False
isProperSubsetOf :: Eq a => UUSet a -> UUSet a -> Bool
isProperSubsetOf (UUSet xs') (UUSet ys') = fst $ foldr go (True,ys') xs'
where
go _ (False,xs) = (False,xs)
go _ (_,[]) = (False,[])
go x (b,soFar) = let midx = List.elemIndex x soFar in
if isJust midx then (b, deleteAt (fromJust midx) soFar)
else (False, soFar)
deleteAt n xs = List.take n xs ++ List.drop (n+1) xs
empty :: UUSet a
empty = UUSet []
singleton :: a -> UUSet a
singleton x = UUSet [x]
insert :: Eq a => a -> UUSet a -> UUSet a
insert x' (UUSet xs) = UUSet $ insert' x' xs
where
insert' x [] = [x]
insert' x (y:ys) | x == y = y:ys
| otherwise = y:insert' x ys
delete :: Eq a => a -> UUSet a -> UUSet a
delete x' (UUSet xs) = UUSet $ delete' x' xs
where
delete' _ [] = []
delete' x (y:ys) | x == y = ys
| otherwise = y:delete' x ys
union :: Eq a => UUSet a -> UUSet a -> UUSet a
union (UUSet xs) (UUSet ys) = UUSet $ foldr go xs ys
where
go y soFar | List.elem y soFar = soFar
| otherwise = y:soFar
difference :: Eq a => UUSet a -> UUSet a -> UUSet a
difference (UUSet xs) (UUSet ys) = UUSet $ foldr go [] xs
where
go x soFar | List.elem x ys = soFar
| otherwise = x:soFar
intersection :: Eq a => UUSet a -> UUSet a -> UUSet a
intersection (UUSet xs) (UUSet ys) = UUSet $ foldr go [] xs
where
go x soFar | List.elem x ys = x:soFar
| otherwise = soFar
filter :: (a -> Bool) -> UUSet a -> UUSet a
filter p (UUSet xs) = UUSet $ List.filter p xs
partition :: (a -> Bool) -> UUSet a -> (UUSet a, UUSet a)
partition p (UUSet xs) = let (l,r) = List.partition p xs in (UUSet l, UUSet r)
map :: (a -> b) -> UUSet a -> UUSet b
map f (UUSet xs) = UUSet $ List.map f xs
mapMaybe :: (a -> Maybe b) -> UUSet a -> UUSet b
mapMaybe f (UUSet xs) = UUSet $ Data.Maybe.mapMaybe f xs