{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Math.Programming.Tests.LP where

import Control.Monad
import Control.Monad.IO.Class
import qualified Data.Text as T
import Math.Programming
import Test.Hspec
import Text.Printf

makeLPTests ::
  (MonadIO m, MonadLP v c o m) =>
  -- | The runner for the API being tested.
  (m () -> IO ()) ->
  -- | The resulting test suite.
  Spec
makeLPTests :: forall (m :: * -> *) v c o.
(MonadIO m, MonadLP v c o m) =>
(m () -> IO ()) -> Spec
makeLPTests m () -> IO ()
runner =
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"LP 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 the diet problem" (m () -> IO ()
runner m ()
forall (m :: * -> *) v c o. (MonadIO m, MonadLP v c o m) => m ()
dietProblemTest)

data Food = Corn | Milk | Bread
  deriving
    ( Food -> Food -> Bool
(Food -> Food -> Bool) -> (Food -> Food -> Bool) -> Eq Food
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Food -> Food -> Bool
$c/= :: Food -> Food -> Bool
== :: Food -> Food -> Bool
$c== :: Food -> Food -> Bool
Eq,
      Eq Food
Eq Food
-> (Food -> Food -> Ordering)
-> (Food -> Food -> Bool)
-> (Food -> Food -> Bool)
-> (Food -> Food -> Bool)
-> (Food -> Food -> Bool)
-> (Food -> Food -> Food)
-> (Food -> Food -> Food)
-> Ord Food
Food -> Food -> Bool
Food -> Food -> Ordering
Food -> Food -> Food
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Food -> Food -> Food
$cmin :: Food -> Food -> Food
max :: Food -> Food -> Food
$cmax :: Food -> Food -> Food
>= :: Food -> Food -> Bool
$c>= :: Food -> Food -> Bool
> :: Food -> Food -> Bool
$c> :: Food -> Food -> Bool
<= :: Food -> Food -> Bool
$c<= :: Food -> Food -> Bool
< :: Food -> Food -> Bool
$c< :: Food -> Food -> Bool
compare :: Food -> Food -> Ordering
$ccompare :: Food -> Food -> Ordering
Ord,
      ReadPrec [Food]
ReadPrec Food
Int -> ReadS Food
ReadS [Food]
(Int -> ReadS Food)
-> ReadS [Food] -> ReadPrec Food -> ReadPrec [Food] -> Read Food
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Food]
$creadListPrec :: ReadPrec [Food]
readPrec :: ReadPrec Food
$creadPrec :: ReadPrec Food
readList :: ReadS [Food]
$creadList :: ReadS [Food]
readsPrec :: Int -> ReadS Food
$creadsPrec :: Int -> ReadS Food
Read,
      Int -> Food -> ShowS
[Food] -> ShowS
Food -> String
(Int -> Food -> ShowS)
-> (Food -> String) -> ([Food] -> ShowS) -> Show Food
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Food] -> ShowS
$cshowList :: [Food] -> ShowS
show :: Food -> String
$cshow :: Food -> String
showsPrec :: Int -> Food -> ShowS
$cshowsPrec :: Int -> Food -> ShowS
Show
    )

data Nutrient = Calories | VitaminA
  deriving
    ( Nutrient -> Nutrient -> Bool
(Nutrient -> Nutrient -> Bool)
-> (Nutrient -> Nutrient -> Bool) -> Eq Nutrient
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Nutrient -> Nutrient -> Bool
$c/= :: Nutrient -> Nutrient -> Bool
== :: Nutrient -> Nutrient -> Bool
$c== :: Nutrient -> Nutrient -> Bool
Eq,
      Eq Nutrient
Eq Nutrient
-> (Nutrient -> Nutrient -> Ordering)
-> (Nutrient -> Nutrient -> Bool)
-> (Nutrient -> Nutrient -> Bool)
-> (Nutrient -> Nutrient -> Bool)
-> (Nutrient -> Nutrient -> Bool)
-> (Nutrient -> Nutrient -> Nutrient)
-> (Nutrient -> Nutrient -> Nutrient)
-> Ord Nutrient
Nutrient -> Nutrient -> Bool
Nutrient -> Nutrient -> Ordering
Nutrient -> Nutrient -> Nutrient
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Nutrient -> Nutrient -> Nutrient
$cmin :: Nutrient -> Nutrient -> Nutrient
max :: Nutrient -> Nutrient -> Nutrient
$cmax :: Nutrient -> Nutrient -> Nutrient
>= :: Nutrient -> Nutrient -> Bool
$c>= :: Nutrient -> Nutrient -> Bool
> :: Nutrient -> Nutrient -> Bool
$c> :: Nutrient -> Nutrient -> Bool
<= :: Nutrient -> Nutrient -> Bool
$c<= :: Nutrient -> Nutrient -> Bool
< :: Nutrient -> Nutrient -> Bool
$c< :: Nutrient -> Nutrient -> Bool
compare :: Nutrient -> Nutrient -> Ordering
$ccompare :: Nutrient -> Nutrient -> Ordering
Ord,
      ReadPrec [Nutrient]
ReadPrec Nutrient
Int -> ReadS Nutrient
ReadS [Nutrient]
(Int -> ReadS Nutrient)
-> ReadS [Nutrient]
-> ReadPrec Nutrient
-> ReadPrec [Nutrient]
-> Read Nutrient
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Nutrient]
$creadListPrec :: ReadPrec [Nutrient]
readPrec :: ReadPrec Nutrient
$creadPrec :: ReadPrec Nutrient
readList :: ReadS [Nutrient]
$creadList :: ReadS [Nutrient]
readsPrec :: Int -> ReadS Nutrient
$creadsPrec :: Int -> ReadS Nutrient
Read,
      Int -> Nutrient -> ShowS
[Nutrient] -> ShowS
Nutrient -> String
(Int -> Nutrient -> ShowS)
-> (Nutrient -> String) -> ([Nutrient] -> ShowS) -> Show Nutrient
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Nutrient] -> ShowS
$cshowList :: [Nutrient] -> ShowS
show :: Nutrient -> String
$cshow :: Nutrient -> String
showsPrec :: Int -> Nutrient -> ShowS
$cshowsPrec :: Int -> Nutrient -> ShowS
Show
    )

dietProblemTest :: (MonadIO m, MonadLP v c o m) => m ()
dietProblemTest :: forall (m :: * -> *) v c o. (MonadIO m, MonadLP v c o m) => m ()
dietProblemTest =
  let cost :: Food -> Double
      cost :: Food -> Double
cost Food
Corn = Double
0.18
      cost Food
Milk = Double
0.23
      cost Food
Bread = Double
0.05

      nutrition :: Nutrient -> Food -> Double
      nutrition :: Nutrient -> Food -> Double
nutrition Nutrient
Calories Food
Corn = Double
72
      nutrition Nutrient
VitaminA Food
Corn = Double
107
      nutrition Nutrient
Calories Food
Milk = Double
121
      nutrition Nutrient
VitaminA Food
Milk = Double
500
      nutrition Nutrient
Calories Food
Bread = Double
65
      nutrition Nutrient
VitaminA Food
Bread = Double
0

      foods :: [Food]
      foods :: [Food]
foods = [Food
Corn, Food
Milk, Food
Bread]

      nutrients :: [Nutrient]
      nutrients :: [Nutrient]
nutrients = [Nutrient
Calories, Nutrient
VitaminA]

      maxServings :: Double
      maxServings :: Double
maxServings = Double
10

      nutrientBounds :: Nutrient -> (Double, Double)
      nutrientBounds :: Nutrient -> (Double, Double)
nutrientBounds Nutrient
Calories = (Double
2000, Double
2250)
      nutrientBounds Nutrient
VitaminA = (Double
5000, Double
50000)

      expected :: Food -> Double
      expected :: Food -> Double
expected Food
Corn = Double
1.94
      expected Food
Milk = Double
10
      expected Food
Bread = Double
10

      expectedCost :: Double
      expectedCost :: Double
expectedCost = Double
3.15

      amountInterval :: Bounds
      amountInterval :: Bounds
amountInterval = Double -> Double -> Bounds
Interval Double
0 Double
maxServings

      amountName :: Food -> T.Text
      amountName :: Food -> Text
amountName Food
food = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> ShowS
forall r. PrintfType r => String -> r
printf String
"amount[%s]" (Food -> String
forall a. Show a => a -> String
show Food
food)

      nutrientMaxName :: Nutrient -> T.Text
      nutrientMaxName :: Nutrient -> Text
nutrientMaxName Nutrient
nutrient = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> ShowS
forall r. PrintfType r => String -> r
printf String
"%s_max" (Nutrient -> String
forall a. Show a => a -> String
show Nutrient
nutrient)

      nutrientMinName :: Nutrient -> T.Text
      nutrientMinName :: Nutrient -> Text
nutrientMinName Nutrient
nutrient = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> ShowS
forall r. PrintfType r => String -> r
printf String
"%s_min" (Nutrient -> String
forall a. Show a => a -> String
show Nutrient
nutrient)
   in do
        -- Create the decision variables
        [(Food, v)]
amounts <- [Food] -> (Food -> m (Food, v)) -> m [(Food, v)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Food]
foods ((Food -> m (Food, v)) -> m [(Food, v)])
-> (Food -> m (Food, v)) -> m [(Food, v)]
forall a b. (a -> b) -> a -> b
$ \Food
food -> do
          v
v <- m v
forall v c o (m :: * -> *). MonadLP v c o m => m v
free m v -> Bounds -> m v
forall v c o (m :: * -> *). MonadLP v c o m => m v -> Bounds -> m v
`within` Bounds
amountInterval
          v -> Text -> m ()
forall v c o (m :: * -> *). MonadLP v c o m => v -> Text -> m ()
setVariableName v
v (Food -> Text
amountName Food
food)
          (Food, v) -> m (Food, v)
forall (m :: * -> *) a. Monad m => a -> m a
return (Food
food, v
v)

        -- Create the nutrient constraints
        [Nutrient] -> (Nutrient -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Nutrient]
nutrients ((Nutrient -> m ()) -> m ()) -> (Nutrient -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Nutrient
nutrient -> do
          let lhs :: LinExpr Double v
lhs = [LinExpr Double v] -> LinExpr Double v
forall a (t :: * -> *) b.
(Num a, Foldable t) =>
t (LinExpr a b) -> LinExpr a b
esum [Nutrient -> Food -> Double
nutrition Nutrient
nutrient Food
food Double -> v -> LinExpr Double v
forall a b. Num a => a -> b -> LinExpr a b
*. v
v | (Food
food, v
v) <- [(Food, v)]
amounts]
              (Double
lower, Double
upper) = Nutrient -> (Double, Double)
nutrientBounds Nutrient
nutrient
          c
u <- LinExpr Double v
lhs LinExpr Double v -> Double -> m c
forall v c o (m :: * -> *).
MonadLP v c o m =>
Expr v -> Double -> m c
.<= Double
upper
          c -> Text -> m ()
forall v c o (m :: * -> *). MonadLP v c o m => c -> Text -> m ()
setConstraintName c
u (Nutrient -> Text
nutrientMaxName Nutrient
nutrient)
          c
l <- LinExpr Double v
lhs LinExpr Double v -> Double -> m c
forall v c o (m :: * -> *).
MonadLP v c o m =>
Expr v -> Double -> m c
.>= Double
lower
          c -> Text -> m ()
forall v c o (m :: * -> *). MonadLP v c o m => c -> Text -> m ()
setConstraintName c
l (Nutrient -> Text
nutrientMinName Nutrient
nutrient)
          () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

        -- Set the objective
        let objectiveExpr :: LinExpr Double v
objectiveExpr = [LinExpr Double v] -> LinExpr Double v
forall a (t :: * -> *) b.
(Num a, Foldable t) =>
t (LinExpr a b) -> LinExpr a b
esum [Food -> Double
cost Food
food Double -> v -> LinExpr Double v
forall a b. Num a => a -> b -> LinExpr a b
*. v
v | (Food
food, v
v) <- [(Food, v)]
amounts]
        o
objective <- LinExpr Double v -> m o
forall v c o (m :: * -> *). MonadLP v c o m => Expr v -> m o
addObjective LinExpr Double v
objectiveExpr
        o -> Sense -> m ()
forall v c o (m :: * -> *). MonadLP v c o m => o -> Sense -> m ()
setObjectiveSense o
objective Sense
Minimization

        -- Solve the problem
        SolutionStatus
status <- m SolutionStatus
forall v c o (m :: * -> *). MonadLP v c o m => m SolutionStatus
optimizeLP

        -- 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

        -- Check the variable values
        [(Food, v)] -> ((Food, v) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Food, v)]
amounts (((Food, v) -> m ()) -> m ()) -> ((Food, v) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(Food
food, v
v) -> do
          Double
x <- v -> m Double
forall v c o (m :: * -> *). MonadLP v c o m => v -> m Double
getVariableValue v
v
          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
x Double -> Double -> Double
forall a. Num a => a -> a -> a
- Food -> Double
expected Food
food) 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-1)

        -- Check the objective value
        Double
objectiveValue <- LinExpr Double v -> m Double
forall v c o (m :: * -> *). MonadLP v c o m => Expr v -> m Double
evalExpr LinExpr Double v
objectiveExpr
        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
objectiveValue Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
expectedCost) 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-1)