module Geometry.VertexEnum.Internal
  ( normalizeConstraints
  , varsOfConstraint
  , feasiblePoint
  , findSigns
  , iPoint )
  where
import           Prelude                hiding         ( EQ )
import           Control.Monad.Logger                  (
                                                         runStdoutLoggingT
                                                       , filterLogger
                                                       )
import           Data.IntMap.Strict                    ( IntMap, mergeWithKey )
import qualified Data.IntMap.Strict                    as IM
import qualified Data.Map.Strict                       as DM
import           Data.Maybe                            ( fromJust, isJust )
import           Data.List                             ( nub, union )
import           Data.List.Extra                       ( unsnoc )
import           Geometry.VertexEnum.Constraint        ( Constraint (..), Sense (..) )
import           Geometry.VertexEnum.LinearCombination ( LinearCombination (..), VarIndex )
import           Linear.Simplex.Solver.TwoPhase        (
                                                         twoPhaseSimplex
                                                       , findFeasibleSolution
                                                       )
import           Linear.Simplex.Types                  (
                                                         Result ( .. )
                                                       , PolyConstraint ( .. )
                                                       , ObjectiveFunction ( .. )
                                                       )
import           Linear.Simplex.Util                   (
                                                         simplifySystem
                                                       )

normalizeLinearCombination :: 
  Num a => [VarIndex] -> LinearCombination a -> IntMap a
normalizeLinearCombination :: forall a. Num a => [Var] -> LinearCombination a -> IntMap a
normalizeLinearCombination [Var]
vars (LinearCombination IntMap a
lc) =
  IntMap a -> IntMap a -> IntMap a
forall a. IntMap a -> IntMap a -> IntMap a
IM.union IntMap a
lc ([(Var, a)] -> IntMap a
forall a. [(Var, a)] -> IntMap a
IM.fromList [(Var
i,a
0) | Var
i <- [Var]
vars [Var] -> [Var] -> [Var]
forall a. Eq a => [a] -> [a] -> [a]
`union` [Var
0]])

varsOfLinearCombo :: LinearCombination a -> [VarIndex]
varsOfLinearCombo :: forall a. LinearCombination a -> [Var]
varsOfLinearCombo (LinearCombination IntMap a
imap) = IntMap a -> [Var]
forall a. IntMap a -> [Var]
IM.keys IntMap a
imap

varsOfConstraint :: Constraint a -> [VarIndex]
varsOfConstraint :: forall a. Constraint a -> [Var]
varsOfConstraint (Constraint LinearCombination a
left Sense
_ LinearCombination a
right) =
  LinearCombination a -> [Var]
forall a. LinearCombination a -> [Var]
varsOfLinearCombo LinearCombination a
left [Var] -> [Var] -> [Var]
forall a. Eq a => [a] -> [a] -> [a]
`union` LinearCombination a -> [Var]
forall a. LinearCombination a -> [Var]
varsOfLinearCombo LinearCombination a
right

normalizeConstraint :: Real a => [VarIndex] -> Constraint a -> [a]
normalizeConstraint :: forall a. Real a => [Var] -> Constraint a -> [a]
normalizeConstraint [Var]
vars (Constraint LinearCombination a
left Sense
sense LinearCombination a
right) =
  if Sense
sense Sense -> Sense -> Bool
forall a. Eq a => a -> a -> Bool
== Sense
Lt
    then [a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
x]
    else (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map a -> a
forall a. Num a => a -> a
negate [a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [-a
x]
  where
    lhs' :: IntMap a
lhs' = [Var] -> LinearCombination a -> IntMap a
forall a. Num a => [Var] -> LinearCombination a -> IntMap a
normalizeLinearCombination [Var]
vars LinearCombination a
left
    rhs' :: IntMap a
rhs' = [Var] -> LinearCombination a -> IntMap a
forall a. Num a => [Var] -> LinearCombination a -> IntMap a
normalizeLinearCombination [Var]
vars LinearCombination a
right
    coefs :: [a]
coefs = IntMap a -> [a]
forall a. IntMap a -> [a]
IM.elems (IntMap a -> [a]) -> IntMap a -> [a]
forall a b. (a -> b) -> a -> b
$ (Var -> a -> a -> Maybe a)
-> (IntMap a -> IntMap a)
-> (IntMap a -> IntMap a)
-> IntMap a
-> IntMap a
-> IntMap a
forall a b c.
(Var -> a -> b -> Maybe c)
-> (IntMap a -> IntMap c)
-> (IntMap b -> IntMap c)
-> IntMap a
-> IntMap b
-> IntMap c
mergeWithKey (\Var
_ a
a a
b -> a -> Maybe a
forall a. a -> Maybe a
Just (a
aa -> a -> a
forall a. Num a => a -> a -> a
-a
b)) IntMap a -> IntMap a
forall a. a -> a
id IntMap a -> IntMap a
forall a. a -> a
id IntMap a
lhs' IntMap a
rhs'
    (a
x, [a]
xs) = case [a]
coefs of
      (a
xx:[a]
xxs) -> (a
xx, [a]
xxs)
      []       -> (a
0, [])

normalizeConstraints :: Real a => [Constraint a] -> [[a]]
normalizeConstraints :: forall a. Real a => [Constraint a] -> [[a]]
normalizeConstraints [Constraint a]
constraints = 
  (Constraint a -> [a]) -> [Constraint a] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map ([Var] -> Constraint a -> [a]
forall a. Real a => [Var] -> Constraint a -> [a]
normalizeConstraint [Var]
vars) [Constraint a]
constraints
  where
    vars :: [Var]
vars = [Var] -> [Var]
forall a. Eq a => [a] -> [a]
nub ([Var] -> [Var]) -> [Var] -> [Var]
forall a b. (a -> b) -> a -> b
$ (Constraint a -> [Var]) -> [Constraint a] -> [Var]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Constraint a -> [Var]
forall a. Constraint a -> [Var]
varsOfConstraint [Constraint a]
constraints

negateIf :: Bool -> Rational -> Rational
negateIf :: Bool -> Rational -> Rational
negateIf Bool
test Rational
x = if Bool
test then -Rational
x else Rational
x

inequality :: [Bool] -> [Rational] -> PolyConstraint
inequality :: [Bool] -> [Rational] -> PolyConstraint
inequality [Bool]
toNegate [Rational]
row = 
  LEQ { 
        $sel:lhs:LEQ :: VarLitMapSum
lhs = [(Var, Rational)] -> VarLitMapSum
forall k a. Ord k => [(k, a)] -> Map k a
DM.fromList ([Var] -> [Rational] -> [(Var, Rational)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var
0 ..] (Rational
1 Rational -> [Rational] -> [Rational]
forall a. a -> [a] -> [a]
: [Rational]
coeffs')), $sel:rhs:LEQ :: Rational
rhs = -Rational
bound
      }
  where
    ([Rational]
coeffs, Rational
bound) = Maybe ([Rational], Rational) -> ([Rational], Rational)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe ([Rational], Rational) -> ([Rational], Rational))
-> Maybe ([Rational], Rational) -> ([Rational], Rational)
forall a b. (a -> b) -> a -> b
$ [Rational] -> Maybe ([Rational], Rational)
forall a. [a] -> Maybe ([a], a)
unsnoc [Rational]
row
    coeffs' :: [Rational]
coeffs' = (Bool -> Rational -> Rational)
-> [Bool] -> [Rational] -> [Rational]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Bool -> Rational -> Rational
negateIf [Bool]
toNegate [Rational]
coeffs

inequalities :: [[Rational]] -> [Bool] -> [PolyConstraint]
inequalities :: [[Rational]] -> [Bool] -> [PolyConstraint]
inequalities [[Rational]]
normConstraints [Bool]
toNegate = 
  [PolyConstraint] -> [PolyConstraint]
simplifySystem ([PolyConstraint] -> [PolyConstraint])
-> [PolyConstraint] -> [PolyConstraint]
forall a b. (a -> b) -> a -> b
$ ([Rational] -> PolyConstraint) -> [[Rational]] -> [PolyConstraint]
forall a b. (a -> b) -> [a] -> [b]
map ([Bool] -> [Rational] -> PolyConstraint
inequality [Bool]
toNegate) [[Rational]]
normConstraints

-- iPoint does not necessarily return the optimal interior point, because 

-- this point possibly corresponds to another [Bool] combination; it just 

-- returns a feasible point

iPoint :: [[Rational]] -> [Bool] -> IO [Double]
iPoint :: [[Rational]] -> [Bool] -> IO [Double]
iPoint [[Rational]]
halfspacesMatrix [Bool]
toNegate = do
  Maybe Result
maybeResult <- LoggingT IO (Maybe Result) -> IO (Maybe Result)
forall (m :: * -> *) a. MonadIO m => LoggingT m a -> m a
runStdoutLoggingT (LoggingT IO (Maybe Result) -> IO (Maybe Result))
-> LoggingT IO (Maybe Result) -> IO (Maybe Result)
forall a b. (a -> b) -> a -> b
$ (LogSource -> LogLevel -> Bool)
-> LoggingT IO (Maybe Result) -> LoggingT IO (Maybe Result)
forall (m :: * -> *) a.
(LogSource -> LogLevel -> Bool) -> LoggingT m a -> LoggingT m a
filterLogger (\LogSource
_ LogLevel
_ -> Bool
False) (LoggingT IO (Maybe Result) -> LoggingT IO (Maybe Result))
-> LoggingT IO (Maybe Result) -> LoggingT IO (Maybe Result)
forall a b. (a -> b) -> a -> b
$ 
                  ObjectiveFunction -> [PolyConstraint] -> LoggingT IO (Maybe Result)
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
ObjectiveFunction -> [PolyConstraint] -> m (Maybe Result)
twoPhaseSimplex ObjectiveFunction
objFunc [PolyConstraint]
polyConstraints
  [Double] -> IO [Double]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Double] -> IO [Double]) -> [Double] -> IO [Double]
forall a b. (a -> b) -> a -> b
$ case Maybe Result
maybeResult of
    Just (Result Var
var VarLitMapSum
varLitMap) -> 
      let sol :: VarLitMapSum
sol = Var -> VarLitMapSum -> VarLitMapSum
forall k a. Ord k => k -> Map k a -> Map k a
DM.delete Var
0 (VarLitMapSum -> VarLitMapSum) -> VarLitMapSum -> VarLitMapSum
forall a b. (a -> b) -> a -> b
$ Var -> VarLitMapSum -> VarLitMapSum
forall k a. Ord k => k -> Map k a -> Map k a
DM.delete Var
var VarLitMapSum
varLitMap
          nvars :: Var
nvars = [Bool] -> Var
forall a. [a] -> Var
forall (t :: * -> *) a. Foldable t => t a -> Var
length [Bool]
toNegate
          sol' :: VarLitMapSum
sol' = VarLitMapSum -> VarLitMapSum -> VarLitMapSum
forall k a. Ord k => Map k a -> Map k a -> Map k a
DM.union VarLitMapSum
sol ([(Var, Rational)] -> VarLitMapSum
forall k a. Ord k => [(k, a)] -> Map k a
DM.fromList ([Var] -> [Rational] -> [(Var, Rational)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var
1 .. Var
nvars] (Rational -> [Rational]
forall a. a -> [a]
repeat Rational
0)))
      in 
      (Rational -> Double) -> [Rational] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map Rational -> Double
forall a. Fractional a => Rational -> a
fromRational 
        (
          (Bool -> Rational -> Rational)
-> [Bool] -> [Rational] -> [Rational]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Bool -> Rational -> Rational
negateIf [Bool]
toNegate (VarLitMapSum -> [Rational]
forall k a. Map k a -> [a]
DM.elems VarLitMapSum
sol')
        )
    Maybe Result
Nothing -> [Char] -> [Double]
forall a. HasCallStack => [Char] -> a
error [Char]
"iPoint: should not happen."
  where
    polyConstraints :: [PolyConstraint]
polyConstraints = [[Rational]] -> [Bool] -> [PolyConstraint]
inequalities [[Rational]]
halfspacesMatrix [Bool]
toNegate
    objFunc :: ObjectiveFunction
objFunc = Max {
        $sel:objective:Max :: VarLitMapSum
objective = Var -> Rational -> VarLitMapSum
forall k a. k -> a -> Map k a
DM.singleton Var
0 Rational
1
      } 

feasiblePoint :: [[Rational]] -> [Bool] -> IO Bool
feasiblePoint :: [[Rational]] -> [Bool] -> IO Bool
feasiblePoint [[Rational]]
halfspacesMatrix [Bool]
toNegate = do
  Maybe FeasibleSystem
maybeFS <- LoggingT IO (Maybe FeasibleSystem) -> IO (Maybe FeasibleSystem)
forall (m :: * -> *) a. MonadIO m => LoggingT m a -> m a
runStdoutLoggingT (LoggingT IO (Maybe FeasibleSystem) -> IO (Maybe FeasibleSystem))
-> LoggingT IO (Maybe FeasibleSystem) -> IO (Maybe FeasibleSystem)
forall a b. (a -> b) -> a -> b
$ (LogSource -> LogLevel -> Bool)
-> LoggingT IO (Maybe FeasibleSystem)
-> LoggingT IO (Maybe FeasibleSystem)
forall (m :: * -> *) a.
(LogSource -> LogLevel -> Bool) -> LoggingT m a -> LoggingT m a
filterLogger (\LogSource
_ LogLevel
_ -> Bool
False) (LoggingT IO (Maybe FeasibleSystem)
 -> LoggingT IO (Maybe FeasibleSystem))
-> LoggingT IO (Maybe FeasibleSystem)
-> LoggingT IO (Maybe FeasibleSystem)
forall a b. (a -> b) -> a -> b
$ 
                  [PolyConstraint] -> LoggingT IO (Maybe FeasibleSystem)
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
[PolyConstraint] -> m (Maybe FeasibleSystem)
findFeasibleSolution [PolyConstraint]
polyConstraints
  Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Maybe FeasibleSystem -> Bool
forall a. Maybe a -> Bool
isJust Maybe FeasibleSystem
maybeFS
  where
    polyConstraints :: [PolyConstraint]
polyConstraints = [PolyConstraint] -> [PolyConstraint]
simplifySystem ([PolyConstraint] -> [PolyConstraint])
-> [PolyConstraint] -> [PolyConstraint]
forall a b. (a -> b) -> a -> b
$ ([Rational] -> PolyConstraint) -> [[Rational]] -> [PolyConstraint]
forall a b. (a -> b) -> [a] -> [b]
map [Rational] -> PolyConstraint
ineq [[Rational]]
halfspacesMatrix
    ineq :: [Rational] -> PolyConstraint
ineq [Rational]
row = 
      LEQ { 
            $sel:lhs:LEQ :: VarLitMapSum
lhs = [(Var, Rational)] -> VarLitMapSum
forall k a. Ord k => [(k, a)] -> Map k a
DM.fromList ([Var] -> [Rational] -> [(Var, Rational)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var
1 ..] [Rational]
coeffs'), $sel:rhs:LEQ :: Rational
rhs = -Rational
bound
          } 
      where
        ([Rational]
coeffs, Rational
bound) = Maybe ([Rational], Rational) -> ([Rational], Rational)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe ([Rational], Rational) -> ([Rational], Rational))
-> Maybe ([Rational], Rational) -> ([Rational], Rational)
forall a b. (a -> b) -> a -> b
$ [Rational] -> Maybe ([Rational], Rational)
forall a. [a] -> Maybe ([a], a)
unsnoc [Rational]
row
        coeffs' :: [Rational]
coeffs' = (Bool -> Rational -> Rational)
-> [Bool] -> [Rational] -> [Rational]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Bool -> Rational -> Rational
negateIf [Bool]
toNegate [Rational]
coeffs

findSigns :: [[Rational]] -> IO [Bool]
findSigns :: [[Rational]] -> IO [Bool]
findSigns [[Rational]]
halfspacesMatrix = do 
  Var -> IO [Bool]
go Var
0
  where
    nvars :: Var
nvars = [Rational] -> Var
forall a. [a] -> Var
forall (t :: * -> *) a. Foldable t => t a -> Var
length ([[Rational]]
halfspacesMatrix [[Rational]] -> Var -> [Rational]
forall a. HasCallStack => [a] -> Var -> a
!! Var
0) Var -> Var -> Var
forall a. Num a => a -> a -> a
- Var
1
    combinations :: [[Bool]]
combinations = [[Bool]] -> [[Bool]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([[Bool]] -> [[Bool]]) -> [[Bool]] -> [[Bool]]
forall a b. (a -> b) -> a -> b
$ Var -> [Bool] -> [[Bool]]
forall a. Var -> a -> [a]
replicate Var
nvars [Bool
False, Bool
True]
    ncombinations :: Var
ncombinations = [[Bool]] -> Var
forall a. [a] -> Var
forall (t :: * -> *) a. Foldable t => t a -> Var
length [[Bool]]
combinations
    go :: Var -> IO [Bool]
go Var
i 
      | Var
i Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
ncombinations = do 
          [Bool] -> IO [Bool]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
      | Bool
otherwise          = do 
          let combo :: [Bool]
combo = [[Bool]]
combinations [[Bool]] -> Var -> [Bool]
forall a. HasCallStack => [a] -> Var -> a
!! Var
i
          Bool
test <- [[Rational]] -> [Bool] -> IO Bool
feasiblePoint [[Rational]]
halfspacesMatrix [Bool]
combo
          if Bool
test 
            then do
              [Bool] -> IO [Bool]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Bool] -> IO [Bool]) -> [Bool] -> IO [Bool]
forall a b. (a -> b) -> a -> b
$ [Bool]
combo
            else do
              Var -> IO [Bool]
go (Var
iVar -> Var -> Var
forall a. Num a => a -> a -> a
+Var
1)