diff options
author | Alberto Ruiz <aruiz@um.es> | 2015-02-24 20:40:39 +0100 |
---|---|---|
committer | Alberto Ruiz <aruiz@um.es> | 2015-02-24 20:40:39 +0100 |
commit | 3bdb9256da00f0c301f334553a047b8f67ddc561 (patch) | |
tree | 94187ed78aa97e08f472b90e4193a4405007803a /packages/glpk/src/Numeric/LinearProgramming.hs | |
parent | 29887ff45b07b42095b994d7b57a2d8bb5363956 (diff) | |
parent | 456aa8ebb8f8ab67f526b33930a54769b15c138a (diff) |
Merge pull request #115 from piotrm0/exact
Exact (glp_exact)
Diffstat (limited to 'packages/glpk/src/Numeric/LinearProgramming.hs')
-rw-r--r-- | packages/glpk/src/Numeric/LinearProgramming.hs | 39 |
1 files changed, 37 insertions, 2 deletions
diff --git a/packages/glpk/src/Numeric/LinearProgramming.hs b/packages/glpk/src/Numeric/LinearProgramming.hs index a54eb59..6a0c47d 100644 --- a/packages/glpk/src/Numeric/LinearProgramming.hs +++ b/packages/glpk/src/Numeric/LinearProgramming.hs | |||
@@ -75,6 +75,7 @@ Multiple bounds for a variable are not allowed, instead of | |||
75 | 75 | ||
76 | module Numeric.LinearProgramming( | 76 | module Numeric.LinearProgramming( |
77 | simplex, | 77 | simplex, |
78 | exact, | ||
78 | sparseOfGeneral, | 79 | sparseOfGeneral, |
79 | Optimization(..), | 80 | Optimization(..), |
80 | Constraints(..), | 81 | Constraints(..), |
@@ -132,8 +133,8 @@ sparseOfGeneral :: Constraints -> Constraints | |||
132 | sparseOfGeneral (General cs) = | 133 | sparseOfGeneral (General cs) = |
133 | Sparse $ map (\bl -> | 134 | Sparse $ map (\bl -> |
134 | let cl = obj bl in | 135 | let cl = obj bl in |
135 | let m = foldr (\(c,t) m -> Map.insertWith (+) t c m) Map.empty cl in | 136 | let cl_unique = foldr (\(c,t) m -> Map.insertWith (+) t c m) Map.empty cl in |
136 | withObj bl (Map.foldrWithKey' (\t c l -> (c#t) : l) [] m)) cs | 137 | withObj bl (Map.foldrWithKey' (\t c l -> (c#t) : l) [] cl_unique)) cs |
137 | sparseOfGeneral _ = error "sparseOfGeneral: a general system of constraints was expected" | 138 | sparseOfGeneral _ = error "sparseOfGeneral: a general system of constraints was expected" |
138 | 139 | ||
139 | simplex :: Optimization -> Constraints -> Bounds -> Solution | 140 | simplex :: Optimization -> Constraints -> Bounds -> Solution |
@@ -156,6 +157,27 @@ simplex opt (Sparse constr) bnds = extract sg sol where | |||
156 | 157 | ||
157 | simplex opt constr@(General _) bnds = simplex opt (sparseOfGeneral constr) bnds | 158 | simplex opt constr@(General _) bnds = simplex opt (sparseOfGeneral constr) bnds |
158 | 159 | ||
160 | -- | Simplex method with exact internal arithmetic. See glp_exact in glpk documentation for more information. | ||
161 | exact :: Optimization -> Constraints -> Bounds -> Solution | ||
162 | |||
163 | exact opt (Dense []) bnds = exact opt (Sparse []) bnds | ||
164 | exact opt (Sparse []) bnds = exact opt (Sparse [Free [0#1]]) bnds | ||
165 | exact opt (General []) bnds = exact opt (Sparse [Free [0#1]]) bnds | ||
166 | |||
167 | exact opt (Dense constr) bnds = extract sg sol where | ||
168 | sol = exactSparse m n (mkConstrD sz objfun constr) (mkBounds sz constr bnds) | ||
169 | n = length objfun | ||
170 | m = length constr | ||
171 | (sz, sg, objfun) = adapt opt | ||
172 | |||
173 | exact opt (Sparse constr) bnds = extract sg sol where | ||
174 | sol = exactSparse m n (mkConstrS sz objfun constr) (mkBounds sz constr bnds) | ||
175 | n = length objfun | ||
176 | m = length constr | ||
177 | (sz, sg, objfun) = adapt opt | ||
178 | |||
179 | exact opt constr@(General _) bnds = exact opt (sparseOfGeneral constr) bnds | ||
180 | |||
159 | adapt :: Optimization -> (Int, Double, [Double]) | 181 | adapt :: Optimization -> (Int, Double, [Double]) |
160 | adapt opt = case opt of | 182 | adapt opt = case opt of |
161 | Maximize x -> (size x, 1 ,x) | 183 | Maximize x -> (size x, 1 ,x) |
@@ -265,6 +287,19 @@ simplexSparse m n c b = unsafePerformIO $ do | |||
265 | app3 (c_simplex_sparse (fi m) (fi n)) mat (cmat c) mat (cmat b) vec s "c_simplex_sparse" | 287 | app3 (c_simplex_sparse (fi m) (fi n)) mat (cmat c) mat (cmat b) vec s "c_simplex_sparse" |
266 | return s | 288 | return s |
267 | 289 | ||
290 | foreign import ccall unsafe "c_exact_sparse" c_exact_sparse | ||
291 | :: CInt -> CInt -- rows and cols | ||
292 | -> CInt -> CInt -> Ptr Double -- coeffs | ||
293 | -> CInt -> CInt -> Ptr Double -- bounds | ||
294 | -> CInt -> Ptr Double -- result | ||
295 | -> IO CInt -- exit code | ||
296 | |||
297 | exactSparse :: Int -> Int -> Matrix Double -> Matrix Double -> Vector Double | ||
298 | exactSparse m n c b = unsafePerformIO $ do | ||
299 | s <- createVector (2+n) | ||
300 | app3 (c_exact_sparse (fi m) (fi n)) mat (cmat c) mat (cmat b) vec s "c_exact_sparse" | ||
301 | return s | ||
302 | |||
268 | glpFR, glpLO, glpUP, glpDB, glpFX :: Double | 303 | glpFR, glpLO, glpUP, glpDB, glpFX :: Double |
269 | glpFR = 0 | 304 | glpFR = 0 |
270 | glpLO = 1 | 305 | glpLO = 1 |