InterestingSets.hs

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