{-# 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) =>
  -- | The runner for the API being tested.
  (m () -> IO ()) ->
  -- | The resulting test suite.
  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)

-- | We solve a simple MIP of the form
--
-- @
-- min  x + y
-- s.t. x >= 1.1
--      y >= 1.1
--      0 <= x <= 5
--      0 <= y <= 5
--      x integer
-- @
--
-- The optimal solution to this MIP is x = 2, y = 1.1.
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

  -- Check that we reached optimality
  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)