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
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
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
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
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)
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
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
)
else
if SimplexNum
basicVarCoeff 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
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
)
Maybe SimplexNum
Nothing -> forall a. HasCallStack => String -> a
error String
"1"
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"
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
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
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
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 :: 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
( \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
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
}
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
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
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)
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
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 :: 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
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 ->
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)
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
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)