module Game.Mastermind.CodeSet.Union (
T, member, size,
fromLists, cube,
overlappingPairs, overlapping,
) where
import qualified Game.Mastermind.CodeSet as CodeSet
import Game.Utility (nonEmptySetToList, )
import qualified Data.NonEmpty.Set as NonEmptySet
import qualified Data.NonEmpty as NonEmpty
import qualified Data.Set as Set
import qualified Data.List.HT as ListHT
import qualified Data.List as List
import Data.Maybe (mapMaybe, )
import Control.Monad (liftM2, guard, )
{- |
@Cons [[a,b,c,d], [e,f,g,h]]@
expresses a x b x c x d union e x f x g x h,
where @x@ denotes the set product.
-}
newtype T a = Cons [[NonEmptySet.T 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 nonEmptySetToList) xs
fromLists :: (Ord a) => [[NonEmpty.T [] a]] -> T a
fromLists = Cons . map (map NonEmptySet.fromList)
flatten :: (Ord a) => T a -> [[a]]
flatten = concatMap sequence . toLists
symbols :: (Ord a) => T a -> Set.Set a
symbols = Set.unions . map Set.unions . flattenFactors
cube :: Int -> NonEmptySet.T 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 . NonEmptySet.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 $ NonEmptySet.size componentSet)
in (n3,
nonEmptySetToList componentSet !! fromInteger i))
n1 prod
representationSize :: T a -> Int
representationSize (Cons x) =
sum . map (sum . map NonEmptySet.size) $ x
{- |
We could try to merge set products.
I'll first want to see, whether this is needed in a relevant number of cases.
-}
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 x y =
normalize $
liftM2 (zipWith Set.intersection) (flattenFactors x) (flattenFactors y)
member :: (Ord a) => [a] -> T a -> Bool
member code (Cons xs) =
any (and . zipWith NonEmptySet.member code) xs
{- |
Remove empty set products.
-}
normalize :: (Ord a) => [[Set.Set a]] -> T a
normalize = Cons . mapMaybe (mapM NonEmptySet.fetch)
flattenFactors :: (Ord a) => T a -> [[Set.Set a]]
flattenFactors (Cons xs) = map (map NonEmptySet.flatten) xs
disjointProduct :: (Ord a) => [Set.Set a] -> [Set.Set a] -> Bool
disjointProduct prod0 prod1 =
any Set.null $ zipWith Set.intersection prod0 prod1
{- |
for debugging: list all pairs of products, that overlap
-}
overlappingPairs :: (Ord a) => T a -> [([Set.Set a], [Set.Set a])]
overlappingPairs set = do
prod0:rest <- ListHT.tails $ flattenFactors set
prod1 <- rest
guard $ not $ disjointProduct prod0 prod1
return (prod0, prod1)
{- |
for debugging: list all subsets, that are contained in more than one product
-}
overlapping :: (Ord a) => T a -> [([Set.Set a], [[Set.Set a]])]
overlapping set = do
let xs = flattenFactors set
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)