{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_HADDOCK show-extensions #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Numeric.Optimization.MIP.Solver.Printemps
-- Copyright   :  (c) Masahiro Sakai 2025
-- License     :  BSD-style
--
-- Maintainer  :  masahiro.sakai@gmail.com
-- Stability   :  provisional
-- Portability :  non-portable
--
-----------------------------------------------------------------------------
module Numeric.Optimization.MIP.Solver.Printemps
  ( Printemps (..)
  , printemps
  ) where

import qualified Data.Aeson as J
import Data.Default.Class
import Data.Map.Lazy (Map)
import qualified Data.Map.Lazy as Map
import qualified Data.Text as T
import qualified Data.Text.Lazy.IO as TLIO
import System.IO.Temp
import qualified Numeric.Optimization.MIP.MPSFile as MPSFile
import Numeric.Optimization.MIP.Base
import Numeric.Optimization.MIP.Solver.Base
import qualified Numeric.Optimization.MIP.Solution.Printemps as PrintempsSol
import Numeric.Optimization.MIP.Internal.ProcessUtil (runProcessWithOutputCallback)
import System.Exit
import System.FilePath ((</>))

-- | A solver instance for calling @mps_solver.exe@ command from [PRINTEMPS](https://snowberryfield.github.io/printemps/).
--
-- It requires PRINTEMPS version 2.6.0 or later.
--
-- Use 'printemps' and record update syntax to modify its field.
data Printemps
  = Printemps
  { Printemps -> String
printempsPath :: String
  , Printemps -> [String]
printempsArgs :: [String]
  }

instance Default Printemps where
  def :: Printemps
def = Printemps
printemps

-- | Default value of t'Printemps'
printemps :: Printemps
printemps :: Printemps
printemps = String -> [String] -> Printemps
Printemps String
"mps_solver" []

instance IsSolver Printemps IO where
  solve' :: Printemps
-> SolveOptions -> Problem Scientific -> IO (Solution Scientific)
solve' Printemps
solver SolveOptions
opt Problem Scientific
prob = do
    let prob' :: Problem Scientific
prob' = Problem Scientific
prob
                { name =
                    case name prob of
                      Just Text
s | Bool -> Bool
not (Text -> Bool
T.null Text
s) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
s
                      Maybe Text
_ -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"problem"
                }

    let (Maybe String
orig_option_file, [String]
args') = [String] -> (Maybe String, [String])
removeOptionArgs (Printemps -> [String]
printempsArgs Printemps
solver)
    Map Text Value
orig_option <-
      case Maybe String
orig_option_file of
        Maybe String
Nothing -> Map Text Value -> IO (Map Text Value)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Map Text Value
forall k a. Map k a
Map.empty
        Just String
fname -> do
          Either String (Map Text Value)
ret <- String -> IO (Either String (Map Text Value))
forall a. FromJSON a => String -> IO (Either String a)
J.eitherDecodeFileStrict' String
fname
          case Either String (Map Text Value)
ret of
            Left String
err -> IOError -> IO (Map Text Value)
forall a. IOError -> IO a
ioError (IOError -> IO (Map Text Value)) -> IOError -> IO (Map Text Value)
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
err
            Right Map Text Value
option -> Map Text Value -> IO (Map Text Value)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Map Text Value
option
    Map Text Value
orig_general <-
      case Value -> Result (Map Text Value)
forall a. FromJSON a => Value -> Result a
J.fromJSON (Value -> Text -> Map Text Value -> Value
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault ([Pair] -> Value
J.object []) Text
"general" Map Text Value
orig_option) of
        J.Error String
err -> IOError -> IO (Map Text Value)
forall a. IOError -> IO a
ioError (IOError -> IO (Map Text Value)) -> IOError -> IO (Map Text Value)
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
err
        J.Success Map Text Value
val -> Map Text Value -> IO (Map Text Value)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Map Text Value
val
    let general :: Map T.Text J.Value
        general :: Map Text Value
general =
          case SolveOptions -> Maybe Double
solveTimeLimit SolveOptions
opt of
            Maybe Double
Nothing -> Map Text Value
orig_general
            Just Double
t -> Text -> Value -> Map Text Value -> Map Text Value
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
"time_max" (Double -> Value
forall a. ToJSON a => a -> Value
J.toJSON Double
t) Map Text Value
orig_general
        option :: Map T.Text J.Value
        option :: Map Text Value
option = Text -> Value -> Map Text Value -> Map Text Value
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
"general" (Map Text Value -> Value
forall a. ToJSON a => a -> Value
J.toJSON Map Text Value
general) Map Text Value
orig_option

    String
-> (String -> IO (Solution Scientific)) -> IO (Solution Scientific)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> m a) -> m a
withSystemTempDirectory String
"printemps" ((String -> IO (Solution Scientific)) -> IO (Solution Scientific))
-> (String -> IO (Solution Scientific)) -> IO (Solution Scientific)
forall a b. (a -> b) -> a -> b
$ \String
path ->
      case FileOptions -> Problem Scientific -> Either String Text
MPSFile.render FileOptions
forall a. Default a => a
def{ optMPSWriteObjName = False } Problem Scientific
prob' of
        Left String
err -> IOError -> IO (Solution Scientific)
forall a. IOError -> IO a
ioError (IOError -> IO (Solution Scientific))
-> IOError -> IO (Solution Scientific)
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
err
        Right Text
s -> do
          let problem_file :: String
problem_file = String
path String -> String -> String
</> String
"input.mps"
          String -> Text -> IO ()
TLIO.writeFile String
problem_file Text
s
          let option_file :: String
option_file = String
path String -> String -> String
</> String
"option.json"
          String -> Map Text Value -> IO ()
forall a. ToJSON a => String -> a -> IO ()
J.encodeFile String
option_file Map Text Value
option

          let args :: [String]
args = [String
"-p", String
option_file] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
args' [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
problem_file]
              onGetLine :: String -> IO ()
onGetLine String
s = SolveOptions -> String -> IO ()
solveLogger SolveOptions
opt String
s
              onGetErrorLine :: String -> IO ()
onGetErrorLine = SolveOptions -> String -> IO ()
solveErrorLogger SolveOptions
opt
          ExitCode
exitcode <- String
-> [String]
-> Maybe String
-> String
-> (String -> IO ())
-> (String -> IO ())
-> IO ExitCode
runProcessWithOutputCallback (Printemps -> String
printempsPath Printemps
solver) [String]
args (String -> Maybe String
forall a. a -> Maybe a
Just String
path) String
"" String -> IO ()
onGetLine String -> IO ()
onGetErrorLine
          if ExitCode
exitcode ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess then do
            Solution Scientific -> IO (Solution Scientific)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Solution Scientific -> IO (Solution Scientific))
-> Solution Scientific -> IO (Solution Scientific)
forall a b. (a -> b) -> a -> b
$ Solution Scientific
forall a. Default a => a
def{ solStatus = StatusUnknown }
          else do
            String -> IO (Solution Scientific)
PrintempsSol.readFile (String
path String -> String -> String
</> String
"incumbent.json")

removeOptionArgs :: [String] -> (Maybe FilePath, [String])
removeOptionArgs :: [String] -> (Maybe String, [String])
removeOptionArgs = Maybe String -> [String] -> [String] -> (Maybe String, [String])
forall {a}.
(Eq a, IsString a) =>
Maybe a -> [a] -> [a] -> (Maybe a, [a])
f Maybe String
forall a. Maybe a
Nothing []
  where
    f :: Maybe a -> [a] -> [a] -> (Maybe a, [a])
f Maybe a
optionFile [a]
args [] = (Maybe a
optionFile, [a] -> [a]
forall a. [a] -> [a]
reverse [a]
args)
    f Maybe a
_ [a]
args (a
"-p" : a
fname : [a]
xs) = Maybe a -> [a] -> [a] -> (Maybe a, [a])
f (a -> Maybe a
forall a. a -> Maybe a
Just a
fname) [a]
args [a]
xs
    f Maybe a
optionFile [a]
args (a
x : [a]
xs) = Maybe a -> [a] -> [a] -> (Maybe a, [a])
f Maybe a
optionFile (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
args) [a]
xs