{-# 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
    { optSHDCommand :: FilePath
optSHDCommand     = FilePath
"shd"
    , optSHDArgs :: [FilePath]
optSHDArgs        = [FilePath
"0"]
    , 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
"shd-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
"shd-out.dat" 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
      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
0..Int
nvforall a. Num a => a -> a -> a
-Int
1])

    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
0,Int
nvforall a. Num a => a -> a -> a
-Int
1) (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..Int
nvforall 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 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 -> 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 ()