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, )


{- |
@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 [[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


{- |
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 (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

{- |
Remove empty set products.
-}
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

{- |
for debugging: list all pairs of products, that overlap
-}
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)

{- |
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 (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)