{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{- |
The monadic interface to CLP allows to optimize
with respect to multiple objectives, successively.
-}
module Numeric.HiGHS.LP.Monad (
   -- * simple solver with warm restart
   T,
   run,
   solve,
   Direction(..),
   Method, Priv.simplex, Priv.choose, Priv.ipm,
   LPEnum.ModelStatus,
   Result,
   -- * solve with extra queries on the result
   solveWith,
   Query, Priv.getObjectiveValue,
   Priv.getOptimalVector, Priv.getSolutionVectors,
   Priv.getBasisStatus, Highs.BasisStatus,
   ) where

import qualified Numeric.HiGHS.LP.Enumeration as LPEnum
import qualified Numeric.HiGHS.LP.FFI as Highs
import qualified Numeric.HiGHS.LP.Debug as Debug
import qualified Numeric.HiGHS.LP.Private as Priv
import Numeric.HiGHS.LP.FFI (Highs)
import Numeric.HiGHS.LP.Private
         (Method, Result, Query, checkStatus, runContT, withBuffer,
          storeBounds, prepareRowBoundsArrays, prepareColumnBoundsArrays,
          storeConstraints, prepareConstraints,
          setMethod, objectiveSense, examineStatus)

import Numeric.LinearProgramming.Common
         (Bounds, Constraints, Direction(..), Objective)

import qualified Data.Array.Comfort.Storable as Array
import qualified Data.Array.Comfort.Shape as Shape

import qualified Control.Monad.Trans.Cont as MC
import qualified Control.Monad.Trans.Reader as MR
import Control.Monad.IO.Class (liftIO)
import Control.Monad (when)
import Control.Exception (bracket)

import System.IO.Unsafe (unsafePerformIO)

import Foreign.Ptr (Ptr)


{- $setup
>>> :set -XTypeFamilies
>>> :set -XTypeOperators
>>> import qualified Numeric.HiGHS.LP.Monad as LP
>>> import qualified Numeric.HiGHS.LP as CLP
>>> import Test.Numeric.HiGHS.LP.Utility (traverse_Lag, traverseLag)
>>> import Test.Numeric.HiGHS.LP (TripletShape, tripletShape, forAllMethod)
>>> import Numeric.HiGHS.LP (Direction, (.*), (<=.))
>>>
>>> import qualified Numeric.LinearProgramming.Monad as LPMonad
>>> import qualified Numeric.LinearProgramming.Test as TestLP
>>> import Numeric.LinearProgramming.Common (Bounds, Objective)
>>>
>>> import qualified Data.Array.Comfort.Storable as Array
>>> import qualified Data.Array.Comfort.Shape as Shape
>>> import qualified Data.NonEmpty as NonEmpty
>>> import Data.Array.Comfort.Storable (Array)
>>> import Data.Traversable (Traversable)
>>> import Data.Foldable (Foldable)
>>>
>>> import qualified Control.Monad.Trans.Except as ME
>>>
>>> import qualified Data.List.HT as ListHT
>>> import Data.Tuple.HT (mapSnd)
>>>
>>> import Foreign.Storable (Storable)
>>>
>>> import qualified Test.QuickCheck as QC
>>>
>>>
>>> type Constraints ix = CLP.Constraints Double ix
>>>
>>>
>>> approxSuccession ::
>>>    (Shape.C sh, Show sh, Show a, Ord a, Num a, Storable a) =>
>>>    a ->
>>>    Either CLP.ModelStatus (NonEmpty.T [] (a, Array sh a)) ->
>>>    Either CLP.ModelStatus (NonEmpty.T [] (a, Array sh a)) ->
>>>    QC.Property
>>> approxSuccession tol x y =
>>>    QC.counterexample (show x) $
>>>    QC.counterexample (show y) $
>>>    case (x,y) of
>>>       (Left sx, Left sy) -> sx==sy
>>>       (Right (NonEmpty.Cons xh xs), Right (NonEmpty.Cons yh ys)) ->
>>>          let equalSol (optX, _) (optY, _) = TestLP.approxReal tol optX optY
>>>          in equalSol xh yh  &&  ListHT.equalWith equalSol xs ys
>>>       _ -> False
>>>
>>>
>>> runSuccessive ::
>>>    (Eq sh, Shape.Indexed sh, Shape.Index sh ~ ix, Foldable t) =>
>>>    CLP.Method ->
>>>    sh ->
>>>    Bounds ix ->
>>>    (Constraints ix, (Direction, Objective sh)) ->
>>>    t (Double -> Constraints ix, (Direction, Objective sh)) ->
>>>    Either CLP.ModelStatus ()
>>> runSuccessive method shape bounds (constrs,dirObj) objs =
>>>    let solve constrs_ dirObj_ = do
>>>          (status,result) <- LP.solve method constrs_ dirObj_
>>>          return $ maybe (Left status) Right result in
>>>    LP.run shape bounds $ ME.runExceptT $ do
>>>       (opt, _xs) <- ME.ExceptT $ solve constrs dirObj
>>>       traverse_Lag opt
>>>          (\prevResult (newConstr, dirObjI) -> do
>>>             (optI, _xs) <-
>>>                ME.ExceptT $ solve (newConstr prevResult) dirObjI
>>>             return optI)
>>>          objs
>>>
>>> solveSuccessiveWarm ::
>>>    (Eq sh, Shape.Indexed sh, Shape.Index sh ~ ix, Traversable t) =>
>>>    CLP.Method ->
>>>    sh ->
>>>    Bounds ix ->
>>>    (Constraints ix, (Direction, Objective sh)) ->
>>>    t (Double -> Constraints ix, (Direction, Objective sh)) ->
>>>    Either CLP.ModelStatus (NonEmpty.T t (Double, Array sh Double))
>>> solveSuccessiveWarm method shape bounds (constrs,dirObj) objs =
>>>    let solve constrs_ dirObj_ = do
>>>          (status,result) <- LP.solve method constrs_ dirObj_
>>>          return $ maybe (Left status) Right result in
>>>    LP.run shape bounds $ ME.runExceptT $ do
>>>       result <- ME.ExceptT $ solve constrs dirObj
>>>       NonEmpty.Cons result <$>
>>>          traverseLag result
>>>             (\(prevOpt, _xs) (newConstr, dirObjI) ->
>>>                 ME.ExceptT $ solve (newConstr prevOpt) dirObjI)
>>>             objs
>>>
>>> solveSuccessiveGen ::
>>>    (Eq sh, Shape.Indexed sh, Shape.Index sh ~ ix, Traversable t) =>
>>>    CLP.Method ->
>>>    sh ->
>>>    Bounds ix ->
>>>    (Constraints ix, (Direction, Objective sh)) ->
>>>    t (Double -> Constraints ix, (Direction, Objective sh)) ->
>>>    Either CLP.ModelStatus (NonEmpty.T t (Double, Array sh Double))
>>> solveSuccessiveGen method shape bounds (constrs,dirObj) objs =
>>>    let solve bounds_ constrs_ dirObj_ =
>>>          case CLP.solve method bounds_ constrs_ dirObj_ of
>>>             (status,result) -> maybe (Left status) Right result in
>>>    LPMonad.run shape bounds $ ME.runExceptT $ do
>>>       result <- ME.ExceptT $ LPMonad.lift solve constrs dirObj
>>>       NonEmpty.Cons result <$>
>>>          traverseLag result
>>>             (\(prevOpt, _xs) (newConstr, dirObjI) ->
>>>                ME.ExceptT $ LPMonad.lift solve (newConstr prevOpt) dirObjI)
>>>             objs
-}


newtype T sh a = Cons (MR.ReaderT (sh, Ptr Highs) IO a)
   deriving ((forall a b. (a -> b) -> T sh a -> T sh b)
-> (forall a b. a -> T sh b -> T sh a) -> Functor (T sh)
forall a b. a -> T sh b -> T sh a
forall a b. (a -> b) -> T sh a -> T sh b
forall sh a b. a -> T sh b -> T sh a
forall sh a b. (a -> b) -> T sh a -> T sh b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall sh a b. (a -> b) -> T sh a -> T sh b
fmap :: forall a b. (a -> b) -> T sh a -> T sh b
$c<$ :: forall sh a b. a -> T sh b -> T sh a
<$ :: forall a b. a -> T sh b -> T sh a
Functor, Functor (T sh)
Functor (T sh)
-> (forall a. a -> T sh a)
-> (forall a b. T sh (a -> b) -> T sh a -> T sh b)
-> (forall a b c. (a -> b -> c) -> T sh a -> T sh b -> T sh c)
-> (forall a b. T sh a -> T sh b -> T sh b)
-> (forall a b. T sh a -> T sh b -> T sh a)
-> Applicative (T sh)
forall sh. Functor (T sh)
forall a. a -> T sh a
forall sh a. a -> T sh a
forall a b. T sh a -> T sh b -> T sh a
forall a b. T sh a -> T sh b -> T sh b
forall a b. T sh (a -> b) -> T sh a -> T sh b
forall sh a b. T sh a -> T sh b -> T sh a
forall sh a b. T sh a -> T sh b -> T sh b
forall sh a b. T sh (a -> b) -> T sh a -> T sh b
forall a b c. (a -> b -> c) -> T sh a -> T sh b -> T sh c
forall sh a b c. (a -> b -> c) -> T sh a -> T sh b -> T sh c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall sh a. a -> T sh a
pure :: forall a. a -> T sh a
$c<*> :: forall sh a b. T sh (a -> b) -> T sh a -> T sh b
<*> :: forall a b. T sh (a -> b) -> T sh a -> T sh b
$cliftA2 :: forall sh a b c. (a -> b -> c) -> T sh a -> T sh b -> T sh c
liftA2 :: forall a b c. (a -> b -> c) -> T sh a -> T sh b -> T sh c
$c*> :: forall sh a b. T sh a -> T sh b -> T sh b
*> :: forall a b. T sh a -> T sh b -> T sh b
$c<* :: forall sh a b. T sh a -> T sh b -> T sh a
<* :: forall a b. T sh a -> T sh b -> T sh a
Applicative, Applicative (T sh)
Applicative (T sh)
-> (forall a b. T sh a -> (a -> T sh b) -> T sh b)
-> (forall a b. T sh a -> T sh b -> T sh b)
-> (forall a. a -> T sh a)
-> Monad (T sh)
forall sh. Applicative (T sh)
forall a. a -> T sh a
forall sh a. a -> T sh a
forall a b. T sh a -> T sh b -> T sh b
forall a b. T sh a -> (a -> T sh b) -> T sh b
forall sh a b. T sh a -> T sh b -> T sh b
forall sh a b. T sh a -> (a -> T sh b) -> T sh b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall sh a b. T sh a -> (a -> T sh b) -> T sh b
>>= :: forall a b. T sh a -> (a -> T sh b) -> T sh b
$c>> :: forall sh a b. T sh a -> T sh b -> T sh b
>> :: forall a b. T sh a -> T sh b -> T sh b
$creturn :: forall sh a. a -> T sh a
return :: forall a. a -> T sh a
Monad)

run ::
   (Shape.Indexed sh, Shape.Index sh ~ ix) =>
   sh -> Bounds ix -> T sh a -> a
run :: forall sh ix a.
(Indexed sh, Index sh ~ ix) =>
sh -> Bounds ix -> T sh a -> a
run sh
shape Bounds ix
bounds (Cons ReaderT (sh, Ptr Highs) IO a
act) =
   IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ ContT a IO a -> IO a
forall a. ContT a IO a -> IO a
runContT (ContT a IO a -> IO a) -> ContT a IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
      Ptr Highs
model <- ((Ptr Highs -> IO a) -> IO a) -> ContT a IO (Ptr Highs)
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
MC.ContT (((Ptr Highs -> IO a) -> IO a) -> ContT a IO (Ptr Highs))
-> ((Ptr Highs -> IO a) -> IO a) -> ContT a IO (Ptr Highs)
forall a b. (a -> b) -> a -> b
$ IO (Ptr Highs)
-> (Ptr Highs -> IO ()) -> (Ptr Highs -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (Ptr Highs)
Highs.create Ptr Highs -> IO ()
Highs.destroy
      IO () -> ContT a IO ()
forall a. IO a -> ContT a IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ContT a IO ()) -> IO () -> ContT a IO ()
forall a b. (a -> b) -> a -> b
$ Ptr Highs -> IO ()
Debug.initLog Ptr Highs
model
      Ptr HighsInt
startPtr <- Array (ZeroBased Int) HighsInt -> ContT a IO (Ptr HighsInt)
forall sh a r. Array sh a -> ContT r IO (Ptr a)
withBuffer (Array (ZeroBased Int) HighsInt -> ContT a IO (Ptr HighsInt))
-> Array (ZeroBased Int) HighsInt -> ContT a IO (Ptr HighsInt)
forall a b. (a -> b) -> a -> b
$ [HighsInt] -> Array (ZeroBased Int) HighsInt
forall a. Storable a => [a] -> Array (ZeroBased Int) a
Array.vectorFromList [HighsInt
0]
      Ptr HighsInt
indexPtr <- Array (ZeroBased Int) HighsInt -> ContT a IO (Ptr HighsInt)
forall sh a r. Array sh a -> ContT r IO (Ptr a)
withBuffer (Array (ZeroBased Int) HighsInt -> ContT a IO (Ptr HighsInt))
-> Array (ZeroBased Int) HighsInt -> ContT a IO (Ptr HighsInt)
forall a b. (a -> b) -> a -> b
$ [HighsInt] -> Array (ZeroBased Int) HighsInt
forall a. Storable a => [a] -> Array (ZeroBased Int) a
Array.vectorFromList []
      let numCols :: Int
numCols = sh -> Int
forall sh. C sh => sh -> Int
Shape.size sh
shape
      Ptr CDouble
objPtr <- Array (ZeroBased Int) CDouble -> ContT a IO (Ptr CDouble)
forall sh a r. Array sh a -> ContT r IO (Ptr a)
withBuffer (Array (ZeroBased Int) CDouble -> ContT a IO (Ptr CDouble))
-> Array (ZeroBased Int) CDouble -> ContT a IO (Ptr CDouble)
forall a b. (a -> b) -> a -> b
$ ZeroBased Int -> CDouble -> Array (ZeroBased Int) CDouble
forall sh a. (Indexed sh, Storable a) => sh -> a -> Array sh a
Array.replicate (Int -> ZeroBased Int
forall n. n -> ZeroBased n
Shape.ZeroBased Int
numCols) CDouble
0
      let emptyDoublePtr :: Ptr CDouble
emptyDoublePtr = Ptr CDouble
objPtr
      (Ptr CDouble
collbPtr,Ptr CDouble
colubPtr) <-
         (Array sh CDouble, Array sh CDouble)
-> ContT a IO (Ptr CDouble, Ptr CDouble)
forall sh r.
(Array sh CDouble, Array sh CDouble)
-> ContT r IO (Ptr CDouble, Ptr CDouble)
storeBounds ((Array sh CDouble, Array sh CDouble)
 -> ContT a IO (Ptr CDouble, Ptr CDouble))
-> (Array sh CDouble, Array sh CDouble)
-> ContT a IO (Ptr CDouble, Ptr CDouble)
forall a b. (a -> b) -> a -> b
$ sh -> Bounds ix -> (Array sh CDouble, Array sh CDouble)
forall sh ix.
(Indexed sh, Index sh ~ ix) =>
sh -> Bounds ix -> (Array sh CDouble, Array sh CDouble)
prepareColumnBoundsArrays sh
shape Bounds ix
bounds
      IO () -> ContT a IO ()
forall a. IO a -> ContT a IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ContT a IO ()) -> IO () -> ContT a IO ()
forall a b. (a -> b) -> a -> b
$ IO Status -> IO ()
checkStatus (IO Status -> IO ()) -> IO Status -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr Highs
-> HighsInt
-> HighsInt
-> HighsInt
-> MatrixFormat
-> ObjSense
-> CDouble
-> Ptr CDouble
-> Ptr CDouble
-> Ptr CDouble
-> Ptr CDouble
-> Ptr CDouble
-> Ptr HighsInt
-> Ptr HighsInt
-> Ptr CDouble
-> IO Status
Highs.passLp Ptr Highs
model
         (Int -> HighsInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
numCols)
         HighsInt
0
         HighsInt
0
         MatrixFormat
Highs.matrixFormatRowwise
         ObjSense
Highs.objSenseMaximize
         CDouble
0 Ptr CDouble
objPtr
         Ptr CDouble
collbPtr Ptr CDouble
colubPtr
         Ptr CDouble
emptyDoublePtr Ptr CDouble
emptyDoublePtr
         Ptr HighsInt
startPtr Ptr HighsInt
indexPtr Ptr CDouble
emptyDoublePtr
      IO a -> ContT a IO a
forall a. IO a -> ContT a IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> ContT a IO a) -> IO a -> ContT a IO a
forall a b. (a -> b) -> a -> b
$ ReaderT (sh, Ptr Highs) IO a -> (sh, Ptr Highs) -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
MR.runReaderT ReaderT (sh, Ptr Highs) IO a
act (sh
shape, Ptr Highs
model)

{- |
Add new constraints to an existing problem
and run with a new direction and objective.

>>> :{
   case Shape.indexTupleFromShape tripletShape of
      (x,y,z) ->
         fmap (mapSnd Array.toTuple) $ snd $
         LP.run tripletShape []
            (LP.solve LP.simplex
               [[2.*x, 1.*y] <=. 10, [1.*y, (5::Double).*z] <=. 20]
               (LP.Maximize, Array.fromTuple (4,-3,2)
                                 :: Array.Array TripletShape Double))
:}
Just (28.0,(5.0,0.0,4.0))

prop> :{
   forAllMethod $ \method ->
   TestLP.forAllOrigin $ \origin ->
   TestLP.forAllProblem origin $ \bounds constrs ->
   QC.forAll (TestLP.genObjective origin) $ \(dir,obj) ->
   case (CLP.solve method bounds constrs (dir,obj),
         LP.run (Array.shape origin) bounds $
            LP.solve method constrs (dir,obj)) of
      ((_, Just (optA,_)), (_, Just (optB,_))) ->
         TestLP.approxReal 0.1 optA optB; _ -> False
:}

prop> :{
   forAllMethod $ \method ->
   TestLP.forAllOrigin $ \origin ->
   TestLP.forAllProblem origin $ \bounds constrs ->
   TestLP.forAllObjectives origin $ \objs_ ->
   case TestLP.successiveObjectives origin 0.01 objs_ of
      (dirObj, objs) ->
         either
            (\msg -> QC.counterexample (show msg) False)
            (const $ QC.property True) $
         runSuccessive method (Array.shape origin) bounds (constrs,dirObj) objs
:}

prop> :{
   forAllMethod $ \method ->
   TestLP.forAllOrigin $ \origin ->
   TestLP.forAllProblem origin $ \bounds constrs ->
   TestLP.forAllObjectives origin $ \objs_ ->
   let shape = Array.shape origin in
   case TestLP.successiveObjectives origin 0.01 objs_ of
      (dirObj, objs) ->
         approxSuccession 0.01
            (solveSuccessiveWarm method shape bounds (constrs,dirObj) objs)
            (solveSuccessiveGen method shape bounds (constrs,dirObj) objs)
:}
-}
solve ::
   (Eq sh, Shape.Indexed sh, Shape.Index sh ~ ix) =>
   Method -> Constraints Double ix ->
   (Direction, Objective sh) -> T sh (Result sh)
solve :: forall sh ix.
(Eq sh, Indexed sh, Index sh ~ ix) =>
Method
-> Constraints Double ix
-> (Direction, Objective sh)
-> T sh (Result sh)
solve = Query sh (Double, Array sh Double)
-> Method
-> Constraints Double ix
-> (Direction, Array sh Double)
-> T sh (ModelStatus, Maybe (Double, Array sh Double))
forall sh ix result.
(Eq sh, Indexed sh, Index sh ~ ix) =>
Query sh result
-> Method
-> Constraints Double ix
-> (Direction, Objective sh)
-> T sh (ModelStatus, Maybe result)
solveWith Query sh (Double, Array sh Double)
forall sh. C sh => Query sh (Double, Array sh Double)
Priv.getResult

solveWith ::
   (Eq sh, Shape.Indexed sh, Shape.Index sh ~ ix) =>
   Query sh result ->
   Method -> Constraints Double ix ->
   (Direction, Objective sh) -> T sh (LPEnum.ModelStatus, Maybe result)
solveWith :: forall sh ix result.
(Eq sh, Indexed sh, Index sh ~ ix) =>
Query sh result
-> Method
-> Constraints Double ix
-> (Direction, Objective sh)
-> T sh (ModelStatus, Maybe result)
solveWith Query sh result
query Method
method Constraints Double ix
constrs (Direction
dir,Objective sh
obj) = ReaderT (sh, Ptr Highs) IO (ModelStatus, Maybe result)
-> T sh (ModelStatus, Maybe result)
forall sh a. ReaderT (sh, Ptr Highs) IO a -> T sh a
Cons (ReaderT (sh, Ptr Highs) IO (ModelStatus, Maybe result)
 -> T sh (ModelStatus, Maybe result))
-> ReaderT (sh, Ptr Highs) IO (ModelStatus, Maybe result)
-> T sh (ModelStatus, Maybe result)
forall a b. (a -> b) -> a -> b
$ do
   (sh
shape, Ptr Highs
model) <- ReaderT (sh, Ptr Highs) IO (sh, Ptr Highs)
forall (m :: * -> *) r. Monad m => ReaderT r m r
MR.ask
   Bool
-> ReaderT (sh, Ptr Highs) IO () -> ReaderT (sh, Ptr Highs) IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (sh
shape sh -> sh -> Bool
forall a. Eq a => a -> a -> Bool
/= Objective sh -> sh
forall sh a. Array sh a -> sh
Array.shape Objective sh
obj) (ReaderT (sh, Ptr Highs) IO () -> ReaderT (sh, Ptr Highs) IO ())
-> ReaderT (sh, Ptr Highs) IO () -> ReaderT (sh, Ptr Highs) IO ()
forall a b. (a -> b) -> a -> b
$
      [Char] -> ReaderT (sh, Ptr Highs) IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"HiGHS.LP.Monad.solve: objective shape mismatch"

   let numRows :: Int
numRows = Constraints Double ix -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Constraints Double ix
constrs
   IO () -> ReaderT (sh, Ptr Highs) IO ()
forall a. IO a -> ReaderT (sh, Ptr Highs) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT (sh, Ptr Highs) IO ())
-> IO () -> ReaderT (sh, Ptr Highs) IO ()
forall a b. (a -> b) -> a -> b
$ ContT () IO () -> IO ()
forall a. ContT a IO a -> IO a
runContT (ContT () IO () -> IO ()) -> ContT () IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      let (Array (ZeroBased Int) CDouble
coefficients, Array (ZeroBased Int) HighsInt
indices, Array (ZeroBased Int) HighsInt
rowStarts) = sh
-> Constraints Double ix
-> (Array (ZeroBased Int) CDouble, Array (ZeroBased Int) HighsInt,
    Array (ZeroBased Int) HighsInt)
forall sh ix.
(Indexed sh, Index sh ~ ix) =>
sh
-> Constraints Double ix
-> (Array (ZeroBased Int) CDouble, Array (ZeroBased Int) HighsInt,
    Array (ZeroBased Int) HighsInt)
prepareConstraints sh
shape Constraints Double ix
constrs
      (Ptr CDouble
coefficientsPtr, Ptr HighsInt
indexPtr, Ptr HighsInt
startPtr)
         <- (Array (ZeroBased Int) CDouble, Array (ZeroBased Int) HighsInt,
 Array (ZeroBased Int) HighsInt)
-> ContT () IO (Ptr CDouble, Ptr HighsInt, Ptr HighsInt)
forall r.
(Array (ZeroBased Int) CDouble, Array (ZeroBased Int) HighsInt,
 Array (ZeroBased Int) HighsInt)
-> ContT r IO (Ptr CDouble, Ptr HighsInt, Ptr HighsInt)
storeConstraints (Array (ZeroBased Int) CDouble
coefficients, Array (ZeroBased Int) HighsInt
indices, Array (ZeroBased Int) HighsInt
rowStarts)
      (Ptr CDouble
rowlbPtr,Ptr CDouble
rowubPtr) <- (Array (ZeroBased Int) CDouble, Array (ZeroBased Int) CDouble)
-> ContT () IO (Ptr CDouble, Ptr CDouble)
forall sh r.
(Array sh CDouble, Array sh CDouble)
-> ContT r IO (Ptr CDouble, Ptr CDouble)
storeBounds ((Array (ZeroBased Int) CDouble, Array (ZeroBased Int) CDouble)
 -> ContT () IO (Ptr CDouble, Ptr CDouble))
-> (Array (ZeroBased Int) CDouble, Array (ZeroBased Int) CDouble)
-> ContT () IO (Ptr CDouble, Ptr CDouble)
forall a b. (a -> b) -> a -> b
$ Constraints Double ix
-> (Array (ZeroBased Int) CDouble, Array (ZeroBased Int) CDouble)
forall ix.
Bounds ix
-> (Array (ZeroBased Int) CDouble, Array (ZeroBased Int) CDouble)
prepareRowBoundsArrays Constraints Double ix
constrs
      Ptr CDouble
objPtr <- Array sh CDouble -> ContT () IO (Ptr CDouble)
forall sh a r. Array sh a -> ContT r IO (Ptr a)
withBuffer (Array sh CDouble -> ContT () IO (Ptr CDouble))
-> Array sh CDouble -> ContT () IO (Ptr CDouble)
forall a b. (a -> b) -> a -> b
$ (Double -> CDouble) -> Objective sh -> Array sh CDouble
forall sh a b.
(C sh, Storable a, Storable b) =>
(a -> b) -> Array sh a -> Array sh b
Array.map Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac Objective sh
obj
      IO () -> ContT () IO ()
forall a. IO a -> ContT () IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ContT () IO ()) -> IO () -> ContT () IO ()
forall a b. (a -> b) -> a -> b
$ do
         IO Status -> IO ()
checkStatus (IO Status -> IO ()) -> IO Status -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr Highs
-> HighsInt
-> Ptr CDouble
-> Ptr CDouble
-> HighsInt
-> Ptr HighsInt
-> Ptr HighsInt
-> Ptr CDouble
-> IO Status
Highs.addRows Ptr Highs
model (Int -> HighsInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
numRows)
            Ptr CDouble
rowlbPtr Ptr CDouble
rowubPtr
            (Int -> HighsInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> HighsInt) -> Int -> HighsInt
forall a b. (a -> b) -> a -> b
$ ZeroBased Int -> Int
forall sh. C sh => sh -> Int
Shape.size (ZeroBased Int -> Int) -> ZeroBased Int -> Int
forall a b. (a -> b) -> a -> b
$ Array (ZeroBased Int) CDouble -> ZeroBased Int
forall sh a. Array sh a -> sh
Array.shape Array (ZeroBased Int) CDouble
coefficients)
            Ptr HighsInt
startPtr Ptr HighsInt
indexPtr Ptr CDouble
coefficientsPtr
         let numCols :: Int
numCols = sh -> Int
forall sh. C sh => sh -> Int
Shape.size sh
shape
         Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
numColsInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO Status -> IO ()
checkStatus (IO Status -> IO ()) -> IO Status -> IO ()
forall a b. (a -> b) -> a -> b
$
            Ptr Highs -> HighsInt -> HighsInt -> Ptr CDouble -> IO Status
Highs.changeColsCostByRange Ptr Highs
model
               HighsInt
0 (Int -> HighsInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
numCols HighsInt -> HighsInt -> HighsInt
forall a. Num a => a -> a -> a
- HighsInt
1) Ptr CDouble
objPtr

   IO (ModelStatus, Maybe result)
-> ReaderT (sh, Ptr Highs) IO (ModelStatus, Maybe result)
forall a. IO a -> ReaderT (sh, Ptr Highs) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ModelStatus, Maybe result)
 -> ReaderT (sh, Ptr Highs) IO (ModelStatus, Maybe result))
-> IO (ModelStatus, Maybe result)
-> ReaderT (sh, Ptr Highs) IO (ModelStatus, Maybe result)
forall a b. (a -> b) -> a -> b
$ do
      Ptr Highs -> Method -> IO ()
setMethod Ptr Highs
model Method
method
      IO Status -> IO ()
checkStatus (IO Status -> IO ()) -> IO Status -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr Highs -> ObjSense -> IO Status
Highs.changeObjectiveSense Ptr Highs
model (ObjSense -> IO Status) -> ObjSense -> IO Status
forall a b. (a -> b) -> a -> b
$ Direction -> ObjSense
objectiveSense Direction
dir
      Query sh result
-> sh -> Ptr Highs -> Status -> IO (ModelStatus, Maybe result)
forall sh a.
C sh =>
Query sh a
-> sh -> Ptr Highs -> Status -> IO (ModelStatus, Maybe a)
examineStatus Query sh result
query sh
shape Ptr Highs
model (Status -> IO (ModelStatus, Maybe result))
-> IO Status -> IO (ModelStatus, Maybe result)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr Highs -> IO Status
Highs.run Ptr Highs
model