Added LPSolve as a solver

1 files changed, 89 insertions, 0 deletions

diff --git a/Math/LinProg/LPSolve/FFI.hs b/Math/LinProg/LPSolve/FFI.hs
new file mode 100644
index 0000000..eb818df
--- /dev/null
+++ b/Math/LinProg/LPSolve/FFI.hs
@@ -0,0 +1,89 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+module Math.LinProg.LPSolve.FFI where
+
+import Foreign
+import Foreign.C
+import Foreign.Marshal.Array
+import Control.Applicative ((<$>))
+import qualified Data.Map as M
+
+type LPRec = Ptr ()
+
+data ResultCode =
+  NoMemory
+  |Optimal
+  |SubOptimal
+  |Infeasible
+  |Unbounded
+  |Degenerate
+  |NumFailure
+  |UserAbort
+  |Timeout
+  |PreSolved
+  |ProcFail
+  |ProcBreak
+  |FeasFound
+  |NoFeasFound
+  deriving (Show, Eq, Ord)
+
+data ConstraintType =
+  Fr
+  |LE
+  |GE
+  |EQ
+  deriving (Show, Eq, Ord, Enum)
+
+foreign import ccall "make_lp" c_make_lp :: CInt -> CInt -> IO LPRec
+foreign import ccall "free_lp" c_free_lp :: Ptr LPRec -> IO ()
+foreign import ccall "set_mat" c_set_mat :: LPRec -> CInt -> CInt -> CDouble -> IO CChar
+foreign import ccall "set_rh" c_set_rh :: LPRec -> CInt -> CDouble -> IO CChar
+foreign import ccall "solve" c_solve :: LPRec -> IO CInt
+foreign import ccall "get_variables" c_get_variables :: LPRec -> Ptr CDouble -> IO CChar
+foreign import ccall "set_constr_type" c_set_constr_type :: LPRec -> CInt -> CInt -> IO CChar
+
+setConstrType :: LPRec -> Int -> ConstraintType -> IO Word8
+setConstrType lp i t = fromIntegral <$> c_set_constr_type lp (fromIntegral i) (fromIntegral $ fromEnum t)
+
+makeLP :: Int -> Int -> IO (Maybe LPRec)
+makeLP n m = do
+  m <- c_make_lp (fromIntegral n) (fromIntegral m)
+  return $ if m == nullPtr then
+    Nothing
+  else
+    Just m
+
+freeLP :: LPRec -> IO ()
+freeLP m = with m $ \m' -> c_free_lp m'
+
+setMat :: LPRec -> Int -> Int -> Double -> IO Word8
+setMat a b c d = fromIntegral <$> c_set_mat a (fromIntegral b) (fromIntegral c) (realToFrac d)
+
+setRHS :: LPRec -> Int -> Double -> IO Word8
+setRHS a b c = fromIntegral <$> c_set_rh a (fromIntegral b) (realToFrac c)
+
+solve :: LPRec -> IO ResultCode
+solve lp = (lut M.!) . fromIntegral <$> c_solve lp
+  where
+    lut = M.fromList [
+        (-2, NoMemory)
+        ,(0, Optimal)
+        ,(1, SubOptimal)
+        ,(2, Infeasible)
+        ,(3, Unbounded)
+        ,(4, Degenerate)
+        ,(5, NumFailure)
+        ,(6, UserAbort)
+        ,(7, Timeout)
+        ,(9, PreSolved)
+        ,(10, ProcFail)
+        ,(11, ProcBreak)
+        ,(12, FeasFound)
+        ,(13, NoFeasFound)
+      ]
+
+getSol :: Int -> LPRec -> IO (Word8, [Double])
+getSol n lp = allocaArray (1+n) $ \arr -> do
+    res <- c_get_variables lp arr
+    vals <- peekArray (1+n) arr
+    let vs = map realToFrac vals
+    return (fromIntegral res, vs)