{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{- |
The monadic interface to CLP allows to optimize
with respect to multiple objectives, successively.
-}
module Numeric.COINOR.CLP.Monad (
   T,
   run,
   simplex,
   concurrent,
   Direction(..),
   Priv.dual, Priv.primal,
   ) where

import qualified Numeric.COINOR.CLP.FFI as FFI
import qualified Numeric.COINOR.CLP.Debug as Debug
import qualified Numeric.COINOR.CLP.Private as Priv
import Numeric.COINOR.CLP.Private
         (Method(runMethod), Result,
          runContT, withBuffer,
          storeBounds, prepareRowBoundsArrays, prepareColumnBoundsArrays,
          storeConstraints, prepareConstraints,
          setOptimizationDirection, 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 Data.NonEmpty as NonEmpty
import Data.NonEmpty ((!:))
import Data.Traversable (for)
import Data.Foldable (traverse_)

import qualified Control.Concurrent.Split.MVar as MVar
import qualified Control.Concurrent as Conc
import qualified Control.Monad.Trans.RWS as MRWS
import Control.Monad.IO.Class (liftIO)
import Control.Monad (when)

import System.IO.Unsafe (unsafePerformIO)

import Foreign.Ptr (Ptr, nullPtr)


{- $setup
>>> :set -XTypeFamilies
>>> :set -XTypeOperators
>>> import qualified Numeric.COINOR.CLP.Monad as LP
>>> import qualified Numeric.COINOR.CLP as CLP
>>> import Test.Numeric.COINOR.CLP.Utility (traverse_Lag, traverseLag)
>>> import Test.Numeric.COINOR.CLP (TripletShape, tripletShape, forAllMethod)
>>> import Numeric.COINOR.CLP (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 Data.NonEmpty ((!:))
>>>
>>> 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.FailureType (NonEmpty.T [] (a, Array sh a)) ->
>>>    Either CLP.FailureType (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.FailureType ()
>>> runSuccessive method shape bounds (constrs,dirObj) objs =
>>>    LP.run shape bounds $ ME.runExceptT $ do
>>>       (opt, _xs) <- ME.ExceptT $ LP.simplex method constrs dirObj
>>>       traverse_Lag opt
>>>          (\prevResult (newConstr, dirObjI) -> do
>>>              (optI, _xs) <-
>>>                 ME.ExceptT $
>>>                    LP.simplex method (newConstr prevResult) dirObjI
>>>              return optI)
>>>          objs
>>>
>>> solveSuccessiveWarm ::
>>>    (Eq sh, Shape.Indexed sh, Shape.Index sh ~ ix, Traversable t) =>
>>>    (Constraints ix -> (Direction, Objective sh) ->
>>>       LP.T sh (Either CLP.FailureType (Double, Array sh Double))) ->
>>>    sh ->
>>>    Bounds ix ->
>>>    (Constraints ix, (Direction, Objective sh)) ->
>>>    t (Double -> Constraints ix, (Direction, Objective sh)) ->
>>>    Either CLP.FailureType (NonEmpty.T t (Double, Array sh Double))
>>> solveSuccessiveWarm solver shape bounds (constrs,dirObj) objs =
>>>    LP.run shape bounds $ ME.runExceptT $ do
>>>       result <- ME.ExceptT $ solver constrs dirObj
>>>       NonEmpty.Cons result <$>
>>>          traverseLag result
>>>             (\(prevOpt, _xs) (newConstr, dirObjI) ->
>>>                 ME.ExceptT $ solver (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.FailureType (NonEmpty.T t (Double, Array sh Double))
>>> solveSuccessiveGen method shape bounds (constrs,dirObj) objs =
>>>    LPMonad.run shape bounds $ ME.runExceptT $ do
>>>       result <-
>>>          ME.ExceptT $ LPMonad.lift (CLP.simplex method) constrs dirObj
>>>       NonEmpty.Cons result <$>
>>>          traverseLag result
>>>             (\(prevOpt, _xs) (newConstr, dirObjI) ->
>>>                 ME.ExceptT $
>>>                    LPMonad.lift (CLP.simplex method)
>>>                       (newConstr prevOpt) dirObjI)
>>>             objs
-}


newtype T sh a = Cons (MRWS.RWST sh () (Ptr FFI.Simplex) 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)

-- FixMe: investigate the segmentation fault on CTRL-C!
-- also happens in CLP
-- investigate using valgrind, could be a problem in Coin-or, though
-- Check, whether pure C programs are also affected.
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 RWST sh () (Ptr Simplex) 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 Simplex
lp <- IO (Ptr Simplex) -> ContT a IO (Ptr Simplex)
forall a. IO a -> ContT a IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Ptr Simplex)
FFI.newModel
      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 Simplex -> IO ()
Debug.initLog Ptr Simplex
lp
      Ptr BigIndex
startPtr <- Array (ZeroBased Int) BigIndex -> ContT a IO (Ptr BigIndex)
forall sh a r. Array sh a -> ContT r IO (Ptr a)
withBuffer (Array (ZeroBased Int) BigIndex -> ContT a IO (Ptr BigIndex))
-> Array (ZeroBased Int) BigIndex -> ContT a IO (Ptr BigIndex)
forall a b. (a -> b) -> a -> b
$ [BigIndex] -> Array (ZeroBased Int) BigIndex
forall a. Storable a => [a] -> Array (ZeroBased Int) a
Array.vectorFromList [BigIndex
0]
      (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
      {-
      We would like to force row-major matrix layout,
      but even if we start with a CoinPackedMatrix in row-major layout,
      addRows switches back to column-major layout.
      -}
      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
$ do
         Ptr Simplex
-> CInt
-> Ptr CDouble
-> Ptr CDouble
-> Ptr CDouble
-> Ptr BigIndex
-> Ptr CInt
-> Ptr CDouble
-> IO ()
FFI.addColumns Ptr Simplex
lp (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CInt) -> Int -> CInt
forall a b. (a -> b) -> a -> b
$ sh -> Int
forall sh. C sh => sh -> Int
Shape.size sh
shape)
            Ptr CDouble
collbPtr Ptr CDouble
colubPtr Ptr CDouble
forall a. Ptr a
nullPtr
            Ptr BigIndex
startPtr Ptr CInt
forall a. Ptr a
nullPtr Ptr CDouble
forall a. Ptr a
nullPtr
         (a
a, Ptr Simplex
lpFinal, ()) <- RWST sh () (Ptr Simplex) IO a
-> sh -> Ptr Simplex -> IO (a, Ptr Simplex, ())
forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
MRWS.runRWST RWST sh () (Ptr Simplex) IO a
act sh
shape Ptr Simplex
lp
         Ptr Simplex -> IO ()
FFI.deleteModel Ptr Simplex
lpFinal
         a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

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

>>> :{
   case Shape.indexTupleFromShape tripletShape of
      (x,y,z) ->
         mapSnd Array.toTuple <$>
         LP.run tripletShape []
            (LP.simplex LP.dual
               [[2.*x, 1.*y] <=. 10, [1.*y, (5::Double).*z] <=. 20]
               (LP.Maximize, Array.fromTuple (4,-3,2) :: Array.Array TripletShape Double))
:}
Right (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.simplex method bounds constrs (dir,obj),
         LP.run (Array.shape origin) bounds $
            LP.simplex method constrs (dir,obj)) of
      (Right (optA,_), Right (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_ ->
   case TestLP.successiveObjectives origin 0.01 objs_ of
      (dirObj, objs) ->
         approxSuccession 0.01
            (solveSuccessiveWarm (LP.simplex method)
               (Array.shape origin) bounds (constrs,dirObj) objs)
            (solveSuccessiveGen method
               (Array.shape origin) bounds (constrs,dirObj) objs)
:}
-}
simplex ::
   (Eq sh, Shape.Indexed sh, Shape.Index sh ~ ix) =>
   Method -> Constraints Double ix ->
   (Direction, Objective sh) -> T sh (Result sh)
simplex :: forall sh ix.
(Eq sh, Indexed sh, Index sh ~ ix) =>
Method
-> Constraints Double ix
-> (Direction, Objective sh)
-> T sh (Result sh)
simplex Method
method Constraints Double ix
constrs (Direction
dir,Objective sh
obj) = RWST sh () (Ptr Simplex) IO (Result sh) -> T sh (Result sh)
forall sh a. RWST sh () (Ptr Simplex) IO a -> T sh a
Cons (RWST sh () (Ptr Simplex) IO (Result sh) -> T sh (Result sh))
-> RWST sh () (Ptr Simplex) IO (Result sh) -> T sh (Result sh)
forall a b. (a -> b) -> a -> b
$ do
   sh
shape <- RWST sh () (Ptr Simplex) IO sh
forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m r
MRWS.ask
   Ptr Simplex
lp <- RWST sh () (Ptr Simplex) IO (Ptr Simplex)
forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
MRWS.get
   IO (Result sh) -> RWST sh () (Ptr Simplex) IO (Result sh)
forall a. IO a -> RWST sh () (Ptr Simplex) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Result sh) -> RWST sh () (Ptr Simplex) IO (Result sh))
-> IO (Result sh) -> RWST sh () (Ptr Simplex) IO (Result sh)
forall a b. (a -> b) -> a -> b
$ do
      Ptr Simplex
-> sh
-> Constraints Double ix
-> (Direction, Objective sh)
-> IO ()
forall sh ix.
(Eq sh, Indexed sh, Index sh ~ ix) =>
Ptr Simplex
-> sh
-> Constraints Double ix
-> (Direction, Objective sh)
-> IO ()
storeStage Ptr Simplex
lp sh
shape Constraints Double ix
constrs (Direction
dir,Objective sh
obj)
--      FFI.dumpMatrix lp
      Method -> Ptr Simplex -> IO ()
runMethod Method
method Ptr Simplex
lp
      sh -> Ptr Simplex -> IO (Result sh)
forall sh. C sh => sh -> Ptr Simplex -> IO (Result sh)
examineStatus sh
shape Ptr Simplex
lp


{- |
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) ->
         approxSuccession 0.01
            (solveSuccessiveWarm (LP.simplex method)
               (Array.shape origin) bounds (constrs,dirObj) objs)
            (solveSuccessiveWarm
               (LP.concurrent (NonEmpty.singleton method))
               (Array.shape origin) bounds (constrs,dirObj) objs)
:}
prop> :{
   forAllMethod $ \method ->
   forAllMethod $ \methodA ->
   forAllMethod $ \methodB ->
   forAllMethod $ \methodC ->
   TestLP.forAllOrigin $ \origin ->
   TestLP.forAllProblem origin $ \bounds constrs ->
   TestLP.forAllObjectives origin $ \objs_ ->
   case TestLP.successiveObjectives origin 0.01 objs_ of
      (dirObj, objs) ->
         approxSuccession 0.01
            (solveSuccessiveWarm (LP.simplex method)
               (Array.shape origin) bounds (constrs,dirObj) objs)
            (solveSuccessiveWarm
               (LP.concurrent (methodA!:methodB:methodC:[]))
               (Array.shape origin) bounds (constrs,dirObj) objs)
:}
-}
concurrent ::
   (Eq sh, Shape.Indexed sh, Shape.Index sh ~ ix) =>
   NonEmpty.T [] Method -> Constraints Double ix ->
   (Direction, Objective sh) -> T sh (Result sh)
concurrent :: forall sh ix.
(Eq sh, Indexed sh, Index sh ~ ix) =>
T [] Method
-> Constraints Double ix
-> (Direction, Objective sh)
-> T sh (Result sh)
concurrent (NonEmpty.Cons Method
method [Method]
methods) Constraints Double ix
constrs (Direction
dir,Objective sh
obj) =
   RWST sh () (Ptr Simplex) IO (Result sh) -> T sh (Result sh)
forall sh a. RWST sh () (Ptr Simplex) IO a -> T sh a
Cons (RWST sh () (Ptr Simplex) IO (Result sh) -> T sh (Result sh))
-> RWST sh () (Ptr Simplex) IO (Result sh) -> T sh (Result sh)
forall a b. (a -> b) -> a -> b
$ (sh -> Ptr Simplex -> IO (Result sh, Ptr Simplex, ()))
-> RWST sh () (Ptr Simplex) IO (Result sh)
forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
MRWS.RWST ((sh -> Ptr Simplex -> IO (Result sh, Ptr Simplex, ()))
 -> RWST sh () (Ptr Simplex) IO (Result sh))
-> (sh -> Ptr Simplex -> IO (Result sh, Ptr Simplex, ()))
-> RWST sh () (Ptr Simplex) IO (Result sh)
forall a b. (a -> b) -> a -> b
$ \sh
shape Ptr Simplex
lp -> do

   Ptr Simplex
-> sh
-> Constraints Double ix
-> (Direction, Objective sh)
-> IO ()
forall sh ix.
(Eq sh, Indexed sh, Index sh ~ ix) =>
Ptr Simplex
-> sh
-> Constraints Double ix
-> (Direction, Objective sh)
-> IO ()
storeStage Ptr Simplex
lp sh
shape Constraints Double ix
constrs (Direction
dir,Objective sh
obj)

   [Ptr Simplex]
lps <-
      [Method] -> (Method -> IO (Ptr Simplex)) -> IO [Ptr Simplex]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Method]
methods ((Method -> IO (Ptr Simplex)) -> IO [Ptr Simplex])
-> (Method -> IO (Ptr Simplex)) -> IO [Ptr Simplex]
forall a b. (a -> b) -> a -> b
$ IO (Ptr Simplex) -> Method -> IO (Ptr Simplex)
forall a b. a -> b -> a
const (IO (Ptr Simplex) -> Method -> IO (Ptr Simplex))
-> IO (Ptr Simplex) -> Method -> IO (Ptr Simplex)
forall a b. (a -> b) -> a -> b
$ do
         Ptr Simplex
newLp <- Ptr Simplex -> IO (Ptr Simplex)
FFI.copyModel Ptr Simplex
lp
         Ptr Simplex -> IO ()
Debug.initLog Ptr Simplex
newLp
         Ptr Simplex -> IO (Ptr Simplex)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr Simplex
newLp

   (In (Ptr Simplex)
resultIn, Out (Ptr Simplex)
resultOut) <- IO (In (Ptr Simplex), Out (Ptr Simplex))
forall a. IO (In a, Out a)
MVar.newEmpty
   T [] ThreadId
threads <-
      T [] (Method, Ptr Simplex)
-> ((Method, Ptr Simplex) -> IO ThreadId) -> IO (T [] ThreadId)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for ((Method
method,Ptr Simplex
lp) (Method, Ptr Simplex)
-> [(Method, Ptr Simplex)] -> T [] (Method, Ptr Simplex)
forall a (f :: * -> *). a -> f a -> T f a
!: [Method] -> [Ptr Simplex] -> [(Method, Ptr Simplex)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Method]
methods [Ptr Simplex]
lps) (((Method, Ptr Simplex) -> IO ThreadId) -> IO (T [] ThreadId))
-> ((Method, Ptr Simplex) -> IO ThreadId) -> IO (T [] ThreadId)
forall a b. (a -> b) -> a -> b
$ \(Method
methodi,Ptr Simplex
lpi) ->
      IO () -> IO ThreadId
Conc.forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
         Method -> Ptr Simplex -> IO ()
runMethod Method
methodi Ptr Simplex
lpi
         In (Ptr Simplex) -> Ptr Simplex -> IO ()
forall a. In a -> a -> IO ()
MVar.put In (Ptr Simplex)
resultIn Ptr Simplex
lpi
   Ptr Simplex
lpWinner <- Out (Ptr Simplex) -> IO (Ptr Simplex)
forall a. Out a -> IO a
MVar.take Out (Ptr Simplex)
resultOut
   (ThreadId -> IO ()) -> T [] ThreadId -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ThreadId -> IO ()
Conc.killThread T [] ThreadId
threads
   (Ptr Simplex -> IO ()) -> [Ptr Simplex] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Ptr Simplex -> IO ()
FFI.deleteModel ([Ptr Simplex] -> IO ()) -> [Ptr Simplex] -> IO ()
forall a b. (a -> b) -> a -> b
$ (Ptr Simplex -> Bool) -> [Ptr Simplex] -> [Ptr Simplex]
forall a. (a -> Bool) -> [a] -> [a]
filter (Ptr Simplex
lpWinnerPtr Simplex -> Ptr Simplex -> Bool
forall a. Eq a => a -> a -> Bool
/=) ([Ptr Simplex] -> [Ptr Simplex]) -> [Ptr Simplex] -> [Ptr Simplex]
forall a b. (a -> b) -> a -> b
$ Ptr Simplex
lpPtr Simplex -> [Ptr Simplex] -> [Ptr Simplex]
forall a. a -> [a] -> [a]
:[Ptr Simplex]
lps
   (Result sh -> (Result sh, Ptr Simplex, ()))
-> IO (Result sh) -> IO (Result sh, Ptr Simplex, ())
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Result sh
result -> (Result sh
result, Ptr Simplex
lpWinner, ())) (IO (Result sh) -> IO (Result sh, Ptr Simplex, ()))
-> IO (Result sh) -> IO (Result sh, Ptr Simplex, ())
forall a b. (a -> b) -> a -> b
$
      sh -> Ptr Simplex -> IO (Result sh)
forall sh. C sh => sh -> Ptr Simplex -> IO (Result sh)
examineStatus sh
shape Ptr Simplex
lpWinner


storeStage ::
   (Eq sh, Shape.Indexed sh, Shape.Index sh ~ ix) =>
   Ptr FFI.Simplex -> sh ->
   Constraints Double ix -> (Direction, Objective sh) -> IO ()
storeStage :: forall sh ix.
(Eq sh, Indexed sh, Index sh ~ ix) =>
Ptr Simplex
-> sh
-> Constraints Double ix
-> (Direction, Objective sh)
-> IO ()
storeStage Ptr Simplex
lp sh
shape Constraints Double ix
constrs (Direction
dir,Objective sh
obj) = do
   Bool -> IO () -> 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) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"COINOR.CLP.Monad.solve: objective shape mismatch"

   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
      (Ptr CDouble
coefficientsPtr, Ptr CInt
indexPtr, Ptr BigIndex
startPtr) <-
         (Array (ZeroBased Int) CDouble, Array (ZeroBased Int) CInt,
 Array (ZeroBased Int) BigIndex)
-> ContT () IO (Ptr CDouble, Ptr CInt, Ptr BigIndex)
forall r.
(Array (ZeroBased Int) CDouble, Array (ZeroBased Int) CInt,
 Array (ZeroBased Int) BigIndex)
-> ContT r IO (Ptr CDouble, Ptr CInt, Ptr BigIndex)
storeConstraints ((Array (ZeroBased Int) CDouble, Array (ZeroBased Int) CInt,
  Array (ZeroBased Int) BigIndex)
 -> ContT () IO (Ptr CDouble, Ptr CInt, Ptr BigIndex))
-> (Array (ZeroBased Int) CDouble, Array (ZeroBased Int) CInt,
    Array (ZeroBased Int) BigIndex)
-> ContT () IO (Ptr CDouble, Ptr CInt, Ptr BigIndex)
forall a b. (a -> b) -> a -> b
$ sh
-> Constraints Double ix
-> (Array (ZeroBased Int) CDouble, Array (ZeroBased Int) CInt,
    Array (ZeroBased Int) BigIndex)
forall sh ix.
(Indexed sh, Index sh ~ ix) =>
sh
-> Constraints Double ix
-> (Array (ZeroBased Int) CDouble, Array (ZeroBased Int) CInt,
    Array (ZeroBased Int) BigIndex)
prepareConstraints sh
shape Constraints Double ix
constrs
      (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
         Ptr Simplex
-> CInt
-> Ptr CDouble
-> Ptr CDouble
-> Ptr BigIndex
-> Ptr CInt
-> Ptr CDouble
-> IO ()
FFI.addRows Ptr Simplex
lp (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CInt) -> Int -> CInt
forall a b. (a -> b) -> a -> b
$ Constraints Double ix -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Constraints Double ix
constrs)
            Ptr CDouble
rowlbPtr Ptr CDouble
rowubPtr Ptr BigIndex
startPtr Ptr CInt
indexPtr Ptr CDouble
coefficientsPtr
         Ptr Simplex -> Ptr CDouble -> IO ()
FFI.chgObjCoefficients Ptr Simplex
lp Ptr CDouble
objPtr

   Ptr Simplex -> Direction -> IO ()
setOptimizationDirection Ptr Simplex
lp Direction
dir

{-
2024-01-05 with Nix on clp/HEAD

Numeric.COINOR.CLP:182: passed
Numeric.COINOR.CLP:193: passed
Numeric.COINOR.CLP:204: passed
Numeric.COINOR.CLP:216: passed
Numeric.COINOR.CLP:227: passed
Numeric.COINOR.CLP:270: +++ OK, passed 1000000 tests.
Numeric.COINOR.CLP:279: +++ OK, passed 1000000 tests.
Numeric.COINOR.CLP:288: +++ OK, passed 1000000 tests.
Numeric.COINOR.CLP:300: +++ OK, passed 1000000 tests.
Numeric.COINOR.CLP:315: +++ OK, passed 1000000 tests.
Numeric.COINOR.CLP:329: +++ OK, passed 1000000 tests.
Numeric.COINOR.CLP:340: +++ OK, passed 1000000 tests.
Numeric.COINOR.CLP:355: +++ OK, passed 1000000 tests.
Numeric.COINOR.CLP.Monad:183: passed
Numeric.COINOR.CLP.Monad:194: +++ OK, passed 1000000 tests.
Numeric.COINOR.CLP.Monad:206: +++ OK, passed 1000000 tests.
Numeric.COINOR.CLP.Monad:217: *** Failed! Falsified (after 680659 tests and 4 shrinks):
primal
StorableArray.fromList (Range {rangeFrom = 'a', rangeTo = 'j'}) [6,10,-6,9,-3,-4,-5,3,5,2]
([Inequality 'a' (Between (-92.0) 79.0),Inequality 'b' (Between (-71.0) 92.0),Inequality 'c' (Between (-59.0) 78.0),Inequality 'd' (Between (-79.0) 103.0),Inequality 'e' (Between (-72.0) 85.0),Inequality 'f' (Between (-86.0) 54.0),Inequality 'g' (Between (-93.0) 62.0),Inequality 'h' (Between (-61.0) 55.0),Inequality 'i' (Between (-68.0) 88.0),Inequality 'j' (Between (-97.0) 101.0)],[Inequality [Term 7.0 'a',Term 8.0 'b',Term 3.0 'e',Term 3.0 'f',Term (-7.0) 'i'] (Between 44.0 67.0),Inequality [Term 8.0 'b',Term (-9.0) 'c',Term (-6.0) 'e',Term (-9.0) 'f',Term 3.0 'g',Term 9.0 'i'] (Between 198.0 239.0),Inequality [Term (-2.0) 'g',Term (-7.0) 'h',Term 3.0 'j'] (Between (-25.0) 19.0),Inequality [Term (-4.0) 'b',Term (-7.0) 'c',Term (-6.0) 'e',Term (-3.0) 'f',Term (-2.0) 'g',Term (-8.0) 'h',Term (-1.0) 'i',Term 2.0 'j'] (Between 8.0 39.0),Inequality [Term 9.0 'e',Term 10.0 'h',Term 1.0 'i'] (Between 8.0 17.0),Inequality [Term 0.0 'a',Term 5.0 'd',Term (-9.0) 'e',Term (-5.0) 'g',Term 10.0 'j'] (Between 96.0 138.0),Inequality [Term 3.0 'c',Term 1.0 'e'] (Between (-41.0) (-7.0)),Inequality [Term (-9.0) 'a',Term 3.0 'c',Term 10.0 'd',Term (-8.0) 'e',Term 0.0 'f',Term 8.0 'i',Term (-7.0) 'j'] (GreaterEqual 57.0),Inequality [Term 10.0 'a',Term 10.0 'd',Term 2.0 'f',Term (-8.0) 'i'] (LessEqual 116.0),Inequality [Term 4.0 'a',Term 6.0 'b',Term (-7.0) 'c',Term 10.0 'd',Term 10.0 'f',Term 3.0 'g',Term 1.0 'h'] (LessEqual 183.0)])
(Maximize,[Term (-6.0) 'b',Term (-3.0) 'f'])!:(Maximize,[Term 9.0 'j']):(Maximize,[Term 3.0 'a',Term 1.0 'e']):(Minimize,[Term (-9.0) 'g']):[]
Right ((18.497129964454135,StorableArray.fromList (Range {rangeFrom = 'a', rangeTo = 'j'}) [74.26133932062942,-4.610513284679251,3.407071102069632,-17.96410791778895,-17.221213306208895,3.0553165812071237,-93.0,11.535555135702769,56.63536839885239,-43.41703801669353])!:(-358.5835187154048,StorableArray.fromList (Range {rangeFrom = 'a', rangeTo = 'j'}) [68.21790432868416,-3.5093014066749015,3.0081518939388605,-15.652437505815044,-16.024455681816583,0.8562261585317592,-85.69364365974626,10.97992110681299,51.42089006821934,-39.84261319060053]):(188.63452765280144,StorableArray.fromList (Range {rangeFrom = 'a', rangeTo = 'j'}) [68.21978577278595,-3.5096438045816516,3.0082765551854775,-15.653157239173282,-16.024829665556435,0.8569109543452587,-85.69592020710948,10.980095358440579,51.422513405602146,-39.84372430171164]):(771.2427929377163,StorableArray.fromList (Range {rangeFrom = 'a', rangeTo = 'j'}) [68.21790432868416,-3.5093014066749015,3.0081518939388605,-15.652437505815044,-16.024455681816583,0.8562261585317592,-85.69364365974626,10.97992110681299,51.42089006821934,-39.84261319060053]):[])
Right ((18.497129964454135,StorableArray.fromList (Range {rangeFrom = 'a', rangeTo = 'j'}) [74.26133932062942,-4.610513284679251,3.407071102069632,-17.96410791778895,-17.221213306208895,3.0553165812071237,-93.0,11.535555135702769,56.63536839885239,-43.41703801669353])!:(-358.5835187154088,StorableArray.fromList (Range {rangeFrom = 'a', rangeTo = 'j'}) [68.21790432868491,-3.509301406675042,3.0081518939389102,-15.652437505815314,-16.024455681816733,0.8562261585320396,-85.69364365974717,10.979921106813057,51.42089006822,-39.84261319060098]):(188.6345276528035,StorableArray.fromList (Range {rangeFrom = 'a', rangeTo = 'j'}) [68.2197857727867,-3.5096438045817804,3.0082765551855246,-15.65315723917356,-16.024829665556577,0.8569109543455168,-85.69592020711036,10.980095358440636,51.42251340560279,-39.843724301712086]):(771.2244389610247,StorableArray.fromList (Range {rangeFrom = 'a', rangeTo = 'j'}) [68.21621638238075,-3.5089938589417318,3.00804049811292,-15.651792022272504,-16.02412149433876,0.855611063065419,-85.69160432900274,10.97976602331364,51.41943321590163,-39.84161549827]):[])

Total: 17
Failures: 1
-}