module Game.Mastermind.CodeSet.Tree ( T, null, member, intersection, size, propIntersections, ) where import qualified Game.Mastermind.CodeSet as CodeSet import Game.Utility (nonEmptySetToList, ) import Control.Monad (liftM2, mfilter, ) import qualified Data.NonEmpty.Set as NonEmptySet import qualified Data.NonEmpty as NonEmpty import qualified Data.Map as Map import qualified Data.Set as Set import Data.Tuple.HT (mapFst, swap, ) import Data.Ord.HT (comparing, ) import Data.Eq.HT (equating, ) import Data.Maybe (mapMaybe, ) import Prelude hiding (null, ) {- | @Products [(a,b),(c,d)]@ expresses a x b union c x d, where @x@ denotes the set product. -} data T a = End | Products (Map.Map (NonEmptySet.T a) (T a)) deriving (Show) instance CodeSet.C T where empty = Products Map.empty union = union intersection = intersection unit = End leftNonEmptyProduct c xs = Products $ if null xs then Map.empty else Map.singleton c xs flatten = flatten symbols = symbols null = null size = size select = select representationSize = representationSize compress = compress flatten :: (Ord a) => T a -> [[a]] flatten End = [[]] flatten (Products xs) = concatMap (\(a,b) -> liftM2 (:) (nonEmptySetToList a) (flatten b)) (Map.toList xs) symbols :: (Ord a) => T a -> Set.Set a symbols End = Set.empty symbols (Products xps) = Set.unions $ map (\(x,xs) -> Set.union (NonEmptySet.flatten x) (symbols xs)) $ Map.toList xps -- ToDo: sizeLimitted max - return size only if it is at most 'max' size :: T a -> Integer size End = 1 size (Products xs) = sum $ map (\(a,b) -> fromIntegral (NonEmptySet.size a) * size b) $ Map.toList xs -- FixMe: somehow inefficient, because the sizes of subsets are recomputed several times select :: T a -> Integer -> [a] select End n = case compare n 0 of LT -> error "CodeSet.select.end: index negative" EQ -> [] GT -> error "CodeSet.select.end: index too large" select (Products xps) n0 = if n0<0 then error "CodeSet.select: negative index" else case dropWhile (\(_, ((n1,sz), _)) -> n1>=sz) $ zip (Map.toList xps) $ uncurry zip $ mapFst (\sizes -> zip (scanl (-) n0 sizes) sizes) $ unzip $ map (\(x,xs) -> let sz = size xs in (fromIntegral (NonEmptySet.size x) * sz, sz)) $ Map.toList xps of [] -> error "CodeSet.select: index too large" ((x,xs), ((n1,_), xsSize)) : _ -> let (j,k) = divMod n1 xsSize in (nonEmptySetToList x !! fromInteger j) : select xs k representationSize :: T a -> Int representationSize End = 1 representationSize (Products xs) = sum $ map (\(a,b) -> NonEmptySet.size a + representationSize b) $ Map.toList xs {- | We could try to merge set products. I'll first want to see, whether this is needed in a relevant number of cases. -} union :: (Ord a) => T a -> T a -> T a union End End = End union (Products xs) (Products ys) = Products (Map.unionWith union xs ys) union _ _ = error "CodeSet.union: sets with different tuple size" intersection :: (Ord a) => T a -> T a -> T a intersection End End = End intersection (Products xps) (Products yps) = Products $ Map.fromListWith union $ normalizeProducts $ liftM2 (\(x,xs) (y,ys) -> (Set.intersection (NonEmptySet.flatten x) (NonEmptySet.flatten y), intersection xs ys)) (Map.toList xps) (Map.toList yps) intersection _ _ = error "CodeSet.intersection: sets with different tuple size" {- | Remove empty set products. -} normalizeProducts :: (Ord a) => [(Set.Set a, T a)] -> [(NonEmptySet.T a, T a)] normalizeProducts = mapMaybe (\(x,xs) -> liftM2 (,) (NonEmptySet.fetch x) (mfilter (not . null) (Just xs))) {- Comparing for structural equivalence is overly strict, but a lot simpler than comparing for set equivalence. -} propIntersections :: (Ord a) => NonEmpty.T [] (T a) -> Bool propIntersections xs = equating Indexable (CodeSet.intersections xs) (CodeSet.intersectionsPQ xs) {- | This allows (T a) to be a key in a Map. I do not want an Ord (T a) instance, since it makes no sense and it requires an Eq (T a) instance that is either expensive (if it means set equality) or confusing (if it means structural equality). -} newtype Indexable a = Indexable (T a) instance (Eq a) => Eq (Indexable a) where (Indexable x) == (Indexable y) = case (x,y) of (End,End) -> True (Products xs, Products ys) -> equating (fmap Indexable) xs ys _ -> False instance (Ord a) => Ord (Indexable a) where compare (Indexable x) (Indexable y) = case (x,y) of (End,End) -> EQ -- maybe should be even an error (End,Products _) -> LT (Products _,End) -> GT (Products xs, Products ys) -> comparing (fmap Indexable) xs ys compress :: (Ord a) => T a -> T a compress End = End compress (Products xs) = Products $ Map.fromListWith union $ map swap $ map (mapFst (\(Indexable set) -> set)) $ Map.toList $ Map.fromListWith NonEmptySet.union $ map (mapFst Indexable) $ map swap $ Map.toList $ fmap compress xs member :: (Ord a) => [a] -> T a -> Bool member [] End = True member (c:cs) (Products xps) = any (\(x,xs) -> NonEmptySet.member c x && member cs xs) $ Map.toList xps member _ _ = error "CodeSet.member: mismatch of tuple size and tuple size in set" null :: T a -> Bool null End = False null (Products xs) = Map.null xs