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

import Control.Monad
import Data.Default.Class
import Data.IORef
import Data.List (stripPrefix)
import qualified Data.Map as Map
import Data.String
import qualified Data.Text.Lazy.IO as TLIO
import System.Exit
import System.IO
import System.IO.Temp
import qualified Numeric.Optimization.MIP.Base as MIP
import qualified Numeric.Optimization.MIP.MPSFile as MPSFile
import Numeric.Optimization.MIP.Solver.Base
import Numeric.Optimization.MIP.Internal.ProcessUtil (runProcessWithOutputCallback)

-- | A solver instance for calling @lp_solve@ command from [lp_solve](https://lpsolve.sourceforge.net/5.5/) package.
--
-- Use 'lpSolve' and record update syntax to modify its field.
data LPSolve
  = LPSolve
  { LPSolve -> String
lpSolvePath :: String
  , LPSolve -> [String]
lpSolveArgs :: [String]
  }

instance Default LPSolve where
  def :: LPSolve
def = LPSolve
lpSolve

-- | Default value of t'LPSolve'
lpSolve :: LPSolve
lpSolve :: LPSolve
lpSolve = String -> [String] -> LPSolve
LPSolve String
"lp_solve" []

instance IsSolver LPSolve IO where
  solve' :: LPSolve
-> SolveOptions -> Problem Scientific -> IO (Solution Scientific)
solve' LPSolve
solver SolveOptions
opt Problem Scientific
prob = do
    case FileOptions -> Problem Scientific -> Either String Text
MPSFile.render FileOptions
forall a. Default a => a
def 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
lp -> do
        String
-> (String -> Handle -> IO (Solution Scientific))
-> IO (Solution Scientific)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
withSystemTempFile String
"lp_solve.mps" ((String -> Handle -> IO (Solution Scientific))
 -> IO (Solution Scientific))
-> (String -> Handle -> IO (Solution Scientific))
-> IO (Solution Scientific)
forall a b. (a -> b) -> a -> b
$ \String
fname1 Handle
h1 -> do
          Handle -> Text -> IO ()
TLIO.hPutStr Handle
h1 Text
lp
          Handle -> IO ()
hClose Handle
h1
          IORef (Maybe Scientific)
objRef <- Maybe Scientific -> IO (IORef (Maybe Scientific))
forall a. a -> IO (IORef a)
newIORef Maybe Scientific
forall a. Maybe a
Nothing
          IORef [(Var, Scientific)]
solRef <- [(Var, Scientific)] -> IO (IORef [(Var, Scientific)])
forall a. a -> IO (IORef a)
newIORef []
          IORef Bool
flagRef <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
          let args :: [String]
args = LPSolve -> [String]
lpSolveArgs LPSolve
solver
                  [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (case SolveOptions -> Maybe Double
solveTimeLimit SolveOptions
opt of
                        Maybe Double
Nothing -> []
                        Just Double
sec -> [String
"-timeout", Double -> String
forall a. Show a => a -> String
show Double
sec])
                  [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (case SolveOptions -> Maybe (Tol Scientific)
solveTol SolveOptions
opt of
                        Maybe (Tol Scientific)
Nothing -> []
                        Just Tol Scientific
tol ->
                          [ String
"-e", Scientific -> String
forall a. Show a => a -> String
show (Tol Scientific -> Scientific
forall r. Tol r -> r
MIP.integralityTol Tol Scientific
tol)
                          , String
"-epsb", Scientific -> String
forall a. Show a => a -> String
show (Tol Scientific -> Scientific
forall r. Tol r -> r
MIP.feasibilityTol Tol Scientific
tol)
                          , String
"-epsd", Scientific -> String
forall a. Show a => a -> String
show (Tol Scientific -> Scientific
forall r. Tol r -> r
MIP.optimalityTol Tol Scientific
tol)
                          ])
                  [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"-fmps", String
fname1]
              onGetLine :: String -> IO ()
onGetLine String
s = do
                case String
s of
                  String
"Actual values of the variables:" -> IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
flagRef Bool
True
                  String
_ | Just String
v <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"Value of objective function: " String
s -> do
                    IORef (Maybe Scientific) -> Maybe Scientific -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Scientific)
objRef (Scientific -> Maybe Scientific
forall a. a -> Maybe a
Just (String -> Scientific
forall a. Read a => String -> a
read String
v))
                  String
_ -> do
                    Bool
flag <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
flagRef
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
flag (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                      case String -> [String]
words String
s of
                        [String
var,String
val] -> IORef [(Var, Scientific)]
-> ([(Var, Scientific)] -> [(Var, Scientific)]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [(Var, Scientific)]
solRef ((String -> Var
forall a. IsString a => String -> a
fromString String
var, String -> Scientific
forall a. Read a => String -> a
read String
val) (Var, Scientific) -> [(Var, Scientific)] -> [(Var, Scientific)]
forall a. a -> [a] -> [a]
:)
                        [String]
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                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 (LPSolve -> String
lpSolvePath LPSolve
solver) [String]
args Maybe String
forall a. Maybe a
Nothing String
"" String -> IO ()
onGetLine String -> IO ()
onGetErrorLine
          Status
status <-
            case ExitCode
exitcode of
              ExitCode
ExitSuccess      -> Status -> IO Status
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Status
MIP.StatusOptimal
              ExitFailure (-2) -> Status -> IO Status
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Status
MIP.StatusUnknown               -- NOMEMORY
              ExitFailure Int
1    -> Status -> IO Status
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Status
MIP.StatusFeasible              -- SUBOPTIMAL
              ExitFailure Int
2    -> Status -> IO Status
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Status
MIP.StatusInfeasible            -- INFEASIBLE
              ExitFailure Int
3    -> Status -> IO Status
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Status
MIP.StatusInfeasibleOrUnbounded -- UNBOUNDED
              ExitFailure Int
4    -> Status -> IO Status
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Status
MIP.StatusUnknown               -- DEGENERATE
              ExitFailure Int
5    -> Status -> IO Status
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Status
MIP.StatusUnknown               -- NUMFAILURE
              ExitFailure Int
6    -> Status -> IO Status
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Status
MIP.StatusUnknown               -- USERABORT
              ExitFailure Int
7    -> Status -> IO Status
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Status
MIP.StatusUnknown               -- TIMEOUT
              ExitFailure Int
9    -> Status -> IO Status
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Status
MIP.StatusOptimal               -- PRESOLVED
              ExitFailure Int
25   -> Status -> IO Status
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Status
MIP.StatusUnknown               -- NUMFAILURE
              ExitFailure Int
n    -> IOError -> IO Status
forall a. IOError -> IO a
ioError (IOError -> IO Status) -> IOError -> IO Status
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError (String -> IOError) -> String -> IOError
forall a b. (a -> b) -> a -> b
$ String
"unknown exit code: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
          Maybe Scientific
obj <- IORef (Maybe Scientific) -> IO (Maybe Scientific)
forall a. IORef a -> IO a
readIORef IORef (Maybe Scientific)
objRef
          [(Var, Scientific)]
sol <- IORef [(Var, Scientific)] -> IO [(Var, Scientific)]
forall a. IORef a -> IO a
readIORef IORef [(Var, Scientific)]
solRef
          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
$
            MIP.Solution
            { solStatus :: Status
MIP.solStatus = Status
status
            , solObjectiveValue :: Maybe Scientific
MIP.solObjectiveValue = Maybe Scientific
obj
            , solVariables :: Map Var Scientific
MIP.solVariables = [(Var, Scientific)] -> Map Var Scientific
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Var, Scientific)]
sol
            }