{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_HADDOCK show-extensions #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Numeric.Optimization.MIP.Solution.HiGHS
-- Copyright   :  (c) Masahiro Sakai 2025
-- License     :  BSD-style
--
-- Maintainer  :  masahiro.sakai@gmail.com
-- Stability   :  provisional
-- Portability :  non-portable
--
-----------------------------------------------------------------------------
module Numeric.Optimization.MIP.Solution.HiGHS
  ( Solution (..)
  , parse
  , readFile
  ) where

import Prelude hiding (readFile, writeFile)

import Control.Exception
import Control.Monad
import Data.Char (isSpace)
import qualified Data.Map as Map
import Data.Scientific (Scientific)
import Data.String
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.IO as TLIO
import System.IO hiding (readFile, writeFile)
import qualified Text.Megaparsec as Megaparsec
import Text.Megaparsec hiding (label, skipManyTill, parse, ParseError)
import Text.Megaparsec.Char hiding (string', char')
import qualified Text.Megaparsec.Char.Lexer as P

import qualified Numeric.Optimization.MIP.Base as MIP
import Numeric.Optimization.MIP.Base (Solution (..))
import Numeric.Optimization.MIP.FileUtils (ParseError)

parser :: forall e s m. (MonadParsec e s m, Token s ~ Char, IsString (Tokens s)) => m (MIP.Solution Scientific)
parser :: forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char, IsString (Tokens s)) =>
m (Solution Scientific)
parser = do
  Tokens s
_ <- m (Tokens s) -> m (Tokens s)
forall a. m a -> m a
strippedLine (Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
"Model status")
  Status
status <- m Status -> m Status
forall a. m a -> m a
stripped (m Status -> m Status) -> m Status -> m Status
forall a b. (a -> b) -> a -> b
$ [m Status] -> m Status
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([m Status] -> m Status) -> [m Status] -> m Status
forall a b. (a -> b) -> a -> b
$ (m Status -> m Status) -> [m Status] -> [m Status]
forall a b. (a -> b) -> [a] -> [b]
map m Status -> m Status
forall a. m a -> m a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
Megaparsec.try
    [ Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
"Not Set" m (Tokens s) -> m Status -> m Status
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Status -> m Status
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Status
MIP.StatusUnknown
    , Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
"Load error" m (Tokens s) -> m Status -> m Status
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Status -> m Status
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Status
MIP.StatusUnknown
    , Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
"Model error" m (Tokens s) -> m Status -> m Status
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Status -> m Status
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Status
MIP.StatusUnknown
    , Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
"Presolve error" m (Tokens s) -> m Status -> m Status
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Status -> m Status
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Status
MIP.StatusUnknown
    , Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
"Solve error" m (Tokens s) -> m Status -> m Status
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Status -> m Status
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Status
MIP.StatusUnknown
    , Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
"Postsolve error" m (Tokens s) -> m Status -> m Status
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Status -> m Status
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Status
MIP.StatusUnknown
    , Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
"Empty" m (Tokens s) -> m Status -> m Status
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Status -> m Status
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Status
MIP.StatusUnknown
    , Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
"Memory limit reached" m (Tokens s) -> m Status -> m Status
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Status -> m Status
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Status
MIP.StatusUnknown
    , Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
"Optimal" m (Tokens s) -> m Status -> m Status
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Status -> m Status
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Status
MIP.StatusOptimal
    , Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
"Infeasible" m (Tokens s) -> m Status -> m Status
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Status -> m Status
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Status
MIP.StatusInfeasible
    , Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
"Primal infeasible or unbounded" m (Tokens s) -> m Status -> m Status
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Status -> m Status
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Status
MIP.StatusInfeasibleOrUnbounded
    , Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
"Unbounded" m (Tokens s) -> m Status -> m Status
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Status -> m Status
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Status
MIP.StatusUnbounded
    , Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
"Bound on objective reached" m (Tokens s) -> m Status -> m Status
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Status -> m Status
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Status
MIP.StatusFeasible -- ???
    , Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
"Target for objective reached" m (Tokens s) -> m Status -> m Status
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Status -> m Status
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Status
MIP.StatusFeasible -- ???
    , Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
"Time limit reached" m (Tokens s) -> m Status -> m Status
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Status -> m Status
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Status
MIP.StatusUnknown
    , Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
"Iteration limit reached" m (Tokens s) -> m Status -> m Status
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Status -> m Status
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Status
MIP.StatusUnknown
    , Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
"Solution limit reached" m (Tokens s) -> m Status -> m Status
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Status -> m Status
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Status
MIP.StatusFeasible -- ???
    , Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
"Interrupted by user" m (Tokens s) -> m Status -> m Status
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Status -> m Status
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Status
MIP.StatusUnknown
    , Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
"Unknown" m (Tokens s) -> m Status -> m Status
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Status -> m Status
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Status
MIP.StatusUnknown
    ]
  Tokens s
_ <- m (Tokens s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol

  m ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space

  Tokens s
_ <- m (Tokens s) -> m (Tokens s)
forall a. m a -> m a
strippedLine (Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
"# Primal solution values")
  m ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace
  [m (Solution Scientific)] -> m (Solution Scientific)
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
    [ do
        Tokens s
_ <- Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
"None" m (Tokens s) -> m () -> m (Tokens s)
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* m ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace m (Tokens s) -> m (Tokens s) -> m (Tokens s)
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* m (Tokens s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol
        Solution Scientific -> m (Solution Scientific)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Solution Scientific -> m (Solution Scientific))
-> Solution Scientific -> m (Solution Scientific)
forall a b. (a -> b) -> a -> b
$
          MIP.Solution
          { solStatus :: Status
MIP.solStatus = Status
status
          , solObjectiveValue :: Maybe Scientific
MIP.solObjectiveValue = Maybe Scientific
forall a. Maybe a
Nothing
          , solVariables :: Map Var Scientific
MIP.solVariables = Map Var Scientific
forall k a. Map k a
Map.empty
          }
    , do
        Tokens s
_ <- (Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
"Feasible" m (Tokens s) -> m (Tokens s) -> m (Tokens s)
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
"Infeasible") m (Tokens s) -> m () -> m (Tokens s)
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* m ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace m (Tokens s) -> m (Tokens s) -> m (Tokens s)
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* m (Tokens s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol
        Scientific
obj <- m Scientific -> m Scientific
forall a. m a -> m a
strippedLine (Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
"Objective" m (Tokens s) -> m () -> m ()
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace1 m () -> m Scientific -> m Scientific
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m Scientific
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Scientific
P.scientific)
        Int
n <- m Int -> m Int
forall a. m a -> m a
strippedLine (Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
"# Columns " m (Tokens s) -> m Int -> m Int
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
P.decimal)
        [(Var, Scientific)]
values <- Int -> m (Var, Scientific) -> m [(Var, Scientific)]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (m (Var, Scientific) -> m [(Var, Scientific)])
-> m (Var, Scientific) -> m [(Var, Scientific)]
forall a b. (a -> b) -> a -> b
$ m (Var, Scientific) -> m (Var, Scientific)
forall a. m a -> m a
strippedLine ((,) (Var -> Scientific -> (Var, Scientific))
-> m Var -> m (Scientific -> (Var, Scientific))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (m Var
ident m Var -> m () -> m Var
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* m ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace1) m (Scientific -> (Var, Scientific))
-> m Scientific -> m (Var, Scientific)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m Scientific
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Scientific
P.scientific)
        Solution Scientific -> m (Solution Scientific)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Solution Scientific -> m (Solution Scientific))
-> Solution Scientific -> m (Solution Scientific)
forall a b. (a -> b) -> a -> b
$
          MIP.Solution
          { solStatus :: Status
MIP.solStatus = Status
status
          , solObjectiveValue :: Maybe Scientific
MIP.solObjectiveValue = Scientific -> Maybe Scientific
forall a. a -> Maybe a
Just 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)]
values
          }
    ]

  where
    stripped :: m a -> m a
    stripped :: forall a. m a -> m a
stripped m a
p = m ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace m () -> m a -> m a
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m a
p m a -> m () -> m a
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* m ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace

    strippedLine :: m a -> m a
    strippedLine :: forall a. m a -> m a
strippedLine m a
p = m a -> m a
forall a. m a -> m a
stripped m a
p m a -> m (Tokens s) -> m a
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* m (Tokens s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol

    ident :: m MIP.Var
    ident :: m Var
ident = String -> Var
forall a. IsString a => String -> a
fromString (String -> Var) -> m String -> m Var
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Char -> m String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some ((Token s -> Bool) -> m (Token s)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace)) m Var -> String -> m Var
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"identifier"

parse :: TL.Text -> Either (ParseError TL.Text) (MIP.Solution Scientific)
parse :: Text -> Either (ParseError Text) (Solution Scientific)
parse = Parsec Void Text (Solution Scientific)
-> String -> Text -> Either (ParseError Text) (Solution Scientific)
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
Megaparsec.parse Parsec Void Text (Solution Scientific)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char, IsString (Tokens s)) =>
m (Solution Scientific)
parser String
"<string>"

readFile :: FilePath -> IO (MIP.Solution Scientific)
readFile :: String -> IO (Solution Scientific)
readFile String
fname = do
  Handle
h <- String -> IOMode -> IO Handle
openFile String
fname IOMode
ReadMode
  Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8
  Either (ParseError Text) (Solution Scientific)
ret <- Parsec Void Text (Solution Scientific)
-> String -> Text -> Either (ParseError Text) (Solution Scientific)
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
Megaparsec.parse Parsec Void Text (Solution Scientific)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char, IsString (Tokens s)) =>
m (Solution Scientific)
parser String
fname (Text -> Either (ParseError Text) (Solution Scientific))
-> IO Text -> IO (Either (ParseError Text) (Solution Scientific))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO Text
TLIO.hGetContents Handle
h
  case Either (ParseError Text) (Solution Scientific)
ret of
    Left ParseError Text
e -> ParseError Text -> IO (Solution Scientific)
forall e a. Exception e => e -> IO a
throwIO (ParseError Text
e :: ParseError TL.Text)
    Right Solution Scientific
a -> Solution Scientific -> IO (Solution Scientific)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Solution Scientific
a

#if !MIN_VERSION_megaparsec(9,0,0)

hspace :: (MonadParsec e s m, Token s ~ Char) => m ()
hspace = void $ takeWhileP (Just "white space") isHSpace
{-# INLINE hspace #-}

hspace1 :: (MonadParsec e s m, Token s ~ Char) => m ()
hspace1 = void $ takeWhile1P (Just "white space") isHSpace
{-# INLINE hspace1 #-}

isHSpace :: Char -> Bool
isHSpace x = isSpace x && x /= '\n' && x /= '\r'

#endif