diff --git a/Control/Monad/LPMonad/Internal.hs b/Control/Monad/LPMonad/Internal.hs --- a/Control/Monad/LPMonad/Internal.hs +++ b/Control/Monad/LPMonad/Internal.hs @@ -44,6 +44,7 @@ -- newVariables' ) where +import Prelude hiding ((-),(+)) import Control.Monad.State.Strict import Control.Monad.Identity @@ -51,7 +52,7 @@ import Data.LinearProgram.Common --- | A simple monad for constructing linear programs. This library is intended to be able to link to +-- | A simple monad for constructing linear programs. This library is intended to be able to link to -- a variety of different linear programming implementations. type LPM v c = LPT v c Identity @@ -92,13 +93,13 @@ {-# SPECIALIZE geq :: (Ord v, Group c) => LinFunc v c -> LinFunc v c -> LPM v c (), (Ord v, Group c, Monad m) => LinFunc v c -> LinFunc v c -> LPT v c m () #-} -- | Specifies the relationship between two functions in the variables. So, for example, --- +-- -- > equal (f ^+^ g) h --- +-- -- constrains the value of @h@ to be equal to the value of @f@ plus the value of @g@. equal, leq, geq :: (Ord v, Group c, MonadState (LP v c) m) => LinFunc v c -> LinFunc v c -> m () -equal f g = equalTo (f ^-^ g) zero -leq f g = leqTo (f ^-^ g) zero +equal f g = equalTo (f - g) zero +leq f g = leqTo (f - g) zero geq = flip leq {-# SPECIALIZE equal' :: (Ord v, Group c) => String -> LinFunc v c -> LinFunc v c -> LPM v c (), @@ -109,8 +110,8 @@ (Ord v, Group c, Monad m) => String -> LinFunc v c -> LinFunc v c -> LPT v c m () #-} -- | Specifies the relationship between two functions in the variables, with a label on the constraint. equal', leq', geq' :: (Ord v, Group c, MonadState (LP v c) m) => String -> LinFunc v c -> LinFunc v c -> m () -equal' lab f g = equalTo' lab (f ^-^ g) zero -leq' lab f g = leqTo' lab (f ^-^ g) zero +equal' lab f g = equalTo' lab (f - g) zero +leq' lab f g = leqTo' lab (f - g) zero geq' = flip . leq' {-# SPECIALIZE equalTo :: LinFunc v c -> c -> LPM v c (), Monad m => LinFunc v c -> c -> LPT v c m () #-} @@ -150,7 +151,7 @@ -- Nothing -> return $ take k [toEnum 0..] -- Just ((start, _), _) -- -> return $ take k $ tail [start..] --- +-- -- {-# SPECIALIZE newVariables' :: (Ord v, Enum v) => LPM v c [v], -- (Ord v, Enum v, Monad m) => LPT v c m [v] #-} -- -- | Returns an infinite list of unused variables. If the program is currently empty, @@ -218,13 +219,15 @@ -- | Adds this function to the objective function. addObjective :: (Ord v, Group c, MonadState (LP v c) m) => LinFunc v c -> m () addObjective obj = modify addObj where - addObj lp@LP{..} = lp {objective = obj ^+^ objective} + addObj lp@LP{..} = lp {objective = obj + objective} -{-# SPECIALIZE addWeightedObjective :: (Ord v, Module r c) => r -> LinFunc v c -> LPM v c (), - (Ord v, Module r c, Monad m) => r -> LinFunc v c -> LPT v c m () #-} +{-# SPECIALIZE addWeightedObjective :: + (Ord v, Ring c) => c -> LinFunc v c -> LPM v c (), + (Ord v, Ring c, Monad m) => c -> LinFunc v c -> LPT v c m () #-} -- | Adds this function to the objective function, with the specified weight. Equivalent to -- @'addObjective' (wt '*^' obj)@. -addWeightedObjective :: (Ord v, Module r c, MonadState (LP v c) m) => r -> LinFunc v c -> m () +addWeightedObjective :: (Ord v, Ring c, MonadState (LP v c) m) => + c -> LinFunc v c -> m () addWeightedObjective wt obj = addObjective (wt *^ obj) {-# SPECIALIZE setVarBounds :: (Ord v, Ord c) => v -> Bounds c -> LPM v c (), diff --git a/Data/Algebra.hs b/Data/Algebra.hs deleted file mode 100644 --- a/Data/Algebra.hs +++ /dev/null @@ -1,35 +0,0 @@ --- | Common library for algebraic structures. Has the advantage of automatically inferring lots of useful structure, especially --- in the writing of linear programs. For example, here are several ways of writing @3 x - 4 y + z@: --- --- > gsum [3 *& x, (-4) *^ var y, var z] --- > linCombination [(3, x), (-4, y), (1, z)] --- > 3 *& x ^-^ 4 *& y ^+^ var z --- --- In addition, if we have two functions @f@ and @g@, we can construct linear combinations of those functions, using --- exactly the same syntax. Moreover, we can multiply functions with 'Double' coefficients by 'Rational' values successfully. --- This module is intended to offer as much generality as possible without getting in your way. -module Data.Algebra ( - -- * Algebraic structures - Group(..), - Ring(..), - Field(..), - Module(..), - VectorSpace(..), - Poly, - varPoly, - GroupRing, - LinFunc, - -- * Algebraic functions - gsum, - combination, - evalPoly, - -- ** Specialized methods on linear functions - var, - varSum, - (*&), - linCombination) where - -import Data.Algebra.Group -import Data.Algebra.Ring -import Data.Algebra.Field -import Data.Algebra.Module diff --git a/Data/Algebra/Field.hs b/Data/Algebra/Field.hs deleted file mode 100644 --- a/Data/Algebra/Field.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE UndecidableInstances, FlexibleInstances, MultiParamTypeClasses #-} - -module Data.Algebra.Field where - -import Data.Ratio - -import Data.Algebra.Ring -import Data.Algebra.Module - -class Ring f => Field f where - inv :: f -> f - (/#) :: f -> f -> f - inv x = one /# x - a /# b = a *# inv b - -instance Field Double where - inv = recip - -instance Integral a => Field (Ratio a) where - {-# SPECIALIZE instance Field Rational #-} - inv = recip - -class (Module f v, Field f) => VectorSpace f v -instance (Module f v, Field f) => VectorSpace f v diff --git a/Data/Algebra/Group.hs b/Data/Algebra/Group.hs deleted file mode 100644 --- a/Data/Algebra/Group.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances #-} -module Data.Algebra.Group where - -import Control.Applicative -import qualified Data.Map as M -import qualified Data.IntMap as IM -import Data.Ratio - -type Poly = [] - -infixr 4 ^+^ -infixr 4 ^-^ - --- | The algebraic structure of a group. Written additively. Required functions: 'zero' and ('^-^' or ('^+^' and 'neg')). -class Group g where - zero :: g - (^+^) :: g -> g -> g - (^-^) :: g -> g -> g - neg :: g -> g - - a ^+^ b = a ^-^ neg b - a ^-^ b = a ^+^ neg b - neg a = zero ^-^ a - -instance Group Bool where - zero = False - (^+^) = (/=) - (^-^) = (/=) - neg = id - -instance Group Int where - zero = 0 - (^+^) = (+) - (^-^) = (-) - neg = negate - -instance Group Integer where - zero = 0 - (^+^) = (+) - (^-^) = (-) - neg = negate - -instance Group Double where - zero = 0 - (^+^) = (+) - (^-^) = (-) - neg = negate - -instance Integral a => Group (Ratio a) where - {-# SPECIALIZE instance Group Rational #-} - zero = 0 - (^+^) = (+) - (^-^) = (-) - neg = negate - -instance Group g => Group (a -> g) where - zero = const zero - (^+^) = liftA2 (^+^) - (^-^) = liftA2 (^-^) - neg = fmap neg - -instance (Ord k, Group g) => Group (M.Map k g) where - zero = M.empty - (^+^) = M.unionWith (^+^) - neg = fmap neg - -instance Group g => Group (IM.IntMap g) where - zero = IM.empty - (^+^) = IM.unionWith (^+^) - neg = fmap neg - -instance Group g => Group (Poly g) where - zero = [] - [] ^+^ p = p - p ^+^ [] = p - (a:as) ^+^ (b:bs) = (a ^+^ b):(as ^+^ bs) - -instance (Group g1, Group g2) => Group (g1, g2) where - {-# SPECIALIZE instance Group g => Group (g, g) #-} - zero = (zero, zero) - (x1, y1) ^+^ (x2, y2) = (x1 ^+^ x2, y1 ^+^ y2) - (x1, y1) ^-^ (x2, y2) = (x1 ^-^ x2, y1 ^-^ y2) - neg (x, y) = (neg x, neg y) - -instance (Group g1, Group g2, Group g3) => Group (g1, g2, g3) where - {-# SPECIALIZE instance Group g => Group (g, g, g) #-} - zero = (zero, zero, zero) - (x1, y1, z1) ^+^ (x2, y2, z2) = (x1 ^+^ x2, y1 ^+^ y2, z1 ^+^ z2) - (x1, y1, z1) ^-^ (x2, y2, z2) = (x1 ^-^ x2, y1 ^-^ y2, z1 ^-^ z2) - neg (x, y, z) = (neg x, neg y, neg z) - -instance (Group g1, Group g2, Group g3, Group g4) => Group (g1, g2, g3, g4) where - {-# SPECIALIZE instance Group g => Group (g, g, g, g) #-} - zero = (zero, zero, zero, zero) - (x1, y1, z1, w1) ^+^ (x2, y2, z2, w2) = (x1 ^+^ x2, y1 ^+^ y2, z1 ^+^ z2, w1 ^+^ w2) - (x1, y1, z1, w1) ^-^ (x2, y2, z2, w2) = (x1 ^-^ x2, y1 ^-^ y2, z1 ^-^ z2, w1 ^-^ w2) - neg (x, y, z, w) = (neg x, neg y, neg z, neg w) - -{-# INLINE gsum #-} --- | Does a summation over the elements of a group. -gsum :: Group g => [g] -> g -gsum = foldr (^+^) zero diff --git a/Data/Algebra/Module.hs b/Data/Algebra/Module.hs deleted file mode 100644 --- a/Data/Algebra/Module.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, IncoherentInstances, TypeSynonymInstances #-} - -module Data.Algebra.Module where - -import Data.Ratio -import qualified Data.Map as M -import qualified Data.IntMap as IM - -import Data.Algebra.Group -import Data.Algebra.Ring - --- | The algebraic structure of a module. A vector space is a module with coefficients in a field. -class (Ring r, Group m) => Module r m where - (*^) :: r -> m -> m - -instance Module Int Int where - (*^) = (*) - -instance Module Integer Integer where - (*^) = (*) - -instance Module Int Integer where - (*^) = (*) . fromIntegral - -instance Integral a => Module Int (Ratio a) where - {-# SPECIALIZE instance Module Int Rational #-} - (*^) = (*) . fromIntegral - -instance Integral a => Module Integer (Ratio a) where - {-# SPECIALIZE instance Module Integer Rational #-} - (*^) = (*) . fromIntegral - -instance Integral a => Module (Ratio a) (Ratio a) where - {-# SPECIALIZE instance Module Rational Rational #-} - (*^) = (*) - -instance Module Int Double where - (*^) = (*) . fromIntegral - -instance Module Integer Double where - (*^) = (*) . fromIntegral - -instance Integral a => Module (Ratio a) Double where - {-# SPECIALIZE instance Module Rational Double #-} - (*^) = (*) . realToFrac - -instance Module Double Double where - (*^) = (*) - -instance (Ord g, Group g, Ring r) => Module (GroupRing r g) (GroupRing r g) where - (*^) = (*#) - -instance Module r m => Module r (a -> m) where - (*^) = fmap . (*^) - -instance (Ord k, Module r m) => Module r (M.Map k m) where - (*^) = fmap . (*^) - -instance Module r m => Module r (IM.IntMap m) where - (*^) = fmap . (*^) - -instance (Module r m1, Module r m2) => Module r (m1, m2) where - {-# SPECIALIZE instance Module r m => Module r (m, m) #-} - r *^ (a, b) = (r *^ a, r *^ b) - -instance (Module r m1, Module r m2, Module r m3) => Module r (m1, m2, m3) where - {-# SPECIALIZE instance Module r m => Module r (m, m, m) #-} - r *^ (a, b, c) = (r *^ a, r *^ b, r *^ c) - -instance (Module r m1, Module r m2, Module r m3, Module r m4) => Module r (m1, m2, m3, m4) where - {-# SPECIALIZE instance Module r m => Module r (m, m, m, m) #-} - r *^ (a, b, c, d) = (r *^ a, r *^ b, r *^ c, r *^ d) - --- | @'LinFunc' v c@ is a linear combination of variables of type @v@ with coefficients --- from @c@. Formally, this is the free @c@-module on @v@. -type LinFunc = M.Map - --- | Given a variable @v@, returns the function equivalent to @v@. -var :: (Ord v, Ring c) => v -> LinFunc v c -var v = M.singleton v one - --- | @c '*&' v@ is equivalent to @c '*^' 'var' v@. -(*&) :: (Ord v, Ring c) => c -> v -> LinFunc v c -c *& v = M.singleton v c - --- | Equivalent to @'vsum' . 'map' 'var'@. -varSum :: (Ord v, Ring c) => [v] -> LinFunc v c -varSum vs = M.fromList [(v, one) | v <- vs] - --- | Given a collection of vectors and scaling coefficients, returns this --- linear combination. -combination :: Module r m => [(r, m)] -> m -combination xs = gsum [r *^ m | (r, m) <- xs] - -{-# INLINE linCombination #-} --- | Given a set of basic variables and coefficients, returns the linear combination obtained --- by summing. -linCombination :: (Ord v, Num r) => [(r, v)] -> LinFunc v r -linCombination xs = M.fromListWith (+) [(v, r) | (r, v) <- xs] - --- | Substitution into a polynomial. -evalPoly :: (Module r m, Ring m) => Poly r -> m -> m -evalPoly f x = foldr (\ c z -> (c *^ one) ^+^ (x *# z)) zero f - -{-# RULES - "zero/*^" forall m . zero *^ m = zero; - "*^/zero" forall r . r *^ zero = zero; - "one/*^" forall m . one *^ m = m; - #-} diff --git a/Data/Algebra/Ring.hs b/Data/Algebra/Ring.hs deleted file mode 100644 --- a/Data/Algebra/Ring.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances #-} -module Data.Algebra.Ring where - -import Control.Applicative - -import Data.Ratio -import qualified Data.Map as M - -import Data.Algebra.Group - -infixr 6 *# - --- | A way of forming a ring from functions. See . -type GroupRing r g = M.Map g r - --- | The algebraic structure of a unital ring. Assumes that the additive operation forms an abelian group, --- that the multiplication operation forms a group, and that multiplication distributes. -class Group r => Ring r where - one :: r - (*#) :: r -> r -> r - -instance Ring Bool where - one = True - (*#) = (&&) - -instance Ring Int where - one = 1 - (*#) = (*) - -instance Ring Integer where - one = 1 - (*#) = (*) - -instance Ring Double where - one = 1 - (*#) = (*) - -instance Integral a => Ring (Ratio a) where - {-# SPECIALIZE instance Ring Rational #-} - one = 1 - (*#) = (*) - --- | The polynomial ring. -instance Ring r => Ring (Poly r) where - one = [one] - (p:ps) *# (q:qs) = (p *# q):(ps *# (q:qs) ^+^ map (p *#) qs) - _ *# _ = [] - --- | The function ring. -instance Ring r => Ring (a -> r) where - one = const one - (*#) = liftA2 (*#) - --- | The group ring. -instance (Ord g, Group g, Ring r) => Ring (GroupRing r g) where - one = M.singleton zero one - m *# n = M.fromListWith (^+^) [(u ^+^ v, f *# g) | (u, f) <- M.assocs m, (v, g) <- M.assocs n] - --- | Returns the polynomial @p(x) = x@. -varPoly :: Ring r => Poly r -varPoly = [zero, one] diff --git a/Data/LinearProgram/Common.hs b/Data/LinearProgram/Common.hs --- a/Data/LinearProgram/Common.hs +++ b/Data/LinearProgram/Common.hs @@ -2,11 +2,11 @@ -- linear programming libraries are made, this will be common to them all. module Data.LinearProgram.Common ( module Data.LinearProgram.Spec, - module Data.Algebra, + module Algebra.Classes, module Data.LinearProgram.Types) where import Data.LinearProgram.Spec -import Data.Algebra +import Algebra.Classes import Data.LinearProgram.Types import Data.Map diff --git a/Data/LinearProgram/GLPK/IO/Internal.hs b/Data/LinearProgram/GLPK/IO/Internal.hs --- a/Data/LinearProgram/GLPK/IO/Internal.hs +++ b/Data/LinearProgram/GLPK/IO/Internal.hs @@ -1,7 +1,7 @@ {-# LANGUAGE ForeignFunctionInterface #-} module Data.LinearProgram.GLPK.IO.Internal (readGLPLP, writeGLPLP) where - +import Prelude hiding ((+)) import Control.Monad import Control.Monad.Trans (liftIO, lift) @@ -83,7 +83,7 @@ 3 -> liftM UBound (ub i) 4 -> liftM2 Bound (lb i) (ub i) _ -> liftM Equ (lb i) - + getObjCoef :: Int -> GLPK Double getObjCoef = getCDouble glpGetObjCoef @@ -118,7 +118,7 @@ sequence_ [do bds <- lift $ rowBounds i name <- lift $ getRowName i - maybe constrain constrain' name + maybe constrain constrain' name (linCombination [(v, names ! j) | (j, v) <- row]) bds | (i, row) <- rowContents] obj <- lift $ sequence [do diff --git a/Data/LinearProgram/GLPK/Internal.hs b/Data/LinearProgram/GLPK/Internal.hs --- a/Data/LinearProgram/GLPK/Internal.hs +++ b/Data/LinearProgram/GLPK/Internal.hs @@ -7,7 +7,7 @@ setObjCoef, setObjectiveDirection, setRowBounds, setRowName, solveSimplex) where-} import Control.Monad - +import Prelude hiding ((+),(*)) import Foreign.Ptr import Foreign.C import Foreign.Marshal.Array @@ -36,7 +36,7 @@ foreign import ccall unsafe "c_glp_get_row_prim" glpGetRowPrim :: Ptr GlpProb -> CInt -> IO CDouble foreign import ccall unsafe "c_glp_get_col_prim" glpGetColPrim :: Ptr GlpProb -> CInt -> IO CDouble foreign import ccall unsafe "c_glp_set_col_kind" glpSetColKind :: Ptr GlpProb -> CInt -> CInt -> IO () -foreign import ccall unsafe "c_glp_mip_solve" glpMipSolve :: +foreign import ccall unsafe "c_glp_mip_solve" glpMipSolve :: Ptr GlpProb -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> CDouble -> CInt -> IO CInt foreign import ccall unsafe "c_glp_mip_obj_val" glpMIPObjVal :: Ptr GlpProb -> IO CDouble foreign import ccall unsafe "c_glp_mip_row_val" glpMIPRowVal :: Ptr GlpProb -> CInt -> IO CDouble @@ -78,7 +78,7 @@ {-# SPECIALIZE setMatRow :: Int -> [(Int, Double)] -> GLPK (), Int -> [(Int, Int)] -> GLPK () #-} setMatRow :: Real a => Int -> [(Int, a)] -> GLPK () -setMatRow i row = GLP $ \ lp -> +setMatRow i row = GLP $ \ lp -> allocaArray (len+1) $ \ (ixs :: Ptr CInt) -> allocaArray (len+1) $ \ (coeffs :: Ptr CDouble) -> do pokeArray ixs (0:map (fromIntegral . fst) row) pokeArray coeffs (0:map (realToFrac . snd) row) diff --git a/Data/LinearProgram/LinExpr.hs b/Data/LinearProgram/LinExpr.hs --- a/Data/LinearProgram/LinExpr.hs +++ b/Data/LinearProgram/LinExpr.hs @@ -1,17 +1,16 @@ {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} module Data.LinearProgram.LinExpr (LinExpr(..), solve, substituteExpr, simplifyExpr, constTerm, coeffTerm, funcToExpr) where - import Control.Monad import Data.LinearProgram.Types -import Data.Algebra +import Algebra.Classes import Data.Functor import Data.Foldable import Data.Map -import Prelude hiding (lookup, filter, foldr) +import Prelude hiding (lookup, filter, foldr, Num(..), recip) constTerm :: LinExpr v c -> c constTerm (LinExpr _ c) = c @@ -24,31 +23,35 @@ data LinExpr v c = LinExpr (LinFunc v c) c deriving (Eq, Read, Show) -instance (Ord v, Group c) => Group (LinExpr v c) where +instance (Ord v, Additive c) => Additive (LinExpr v c) where zero = LinExpr zero zero - LinExpr a1 c1 ^+^ LinExpr a2 c2 = LinExpr (a1 ^+^ a2) (c1 ^+^ c2) - LinExpr a1 c1 ^-^ LinExpr a2 c2 = LinExpr (a1 ^-^ a2) (c1 ^-^ c2) - neg (LinExpr a c) = LinExpr (neg a) (neg c) + LinExpr a1 c1 + LinExpr a2 c2 = LinExpr (a1 + a2) (c1 + c2) -instance (Ord v, Module r c) => Module r (LinExpr v c) where - k *^ LinExpr a c = LinExpr (k *^ a) (k *^ c) +instance (Ord v, Group c) => Group (LinExpr v c) where + LinExpr a1 c1 - LinExpr a2 c2 = LinExpr (a1 - a2) (c1 - c2) + negate (LinExpr a c) = LinExpr (negate a) (negate c) +instance (Ord v,AbelianAdditive c) => AbelianAdditive (LinExpr v c) + +instance (Ord v, Ring c) => Module c (LinExpr v c) where + k *^ LinExpr a c = LinExpr (k *^ a) (k * c) + substituteExpr :: (Ord v, Module c c) => v -> LinExpr v c -> LinExpr v c -> LinExpr v c substituteExpr v expV expr@(LinExpr a c) = case lookup v a of Nothing -> expr - Just k -> LinExpr (delete v a) c ^+^ (k *^ expV) + Just k -> LinExpr (delete v a) c + (k *^ expV) simplifyExpr :: (Ord v, Module c c) => LinExpr v c -> Map v (LinExpr v c) -> LinExpr v c simplifyExpr (LinExpr a c) sol = - foldrWithKey (const (^+^)) (LinExpr (difference a sol) c) (intersectionWith (*^) a sol) + foldrWithKey (const (+)) (LinExpr (difference a sol) c) (intersectionWith (*^) a sol) solve :: (Ord v, Eq c, VectorSpace c c) => [(LinFunc v c, c)] -> Maybe (Map v (LinExpr v c)) -solve equs = solve' [LinExpr a (neg c) | (a, c) <- equs] +solve equs = solve' [LinExpr a (negate c) | (a, c) <- equs] solve' :: (Ord v, Eq c, VectorSpace c c) => [LinExpr v c] -> Maybe (Map v (LinExpr v c)) solve' (LinExpr a c:equs) = case minViewWithKey (filter (/= zero) a) of Nothing -> guard (c == zero) >> solve' equs - Just ((x, a0), a') -> let expX = neg (inv a0 *^ LinExpr a' c) in + Just ((x, a0), a') -> let expX = negate (recip a0 *^ LinExpr a' c) in liftM (simplifyExpr expX >>= insert x) (solve' (substituteExpr x expX <$> equs)) solve' [] = return empty diff --git a/Data/LinearProgram/Spec.hs b/Data/LinearProgram/Spec.hs --- a/Data/LinearProgram/Spec.hs +++ b/Data/LinearProgram/Spec.hs @@ -1,17 +1,18 @@ {-# LANGUAGE TupleSections, RecordWildCards, DeriveFunctor #-} module Data.LinearProgram.Spec (Constraint(..), VarTypes, ObjectiveFunc, VarBounds, LP(..), - mapVars, mapVals, allVars) where + mapVars, mapVals, allVars, linCombination) where +import Prelude hiding (negate, (+)) import Control.DeepSeq import Control.Monad - import Data.Char (isSpace) import Data.Map hiding (map, foldl) import Text.ParserCombinators.ReadP -import Data.Algebra +import Algebra.Classes import Data.LinearProgram.Types +import qualified Data.Map as M -- | Representation of a linear constraint on the variables, possibly labeled. -- The function may be bounded both above and below. @@ -30,6 +31,9 @@ data LP v c = LP {direction :: Direction, objective :: ObjectiveFunc v c, constraints :: [Constraint v c], varBounds :: VarBounds v c, varTypes :: VarTypes v} deriving (Read, Show, Functor) +linCombination :: (Ord v, Additive r) => [(r, v)] -> LinFunc v r +linCombination xs = M.fromListWith (+) [(v, r) | (r, v) <- xs] + allVars :: Ord v => LP v c -> Map v () allVars LP{..} = foldl union ((() <$ objective) `union` (() <$ varBounds) `union` (() <$ varTypes)) [() <$ f | Constr _ f _ <- constraints] @@ -42,27 +46,27 @@ UBound x -> expr ++ " <= " ++ show x Bound l u -> show l ++ " <= " ++ expr ++ " <= " ++ show u -showFunc :: (Show v, Num c, Ord c, Show c) => LinFunc v c -> String +showFunc :: (Show v, Ord c, Show c, Num c, Group c) => LinFunc v c -> String showFunc func = case assocs func of [] -> "0" ((v,c):vcs) -> - show c ++ " " ++ map replaceSpace (show v) ++ + show c ++ " " ++ map replaceSpace (show v) ++ concatMap showTerm vcs where showTerm (v, c) = case compare c 0 of EQ -> "" GT -> " + " ++ show c ++ " " ++ show v LT -> " - " ++ show (negate c) ++ " " ++ show v - + replaceSpace :: Char -> Char replaceSpace c | isSpace c = '_' | otherwise = c -instance (Show v, Num c, Ord c, Show c) => Show (Constraint v c) where +instance (Show v, Ord c, Show c, Num c, Group c) => Show (Constraint v c) where show (Constr lab func bds) = maybe "" (++ ": ") lab ++ showBds (showFunc func) bds -instance (Read v, Ord v, Read c, Ord c, Num c) => Read (Constraint v c) where +instance (Read v, Ord v, Read c, Ord c, Num c, Group c) => Read (Constraint v c) where readsPrec _= readP_to_S $ liftM toConstr (lab <++ nolab) where toConstr (l, f, bds) = Constr l (fromList f) bds lab = do skipSpaces @@ -76,8 +80,8 @@ readConst = readS_to_P reads readVar = readS_to_P reads -readCoef :: Num c => ReadP c -> ReadP c -readCoef readC = between skipSpaces skipSpaces $ +readCoef :: (Num c, Group c) => ReadP c -> ReadP c +readCoef readC = between skipSpaces skipSpaces $ (do char '+' skipSpaces readC') <++ @@ -121,7 +125,7 @@ -- | Applies the specified function to the variables in the linear program. -- If multiple variables in the original program are mapped to the same variable in the new program, -- in general, we set those variables to all be equal, as follows. --- +-- -- * In linear functions, including the objective function and the constraints, -- coefficients will be added together. For instance, if @v1,v2@ are mapped to the same -- variable @v'@, then a linear function of the form @c1 *& v1 ^+^ c2 *& v2@ will be mapped to @@ -129,12 +133,12 @@ -- -- * In variable bounds, bounds will be combined. An error will be thrown if the bounds -- are mutually contradictory. --- +-- -- * In variable kinds, the most restrictive kind will be retained. mapVars :: (Ord v', Ord c, Group c) => (v -> v') -> LP v c -> LP v' c -mapVars f LP{..} = - LP{objective = mapKeysWith (^+^) f objective, - constraints = [Constr lab (mapKeysWith (^+^) f func) bd | Constr lab func bd <- constraints], +mapVars f LP{..} = + LP{objective = mapKeysWith (+) f objective, + constraints = [Constr lab (mapKeysWith (+) f func) bd | Constr lab func bd <- constraints], varBounds = mapKeysWith mappend f varBounds, varTypes = mapKeysWith mappend f varTypes, ..} diff --git a/Data/LinearProgram/Types.hs b/Data/LinearProgram/Types.hs --- a/Data/LinearProgram/Types.hs +++ b/Data/LinearProgram/Types.hs @@ -1,9 +1,13 @@ {-# LANGUAGE DeriveFunctor, DeriveGeneric #-} -module Data.LinearProgram.Types (VarKind(..), Direction(..), Bounds(..)) where +module Data.LinearProgram.Types (LinFunc, VarKind(..), Direction(..), Bounds(..)) where import Control.DeepSeq import Data.Monoid import GHC.Generics +import Data.Map + +type LinFunc = Map + data VarKind = ContVar | IntVar | BinVar deriving (Eq, Ord, Enum, Show, Read, Generic) diff --git a/examples/example1.hs b/examples/example1.hs --- a/examples/example1.hs +++ b/examples/example1.hs @@ -1,21 +1,29 @@ +import Prelude hiding (Num(..)) -import Data.LinearProgram.LPMonad +import Algebra.Classes +import Control.Monad.LPMonad +import Data.LinearProgram.Common import Data.LinearProgram import Data.LinearProgram.GLPK +import qualified Data.Map as M +import Data.LinearProgram.LinExpr objFun :: LinFunc String Int objFun = linCombination [(10, "x1"), (6, "x2"), (4, "x3")] +n *& v = linCombination [(n,v)] + lp :: LP String Int -lp = execLPM $ do setDirection Max - setObjective objFun - leqTo (varSum ["x1", "x2", "x3"]) 100 - leqTo (10 *^ var "x1" ^+^ 4 *& "x2" ^+^ 5 *^ var "x3") 600 - leqTo (linCombination [(2, "x1"), (2, "x2"), (6, "x3")]) 300 - varGeq "x1" 0 - varBds "x2" 0 50 - varGeq "x3" 0 - setVarKind "x1" IntVar - setVarKind "x2" ContVar +lp = execLPM $ do + setDirection Max + setObjective objFun + leqTo (add $ map (1 *&) ["x1", "x2", "x3"]) 100 + leqTo (10 *& "x1" + 4 *& "x2" + 5 *& "x3") 600 + leqTo (linCombination [(2, "x1"), (2, "x2"), (6, "x3")]) 300 + varGeq "x1" 0 + varBds "x2" 0 50 + varGeq "x3" 0 + setVarKind "x1" IntVar + setVarKind "x2" ContVar main = print =<< glpSolveVars mipDefaults lp diff --git a/glpk-hs.cabal b/glpk-hs.cabal --- a/glpk-hs.cabal +++ b/glpk-hs.cabal @@ -1,5 +1,5 @@ Name: glpk-hs -Version: 0.3.5 +Version: 0.5 Author: Louis Wasserman License: BSD3 License-file: LICENSE @@ -27,14 +27,13 @@ location: https://github.com/jyp/glpk-hs library - Build-Depends: base >= 4 && < 5, array, containers, mtl, deepseq + Build-Depends: base >= 4 && < 5, array, containers, mtl, deepseq, gasp Exposed-modules: Data.LinearProgram, Data.LinearProgram.Common, Data.LinearProgram.LinExpr, Data.LinearProgram.GLPK, Data.LinearProgram.GLPK.Solver, Data.LinearProgram.GLPK.IO, - Data.Algebra, Control.Monad.LPMonad, Control.Monad.LPMonad.Supply, Control.Monad.LPMonad.Supply.Class @@ -44,10 +43,6 @@ Data.LinearProgram.GLPK.IO.Internal, Control.Monad.LPMonad.Internal, Data.LinearProgram.Spec, - Data.LinearProgram.Types, - Data.Algebra.Group, - Data.Algebra.Ring, - Data.Algebra.Module, - Data.Algebra.Field + Data.LinearProgram.Types c-sources: glpk/glpk.c extra-libraries: glpk