content: {-# OPTIONS_GHC -Wall #-}
  {-# OPTIONS_HADDOCK show-extensions #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE FunctionalDependencies #-}
  {-# LANGUAGE KindSignatures #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  -----------------------------------------------------------------------------
  -- |
  -- Module      :  ToySolver.Combinatorial.HittingSet.InterestingSets
  -- Copyright   :  (c) Masahiro Sakai 2016
  -- License     :  BSD-style
  --
  -- Maintainer  :  masahiro.sakai@gmail.com
  -- Stability   :  provisional
  -- Portability :  non-portable
  --
  -- * D. Gunopulos, H. Mannila, R. Khardon, and H. Toivonen, Data mining,
  --   hypergraph transversals, and machine learning (extended abstract),
  --   in Proceedings of the Sixteenth ACM SIGACT-SIGMOD-SIGART Symposium
  --   on Principles of Database Systems, ser. PODS '97. 1997, pp. 209-216.
  --   <http://almaden.ibm.com/cs/projects/iis/hdb/Publications/papers/pods97_trans.pdf>
  --
  -----------------------------------------------------------------------------
  module ToySolver.Combinatorial.HittingSet.InterestingSets
    (
    -- * Problem definition
      IsProblem (..)
    , InterestingOrUninterestingSet (..)
    , defaultGrow
    , defaultShrink
    , defaultMaximalInterestingSet
    , defaultMinimalUninterestingSet
    , defaultMinimalUninterestingSetOrMaximalInterestingSet
    , SimpleProblem (..)
  
    -- * Options for maximal interesting sets enumeration
    , Options (..)
  
    -- * Datatype for monotone CNF/DNF dualization
    , ImplicateOrImplicant (..)
    ) where
  
  import Control.Monad
  import Data.Default.Class
  import Data.IntSet (IntSet)
  import qualified Data.IntSet as IntSet
  import Data.Kind (Type)
  import Data.Set (Set)
  import qualified Data.Set as Set
  import qualified ToySolver.Combinatorial.HittingSet.Simple as HTC
  
  data InterestingOrUninterestingSet
    = UninterestingSet IntSet
    | InterestingSet IntSet
    deriving (Eq, Ord, Show, Read)
  
  -- | A problem is essentially a pair of an @IntSet@ (@universe@) and
  -- a monotone pure function @IntSet -> Bool@ (@isInteresting@), but
  -- we generalize a bit for potentialial optimization opportunity.
  --
  -- For simple cases you can just use 'SimpleProblem' instance.
  class Monad m => IsProblem prob m | prob -> m where
    universe :: prob -> IntSet
  
    -- | Interesting sets are lower closed subsets of 'universe', i.e. if @xs@ is
    -- interesting then @ys@ ⊆ @xs@ is also interesting.
    isInteresting :: prob -> IntSet -> m Bool
    isInteresting prob xs = do
      ret <- isInteresting' prob xs
      return $!
        case ret of
          InterestingSet _ -> True
          UninterestingSet _ -> False
  
    -- | If @xs@ is interesting it returns @InterestingSet ys@ where @ys@ is an interesting superset of @xs@.
    -- If @xs@ is uninteresting it returns @UninterestingSet ys@ where @ys@ is an uninteresting subset of @xs@.
    isInteresting' :: prob -> IntSet -> m InterestingOrUninterestingSet
    isInteresting' prob xs = do
      b <- isInteresting prob xs
      return $ if b then InterestingSet xs else UninterestingSet xs
  
    -- | @grow xs@ computes maximal interesting set @ys@ that is a superset of @xs@.
    grow :: prob -> IntSet -> m IntSet
    grow = defaultGrow
  
    -- | @shrink xs@ computes minimal uninteresting set @ys@ that is a subset of @xs@.
    shrink :: prob -> IntSet -> m IntSet
    shrink = defaultShrink
  
    -- | If @xs@ is an interesting set @maximalInterestingSet prob xs@ returns @Just ys@
    -- such that @ys@ is a maximal interesting superset of @xs@, otherwise it returns @Nothing@.
    maximalInterestingSet :: prob -> IntSet -> m (Maybe IntSet)
    maximalInterestingSet = defaultMaximalInterestingSet
  
    -- | If @xs@ is an uninteresting set @minimalUninterestingSet prob xs@ returns @Just ys@
    -- such that @ys@ is a minimal uninteresting subset of @xs@, otherwise it returns @Nothing@.
    minimalUninterestingSet :: prob -> IntSet -> m (Maybe IntSet)
    minimalUninterestingSet = defaultMinimalUninterestingSet
  
    -- | If @xs@ is an uninteresting set @minimalUninterestingSetOrMaximalInterestingSet prob xs@ returns @Left ys@
    -- such that @ys@ is a minimal uninteresting subset of @xs@.
    -- If @xs@ is an interesting set @minimalUninterestingSetOrMaximalInterestingSet prob xs@ returns @Right ys@
    -- such that @ys@ is a maximal interesting superset of @xs@
    minimalUninterestingSetOrMaximalInterestingSet :: prob -> IntSet -> m InterestingOrUninterestingSet
    minimalUninterestingSetOrMaximalInterestingSet = defaultMinimalUninterestingSetOrMaximalInterestingSet
  
    {-# MINIMAL universe, (isInteresting | isInteresting') #-}
  
  -- | Default implementation of 'grow' using 'isInteresting''.
  defaultGrow :: IsProblem prob m => prob -> IntSet -> m IntSet
  defaultGrow prob xs = foldM f xs (IntSet.toList (universe prob `IntSet.difference` xs))
    where
      f xs' y = do
        ret <- isInteresting' prob (IntSet.insert y xs')
        case ret of
          UninterestingSet _ -> return xs'
          InterestingSet xs'' -> return xs''
  
  -- | Default implementation of 'shrink' using 'isInteresting''.
  defaultShrink :: IsProblem prob m => prob -> IntSet -> m IntSet
  defaultShrink prob xs = foldM f xs (IntSet.toList xs)
    where
      f xs' y = do
        ret <- isInteresting' prob (IntSet.delete y xs')
        case ret of
          UninterestingSet xs'' -> return xs''
          InterestingSet _ -> return xs'
  
  -- | Default implementation of 'maximalUninterestingSet' using 'isInteresting'' and 'grow'.
  defaultMaximalInterestingSet :: IsProblem prob m => prob -> IntSet -> m (Maybe IntSet)
  defaultMaximalInterestingSet prob xs = do
   ret <- isInteresting' prob xs
   case ret of
     UninterestingSet _ -> return Nothing
     InterestingSet xs' -> liftM Just $ grow prob xs'
  
  -- | Default implementation of 'minimalUninterestingSet' using 'isInteresting'' and 'shrink'.
  defaultMinimalUninterestingSet :: IsProblem prob m => prob -> IntSet -> m (Maybe IntSet)
  defaultMinimalUninterestingSet prob xs = do
   ret <- isInteresting' prob xs
   case ret of
     UninterestingSet xs' -> liftM Just $ shrink prob xs'
     InterestingSet _ -> return Nothing
  
  -- | Default implementation of 'minimalUninterestingSetOrMaximalInterestingSet' using 'isInteresting'', 'shrink' 'grow'.
  defaultMinimalUninterestingSetOrMaximalInterestingSet
    :: IsProblem prob m => prob -> IntSet -> m InterestingOrUninterestingSet
  defaultMinimalUninterestingSetOrMaximalInterestingSet prob xs = do
   ret <- isInteresting' prob xs
   case ret of
     UninterestingSet ys -> liftM UninterestingSet $ shrink prob ys
     InterestingSet ys -> liftM InterestingSet $ grow prob ys
  
  data SimpleProblem (m :: Type -> Type) = SimpleProblem IntSet (IntSet -> Bool)
  
  instance Monad m => IsProblem (SimpleProblem m) m where
    universe (SimpleProblem univ _) = univ
    isInteresting (SimpleProblem _ f) = return . f
  
  data Options m
    = Options
    { optMinimalHittingSets :: Set IntSet -> m (Set IntSet)
    , optMaximalInterestingSets :: Set IntSet
    , optMinimalUninterestingSets :: Set IntSet
    , optOnMaximalInterestingSetFound :: IntSet -> m ()
    , optOnMinimalUninterestingSetFound :: IntSet -> m ()
    }
  
  instance Monad m => Default (Options m) where
    def =
      Options
      { optMinimalHittingSets = return . HTC.minimalHittingSets
      , optMaximalInterestingSets = Set.empty
      , optMinimalUninterestingSets = Set.empty
      , optOnMaximalInterestingSetFound = \_ -> return ()
      , optOnMinimalUninterestingSetFound = \_ -> return ()
      }
  
  
  data ImplicateOrImplicant
    = Implicate IntSet
    | Implicant IntSet
    deriving (Eq, Ord, Show, Read)
  