-- |
-- Module      : Linear.Simplex.Util
-- Description : Helper functions
-- Copyright   : (c) Junaid Rasheed, 2020-2023
-- License     : BSD-3
-- Maintainer  : jrasheed178@gmail.com
-- Stability   : experimental
--
-- Helper functions for performing the two-phase simplex method.
module Linear.Simplex.Util where

import Control.Lens
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Logger (LogLevel (..), LogLine, MonadLogger, logDebug, logError, logInfo, logWarn)
import Data.Bifunctor
import Data.Generics.Labels ()
import Data.Generics.Product (field)
import Data.List
import qualified Data.Map as Map
import qualified Data.Map.Merge.Lazy as MapMerge
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Data.Time (getCurrentTime)
import Data.Time.Format.ISO8601 (iso8601Show)
import Linear.Simplex.Types
import Prelude hiding (EQ)

-- | Is the given 'ObjectiveFunction' to be 'Max'imized?
isMax :: ObjectiveFunction -> Bool
isMax :: ObjectiveFunction -> Bool
isMax (Max VarLitMapSum
_) = Bool
True
isMax (Min VarLitMapSum
_) = Bool
False

-- | Simplifies a system of 'PolyConstraint's by first calling 'simplifyPolyConstraint',
--  then reducing 'LEQ' and 'GEQ' with same LHS and RHS (and other similar situations) into 'EQ',
--  and finally removing duplicate elements using 'nub'.
simplifySystem :: [PolyConstraint] -> [PolyConstraint]
simplifySystem :: [PolyConstraint] -> [PolyConstraint]
simplifySystem = forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PolyConstraint] -> [PolyConstraint]
reduceSystem
  where
    reduceSystem :: [PolyConstraint] -> [PolyConstraint]
    reduceSystem :: [PolyConstraint] -> [PolyConstraint]
reduceSystem [] = []
    -- Reduce LEQ with matching GEQ and EQ into EQ
    reduceSystem ((LEQ VarLitMapSum
lhs SimplexNum
rhs) : [PolyConstraint]
pcs) =
      let matchingConstraints :: [PolyConstraint]
matchingConstraints =
            forall a. (a -> Bool) -> [a] -> [a]
filter
              ( \case
                  GEQ VarLitMapSum
lhs' SimplexNum
rhs' -> VarLitMapSum
lhs forall a. Eq a => a -> a -> Bool
== VarLitMapSum
lhs' Bool -> Bool -> Bool
&& SimplexNum
rhs forall a. Eq a => a -> a -> Bool
== SimplexNum
rhs'
                  EQ VarLitMapSum
lhs' SimplexNum
rhs' -> VarLitMapSum
lhs forall a. Eq a => a -> a -> Bool
== VarLitMapSum
lhs' Bool -> Bool -> Bool
&& SimplexNum
rhs forall a. Eq a => a -> a -> Bool
== SimplexNum
rhs'
                  PolyConstraint
_ -> Bool
False
              )
              [PolyConstraint]
pcs
      in  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PolyConstraint]
matchingConstraints
            then VarLitMapSum -> SimplexNum -> PolyConstraint
LEQ VarLitMapSum
lhs SimplexNum
rhs forall a. a -> [a] -> [a]
: [PolyConstraint] -> [PolyConstraint]
reduceSystem [PolyConstraint]
pcs
            else VarLitMapSum -> SimplexNum -> PolyConstraint
EQ VarLitMapSum
lhs SimplexNum
rhs forall a. a -> [a] -> [a]
: [PolyConstraint] -> [PolyConstraint]
reduceSystem ([PolyConstraint]
pcs forall a. Eq a => [a] -> [a] -> [a]
\\ [PolyConstraint]
matchingConstraints)
    -- Reduce GEQ with matching LEQ and EQ into EQ
    reduceSystem ((GEQ VarLitMapSum
lhs SimplexNum
rhs) : [PolyConstraint]
pcs) =
      let matchingConstraints :: [PolyConstraint]
matchingConstraints =
            forall a. (a -> Bool) -> [a] -> [a]
filter
              ( \case
                  LEQ VarLitMapSum
lhs' SimplexNum
rhs' -> VarLitMapSum
lhs forall a. Eq a => a -> a -> Bool
== VarLitMapSum
lhs' Bool -> Bool -> Bool
&& SimplexNum
rhs forall a. Eq a => a -> a -> Bool
== SimplexNum
rhs'
                  EQ VarLitMapSum
lhs' SimplexNum
rhs' -> VarLitMapSum
lhs forall a. Eq a => a -> a -> Bool
== VarLitMapSum
lhs' Bool -> Bool -> Bool
&& SimplexNum
rhs forall a. Eq a => a -> a -> Bool
== SimplexNum
rhs'
                  PolyConstraint
_ -> Bool
False
              )
              [PolyConstraint]
pcs
      in  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PolyConstraint]
matchingConstraints
            then VarLitMapSum -> SimplexNum -> PolyConstraint
GEQ VarLitMapSum
lhs SimplexNum
rhs forall a. a -> [a] -> [a]
: [PolyConstraint] -> [PolyConstraint]
reduceSystem [PolyConstraint]
pcs
            else VarLitMapSum -> SimplexNum -> PolyConstraint
EQ VarLitMapSum
lhs SimplexNum
rhs forall a. a -> [a] -> [a]
: [PolyConstraint] -> [PolyConstraint]
reduceSystem ([PolyConstraint]
pcs forall a. Eq a => [a] -> [a] -> [a]
\\ [PolyConstraint]
matchingConstraints)
    -- Reduce EQ with matching LEQ and GEQ into EQ
    reduceSystem ((EQ VarLitMapSum
lhs SimplexNum
rhs) : [PolyConstraint]
pcs) =
      let matchingConstraints :: [PolyConstraint]
matchingConstraints =
            forall a. (a -> Bool) -> [a] -> [a]
filter
              ( \case
                  LEQ VarLitMapSum
lhs' SimplexNum
rhs' -> VarLitMapSum
lhs forall a. Eq a => a -> a -> Bool
== VarLitMapSum
lhs' Bool -> Bool -> Bool
&& SimplexNum
rhs forall a. Eq a => a -> a -> Bool
== SimplexNum
rhs'
                  GEQ VarLitMapSum
lhs' SimplexNum
rhs' -> VarLitMapSum
lhs forall a. Eq a => a -> a -> Bool
== VarLitMapSum
lhs' Bool -> Bool -> Bool
&& SimplexNum
rhs forall a. Eq a => a -> a -> Bool
== SimplexNum
rhs'
                  PolyConstraint
_ -> Bool
False
              )
              [PolyConstraint]
pcs
      in  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PolyConstraint]
matchingConstraints
            then VarLitMapSum -> SimplexNum -> PolyConstraint
EQ VarLitMapSum
lhs SimplexNum
rhs forall a. a -> [a] -> [a]
: [PolyConstraint] -> [PolyConstraint]
reduceSystem [PolyConstraint]
pcs
            else VarLitMapSum -> SimplexNum -> PolyConstraint
EQ VarLitMapSum
lhs SimplexNum
rhs forall a. a -> [a] -> [a]
: [PolyConstraint] -> [PolyConstraint]
reduceSystem ([PolyConstraint]
pcs forall a. Eq a => [a] -> [a] -> [a]
\\ [PolyConstraint]
matchingConstraints)

-- | Converts a 'Dict' to a 'Tableau' using 'dictEntryToTableauEntry'.
--  FIXME: maybe remove this line. The basic variables will have a coefficient of 1 in the 'Tableau'.
dictionaryFormToTableau :: Dict -> Tableau
dictionaryFormToTableau :: Dict -> Tableau
dictionaryFormToTableau =
  forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey
    ( \Var
basicVar (DictValue {SimplexNum
VarLitMapSum
$sel:constant:DictValue :: DictValue -> SimplexNum
$sel:varMapSum:DictValue :: DictValue -> VarLitMapSum
constant :: SimplexNum
varMapSum :: VarLitMapSum
..}) ->
        TableauRow
          { $sel:lhs:TableauRow :: VarLitMapSum
lhs = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Var
basicVar SimplexNum
1 forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a
negate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VarLitMapSum
varMapSum
          , $sel:rhs:TableauRow :: SimplexNum
rhs = SimplexNum
constant
          }
    )

-- | Converts a 'Tableau' to a 'Dict'.
--  We do this by isolating the basic variable on the LHS, ending up with all non basic variables and a 'SimplexNum' constant on the RHS.
tableauInDictionaryForm :: Tableau -> Dict
tableauInDictionaryForm :: Tableau -> Dict
tableauInDictionaryForm =
  forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey
    ( \Var
basicVar (TableauRow {SimplexNum
VarLitMapSum
rhs :: SimplexNum
lhs :: VarLitMapSum
$sel:rhs:TableauRow :: TableauRow -> SimplexNum
$sel:lhs:TableauRow :: TableauRow -> VarLitMapSum
..}) ->
        let basicVarCoeff :: SimplexNum
basicVarCoeff = forall a. a -> Maybe a -> a
fromMaybe SimplexNum
1 forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Var
basicVar VarLitMapSum
lhs
        in  DictValue
              { $sel:varMapSum:DictValue :: VarLitMapSum
varMapSum =
                  forall a b k. (a -> b) -> Map k a -> Map k b
Map.map
                    (\SimplexNum
c -> forall a. Num a => a -> a
negate SimplexNum
c forall a. Fractional a => a -> a -> a
/ SimplexNum
basicVarCoeff)
                    forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Var
basicVar VarLitMapSum
lhs
              , $sel:constant:DictValue :: SimplexNum
constant = SimplexNum
rhs forall a. Fractional a => a -> a -> a
/ SimplexNum
basicVarCoeff
              }
    )

-- | If this function is given 'Nothing', return 'Nothing'.
--  Otherwise, we 'lookup' the 'Integer' given in the first item of the pair in the map given in the second item of the pair.
--  This is typically used to extract the value of the 'ObjectiveFunction' after calling 'Linear.Simplex.Solver.TwoPhase.twoPhaseSimplex'.
extractObjectiveValue :: Maybe Result -> Maybe SimplexNum
extractObjectiveValue :: Maybe Result -> Maybe SimplexNum
extractObjectiveValue = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ \Result
result ->
  case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Result
result.objectiveVar Result
result.varValMap of
    Maybe SimplexNum
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"Objective not found in results when extracting objective value"
    Just SimplexNum
r -> SimplexNum
r

-- | Combines two 'VarLitMapSums together by summing values with matching keys
combineVarLitMapSums :: VarLitMapSum -> VarLitMapSum -> VarLitMapSum
combineVarLitMapSums :: VarLitMapSum -> VarLitMapSum -> VarLitMapSum
combineVarLitMapSums =
  forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
MapMerge.merge
    (forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> Maybe y) -> WhenMissing f k x y
MapMerge.mapMaybeMissing forall {b} {a}. b -> a -> Maybe a
keepVal)
    (forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> Maybe y) -> WhenMissing f k x y
MapMerge.mapMaybeMissing forall {b} {a}. b -> a -> Maybe a
keepVal)
    (forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> Maybe z) -> WhenMatched f k x y z
MapMerge.zipWithMaybeMatched forall {a} {p}. Num a => p -> a -> a -> Maybe a
sumVals)
  where
    keepVal :: b -> a -> Maybe a
keepVal = forall a b. a -> b -> a
const forall (f :: * -> *) a. Applicative f => a -> f a
pure
    sumVals :: p -> a -> a -> Maybe a
sumVals p
k a
v1 a
v2 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ a
v1 forall a. Num a => a -> a -> a
+ a
v2

foldDictValue :: [DictValue] -> DictValue
foldDictValue :: [DictValue] -> DictValue
foldDictValue [] = forall a. HasCallStack => [Char] -> a
error [Char]
"Empty list of DictValues given to foldDictValue"
foldDictValue [DictValue
x] = DictValue
x
foldDictValue (DictValue {$sel:varMapSum:DictValue :: DictValue -> VarLitMapSum
varMapSum = VarLitMapSum
vm1, $sel:constant:DictValue :: DictValue -> SimplexNum
constant = SimplexNum
c1} : DictValue {$sel:varMapSum:DictValue :: DictValue -> VarLitMapSum
varMapSum = VarLitMapSum
vm2, $sel:constant:DictValue :: DictValue -> SimplexNum
constant = SimplexNum
c2} : [DictValue]
dvs) =
  let combinedDictValue :: DictValue
combinedDictValue =
        DictValue
          { $sel:varMapSum:DictValue :: VarLitMapSum
varMapSum = [VarLitMapSum] -> VarLitMapSum
foldVarLitMap [VarLitMapSum
vm1, VarLitMapSum
vm2]
          , $sel:constant:DictValue :: SimplexNum
constant = SimplexNum
c1 forall a. Num a => a -> a -> a
+ SimplexNum
c2
          }
  in  [DictValue] -> DictValue
foldDictValue forall a b. (a -> b) -> a -> b
$ DictValue
combinedDictValue forall a. a -> [a] -> [a]
: [DictValue]
dvs

foldVarLitMap :: [VarLitMap] -> VarLitMap
foldVarLitMap :: [VarLitMapSum] -> VarLitMapSum
foldVarLitMap [] = forall a. HasCallStack => [Char] -> a
error [Char]
"Empty list of VarLitMaps given to foldVarLitMap"
foldVarLitMap [VarLitMapSum
x] = VarLitMapSum
x
foldVarLitMap (VarLitMapSum
vm1 : VarLitMapSum
vm2 : [VarLitMapSum]
vms) =
  let combinedVars :: [Var]
combinedVars = forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
Map.keys VarLitMapSum
vm1 forall a. Semigroup a => a -> a -> a
<> forall k a. Map k a -> [k]
Map.keys VarLitMapSum
vm2

      combinedVarMap :: VarLitMapSum
combinedVarMap =
        forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$
          forall a b. (a -> b) -> [a] -> [b]
map
            ( \Var
var ->
                let mVm1VarVal :: Maybe SimplexNum
mVm1VarVal = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Var
var VarLitMapSum
vm1
                    mVm2VarVal :: Maybe SimplexNum
mVm2VarVal = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Var
var VarLitMapSum
vm2
                in  ( Var
var
                    , case (Maybe SimplexNum
mVm1VarVal, Maybe SimplexNum
mVm2VarVal) of
                        (Just SimplexNum
vm1VarVal, Just SimplexNum
vm2VarVal) -> SimplexNum
vm1VarVal forall a. Num a => a -> a -> a
+ SimplexNum
vm2VarVal
                        (Just SimplexNum
vm1VarVal, Maybe SimplexNum
Nothing) -> SimplexNum
vm1VarVal
                        (Maybe SimplexNum
Nothing, Just SimplexNum
vm2VarVal) -> SimplexNum
vm2VarVal
                        (Maybe SimplexNum
Nothing, Maybe SimplexNum
Nothing) -> forall a. HasCallStack => [Char] -> a
error [Char]
"Reached unreachable branch in foldDictValue"
                    )
            )
            [Var]
combinedVars
  in  [VarLitMapSum] -> VarLitMapSum
foldVarLitMap forall a b. (a -> b) -> a -> b
$ VarLitMapSum
combinedVarMap forall a. a -> [a] -> [a]
: [VarLitMapSum]
vms

insertPivotObjectiveToDict :: PivotObjective -> Dict -> Dict
insertPivotObjectiveToDict :: PivotObjective -> Dict -> Dict
insertPivotObjectiveToDict PivotObjective
objective = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PivotObjective
objective.variable (DictValue {$sel:varMapSum:DictValue :: VarLitMapSum
varMapSum = PivotObjective
objective.function, $sel:constant:DictValue :: SimplexNum
constant = PivotObjective
objective.constant})

showT :: (Show a) => a -> T.Text
showT :: forall a. Show a => a -> Text
showT = [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show

logMsg :: (MonadIO m, MonadLogger m) => LogLevel -> T.Text -> m ()
logMsg :: forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogLevel -> Text -> m ()
logMsg LogLevel
lvl Text
msg = do
  Text
currTime <- [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. ISO8601 t => t -> [Char]
iso8601Show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  let msgToLog :: Text
msgToLog = Text
currTime forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
msg
  case LogLevel
lvl of
    LogLevel
LevelDebug -> $Var
[Char]
LogLevel
[Char] -> Text
[Char] -> [Char] -> [Char] -> CharPos -> CharPos -> Loc
Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
pack :: [Char] -> Text
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logDebug Text
msgToLog
    LogLevel
LevelInfo -> $Var
[Char]
LogLevel
[Char] -> Text
[Char] -> [Char] -> [Char] -> CharPos -> CharPos -> Loc
Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
pack :: [Char] -> Text
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logInfo Text
msgToLog
    LogLevel
LevelWarn -> $Var
[Char]
LogLevel
[Char] -> Text
[Char] -> [Char] -> [Char] -> CharPos -> CharPos -> Loc
Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
pack :: [Char] -> Text
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logWarn Text
msgToLog
    LogLevel
LevelError -> $Var
[Char]
LogLevel
[Char] -> Text
[Char] -> [Char] -> [Char] -> CharPos -> CharPos -> Loc
Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
pack :: [Char] -> Text
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logError Text
msgToLog
    LevelOther Text
otherLvl -> forall a. HasCallStack => [Char] -> a
error [Char]
"logMsg: LevelOther is not implemented"

extractTableauValues :: Tableau -> Map.Map Var SimplexNum
extractTableauValues :: Tableau -> VarLitMapSum
extractTableauValues = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (.rhs)

extractDictValues :: Dict -> Map.Map Var SimplexNum
extractDictValues :: Dict -> VarLitMapSum
extractDictValues = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (.constant)