diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,20 @@ -# Changelog for GlpkHs +# Changelog for `glpk-headers` -## Unreleased changes +## [Unreleased] + +- The `mkHaskellErrorHook` function was added to + `Math.Programming.Glpk.Headers` to support writing GLPK error + handlers. + +- The `mkHaskellTermHook` function was added to + `Math.Programming.Glpk.Headers` to support writing GLPK terminal + callback hooks. + +- The `mkHaskellMIPCallback` function was added to + `Math.Programming.Glpk.Headers` to support writing MIP callback + functions. + +## [0.5.0] -- 2021-03-07 + +* Switch from Stack to Cabal (and Nix). +* Update to GHC 8.8.4 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Patrick Steele (c) 2018 +Copyright (c) 2018-2023, Patrick Steele All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,3 +4,7 @@ [GLPK](https://www.gnu.org/software/glpk/). No attempt is made to make these bindings conform to Haskell norms --- they are a direct translation from the GLPK header file. + +## Requirements + +* GLPK >=4.65 diff --git a/glpk-headers.cabal b/glpk-headers.cabal --- a/glpk-headers.cabal +++ b/glpk-headers.cabal @@ -1,51 +1,37 @@ -cabal-version: 1.12 -name: glpk-headers -version: 0.4.1 -license: BSD3 -license-file: LICENSE -copyright: 2018 Patrick Steele -maintainer: steele.pat@gmail.com -author: Patrick Steele -homepage: https://github.com/prsteele/glpk-headers-haskell#readme -bug-reports: https://github.com/prsteele/glpk-headers-haskell/issues -synopsis: Low-level Haskell bindings to GLPK. -description: - Please see the README on GitHub at - -category: Math -build-type: Simple -extra-source-files: - README.md - ChangeLog.md +cabal-version: 2.4 +name: glpk-headers +version: 0.5.0 +synopsis: Low-level Haskell bindings to the GLPK library +description: Please see the README on GitHub at +bug-reports: https://github.com/prsteele/math-programming/issues +license: BSD-3-Clause +license-file: LICENSE +author: Patrick Steele +maintainer: steele.pat@gmail.com +copyright: 2018-2023, Patrick Steele +category: Math +build-type: Simple +extra-source-files: README.md, ChangeLog.md source-repository head - type: git - location: https://github.com/prsteele/glpk-headers-haskell + type: git + location: https://github.com/prsteele/math-programming library - exposed-modules: Math.Programming.Glpk.Header - hs-source-dirs: src - other-modules: Paths_glpk_headers - default-language: Haskell2010 - build-depends: - base >=4.7 && <5, - derive-storable >=0.1.2.0 && <0.3 - -test-suite GlpkHs-test - type: exitcode-stdio-1.0 - main-is: Driver.hs - hs-source-dirs: test - other-modules: - Diet - Paths_glpk_headers + default-language: Haskell2010 + hs-source-dirs: src + exposed-modules: Math.Programming.Glpk.Header + extra-libraries: glpk + build-depends: base <5 + , derive-storable ^>=0.3 - default-language: Haskell2010 - extra-libraries: glpk - ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: - base >=4.7 && <5, - derive-storable >=0.1.2.0 && <0.3, - glpk-headers -any, - tasty >=1.2.3 && <1.3, - tasty-discover >=4.2.1 && <4.3, - tasty-hunit >=0.10.0.2 && <0.11 +test-suite glpk-headers-haskell-test-suite + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + ghc-options: -threaded -with-rtsopts=-N + other-modules: Math.Programming.Glpk.HeadersSpec + build-depends: glpk-headers + , base <5 + , hspec ^>=2.8 diff --git a/src/Math/Programming/Glpk/Header.hsc b/src/Math/Programming/Glpk/Header.hsc --- a/src/Math/Programming/Glpk/Header.hsc +++ b/src/Math/Programming/Glpk/Header.hsc @@ -399,6 +399,11 @@ , glp_config , glp_term_out , glp_term_hook + , glp_error_hook + -- ** Helper functions + , mkHaskellErrorHook + , mkHaskellTermHook + , mkHaskellMIPCallback ) where import Data.Typeable @@ -805,7 +810,6 @@ = GlpkVariableType { fromGlpkVariableType :: CInt } deriving ( Eq - , GStorable , Ord , Read , Show @@ -929,7 +933,6 @@ = GlpkMessageLevel { fromGlpkMessageLevel :: CInt } deriving ( Eq - , GStorable , Ord , Read , Show @@ -951,7 +954,6 @@ = GlpkSimplexMethod { fromGlpkSimplexMethod :: CInt } deriving ( Eq - , GStorable , Ord , Read , Show @@ -971,7 +973,6 @@ = GlpkPricing { fromGlpkPricing :: CInt } deriving ( Eq - , GStorable , Ord , Read , Show @@ -991,7 +992,6 @@ = GlpkRatioTest { fromGlpkRatioTest :: CInt } deriving ( Eq - , GStorable , Ord , Read , Show @@ -1010,7 +1010,6 @@ = GlpkPreCholeskyOrdering { fromGlpkPreCholeskyOrdering :: CInt } deriving ( Eq - , GStorable , Ord , Read , Show @@ -1031,7 +1030,6 @@ = GlpkBranchingTechnique { fromGlpkBranchingTechnique :: CInt } deriving ( Eq - , GStorable , Ord , Read , Show @@ -1053,7 +1051,6 @@ = GlpkBacktrackingTechnique { fromGlpkBacktrackingTechnique :: CInt } deriving ( Eq - , GStorable , Ord , Read , Show @@ -1074,7 +1071,6 @@ = GlpkPreProcessingTechnique { fromGlpkPreProcessingTechnique :: CInt } deriving ( Eq - , GStorable , Ord , Read , Show @@ -1094,7 +1090,6 @@ = GlpkFeasibilityPump { fromGlpkFeasibilityPump :: CInt } deriving ( Eq - , GStorable , Ord , Read , Show @@ -1113,7 +1108,6 @@ = GlpkProximitySearch { fromGlpkProximitySearch :: CInt } deriving ( Eq - , GStorable , Ord , Read , Show @@ -1132,7 +1126,6 @@ = GlpkGomoryCuts { fromGlpkGomoryCuts :: CInt } deriving ( Eq - , GStorable , Ord , Read , Show @@ -1151,7 +1144,6 @@ = GlpkMIRCuts { fromGlpkMIRCuts :: CInt } deriving ( Eq - , GStorable , Ord , Read , Show @@ -1170,7 +1162,6 @@ = GlpkCoverCuts { fromGlpkCoverCuts :: CInt } deriving ( Eq - , GStorable , Ord , Read , Show @@ -1189,7 +1180,6 @@ = GlpkCliqueCuts { fromGlpkCliqueCuts :: CInt } deriving ( Eq - , GStorable , Ord , Read , Show @@ -1208,7 +1198,6 @@ = GlpkPresolve { fromGlpkPresolve :: CInt } deriving ( Eq - , GStorable , Ord , Read , Show @@ -1227,7 +1216,6 @@ = GlpkBinarization { fromGlpkBinarization :: CInt } deriving ( Eq - , GStorable , Ord , Read , Show @@ -1246,7 +1234,6 @@ = GlpkSimpleRounding { fromGlpkSimpleRounding :: CInt } deriving ( Eq - , GStorable , Ord , Read , Show @@ -1265,7 +1252,7 @@ = GlpkConstraintOrigin { fromGlpkConstraintOrigin :: CInt } deriving ( Eq - , GStorable + , Generic , Ord , Read , Show @@ -1285,7 +1272,6 @@ = GlpkCutType { fromGlpkCutType :: CInt } deriving ( Eq - , GStorable , Ord , Read , Show @@ -1306,7 +1292,6 @@ = GlpkControl { fromGlpkControl :: CInt } deriving ( Eq - , GStorable , Ord , Read , Show @@ -1500,7 +1485,6 @@ = GlpkFactorizationType { fromGlpkFactorizationType :: CInt } deriving ( Eq - , GStorable , Ord , Read , Show @@ -2760,3 +2744,17 @@ :: FunPtr (Ptr a -> CString -> IO CInt) -> Ptr a -> IO () + +foreign import ccall "glp_error_hook" glp_error_hook + :: FunPtr (Ptr a -> IO CInt) + -> Ptr a + -> IO () + +foreign import ccall "wrapper" + mkHaskellErrorHook :: (Ptr a -> IO CInt) -> IO (FunPtr (Ptr a -> IO CInt)) + +foreign import ccall "wrapper" + mkHaskellTermHook :: (Ptr a -> IO CInt) -> IO (FunPtr (Ptr a -> IO CInt)) + +foreign import ccall "wrapper" + mkHaskellMIPCallback :: (Ptr (GlpkTree a) -> Ptr a -> IO ()) -> IO (FunPtr (Ptr (GlpkTree a) -> Ptr a -> IO ())) diff --git a/test/Diet.hs b/test/Diet.hs deleted file mode 100644 --- a/test/Diet.hs +++ /dev/null @@ -1,129 +0,0 @@ -module Diet where - -import Control.Monad -import Foreign.C.Types -import Foreign.Ptr -import Test.Tasty -import Test.Tasty.HUnit -import Text.Printf - -import Math.Programming.Glpk.Header - -test_diet :: TestTree -test_diet = testGroup "Diet problem" - [ testCase "Basic diet problem" basicDiet - ] - -data Food = Corn | Milk | Bread - deriving - ( Eq - , Ord - , Read - , Show - ) - -data Nutrient = Calories | VitaminA - deriving - ( Eq - , Ord - , Read - , Show - ) - -basicDiet :: Assertion -basicDiet = - let - cost :: Food -> CDouble - cost Corn = 0.18 - cost Milk = 0.23 - cost Bread = 0.05 - - nutrition :: Nutrient -> Food -> CDouble - 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 :: CDouble - maxServings = 10 - - nutrientBounds :: Nutrient -> (CDouble, CDouble) - nutrientBounds Calories = (2000, 2250) - nutrientBounds VitaminA = (5000, 50000) - - numAmountVariables :: CInt - numAmountVariables = fromIntegral $ length foods - - numNutrientConstraints :: CInt - numNutrientConstraints = fromIntegral (length nutrients) - - expected :: Food -> CDouble - expected Corn = 1.94 - expected Milk = 10 - expected Bread = 10 - - expectedCost :: CDouble - expectedCost = 3.15 - in do - _ <- glp_term_out glpkOff - problem <- glp_create_prob - - -- Create the decision variables - amountStart <- glp_add_cols problem numAmountVariables - let amounts = zip foods [amountStart..] - - -- Create the nutrient constraints - nutrientConStart <- glp_add_rows problem numNutrientConstraints - let nutrientConstraints = zip nutrients [nutrientConStart..] - - -- Set the objective - glp_set_obj_dir problem glpkMin - forM_ amounts $ \(food, column) -> - glp_set_obj_coef problem column (cost food) - - -- Set the right-hand side of the nutrient constraints - forM_ nutrientConstraints $ \(nutrient, row) -> do - let (lower, upper) = nutrientBounds nutrient - glp_set_row_bnds problem row glpkBounded lower upper - - -- Set the body of the nutrient constraints - forM_ nutrientConstraints $ \(nutrient, row) -> - allocaGlpkArray (map snd amounts) $ \indices -> - allocaGlpkArray (map (nutrition nutrient . fst) amounts) $ \coefs -> - glp_set_mat_row problem row numAmountVariables indices coefs - - -- Ensure we don't have too many servings of any one food - forM_ amounts $ \(_, column) -> - glp_set_col_bnds problem column glpkBounded 0 maxServings - - -- Check that we reached optimality - status <- glp_simplex problem nullPtr - status @?= glpkSimplexSuccess - - -- Check the variable values - forM_ amounts $ \(food, column) -> do - x <- glp_get_col_prim problem column - - let correct = expected food - msg = printf - "Amount of %s should be about %.2f, but is %.3f" - (show food) - (realToFrac correct :: Double) - (realToFrac x :: Double) - assertBool msg (abs (x - correct) <= 1e-1) - - -- Check the objective value - objective <- glp_get_obj_val problem - let msg = printf - "Objective should be about %.2f, but is %.3f" - (realToFrac expectedCost :: Double) - (realToFrac objective :: Double) - assertBool msg (abs (objective - expectedCost) < 1e-1) diff --git a/test/Driver.hs b/test/Driver.hs deleted file mode 100644 --- a/test/Driver.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF tasty-discover #-} -{-| -Module : Main - -The entry point for tests. We use tasty-discover to automatically -discover test functions in this directory, so simply preface tasty -tests with test_ for tasty TestTrees, or prop_ for QuickCheck -properties. --} -module Main where diff --git a/test/Math/Programming/Glpk/HeadersSpec.hs b/test/Math/Programming/Glpk/HeadersSpec.hs new file mode 100644 --- /dev/null +++ b/test/Math/Programming/Glpk/HeadersSpec.hs @@ -0,0 +1,115 @@ +module Math.Programming.Glpk.HeadersSpec where + +import Control.Monad +import Foreign.C.Types +import Foreign.Ptr +import Math.Programming.Glpk.Header +import Test.Hspec +import Text.Printf + +spec :: Spec +spec = + describe "GPLK bindings" $ do + it "can solve the diet problem" basicDiet + +data Food = Corn | Milk | Bread + deriving + ( Eq, + Ord, + Read, + Show + ) + +data Nutrient = Calories | VitaminA + deriving + ( Eq, + Ord, + Read, + Show + ) + +basicDiet :: IO () +basicDiet = + let cost :: Food -> CDouble + cost Corn = 0.18 + cost Milk = 0.23 + cost Bread = 0.05 + + nutrition :: Nutrient -> Food -> CDouble + 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 :: CDouble + maxServings = 10 + + nutrientBounds :: Nutrient -> (CDouble, CDouble) + nutrientBounds Calories = (2000, 2250) + nutrientBounds VitaminA = (5000, 50000) + + numAmountVariables :: CInt + numAmountVariables = fromIntegral $ length foods + + numNutrientConstraints :: CInt + numNutrientConstraints = fromIntegral (length nutrients) + + expected :: Food -> CDouble + expected Corn = 1.94 + expected Milk = 10 + expected Bread = 10 + + expectedCost :: CDouble + expectedCost = 3.15 + in do + _ <- glp_term_out glpkOff + problem <- glp_create_prob + + -- Create the decision variables + amountStart <- glp_add_cols problem numAmountVariables + let amounts = zip foods [amountStart ..] + + -- Create the nutrient constraints + nutrientConStart <- glp_add_rows problem numNutrientConstraints + let nutrientConstraints = zip nutrients [nutrientConStart ..] + + -- Set the objective + glp_set_obj_dir problem glpkMin + forM_ amounts $ \(food, column) -> + glp_set_obj_coef problem column (cost food) + + -- Set the right-hand side of the nutrient constraints + forM_ nutrientConstraints $ \(nutrient, row) -> do + let (lower, upper) = nutrientBounds nutrient + glp_set_row_bnds problem row glpkBounded lower upper + + -- Set the body of the nutrient constraints + forM_ nutrientConstraints $ \(nutrient, row) -> + allocaGlpkArray (map snd amounts) $ \indices -> + allocaGlpkArray (map (nutrition nutrient . fst) amounts) $ \coefs -> + glp_set_mat_row problem row numAmountVariables indices coefs + + -- Ensure we don't have too many servings of any one food + forM_ amounts $ \(_, column) -> + glp_set_col_bnds problem column glpkBounded 0 maxServings + + -- Check that we reached optimality + status <- glp_simplex problem nullPtr + status `shouldBe` glpkSimplexSuccess + + -- Check the variable values + forM_ amounts $ \(food, column) -> do + x <- glp_get_col_prim problem column + abs (x - expected food) `shouldSatisfy` (<= 1e-1) + + -- Check the objective value + objective <- glp_get_obj_val problem + abs (objective - expectedCost) `shouldSatisfy` (<= 1e-1) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,3 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} + +module Spec where