Set.hs

-- A list-based library for programming with sets.
-- Colin Runciman, June 2007 to April 2008.

module Set (Set, elemList, set, emptyS, singleS, pairS, insertS, deleteS, 
            sizeS, sizeAtMostS, sizeExactlyS, sizeAtLeastS,
            isEmptyS, nonEmptyS, minS, choiceS, (<~),
            (\/), (/\), (\\), unionS, interS, subS, disjointS,
            elemSubsetsOf, powerS, partitionsS, subsetPartitionsS,
            (<|), allS, anyS, exactly, forAll, thereExists, forExactly,
            minimalS, mapS, mapMonoS, unionMapS, regular) where

import Data.List (nub, sort, intersperse)

infixl 7 /\
infixl 6 \/
infixr 5 `elemSubsetsOf`, `subsetPartitionsS`, <|
infix  4 <~, `subS`

data Set a = S {elemList :: [a]}

instance (Ord a, Eq a) => Eq (Set a)
  where
  S xs == S ys = xs == ys

instance Ord a => Ord (Set a)
  where
  compare (S xs) (S ys) = compare xs ys

instance (Ord a, Show a) => Show (Set a)
  where
  show (S xs) =
    "{"++concat (intersperse "," (map show xs))++"}"

set :: Ord a => [a] -> Set a
set = S . nub . sort

emptyS :: Ord a => Set a
emptyS = S []

singleS :: Ord a => a -> Set a
singleS e = S [e]

pairS :: Ord a => a -> a -> Set a
pairS e1 e2 = set [e1,e2]

insertS :: Ord a => a -> Set a -> Set a
insertS e = S . insertList e . elemList
  where
  insertList e []         = [e]
  insertList e xs@(x:xs') = case compare e x of
                            LT -> e : xs
                            EQ -> xs
                            GT -> x : insertList e xs'

deleteS :: Ord a => a -> Set a -> Set a
deleteS e = S . deleteList e . elemList
  where
  deleteList e []         = []
  deleteList e xs@(x:xs') = case compare e x of
                            LT -> xs
                            EQ -> xs'
                            GT -> x : deleteList e xs'

sizeS :: Ord a => Set a -> Int
sizeS = length . elemList

sizeExactlyS :: Ord a => Int -> Set a -> Bool
sizeExactlyS n = lengthExactly n . elemList
  where
  lengthExactly 0 xs     = null xs
  lengthExactly n []     = False
  lengthExactly n (x:xs) = lengthExactly (n-1) xs

sizeAtLeastS :: Ord a => Int -> Set a -> Bool
sizeAtLeastS n = lengthAtLeast n . elemList
  where
  lengthAtLeast 0 xs     = True
  lengthAtLeast n []     = False
  lengthAtLeast n (x:xs) = lengthAtLeast (n-1) xs

sizeAtMostS :: Ord a => Int -> Set a -> Bool
sizeAtMostS n = lengthAtMost n . elemList
  where
  lengthAtMost 0 xs     = null xs
  lengthAtMost n []     = True
  lengthAtMost n (x:xs) = lengthAtMost (n-1) xs

isEmptyS :: Ord a => Set a -> Bool
isEmptyS = null . elemList

nonEmptyS :: Ord a => Set a -> Bool
nonEmptyS = not . isEmptyS

minS :: Ord a => Set a -> a
minS = head . elemList

choiceS :: Ord a => Set a -> Set (a, Set a)
choiceS = S . choice . elemList
  where
  choice xs = [(x, S (xs1++xs2)) | (xs1,x:xs2) <- splits xs]  

splits :: [a] -> [([a],[a])]
splits []     = [([],[])]
splits (x:xs) = ([],x:xs) : [(x:xs1, xs2) | (xs1,xs2) <- splits xs]

(<~) :: Ord a => a -> Set a -> Bool
(<~) e = ordElem e . elemList
  where
  ordElem e []     = False
  ordElem e (x:xs) = case compare e x of
                     LT -> False
                     EQ -> True
                     GT -> ordElem e xs

(\/) :: Ord a => Set a -> Set a -> Set a
S xs \/ S ys = S (join xs ys)
  where
  join [] ys = ys
  join xs [] = xs
  join xs@(x:xs') ys@(y:ys') =
    case compare x y of
    LT -> x : join xs' ys
    EQ -> x : join xs' ys'
    GT -> y : join xs  ys'

(/\) :: Ord a => Set a -> Set a -> Set a
S xs /\ S ys = S (meet xs ys)

meet [] _  = []
meet _  [] = []
meet xs@(x:xs') ys@(y:ys') =
  case compare x y of
  LT ->     meet xs' ys
  EQ -> x : meet xs' ys'
  GT ->     meet xs  ys'

(\\) :: Ord a => Set a -> Set a -> Set a
S xs \\ S ys = S (diff xs ys)

diff [] _  = []
diff xs [] = xs
diff xs@(x:xs') ys@(y:ys') =
  case compare x y of
  LT -> x : diff xs' ys
  EQ ->     diff xs' ys'
  GT ->     diff xs  ys'

unionS :: Ord a => Set (Set a) -> Set a
unionS = foldr (\/) emptyS . elemList

interS :: Ord a => Set (Set a) -> Set a
interS = foldr1 (/\) . elemList

disjointS :: Ord a => Set a -> Set a -> Bool
disjointS (S xs) (S ys) = null (meet xs ys)

subS :: Ord a => Set a -> Set a -> Bool
subS (S xs) (S ys) = null (diff xs ys)

elemSubsetsOf :: Ord a => Int -> Set a -> Set (Set a)
elemSubsetsOf n =
  S . map S . sublistsOf n . elemList
  where
  sublistsOf 0 _      = [[]]
  sublistsOf _ []     = []
  sublistsOf n (x:xs) =
    map (x:) (sublistsOf (n-1) xs) ++ sublistsOf n xs

powerS :: Ord a => Set a -> Set (Set a)
powerS = 
  S . map S . ([]:) . nonEmptySublists . elemList
  where
  nonEmptySublists [] = []
  nonEmptySublists (x:xs) =
    [x] : map (x:) ss ++ ss
    where
    ss = nonEmptySublists xs

-- outer 'set' used to be 'S' but then ordering between
-- partitions can be wrong
-- TO DO: instead reorder partitionsList computation?
partitionsS :: Ord a => Set a -> Set (Set (Set a))
partitionsS = set . map (S . map S) . partitionsList . elemList
  where
  partitionsList []     = [[]]
  partitionsList (x:xs) =
    [[x] : p | p <- ps] ++
    [(x:xs') : xss ++ xss' | p <- ps, (xss,xs':xss') <- splits p]
    where
    ps = partitionsList xs

subsetPartitionsS :: Ord a => Int -> Set a -> Set (Set (Set a))
subsetPartitionsS n = S . map (S . map S) . sublistPartitionsList n . elemList
  where
  sublistPartitionsList n []  = [[] | n == 0]
  sublistPartitionsList n (x:xs) =
    [ [x] : p
    | n > 0, p <- sublistPartitionsList (n-1) xs ] ++
    [ (x:xs') : xss ++ xss'
    | n > 0, p <- sublistPartitionsList n xs, (xss,xs':xss') <- splits p ]

(<|) :: Ord a => (a -> Bool) -> Set a -> Set a
(<|) p = S . filter p . elemList

allS, anyS :: Ord a => (a -> Bool) -> Set a -> Bool
allS p = all p . elemList
anyS p = any p . elemList

exactly ::
  Ord a => Int -> (a->Bool) -> Set a -> Bool
exactly n p =
  exactlyList n p . elemList
  where
  exactlyList 0 p xs     = not (any p xs)
  exactlyList n p []     = False
  exactlyList n p (x:xs) = exactlyList 
                             (if p x then n-1 else n) p xs

forAll, thereExists :: Ord a => Set a -> (a->Bool) -> Bool
forAll s p = allS p s
thereExists s p = anyS p s

forExactly :: Ord a => Int -> Set a -> (a->Bool) -> Bool
forExactly n s p = exactly n p s

mapS :: (Ord a, Ord b) => (a -> b) -> Set a -> Set b
mapS f = set . map f . elemList

-- more efficient variant when f is monotonic
mapMonoS :: (Ord a, Ord b) => (a -> b) -> Set a -> Set b
mapMonoS f = S . map f . elemList

unionMapS :: (Ord a, Ord b) => (a -> Set b) -> Set a -> Set b
unionMapS f = foldr (\/) emptyS . map f . elemList

minimalS :: Ord a => (Set a -> Bool) -> Set a -> Bool
minimalS p s = (p <| powerS s) == set [s]

regular :: Ord a => Int -> Set (Set a) -> Bool
regular d ss =
  -- every element occurs in exactly d sets
  forAll (unionS ss) $ \e ->
    forExactly d ss $ \s -> e <~ s