{-# LANGUAGE DeriveDataTypeable #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_HADDOCK show-extensions #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  ToySolver.Combinatorial.HittingSet.SHD
-- Copyright   :  (c) Masahiro Sakai 2014
-- License     :  BSD-style
--
-- Maintainer  :  masahiro.sakai@gmail.com
-- Stability   :  provisional
-- Portability :  non-portable
--
-- Wrapper for shd command.
--
-- * Hypergraph Dualization Repository
--   <http://research.nii.ac.jp/~uno/dualization.html>
--
-----------------------------------------------------------------------------
module ToySolver.Combinatorial.HittingSet.SHD
  ( Options (..)
  , Failure (..)
  , minimalHittingSets
  ) where

import Control.Exception (Exception, throwIO)
import Control.Monad
import Data.Array.Unboxed
import Data.Default.Class
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
optSHDCommand     :: FilePath
  , Options -> [FilePath]
optSHDArgs        :: [String]
  , Options -> FilePath -> IO ()
optOnGetLine      :: String -> IO ()
  , Options -> FilePath -> IO ()
optOnGetErrorLine :: String -> IO ()
  }

instance Default Options where
  def :: Options
def =
    Options :: FilePath
-> [FilePath]
-> (FilePath -> IO ())
-> (FilePath -> IO ())
-> Options
Options
    { optSHDCommand :: FilePath
optSHDCommand     = FilePath
"shd"
    , optSHDArgs :: [FilePath]
optSHDArgs        = [FilePath
"0"]
    , optOnGetLine :: FilePath -> IO ()
optOnGetLine      = \FilePath
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    , optOnGetErrorLine :: FilePath -> IO ()
optOnGetErrorLine = \FilePath
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    }

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

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

execSHD :: Options -> FilePath -> FilePath -> IO ()
execSHD :: Options -> FilePath -> FilePath -> IO ()
execSHD Options
opt FilePath
inputFile FilePath
outputFile = do
  let args :: [FilePath]
args = Options -> [FilePath]
optSHDArgs Options
opt [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
inputFile, FilePath
outputFile]
  ExitCode
exitcode <- FilePath
-> [FilePath]
-> FilePath
-> (FilePath -> IO ())
-> (FilePath -> IO ())
-> IO ExitCode
runProcessWithOutputCallback (Options -> FilePath
optSHDCommand Options
opt) [FilePath]
args FilePath
"" (Options -> FilePath -> IO ()
optOnGetLine Options
opt) (Options -> FilePath -> IO ()
optOnGetErrorLine Options
opt)
  case ExitCode
exitcode of
    ExitFailure Int
n -> Failure -> IO ()
forall e a. Exception e => e -> IO a
throwIO (Failure -> IO ()) -> Failure -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Failure
Failure Int
n
    ExitCode
ExitSuccess -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()