{-# LANGUAGE LambdaCase #-}

{-|
Module      : Linear.Simplex.Util
Description : Helper functions
Copyright   : (c) Junaid Rasheed, 2020-2022
License     : BSD-3
Maintainer  : jrasheed178@gmail.com
Stability   : experimental

Helper functions for performing the two-phase simplex method.
-}
module Linear.Simplex.Util where

import Prelude hiding (EQ);
import Linear.Simplex.Types
import Data.List
import Data.Bifunctor

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

-- |Extract the objective ('VarConstMap') from an 'ObjectiveFunction'
getObjective :: ObjectiveFunction -> VarConstMap
getObjective :: ObjectiveFunction -> VarConstMap
getObjective (Max VarConstMap
o) = VarConstMap
o
getObjective (Min VarConstMap
o) = VarConstMap
o

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

-- |Simplify an 'ObjectiveFunction' by first 'sort'ing and then calling 'foldSumVarConstMap' on the 'VarConstMap'.
simplifyObjectiveFunction :: ObjectiveFunction -> ObjectiveFunction
simplifyObjectiveFunction :: ObjectiveFunction -> ObjectiveFunction
simplifyObjectiveFunction (Max VarConstMap
varConstMap) = VarConstMap -> ObjectiveFunction
Max (VarConstMap -> VarConstMap
foldSumVarConstMap (VarConstMap -> VarConstMap
forall a. Ord a => [a] -> [a]
sort VarConstMap
varConstMap))
simplifyObjectiveFunction (Min VarConstMap
varConstMap) = VarConstMap -> ObjectiveFunction
Min (VarConstMap -> VarConstMap
foldSumVarConstMap (VarConstMap -> VarConstMap
forall a. Ord a => [a] -> [a]
sort VarConstMap
varConstMap))

-- |Simplify a 'PolyConstraint' by first 'sort'ing and then calling 'foldSumVarConstMap' on the 'VarConstMap'. 
simplifyPolyConstraint :: PolyConstraint -> PolyConstraint
simplifyPolyConstraint :: PolyConstraint -> PolyConstraint
simplifyPolyConstraint (LEQ VarConstMap
varConstMap Rational
rhs) = VarConstMap -> Rational -> PolyConstraint
LEQ (VarConstMap -> VarConstMap
foldSumVarConstMap (VarConstMap -> VarConstMap
forall a. Ord a => [a] -> [a]
sort VarConstMap
varConstMap)) Rational
rhs
simplifyPolyConstraint (GEQ VarConstMap
varConstMap Rational
rhs) = VarConstMap -> Rational -> PolyConstraint
GEQ (VarConstMap -> VarConstMap
foldSumVarConstMap (VarConstMap -> VarConstMap
forall a. Ord a => [a] -> [a]
sort VarConstMap
varConstMap)) Rational
rhs
simplifyPolyConstraint (EQ VarConstMap
varConstMap Rational
rhs)  = VarConstMap -> Rational -> PolyConstraint
EQ (VarConstMap -> VarConstMap
foldSumVarConstMap (VarConstMap -> VarConstMap
forall a. Ord a => [a] -> [a]
sort VarConstMap
varConstMap)) Rational
rhs

-- |Add a sorted list of 'VarConstMap's, folding where the variables are equal
foldSumVarConstMap :: [(Integer, Rational)] -> [(Integer, Rational)]
foldSumVarConstMap :: VarConstMap -> VarConstMap
foldSumVarConstMap []                          = []
foldSumVarConstMap [(Integer
v, Rational
c)]                    = [(Integer
v, Rational
c)]
foldSumVarConstMap ((Integer
v1, Rational
c1) : (Integer
v2, Rational
c2) : VarConstMap
vcm) =
  if Integer
v1 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
v2
    then 
      let newC :: Rational
newC = Rational
c1 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
c2
      in
        if Rational
newC Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== Rational
0
          then VarConstMap -> VarConstMap
foldSumVarConstMap VarConstMap
vcm
          else VarConstMap -> VarConstMap
foldSumVarConstMap (VarConstMap -> VarConstMap) -> VarConstMap -> VarConstMap
forall a b. (a -> b) -> a -> b
$ (Integer
v1, Rational
c1 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
c2) (Integer, Rational) -> VarConstMap -> VarConstMap
forall a. a -> [a] -> [a]
: VarConstMap
vcm
    else (Integer
v1, Rational
c1) (Integer, Rational) -> VarConstMap -> VarConstMap
forall a. a -> [a] -> [a]
: VarConstMap -> VarConstMap
foldSumVarConstMap ((Integer
v2, Rational
c2) (Integer, Rational) -> VarConstMap -> VarConstMap
forall a. a -> [a] -> [a]
: VarConstMap
vcm)

-- |Get a map of the value of every 'Integer' variable in a 'Tableau'
displayTableauResults :: Tableau -> [(Integer, Rational)]
displayTableauResults :: Tableau -> VarConstMap
displayTableauResults = ((Integer, (VarConstMap, Rational)) -> (Integer, Rational))
-> Tableau -> VarConstMap
forall a b. (a -> b) -> [a] -> [b]
map (\(Integer
basicVar, (VarConstMap
_, Rational
rhs)) -> (Integer
basicVar, Rational
rhs))

-- |Get a map of the value of every 'Integer' variable in a 'DictionaryForm'
displayDictionaryResults :: DictionaryForm -> [(Integer, Rational)]
displayDictionaryResults :: DictionaryForm -> VarConstMap
displayDictionaryResults DictionaryForm
dict = Tableau -> VarConstMap
displayTableauResults(Tableau -> VarConstMap) -> Tableau -> VarConstMap
forall a b. (a -> b) -> a -> b
$ DictionaryForm -> Tableau
dictionaryFormToTableau DictionaryForm
dict

-- |Map the given 'Integer' variable to the given 'ObjectiveFunction', for entering into 'DictionaryForm'.
createObjectiveDict :: ObjectiveFunction -> Integer -> (Integer, VarConstMap)
createObjectiveDict :: ObjectiveFunction -> Integer -> (Integer, VarConstMap)
createObjectiveDict (Max VarConstMap
obj) Integer
objectiveVar = (Integer
objectiveVar, VarConstMap
obj)
createObjectiveDict (Min VarConstMap
obj) Integer
objectiveVar = (Integer
objectiveVar, ((Integer, Rational) -> (Integer, Rational))
-> VarConstMap -> VarConstMap
forall a b. (a -> b) -> [a] -> [b]
map ((Rational -> Rational)
-> (Integer, Rational) -> (Integer, Rational)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Rational -> Rational
forall a. Num a => a -> a
negate) VarConstMap
obj)

-- |Converts a 'Tableau' to 'DictionaryForm'.
-- We do this by isolating the basic variable on the LHS, ending up with all non basic variables and a 'Rational' constant on the RHS.
-- (-1) is used to represent the rational constant.
tableauInDictionaryForm :: Tableau -> DictionaryForm
tableauInDictionaryForm :: Tableau -> DictionaryForm
tableauInDictionaryForm []                      = []
tableauInDictionaryForm ((Integer
basicVar, (VarConstMap
vcm, Rational
r)) : Tableau
rows)  =
  (Integer
basicVar, (-Integer
1, Rational
r Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
basicCoeff) (Integer, Rational) -> VarConstMap -> VarConstMap
forall a. a -> [a] -> [a]
: ((Integer, Rational) -> (Integer, Rational))
-> VarConstMap -> VarConstMap
forall a b. (a -> b) -> [a] -> [b]
map (\(Integer
v, Rational
c) -> (Integer
v, Rational -> Rational
forall a. Num a => a -> a
negate Rational
c Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
basicCoeff)) VarConstMap
nonBasicVars) (Integer, VarConstMap) -> DictionaryForm -> DictionaryForm
forall a. a -> [a] -> [a]
: Tableau -> DictionaryForm
tableauInDictionaryForm Tableau
rows
  where
    basicCoeff :: Rational
basicCoeff = if VarConstMap -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null VarConstMap
basicVars then Rational
1 else (Integer, Rational) -> Rational
forall a b. (a, b) -> b
snd ((Integer, Rational) -> Rational)
-> (Integer, Rational) -> Rational
forall a b. (a -> b) -> a -> b
$ VarConstMap -> (Integer, Rational)
forall a. [a] -> a
head VarConstMap
basicVars
    (VarConstMap
basicVars, VarConstMap
nonBasicVars) = ((Integer, Rational) -> Bool)
-> VarConstMap -> (VarConstMap, VarConstMap)
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\(Integer
v, Rational
_) -> Integer
v Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
basicVar) VarConstMap
vcm

-- |Converts a 'DictionaryForm' to a 'Tableau'.
-- This is done by moving all non-basic variables from the right to the left.
-- The rational constant (represented by the 'Integer' variable -1) stays on the right.
-- The basic variables will have a coefficient of 1 in the 'Tableau'.
dictionaryFormToTableau :: DictionaryForm -> Tableau
dictionaryFormToTableau :: DictionaryForm -> Tableau
dictionaryFormToTableau [] = []
dictionaryFormToTableau ((Integer
basicVar, VarConstMap
row) : DictionaryForm
rows) = 
    (Integer
basicVar, ((Integer
basicVar, Rational
1) (Integer, Rational) -> VarConstMap -> VarConstMap
forall a. a -> [a] -> [a]
: ((Integer, Rational) -> (Integer, Rational))
-> VarConstMap -> VarConstMap
forall a b. (a -> b) -> [a] -> [b]
map ((Rational -> Rational)
-> (Integer, Rational) -> (Integer, Rational)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Rational -> Rational
forall a. Num a => a -> a
negate) VarConstMap
nonBasicVars, Rational
r)) (Integer, (VarConstMap, Rational)) -> Tableau -> Tableau
forall a. a -> [a] -> [a]
: DictionaryForm -> Tableau
dictionaryFormToTableau DictionaryForm
rows
  where
    (VarConstMap
rationalConstant, VarConstMap
nonBasicVars) = ((Integer, Rational) -> Bool)
-> VarConstMap -> (VarConstMap, VarConstMap)
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\(Integer
v,Rational
_) -> Integer
v Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== (-Integer
1)) VarConstMap
row
    r :: Rational
r = if VarConstMap -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null VarConstMap
rationalConstant then Rational
0 else ((Integer, Rational) -> Rational
forall a b. (a, b) -> b
snd ((Integer, Rational) -> Rational)
-> (VarConstMap -> (Integer, Rational)) -> VarConstMap -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarConstMap -> (Integer, Rational)
forall a. [a] -> a
head) VarConstMap
rationalConstant -- If there is no rational constant found in the right side, the rational constant is 0.

-- |If this function is given 'Nothing', return 'Nothing'.
-- Otherwise, we 'lookup' the 'Integer' given in the first item of the pair in the map given in the second item of the pair.
-- This is typically used to extract the value of the 'ObjectiveFunction' after calling 'Linear.Simplex.Simplex.twoPhaseSimplex'. 
extractObjectiveValue :: Maybe (Integer, [(Integer, Rational)]) -> Maybe Rational
extractObjectiveValue :: Maybe (Integer, VarConstMap) -> Maybe Rational
extractObjectiveValue Maybe (Integer, VarConstMap)
Nothing                  = Maybe Rational
forall a. Maybe a
Nothing
extractObjectiveValue (Just (Integer
objVar, VarConstMap
results)) =
  case Integer -> VarConstMap -> Maybe Rational
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Integer
objVar VarConstMap
results of
    Maybe Rational
Nothing -> [Char] -> Maybe Rational
forall a. HasCallStack => [Char] -> a
error [Char]
"Objective not found in results when extracting objective value"
    Maybe Rational
r -> Maybe Rational
r