{-# LANGUAGE DeriveDataTypeable #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_HADDOCK show-extensions #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  ToySolver.Combinatorial.HittingSet.HTCBDD
-- Copyright   :  (c) Masahiro Sakai 2014
-- License     :  BSD-style
--
-- Maintainer  :  masahiro.sakai@gmail.com
-- Stability   :  provisional
-- Portability :  non-portable
--
-- Wrapper for htcbdd command.
--
-- * HTC-BDD: Hypergraph Transversal Computation with Binary Decision Diagrams
--   <http://kuma-san.net/htcbdd.html>
--
-----------------------------------------------------------------------------
module ToySolver.Combinatorial.HittingSet.HTCBDD
  ( Options (..)
  , Method (..)
  , Failure (..)
  , minimalHittingSets
  ) where

import Control.Exception (Exception, throwIO)
import Control.Monad
import Data.Default.Class
import Data.Array.Unboxed
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Typeable
import System.Exit
import System.IO
import System.IO.Temp
import ToySolver.Internal.ProcessUtil (runProcessWithOutputCallback)

-- | Options for solving.
--
-- The default option can be obtained by 'def'.
data Options
  = Options
  { Options -> FilePath
optHTCBDDCommand  :: FilePath
  , Options -> Method
optMethod         :: Method
  , Options -> FilePath -> IO ()
optOnGetLine      :: String -> IO ()
  , Options -> FilePath -> IO ()
optOnGetErrorLine :: String -> IO ()
  }

data Method
  = MethodToda
  | MethodKnuth
  deriving (Method -> Method -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Method -> Method -> Bool
$c/= :: Method -> Method -> Bool
== :: Method -> Method -> Bool
$c== :: Method -> Method -> Bool
Eq, Eq Method
Method -> Method -> Bool
Method -> Method -> Ordering
Method -> Method -> Method
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Method -> Method -> Method
$cmin :: Method -> Method -> Method
max :: Method -> Method -> Method
$cmax :: Method -> Method -> Method
>= :: Method -> Method -> Bool
$c>= :: Method -> Method -> Bool
> :: Method -> Method -> Bool
$c> :: Method -> Method -> Bool
<= :: Method -> Method -> Bool
$c<= :: Method -> Method -> Bool
< :: Method -> Method -> Bool
$c< :: Method -> Method -> Bool
compare :: Method -> Method -> Ordering
$ccompare :: Method -> Method -> Ordering
Ord, Int -> Method -> ShowS
[Method] -> ShowS
Method -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Method] -> ShowS
$cshowList :: [Method] -> ShowS
show :: Method -> FilePath
$cshow :: Method -> FilePath
showsPrec :: Int -> Method -> ShowS
$cshowsPrec :: Int -> Method -> ShowS
Show)

instance Default Method where
  def :: Method
def = Method
MethodToda

instance Default Options where
  def :: Options
def =
    Options
    { optHTCBDDCommand :: FilePath
optHTCBDDCommand  = FilePath
"htcbdd"
    , optMethod :: Method
optMethod         = forall a. Default a => a
def
    , optOnGetLine :: FilePath -> IO ()
optOnGetLine      = \FilePath
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    , optOnGetErrorLine :: FilePath -> IO ()
optOnGetErrorLine = \FilePath
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    }

data Failure = Failure !Int
  deriving (Int -> Failure -> ShowS
[Failure] -> ShowS
Failure -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Failure] -> ShowS
$cshowList :: [Failure] -> ShowS
show :: Failure -> FilePath
$cshow :: Failure -> FilePath
showsPrec :: Int -> Failure -> ShowS
$cshowsPrec :: Int -> Failure -> ShowS
Show, Typeable)

instance Exception Failure

minimalHittingSets :: Options -> Set IntSet -> IO (Set IntSet)
minimalHittingSets :: Options -> Set IntSet -> IO (Set IntSet)
minimalHittingSets Options
opt Set IntSet
es = do
  forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> (FilePath -> Handle -> m a) -> m a
withSystemTempFile FilePath
"htcbdd-input.dat" forall a b. (a -> b) -> a -> b
$ \FilePath
fname1 Handle
h1 -> do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. Set a -> [a]
Set.toList Set IntSet
es) forall a b. (a -> b) -> a -> b
$ \IntSet
e -> do
      Handle -> FilePath -> IO ()
hPutStrLn Handle
h1 forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unwords [forall a. Show a => a -> FilePath
show (IntMap Int
encTable forall a. IntMap a -> Int -> a
IntMap.! Int
v) | Int
v <- IntSet -> [Int]
IntSet.toList IntSet
e]
    Handle -> IO ()
hClose Handle
h1
    forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> (FilePath -> Handle -> m a) -> m a
withSystemTempFile FilePath
"htcbdd-out.dat" forall a b. (a -> b) -> a -> b
$ \FilePath
fname2 Handle
h2 -> do
      Handle -> IO ()
hClose Handle
h2
      Options -> FilePath -> FilePath -> IO ()
execHTCBDD Options
opt FilePath
fname1 FilePath
fname2
      FilePath
s <- FilePath -> IO FilePath
readFile FilePath
fname2
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ([Int] -> IntSet
IntSet.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ((UArray Int Int
decTable forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => FilePath -> a
read) forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
words) forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
lines FilePath
s
  where
    vs :: IntSet
    vs :: IntSet
vs = forall (f :: * -> *). Foldable f => f IntSet -> IntSet
IntSet.unions (forall a. Set a -> [a]
Set.toList Set IntSet
es)

    nv :: Int
    nv :: Int
nv = IntSet -> Int
IntSet.size IntSet
vs

    encTable :: IntMap Int
    encTable :: IntMap Int
encTable = forall a. [(Int, a)] -> IntMap a
IntMap.fromList (forall a b. [a] -> [b] -> [(a, b)]
zip (IntSet -> [Int]
IntSet.toList IntSet
vs) [Int
1..Int
nv])

    decTable :: UArray Int Int
    decTable :: UArray Int Int
decTable = forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [(i, e)] -> a i e
array (Int
1,Int
nv) (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..Int
nv] (IntSet -> [Int]
IntSet.toList IntSet
vs))

execHTCBDD :: Options -> FilePath -> FilePath -> IO ()
execHTCBDD :: Options -> FilePath -> FilePath -> IO ()
execHTCBDD Options
opt FilePath
inputFile FilePath
outputFile = do
  let args :: [FilePath]
args = [FilePath
"-k" | Options -> Method
optMethod Options
opt forall a. Eq a => a -> a -> Bool
== Method
MethodKnuth] forall a. [a] -> [a] -> [a]
++ [FilePath
inputFile, FilePath
outputFile]
  ExitCode
exitcode <- FilePath
-> [FilePath]
-> FilePath
-> (FilePath -> IO ())
-> (FilePath -> IO ())
-> IO ExitCode
runProcessWithOutputCallback (Options -> FilePath
optHTCBDDCommand Options
opt) [FilePath]
args FilePath
"" (Options -> FilePath -> IO ()
optOnGetLine Options
opt) (Options -> FilePath -> IO ()
optOnGetErrorLine Options
opt)
  case ExitCode
exitcode of
    ExitFailure Int
n -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ Int -> Failure
Failure Int
n
    ExitCode
ExitSuccess -> forall (m :: * -> *) a. Monad m => a -> m a
return ()