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 + +## 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,11 @@ +# math-programming + +A math programming library. + +This library is designed to formulate and solve math programs, in +particular linear programs and mixed-integer linear programs. + +This library alone is not sufficient to solve math programs; to do so, +a solver backend implementing the `LPMonad` or `IPMonad` classes is +required, such as the [GLPK +backend](https://github.com/prsteele/math-programming-glpk). 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.cabal b/math-programming.cabal new file mode 100644 --- /dev/null +++ b/math-programming.cabal @@ -0,0 +1,60 @@ +cabal-version: 1.12 +name: math-programming +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#readme +bug-reports: https://github.com/prsteele/math-programming/issues +synopsis: A library for formulating and solving math programs. +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 + +library + exposed-modules: + Math.Programming + Math.Programming.Dsl + Math.Programming.Types + + hs-source-dirs: src + other-modules: Paths_math_programming + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >=4.7 && <5, + containers >=0.6.0.1 && <0.7, + mtl >=2.2.2 && <2.3, + text >=1.2.3.1 && <1.3 + +test-suite math-programming-test + type: exitcode-stdio-1.0 + main-is: Driver.hs + hs-source-dirs: test + other-modules: + Math.Programming.TestLinearExpression + Paths_math_programming + + default-language: Haskell2010 + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + base >=4.7 && <5, + containers >=0.6.0.1 && <0.7, + math-programming, + mtl >=2.2.2 && <2.3, + tasty >=1.2.3 && <1.3, + tasty-discover >=4.2.1 && <4.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.hs b/src/Math/Programming.hs new file mode 100644 --- /dev/null +++ b/src/Math/Programming.hs @@ -0,0 +1,273 @@ +{-| A library for modeling and solving linear and integer programs. + +This library is merely a frontend to various solver backends. At the +time this was written, the only known supported backend is +. +-} +module Math.Programming + ( -- * Math programs + -- $mathprograms + + -- ** Linear programs + LPMonad (..) + , Expr + , Bounds (..) + , SolutionStatus (..) + , Sense (..) + + -- ** Integer programs + , IPMonad (..) + , Domain (..) + + -- * Model-building DSL + -- $models + + -- ** Creating variables + -- $variables + + -- *** Continuous variables + , free + , nonNeg + , nonPos + , bounded + , within + + -- *** Integer variables + , integer + , binary + , nonNegInteger + , nonPosInteger + , asKind + + -- ** Linear expressions + -- $expressions + , LinearExpression (..) + , eval + , simplify + , var + , con + , exprSum + , varSum + + -- *** Addition + -- $addition + , (.+.) + , (@+@) + , (.+@) + , (@+.) + , (@+#) + , (#+@) + , (#+.) + , (.+#) + + -- *** Subtraction + -- $subtraction + , (.-.) + , (@-@) + , (.-@) + , (@-.) + , (@-#) + , (#-@) + , (#-.) + , (.-#) + + -- *** Multiplication + -- $multiplication + , (#*@) + , (@*#) + , (#*.) + , (.*#) + + -- *** Division + -- $division + , (@/#) + , (./#) + + -- ** Constraints + -- $constraints + , Inequality (..) + + -- *** Less-than constraints + -- $lt + , (#<=@) + , (#<=.) + , (@<=#) + , (@<=@) + , (@<=.) + , (.<=#) + , (.<=@) + , (.<=.) + + -- *** Greater-than constraints + -- $gt + , (#>=@) + , (#>=.) + , (@>=#) + , (@>=@) + , (@>=.) + , (.>=#) + , (.>=@) + , (.>=.) + + -- *** Equality constraints + -- $eq + , (#==@) + , (#==.) + , (@==#) + , (@==@) + , (@==.) + , (.==#) + , (.==@) + , (.==.) + + -- ** Specifying objectives + , minimize + , maximize + + -- ** Utilities + , evalExpr + , named + , nameOf + ) where + +import Math.Programming.Dsl +import Math.Programming.Types + +-- $mathprograms +-- +-- The 'LPMonad' provides all the primitives necessary to formulate +-- and solve linear programs; the 'IPMonad' provides the same for +-- integer programs. However, you should not often need to use these +-- APIs directly, as we provide more user-friendly functions wrapping +-- these low-level functions below. + +-- $models +-- +-- The functions in the 'LPMonad' and 'IPMonad' typeclasses are +-- designed to interface with low-level solver backends. We provide a +-- cleaner interface in the following sections. + +-- $variables +-- +-- 'LPMonad' provides 'addVariable' and 'setVariableBounds', and +-- 'IPMonad' additionally provides 'setVariableDomain'. While +-- sufficient to create your programs, you are encouraged to use the +-- more natural functions below. + +-- $expressions +-- +-- The module 'Math.Programming.LinearExpression' provides operators +-- to build up 'LinearExpression' objects using declared variables. + +-- $addition +-- +-- We can summarize the addition operators with the table +-- +-- +-----------------+--------+--------+------------------+ +-- | |Constant|Variable| Expression | +-- +-----------------+--------+--------+------------------+ +-- |Constant | '+' | '#+@' | '#+.' | +-- +-----------------+--------+--------+------------------+ +-- |Variable | '@+#' | '@+@' | '@+.' | +-- +-----------------+--------+--------+------------------+ +-- |Expression | '.+#' | '.+@' | '.+.' | +-- +-----------------+--------+--------+------------------+ + +-- $subtraction +-- +-- We can summarize the subtraction operators with the table +-- +-- +-----------------+--------+--------+------------------+ +-- | |Constant|Variable| Expression | +-- +-----------------+--------+--------+------------------+ +-- |Constant | '-' | '#-@' | '#-.' | +-- +-----------------+--------+--------+------------------+ +-- |Variable | '@-#' | '@-@' | '@-.' | +-- +-----------------+--------+--------+------------------+ +-- |Expression | '.-#' | '.-@' | '.-.' | +-- +-----------------+--------+--------+------------------+ + +-- $multiplication +-- +-- We can summarize the multiplication operators with the table +-- +-- +-----------------+--------+--------+------------------+ +-- | |Constant|Variable| Expression | +-- +-----------------+--------+--------+------------------+ +-- |Constant | '*' | '#*@' | '#*.' | +-- +-----------------+--------+--------+------------------+ +-- |Variable | '@*#' | | | +-- +-----------------+--------+--------+------------------+ +-- |Expression | '.*#' | | | +-- +-----------------+--------+--------+------------------+ +-- +-- As there are few possibilities for valid multiplication, it can be +-- convenient to define e.g. @.*@ or some other short operator as an +-- alias for '#*@'. + +-- $division +-- +-- We can summarize the multiplication operators with the table +-- +-- +-----------------+--------+--------+------------------+ +-- | |Constant|Variable| Expression | +-- +-----------------+--------+--------+------------------+ +-- |Constant | '/' | | | +-- +-----------------+--------+--------+------------------+ +-- |Variable | '@/#' | | | +-- +-----------------+--------+--------+------------------+ +-- |Expression | './#' | | | +-- +-----------------+--------+--------+------------------+ +-- +-- As there are few possibilities for valid division, it +-- can be convenient to define e.g. @./@ or some other short operator +-- as an alias for '@/#'. + +-- $constraints +-- +-- The 'LPMonad' provides the 'addConstraint' function. However, you +-- will typically use the operators below to directly apply +-- constraints to the model. We follow the same conventions as with +-- our arithmetic operators. + +-- $lt +-- +-- We can summarize the various inquality operators in the following table. +-- +-- +-----------------+--------+--------+------------------+ +-- | |Constant|Variable| Expression | +-- +-----------------+--------+--------+------------------+ +-- |Constant | | '#<=@' | '#<=.' | +-- +-----------------+--------+--------+------------------+ +-- |Variable | '@<=#' | '@<=@' | '@<=.' | +-- +-----------------+--------+--------+------------------+ +-- |Expression | '.<=#' | '.<=@' | '.<=.' | +-- +-----------------+--------+--------+------------------+ + +-- $gt +-- +-- We can summarize the various inquality operators in the following table. +-- +-- +-----------------+--------+--------+------------------+ +-- | |Constant|Variable| Expression | +-- +-----------------+--------+--------+------------------+ +-- |Constant | | '#>=@' | '#>=.' | +-- +-----------------+--------+--------+------------------+ +-- |Variable | '@>=#' | '@>=@' | '@>=.' | +-- +-----------------+--------+--------+------------------+ +-- |Expression | '.>=#' | '.>=@' | '.>=.' | +-- +-----------------+--------+--------+------------------+ + +-- $eq +-- +-- We can summarize the various inquality operators in the following table. +-- +-- +-----------------+--------+--------+------------------+ +-- | |Constant|Variable| Expression | +-- +-----------------+--------+--------+------------------+ +-- |Constant | | '#==@' | '#==.' | +-- +-----------------+--------+--------+------------------+ +-- |Variable | '@==#' | '@==@' | '@==.' | +-- +-----------------+--------+--------+------------------+ +-- |Expression | '.==#' | '.==@' | '.==.' | +-- +-----------------+--------+--------+------------------+ diff --git a/src/Math/Programming/Dsl.hs b/src/Math/Programming/Dsl.hs new file mode 100644 --- /dev/null +++ b/src/Math/Programming/Dsl.hs @@ -0,0 +1,274 @@ +module Math.Programming.Dsl where + +import Data.Bifunctor +import Data.List (sortOn) + +import Math.Programming.Types + +-- | Create an objective to be minimized. +minimize :: LPMonad m => Expr m -> m (Objective m) +minimize objectiveExpr = do + objective <- addObjective objectiveExpr + setObjectiveSense objective Minimization + pure objective + +-- | Create an objective to be maximized. +maximize :: LPMonad m => Expr m -> m (Objective m) +maximize objectiveExpr = do + objective <- addObjective objectiveExpr + setObjectiveSense objective Maximization + pure objective + +-- | Get the value of a linear expression in the current solution. +evalExpr :: LPMonad m => Expr m -> m (Numeric m) +evalExpr expr = traverse getVariableValue expr >>= return . eval + +-- | Create a new free variable. +free :: LPMonad m => m (Variable m) +free = addVariable `within` Free + +-- | Create a new non-negative variable. +nonNeg :: LPMonad m => m (Variable m) +nonNeg = addVariable `within` NonNegativeReals + +-- | Create a new non-positive variable. +nonPos :: LPMonad m => m (Variable m) +nonPos = addVariable `within` NonPositiveReals + +-- | Create a new variable bounded between two values. +bounded :: LPMonad m => Numeric m -> Numeric m -> m (Variable m) +bounded lo hi = within addVariable (Interval lo hi) + +-- | Constrain a variable to take on certain values. +-- +-- This function is designed to be used as an infix operator, e.g. +-- +-- @ +-- 'addVariable' \``within`\` 'NonNegativeReals' +-- @ +within :: LPMonad m => m (Variable m) -> Bounds (Numeric m) -> m (Variable m) +within makeVar bounds = do + variable <- makeVar + setVariableBounds variable bounds + pure variable + +-- | Create an integer-valued variable. +integer :: IPMonad m => m (Variable m) +integer = addVariable `asKind` Integer + +-- | Create a binary variable. +binary :: IPMonad m => m (Variable m) +binary = addVariable `asKind` Binary + +-- | Create an integer-value variable that takes on non-negative values. +nonNegInteger :: IPMonad m => m (Variable m) +nonNegInteger = addVariable `asKind` Integer `within` NonNegativeReals + +-- | Create an integer-value variable that takes on non-positive values. +nonPosInteger :: IPMonad m => m (Variable m) +nonPosInteger = addVariable `asKind` Integer `within` NonPositiveReals + +-- | Set the type of a variable. +-- +-- This function is designed to be used as an infix operator, e.g. +-- +-- @ +-- 'addVariable' \``asKind`\` 'Binary' +-- @ +asKind :: IPMonad m => m (Variable m) -> Domain -> m (Variable m) +asKind make domain = do + variable <- make + setVariableDomain variable domain + pure variable + +-- | Name a variable, constraint, or objective. +-- +-- This function is designed to be used as an infix operator, e.g. +-- +-- @ +-- 'free' \``named`\` "X_1" +-- @ +named :: (Monad m, Nameable m a) => m a -> String -> m a +named make name = do + x <- make + setName x name + pure x + +-- | Retrieve the name of a variable, constraint, or objective. +nameOf :: (Monad m, Nameable m a) => a -> m String +nameOf = getName + +(#+@) :: Num a => a -> b -> LinearExpression a b +(#+.) :: Num a => a -> LinearExpression a b -> LinearExpression a b +(@+#) :: Num a => b -> a -> LinearExpression a b +(@+@) :: Num a => b -> b -> LinearExpression a b +(@+.) :: Num a => b -> LinearExpression a b -> LinearExpression a b +(.+#) :: Num a => LinearExpression a b -> a -> LinearExpression a b +(.+@) :: Num a => LinearExpression a b -> b -> LinearExpression a b +(.+.) :: Num a => LinearExpression a b -> LinearExpression a b -> LinearExpression a b +(#-@) :: Num a => a -> b -> LinearExpression a b +(#-.) :: Num a => a -> LinearExpression a b -> LinearExpression a b +(@-#) :: Num a => b -> a -> LinearExpression a b +(@-@) :: Num a => b -> b -> LinearExpression a b +(@-.) :: Num a => b -> LinearExpression a b -> LinearExpression a b +(.-#) :: Num a => LinearExpression a b -> a -> LinearExpression a b +(.-@) :: Num a => LinearExpression a b -> b -> LinearExpression a b +(.-.) :: Num a => LinearExpression a b -> LinearExpression a b -> LinearExpression a b +(#*.) :: Num a => a -> LinearExpression a b -> LinearExpression a b +(.*#) :: Num a => LinearExpression a b -> a -> LinearExpression a b +(#*@) :: Num a => a -> b -> LinearExpression a b +(@*#) :: Num a => b -> a -> LinearExpression a b +(@/#) :: Fractional a => b -> a -> LinearExpression a b +(./#) :: Fractional a => LinearExpression a b -> a -> LinearExpression a b + +x #+@ y = con x .+. var y +x #+. y = con x .+. y +x @+# y = var x .+. con y +x @+@ y = var x .+. var y +x @+. y = var x .+. y +x .+@ y = x .+. var y +x .+# y = x .+. con y +x .+. y = x <> y +x #-@ y = con x .-. var y +x #-. y = con x .-. y +x @-# y = var x .-. con y +x @-@ y = var x .-. var y +x @-. y = var x .-. y +x .-# y = x .-. con y +x .-@ y = x .-. var y +x .-. y = x .+. (-1) #*. y +x #*@ y = var y .*# x +x #*. y = y .*# x +x @*# y = var x .*# y +x .*# y = first (* y) x +x @/# y = var x ./# y +x ./# y = first (/ y) x + +infixl 6 #+@ +infixl 6 #+. +infixl 6 @+# +infixl 6 @+@ +infixl 6 @+. +infixl 6 .+# +infixl 6 .+@ +infixl 6 .+. +infixl 6 #-@ +infixl 6 #-. +infixl 6 @-# +infixl 6 @-@ +infixl 6 @-. +infixl 6 .-# +infixl 6 .-@ +infixl 6 .-. +infixl 7 #*@ +infixl 7 #*. +infixl 7 @*# +infixl 7 .*# +infixl 7 @/# +infixl 7 ./# + +-- | Combine equivalent terms by summing their coefficients. +simplify :: (Ord b, Num a) => LinearExpression a b -> LinearExpression a b +simplify (LinearExpression terms constant) + = LinearExpression (reduce (sortOn snd terms)) constant + where + reduce [] = [] + reduce ((c, x): []) = [(c, x)] + reduce ((c, x): (c', x'): xs) + | x == x' = (c + c', x) : reduce xs + | otherwise = (c, x) : reduce ((c', x'): xs) + +-- | Reduce an expression to its value. +eval :: Num a => LinearExpression a a -> a +eval (LinearExpression terms constant) = constant + sum (map (uncurry (*)) terms) + +-- | Construct an expression representing a variable. +var :: Num a => b -> LinearExpression a b +var x = LinearExpression [(1, x)] 0 + +-- | Construct an expression representing a constant. +con :: Num a => a -> LinearExpression a b +con x = LinearExpression [] x + +-- | Construct an expression by summing expressions. +exprSum :: Num a => [LinearExpression a b] -> LinearExpression a b +exprSum = mconcat + +-- | Construct an expression by summing variables. +varSum :: Num a => [b] -> LinearExpression a b +varSum = mconcat . fmap var + +(#<=@) :: LPMonad m => Numeric m -> Variable m -> m (Constraint m) +(#<=.) :: LPMonad m => Numeric m -> Expr m -> m (Constraint m) +(@<=#) :: LPMonad m => Variable m -> Numeric m -> m (Constraint m) +(@<=@) :: LPMonad m => Variable m -> Variable m -> m (Constraint m) +(@<=.) :: LPMonad m => Variable m -> Expr m -> m (Constraint m) +(.<=#) :: LPMonad m => Expr m -> Numeric m -> m (Constraint m) +(.<=@) :: LPMonad m => Expr m -> Variable m -> m (Constraint m) +(.<=.) :: LPMonad m => Expr m -> Expr m -> m (Constraint m) +(#>=@) :: LPMonad m => Numeric m -> Variable m -> m (Constraint m) +(#>=.) :: LPMonad m => Numeric m -> Expr m -> m (Constraint m) +(@>=#) :: LPMonad m => Variable m -> Numeric m -> m (Constraint m) +(@>=@) :: LPMonad m => Variable m -> Variable m -> m (Constraint m) +(@>=.) :: LPMonad m => Variable m -> Expr m -> m (Constraint m) +(.>=#) :: LPMonad m => Expr m -> Numeric m -> m (Constraint m) +(.>=@) :: LPMonad m => Expr m -> Variable m -> m (Constraint m) +(.>=.) :: LPMonad m => Expr m -> Expr m -> m (Constraint m) +(#==@) :: LPMonad m => Numeric m -> Variable m -> m (Constraint m) +(#==.) :: LPMonad m => Numeric m -> Expr m -> m (Constraint m) +(@==#) :: LPMonad m => Variable m -> Numeric m -> m (Constraint m) +(@==@) :: LPMonad m => Variable m -> Variable m -> m (Constraint m) +(@==.) :: LPMonad m => Variable m -> Expr m -> m (Constraint m) +(.==#) :: LPMonad m => Expr m -> Numeric m -> m (Constraint m) +(.==@) :: LPMonad m => Expr m -> Variable m -> m (Constraint m) +(.==.) :: LPMonad m => Expr m -> Expr m -> m (Constraint m) + +x #<=@ y = addConstraint $ Inequality LT (con x) (var y) +x #<=. y = addConstraint $ Inequality LT (con x) y +x @<=# y = addConstraint $ Inequality LT (var x) (con y) +x @<=@ y = addConstraint $ Inequality LT (var x) (var y) +x @<=. y = addConstraint $ Inequality LT (var x) y +x .<=# y = addConstraint $ Inequality LT x (con y) +x .<=@ y = addConstraint $ Inequality LT x (var y) +x .<=. y = addConstraint $ Inequality LT x y +x #>=@ y = addConstraint $ Inequality GT (con x) (var y) +x #>=. y = addConstraint $ Inequality GT (con x) y +x @>=# y = addConstraint $ Inequality GT (var x) (con y) +x @>=@ y = addConstraint $ Inequality GT (var x) (var y) +x @>=. y = addConstraint $ Inequality GT (var x) y +x .>=# y = addConstraint $ Inequality GT x (con y) +x .>=@ y = addConstraint $ Inequality GT x (var y) +x .>=. y = addConstraint $ Inequality GT x y +x #==@ y = addConstraint $ Inequality EQ (con x) (var y) +x #==. y = addConstraint $ Inequality EQ (con x) y +x @==# y = addConstraint $ Inequality EQ (var x) (con y) +x @==@ y = addConstraint $ Inequality EQ (var x) (var y) +x @==. y = addConstraint $ Inequality EQ (var x) y +x .==# y = addConstraint $ Inequality EQ x (con y) +x .==@ y = addConstraint $ Inequality EQ x (var y) +x .==. y = addConstraint $ Inequality EQ x y + +infix 4 #<=@ +infix 4 #<=. +infix 4 @<=# +infix 4 @<=@ +infix 4 @<=. +infix 4 .<=# +infix 4 .<=@ +infix 4 .<=. +infix 4 #>=@ +infix 4 #>=. +infix 4 @>=# +infix 4 @>=@ +infix 4 @>=. +infix 4 .>=# +infix 4 .>=@ +infix 4 .>=. +infix 4 #==@ +infix 4 #==. +infix 4 @==# +infix 4 @==@ +infix 4 @==. +infix 4 .==# +infix 4 .==@ +infix 4 .==. diff --git a/src/Math/Programming/Types.hs b/src/Math/Programming/Types.hs new file mode 100644 --- /dev/null +++ b/src/Math/Programming/Types.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +module Math.Programming.Types where + +import Data.Bifunctor +import Data.Traversable (fmapDefault, foldMapDefault) + +-- | A convient shorthand for the type of linear expressions used in a +-- given model. +type Expr m = LinearExpression (Numeric m) (Variable m) + +-- | A monad for formulating and solving linear programs. +-- +-- We manipulate linear programs and their settings using the +-- 'Mutable' typeclass. +class (Monad m, Num (Numeric m)) => LPMonad m where + -- | The numeric type used in the model. + type Numeric m :: * + + -- | The type of variables in the model. 'LPMonad' treats these as + -- opaque values, but instances may expose more details. + data Variable m :: * + + -- | The type of constraints in the model. 'LPMonad' treats these + -- as opaque values, but instances may expose more details. + data Constraint m :: * + + -- | The type of objectives in the model. 'LPMonad' treats these + -- as opaque values, but instances may expose more details. + data Objective m :: * + + -- | Create a new decision variable in the model. + -- + -- This variable will be initialized to be a non-negative continuous + -- variable. + addVariable :: m (Variable m) + + -- | Remove a decision variable from the model. + -- + -- The variable cannot be used after being deleted. + removeVariable :: Variable m -> m () + + -- | Get the name of the variable. + getVariableName :: Variable m -> m String + + -- | Set the name of the variable. + setVariableName :: Variable m -> String -> m () + + -- | Get the allowed values of a variable. + getVariableBounds :: Variable m -> m (Bounds (Numeric m)) + + -- | Constrain a variable to take on certain values. + setVariableBounds :: Variable m -> Bounds (Numeric m) -> m () + + -- | Get the value of a variable in the current solution. + getVariableValue :: Variable m -> m (Numeric m) + + -- | Add a constraint to the model represented by an inequality. + addConstraint :: Inequality (LinearExpression (Numeric m) (Variable m)) -> m (Constraint m) + + -- | Remove a constraint from the model. + -- + -- The constraint cannot used after being deleted. + removeConstraint :: Constraint m -> m () + + -- | Get the name of the constraint. + getConstraintName :: Constraint m -> m String + + -- | Set the name of the constraint. + setConstraintName :: Constraint m -> String -> m () + + -- | Get the value of the dual variable associated with the + -- constraint in the current solution. + -- + -- This value has no meaning if the current solution is not an LP + -- solution. + getDualValue :: Constraint m -> m (Numeric m) + + -- | Add a constraint to the model represented by an inequality. + addObjective :: LinearExpression (Numeric m) (Variable m) -> m (Objective m) + + -- | Get the name of the objective. + getObjectiveName :: Objective m -> m String + + -- | Set the name of the objective. + setObjectiveName :: Objective m -> String -> m () + + -- | Whether the objective is to be minimized or maximized. + getObjectiveSense :: Objective m -> m Sense + + -- | Set whether the objective is to be minimized or maximized. + setObjectiveSense :: Objective m -> Sense -> m () + + -- | Get the value of the objective in the current solution. + getObjectiveValue :: Objective m -> m (Numeric m) + + -- | Get the number of seconds the solver is allowed to run before + -- halting. + getTimeout :: m Double + + -- | Set the number of seconds the solver is allowed to run before + -- halting. + setTimeout :: Double -> m () + + -- | Optimize the continuous relaxation of the model. + optimizeLP :: m SolutionStatus + + -- | Write out the formulation. + writeFormulation :: FilePath -> m () + +-- | A (mixed) integer program. +-- +-- In addition to the methods of the 'LPMonad' class, this monad +-- supports constraining variables to be either continuous or +-- discrete. +class ( LPMonad m + ) => IPMonad m where + -- | Optimize the mixed-integer program. + optimizeIP :: m SolutionStatus + + -- | Get the domain of a variable. + getVariableDomain :: Variable m -> m Domain + + -- | Set the domain of a variable. + setVariableDomain :: Variable m -> Domain -> m () + + -- | Get the allowed relative gap between LP and IP solutions. + getRelativeMIPGap :: m Double + + -- | Set the allowed relative gap between LP and IP solutions. + setRelativeMIPGap :: Double -> m () + +-- | Whether a math program is minimizing or maximizing its objective. +data Sense = Minimization | Maximization + deriving + ( Eq + , Ord + , Read + , Show + ) + +-- | The outcome of an optimization. +data SolutionStatus + = Optimal + -- ^ An optimal solution has been found. + | Feasible + -- ^ A feasible solution has been found. The result may or may not + -- be optimal. + | Infeasible + -- ^ The model has been proven to be infeasible. + | Unbounded + -- ^ The model has been proven to be unbounded. + | Error + -- ^ An error was encountered during the solve. Instance-specific + -- methods should be used to determine what occurred. + deriving + ( Eq + , Ord + , Read + , Show + ) + +-- | An interval of the real numbers. +data Bounds b + = NonNegativeReals + -- ^ The non-negative reals. + | NonPositiveReals + -- ^ The non-positive reals. + | Interval b b + -- ^ Any closed interval of the reals. + | Free + -- ^ Any real number. + deriving + ( Read + , Show + ) + +-- | The type of values that a variable can take on. +-- +-- Note that the @Integer@ constructor does not interfere with the +-- @Integer@ type, as the @Integer@ type does not define a constuctor +-- of the same name. The ambiguity is unfortunate, but other natural +-- nomenclature such as @Integral@ are similarly conflicted. +data Domain + = Continuous + -- ^ The variable lies in the real numbers + | Integer + -- ^ The variable lies in the integers + | Binary + -- ^ The variable lies in the set @{0, 1}@. + deriving + ( Read + , Show + ) + +class Nameable m a where + getName :: a -> m String + setName :: a -> String -> m () + +instance LPMonad m => Nameable m (Variable m) where + getName = getVariableName + setName = setVariableName + +instance LPMonad m => Nameable m (Constraint m) where + getName = getConstraintName + setName = setConstraintName + +instance LPMonad m => Nameable m (Objective m) where + getName = getObjectiveName + setName = setObjectiveName + +-- | A linear expression containing symbolic variables of type @b@ and +-- numeric coefficients of type @a@. +-- +-- Using 'String's to denote variables and 'Double's as our numeric +-- type, we could express /3 x + 2 y + 1/ as +-- +-- @ +-- LinearExpression [(3, "x"), (2, "y")] 1 +-- @ +data LinearExpression a b + = LinearExpression [(a, b)] a + deriving + ( Read + , Show + ) + +-- | Implements addition of 'LinearExpression a b' terms +instance Num a => Semigroup (LinearExpression a b) where + (LinearExpression termsLhs constantLhs) <> (LinearExpression termsRhs constantRhs) + = LinearExpression (termsLhs <> termsRhs) (constantLhs + constantRhs) + +-- | Using '0' as the identity element +instance Num a => Monoid (LinearExpression a b) where + mempty = LinearExpression [] 0 + +instance Functor (LinearExpression a) where + fmap = fmapDefault + +instance Bifunctor LinearExpression where + first f (LinearExpression terms constant) + = LinearExpression (fmap (first f) terms) (f constant) + second f (LinearExpression terms constant) + = LinearExpression (fmap (fmap f) terms) constant + +instance Foldable (LinearExpression a) where + foldMap = foldMapDefault + +-- | Useful for substituting values in a monadic/applicative context +instance Traversable (LinearExpression a) where + traverse f (LinearExpression terms constant) + = LinearExpression <$> traverse (traverse f) terms <*> pure constant + +-- | Non-strict inequalities. +data Inequality a + = Inequality Ordering a a + deriving + ( Read + , Show + ) + +instance Functor Inequality where + fmap = fmapDefault + +instance Foldable Inequality where + foldMap = foldMapDefault + +instance Traversable Inequality where + traverse f (Inequality sense lhs rhs) + = Inequality sense <$> f lhs <*> f rhs diff --git a/test/Driver.hs b/test/Driver.hs new file mode 100644 --- /dev/null +++ b/test/Driver.hs @@ -0,0 +1,10 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --ignores="*~" #-} +{-| +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/TestLinearExpression.hs b/test/Math/Programming/TestLinearExpression.hs new file mode 100644 --- /dev/null +++ b/test/Math/Programming/TestLinearExpression.hs @@ -0,0 +1,74 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances #-} +module Math.Programming.TestLinearExpression where + +import Control.Monad +import Data.Ratio + +import Test.Tasty +import Test.Tasty.QuickCheck + +import Math.Programming + +test_tree :: TestTree +test_tree = testGroup "LinearExpression tests" + [ testProperty "Additive commutativity" commutativityProp + , testProperty "Additive associativity" additiveAssociativityProp + , testProperty "Coefficient commutativity" coefficientCommutativityProp + , testProperty "Simplification" simplifyProp + ] + +type ExactExpr = LinearExpression (Ratio Integer) (Ratio Integer) + +instance Arbitrary ExactExpr where + arbitrary = LinearExpression <$> arbitrary <*> arbitrary + +-- | A pair of linear expressions, differing only by the ordering of +-- the summands. +newtype ShuffledAndUnshuffled + = ShuffledAndUnshuffled (ExactExpr, ExactExpr) + deriving + ( Show + ) + +instance Arbitrary ShuffledAndUnshuffled where + arbitrary = do + unshuffled@(LinearExpression terms constant) <- arbitrary + shuffledTerms <- shuffle terms + let shuffled = LinearExpression shuffledTerms constant + return $ ShuffledAndUnshuffled (unshuffled, shuffled) + +-- | Addition should be commutative. +commutativityProp :: ShuffledAndUnshuffled -> Bool +commutativityProp (ShuffledAndUnshuffled (shuffled, unshuffled)) + = eval shuffled == eval unshuffled + +-- | A pair of linear expressions, differing only by the ordering of +-- the coefficients of the summands. +newtype ShuffledCoefficients + = ShuffledCoefficients (ExactExpr, ExactExpr) + deriving + ( Show + ) + +instance Arbitrary ShuffledCoefficients where + arbitrary = do + unshuffled@(LinearExpression terms constant) <- arbitrary + terms' <- forM terms $ \(x, y) -> do + flipped <- arbitrary + return $ if flipped + then (y, x) + else (x, y) + let shuffled = LinearExpression terms' constant + return $ ShuffledCoefficients (shuffled, unshuffled) + +coefficientCommutativityProp :: ShuffledCoefficients -> Bool +coefficientCommutativityProp (ShuffledCoefficients (shuffled, unshuffled)) + = eval shuffled == eval unshuffled + +additiveAssociativityProp :: ExactExpr -> ExactExpr -> ExactExpr -> Bool +additiveAssociativityProp x y z + = eval ((x .+. y) .+. z) == eval (x .+. (y .+. z)) + +simplifyProp :: ExactExpr -> Bool +simplifyProp x = eval x == eval (simplify x)