1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
|
{-# LANGUAGE ForeignFunctionInterface, ViewPatterns #-}
module Math.LinProg.LPSolve.FFI (
ResultCode(..)
,ConstraintType(..)
,LPRec
,setConstrType
,setTimeout
,setInt
,setBin
,makeLP
,freeLP
,setRow
,setMat
,setRHS
,solve
,getSol
,debugDump
) where
import Foreign
import Foreign.C
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
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 ()
foreign import ccall "hs_set_row" c_hs_set_row :: LPRec -> CInt -> CInt -> Ptr CInt -> Ptr CDouble -> IO CChar
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)
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)
setRow :: LPRec -> Int -> [(Int, Double)] -> IO Word8
setRow m row (unzip -> (cols, ws)) = fmap fromIntegral $ withArray (map fromIntegral cols) $ \c ->
withArray (map realToFrac ws) $ \w ->
c_hs_set_row m
(fromIntegral row)
(fromIntegral (length cols))
c
w
setRHS :: LPRec -> Int -> Double -> IO Word8
setRHS a b c = fromIntegral <$> c_set_rh a (fromIntegral b) (realToFrac c)
setInt :: LPRec -> Int -> IO Word8
setInt m a = fromIntegral <$> c_set_int m (fromIntegral a) 1
setBin :: LPRec -> Int -> IO Word8
setBin m a = fromIntegral <$> c_set_binary m (fromIntegral a) 1
solve :: LPRec -> IO ResultCode
solve lp = (lut M.!) . fromIntegral <$> c_solve lp
where
lut = M.fromList [
(-2, NoMemory)
,(0 :: Int, 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)
|
