{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Numeric.COINOR.CLP.Private where

import qualified Numeric.COINOR.CLP.FFI as FFI
import Numeric.LinearProgramming.Common
         (Term(..), Bound(..), Inequality(Inequality),
          Bounds, Constraints, Direction(..))

import qualified Data.Array.Comfort.Boxed as BoxedArray
import qualified Data.Array.Comfort.Storable.Unchecked.Monadic as ArrayMonadic
import qualified Data.Array.Comfort.Storable.Unchecked as ArrayUnchecked
import qualified Data.Array.Comfort.Storable as Array
import qualified Data.Array.Comfort.Shape as Shape
import Data.Array.Comfort.Storable (Array)
import Data.Foldable (for_)
import Data.Tuple.HT (mapPair)

import qualified Control.Monad.Trans.Cont as MC
import qualified Control.Applicative.HT as AppHT
import qualified Control.Functor.HT as FuncHT
import Control.Monad (forever)
import Control.Functor.HT (void)

import Foreign.Storable (pokeElemOff, peekElemOff)
import Foreign.ForeignPtr (withForeignPtr)
import Foreign.Ptr (Ptr)
import Foreign.C.Types (CDouble, CInt, CBool)



withBuffer :: Array sh a -> MC.ContT r IO (Ptr a)
withBuffer :: forall sh a r. Array sh a -> ContT r IO (Ptr a)
withBuffer Array sh a
arr =
   ((Ptr a -> IO r) -> IO r) -> ContT r IO (Ptr a)
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
MC.ContT (((Ptr a -> IO r) -> IO r) -> ContT r IO (Ptr a))
-> ((Ptr a -> IO r) -> IO r) -> ContT r IO (Ptr a)
forall a b. (a -> b) -> a -> b
$ ForeignPtr a -> (Ptr a -> IO r) -> IO r
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr (Array sh a -> ForeignPtr a
forall sh a. Array sh a -> ForeignPtr a
ArrayUnchecked.buffer Array sh a
arr)

runContT :: MC.ContT a IO a -> IO a
runContT :: forall a. ContT a IO a -> IO a
runContT ContT a IO a
act = ContT a IO a -> (a -> IO a) -> IO a
forall {k} (r :: k) (m :: k -> *) a.
ContT r m a -> (a -> m r) -> m r
MC.runContT ContT a IO a
act a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return



false, true :: CBool
false :: CBool
false = Int -> CBool
forall a. Enum a => Int -> a
toEnum (Int -> CBool) -> Int -> CBool
forall a b. (a -> b) -> a -> b
$ Bool -> Int
forall a. Enum a => a -> Int
fromEnum Bool
False
true :: CBool
true  = Int -> CBool
forall a. Enum a => Int -> a
toEnum (Int -> CBool) -> Int -> CBool
forall a b. (a -> b) -> a -> b
$ Bool -> Int
forall a. Enum a => a -> Int
fromEnum Bool
True

positiveInfinity, negativeInfinity :: CDouble
positiveInfinity :: CDouble
positiveInfinity =  CDouble
1CDouble -> CDouble -> CDouble
forall a. Fractional a => a -> a -> a
/CDouble
0
negativeInfinity :: CDouble
negativeInfinity = -CDouble
1CDouble -> CDouble -> CDouble
forall a. Fractional a => a -> a -> a
/CDouble
0

prepareBounds :: Inequality a -> (a, (CDouble, CDouble))
prepareBounds :: forall a. Inequality a -> (a, (CDouble, CDouble))
prepareBounds (Inequality a
x Bound
bnd) =
   (,) a
x ((CDouble, CDouble) -> (a, (CDouble, CDouble)))
-> (CDouble, CDouble) -> (a, (CDouble, CDouble))
forall a b. (a -> b) -> a -> b
$
   case Bound
bnd of
      LessEqual Double
up    -> (CDouble
negativeInfinity, Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
up)
      GreaterEqual Double
lo -> (Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
lo,    CDouble
positiveInfinity)
      Between Double
lo Double
up   -> (Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
lo,    Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
up)
      Equal Double
y         -> (Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
y,     Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
y)
      Bound
Free            -> (CDouble
negativeInfinity, CDouble
positiveInfinity)

-- ToDo: write Arrays in one go
prepareColumnBoundsArrays ::
   (Shape.Indexed sh, Shape.Index sh ~ ix) =>
   sh -> Bounds ix -> (Array sh CDouble, Array sh CDouble)
prepareColumnBoundsArrays :: forall sh ix.
(Indexed sh, Index sh ~ ix) =>
sh -> Bounds ix -> (Array sh CDouble, Array sh CDouble)
prepareColumnBoundsArrays sh
shape =
   (Array sh CDouble -> Array sh CDouble,
 Array sh CDouble -> Array sh CDouble)
-> (Array sh CDouble, Array sh CDouble)
-> (Array sh CDouble, Array sh CDouble)
forall a c b d. (a -> c, b -> d) -> (a, b) -> (c, d)
mapPair (Array sh CDouble -> Array sh CDouble
forall sh a. (C sh, Storable a) => Array sh a -> Array sh a
Array.fromBoxed, Array sh CDouble -> Array sh CDouble
forall sh a. (C sh, Storable a) => Array sh a -> Array sh a
Array.fromBoxed) ((Array sh CDouble, Array sh CDouble)
 -> (Array sh CDouble, Array sh CDouble))
-> (Bounds ix -> (Array sh CDouble, Array sh CDouble))
-> Bounds ix
-> (Array sh CDouble, Array sh CDouble)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   Array sh (CDouble, CDouble) -> (Array sh CDouble, Array sh CDouble)
forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
FuncHT.unzip (Array sh (CDouble, CDouble)
 -> (Array sh CDouble, Array sh CDouble))
-> (Bounds ix -> Array sh (CDouble, CDouble))
-> Bounds ix
-> (Array sh CDouble, Array sh CDouble)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   (CDouble, CDouble)
-> sh
-> [(Index sh, (CDouble, CDouble))]
-> Array sh (CDouble, CDouble)
forall sh a. Indexed sh => a -> sh -> [(Index sh, a)] -> Array sh a
BoxedArray.fromAssociations (CDouble
0, CDouble
positiveInfinity) sh
shape ([(ix, (CDouble, CDouble))] -> Array sh (CDouble, CDouble))
-> (Bounds ix -> [(ix, (CDouble, CDouble))])
-> Bounds ix
-> Array sh (CDouble, CDouble)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   (Inequality ix -> (ix, (CDouble, CDouble)))
-> Bounds ix -> [(ix, (CDouble, CDouble))]
forall a b. (a -> b) -> [a] -> [b]
map Inequality ix -> (ix, (CDouble, CDouble))
forall a. Inequality a -> (a, (CDouble, CDouble))
prepareBounds


type ShapeInt = Shape.ZeroBased Int

prepareRowBoundsArrays ::
   Bounds ix -> (Array ShapeInt CDouble, Array ShapeInt CDouble)
prepareRowBoundsArrays :: forall ix.
Bounds ix -> (Array ShapeInt CDouble, Array ShapeInt CDouble)
prepareRowBoundsArrays Bounds ix
constrs =
   let shape :: ShapeInt
shape = Int -> ShapeInt
forall n. n -> ZeroBased n
Shape.ZeroBased (Int -> ShapeInt) -> Int -> ShapeInt
forall a b. (a -> b) -> a -> b
$ Bounds ix -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Bounds ix
constrs in
   ([CDouble] -> Array ShapeInt CDouble,
 [CDouble] -> Array ShapeInt CDouble)
-> ([CDouble], [CDouble])
-> (Array ShapeInt CDouble, Array ShapeInt CDouble)
forall a c b d. (a -> c, b -> d) -> (a, b) -> (c, d)
mapPair (ShapeInt -> [CDouble] -> Array ShapeInt CDouble
forall sh a. (C sh, Storable a) => sh -> [a] -> Array sh a
Array.fromList ShapeInt
shape, ShapeInt -> [CDouble] -> Array ShapeInt CDouble
forall sh a. (C sh, Storable a) => sh -> [a] -> Array sh a
Array.fromList ShapeInt
shape) (([CDouble], [CDouble])
 -> (Array ShapeInt CDouble, Array ShapeInt CDouble))
-> ([CDouble], [CDouble])
-> (Array ShapeInt CDouble, Array ShapeInt CDouble)
forall a b. (a -> b) -> a -> b
$
   [(CDouble, CDouble)] -> ([CDouble], [CDouble])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(CDouble, CDouble)] -> ([CDouble], [CDouble]))
-> [(CDouble, CDouble)] -> ([CDouble], [CDouble])
forall a b. (a -> b) -> a -> b
$ (Inequality ix -> (CDouble, CDouble))
-> Bounds ix -> [(CDouble, CDouble)]
forall a b. (a -> b) -> [a] -> [b]
map ((ix, (CDouble, CDouble)) -> (CDouble, CDouble)
forall a b. (a, b) -> b
snd ((ix, (CDouble, CDouble)) -> (CDouble, CDouble))
-> (Inequality ix -> (ix, (CDouble, CDouble)))
-> Inequality ix
-> (CDouble, CDouble)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inequality ix -> (ix, (CDouble, CDouble))
forall a. Inequality a -> (a, (CDouble, CDouble))
prepareBounds) Bounds ix
constrs

storeBounds ::
   (Array sh CDouble, Array sh CDouble) ->
   MC.ContT r IO (Ptr CDouble, Ptr CDouble)
storeBounds :: forall sh r.
(Array sh CDouble, Array sh CDouble)
-> ContT r IO (Ptr CDouble, Ptr CDouble)
storeBounds = (Array sh CDouble -> ContT r IO (Ptr CDouble),
 Array sh CDouble -> ContT r IO (Ptr CDouble))
-> (Array sh CDouble, Array sh CDouble)
-> ContT r IO (Ptr CDouble, Ptr CDouble)
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c, b -> f d) -> (a, b) -> f (c, d)
AppHT.mapPair (Array sh CDouble -> ContT r IO (Ptr CDouble)
forall sh a r. Array sh a -> ContT r IO (Ptr a)
withBuffer, Array sh CDouble -> ContT r IO (Ptr CDouble)
forall sh a r. Array sh a -> ContT r IO (Ptr a)
withBuffer)


prepareConstraints ::
   (Shape.Indexed sh, Shape.Index sh ~ ix) =>
   sh -> Constraints Double ix ->
   (Array ShapeInt CDouble, Array ShapeInt CInt, Array ShapeInt FFI.BigIndex)
prepareConstraints :: forall sh ix.
(Indexed sh, Index sh ~ ix) =>
sh
-> Constraints Double ix
-> (Array ShapeInt CDouble, Array ShapeInt CInt,
    Array ShapeInt BigIndex)
prepareConstraints sh
shape Constraints Double ix
constrs =
   let {-
       It seems that LP solvers generally do not expect zero coefficients,
       although that is not document.
       https://hydra.nixos.org/build/239790474/nixlog/2
       https://list.coin-or.org/pipermail/clp/2023-November/001805.html
       -}
       constrsNonZero :: Constraints Double ix
constrsNonZero = (Inequality [Term Double ix] -> Inequality [Term Double ix])
-> Constraints Double ix -> Constraints Double ix
forall a b. (a -> b) -> [a] -> [b]
map (([Term Double ix] -> [Term Double ix])
-> Inequality [Term Double ix] -> Inequality [Term Double ix]
forall a b. (a -> b) -> Inequality a -> Inequality b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Term Double ix -> Bool) -> [Term Double ix] -> [Term Double ix]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Term Double
c ix
_x) -> Double
cDouble -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/=Double
0))) Constraints Double ix
constrs
       rowStarts :: Array ShapeInt BigIndex
rowStarts =
         [BigIndex] -> Array ShapeInt BigIndex
forall a. Storable a => [a] -> Array ShapeInt a
Array.vectorFromList ([BigIndex] -> Array ShapeInt BigIndex)
-> [BigIndex] -> Array ShapeInt BigIndex
forall a b. (a -> b) -> a -> b
$ (BigIndex -> BigIndex -> BigIndex)
-> BigIndex -> [BigIndex] -> [BigIndex]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl BigIndex -> BigIndex -> BigIndex
forall a. Num a => a -> a -> a
(+) BigIndex
0 ([BigIndex] -> [BigIndex]) -> [BigIndex] -> [BigIndex]
forall a b. (a -> b) -> a -> b
$
         (Inequality [Term Double ix] -> BigIndex)
-> Constraints Double ix -> [BigIndex]
forall a b. (a -> b) -> [a] -> [b]
map (\(Inequality [Term Double ix]
terms Bound
_bnd) -> Int -> BigIndex
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> BigIndex) -> Int -> BigIndex
forall a b. (a -> b) -> a -> b
$ [Term Double ix] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Term Double ix]
terms)
            Constraints Double ix
constrsNonZero
       shapeOffset :: Index sh -> Int
shapeOffset = sh -> Index sh -> Int
forall sh. Indexed sh => sh -> Index sh -> Int
Shape.offset sh
shape
       coefficients :: [Term Double ix]
coefficients =
         (Inequality [Term Double ix] -> [Term Double ix])
-> Constraints Double ix -> [Term Double ix]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Inequality [Term Double ix]
terms Bound
_bnd) -> [Term Double ix]
terms) Constraints Double ix
constrsNonZero
       indexArr :: Array ShapeInt CInt
indexArr =
         [CInt] -> Array ShapeInt CInt
forall a. Storable a => [a] -> Array ShapeInt a
Array.vectorFromList ([CInt] -> Array ShapeInt CInt) -> [CInt] -> Array ShapeInt CInt
forall a b. (a -> b) -> a -> b
$
         (Term Double ix -> CInt) -> [Term Double ix] -> [CInt]
forall a b. (a -> b) -> [a] -> [b]
map (\(Term Double
_ ix
ix) -> Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CInt) -> Int -> CInt
forall a b. (a -> b) -> a -> b
$ Index sh -> Int
shapeOffset ix
Index sh
ix) [Term Double ix]
coefficients
       coefficientArr :: Array ShapeInt CDouble
coefficientArr =
         [CDouble] -> Array ShapeInt CDouble
forall a. Storable a => [a] -> Array ShapeInt a
Array.vectorFromList ([CDouble] -> Array ShapeInt CDouble)
-> [CDouble] -> Array ShapeInt CDouble
forall a b. (a -> b) -> a -> b
$
         (Term Double ix -> CDouble) -> [Term Double ix] -> [CDouble]
forall a b. (a -> b) -> [a] -> [b]
map (\(Term Double
c ix
_) -> Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
c) [Term Double ix]
coefficients
   in (Array ShapeInt CDouble
coefficientArr, Array ShapeInt CInt
indexArr, Array ShapeInt BigIndex
rowStarts)

storeConstraints ::
   (Array ShapeInt CDouble, Array ShapeInt CInt, Array ShapeInt FFI.BigIndex) ->
   MC.ContT r IO (Ptr CDouble, Ptr CInt, Ptr FFI.BigIndex)
storeConstraints :: forall r.
(Array ShapeInt CDouble, Array ShapeInt CInt,
 Array ShapeInt BigIndex)
-> ContT r IO (Ptr CDouble, Ptr CInt, Ptr BigIndex)
storeConstraints (Array ShapeInt CDouble
coefficients, Array ShapeInt CInt
indices, Array ShapeInt BigIndex
rowStarts) =
   (Ptr CDouble
 -> Ptr CInt
 -> Ptr BigIndex
 -> (Ptr CDouble, Ptr CInt, Ptr BigIndex))
-> ContT r IO (Ptr CDouble)
-> ContT r IO (Ptr CInt)
-> ContT r IO (Ptr BigIndex)
-> ContT r IO (Ptr CDouble, Ptr CInt, Ptr BigIndex)
forall (m :: * -> *) a b c r.
Applicative m =>
(a -> b -> c -> r) -> m a -> m b -> m c -> m r
AppHT.lift3 (,,)
      (Array ShapeInt CDouble -> ContT r IO (Ptr CDouble)
forall sh a r. Array sh a -> ContT r IO (Ptr a)
withBuffer Array ShapeInt CDouble
coefficients)
      (Array ShapeInt CInt -> ContT r IO (Ptr CInt)
forall sh a r. Array sh a -> ContT r IO (Ptr a)
withBuffer Array ShapeInt CInt
indices)
      (Array ShapeInt BigIndex -> ContT r IO (Ptr BigIndex)
forall sh a r. Array sh a -> ContT r IO (Ptr a)
withBuffer Array ShapeInt BigIndex
rowStarts)


setOptimizationDirection :: Ptr FFI.Simplex -> Direction -> IO ()
setOptimizationDirection :: Ptr Simplex -> Direction -> IO ()
setOptimizationDirection Ptr Simplex
lp Direction
dir =
   Ptr Simplex -> CDouble -> IO ()
FFI.setOptimizationDirection Ptr Simplex
lp (CDouble -> IO ()) -> CDouble -> IO ()
forall a b. (a -> b) -> a -> b
$
      case Direction
dir of Direction
Minimize -> CDouble
1; Direction
Maximize -> -CDouble
1


newtype Method = Method {Method -> Ptr Simplex -> IO ()
runMethod :: Ptr FFI.Simplex -> IO ()}

dual, primal :: Method
dual :: Method
dual = (Ptr Simplex -> IO ()) -> Method
Method ((Ptr Simplex -> IO ()) -> Method)
-> (Ptr Simplex -> IO ()) -> Method
forall a b. (a -> b) -> a -> b
$ \Ptr Simplex
lp -> IO CInt -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr Simplex -> CInt -> IO CInt
FFI.dual Ptr Simplex
lp CInt
0
primal :: Method
primal = (Ptr Simplex -> IO ()) -> Method
Method ((Ptr Simplex -> IO ()) -> Method)
-> (Ptr Simplex -> IO ()) -> Method
forall a b. (a -> b) -> a -> b
$ \Ptr Simplex
lp -> IO CInt -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr Simplex -> CInt -> IO CInt
FFI.primal Ptr Simplex
lp CInt
0

initialSolve, initialDualSolve, initialPrimalSolve,
   initialBarrierSolve, initialBarrierNoCrossSolve :: Method
initialSolve :: Method
initialSolve = (Ptr Simplex -> IO ()) -> Method
Method ((Ptr Simplex -> IO ()) -> Method)
-> (Ptr Simplex -> IO ()) -> Method
forall a b. (a -> b) -> a -> b
$ IO CInt -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CInt -> IO ())
-> (Ptr Simplex -> IO CInt) -> Ptr Simplex -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Simplex -> IO CInt
FFI.initialSolve
initialDualSolve :: Method
initialDualSolve = (Ptr Simplex -> IO ()) -> Method
Method ((Ptr Simplex -> IO ()) -> Method)
-> (Ptr Simplex -> IO ()) -> Method
forall a b. (a -> b) -> a -> b
$ IO CInt -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CInt -> IO ())
-> (Ptr Simplex -> IO CInt) -> Ptr Simplex -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Simplex -> IO CInt
FFI.initialDualSolve
initialPrimalSolve :: Method
initialPrimalSolve = (Ptr Simplex -> IO ()) -> Method
Method ((Ptr Simplex -> IO ()) -> Method)
-> (Ptr Simplex -> IO ()) -> Method
forall a b. (a -> b) -> a -> b
$ IO CInt -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CInt -> IO ())
-> (Ptr Simplex -> IO CInt) -> Ptr Simplex -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Simplex -> IO CInt
FFI.initialPrimalSolve
initialBarrierSolve :: Method
initialBarrierSolve = (Ptr Simplex -> IO ()) -> Method
Method ((Ptr Simplex -> IO ()) -> Method)
-> (Ptr Simplex -> IO ()) -> Method
forall a b. (a -> b) -> a -> b
$ IO CInt -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CInt -> IO ())
-> (Ptr Simplex -> IO CInt) -> Ptr Simplex -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Simplex -> IO CInt
FFI.initialBarrierSolve
initialBarrierNoCrossSolve :: Method
initialBarrierNoCrossSolve = (Ptr Simplex -> IO ()) -> Method
Method ((Ptr Simplex -> IO ()) -> Method)
-> (Ptr Simplex -> IO ()) -> Method
forall a b. (a -> b) -> a -> b
$ IO CInt -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CInt -> IO ())
-> (Ptr Simplex -> IO CInt) -> Ptr Simplex -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Simplex -> IO CInt
FFI.initialBarrierNoCrossSolve

solveEndless :: Method
solveEndless :: Method
solveEndless = (Ptr Simplex -> IO ()) -> Method
Method ((Ptr Simplex -> IO ()) -> Method)
-> (Ptr Simplex -> IO ()) -> Method
forall a b. (a -> b) -> a -> b
$ IO CInt -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO CInt -> IO ())
-> (Ptr Simplex -> IO CInt) -> Ptr Simplex -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Simplex -> IO CInt
FFI.initialSolve


data FailureType =
     PrimalInfeasible
   | DualInfeasible
   | StoppedOnIterations
   | StoppedDueToErrors
   deriving (FailureType -> FailureType -> Bool
(FailureType -> FailureType -> Bool)
-> (FailureType -> FailureType -> Bool) -> Eq FailureType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FailureType -> FailureType -> Bool
== :: FailureType -> FailureType -> Bool
$c/= :: FailureType -> FailureType -> Bool
/= :: FailureType -> FailureType -> Bool
Eq, Int -> FailureType -> ShowS
[FailureType] -> ShowS
FailureType -> String
(Int -> FailureType -> ShowS)
-> (FailureType -> String)
-> ([FailureType] -> ShowS)
-> Show FailureType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FailureType -> ShowS
showsPrec :: Int -> FailureType -> ShowS
$cshow :: FailureType -> String
show :: FailureType -> String
$cshowList :: [FailureType] -> ShowS
showList :: [FailureType] -> ShowS
Show)

type Result sh = Either FailureType (Double, Array sh Double)

examineStatus :: (Shape.C sh) => sh -> Ptr FFI.Simplex -> IO (Result sh)
examineStatus :: forall sh. C sh => sh -> Ptr Simplex -> IO (Result sh)
examineStatus sh
shape Ptr Simplex
lp = do
   CInt
status <- Ptr Simplex -> IO CInt
FFI.status Ptr Simplex
lp
   case CInt
status of
      CInt
0 -> do
         CDouble
objVal <- Ptr Simplex -> IO CDouble
FFI.objectiveValue Ptr Simplex
lp
         Array sh Double
optVec <-
            sh -> (Int -> Ptr Double -> IO ()) -> IO (Array sh Double)
forall (m :: * -> *) sh a.
(PrimMonad m, C sh, Storable a) =>
sh -> (Int -> Ptr a -> IO ()) -> m (Array sh a)
ArrayMonadic.unsafeCreateWithSize sh
shape ((Int -> Ptr Double -> IO ()) -> IO (Array sh Double))
-> (Int -> Ptr Double -> IO ()) -> IO (Array sh Double)
forall a b. (a -> b) -> a -> b
$ \Int
size Ptr Double
arrPtr -> do
               Ptr CDouble
optVecPtr <- Ptr Simplex -> IO (Ptr CDouble)
FFI.getColSolution Ptr Simplex
lp
               [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
size [Int
0..]) ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
k ->
                  Ptr Double -> Int -> Double -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Double
arrPtr Int
k (Double -> IO ()) -> (CDouble -> Double) -> CDouble -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CDouble -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac
                     (CDouble -> IO ()) -> IO CDouble -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr CDouble -> Int -> IO CDouble
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr CDouble
optVecPtr Int
k
         Result sh -> IO (Result sh)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result sh -> IO (Result sh)) -> Result sh -> IO (Result sh)
forall a b. (a -> b) -> a -> b
$ (Double, Array sh Double) -> Result sh
forall a b. b -> Either a b
Right (CDouble -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac CDouble
objVal, Array sh Double
optVec)
      CInt
1 -> Result sh -> IO (Result sh)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result sh -> IO (Result sh)) -> Result sh -> IO (Result sh)
forall a b. (a -> b) -> a -> b
$ FailureType -> Result sh
forall a b. a -> Either a b
Left FailureType
PrimalInfeasible
      CInt
2 -> Result sh -> IO (Result sh)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result sh -> IO (Result sh)) -> Result sh -> IO (Result sh)
forall a b. (a -> b) -> a -> b
$ FailureType -> Result sh
forall a b. a -> Either a b
Left FailureType
DualInfeasible
      CInt
3 -> Result sh -> IO (Result sh)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result sh -> IO (Result sh)) -> Result sh -> IO (Result sh)
forall a b. (a -> b) -> a -> b
$ FailureType -> Result sh
forall a b. a -> Either a b
Left FailureType
StoppedOnIterations
      CInt
_ -> Result sh -> IO (Result sh)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result sh -> IO (Result sh)) -> Result sh -> IO (Result sh)
forall a b. (a -> b) -> a -> b
$ FailureType -> Result sh
forall a b. a -> Either a b
Left FailureType
StoppedDueToErrors