module Data.LinearProgram.GLPK.Internal (GLPK, MsgLev (..), Preprocessing (..), Direction(..), BacktrackTechnique(..),
BranchingTechnique(..), Cuts(..), runGLPK, addCols,
addRows, createIndex, findCol, findRow, getColPrim, getRowPrim, getObjVal,
mipColVal, mipRowVal, mipObjVal, mipSolve, setColBounds, setColKind, setColName, setMatRow,
setObjCoef, setObjectiveDirection, setRowBounds, setRowName, solveSimplex) where
import Control.Monad
import Control.Monad.Trans
import Debug.Trace
import Foreign.Ptr
import Foreign.C
import Foreign.ForeignPtr
import Foreign.Marshal.Array
import Data.Bits
import Data.LinearProgram.Types
data GlpProb
foreign import ccall "c_glp_create_prob" glpCreateProb :: IO (Ptr GlpProb)
foreign import ccall "c_glp_set_obj_dir" glpSetObjDir :: Ptr GlpProb -> CInt -> IO ()
foreign import ccall "c_glp_add_rows" glpAddRows :: Ptr GlpProb -> CInt -> IO CInt
foreign import ccall "c_glp_add_cols" glpAddCols :: Ptr GlpProb -> CInt -> IO CInt
foreign import ccall "c_glp_set_row_name" glpSetRowName :: Ptr GlpProb -> CInt -> CString -> IO ()
foreign import ccall "c_glp_set_col_name" glpSetColName :: Ptr GlpProb -> CInt -> CString -> IO ()
foreign import ccall "c_glp_set_row_bnds" glpSetRowBnds :: Ptr GlpProb -> CInt -> CInt -> CDouble -> CDouble -> IO ()
foreign import ccall "c_glp_set_col_bnds" glpSetColBnds :: Ptr GlpProb -> CInt -> CInt -> CDouble -> CDouble -> IO ()
foreign import ccall "c_glp_set_obj_coef" glpSetObjCoef :: Ptr GlpProb -> CInt -> CDouble -> IO ()
foreign import ccall "c_glp_set_mat_row" glpSetMatRow :: Ptr GlpProb -> CInt -> CInt -> Ptr CInt -> Ptr CDouble -> IO ()
foreign import ccall "c_glp_delete_prob" glpDelProb :: Ptr GlpProb -> IO ()
foreign import ccall "c_glp_create_index" glpCreateIndex :: Ptr GlpProb -> IO ()
foreign import ccall "c_glp_find_row" glpFindRow :: Ptr GlpProb -> CString -> IO CInt
foreign import ccall "c_glp_find_col" glpFindCol :: Ptr GlpProb -> CString -> IO CInt
foreign import ccall "c_glp_solve_simplex" glpSolveSimplex :: Ptr GlpProb -> CInt -> CInt -> CInt -> IO CInt
foreign import ccall "c_glp_get_obj_val" glpGetObjVal :: Ptr GlpProb -> IO CDouble
foreign import ccall "c_glp_get_row_prim" glpGetRowPrim :: Ptr GlpProb -> CInt -> IO CDouble
foreign import ccall "c_glp_get_col_prim" glpGetColPrim :: Ptr GlpProb -> CInt -> IO CDouble
foreign import ccall "c_glp_set_col_kind" glpSetColKind :: Ptr GlpProb -> CInt -> CInt -> IO ()
foreign import ccall "c_glp_mip_solve" glpMipSolve ::
Ptr GlpProb -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> CDouble -> CInt -> IO CInt
foreign import ccall "c_glp_mip_obj_val" glpMIPObjVal :: Ptr GlpProb -> IO CDouble
foreign import ccall "c_glp_mip_row_val" glpMIPRowVal :: Ptr GlpProb -> CInt -> IO CDouble
foreign import ccall "c_glp_mip_col_val" glpMIPColVal :: Ptr GlpProb -> CInt -> IO CDouble
newtype GLPK a = GLP {execGLPK :: Ptr GlpProb -> IO a}
runGLPK :: GLPK a -> IO a
runGLPK m = do lp <- glpCreateProb
ans <- execGLPK m lp
glpDelProb lp
return ans
instance Monad GLPK where
return x = GLP $ \ _ -> return x
m >>= k = GLP $ \ lp -> do x <- execGLPK m lp
execGLPK (k x) lp
instance MonadIO GLPK where
liftIO m = GLP (const m)
setObjectiveDirection :: Direction -> GLPK ()
setObjectiveDirection dir = GLP $ flip glpSetObjDir
(case dir of Min -> 1
Max -> 2)
addRows :: Int -> GLPK Int
addRows n = GLP $ liftM (subtract 1 . fromIntegral) . flip glpAddRows (fromIntegral n)
addCols :: Int -> GLPK Int
addCols n = GLP $ liftM (subtract 1 . fromIntegral) . flip glpAddCols (fromIntegral n)
setRowName :: Int -> String -> GLPK ()
setRowName i nam = GLP $ withCString nam . flip glpSetRowName (fromIntegral (i+1))
setColName :: Int -> String -> GLPK ()
setColName i nam = GLP $ withCString nam . flip glpSetColName (fromIntegral (i+1))
setRowBounds :: Real a => Int -> Bounds a -> GLPK ()
setRowBounds i bds = GLP $ \ lp -> onBounds (glpSetRowBnds lp (fromIntegral (i+1))) bds
setColBounds :: Real a => Int -> Bounds a -> GLPK ()
setColBounds i bds = GLP $ \ lp -> onBounds (glpSetColBnds lp (fromIntegral (i+1))) bds
onBounds :: Real a => (CInt -> CDouble -> CDouble -> x) -> Bounds a -> x
onBounds f bds = case bds of
Free -> f 1 0 0
LBound a -> f 2 (realToFrac a) 0
UBound a -> f 3 0 (realToFrac a)
Bound a b -> f 4 (realToFrac a) (realToFrac b)
Equ a -> f 5 (realToFrac a) 0
setObjCoef :: Real a => Int -> a -> GLPK ()
setObjCoef i v = GLP $ \ lp -> glpSetObjCoef lp (fromIntegral (i + 1)) (realToFrac v)
setMatRow :: Real a => Int -> [(Int, a)] -> GLPK ()
setMatRow i row = GLP $ \ lp ->
allocaArray (len+1) $ \ (ixs :: Ptr CInt) -> allocaArray (len+1) $ \ (coeffs :: Ptr CDouble) -> do
pokeArray ixs (0:map (fromIntegral . (+1) . fst) row)
pokeArray coeffs (0:map (realToFrac . snd) row)
glpSetMatRow lp (fromIntegral (i+1)) (fromIntegral len) ixs coeffs
where len = length row
createIndex :: GLPK ()
createIndex = GLP glpCreateIndex
findRow :: String -> GLPK Int
findRow nam = GLP $ liftM (subtract 1 . fromIntegral) . withCString nam . glpFindRow
findCol :: String -> GLPK Int
findCol nam = GLP $ liftM (subtract 1 . fromIntegral) . withCString nam . glpFindCol
data MsgLev = MsgOff | MsgErr | MsgOn | MsgAll
solveSimplex :: MsgLev -> Int -> Bool -> GLPK Bool
solveSimplex msglev tmLim presolve = GLP $ \ lp -> liftM (== 0) $ glpSolveSimplex lp
(getMsgLev msglev)
tmLim'
(if presolve then 1 else 0)
where tmLim' = fromIntegral (tmLim * 1000)
getMsgLev :: MsgLev -> CInt
getMsgLev msglev = case msglev of
MsgOff -> 0
MsgErr -> 1
MsgOn -> 2
MsgAll -> 3
getObjVal :: GLPK Double
getObjVal = liftM realToFrac $ GLP glpGetObjVal
getRowPrim :: Int -> GLPK Double
getRowPrim i = liftM realToFrac $ GLP (`glpGetRowPrim` fromIntegral (i+1))
getColPrim :: Int -> GLPK Double
getColPrim i = liftM realToFrac $ GLP (`glpGetColPrim` fromIntegral (i+1))
setColKind :: Int -> VarKind -> GLPK ()
setColKind i kind = GLP $ \ lp -> glpSetColKind lp (fromIntegral (i+1)) (case kind of
ContVar -> 1
IntVar -> 2
BinVar -> 3)
data BranchingTechnique = FirstFrac | LastFrac | MostFrac | DrTom | HybridP
data BacktrackTechnique = DepthFirst | BreadthFirst | LocBound | ProjHeur
data Preprocessing = NoPre | RootPre | AllPre
data Cuts = GMI | MIR | Cov | Clq deriving (Eq)
mipSolve :: MsgLev -> BranchingTechnique -> BacktrackTechnique -> Preprocessing -> Bool ->
[Cuts] -> Double -> Int -> Bool -> GLPK Bool
mipSolve msglev brt btt pp fp cuts mipgap tmlim presol =
liftM (== 0) $ GLP $ \ lp -> glpMipSolve lp (getMsgLev msglev)
brt' btt' pp' fp' tmlim' cuts' mipgap' presol'
where brt' = case brt of
FirstFrac -> 1
LastFrac -> 2
MostFrac -> 3
DrTom -> 4
HybridP -> 5
btt' = case btt of
DepthFirst -> 1
BreadthFirst -> 2
LocBound -> 3
ProjHeur -> 4
pp' = case pp of
NoPre -> 0
RootPre -> 1
AllPre -> 2
fp' = if fp then 1 else 0
cuts' = (if GMI `elem` cuts then 1 else 0) .|.
(if MIR `elem` cuts then 2 else 0) .|.
(if Cov `elem` cuts then 4 else 0) .|.
(if Clq `elem` cuts then 8 else 0)
mipgap' = realToFrac mipgap
tmlim' = fromIntegral (1000 * tmlim)
presol' = if presol then 1 else 0
mipObjVal :: GLPK Double
mipObjVal = liftM realToFrac $ GLP glpMIPObjVal
mipRowVal :: Int -> GLPK Double
mipRowVal i = liftM realToFrac $ GLP (`glpMIPRowVal` fromIntegral (i+1))
mipColVal :: Int -> GLPK Double
mipColVal i = liftM realToFrac $ GLP (`glpMIPRowVal` fromIntegral (i+1))