diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for math-programming-api-tests + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Patrick Steele (c) 2018 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Patrick Steele nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,4 @@ +# math-programming-tests + +This library provides utility functions for testing backends to the +`math-programming` library. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/math-programming-tests.cabal b/math-programming-tests.cabal new file mode 100644 --- /dev/null +++ b/math-programming-tests.cabal @@ -0,0 +1,44 @@ +cabal-version: 1.12 +name: math-programming-tests +version: 0.3.0 +license: BSD3 +license-file: LICENSE +copyright: 2018 Patrick Steele +maintainer: steele.pat@gmail.com +author: Patrick Steele +homepage: https://github.com/prsteele/math-programming-tests#readme +bug-reports: https://github.com/prsteele/math-programming-tests/issues +synopsis: + Utility functions for testing implementations of the math-programming library. + +description: + Please see the README on GitHub at + +category: Math +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/prsteele/math-programming-tests + +library + exposed-modules: + Math.Programming.Tests + Math.Programming.Tests.Api + Math.Programming.Tests.IP + Math.Programming.Tests.LP + + hs-source-dirs: src + other-modules: Paths_math_programming_tests + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >=4.12.0.0 && <4.13, + math-programming >=0.3.0 && <0.4, + tasty >=1.2.3 && <1.3, + tasty-hunit >=0.10.0.2 && <0.11, + tasty-quickcheck >=0.10.1.1 && <0.11, + text >=1.2.3.1 && <1.3 diff --git a/src/Math/Programming/Tests.hs b/src/Math/Programming/Tests.hs new file mode 100644 --- /dev/null +++ b/src/Math/Programming/Tests.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE FlexibleContexts #-} +module Math.Programming.Tests where + +import Control.Monad.IO.Class +import Test.Tasty +import Text.Printf + +import Math.Programming +import Math.Programming.Tests.Api +import Math.Programming.Tests.IP +import Math.Programming.Tests.LP + +makeAllTests + :: (PrintfArg (Numeric m), RealFrac (Numeric m), MonadIO m, IPMonad m) + => String -- ^ The name of the API being tested. This will + -- be used to generate test group names. + -> (m () -> IO ()) -- ^ The runner for the API being tested. + -> TestTree -- ^ The resulting test suite. +makeAllTests apiName runner + = testGroup (printf "Math.Programming tests (%s)" apiName) + [ makeApiTests runner + , makeLPTests runner + , makeIPTests runner + ] diff --git a/src/Math/Programming/Tests/Api.hs b/src/Math/Programming/Tests/Api.hs new file mode 100644 --- /dev/null +++ b/src/Math/Programming/Tests/Api.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Math.Programming.Tests.Api where + +import Control.Monad.IO.Class +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +import Math.Programming + +makeApiTests + :: (Num (Numeric m), MonadIO m, LPMonad m) + => (m () -> IO ()) -- ^ The runner for the API being tested. + -> TestTree -- ^ The resulting test suite. +makeApiTests runner = testGroup "API tests" + [ testCase "Set/get variable names" (runner setGetVariableName) + , testCase "Set/get constraint names" (runner setGetConstraintName) + ] + +-- | We should be able to set and retrieve variable names +setGetVariableName :: (MonadIO m, LPMonad m) => m () +setGetVariableName = do + let name = "foo" + x <- free + setVariableName x name + + vName <- getVariableName x + liftIO $ vName @?= name + +-- | We should be able to set and retrieve constraint names +setGetConstraintName :: (Num (Numeric m), MonadIO m, LPMonad m) => m () +setGetConstraintName = do + let name = "foo" + x <- free + c <- (x @>=# 0) `named` name + cName <- getConstraintName c + liftIO $ cName @?= name + +data Action + = AddVariable + | AddConstraint + | AddThenDeleteVariable + | AddThenDeleteConstraint + deriving + ( Enum + , Show + ) + +instance Arbitrary Action where + arbitrary = elements actions + where + actions = [AddVariable .. AddThenDeleteConstraint] + +newtype LPActions m = LPActions (m ()) + +instance LPMonad m => Arbitrary (LPActions m) where + arbitrary = LPActions <$> sized lpActions + +lpActions :: LPMonad m => Int -> Gen (m ()) +lpActions remaining + | remaining <= 0 = return (return ()) + | otherwise = do + action <- arbitrary + case action of + AddVariable + -> return (addVariable >> return ()) + AddThenDeleteVariable + -> bindOver addVariable removeVariable <$> lpActions (remaining - 1) + _ -> return (return ()) + +-- | Execute the monadic bind (>>=), with some other actions taken in +-- between. +bindOver + :: (Monad m) + => m a -- ^ The action providing the passed value + -> (a -> m b) -- ^ The function to bind to + -> m () -- ^ The intermediate actions + -> m b -- ^ The resulting value +bindOver action fn intermediate = action >>= (\x -> intermediate >> fn x) + +arbitraryLPActionsProp :: LPActions m -> m () +arbitraryLPActionsProp (LPActions actions) = actions diff --git a/src/Math/Programming/Tests/IP.hs b/src/Math/Programming/Tests/IP.hs new file mode 100644 --- /dev/null +++ b/src/Math/Programming/Tests/IP.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE FlexibleContexts #-} +module Math.Programming.Tests.IP where + +import Control.Monad.IO.Class +import Test.Tasty +import Test.Tasty.HUnit +import Text.Printf + +import Math.Programming + +makeIPTests + :: (PrintfArg (Numeric m), RealFrac (Numeric m), MonadIO m, IPMonad m) + => (m () -> IO ()) -- ^ The runner for the API being tested. + -> TestTree -- ^ The resulting test suite. +makeIPTests runner = testGroup "IP problems" + [ testCase "Simple MIP" (runner 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 :: (PrintfArg (Numeric m), RealFrac (Numeric m), MonadIO m, IPMonad m) => m () +simpleMIPTest = do + x <- bounded 0 5 `asKind` Integer + y <- bounded 0 5 `asKind` Continuous + _ <- x @>=# 1.1 + _ <- y @>=# 1.1 + objective <- minimize $ x @+@ y + status <- optimizeIP + + -- Check that we reached optimality + liftIO $ status @?= Optimal + + vx <- getVariableValue x + let expectedX = 2 + xmsg = printf "Expected x to be 2, but is %.3f" vx + liftIO $ assertBool xmsg (abs (vx - expectedX) <= 1e-3) + + vy <- getVariableValue y + let expectedY = 1.1 + ymsg = printf "Expected y to be 1.1, but is %.3f" vy + liftIO $ assertBool ymsg (abs (vy - expectedY) <= 1e-3) + + vobj <- getObjectiveValue objective + let expectedObj = expectedX + expectedY + objMsg = printf "Expected optimal solution to be %f, but is %f" expectedObj vobj + liftIO $ assertBool objMsg (abs (vobj - expectedObj) <= 1e-3) diff --git a/src/Math/Programming/Tests/LP.hs b/src/Math/Programming/Tests/LP.hs new file mode 100644 --- /dev/null +++ b/src/Math/Programming/Tests/LP.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Math.Programming.Tests.LP where + +import Control.Monad +import Control.Monad.IO.Class +import Test.Tasty +import Test.Tasty.HUnit +import Text.Printf + +import Math.Programming + +makeLPTests + :: (PrintfArg (Numeric m), RealFrac (Numeric m), MonadIO m, LPMonad m) + => (m () -> IO ()) -- ^ The runner for the API being tested. + -> TestTree -- ^ The resulting test suite. +makeLPTests runner = testGroup "LP problems" + [ testCase "Diet problem" (runner dietProblemTest) + ] + +data Food = Corn | Milk | Bread + deriving + ( Eq + , Ord + , Read + , Show + ) + +data Nutrient = Calories | VitaminA + deriving + ( Eq + , Ord + , Read + , Show + ) + +dietProblemTest :: forall m. (PrintfArg (Numeric m), RealFrac (Numeric m), MonadIO m, LPMonad m) => m () +dietProblemTest = + let + cost :: Food -> Numeric m + cost Corn = 0.18 + cost Milk = 0.23 + cost Bread = 0.05 + + nutrition :: Nutrient -> Food -> Numeric m + nutrition Calories Corn = 72 + nutrition VitaminA Corn = 107 + nutrition Calories Milk = 121 + nutrition VitaminA Milk = 500 + nutrition Calories Bread = 65 + nutrition VitaminA Bread = 0 + + foods :: [Food] + foods = [Corn, Milk, Bread] + + nutrients :: [Nutrient] + nutrients = [Calories, VitaminA] + + maxServings :: Numeric m + maxServings = 10 + + nutrientBounds :: Nutrient -> (Numeric m, Numeric m) + nutrientBounds Calories = (2000, 2250) + nutrientBounds VitaminA = (5000, 50000) + + expected :: Food -> Numeric m + expected Corn = 1.94 + expected Milk = 10 + expected Bread = 10 + + expectedCost :: Numeric m + expectedCost = 3.15 + + amountInterval :: Bounds (Numeric m) + amountInterval = Interval 0 maxServings + + amountName :: Food -> String + amountName food = printf "amount[%s]" (show food) + + nutrientMaxName :: Nutrient -> String + nutrientMaxName nutrient = printf "%s_max" (show nutrient) + + nutrientMinName :: Nutrient -> String + nutrientMinName nutrient = printf "%s_min" (show nutrient) + + in do + -- Create the decision variables + amounts <- forM foods $ \food -> do + v <- addVariable `within` amountInterval `named` (amountName food) + return (food, v) + + -- Create the nutrient constraints + forM_ nutrients $ \nutrient -> do + let lhs = exprSum [nutrition nutrient food #*@ v | (food, v) <- amounts] + (lower, upper) = nutrientBounds nutrient + _ <- (lhs .<=# upper) `named` (nutrientMaxName nutrient) + _ <- (lhs .>=# lower) `named` (nutrientMinName nutrient) + pure () + + -- Set the objective + let objectiveExpr = exprSum [cost food #*@ v | (food, v) <- amounts] + objective <- addObjective objectiveExpr + setObjectiveSense objective Minimization + + -- Solve the problem + status <- optimizeLP + + -- Check that we reached optimality + liftIO $ status @?= Optimal + + -- Check the variable values + forM_ amounts $ \(food, v) -> do + x <- getVariableValue v + + let correct = expected food + msg = printf + "Amount of %s should be about %.2f, but is %.3f" + (show food) + correct + x + liftIO $ assertBool msg (abs (x - correct) <= 1e-1) + + -- Check the objective value + objectiveValue <- evalExpr objectiveExpr + let msg = printf + "Objective should be about %.2f, but is %.3f" + expectedCost + objectiveValue + liftIO $ assertBool msg (abs (objectiveValue - expectedCost) < 1e-1)