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

import Prelude hiding (readFile, writeFile)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Scientific (Scientific)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.IO as TLIO
import Numeric.Optimization.MIP (Solution)
import qualified Numeric.Optimization.MIP as MIP

parse :: TL.Text -> MIP.Solution Scientific
parse :: Text -> Solution Scientific
parse Text
t = [Text] -> Solution Scientific
parse' ([Text] -> Solution Scientific) -> [Text] -> Solution Scientific
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
TL.lines Text
t

parse' :: [TL.Text] -> MIP.Solution Scientific
parse' :: [Text] -> Solution Scientific
parse' [Text]
ls =
  case [Text] -> (Map Text Text, [Text])
parseHeaders [Text]
ls of
    (Map Text Text
headers, [Text]
ls2) ->
      case [Text] -> (Map Var Scientific, [Text])
parseColumns ([Text] -> [Text]
skipRows [Text]
ls2) of
        (Map Var Scientific
vs, [Text]
_) ->
          let status :: Status
status = Status -> Text -> Map Text Status -> Status
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Status
MIP.StatusUnknown (Map Text Text
headers Map Text Text -> Text -> Text
forall k a. Ord k => Map k a -> k -> a
Map.! Text
"Status") Map Text Status
statusTable
              objstr :: Text
objstr = Map Text Text
headers Map Text Text -> Text -> Text
forall k a. Ord k => Map k a -> k -> a
Map.! Text
"Objective"
              objstr2 :: Text
objstr2 =
                case (Char -> Bool) -> Text -> Maybe Int
T.findIndex (Char
'='Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) Text
objstr of
                  Maybe Int
Nothing -> Text
objstr
                  Just Int
idx -> Int -> Text -> Text
T.drop (Int
idxInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Text
objstr
              obj :: Scientific
obj = case ReadS Scientific
forall a. Read a => ReadS a
reads (Text -> String
T.unpack Text
objstr2) of
                      [] -> String -> Scientific
forall a. HasCallStack => String -> a
error String
"parse error"
                      (Scientific
r,String
_):[(Scientific, String)]
_ -> Scientific
r
          in 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 = Map Var Scientific
vs
             }

parseHeaders :: [TL.Text] -> (Map T.Text T.Text, [TL.Text])
parseHeaders :: [Text] -> (Map Text Text, [Text])
parseHeaders = Map Text Text -> [Text] -> (Map Text Text, [Text])
f Map Text Text
forall k a. Map k a
Map.empty
  where
    f :: Map Text Text -> [Text] -> (Map Text Text, [Text])
f Map Text Text
_ [] = String -> (Map Text Text, [Text])
forall a. HasCallStack => String -> a
error String
"parse error"
    f Map Text Text
ret (Text
"":[Text]
ls) = (Map Text Text
ret, [Text]
ls)
    f Map Text Text
ret (Text
l:[Text]
ls) =
      case (Char -> Bool) -> Text -> (Text, Text)
TL.break (Char
':'Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) Text
l of
        (Text
_, Text
"") -> String -> (Map Text Text, [Text])
forall a. HasCallStack => String -> a
error String
"parse error"
        (Text
name, Text
val) -> Map Text Text -> [Text] -> (Map Text Text, [Text])
f (Text -> Text -> Map Text Text -> Map Text Text
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Text -> Text
TL.toStrict Text
name) (Text -> Text
TL.toStrict (Text -> Text
TL.strip (HasCallStack => Text -> Text
Text -> Text
TL.tail Text
val))) Map Text Text
ret) [Text]
ls

skipRows :: [TL.Text] -> [TL.Text]
skipRows :: [Text] -> [Text]
skipRows [] = String -> [Text]
forall a. HasCallStack => String -> a
error String
"parse error"
skipRows (Text
"":[Text]
ls) = [Text]
ls
skipRows (Text
_:[Text]
ls) = [Text] -> [Text]
skipRows [Text]
ls

parseColumns :: [TL.Text] -> (Map MIP.Var Scientific, [TL.Text])
parseColumns :: [Text] -> (Map Var Scientific, [Text])
parseColumns (Text
l1:Text
l2:[Text]
ls)
  | Text
l1 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"   No. Column name       Activity     Lower bound   Upper bound"
  , Text
l2 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"------ ------------    ------------- ------------- -------------"
    = [(Var, Scientific)] -> [Text] -> (Map Var Scientific, [Text])
f [] [Text]
ls
  where
    f :: [(MIP.Var, Scientific)] -> [TL.Text] -> (Map MIP.Var Scientific, [TL.Text])
    f :: [(Var, Scientific)] -> [Text] -> (Map Var Scientific, [Text])
f [(Var, Scientific)]
_ [] = String -> (Map Var Scientific, [Text])
forall a. HasCallStack => String -> a
error String
"parse error"
    f [(Var, Scientific)]
ret (Text
"":[Text]
ls2) = ([(Var, Scientific)] -> Map Var Scientific
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Var, Scientific)]
ret, [Text]
ls2)
    f [(Var, Scientific)]
ret (Text
l:[Text]
ls2) =
      case [Text]
ws of
        (Text
_no : Text
col : Text
"*" : Text
activity : [Text]
_) -> [(Var, Scientific)] -> [Text] -> (Map Var Scientific, [Text])
f ((Text -> Var
MIP.Var (Text -> Text
TL.toStrict Text
col), String -> Scientific
forall a. Read a => String -> a
read (Text -> String
TL.unpack Text
activity)) (Var, Scientific) -> [(Var, Scientific)] -> [(Var, Scientific)]
forall a. a -> [a] -> [a]
: [(Var, Scientific)]
ret) [Text]
ls3
        (Text
_no : Text
col : Text
activity : [Text]
_) -> [(Var, Scientific)] -> [Text] -> (Map Var Scientific, [Text])
f ((Text -> Var
MIP.Var (Text -> Text
TL.toStrict Text
col), String -> Scientific
forall a. Read a => String -> a
read (Text -> String
TL.unpack Text
activity)) (Var, Scientific) -> [(Var, Scientific)] -> [(Var, Scientific)]
forall a. a -> [a] -> [a]
: [(Var, Scientific)]
ret) [Text]
ls3
        [Text]
_ -> String -> (Map Var Scientific, [Text])
forall a. HasCallStack => String -> a
error String
"parse error"
      where
        ([Text]
ws,[Text]
ls3) =
          case Text -> [Text]
TL.words Text
l of
            ws1 :: [Text]
ws1@(Text
_:Text
_:Text
_:[Text]
_) -> ([Text]
ws1, [Text]
ls2)
            ws1 :: [Text]
ws1@[Text
_,Text
_] -> ([Text]
ws1 [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Text -> [Text]
TL.words ([Text] -> Text
forall a. HasCallStack => [a] -> a
head [Text]
ls2), [Text] -> [Text]
forall a. HasCallStack => [a] -> [a]
tail [Text]
ls2)
            [Text]
_ -> String -> ([Text], [Text])
forall a. HasCallStack => String -> a
error String
"parse error"
parseColumns [Text]
_ = String -> (Map Var Scientific, [Text])
forall a. HasCallStack => String -> a
error String
"parse error"

statusTable :: Map T.Text MIP.Status
statusTable :: Map Text Status
statusTable = [(Text, Status)] -> Map Text Status
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
  [ (Text
"INTEGER OPTIMAL", Status
MIP.StatusOptimal)
  , (Text
"INTEGER NON-OPTIMAL", Status
MIP.StatusUnknown)
  , (Text
"INTEGER EMPTY", Status
MIP.StatusInfeasible)
  ]

readFile :: FilePath -> IO (MIP.Solution Scientific)
readFile :: String -> IO (Solution Scientific)
readFile String
fname = Text -> Solution Scientific
parse (Text -> Solution Scientific)
-> IO Text -> IO (Solution Scientific)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Text
TLIO.readFile String
fname