aboutsummaryrefslogtreecommitdiff
path: root/Math
diff options
context:
space:
mode:
authorJustin Bedo <cu@cua0.org>2014-10-30 07:03:03 +1100
committerJustin Bedo <cu@cua0.org>2014-10-30 07:13:33 +1100
commit946d8bcd81c1ea580032cd9f8140aad223b3156f (patch)
treeae7c55ecef51fc56f74388435927c71dc5ea0c65 /Math
parentd68fb49cad1a5bba7e52c7ff464d15c867052d0f (diff)
Bugfix: alignment of variables in solution was incorrect
Diffstat (limited to 'Math')
-rw-r--r--Math/LinProg/LPSolve.hs35
-rw-r--r--Math/LinProg/LPSolve/FFI.hs5
2 files changed, 23 insertions, 17 deletions
diff --git a/Math/LinProg/LPSolve.hs b/Math/LinProg/LPSolve.hs
index 5299d94..427c5d7 100644
--- a/Math/LinProg/LPSolve.hs
+++ b/Math/LinProg/LPSolve.hs
@@ -43,38 +43,38 @@ solveWithTimeout t (compile -> lp) = do
setTimeout m t
-- Eqs
- forM_ (zip [1..] $ lp ^. equals) $ \(i, eq) ->
- forM_ (varTerms (fst eq)) $ \(v, w) -> do
- let c = negate $ snd eq
+ forM_ (zip [1..] $ lp ^. equals) $ \(i, eq) -> do
+ let c = negate $ snd eq
+ setConstrType m i EQ
+ setRHS m i c
+ forM_ (varTerms (fst eq)) $ \(v, w) ->
setMat m i (varLUT M.! v) w
- setConstrType m i EQ
- setRHS m i c
- return ()
+ return ()
-- Leqs
- forM_ (zip [1+nequals..] $ lp ^. leqs) $ \(i, eq) ->
- forM_ (varTerms (fst eq)) $ \(v, w) -> do
- let c = negate $ snd eq
+ forM_ (zip [1+nequals..] $ lp ^. leqs) $ \(i, eq) -> do
+ let c = negate $ snd eq
+ setConstrType m i LE
+ setRHS m i c
+ forM_ (varTerms (fst eq)) $ \(v, w) ->
setMat m i (varLUT M.! v) w
- setConstrType m i LE
- setRHS m i c
- return ()
+ return ()
-- Ints
- forM_ (lp ^. ints) $ \v -> do
+ forM_ (lp ^. ints) $ \v ->
setInt m (varLUT M.! v)
-- Bins
- forM_ (lp ^. bins) $ \v -> do
+ forM_ (lp ^. bins) $ \v ->
setBin m (varLUT M.! v)
-- Objective
- forM_ (varTerms (lp ^. objective)) $ \(v, w) -> do
+ forM_ (varTerms (lp ^. objective)) $ \(v, w) ->
void $ setMat m 0 (varLUT M.! v) w
res <- F.solve m
sol <- snd <$> getSol nvars m
- let vars = zip (M.keys varLUT) sol
+ let vars = zip varList sol
return (Just res, vars)
where
nconstr = length allConstr
@@ -82,7 +82,8 @@ solveWithTimeout t (compile -> lp) = do
nequals = length (lp ^. equals)
allConstr = (lp ^. equals) ++ (lp ^. leqs)
- varLUT = M.fromList $ zip (sort $ nub $ concatMap (vars . fst) allConstr ++ vars (lp ^. objective)) [1..]
+ varList = nub $ concatMap (vars . fst) allConstr ++ vars (lp ^. objective)
+ varLUT = M.fromList $ zip varList [1..]
with m f = do
r <- f m
diff --git a/Math/LinProg/LPSolve/FFI.hs b/Math/LinProg/LPSolve/FFI.hs
index ff0bc16..64919b9 100644
--- a/Math/LinProg/LPSolve/FFI.hs
+++ b/Math/LinProg/LPSolve/FFI.hs
@@ -13,6 +13,7 @@ module Math.LinProg.LPSolve.FFI (
,setRHS
,solve
,getSol
+ ,debugDump
) where
import Foreign
@@ -56,6 +57,10 @@ foreign import ccall "set_constr_type" c_set_constr_type :: LPRec -> CInt -> CIn
foreign import ccall "set_timeout" c_set_timeout :: LPRec -> CLong -> IO ()
foreign import ccall "set_int" c_set_int :: LPRec -> CInt -> CChar -> IO CChar
foreign import ccall "set_binary" c_set_binary :: LPRec -> CInt -> CChar -> IO CChar
+foreign import ccall "print_debugdump" c_print_debugdump :: LPRec -> CString -> IO ()
+
+debugDump :: LPRec -> FilePath -> IO ()
+debugDump lp path = withCString path $ \str -> c_print_debugdump lp str
setTimeout :: LPRec -> Integer -> IO ()
setTimeout lp x = c_set_timeout lp (fromIntegral x)