{-# OPTIONS_GHC -Wall #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  ToySolver.Combinatorial.HittingSet.Simple
-- Copyright   :  (c) Masahiro Sakai 2012-2014
-- License     :  BSD-style
--
-- Maintainer  :  masahiro.sakai@gmail.com
-- Stability   :  provisional
-- Portability :  portable
--
-----------------------------------------------------------------------------
module ToySolver.Combinatorial.HittingSet.Simple
  ( minimalHittingSets
  , enumMinimalHittingSets
  ) where

import Control.Monad
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
import Data.Set (Set)
import qualified Data.Set as Set
import ToySolver.Combinatorial.HittingSet.Util (maintainNoSupersets)

minimalHittingSets :: Set IntSet -> Set IntSet
minimalHittingSets :: Set IntSet -> Set IntSet
minimalHittingSets = [IntSet] -> Set IntSet
forall a. Ord a => [a] -> Set a
Set.fromList ([IntSet] -> Set IntSet)
-> (Set IntSet -> [IntSet]) -> Set IntSet -> Set IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [IntSet] -> [IntSet]
minimalHittingSets' ([IntSet] -> [IntSet])
-> (Set IntSet -> [IntSet]) -> Set IntSet -> [IntSet]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set IntSet -> [IntSet]
forall a. Set a -> [a]
Set.toList

enumMinimalHittingSets :: Set IntSet -> [IntSet]
enumMinimalHittingSets :: Set IntSet -> [IntSet]
enumMinimalHittingSets = [IntSet] -> [IntSet]
forall a. Ord a => [a] -> [a]
nubOrd ([IntSet] -> [IntSet])
-> (Set IntSet -> [IntSet]) -> Set IntSet -> [IntSet]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [IntSet] -> [IntSet]
minimalHittingSets' ([IntSet] -> [IntSet])
-> (Set IntSet -> [IntSet]) -> Set IntSet -> [IntSet]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set IntSet -> [IntSet]
forall a. Set a -> [a]
Set.toList

minimalHittingSets' :: [IntSet] -> [IntSet]
minimalHittingSets' :: [IntSet] -> [IntSet]
minimalHittingSets' [IntSet]
es = [IntSet] -> IntSet -> [IntSet]
f [IntSet]
es IntSet
IntSet.empty
  where
    f :: [IntSet] -> IntSet -> [IntSet]
    f :: [IntSet] -> IntSet -> [IntSet]
f [] IntSet
hs = IntSet -> [IntSet]
forall (m :: * -> *) a. Monad m => a -> m a
return IntSet
hs
    f [IntSet]
es IntSet
hs = do
      Key
v <- IntSet -> [Key]
IntSet.toList (IntSet -> [Key]) -> IntSet -> [Key]
forall a b. (a -> b) -> a -> b
$ [IntSet] -> IntSet
forall (f :: * -> *). Foldable f => f IntSet -> IntSet
IntSet.unions [IntSet]
es
      let hs' :: IntSet
hs' = Key -> IntSet -> IntSet
IntSet.insert Key
v IntSet
hs
      IntSet
e <- [IntSet]
es
      Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Key
v Key -> IntSet -> Bool
`IntSet.member` IntSet
e
      let es' :: [IntSet]
es' = [IntSet] -> Key -> IntSet -> [IntSet]
propagateChoice [IntSet]
es Key
v IntSet
e
      [IntSet] -> IntSet -> [IntSet]
f [IntSet]
es' IntSet
hs'

propagateChoice :: [IntSet] -> Int -> IntSet -> [IntSet]
propagateChoice :: [IntSet] -> Key -> IntSet -> [IntSet]
propagateChoice [IntSet]
es Key
v IntSet
e = [IntSet]
zs
  where
    xs :: [IntSet]
xs = (IntSet -> Bool) -> [IntSet] -> [IntSet]
forall a. (a -> Bool) -> [a] -> [a]
filter (Key
v Key -> IntSet -> Bool
`IntSet.notMember`) [IntSet]
es
    ys :: [IntSet]
ys = (IntSet -> IntSet) -> [IntSet] -> [IntSet]
forall a b. (a -> b) -> [a] -> [b]
map ((Key -> Bool) -> IntSet -> IntSet
IntSet.filter (Key
v Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
<) (IntSet -> IntSet) -> (IntSet -> IntSet) -> IntSet -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntSet -> IntSet -> IntSet
`IntSet.difference` IntSet
e)) [IntSet]
xs
    zs :: [IntSet]
zs = [IntSet] -> [IntSet]
maintainNoSupersets [IntSet]
ys

nubOrd :: Ord a => [a] -> [a]
nubOrd :: [a] -> [a]
nubOrd = Set a -> [a] -> [a]
forall a. Ord a => Set a -> [a] -> [a]
go Set a
forall a. Set a
Set.empty
  where
    go :: Set a -> [a] -> [a]
go Set a
occurred (a
x:[a]
xs)
      | a
x a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
occurred = Set a -> [a] -> [a]
go Set a
occurred [a]
xs
      | Bool
otherwise = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Set a -> [a] -> [a]
go (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
x Set a
occurred) [a]
xs
    go Set a
_ [] = []