module SetFamilies where
import Data.List --for nub and sort
-----------------------------------------------------------------------------
--Sets and their types; sets are implemented as lists in ascending order.
type Set = [Int]
--Conjugate types as a list of pairs (i, number of sets containing i)
ctype :: [Set] -> [(Int, Int)]
ctype [] = []
ctype ss = let n = maximum (concat ss)
in [(i, length $ filter (i `elem`) ss) | i <- [1..n]]
--Normal type as a partition (partitions are implemented at the end of this
--file). It is assumed that the conjugate type is a partition.
ptype :: [Set] -> Partition
ptype = conjugatePartition . (map snd) . ctype
--allSets k a b returns all k-element subsets with entries between a and b
allSets :: Int -> Int -> Int -> [Set]
allSets 0 _ _ = [[]]
allSets m a b = [x : rest | x <- [a..b],
rest <- allSets (m-1) (x+1) b]
-----------------------------------------------------------------------------
--Majorization order on Sets
compareSets :: Set -> Set -> Maybe Ordering
compareSets as bs =
let cs = map (uncurry compare) (zip as bs)
cs' = removeInitial EQ cs
in case cs' of [] -> Just EQ
GT : rs | LT `elem` rs -> Nothing
| otherwise -> Just GT
LT : rs | GT `elem` rs -> Nothing
| otherwise -> Just LT
incomparable :: Set -> Set -> Bool
incomparable x y = compareSets x y == Nothing
-----------------------------------------------------------------------------
--Total orderings and downsets
downSet :: Set -> [Set]
downSet [] = []
downSet t = let n = maximum t
m = length t
in [s | s <- allSets m 1 n,
let c = compareSets s t,
c == Just EQ || c == Just LT]
-------------------------------------------------------------------------------
--Set families
setFamilyWithMaximals :: [Set] -> [Set]
setFamilyWithMaximals ss = nub $ concat $ [downSet s | s <- ss]
maximals :: [Set] -> [Set]
maximals ss = [s | s <- ss,
and [not (compareSets x s == Just GT) | x <- ss]]
--Find elements missing from the closure
allMissingElts :: [Set] -> [Set]
allMissingElts ss = let ss' = setFamilyWithMaximals (maximals ss)
in ss' `diff` ss
--Test whether a set family is closed; if not, return a set which fails
missingElt :: [Set] -> Maybe Set
missingElt = safeHead . allMissingElts
-------------------------------------------------------------------------------
--Generating all closed set families of a given shape.
--Find all set families with shape (m^n) and maximum entry k, building from
--a set family with maximals ms (all m-sets), and adding maximals from the list rs.
--We keep track of the length of the set system as we build it, as l.
setFamiliesFrom :: Int -> Int -> ([Set], [Set], Int) -> [([Set], [Set], Int)]
setFamiliesFrom n k (ms, rs, l)
| l > n = []
| l == n = [(ms, rs, l)]
| otherwise = case rs of
[] -> []
(r : restrs) -> setFamiliesFrom n k (ms', rs', l')
++ setFamiliesFrom n k (ms, restrs, l)
where ms' = (r : ms)
rs' = filter (`incomparable` r) restrs
l' = l + length [s | s <- downSet r,
and [s `incomparable` m | m <- ms]]
setFamilies :: Int -> Int -> Int -> [[Set]]
setFamilies m n k =
[ms | (ms, _, _) <- setFamiliesFrom n k ([], allSets m 1 k, 0)]
--can experiment with supplying candidate minimals in a different
--order, e.g. reversed: doesn't seem to make too much difference.
-------------------------------------------------------------------------------
--Find all pairs (type, maximal elements) of closed set families of a given
--shape, or just the types, or just the minimal types.
downClosedPairs :: Int -> Int -> Int -> [(Partition, [Set])]
downClosedPairs m n k = [(ptype ss, ms) | ms <- setFamilies m n k,
let ss = setFamilyWithMaximals ms]
downClosedTypes :: Int -> Int -> Int -> [Partition]
downClosedTypes m n k = map fst (downClosedPairs m n k)
--Streamed so can check on progress. For rest sorting means won't see
--any results until all the types have been found.
downClosedTypesSorted :: Int -> Int -> Int -> [Partition]
downClosedTypesSorted m n k = reverse $ sort $ map fst (downClosedPairs m n k)
minimalPairs :: Int -> Int -> Int -> [(Partition, [Set])]
minimalPairs m n k = takeMinimals (reverse $ sort $ downClosedPairs m n k)
where takeMinimals ps =
[(t, ms) | (t, ms) <- ps,
and [not (t `dominates` u) | (u, _) <- ps, not (u == t)]]
minimalTypes :: Int -> Int -> Int -> [Partition]
minimalTypes m n k = map fst (minimalPairs m n k)
-------------------------------------------------------------------------------
--Partition functions
type Partition = [Int]
size :: Partition -> Int
size ps = sum ps
partitions :: Int -> [Partition]
partitions n = partitionsLE n n
partitionsLE :: Int -> Int -> [Partition]
partitionsLE 0 m = [[]]
partitionsLE n m = [k : ps | k <- [1..min m n],
ps <- partitionsLE (n-k) k]
conjugatePartition :: Partition -> Partition
conjugatePartition [] = []
conjugatePartition ps@(a : _) = map f [1..a]
where f i = length (filter (>= i) ps)
dominates :: Partition -> Partition -> Bool
dominates ps qs = let sps = scanl (+) 0 ps
sqs = scanl (+) 0 qs
in and (zipWith (>=) sps sqs)
-------------------------------------------------------------------------------
--Utility functions
diff :: Eq a => [a] -> [a] -> [a]
diff xs ys = [x | x <- xs, not (x `elem` ys)]
meet :: Eq a => [a] -> [a] -> [a]
meet xs ys = [x | x <- xs, x `elem` ys]
safeHead :: [a] -> Maybe a
safeHead [] = Nothing
safeHead (x : _) = Just x
removeInitial :: Eq a => a -> [a] -> [a]
removeInitial x [] = []
removeInitial x l@(y : ys) | x == y = removeInitial x ys
| otherwise = l
printList :: (Show a) => [a] -> IO ()
printList xs = putStrLn $ unlines $ map show xs