{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_HADDOCK show-extensions #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
module ToySolver.Combinatorial.HittingSet.DAA
(
module ToySolver.Combinatorial.HittingSet.InterestingSets
, run
, generateCNFAndDNF
) where
import Control.Monad.Identity
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 ToySolver.Combinatorial.HittingSet.InterestingSets
import ToySolver.Combinatorial.HittingSet.Util (maintainNoSupersets)
run :: forall prob m. IsProblem prob m => prob -> Options m -> m (Set IntSet, Set IntSet)
run :: forall prob (m :: * -> *).
IsProblem prob m =>
prob -> Options m -> m (Set IntSet, Set IntSet)
run prob
prob Options m
opt = do
let comp_pos :: Set IntSet
comp_pos = forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map IntSet -> IntSet
complement (forall (m :: * -> *). Options m -> Set IntSet
optMaximalInterestingSets Options m
opt)
Set IntSet
hst_comp_pos <- forall (m :: * -> *). Options m -> Set IntSet -> m (Set IntSet)
optMinimalHittingSets Options m
opt Set IntSet
comp_pos
Set IntSet
-> Set IntSet -> Set IntSet -> m (Set IntSet, Set IntSet)
loop Set IntSet
comp_pos Set IntSet
hst_comp_pos (forall (m :: * -> *). Options m -> Set IntSet
optMinimalUninterestingSets Options m
opt)
where
univ :: IntSet
univ :: IntSet
univ = forall prob (m :: * -> *). IsProblem prob m => prob -> IntSet
universe prob
prob
complement :: IntSet -> IntSet
complement :: IntSet -> IntSet
complement = (IntSet
univ IntSet -> IntSet -> IntSet
`IntSet.difference`)
loop :: Set IntSet -> Set IntSet -> Set IntSet -> m (Set IntSet, Set IntSet)
loop :: Set IntSet
-> Set IntSet -> Set IntSet -> m (Set IntSet, Set IntSet)
loop Set IntSet
comp_pos Set IntSet
hst_comp_pos Set IntSet
neg = do
let xss :: Set IntSet
xss = Set IntSet
hst_comp_pos forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set IntSet
neg
if forall a. Set a -> Bool
Set.null Set IntSet
xss then
forall (m :: * -> *) a. Monad m => a -> m a
return (forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map IntSet -> IntSet
complement Set IntSet
comp_pos, Set IntSet
neg)
else do
(Set IntSet
comp_pos', Set IntSet
hst_comp_pos', Set IntSet
neg') <- Set IntSet
-> Set IntSet
-> Set IntSet
-> [IntSet]
-> m (Set IntSet, Set IntSet, Set IntSet)
loop2 Set IntSet
comp_pos Set IntSet
hst_comp_pos Set IntSet
neg (forall a. Set a -> [a]
Set.toList Set IntSet
xss)
Set IntSet
-> Set IntSet -> Set IntSet -> m (Set IntSet, Set IntSet)
loop Set IntSet
comp_pos' Set IntSet
hst_comp_pos' Set IntSet
neg'
loop2 :: Set IntSet -> Set IntSet -> Set IntSet -> [IntSet] -> m (Set IntSet, Set IntSet, Set IntSet)
loop2 :: Set IntSet
-> Set IntSet
-> Set IntSet
-> [IntSet]
-> m (Set IntSet, Set IntSet, Set IntSet)
loop2 Set IntSet
comp_pos Set IntSet
hst_comp_pos Set IntSet
neg [] = forall (m :: * -> *) a. Monad m => a -> m a
return (Set IntSet
comp_pos, Set IntSet
hst_comp_pos, Set IntSet
neg)
loop2 Set IntSet
comp_pos Set IntSet
hst_comp_pos Set IntSet
neg (IntSet
xs : [IntSet]
xss) = do
Maybe IntSet
ret <- forall prob (m :: * -> *).
IsProblem prob m =>
prob -> IntSet -> m (Maybe IntSet)
maximalInterestingSet prob
prob IntSet
xs
case Maybe IntSet
ret of
Maybe IntSet
Nothing -> do
forall (m :: * -> *). Options m -> IntSet -> m ()
optOnMinimalUninterestingSetFound Options m
opt IntSet
xs
Set IntSet
-> Set IntSet
-> Set IntSet
-> [IntSet]
-> m (Set IntSet, Set IntSet, Set IntSet)
loop2 Set IntSet
comp_pos Set IntSet
hst_comp_pos (forall a. Ord a => a -> Set a -> Set a
Set.insert IntSet
xs Set IntSet
neg) [IntSet]
xss
Just IntSet
ys -> do
forall (m :: * -> *). Options m -> IntSet -> m ()
optOnMaximalInterestingSetFound Options m
opt IntSet
ys
let zs :: IntSet
zs = IntSet -> IntSet
complement IntSet
ys
comp_pos' :: Set IntSet
comp_pos' = forall a. Ord a => a -> Set a -> Set a
Set.insert IntSet
zs Set IntSet
comp_pos
hst_comp_pos' :: Set IntSet
hst_comp_pos' = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ [IntSet] -> [IntSet]
maintainNoSupersets forall a b. (a -> b) -> a -> b
$
[Key -> IntSet -> IntSet
IntSet.insert Key
w IntSet
ws | IntSet
ws <- forall a. Set a -> [a]
Set.toList Set IntSet
hst_comp_pos, Key
w <- IntSet -> [Key]
IntSet.toList IntSet
zs]
forall (m :: * -> *) a. Monad m => a -> m a
return (Set IntSet
comp_pos', Set IntSet
hst_comp_pos', Set IntSet
neg)
generateCNFAndDNF
:: IntSet
-> (IntSet -> Bool)
-> Set IntSet
-> Set IntSet
-> (Set IntSet, Set IntSet)
generateCNFAndDNF :: IntSet
-> (IntSet -> Bool)
-> Set IntSet
-> Set IntSet
-> (Set IntSet, Set IntSet)
generateCNFAndDNF IntSet
vs IntSet -> Bool
f Set IntSet
cs Set IntSet
ds = (forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (IntSet
vs IntSet -> IntSet -> IntSet
`IntSet.difference`) Set IntSet
pos, Set IntSet
neg)
where
prob :: SimpleProblem m
prob = forall (m :: * -> *). IntSet -> (IntSet -> Bool) -> SimpleProblem m
SimpleProblem IntSet
vs (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntSet -> Bool
f)
opt :: Options Identity
opt = forall a. Default a => a
def
{ optMaximalInterestingSets :: Set IntSet
optMaximalInterestingSets = forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (IntSet
vs IntSet -> IntSet -> IntSet
`IntSet.difference`) Set IntSet
cs
, optMinimalUninterestingSets :: Set IntSet
optMinimalUninterestingSets = Set IntSet
ds
}
(Set IntSet
pos,Set IntSet
neg) = forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall prob (m :: * -> *).
IsProblem prob m =>
prob -> Options m -> m (Set IntSet, Set IntSet)
run forall {m :: * -> *}. SimpleProblem m
prob Options Identity
opt