-- |
-- Module      : Linear.Simplex.Simplex.TwoPhase
-- Description : Implements the twoPhaseSimplex method
-- Copyright   : (c) Junaid Rasheed, 2020-2023
-- License     : BSD-3
-- Maintainer  : jrasheed178@gmail.com
-- Stability   : experimental
--
-- Module implementing the two-phase simplex method.
-- 'findFeasibleSolution' performs phase one of the two-phase simplex method.
-- 'optimizeFeasibleSystem' performs phase two of the two-phase simplex method.
-- 'twoPhaseSimplex' performs both phases of the two-phase simplex method.
module Linear.Simplex.Solver.TwoPhase (findFeasibleSolution, optimizeFeasibleSystem, twoPhaseSimplex) where

import Prelude hiding (EQ)

import Control.Lens
import Control.Monad (unless)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Logger
import Data.Bifunctor
import Data.List
import qualified Data.Map as M
import Data.Maybe (fromJust, fromMaybe, mapMaybe)
import Data.Ratio (denominator, numerator, (%))
import qualified Data.Text as Text
import GHC.Real (Ratio)
import Linear.Simplex.Types
import Linear.Simplex.Util

-- | Find a feasible solution for the given system of 'PolyConstraint's by performing the first phase of the two-phase simplex method
--  All variables in the 'PolyConstraint' must be positive.
--  If the system is infeasible, return 'Nothing'
--  Otherwise, return the feasible system in 'Dict' as well as a list of slack variables, a list artificial variables, and the objective variable.
findFeasibleSolution :: (MonadIO m, MonadLogger m) => [PolyConstraint] -> m (Maybe FeasibleSystem)
findFeasibleSolution :: forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
[PolyConstraint] -> m (Maybe FeasibleSystem)
findFeasibleSolution [PolyConstraint]
unsimplifiedSystem = do
  forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogLevel -> Text -> m ()
logMsg LogLevel
LevelInfo forall a b. (a -> b) -> a -> b
$ Text
"findFeasibleSolution: Looking for solution for " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT [PolyConstraint]
unsimplifiedSystem
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
artificialVars -- No artificial vars, we have a feasible system
    then do
      forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogLevel -> Text -> m ()
logMsg LogLevel
LevelInfo Text
"findFeasibleSolution: Feasible solution found with no artificial vars"
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Dict -> [Var] -> [Var] -> Var -> FeasibleSystem
FeasibleSystem Dict
systemWithBasicVarsAsDictionary [Var]
slackVars [Var]
artificialVars Var
objectiveVar
    else do
      forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogLevel -> Text -> m ()
logMsg LogLevel
LevelInfo forall a b. (a -> b) -> a -> b
$
        Text
"findFeasibleSolution: Needed to create artificial vars. System with artificial vars (in Tableau form) "
          forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT Tableau
systemWithBasicVars
      Maybe Dict
mPhase1Dict <- forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
PivotObjective -> Dict -> m (Maybe Dict)
simplexPivot PivotObjective
artificialPivotObjective Dict
systemWithBasicVarsAsDictionary
      case Maybe Dict
mPhase1Dict of
        Just Dict
phase1Dict -> do
          forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogLevel -> Text -> m ()
logMsg LogLevel
LevelInfo forall a b. (a -> b) -> a -> b
$
            Text
"findFeasibleSolution: System after pivoting with objective"
              forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT PivotObjective
artificialPivotObjective
              forall a. Semigroup a => a -> a -> a
<> Text
": "
              forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT Dict
phase1Dict
          let eliminateArtificialVarsFromPhase1Tableau :: Dict
eliminateArtificialVarsFromPhase1Tableau =
                forall a b k. (a -> b) -> Map k a -> Map k b
M.map
                  ( \DictValue {SimplexNum
VarLitMap
$sel:constant:DictValue :: DictValue -> SimplexNum
$sel:varMapSum:DictValue :: DictValue -> VarLitMap
constant :: SimplexNum
varMapSum :: VarLitMap
..} ->
                      DictValue
                        { $sel:varMapSum:DictValue :: VarLitMap
varMapSum = forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\Var
k SimplexNum
_ -> Var
k forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Var]
artificialVars) VarLitMap
varMapSum
                        , SimplexNum
$sel:constant:DictValue :: SimplexNum
constant :: SimplexNum
..
                        }
                  )
                  Dict
phase1Dict
          case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
objectiveVar Dict
eliminateArtificialVarsFromPhase1Tableau of
            Maybe DictValue
Nothing -> do
              forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogLevel -> Text -> m ()
logMsg LogLevel
LevelWarn forall a b. (a -> b) -> a -> b
$
                Text
"findFeasibleSolution: Objective row not found after eliminatiing artificial vars. This is unexpected. System without artificial vars (in Dict form) "
                  forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT Dict
eliminateArtificialVarsFromPhase1Tableau
              -- If the objecitve row is not found, the system is feasible iff
              -- the artificial vars sum to zero. The value of an artificial
              -- variable is 0 if non-basic, and the RHS of the row if basic
              let artificialVarsVals :: [SimplexNum]
artificialVarsVals = forall a b. (a -> b) -> [a] -> [b]
map (\Var
v -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe SimplexNum
0 (.constant) (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
v Dict
eliminateArtificialVarsFromPhase1Tableau)) [Var]
artificialVars
              let artificialVarsValsSum :: SimplexNum
artificialVarsValsSum = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [SimplexNum]
artificialVarsVals
              if SimplexNum
artificialVarsValsSum forall a. Eq a => a -> a -> Bool
== SimplexNum
0
                then do
                  forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogLevel -> Text -> m ()
logMsg LogLevel
LevelInfo forall a b. (a -> b) -> a -> b
$
                    Text
"findFeasibleSolution: Artifical variables sum up to 0, thus original tableau is feasible. System without artificial vars (in Dict form) "
                      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT Dict
eliminateArtificialVarsFromPhase1Tableau
                  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                    FeasibleSystem
                      { $sel:dict:FeasibleSystem :: Dict
dict = Dict
eliminateArtificialVarsFromPhase1Tableau
                      , $sel:slackVars:FeasibleSystem :: [Var]
slackVars = [Var]
slackVars
                      , $sel:artificialVars:FeasibleSystem :: [Var]
artificialVars = [Var]
artificialVars
                      , $sel:objectiveVar:FeasibleSystem :: Var
objectiveVar = Var
objectiveVar
                      }
                else do
                  forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogLevel -> Text -> m ()
logMsg LogLevel
LevelInfo forall a b. (a -> b) -> a -> b
$
                    Text
"findFeasibleSolution: Artifical variables sum up to "
                      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT SimplexNum
artificialVarsValsSum
                      forall a. Semigroup a => a -> a -> a
<> Text
", thus original tableau is infeasible. System without artificial vars (in Dict form) "
                      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT Dict
eliminateArtificialVarsFromPhase1Tableau
                  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            Just DictValue
row ->
              if DictValue
row.constant forall a. Eq a => a -> a -> Bool
== SimplexNum
0
                then do
                  forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogLevel -> Text -> m ()
logMsg LogLevel
LevelInfo forall a b. (a -> b) -> a -> b
$
                    Text
"findFeasibleSolution: Objective RHS is zero after pivoting, thus original tableau is feasible. feasible system (in Dict form) "
                      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT Dict
eliminateArtificialVarsFromPhase1Tableau
                  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                    FeasibleSystem
                      { $sel:dict:FeasibleSystem :: Dict
dict = Dict
eliminateArtificialVarsFromPhase1Tableau
                      , $sel:slackVars:FeasibleSystem :: [Var]
slackVars = [Var]
slackVars
                      , $sel:artificialVars:FeasibleSystem :: [Var]
artificialVars = [Var]
artificialVars
                      , $sel:objectiveVar:FeasibleSystem :: Var
objectiveVar = Var
objectiveVar
                      }
                else do
                  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DictValue
row.constant forall a. Ord a => a -> a -> Bool
< SimplexNum
0) forall a b. (a -> b) -> a -> b
$ do
                    let errMsg :: String
errMsg =
                          String
"findFeasibleSolution: Objective RHS is negative after pivoting. This should be impossible. System without artificial vars (in Dict form) "
                            forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Dict
eliminateArtificialVarsFromPhase1Tableau
                    forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogLevel -> Text -> m ()
logMsg LogLevel
LevelError forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
errMsg
                    forall a. HasCallStack => String -> a
error String
errMsg
                  forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogLevel -> Text -> m ()
logMsg LogLevel
LevelInfo forall a b. (a -> b) -> a -> b
$
                    Text
"findFeasibleSolution: Objective RHS not zero after phase 1, thus original tableau is infeasible. System without artificial vars (in Dict form) "
                      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT Dict
eliminateArtificialVarsFromPhase1Tableau
                  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        Maybe Dict
Nothing -> do
          forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogLevel -> Text -> m ()
logMsg LogLevel
LevelInfo forall a b. (a -> b) -> a -> b
$
            Text
"findFeasibleSolution: Infeasible solution found, could not pivot with objective "
              forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT PivotObjective
artificialPivotObjective
              forall a. Semigroup a => a -> a -> a
<> Text
" over system (in Dict form) "
              forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT Dict
systemWithBasicVarsAsDictionary
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
  where
    system :: [PolyConstraint]
system = [PolyConstraint] -> [PolyConstraint]
simplifySystem [PolyConstraint]
unsimplifiedSystem

    maxVar :: Var
maxVar =
      forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map
          ( \case
              LEQ VarLitMap
vcm SimplexNum
_ -> forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList VarLitMap
vcm)
              GEQ VarLitMap
vcm SimplexNum
_ -> forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList VarLitMap
vcm)
              EQ VarLitMap
vcm SimplexNum
_ -> forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList VarLitMap
vcm)
          )
          [PolyConstraint]
system

    ([(Maybe Var, PolyConstraint)]
systemWithSlackVars, [Var]
slackVars) = [PolyConstraint]
-> Var -> [Var] -> ([(Maybe Var, PolyConstraint)], [Var])
systemInStandardForm [PolyConstraint]
system Var
maxVar []

    maxVarWithSlackVars :: Var
maxVarWithSlackVars = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
slackVars then Var
maxVar else forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Var]
slackVars

    (Tableau
systemWithBasicVars, [Var]
artificialVars) = [(Maybe Var, PolyConstraint)] -> Var -> (Tableau, [Var])
systemWithArtificialVars [(Maybe Var, PolyConstraint)]
systemWithSlackVars Var
maxVarWithSlackVars

    finalMaxVar :: Var
finalMaxVar = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
artificialVars then Var
maxVarWithSlackVars else forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Var]
artificialVars

    systemWithBasicVarsAsDictionary :: Dict
systemWithBasicVarsAsDictionary = Tableau -> Dict
tableauInDictionaryForm Tableau
systemWithBasicVars

    artificialPivotObjective :: PivotObjective
artificialPivotObjective = Dict -> [Var] -> PivotObjective
createArtificialPivotObjective Dict
systemWithBasicVarsAsDictionary [Var]
artificialVars

    objectiveVar :: Var
objectiveVar = Var
finalMaxVar forall a. Num a => a -> a -> a
+ Var
1

    -- Convert a system of 'PolyConstraint's to standard form; a system of only equations ('EQ').
    -- Add slack vars where necessary.
    -- This may give you an infeasible system if slack vars are negative when original variables are zero.
    -- If a constraint is already EQ, set the basic var to Nothing.
    -- Final system is a list of equalities for the given system.
    -- To be feasible, all vars must be >= 0.
    systemInStandardForm :: [PolyConstraint] -> Var -> [Var] -> ([(Maybe Var, PolyConstraint)], [Var])
    systemInStandardForm :: [PolyConstraint]
-> Var -> [Var] -> ([(Maybe Var, PolyConstraint)], [Var])
systemInStandardForm [] Var
_ [Var]
sVars = ([], [Var]
sVars)
    systemInStandardForm (EQ VarLitMap
v SimplexNum
r : [PolyConstraint]
xs) Var
maxVar [Var]
sVars = ((forall a. Maybe a
Nothing, VarLitMap -> SimplexNum -> PolyConstraint
EQ VarLitMap
v SimplexNum
r) forall a. a -> [a] -> [a]
: [(Maybe Var, PolyConstraint)]
newSystem, [Var]
newSlackVars)
      where
        ([(Maybe Var, PolyConstraint)]
newSystem, [Var]
newSlackVars) = [PolyConstraint]
-> Var -> [Var] -> ([(Maybe Var, PolyConstraint)], [Var])
systemInStandardForm [PolyConstraint]
xs Var
maxVar [Var]
sVars
    systemInStandardForm (LEQ VarLitMap
v SimplexNum
r : [PolyConstraint]
xs) Var
maxVar [Var]
sVars = ((forall a. a -> Maybe a
Just Var
newSlackVar, VarLitMap -> SimplexNum -> PolyConstraint
EQ (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
newSlackVar SimplexNum
1 VarLitMap
v) SimplexNum
r) forall a. a -> [a] -> [a]
: [(Maybe Var, PolyConstraint)]
newSystem, [Var]
newSlackVars)
      where
        newSlackVar :: Var
newSlackVar = Var
maxVar forall a. Num a => a -> a -> a
+ Var
1
        ([(Maybe Var, PolyConstraint)]
newSystem, [Var]
newSlackVars) = [PolyConstraint]
-> Var -> [Var] -> ([(Maybe Var, PolyConstraint)], [Var])
systemInStandardForm [PolyConstraint]
xs Var
newSlackVar (Var
newSlackVar forall a. a -> [a] -> [a]
: [Var]
sVars)
    systemInStandardForm (GEQ VarLitMap
v SimplexNum
r : [PolyConstraint]
xs) Var
maxVar [Var]
sVars = ((forall a. a -> Maybe a
Just Var
newSlackVar, VarLitMap -> SimplexNum -> PolyConstraint
EQ (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
newSlackVar (-SimplexNum
1) VarLitMap
v) SimplexNum
r) forall a. a -> [a] -> [a]
: [(Maybe Var, PolyConstraint)]
newSystem, [Var]
newSlackVars)
      where
        newSlackVar :: Var
newSlackVar = Var
maxVar forall a. Num a => a -> a -> a
+ Var
1
        ([(Maybe Var, PolyConstraint)]
newSystem, [Var]
newSlackVars) = [PolyConstraint]
-> Var -> [Var] -> ([(Maybe Var, PolyConstraint)], [Var])
systemInStandardForm [PolyConstraint]
xs Var
newSlackVar (Var
newSlackVar forall a. a -> [a] -> [a]
: [Var]
sVars)

    -- Add artificial vars to a system of 'PolyConstraint's.
    -- Artificial vars are added when:
    --  Basic var is Nothing (When the original constraint was already an EQ).
    --  Slack var is equal to a negative value (this is infeasible, all vars need to be >= 0).
    --  Final system will be a feasible artificial system.
    -- We keep track of artificial vars in the second item of the returned pair so they can be eliminated once phase 1 is complete.
    -- If an artificial var would normally be negative, we negate the row so we can keep artificial variables equal to 1
    systemWithArtificialVars :: [(Maybe Var, PolyConstraint)] -> Var -> (Tableau, [Var])
    systemWithArtificialVars :: [(Maybe Var, PolyConstraint)] -> Var -> (Tableau, [Var])
systemWithArtificialVars [] Var
_ = (forall k a. Map k a
M.empty, [])
    systemWithArtificialVars ((Maybe Var
mVar, EQ VarLitMap
v SimplexNum
r) : [(Maybe Var, PolyConstraint)]
pcs) Var
maxVar =
      case Maybe Var
mVar of
        Maybe Var
Nothing ->
          if SimplexNum
r forall a. Ord a => a -> a -> Bool
>= SimplexNum
0
            then
              ( forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
newArtificialVar (TableauRow {$sel:lhs:TableauRow :: VarLitMap
lhs = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
newArtificialVar SimplexNum
1 VarLitMap
v, $sel:rhs:TableauRow :: SimplexNum
rhs = SimplexNum
r}) Tableau
newSystemWithNewMaxVar
              , Var
newArtificialVar forall a. a -> [a] -> [a]
: [Var]
artificialVarsWithNewMaxVar
              )
            else
              ( forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
newArtificialVar (TableauRow {$sel:lhs:TableauRow :: VarLitMap
lhs = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
newArtificialVar (-SimplexNum
1) VarLitMap
v, $sel:rhs:TableauRow :: SimplexNum
rhs = SimplexNum
r}) Tableau
newSystemWithNewMaxVar
              , Var
newArtificialVar forall a. a -> [a] -> [a]
: [Var]
artificialVarsWithNewMaxVar
              )
        Just Var
basicVar ->
          case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
basicVar VarLitMap
v of
            Just SimplexNum
basicVarCoeff ->
              if SimplexNum
r forall a. Eq a => a -> a -> Bool
== SimplexNum
0
                then (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
basicVar (TableauRow {$sel:lhs:TableauRow :: VarLitMap
lhs = VarLitMap
v, $sel:rhs:TableauRow :: SimplexNum
rhs = SimplexNum
r}) Tableau
newSystemWithoutNewMaxVar, [Var]
artificialVarsWithoutNewMaxVar)
                else
                  if SimplexNum
r forall a. Ord a => a -> a -> Bool
> SimplexNum
0
                    then
                      if SimplexNum
basicVarCoeff forall a. Ord a => a -> a -> Bool
>= SimplexNum
0 -- Should only be 1 in the standard call path
                        then (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
basicVar (TableauRow {$sel:lhs:TableauRow :: VarLitMap
lhs = VarLitMap
v, $sel:rhs:TableauRow :: SimplexNum
rhs = SimplexNum
r}) Tableau
newSystemWithoutNewMaxVar, [Var]
artificialVarsWithoutNewMaxVar)
                        else
                          ( forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
newArtificialVar (TableauRow {$sel:lhs:TableauRow :: VarLitMap
lhs = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
newArtificialVar SimplexNum
1 VarLitMap
v, $sel:rhs:TableauRow :: SimplexNum
rhs = SimplexNum
r}) Tableau
newSystemWithNewMaxVar
                          , Var
newArtificialVar forall a. a -> [a] -> [a]
: [Var]
artificialVarsWithNewMaxVar -- Slack var is negative, r is positive (when original constraint was GEQ)
                          )
                    else -- r < 0

                      if SimplexNum
basicVarCoeff forall a. Ord a => a -> a -> Bool
<= SimplexNum
0 -- Should only be -1 in the standard call path
                        then (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
basicVar (TableauRow {$sel:lhs:TableauRow :: VarLitMap
lhs = VarLitMap
v, $sel:rhs:TableauRow :: SimplexNum
rhs = SimplexNum
r}) Tableau
newSystemWithoutNewMaxVar, [Var]
artificialVarsWithoutNewMaxVar)
                        else
                          ( forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
newArtificialVar (TableauRow {$sel:lhs:TableauRow :: VarLitMap
lhs = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
newArtificialVar (-SimplexNum
1) VarLitMap
v, $sel:rhs:TableauRow :: SimplexNum
rhs = SimplexNum
r}) Tableau
newSystemWithNewMaxVar
                          , Var
newArtificialVar forall a. a -> [a] -> [a]
: [Var]
artificialVarsWithNewMaxVar -- Slack var is negative, r is negative (when original constraint was LEQ)
                          )
            Maybe SimplexNum
Nothing -> forall a. HasCallStack => String -> a
error String
"1" -- undefined
      where
        newArtificialVar :: Var
newArtificialVar = Var
maxVar forall a. Num a => a -> a -> a
+ Var
1

        (Tableau
newSystemWithNewMaxVar, [Var]
artificialVarsWithNewMaxVar) = [(Maybe Var, PolyConstraint)] -> Var -> (Tableau, [Var])
systemWithArtificialVars [(Maybe Var, PolyConstraint)]
pcs Var
newArtificialVar

        (Tableau
newSystemWithoutNewMaxVar, [Var]
artificialVarsWithoutNewMaxVar) = [(Maybe Var, PolyConstraint)] -> Var -> (Tableau, [Var])
systemWithArtificialVars [(Maybe Var, PolyConstraint)]
pcs Var
maxVar
    systemWithArtificialVars [(Maybe Var, PolyConstraint)]
_ Var
_ = forall a. HasCallStack => String -> a
error String
"systemWithArtificialVars: given system includes non-EQ constraints"

    -- \| Takes a 'Dict' and a '[Var]' as input and returns a 'PivotObjective'.
    -- The 'Dict' represents the tableau of a linear program with artificial
    -- variables, and '[Var]' represents the artificial variables.

    -- The function first filters out the rows of the tableau that correspond
    -- to the artificial variables, and negates them. It then computes the sum
    -- of the negated rows, which represents the 'PivotObjective'.
    createArtificialPivotObjective :: Dict -> [Var] -> PivotObjective
    createArtificialPivotObjective :: Dict -> [Var] -> PivotObjective
createArtificialPivotObjective Dict
rows [Var]
artificialVars =
      PivotObjective
        { $sel:variable:PivotObjective :: Var
variable = Var
objectiveVar
        , $sel:function:PivotObjective :: VarLitMap
function = [VarLitMap] -> VarLitMap
foldVarLitMap forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (.varMapSum) [DictValue]
negatedRowsWithoutArtificialVars
        , $sel:constant:PivotObjective :: SimplexNum
constant = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (.constant) [DictValue]
negatedRowsWithoutArtificialVars
        }
      where
        -- Filter out non-artificial entries
        rowsToAdd :: Dict
rowsToAdd = forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\Var
k DictValue
_ -> Var
k forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Var]
artificialVars) Dict
rows
        negatedRows :: Dict
negatedRows = forall a b k. (a -> b) -> Map k a -> Map k b
M.map (\(DictValue VarLitMap
rowVarMapSum SimplexNum
rowConstant) -> VarLitMap -> SimplexNum -> DictValue
DictValue (forall a b k. (a -> b) -> Map k a -> Map k b
M.map forall a. Num a => a -> a
negate VarLitMap
rowVarMapSum) (forall a. Num a => a -> a
negate SimplexNum
rowConstant)) Dict
rowsToAdd
        -- Negate rows, discard keys and artificial vars since the pivot objective does not care about them
        negatedRowsWithoutArtificialVars :: [DictValue]
negatedRowsWithoutArtificialVars =
          forall a b. (a -> b) -> [a] -> [b]
map
            ( \(Var
_, DictValue {SimplexNum
VarLitMap
constant :: SimplexNum
varMapSum :: VarLitMap
$sel:constant:DictValue :: DictValue -> SimplexNum
$sel:varMapSum:DictValue :: DictValue -> VarLitMap
..}) ->
                DictValue
                  { $sel:varMapSum:DictValue :: VarLitMap
varMapSum = forall a b k. (a -> b) -> Map k a -> Map k b
M.map forall a. Num a => a -> a
negate forall a b. (a -> b) -> a -> b
$ forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\Var
k SimplexNum
_ -> Var
k forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Var]
artificialVars) VarLitMap
varMapSum
                  , $sel:constant:DictValue :: SimplexNum
constant = forall a. Num a => a -> a
negate SimplexNum
constant
                  }
            )
            forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList Dict
rowsToAdd

-- | Optimize a feasible system by performing the second phase of the two-phase simplex method.
--  We first pass an 'ObjectiveFunction'.
--  Then, the feasible system in 'DictionaryForm' as well as a list of slack variables, a list artificial variables, and the objective variable.
--  Returns a pair with the first item being the 'Integer' variable equal to the 'ObjectiveFunction'
--  and the second item being a map of the values of all 'Integer' variables appearing in the system, including the 'ObjectiveFunction'.
optimizeFeasibleSystem :: (MonadIO m, MonadLogger m) => ObjectiveFunction -> FeasibleSystem -> m (Maybe Result)
optimizeFeasibleSystem :: forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
ObjectiveFunction -> FeasibleSystem -> m (Maybe Result)
optimizeFeasibleSystem ObjectiveFunction
objFunction fsys :: FeasibleSystem
fsys@(FeasibleSystem {$sel:dict:FeasibleSystem :: FeasibleSystem -> Dict
dict = Dict
phase1Dict, Var
[Var]
objectiveVar :: Var
artificialVars :: [Var]
slackVars :: [Var]
$sel:objectiveVar:FeasibleSystem :: FeasibleSystem -> Var
$sel:artificialVars:FeasibleSystem :: FeasibleSystem -> [Var]
$sel:slackVars:FeasibleSystem :: FeasibleSystem -> [Var]
..}) = do
  forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogLevel -> Text -> m ()
logMsg LogLevel
LevelInfo forall a b. (a -> b) -> a -> b
$
    Text
"optimizeFeasibleSystem: Optimizing feasible system " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT FeasibleSystem
fsys forall a. Semigroup a => a -> a -> a
<> Text
" with objective " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT ObjectiveFunction
objFunction
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
artificialVars
    then do
      forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogLevel -> Text -> m ()
logMsg LogLevel
LevelInfo forall a b. (a -> b) -> a -> b
$
        Text
"optimizeFeasibleSystem: No artificial vars, system is feasible. Pivoting system (in dict form) "
          forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT Dict
phase1Dict
          forall a. Semigroup a => a -> a -> a
<> Text
" with objective "
          forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT PivotObjective
normalObjective
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Tableau -> Result
displayResults forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dict -> Tableau
dictionaryFormToTableau) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
PivotObjective -> Dict -> m (Maybe Dict)
simplexPivot PivotObjective
normalObjective Dict
phase1Dict
    else do
      forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogLevel -> Text -> m ()
logMsg LogLevel
LevelInfo forall a b. (a -> b) -> a -> b
$
        Text
"optimizeFeasibleSystem: Artificial vars present. Pivoting system (in dict form) "
          forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT Dict
phase1Dict
          forall a. Semigroup a => a -> a -> a
<> Text
" with objective "
          forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT PivotObjective
adjustedObjective
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Tableau -> Result
displayResults forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dict -> Tableau
dictionaryFormToTableau) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
PivotObjective -> Dict -> m (Maybe Dict)
simplexPivot PivotObjective
adjustedObjective Dict
phase1Dict
  where
    -- \| displayResults takes a 'Tableau' and returns a 'Result'. The 'Tableau'
    -- represents the final tableau of a linear program after the simplex
    -- algorithm has been applied. The 'Result' contains the value of the
    -- objective variable and a map of the values of all variables appearing
    -- in the system, including the objective variable.
    --
    -- The function first filters out the rows of the tableau that correspond
    -- to the slack and artificial variables. It then extracts the values of
    -- the remaining variables and stores them in a map. If the objective
    -- function is a maximization problem, the map contains the values of the
    -- variables as they appear in the final tableau. If the objective function
    -- is a minimization problem, the map contains the values of the variables
    -- as they appear in the final tableau, except for the objective variable,
    -- which is negated.
    displayResults :: Tableau -> Result
    displayResults :: Tableau -> Result
displayResults Tableau
tableau =
      Result
        { $sel:objectiveVar:Result :: Var
objectiveVar = Var
objectiveVar
        , $sel:varValMap:Result :: VarLitMap
varValMap = VarLitMap
extractVarVals
        }
      where
        extractVarVals :: VarLitMap
extractVarVals =
          let tableauWithOriginalVars :: Tableau
tableauWithOriginalVars =
                forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey
                  ( \Var
basicVarName TableauRow
_ ->
                      Var
basicVarName forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Var]
slackVars forall a. [a] -> [a] -> [a]
++ [Var]
artificialVars
                  )
                  Tableau
tableau
          in  case ObjectiveFunction
objFunction of
                Max VarLitMap
_ ->
                  forall a b k. (a -> b) -> Map k a -> Map k b
M.map
                    ( \TableauRow
tableauRow ->
                        TableauRow
tableauRow.rhs
                    )
                    Tableau
tableauWithOriginalVars
                Min VarLitMap
_ ->
                  forall k a b. (k -> a -> b) -> Map k a -> Map k b
M.mapWithKey -- We maximized -objVar, so we negate the objVar to get the final value
                    ( \Var
basicVarName TableauRow
tableauRow ->
                        if Var
basicVarName forall a. Eq a => a -> a -> Bool
== Var
objectiveVar
                          then forall a. Num a => a -> a
negate forall a b. (a -> b) -> a -> b
$ TableauRow
tableauRow.rhs
                          else TableauRow
tableauRow.rhs
                    )
                    Tableau
tableauWithOriginalVars

    -- \| Objective to use when optimising the linear program if no artificial
    -- variables were necessary in the first phase. It is essentially the original
    -- objective function, with a potential change of sign based on the type of
    -- problem (Maximization or Minimization).
    normalObjective :: PivotObjective
    normalObjective :: PivotObjective
normalObjective =
      PivotObjective
        { $sel:variable:PivotObjective :: Var
variable = Var
objectiveVar
        , $sel:function:PivotObjective :: VarLitMap
function = if ObjectiveFunction -> Bool
isMax ObjectiveFunction
objFunction then ObjectiveFunction
objFunction.objective else forall a b k. (a -> b) -> Map k a -> Map k b
M.map forall a. Num a => a -> a
negate ObjectiveFunction
objFunction.objective
        , $sel:constant:PivotObjective :: SimplexNum
constant = SimplexNum
0
        }

    -- \| Objective to use when optimising the linear program if artificial
    -- variables were necessary in the first phase. It is an adjustment to the
    -- original objective function, where the linear coefficients are modified
    -- by back-substitution of the values of the artificial variables.
    adjustedObjective :: PivotObjective
    adjustedObjective :: PivotObjective
adjustedObjective =
      PivotObjective
        { $sel:variable:PivotObjective :: Var
variable = Var
objectiveVar
        , $sel:function:PivotObjective :: VarLitMap
function = VarLitMap
calcVarMap
        , $sel:constant:PivotObjective :: SimplexNum
constant = SimplexNum
calcConstants
        }
      where
        -- \| Compute the adjustment to the constant term of the objective
        -- function. It adds up the products of the original coefficients and
        -- the corresponding constant term (rhs) of each artificial variable
        -- in the phase 1 'Dict'.
        calcConstants :: SimplexNum
        calcConstants :: SimplexNum
calcConstants =
          forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
            forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map
              ( \(Var
var, SimplexNum
coeff) ->
                  let multiplyWith :: SimplexNum
multiplyWith = if ObjectiveFunction -> Bool
isMax ObjectiveFunction
objFunction then SimplexNum
coeff else -SimplexNum
coeff
                  in  case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
var Dict
phase1Dict of
                        Maybe DictValue
Nothing -> SimplexNum
0
                        Just DictValue
row -> DictValue
row.constant forall a. Num a => a -> a -> a
* SimplexNum
multiplyWith
              )
            forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList ObjectiveFunction
objFunction.objective

        -- \| Compute the adjustment to the coefficients of the original
        -- variables in the objective function. It performs back-substitution
        -- of the variables in the original objective function using the
        -- current value of each artificial variable in the phase 1 'Dict'.
        calcVarMap :: VarLitMapSum
        calcVarMap :: VarLitMap
calcVarMap =
          [VarLitMap] -> VarLitMap
foldVarLitMap forall a b. (a -> b) -> a -> b
$
            forall a b. (a -> b) -> [a] -> [b]
map
              ( forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. ( \(Var
var, SimplexNum
coeff) ->
                        let multiplyWith :: SimplexNum
multiplyWith = if ObjectiveFunction -> Bool
isMax ObjectiveFunction
objFunction then SimplexNum
coeff else -SimplexNum
coeff
                        in  case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
var Dict
phase1Dict of
                              Maybe DictValue
Nothing ->
                                [(Var
var, SimplexNum
multiplyWith)]
                              Just DictValue
row -> forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a. Num a => a -> a -> a
* SimplexNum
multiplyWith)) (forall k a. Map k a -> [(k, a)]
M.toList forall a b. (a -> b) -> a -> b
$ DictValue
row.varMapSum)
                    )
              )
              (forall k a. Map k a -> [(k, a)]
M.toList ObjectiveFunction
objFunction.objective)

-- | Perform the two phase simplex method with a given 'ObjectiveFunction' a system of 'PolyConstraint's.
--  Assumes the 'ObjectiveFunction' and 'PolyConstraint' is not empty.
--  Returns a pair with the first item being the 'Integer' variable equal to the 'ObjectiveFunction'
--  and the second item being a map of the values of all 'Integer' variables appearing in the system, including the 'ObjectiveFunction'.
twoPhaseSimplex :: (MonadIO m, MonadLogger m) => ObjectiveFunction -> [PolyConstraint] -> m (Maybe Result)
twoPhaseSimplex :: forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
ObjectiveFunction -> [PolyConstraint] -> m (Maybe Result)
twoPhaseSimplex ObjectiveFunction
objFunction [PolyConstraint]
unsimplifiedSystem = do
  forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogLevel -> Text -> m ()
logMsg LogLevel
LevelInfo forall a b. (a -> b) -> a -> b
$
    Text
"twoPhaseSimplex: Solving system " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT [PolyConstraint]
unsimplifiedSystem forall a. Semigroup a => a -> a -> a
<> Text
" with objective " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT ObjectiveFunction
objFunction
  Maybe FeasibleSystem
phase1Result <- forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
[PolyConstraint] -> m (Maybe FeasibleSystem)
findFeasibleSolution [PolyConstraint]
unsimplifiedSystem
  case Maybe FeasibleSystem
phase1Result of
    Just FeasibleSystem
feasibleSystem -> do
      forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogLevel -> Text -> m ()
logMsg LogLevel
LevelInfo forall a b. (a -> b) -> a -> b
$
        Text
"twoPhaseSimplex: Feasible system found for "
          forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT [PolyConstraint]
unsimplifiedSystem
          forall a. Semigroup a => a -> a -> a
<> Text
"; Feasible system: "
          forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT FeasibleSystem
feasibleSystem
      Maybe Result
optimizedSystem <- forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
ObjectiveFunction -> FeasibleSystem -> m (Maybe Result)
optimizeFeasibleSystem ObjectiveFunction
objFunction FeasibleSystem
feasibleSystem
      forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogLevel -> Text -> m ()
logMsg LogLevel
LevelInfo forall a b. (a -> b) -> a -> b
$
        Text
"twoPhaseSimplex: Optimized system found for "
          forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT [PolyConstraint]
unsimplifiedSystem
          forall a. Semigroup a => a -> a -> a
<> Text
"; Optimized system: "
          forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT Maybe Result
optimizedSystem
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Result
optimizedSystem
    Maybe FeasibleSystem
Nothing -> do
      forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogLevel -> Text -> m ()
logMsg LogLevel
LevelInfo forall a b. (a -> b) -> a -> b
$ Text
"twoPhaseSimplex: Phase 1 gives infeasible result for " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT [PolyConstraint]
unsimplifiedSystem
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

-- | Perform the simplex pivot algorithm on a system with basic vars, assume that the first row is the 'ObjectiveFunction'.
simplexPivot :: (MonadIO m, MonadLogger m) => PivotObjective -> Dict -> m (Maybe Dict)
simplexPivot :: forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
PivotObjective -> Dict -> m (Maybe Dict)
simplexPivot objective :: PivotObjective
objective@(PivotObjective {$sel:variable:PivotObjective :: PivotObjective -> Var
variable = Var
objectiveVar, $sel:function:PivotObjective :: PivotObjective -> VarLitMap
function = VarLitMap
objectiveFunc, $sel:constant:PivotObjective :: PivotObjective -> SimplexNum
constant = SimplexNum
objectiveConstant}) Dict
dictionary = do
  forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogLevel -> Text -> m ()
logMsg LogLevel
LevelInfo forall a b. (a -> b) -> a -> b
$
    Text
"simplexPivot: Pivoting with objective " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT PivotObjective
objective forall a. Semigroup a => a -> a -> a
<> Text
" over system (in Dict form) " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT Dict
dictionary
  case VarLitMap -> Maybe Var
mostPositive VarLitMap
objectiveFunc of
    Maybe Var
Nothing -> do
      forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogLevel -> Text -> m ()
logMsg LogLevel
LevelInfo forall a b. (a -> b) -> a -> b
$
        Text
"simplexPivot: Pivoting complete as no positive variables found in objective "
          forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT PivotObjective
objective
          forall a. Semigroup a => a -> a -> a
<> Text
" over system (in Dict form) "
          forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT Dict
dictionary
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (PivotObjective -> Dict -> Dict
insertPivotObjectiveToDict PivotObjective
objective Dict
dictionary)
    Just Var
pivotNonBasicVar -> do
      forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogLevel -> Text -> m ()
logMsg LogLevel
LevelInfo forall a b. (a -> b) -> a -> b
$
        Text
"simplexPivot: Non-basic pivoting variable in objective, determined by largest coefficient = " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT Var
pivotNonBasicVar
      let mPivotBasicVar :: Maybe Var
mPivotBasicVar = Dict -> Var -> Maybe Var -> Maybe SimplexNum -> Maybe Var
ratioTest Dict
dictionary Var
pivotNonBasicVar forall a. Maybe a
Nothing forall a. Maybe a
Nothing
      case Maybe Var
mPivotBasicVar of
        Maybe Var
Nothing -> do
          forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogLevel -> Text -> m ()
logMsg LogLevel
LevelInfo forall a b. (a -> b) -> a -> b
$
            Text
"simplexPivot: Ratio test failed with non-basic variable "
              forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT Var
pivotNonBasicVar
              forall a. Semigroup a => a -> a -> a
<> Text
" over system (in Dict form) "
              forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT Dict
dictionary
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        Just Var
pivotBasicVar -> do
          forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogLevel -> Text -> m ()
logMsg LogLevel
LevelInfo forall a b. (a -> b) -> a -> b
$ Text
"simplexPivot: Basic pivoting variable determined by ratio test " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT Var
pivotBasicVar
          forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogLevel -> Text -> m ()
logMsg LogLevel
LevelInfo forall a b. (a -> b) -> a -> b
$
            Text
"simplexPivot: Pivoting with basic var "
              forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT Var
pivotBasicVar
              forall a. Semigroup a => a -> a -> a
<> Text
", non-basic var "
              forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT Var
pivotNonBasicVar
              forall a. Semigroup a => a -> a -> a
<> Text
", objective "
              forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT PivotObjective
objective
              forall a. Semigroup a => a -> a -> a
<> Text
" over system (in Dict form) "
              forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT Dict
dictionary
          let pivotResult :: Dict
pivotResult = Var -> Var -> Dict -> Dict
pivot Var
pivotBasicVar Var
pivotNonBasicVar (PivotObjective -> Dict -> Dict
insertPivotObjectiveToDict PivotObjective
objective Dict
dictionary)
              pivotedObj :: PivotObjective
pivotedObj =
                let pivotedObjEntry :: DictValue
pivotedObjEntry = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"simplexPivot: Can't find objective after pivoting") forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
objectiveVar Dict
pivotResult
                in  PivotObjective
objective forall a b. a -> (a -> b) -> b
& forall a. IsLabel "function" a => a
#function forall s t a b. ASetter s t a b -> b -> s -> t
.~ DictValue
pivotedObjEntry.varMapSum forall a b. a -> (a -> b) -> b
& forall a. IsLabel "constant" a => a
#constant forall s t a b. ASetter s t a b -> b -> s -> t
.~ DictValue
pivotedObjEntry.constant
              pivotedDict :: Dict
pivotedDict = forall k a. Ord k => k -> Map k a -> Map k a
M.delete Var
objectiveVar Dict
pivotResult
          forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
LogLevel -> Text -> m ()
logMsg LogLevel
LevelInfo forall a b. (a -> b) -> a -> b
$
            Text
"simplexPivot: Pivoted, Recursing with new pivoting objective "
              forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT PivotObjective
pivotedObj
              forall a. Semigroup a => a -> a -> a
<> Text
" for new pivoted system (in Dict form) "
              forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT Dict
pivotedDict
          forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
PivotObjective -> Dict -> m (Maybe Dict)
simplexPivot
            PivotObjective
pivotedObj
            Dict
pivotedDict
  where
    ratioTest :: Dict -> Var -> Maybe Var -> Maybe Rational -> Maybe Var
    ratioTest :: Dict -> Var -> Maybe Var -> Maybe SimplexNum -> Maybe Var
ratioTest Dict
dict = [(Var, DictValue)]
-> Var -> Maybe Var -> Maybe SimplexNum -> Maybe Var
aux (forall k a. Map k a -> [(k, a)]
M.toList Dict
dict)
      where
        aux :: [(Var, DictValue)] -> Var -> Maybe Var -> Maybe Rational -> Maybe Var
        aux :: [(Var, DictValue)]
-> Var -> Maybe Var -> Maybe SimplexNum -> Maybe Var
aux [] Var
_ Maybe Var
mCurrentMinBasicVar Maybe SimplexNum
_ = Maybe Var
mCurrentMinBasicVar
        aux (x :: (Var, DictValue)
x@(Var
basicVar, DictValue
dictEquation) : [(Var, DictValue)]
xs) Var
mostNegativeVar Maybe Var
mCurrentMinBasicVar Maybe SimplexNum
mCurrentMin =
          case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
mostNegativeVar DictValue
dictEquation.varMapSum of
            Maybe SimplexNum
Nothing -> [(Var, DictValue)]
-> Var -> Maybe Var -> Maybe SimplexNum -> Maybe Var
aux [(Var, DictValue)]
xs Var
mostNegativeVar Maybe Var
mCurrentMinBasicVar Maybe SimplexNum
mCurrentMin
            Just SimplexNum
currentCoeff ->
              let dictEquationConstant :: SimplexNum
dictEquationConstant = DictValue
dictEquation.constant
              in  if SimplexNum
currentCoeff forall a. Ord a => a -> a -> Bool
>= SimplexNum
0 Bool -> Bool -> Bool
|| SimplexNum
dictEquationConstant forall a. Ord a => a -> a -> Bool
< SimplexNum
0
                    then [(Var, DictValue)]
-> Var -> Maybe Var -> Maybe SimplexNum -> Maybe Var
aux [(Var, DictValue)]
xs Var
mostNegativeVar Maybe Var
mCurrentMinBasicVar Maybe SimplexNum
mCurrentMin
                    else case Maybe SimplexNum
mCurrentMin of
                      Maybe SimplexNum
Nothing -> [(Var, DictValue)]
-> Var -> Maybe Var -> Maybe SimplexNum -> Maybe Var
aux [(Var, DictValue)]
xs Var
mostNegativeVar (forall a. a -> Maybe a
Just Var
basicVar) (forall a. a -> Maybe a
Just (SimplexNum
dictEquationConstant forall a. Fractional a => a -> a -> a
/ SimplexNum
currentCoeff))
                      Just SimplexNum
currentMin ->
                        if (SimplexNum
dictEquationConstant forall a. Fractional a => a -> a -> a
/ SimplexNum
currentCoeff) forall a. Ord a => a -> a -> Bool
>= SimplexNum
currentMin
                          then [(Var, DictValue)]
-> Var -> Maybe Var -> Maybe SimplexNum -> Maybe Var
aux [(Var, DictValue)]
xs Var
mostNegativeVar (forall a. a -> Maybe a
Just Var
basicVar) (forall a. a -> Maybe a
Just (SimplexNum
dictEquationConstant forall a. Fractional a => a -> a -> a
/ SimplexNum
currentCoeff))
                          else [(Var, DictValue)]
-> Var -> Maybe Var -> Maybe SimplexNum -> Maybe Var
aux [(Var, DictValue)]
xs Var
mostNegativeVar Maybe Var
mCurrentMinBasicVar Maybe SimplexNum
mCurrentMin

    mostPositive :: VarLitMapSum -> Maybe Var
    mostPositive :: VarLitMap -> Maybe Var
mostPositive VarLitMap
varLitMap =
      case [(Var, SimplexNum)]
-> Maybe (Var, SimplexNum) -> Maybe (Var, SimplexNum)
findLargestCoeff (forall k a. Map k a -> [(k, a)]
M.toList VarLitMap
varLitMap) forall a. Maybe a
Nothing of
        Just (Var
largestVarName, SimplexNum
largestVarCoeff) ->
          if SimplexNum
largestVarCoeff forall a. Ord a => a -> a -> Bool
<= SimplexNum
0
            then forall a. Maybe a
Nothing
            else forall a. a -> Maybe a
Just Var
largestVarName
        Maybe (Var, SimplexNum)
Nothing -> forall a. Maybe a
Nothing
      where
        findLargestCoeff :: [(Var, SimplexNum)] -> Maybe (Var, SimplexNum) -> Maybe (Var, SimplexNum)
        findLargestCoeff :: [(Var, SimplexNum)]
-> Maybe (Var, SimplexNum) -> Maybe (Var, SimplexNum)
findLargestCoeff [] Maybe (Var, SimplexNum)
mCurrentMax = Maybe (Var, SimplexNum)
mCurrentMax
        findLargestCoeff (v :: (Var, SimplexNum)
v@(Var
vName, SimplexNum
vCoeff) : [(Var, SimplexNum)]
vs) Maybe (Var, SimplexNum)
mCurrentMax =
          case Maybe (Var, SimplexNum)
mCurrentMax of
            Maybe (Var, SimplexNum)
Nothing -> [(Var, SimplexNum)]
-> Maybe (Var, SimplexNum) -> Maybe (Var, SimplexNum)
findLargestCoeff [(Var, SimplexNum)]
vs (forall a. a -> Maybe a
Just (Var, SimplexNum)
v)
            Just (Var
_, SimplexNum
currentMaxCoeff) ->
              if SimplexNum
currentMaxCoeff forall a. Ord a => a -> a -> Bool
>= SimplexNum
vCoeff
                then [(Var, SimplexNum)]
-> Maybe (Var, SimplexNum) -> Maybe (Var, SimplexNum)
findLargestCoeff [(Var, SimplexNum)]
vs Maybe (Var, SimplexNum)
mCurrentMax
                else [(Var, SimplexNum)]
-> Maybe (Var, SimplexNum) -> Maybe (Var, SimplexNum)
findLargestCoeff [(Var, SimplexNum)]
vs (forall a. a -> Maybe a
Just (Var, SimplexNum)
v)

    -- Pivot a dictionary using the two given variables.
    -- The first variable is the leaving (non-basic) variable.
    -- The second variable is the entering (basic) variable.
    -- Expects the entering variable to be present in the row containing the leaving variable.
    -- Expects each row to have a unique basic variable.
    -- Expects each basic variable to not appear on the RHS of any equation.
    pivot :: Var -> Var -> Dict -> Dict
    pivot :: Var -> Var -> Dict -> Dict
pivot Var
leavingVariable Var
enteringVariable Dict
dict =
      case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
enteringVariable (DictValue
dictEntertingRow.varMapSum) of
        Just SimplexNum
enteringVariableCoeff ->
          Dict
updatedRows
          where
            -- Move entering variable to basis, update other variables in row appropriately
            pivotEnteringRow :: DictValue
            pivotEnteringRow :: DictValue
pivotEnteringRow =
              DictValue
dictEntertingRow
                forall a b. a -> (a -> b) -> b
& forall a. IsLabel "varMapSum" a => a
#varMapSum
                  forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ( \VarLitMap
basicEquation ->
                        -- uncurry
                        forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert
                          Var
leavingVariable
                          (-SimplexNum
1)
                          (forall {a}. Map Var a -> Map Var a
filterOutEnteringVarTerm VarLitMap
basicEquation)
                          forall a b. a -> (a -> b) -> b
& forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
                            forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ SimplexNum -> SimplexNum
divideByNegatedEnteringVariableCoeff
                     )
                forall a b. a -> (a -> b) -> b
& forall a. IsLabel "constant" a => a
#constant
                  forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ SimplexNum -> SimplexNum
divideByNegatedEnteringVariableCoeff
              where
                newEnteringVarTerm :: (Var, Integer)
newEnteringVarTerm = (Var
leavingVariable, -Integer
1)
                divideByNegatedEnteringVariableCoeff :: SimplexNum -> SimplexNum
divideByNegatedEnteringVariableCoeff = (forall a. Fractional a => a -> a -> a
/ forall a. Num a => a -> a
negate SimplexNum
enteringVariableCoeff)

            -- Substitute pivot equation into other rows
            updatedRows :: Dict
            updatedRows :: Dict
updatedRows =
              forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Var -> DictValue -> (Var, DictValue)
f2) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList Dict
dict
              where
                f :: Var -> DictValue -> DictValue
f Var
entryVar DictValue
entryVal =
                  if Var
leavingVariable forall a. Eq a => a -> a -> Bool
== Var
entryVar
                    then DictValue
pivotEnteringRow
                    else case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
enteringVariable (DictValue
entryVal.varMapSum) of
                      Just SimplexNum
subsCoeff ->
                        DictValue
entryVal
                          forall a b. a -> (a -> b) -> b
& forall a. IsLabel "varMapSum" a => a
#varMapSum
                            forall s t a b. ASetter s t a b -> b -> s -> t
.~ VarLitMap -> VarLitMap -> VarLitMap
combineVarLitMapSums
                              (DictValue
pivotEnteringRow.varMapSum forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (SimplexNum
subsCoeff forall a. Num a => a -> a -> a
*))
                              (forall {a}. Map Var a -> Map Var a
filterOutEnteringVarTerm (DictValue
entryVal.varMapSum))
                          forall a b. a -> (a -> b) -> b
& forall a. IsLabel "constant" a => a
#constant
                            forall s t a b. ASetter s t a b -> b -> s -> t
.~ ((SimplexNum
subsCoeff forall a. Num a => a -> a -> a
* (DictValue
pivotEnteringRow.constant)) forall a. Num a => a -> a -> a
+ DictValue
entryVal.constant)
                      Maybe SimplexNum
Nothing -> DictValue
entryVal

                f2 :: Var -> DictValue -> (Var, DictValue)
                f2 :: Var -> DictValue -> (Var, DictValue)
f2 Var
entryVar DictValue
entryVal =
                  if Var
leavingVariable forall a. Eq a => a -> a -> Bool
== Var
entryVar
                    then (Var
enteringVariable, DictValue
pivotEnteringRow)
                    else case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
enteringVariable (DictValue
entryVal.varMapSum) of
                      Just SimplexNum
subsCoeff ->
                        ( Var
entryVar
                        , DictValue
entryVal
                            forall a b. a -> (a -> b) -> b
& forall a. IsLabel "varMapSum" a => a
#varMapSum
                              forall s t a b. ASetter s t a b -> b -> s -> t
.~ VarLitMap -> VarLitMap -> VarLitMap
combineVarLitMapSums
                                (DictValue
pivotEnteringRow.varMapSum forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (SimplexNum
subsCoeff forall a. Num a => a -> a -> a
*))
                                (forall {a}. Map Var a -> Map Var a
filterOutEnteringVarTerm (DictValue
entryVal.varMapSum))
                            forall a b. a -> (a -> b) -> b
& forall a. IsLabel "constant" a => a
#constant
                              forall s t a b. ASetter s t a b -> b -> s -> t
.~ ((SimplexNum
subsCoeff forall a. Num a => a -> a -> a
* (DictValue
pivotEnteringRow.constant)) forall a. Num a => a -> a -> a
+ DictValue
entryVal.constant)
                        )
                      Maybe SimplexNum
Nothing -> (Var
entryVar, DictValue
entryVal)
        Maybe SimplexNum
Nothing -> forall a. HasCallStack => String -> a
error String
"pivot: non basic variable not found in basic row"
      where
        -- \| The entering row, i.e., the row in the dict which is the value of
        -- leavingVariable.
        dictEntertingRow :: DictValue
dictEntertingRow =
          forall a. a -> Maybe a -> a
fromMaybe
            (forall a. HasCallStack => String -> a
error String
"pivot: Basic variable not found in Dict")
            forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
leavingVariable Dict
dict

        filterOutEnteringVarTerm :: Map Var a -> Map Var a
filterOutEnteringVarTerm = forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\Var
vName a
_ -> Var
vName forall a. Eq a => a -> a -> Bool
/= Var
enteringVariable)