module Game.Mastermind.CodeSet.Union where
import qualified Game.Mastermind.CodeSet as CodeSet
import qualified Data.Set as Set
import qualified Data.List as List
import qualified Data.List.HT as ListHT
import Control.Monad (liftM2, guard, )
newtype T a = Cons [[Set.Set a]]
instance (Ord a, Show a) => Show (T a) where
showsPrec n cs =
showParen (n>=10) $
showString "CodeSet.fromLists " . shows (toLists cs)
instance CodeSet.C T where
empty = Cons []
union = union
intersection = intersection
unit = Cons [[]]
leftNonEmptyProduct c (Cons xs) = Cons (map (c:) xs)
flatten = flatten
symbols = symbols
null (Cons xs) = null xs
size = size
select = select
representationSize = representationSize
compress = id
toLists :: (Ord a) => T a -> [[[a]]]
toLists (Cons xs) =
map (map Set.toList) xs
fromLists :: (Ord a) => [[[a]]] -> T a
fromLists =
Cons . map (map Set.fromList)
flatten :: (Ord a) => T a -> [[a]]
flatten = concatMap sequence . toLists
symbols :: (Ord a) => T a -> Set.Set a
symbols (Cons xs) =
Set.unions $ map Set.unions xs
cube :: Int -> Set.Set a -> T a
cube n alphabet = Cons [replicate n alphabet]
size :: T a -> Integer
size = sum . productSizes
productSizes :: T a -> [Integer]
productSizes (Cons x) =
map (product . map (fromIntegral . Set.size)) $ x
select :: T a -> Integer -> [a]
select set@(Cons xs) n0 =
let sizes = productSizes set
in if n0<0
then error "CodeSet.select: negative index"
else
case dropWhile (\(n1,sz,_) -> n1>=sz) $
zip3 (scanl () n0 sizes) sizes xs of
[] -> error "CodeSet.select: index too large"
(n1,_,prod) : _ ->
(\(n3,cs) ->
if n3==0
then cs
else error "CodeSet.select: at the end index must be zero") $
List.mapAccumR
(\n2 componentSet ->
let (n3,i) = divMod n2 (fromIntegral $ Set.size componentSet)
in (n3, Set.toList componentSet !! fromInteger i))
n1 prod
representationSize :: T a -> Int
representationSize (Cons x) =
sum . map (sum . map Set.size) $ x
union :: T a -> T a -> T a
union (Cons x) (Cons y) = Cons (x++y)
intersection :: (Ord a) => T a -> T a -> T a
intersection (Cons x) (Cons y) =
normalize $ Cons $ liftM2 (zipWith Set.intersection) x y
member :: (Ord a) => [a] -> T a -> Bool
member code (Cons xs) =
any (and . zipWith Set.member code) xs
normalize :: T a -> T a
normalize (Cons x) =
Cons $ filter (all (not . Set.null)) x
disjointProduct :: (Ord a) => [Set.Set a] -> [Set.Set a] -> Bool
disjointProduct prod0 prod1 =
any Set.null $ zipWith Set.intersection prod0 prod1
overlappingPairs :: (Ord a) => T a -> [([Set.Set a], [Set.Set a])]
overlappingPairs (Cons xs) = do
prod0:rest <- ListHT.tails xs
prod1 <- rest
guard $ not $ disjointProduct prod0 prod1
return (prod0, prod1)
overlapping :: (Ord a) => T a -> [([Set.Set a], [[Set.Set a]])]
overlapping (Cons xs) = do
subset <- Set.toList $ Set.fromList $ do
prod0:rest <- ListHT.tails xs
prod1 <- rest
let sec = zipWith Set.intersection prod0 prod1
guard $ all (not . Set.null) $ sec
return sec
return (subset, filter (not . disjointProduct subset) xs)