{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Numeric.COINOR.CLP.Monad (
T,
run,
simplex,
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 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, nullPtr)
newtype T sh a = Cons (MR.ReaderT (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)
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 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 <- ((Ptr Simplex -> IO a) -> IO a) -> ContT a IO (Ptr Simplex)
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
MC.ContT (((Ptr Simplex -> IO a) -> IO a) -> ContT a IO (Ptr Simplex))
-> ((Ptr Simplex -> IO a) -> IO a) -> ContT a IO (Ptr Simplex)
forall a b. (a -> b) -> a -> b
$ IO (Ptr Simplex)
-> (Ptr Simplex -> IO ()) -> (Ptr Simplex -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (Ptr Simplex)
FFI.newModel Ptr Simplex -> IO ()
FFI.deleteModel
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
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
-> 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
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 Simplex) IO a -> (sh, Ptr Simplex) -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
MR.runReaderT ReaderT (sh, Ptr Simplex) IO a
act (sh
shape, Ptr Simplex
lp)
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) = ReaderT (sh, Ptr Simplex) IO (Result sh) -> T sh (Result sh)
forall sh a. ReaderT (sh, Ptr Simplex) IO a -> T sh a
Cons (ReaderT (sh, Ptr Simplex) IO (Result sh) -> T sh (Result sh))
-> ReaderT (sh, Ptr Simplex) IO (Result sh) -> T sh (Result sh)
forall a b. (a -> b) -> a -> b
$ do
(sh
shape, Ptr Simplex
lp) <- ReaderT (sh, Ptr Simplex) IO (sh, Ptr Simplex)
forall (m :: * -> *) r. Monad m => ReaderT r m r
MR.ask
Bool
-> ReaderT (sh, Ptr Simplex) IO ()
-> ReaderT (sh, Ptr Simplex) 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 Simplex) IO ()
-> ReaderT (sh, Ptr Simplex) IO ())
-> ReaderT (sh, Ptr Simplex) IO ()
-> ReaderT (sh, Ptr Simplex) IO ()
forall a b. (a -> b) -> a -> b
$
[Char] -> ReaderT (sh, Ptr Simplex) IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"COINOR.CLP.Monad.solve: objective shape mismatch"
IO () -> ReaderT (sh, Ptr Simplex) IO ()
forall a. IO a -> ReaderT (sh, Ptr Simplex) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT (sh, Ptr Simplex) IO ())
-> IO () -> ReaderT (sh, Ptr Simplex) 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
(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
IO (Result sh) -> ReaderT (sh, Ptr Simplex) IO (Result sh)
forall a. IO a -> ReaderT (sh, Ptr Simplex) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Result sh) -> ReaderT (sh, Ptr Simplex) IO (Result sh))
-> IO (Result sh) -> ReaderT (sh, Ptr Simplex) IO (Result sh)
forall a b. (a -> b) -> a -> b
$ do
Ptr Simplex -> Direction -> IO ()
setOptimizationDirection Ptr Simplex
lp Direction
dir
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