glpk-hs 0.0.0 → 0.0.1

raw patch · 7 files changed

+112/−81 lines, 7 filesdep +timePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: time

API changes (from Hackage documentation)

Files

• Data/LinFunc.hs +1/−1
• Data/LinearProgram/GLPK.hs +30/−23
• Data/LinearProgram/GLPK/Internal.hs +57/−54
• Data/LinearProgram/Spec.hs +9/−0
• Data/LinearProgram/Types.hs +7/−0
• glpk-hs.cabal +2/−2
• glpk/glpk.c +6/−1

@@ -9,7 +9,7 @@ import Data.Ratio import Data.Array.Base import Data.Array.IArray-import Data.Array.Unboxed+-- import Data.Array.Unboxed  -- import Data.LinFunc.TH import Data.LinFunc.Class

@@ -7,13 +7,16 @@  import Control.Monad.Trans +-- import Debug.Trace+ import Data.Map import Data.Maybe (catMaybes) import Data.LinearProgram.Spec import Data.LinearProgram.Types import Data.LinearProgram.GLPK.Internal -import System.CPUTime+import Data.Time.Clock+-- import System.Time  import GHC.Exts(build) @@ -33,7 +36,7 @@  -- | Solves the linear or mixed integer programming problem.  Returns -- the value of the objective function, and the values of the variables.-glpSolveVars :: (Ord v, Real c) => GLPOpts -> LP v c -> IO (Double, Map v Double)+glpSolveVars :: (Ord v, Show v, Real c) => GLPOpts -> LP v c -> IO (Double, Map v Double) glpSolveVars opts@SimplexOpts{} lp = runGLPK $ do 	Just vars <- doGLP opts lp 	obj <- getObjVal@@ -54,7 +57,7 @@ -- | Solves the linear or mixed integer programming problem.  Returns -- the value of the objective function, the values of the variables, -- and the values of any labeled rows.-glpSolveAll :: (Ord v, Real c) => GLPOpts -> LP v c -> IO (Double, Map v Double, Map String Double)+glpSolveAll :: (Ord v, Show v, Real c) => GLPOpts -> LP v c -> IO (Double, Map v Double, Map String Double) glpSolveAll opts@SimplexOpts{} lp@LP{..} = runGLPK $ do 	Just vars <- doGLP opts lp 	obj <- getObjVal@@ -80,40 +83,44 @@ 				| (i, Constr nam _ _) <- zip [0..] constraints] 	return (obj, fromDistinctAscList vals, fromDistinctAscList (catMaybes rows)) -doGLP :: (Ord v, Real c) => GLPOpts -> LP v c -> GLPK (Maybe (Map v Int))+doGLP :: (Ord v, Show v, Real c) => GLPOpts -> LP v c -> GLPK (Maybe (Map v Int)) doGLP SimplexOpts{..} lp = do 	vars <- writeProblem lp 	success <- solveSimplex msgLev tmLim presolve-	return (if success then Just vars else Nothing)+	return (Just vars) doGLP MipOpts{..} lp = do 	vars <- writeProblem lp-	time <- getTime-	solveSimplex msgLev tmLim presolve-	time' <- getTime-	let tmLim' = (fromIntegral tmLim - time' + time + 1000000000000 - 1) `quot` 1000000000000+-- 	time <- getTime+-- 	solveSimplex msgLev tmLim presolve+-- 	time' <- getTime+	let tmLim' = tmLim  --- round (toRational (time' `diffUTCTime` time)) 	success <- mipSolve msgLev brTech btTech ppTech fpHeur cuts mipGap (fromIntegral tmLim') presolve-	return (if success then Just vars else Nothing)-	where	getTime = liftIO getCPUTime+	return (Just vars) --(if success then Just vars else Nothing)+-- 	where	getTime = liftIO getCurrentTime -writeProblem :: (Ord v, Real c) => LP v c -> GLPK (Map v Int)+writeProblem :: (Ord v, Show v, Real c) => LP v c -> GLPK (Map v Int) writeProblem LP{..} = do 	setObjectiveDirection direction 	i0 <- addCols nVars-	sequence_ [setObjCoef (i + i0) v | (i, v) <- elems $ intersectionWith (,) allVars objective]+	let allVars' = fmap (i0 +) allVars+	sequence_ [setColName i (show v) | (v, i) <- assocs allVars']+	sequence_ [setObjCoef i v | (i, v) <- elems $ intersectionWith (,) allVars' objective] 	j0 <- addRows (length constraints) 	sequence_ [do	case lab of 				Nothing	-> return ()-				Just n	-> setRowName (j0 + j) n-			setMatRow (j0 + j)-				(elems (intersectionWith (,) allVars f))-			setRowBounds (j0 + j) bnds-				| (j, Constr lab f bnds) <- zip [0..] constraints]+				Just n	-> setRowName j n+			setMatRow j+				[(i, v) | (i, v) <- elems (intersectionWith (,) allVars' f)]+			setRowBounds j bnds+				| (j, Constr lab f bnds) <- zip [j0..] constraints] 	createIndex-	sequence_ [setColBounds (i0 + i) bnds |-			(i, bnds) <- elems $ intersectionWith (,) allVars varBounds]-	sequence_ [setColKind (i0 + i) knd |-			(i, knd) <- elems $ intersectionWith (,) allVars varTypes]-	return allVars+	sequence_ [setColBounds (i) bnds |+			(i, bnds) <- elems $ intersectionWith (,) allVars' varBounds]+	sequence_ [setColBounds i Free | i <- elems $ difference allVars' varBounds]+	sequence_ [setColKind (i) knd |+			(i, knd) <- elems $ intersectionWith (,) allVars' varTypes]+-- 	writeLP+	return allVars' 	where	allVars0 = fmap (const ()) objective `union` 			unions [fmap (const ()) f | Constr _ f _ <- constraints] `union` 			fmap (const ()) varBounds `union` fmap (const ()) varTypes

@@ -1,6 +1,6 @@ {-# LANGUAGE ScopedTypeVariables, EmptyDataDecls, ForeignFunctionInterface #-} module Data.LinearProgram.GLPK.Internal (GLPK, MsgLev (..), Preprocessing (..), Direction(..), BacktrackTechnique(..),-	BranchingTechnique(..), Cuts(..), runGLPK, addCols,+	BranchingTechnique(..), Cuts(..), runGLPK, writeLP, addCols, 	addRows, createIndex, findCol, findRow, getColPrim, getRowPrim, getObjVal, 	mipColVal, mipRowVal, mipObjVal, mipSolve, setColBounds, setColKind, setColName, setMatRow, 	setObjCoef, setObjectiveDirection, setRowBounds, setRowName, solveSimplex) where@@ -8,7 +8,7 @@ import Control.Monad import Control.Monad.Trans -import Debug.Trace+-- import Debug.Trace  import Foreign.Ptr import Foreign.C@@ -21,40 +21,42 @@  data GlpProb -foreign import ccall "c_glp_create_prob" glpCreateProb :: IO (Ptr GlpProb)+foreign import ccall unsafe "c_glp_create_prob" glpCreateProb :: IO (Ptr GlpProb) -- foreign import ccall "c_glp_set_obj_name" glpSetObjName :: Ptr GlpProb -> CString -> IO ()-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 :: +foreign import ccall unsafe "c_glp_set_obj_dir" glpSetObjDir :: Ptr GlpProb -> CInt -> IO ()+foreign import ccall unsafe "c_glp_add_rows" glpAddRows :: Ptr GlpProb -> CInt -> IO CInt+foreign import ccall unsafe "c_glp_add_cols" glpAddCols :: Ptr GlpProb -> CInt -> IO CInt+foreign import ccall unsafe "c_glp_set_row_name" glpSetRowName :: Ptr GlpProb -> CInt -> CString -> IO ()+foreign import ccall unsafe "c_glp_set_col_name" glpSetColName :: Ptr GlpProb -> CInt -> CString -> IO ()+foreign import ccall unsafe "c_glp_set_row_bnds" glpSetRowBnds :: Ptr GlpProb -> CInt -> CInt -> CDouble -> CDouble -> IO ()+foreign import ccall unsafe "c_glp_set_col_bnds" glpSetColBnds :: Ptr GlpProb -> CInt -> CInt -> CDouble -> CDouble -> IO ()+foreign import ccall unsafe "c_glp_set_obj_coef" glpSetObjCoef :: Ptr GlpProb -> CInt -> CDouble -> IO ()+foreign import ccall unsafe "c_glp_set_mat_row" glpSetMatRow :: Ptr GlpProb -> CInt -> CInt -> Ptr CInt -> Ptr CDouble -> IO ()+foreign import ccall unsafe "&c_glp_delete_prob" glpDelProb :: FunPtr (Ptr GlpProb -> IO ())+foreign import ccall unsafe "c_glp_create_index" glpCreateIndex :: Ptr GlpProb -> IO ()+foreign import ccall unsafe "c_glp_find_row" glpFindRow :: Ptr GlpProb -> CString -> IO CInt+foreign import ccall unsafe "c_glp_find_col" glpFindCol :: Ptr GlpProb -> CString -> IO CInt+foreign import ccall unsafe "c_glp_solve_simplex" glpSolveSimplex :: Ptr GlpProb -> CInt -> CInt -> CInt -> IO CInt+foreign import ccall unsafe "c_glp_get_obj_val" glpGetObjVal :: Ptr GlpProb -> IO CDouble+foreign import ccall unsafe "c_glp_get_row_prim" glpGetRowPrim :: Ptr GlpProb -> CInt -> IO CDouble+foreign import ccall unsafe "c_glp_get_col_prim" glpGetColPrim :: Ptr GlpProb -> CInt -> IO CDouble+foreign import ccall unsafe "c_glp_set_col_kind" glpSetColKind :: Ptr GlpProb -> CInt -> CInt -> IO ()+foreign import ccall unsafe "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+foreign import ccall unsafe "c_glp_mip_obj_val" glpMIPObjVal :: Ptr GlpProb -> IO CDouble+foreign import ccall unsafe "c_glp_mip_row_val" glpMIPRowVal :: Ptr GlpProb -> CInt -> IO CDouble+foreign import ccall unsafe "c_glp_mip_col_val" glpMIPColVal :: Ptr GlpProb -> CInt -> IO CDouble+foreign import ccall unsafe "c_glp_write_lp" glpWriteLP :: Ptr GlpProb -> IO ()  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+runGLPK m = do	lp <- newForeignPtr glpDelProb =<< glpCreateProb+		withForeignPtr lp (execGLPK m) +writeLP :: GLPK ()+writeLP = GLP glpWriteLP+ instance Monad GLPK where 	{-# INLINE return #-} 	{-# INLINE (>>=) #-}@@ -71,22 +73,22 @@ 			Max	-> 2)  addRows :: Int -> GLPK Int-addRows n = GLP $ liftM (subtract 1 . fromIntegral) . flip glpAddRows (fromIntegral n)+addRows n = GLP $ liftM fromIntegral . flip glpAddRows (fromIntegral n)  addCols :: Int -> GLPK Int-addCols n = GLP $ liftM (subtract 1 . fromIntegral) . flip glpAddCols (fromIntegral n)+addCols n = GLP $ liftM fromIntegral . flip glpAddCols (fromIntegral n)  setRowName :: Int -> String -> GLPK ()-setRowName i nam = GLP $ withCString nam . flip glpSetRowName (fromIntegral (i+1))+setRowName i nam = GLP $ withCString nam . flip glpSetRowName (fromIntegral i)  setColName :: Int -> String -> GLPK ()-setColName i nam = GLP $ withCString nam . flip glpSetColName (fromIntegral (i+1))+setColName i nam = GLP $ withCString nam . flip glpSetColName (fromIntegral i)  setRowBounds :: Real a => Int -> Bounds a -> GLPK ()-setRowBounds i bds = GLP $ \ lp -> onBounds (glpSetRowBnds lp (fromIntegral (i+1))) bds+setRowBounds i bds = GLP $ \ lp -> onBounds (glpSetRowBnds lp (fromIntegral i)) bds  setColBounds :: Real a => Int -> Bounds a -> GLPK ()-setColBounds i bds = GLP $ \ lp -> onBounds (glpSetColBnds lp (fromIntegral (i+1))) bds+setColBounds i bds = GLP $ \ lp -> onBounds (glpSetColBnds lp (fromIntegral i)) bds  onBounds :: Real a => (CInt -> CDouble -> CDouble -> x) -> Bounds a -> x onBounds f bds = case bds of@@ -97,24 +99,24 @@ 	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)+setObjCoef i v = GLP $ \ lp -> glpSetObjCoef lp (fromIntegral i) (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 ixs (0:map (fromIntegral . fst) row) 		pokeArray coeffs (0:map (realToFrac . snd) row)-		glpSetMatRow lp (fromIntegral (i+1)) (fromIntegral len) ixs coeffs+		glpSetMatRow lp (fromIntegral i) (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+findRow nam = GLP $ liftM fromIntegral . withCString nam . glpFindRow  findCol :: String -> GLPK Int-findCol nam = GLP $ liftM (subtract 1 . fromIntegral) . withCString nam . glpFindCol+findCol nam = GLP $ liftM fromIntegral . withCString nam . glpFindCol  data MsgLev = MsgOff | MsgErr | MsgOn | MsgAll @@ -136,13 +138,13 @@ getObjVal = liftM realToFrac $ GLP glpGetObjVal  getRowPrim :: Int -> GLPK Double-getRowPrim i = liftM realToFrac $ GLP (`glpGetRowPrim` fromIntegral (i+1))+getRowPrim i = liftM realToFrac $ GLP (`glpGetRowPrim` fromIntegral i)  getColPrim :: Int -> GLPK Double-getColPrim i = liftM realToFrac $ GLP (`glpGetColPrim` fromIntegral (i+1))+getColPrim i = liftM realToFrac $ GLP (`glpGetColPrim` fromIntegral i)  setColKind :: Int -> VarKind -> GLPK ()-setColKind i kind = GLP $ \ lp -> glpSetColKind lp (fromIntegral (i+1)) (case kind of+setColKind i kind = GLP $ \ lp -> glpSetColKind lp (fromIntegral i) (case kind of 	ContVar -> 1 	IntVar	-> 2 	BinVar	-> 3)@@ -155,37 +157,38 @@ 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)+		liftM (== 0) $ GLP $ \ lp -> glpMipSolve lp msglev' 						brt' btt' pp' fp' tmlim' cuts' mipgap' presol'-	where	brt' = case brt of+	where	!msglev' = getMsgLev msglev+		!brt' = case brt of 			FirstFrac	-> 1 			LastFrac	-> 2 			MostFrac	-> 3 			DrTom		-> 4 			HybridP		-> 5-		btt' = case btt of+		!btt' = case btt of 			DepthFirst	-> 1 			BreadthFirst	-> 2 			LocBound	-> 3 			ProjHeur	-> 4-		pp' = case pp of+		!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) .|.+		!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+		!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))+mipRowVal i = liftM realToFrac $ GLP (`glpMIPRowVal` fromIntegral i)  mipColVal :: Int -> GLPK Double-mipColVal i = liftM realToFrac $ GLP (`glpMIPRowVal` fromIntegral (i+1))+mipColVal i = liftM realToFrac $ GLP (`glpMIPColVal` fromIntegral i)

@@ -1,5 +1,7 @@+{-# LANGUAGE RecordWildCards #-} module Data.LinearProgram.Spec where +-- import Control.DeepSeq -- import Data.Bounds import Data.LinFunc import Data.LinearProgram.Types@@ -12,5 +14,12 @@ type ObjectiveFunc = LinFunc type VarBounds v c = Map v (Bounds c) +-- instance (NFData v, NFData c) => NFData (Constraint v c) where+-- 	rnf (Constr lab f b) = lab `deepseq` f `deepseq` rnf b+ data LP v c = LP {direction :: Direction, objective :: ObjectiveFunc v c, constraints :: [Constraint v c], 			varBounds :: VarBounds v c, varTypes :: VarTypes v} deriving (Read, Show)++-- instance (NFData v, NFData c) => NFData (LP v c) where+-- 	rnf LP{..} = direction `deepseq` objective `deepseq` constraints `deepseq`+-- 		varBounds `deepseq` rnf varTypes

@@ -1,18 +1,25 @@ module Data.LinearProgram.Types where +-- import Control.DeepSeq+ import Data.Monoid  data VarKind = ContVar | IntVar | BinVar deriving (Eq, Ord, Show, Read) +-- instance NFData VarKind+ instance Monoid VarKind where 	mempty = ContVar 	mappend = max  data Direction = Min | Max deriving (Eq, Ord, Show, Read) +-- instance NFData Direction  data Bounds a = 	Free | LBound a | UBound a | Equ a | Bound a a deriving (Eq, Show, Read)++-- instance NFData (Bounds a)  -- Bounds form a monoid under intersection. instance Ord a => Monoid (Bounds a) where

@@ -1,5 +1,5 @@ Name:           glpk-hs-Version:        0.0.0+Version:        0.0.1 Author:         Louis Wasserman License:        GPL License-file:   LICENSE@@ -20,7 +20,7 @@  extra-source-files: examples/example1.hs -Build-Depends:    base >= 3 && < 5, array, containers, mtl+Build-Depends:    base >= 3 && < 5, array, containers, mtl, time Exposed-modules:  Data.LinFunc,                   Data.LinearProgram,                   Data.LinearProgram.GLPK,

@@ -8,6 +8,10 @@ 	return lp; } +void c_glp_write_lp (glp_prob *lp){+  	glp_write_lp(lp, 0, "test.cplex");+}+ void c_glp_set_obj_name(glp_prob *lp, const char *name){   	glp_set_obj_name(lp, name); }@@ -99,7 +103,8 @@ 	iocp.br_tech = br_tech; 	iocp.bt_tech = bt_tech; 	iocp.pp_tech = pp_tech;-	iocp.fp_heur = fp_heur;+	iocp.fp_heur = fp_heur ? GLP_ON : GLP_OFF;+// 	printf ("fp %d\n", iocp.fp_heur); 	iocp.gmi_cuts = cuts & 1 ? GLP_ON : GLP_OFF; 	iocp.mir_cuts = cuts & 2 ? GLP_ON : GLP_OFF; 	iocp.cov_cuts = cuts & 4 ? GLP_ON : GLP_OFF;