{-# LANGUAGE FlexibleContexts #-}
module Math.Programming.Tests.IP where
import Control.Monad.IO.Class
import Math.Programming
import Test.Hspec
makeIPTests ::
(MonadIO m, MonadIP v c o m) =>
(m () -> IO ()) ->
Spec
makeIPTests :: forall (m :: * -> *) v c o.
(MonadIO m, MonadIP v c o m) =>
(m () -> IO ()) -> Spec
makeIPTests m () -> IO ()
runner =
String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"IP problems" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"solves a simple MIP" (m () -> IO ()
runner m ()
forall (m :: * -> *) v c o. (MonadIO m, MonadIP v c o m) => m ()
simpleMIPTest)
simpleMIPTest :: (MonadIO m, MonadIP v c o m) => m ()
simpleMIPTest :: forall (m :: * -> *) v c o. (MonadIO m, MonadIP v c o m) => m ()
simpleMIPTest = do
v
x <- Double -> Double -> m v
forall v c o (m :: * -> *).
MonadLP v c o m =>
Double -> Double -> m v
bounded Double
0 Double
5 m v -> Domain -> m v
forall v c o (m :: * -> *). MonadIP v c o m => m v -> Domain -> m v
`asKind` Domain
Integer
v
y <- Double -> Double -> m v
forall v c o (m :: * -> *).
MonadLP v c o m =>
Double -> Double -> m v
bounded Double
0 Double
5 m v -> Domain -> m v
forall v c o (m :: * -> *). MonadIP v c o m => m v -> Domain -> m v
`asKind` Domain
Continuous
c
_ <- v -> LinExpr Double v
forall a b. Num a => b -> LinExpr a b
var v
x LinExpr Double v -> Double -> m c
forall v c o (m :: * -> *).
MonadLP v c o m =>
Expr v -> Double -> m c
.>= Double
1.1
c
_ <- v -> LinExpr Double v
forall a b. Num a => b -> LinExpr a b
var v
y LinExpr Double v -> Double -> m c
forall v c o (m :: * -> *).
MonadLP v c o m =>
Expr v -> Double -> m c
.>= Double
1.1
o
objective <- LinExpr Double v -> m o
forall v c o (m :: * -> *). MonadLP v c o m => Expr v -> m o
minimize (LinExpr Double v -> m o) -> LinExpr Double v -> m o
forall a b. (a -> b) -> a -> b
$ v -> LinExpr Double v
forall a b. Num a => b -> LinExpr a b
var v
x LinExpr Double v -> LinExpr Double v -> LinExpr Double v
forall a b. Num a => LinExpr a b -> LinExpr a b -> LinExpr a b
.+. v -> LinExpr Double v
forall a b. Num a => b -> LinExpr a b
var v
y
SolutionStatus
status <- m SolutionStatus
forall v c o (m :: * -> *). MonadIP v c o m => m SolutionStatus
optimizeIP
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ SolutionStatus
status SolutionStatus -> SolutionStatus -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` SolutionStatus
Optimal
let expectedX :: Double
expectedX = Double
2
expectedY :: Double
expectedY = Double
1.1
expectedObj :: Double
expectedObj = Double
expectedX Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
expectedY
Double
vx <- v -> m Double
forall v c o (m :: * -> *). MonadLP v c o m => v -> m Double
getVariableValue v
x
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Double -> Double
forall a. Num a => a -> a
abs (Double
vx Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
expectedX) Double -> (Double -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` (Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
1e-3)
Double
vy <- v -> m Double
forall v c o (m :: * -> *). MonadLP v c o m => v -> m Double
getVariableValue v
y
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Double -> Double
forall a. Num a => a -> a
abs (Double
vy Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
expectedY) Double -> (Double -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` (Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
1e-3)
Double
vobj <- o -> m Double
forall v c o (m :: * -> *). MonadLP v c o m => o -> m Double
getObjectiveValue o
objective
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Double -> Double
forall a. Num a => a -> a
abs (Double
vobj Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
expectedObj) Double -> (Double -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` (Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
1e-3)