minimal subsets matching condition

SubsetsMatchingCondition.hs

module SubsetsMatchingCondition where

import Data.Maybe (mapMaybe)

data Cond a = Unsatisfied a | Satisfied a
  deriving (Show)

-- | Construct *minimal* subsets that satisfy the
-- condition upon the monoidal fold.  The monoidal
-- append must be "monotonic" for sensible results.
--
-- This is a quasi-group, by way of the explicit
-- inversion function argument @inv@.
--
ssCond :: (Monoid m) => (a -> m) -> (m -> m) -> (m -> Bool) -> [a] -> [[a]]
ssCond conv inv test = mapMaybe (\x -> case x of Satisfied l -> Just l ; _ -> Nothing) . go
  where
  go [] = []
  go (x:xs)
    | test (conv x) = Satisfied [x] : go xs
    | otherwise =
      let
        -- ys already satisfies the condition; do not add x to it
        f (Satisfied ys) r = Satisfied ys : r
        f (Unsatisfied ys) r =
          let z = foldMap conv (x : ys)
          in if test z
            then
              -- (x:ys) satisfies the test and is a /candidate/ subset.
              -- We now have to test whether (x:ys) is a /minimal/
              -- subset.  That is, that there is no true subset of
              -- (x:ys) that also satisfies the test.  Use the group
              -- inversion function to "subtract" each element of
              -- ys from the fold and test the result.
              if any (test . (z <>) . inv) (fmap conv ys)
                -- There are subsets of order n - 1 containing x that
                -- satisfy test. (x:ys) not not a result; omit it.
                then Unsatisfied ys : r
                -- There are no subsets of order n - 1 containing x that
                -- satisfy test.  So (x:ys) is a valid result.
                else Unsatisfied ys : Satisfied (x : ys) : r
            else
              -- (x:ys) does not satisfy the test.  Keep it as an Unsatisfied
              -- intermediate result.
              Unsatisfied ys : Unsatisfied (x : ys) : r
      in Unsatisfied [x] : foldr f [] (go xs)