packages feed

math-programming-tests (empty) → 0.3.0

raw patch · 9 files changed

+376/−0 lines, 9 filesdep +basedep +math-programmingdep +tastysetup-changed

Dependencies added: base, math-programming, tasty, tasty-hunit, tasty-quickcheck, text

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for math-programming-api-tests++## Unreleased changes
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,4 @@+# math-programming-tests++This library provides utility functions for testing backends to the+`math-programming` library.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ math-programming-tests.cabal view
@@ -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 <https://github.com/prsteele/math-programming-api-tests#readme>++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
+ src/Math/Programming/Tests.hs view
@@ -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+    ]
+ src/Math/Programming/Tests/Api.hs view
@@ -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
+ src/Math/Programming/Tests/IP.hs view
@@ -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)
+ src/Math/Programming/Tests/LP.hs view
@@ -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)