{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module ToySolver.Combinatorial.HittingSet.InterestingSets
(
IsProblem (..)
, InterestingOrUninterestingSet (..)
, defaultGrow
, defaultShrink
, defaultMaximalInterestingSet
, defaultMinimalUninterestingSet
, defaultMinimalUninterestingSetOrMaximalInterestingSet
, SimpleProblem (..)
, Options (..)
, ImplicateOrImplicant (..)
) where
import Control.Monad
import Data.Default.Class
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
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)
class Monad m => IsProblem prob m | prob -> m where
universe :: prob -> IntSet
isInteresting :: prob -> IntSet -> m Bool
isInteresting prob xs = do
ret <- isInteresting' prob xs
return $!
case ret of
InterestingSet _ -> True
UninterestingSet _ -> False
isInteresting' :: prob -> IntSet -> m InterestingOrUninterestingSet
isInteresting' prob xs = do
b <- isInteresting prob xs
return $ if b then InterestingSet xs else UninterestingSet xs
grow :: prob -> IntSet -> m IntSet
grow = defaultGrow
shrink :: prob -> IntSet -> m IntSet
shrink = defaultShrink
maximalInterestingSet :: prob -> IntSet -> m (Maybe IntSet)
maximalInterestingSet = defaultMaximalInterestingSet
minimalUninterestingSet :: prob -> IntSet -> m (Maybe IntSet)
minimalUninterestingSet = defaultMinimalUninterestingSet
minimalUninterestingSetOrMaximalInterestingSet :: prob -> IntSet -> m InterestingOrUninterestingSet
minimalUninterestingSetOrMaximalInterestingSet = defaultMinimalUninterestingSetOrMaximalInterestingSet
{-# MINIMAL universe, (isInteresting | 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''
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'
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'
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
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 :: * -> *) = 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)