glpk-hs 0.0.4 → 0.1.0

raw patch · 12 files changed

+233/−115 lines, 12 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Data/LinearProgram/Common.hs +9/−0
• Data/LinearProgram/GLPK/IO.hs +2/−2
• Data/LinearProgram/GLPK/IO/Internal.hs +17/−7
• Data/LinearProgram/GLPK/Internal.hs +23/−44
• Data/LinearProgram/GLPK/Solver.hs +3/−19
• Data/LinearProgram/GLPK/Types.hs +1/−1
• Data/LinearProgram/LPMonad.hs +21/−9
• Data/LinearProgram/LPMonad/Internal.hs +12/−7
• Data/LinearProgram/LinFunc.hs +3/−5
• Data/LinearProgram/Spec.hs +121/−9
• Data/LinearProgram/Types.hs +20/−11
• glpk-hs.cabal +1/−1

@@ -6,3 +6,12 @@ import Data.LinearProgram.Spec import Data.LinearProgram.LinFunc import Data.LinearProgram.Types++import Data.Map+import GHC.Exts (build)++{-# RULES+	"assocs" assocs = \ m -> build (\ c n -> foldWithKey (curry c) n m);+	"elems" elems = \ m -> build (\ c n -> foldWithKey (const c) n m);+	"keys" keys = \ m -> build (\ c n -> foldWithKey (\ k _ -> c k) n m);+	#-}

@@ -12,8 +12,8 @@  -- | Read a linear program from a file in CPLEX LP format. readLP :: FilePath -> IO (LP String Double)-readLP = runGLPK . readGLP_LP+readLP = runGLPK . readGLPLP  -- | Write a linear program to a file in CPLEX LP format. writeLP :: (Ord v, Show v, Real c) => FilePath -> LP v c -> IO ()-writeLP file = runGLPK . writeGLP_LP file+writeLP file = runGLPK . writeGLPLP file

@@ -1,9 +1,9 @@ {-# LANGUAGE ForeignFunctionInterface #-} -module Data.LinearProgram.GLPK.IO.Internal (readGLP_LP, writeGLP_LP) where+module Data.LinearProgram.GLPK.IO.Internal (readGLPLP, writeGLPLP) where  import Control.Monad-import Control.Monad.Trans+import Control.Monad.Trans (liftIO, lift)  import Data.Map hiding (map, filter) @@ -13,6 +13,8 @@  foreign import ccall unsafe "c_glp_write_lp" glpWriteLP :: Ptr GlpProb -> CString -> IO () foreign import ccall unsafe "c_glp_read_lp" glpReadLP :: Ptr GlpProb -> 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_name" glpSetRowName :: Ptr GlpProb -> CInt -> CString -> IO () foreign import ccall unsafe "c_glp_get_obj_dir" glpGetObjDir :: Ptr GlpProb -> IO CInt foreign import ccall unsafe "c_glp_get_num_rows" glpGetNumRows :: Ptr GlpProb -> IO CInt foreign import ccall unsafe "c_glp_get_num_cols" glpGetNumCols :: Ptr GlpProb -> IO CInt@@ -63,6 +65,12 @@ getCDouble :: (Ptr GlpProb -> CInt -> IO CDouble) -> Int -> GLPK Double getCDouble f i = GLP $ \ lp -> liftM realToFrac $ f lp (fromIntegral i) +setRowName :: Int -> String -> GLPK ()+setRowName i nam = GLP $ withCString nam . flip glpSetRowName (fromIntegral i)++setColName :: Int -> String -> GLPK ()+setColName i nam = GLP $ withCString nam . flip glpSetColName (fromIntegral i)+ loadBounds :: (Int -> GLPK Double) -> (Int -> GLPK Double) -> 	(Int -> GLPK Int) -> Int -> GLPK (Bounds Double) loadBounds lb ub tp i = do@@ -89,8 +97,8 @@ 			return (i, zip (map fromIntegral ixsL) (map realToFrac coefsL)) 			| i <- [1..n]] -readGLP_LP :: FilePath -> GLPK (LP String Double)-readGLP_LP file = execLPT $ do+readGLPLP :: FilePath -> GLPK (LP String Double)+readGLPLP file = execLPT $ do 	lift $ readLP file 	setDirection =<< lift getDir 	nCols <- lift getNumCols@@ -117,7 +125,9 @@ 	setObjective (fromList (filter ((/= 0) . snd) obj)) 		 -writeGLP_LP :: (Show v, Ord v, Real c) => FilePath -> LP v c -> GLPK ()-writeGLP_LP file lp = do-	writeProblem lp+writeGLPLP :: (Show v, Ord v, Real c) => FilePath -> LP v c -> GLPK ()+writeGLPLP file lp = do+	vars <- writeProblem lp+	sequence_ [setColName i (show v) | (v, i) <- assocs vars]+	sequence_ [setRowName i lab | (i, Constr (Just lab) _ _) <- zip [1..] (constraints lp)] 	writeLP file

@@ -1,8 +1,10 @@-{-# LANGUAGE RecordWildCards, ScopedTypeVariables, EmptyDataDecls, ForeignFunctionInterface #-}-module Data.LinearProgram.GLPK.Internal (writeProblem, addCols,+{-# LANGUAGE RecordWildCards, ScopedTypeVariables, ForeignFunctionInterface #-}+module Data.LinearProgram.GLPK.Internal (writeProblem, solveSimplex, mipSolve,+	getObjVal, getRowPrim, getColPrim, mipObjVal, mipRowVal, mipColVal) where+{-(writeProblem, addCols, 	addRows, createIndex, findCol, findRow, getColPrim, getRowPrim, getObjVal, 	mipColVal, mipRowVal, mipObjVal, mipSolve, setColBounds, setColKind, setColName, setMatRow,-	setObjCoef, setObjectiveDirection, setRowBounds, setRowName, solveSimplex) where+	setObjCoef, setObjectiveDirection, setRowBounds, setRowName, solveSimplex) where-}  import Control.Monad @@ -20,15 +22,13 @@ 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_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_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@@ -50,12 +50,6 @@ addCols :: Int -> GLPK Int addCols n = GLP $ liftM fromIntegral . flip glpAddCols (fromIntegral n) -setRowName :: Int -> String -> GLPK ()-setRowName i nam = GLP $ withCString nam . flip glpSetRowName (fromIntegral i)--setColName :: Int -> String -> GLPK ()-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)) bds @@ -81,14 +75,14 @@ 		glpSetMatRow lp (fromIntegral i) (fromIntegral len) ixs coeffs 	where	len = length row -createIndex :: GLPK ()-createIndex = GLP glpCreateIndex+-- createIndex :: GLPK ()+-- createIndex = GLP glpCreateIndex -findRow :: String -> GLPK Int-findRow nam = GLP $ liftM fromIntegral . withCString nam . glpFindRow+-- findRow :: String -> GLPK Int+-- findRow nam = GLP $ liftM fromIntegral . withCString nam . glpFindRow -findCol :: String -> GLPK Int-findCol nam = GLP $ liftM fromIntegral . withCString nam . glpFindCol+-- findCol :: String -> GLPK Int+-- findCol nam = GLP $ liftM fromIntegral . withCString nam . glpFindCol  solveSimplex :: MsgLev -> Int -> Bool -> GLPK ReturnCode solveSimplex msglev tmLim presolve = GLP $ \ lp -> liftM (toEnum . fromIntegral) $ glpSolveSimplex lp@@ -118,29 +112,17 @@ 		liftM (toEnum . fromIntegral) $ GLP $ \ lp -> glpMipSolve lp msglev' 						brt' btt' pp' fp' tmlim' cuts' mipgap' presol' 	where	!msglev' = getMsgLev msglev-		!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+		!brt' = 1 + fromIntegral (fromEnum brt)+		!btt' = 1 + fromIntegral (fromEnum btt)+		!pp' = fromIntegral (fromEnum pp)+		!fp' = fromIntegral (fromEnum fp) 		!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+		!presol' = fromIntegral (fromEnum presol)  mipObjVal :: GLPK Double mipObjVal = liftM realToFrac $ GLP glpMIPObjVal@@ -158,18 +140,15 @@ 	let allVars' = fmap (i0 +) 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 j n-			setMatRow j+	sequence_ [do	setMatRow j 				[(i, v) | (i, v) <- elems (intersectionWith (,) allVars' f)] 			setRowBounds j bnds-				| (j, Constr lab f bnds) <- zip [j0..] constraints]+				| (j, Constr _ f bnds) <- zip [j0..] constraints] -- 	createIndex-	sequence_ [setColBounds (i) bnds |+	sequence_ [setColBounds i bnds | 			(i, bnds) <- elems $ intersectionWith (,) allVars' varBounds] 	sequence_ [setColBounds i Free | i <- elems $ difference allVars' varBounds]-	sequence_ [setColKind (i) knd |+	sequence_ [setColKind i knd | 			(i, knd) <- elems $ intersectionWith (,) allVars' varTypes] -- 	writeLP 	return allVars'

@@ -19,20 +19,10 @@ 	Cuts(..)) where   import Control.Monad--- import Control.Monad.Trans --- import Debug.Trace- import Data.Map--- import Data.Maybe (catMaybes)-import Data.LinearProgram.Common-import Data.LinearProgram.GLPK.Internal-import Data.LinearProgram.GLPK.Types---- import Data.Time.Clock--- import System.Time--import GHC.Exts(build)+import Data.LinearProgram.Spec+import Data.LinearProgram.GLPK.Common  -- | Options available for customizing GLPK operations.  This also determines -- which kind of solving is performed -- relaxed LP, or MIP.@@ -95,7 +85,7 @@ 			val <- mipColVal i 			return (v, val) 				| (v, i) <- assocs vars]-		rows <- sequence [liftM (RowVal c) (getRowPrim i)+		rows <- sequence [liftM (RowVal c) (mipRowVal i) 					| (i, c) <- zip [1..] constraints] 		return (Just (obj, fromDistinctAscList vals, rows))) vars @@ -113,9 +103,3 @@ 	success <- mipSolve msgLev brTech btTech ppTech fpHeur cuts mipGap (fromIntegral tmLim') presolve 	return (success, guard (gaveAnswer success) >> Just vars) --(if success then Just vars else Nothing) -- 	where	getTime = liftIO getCurrentTime-		-{-# RULES-	"assocs" assocs = \ m -> build (\ c n -> foldWithKey (curry c) n m);-	"elems" elems = \ m -> build (\ c n -> foldWithKey (const c) n m);-	"keys" keys = \ m -> build (\ c n -> foldWithKey (\ k _ -> c k) n m);-	#-}

@@ -2,7 +2,7 @@  module Data.LinearProgram.GLPK.Types where -import Control.Monad.Trans+import Control.Monad.Trans (MonadIO (..))  import Foreign.Ptr import Foreign.ForeignPtr

@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts, RecordWildCards #-}+{-# LANGUAGE FlexibleContexts #-}  -- | A collection of operations that can be used to specify linear programming in a -- simple, monadic way.  It is not too difficult to construct 'LP' values explicitly,@@ -17,13 +17,14 @@ 	glpSolve', 	-- * File I/O 	writeLPToFile,-	readLPFromFile) where+	readLPFromFile,+	readLPFromFile') where -import Control.Monad.State.Strict--- import Control.Monad.Identity+import Control.Monad ((<=<))+import Control.Monad.State.Class (MonadState(..))+import Control.Monad.Trans (MonadIO (..)) -import Data.Map--- import Data.Monoid+import Data.Map (Map)  import Data.LinearProgram.Common import Data.LinearProgram.LPMonad.Internal@@ -31,7 +32,6 @@ import Data.LinearProgram.GLPK.Solver import Data.LinearProgram.GLPK.IO - {-# SPECIALIZE quickSolveLP :: (Ord v, Real c) =>  	LPT v c IO (ReturnCode, Maybe (Double, Map v Double)) #-} {-# SPECIALIZE quickSolveMIP :: (Ord v, Real c) => @@ -68,11 +68,23 @@ glpSolve' opts = get >>= liftIO . glpSolveAll opts  {-# SPECIALIZE writeLPToFile :: (Ord v, Show v, Real c) => FilePath -> LPT v c IO () #-}+-- | Writes the current linear program to the specified file in CPLEX LP format. +-- (This is a binding to GLPK, not a Haskell implementation of CPLEX.) writeLPToFile :: (Ord v, Show v, Real c, MonadState (LP v c) m, MonadIO m) => 	FilePath -> m () writeLPToFile file = get >>= liftIO . writeLP file  +{-# SPECIALIZE readLPFromFile :: (Ord v, Read v, Ord c, Fractional c, Module r c) => FilePath -> LPT v c IO () #-}+-- | Reads a linear program from the specified file in CPLEX LP format, overwriting+-- the current linear program.  Uses 'read' and 'realToFrac' to translate to the specified type.+-- (This is a binding to GLPK, not a Haskell implementation of CPLEX.)+readLPFromFile :: (Ord v, Read v, Ord c, Fractional c, Module r c, MonadState (LP v c) m, MonadIO m) =>+	FilePath -> m ()+readLPFromFile = put . mapVars read . mapVals realToFrac <=< liftIO . execLPT . readLPFromFile'+ {-# SPECIALIZE readLPFromFile :: FilePath -> LPT String Double IO () #-}-readLPFromFile :: (MonadState (LP String Double) m, MonadIO m) =>+-- | Reads a linear program from the specified file in CPLEX LP format, overwriting+-- the current linear program.  (This is a binding to GLPK, not a Haskell implementation of CPLEX.)+readLPFromFile' :: (MonadState (LP String Double) m, MonadIO m) => 	FilePath -> m ()-readLPFromFile file = put =<< liftIO (readLP file)+readLPFromFile' file = put =<< liftIO (readLP file)

@@ -11,19 +11,20 @@ 	execLPT, 	evalLPM, 	evalLPT,-	-- * Objective configuration+	-- * Constructing the LP+	-- ** Objective configuration 	setDirection, 	setObjective, 	addObjective, 	addWeightedObjective,-	-- * Two-function constraints+	-- ** Two-function constraints 	leq, 	equal, 	geq, 	leq', 	equal', 	geq',-	-- * One-function constraints+	-- ** One-function constraints 	leqTo, 	equalTo, 	geqTo,@@ -32,7 +33,7 @@ 	equalTo', 	geqTo', 	constrain',-	-- * Variable constraints+	-- ** Variable constraints 	varLeq, 	varEq, 	varGeq,@@ -121,7 +122,7 @@ 	Monad m => String -> LinFunc v c -> c -> LPT v c m () #-} {-# SPECIALIZE leqTo' :: String -> LinFunc v c -> c -> LPM v c (), 	Monad m => String -> LinFunc v c -> c -> LPT v c m () #-}--- | Sets a labelled constraint on a linear function in the variables.+-- | Sets a labeled constraint on a linear function in the variables. equalTo', leqTo', geqTo' :: MonadState (LP v c) m => String -> LinFunc v c -> c -> m () equalTo' lab f v = constrain' lab f (Equ v) leqTo' lab f v = constrain' lab f (UBound v)@@ -134,7 +135,8 @@ {-# SPECIALIZE varGeq :: (Ord v, Ord c) => v -> c -> LPM v c (), 	(Ord v, Ord c, Monad m) => v -> c -> LPT v c m () #-} -- | Sets a constraint on the value of a variable.  If you constrain a variable more than once,--- the constraints will be combined.+-- the constraints will be combined.  If the constraints are mutually contradictory,+-- an error will be generated.  This is more efficient than adding an equivalent function constraint. varEq, varLeq, varGeq :: (Ord v, Ord c, MonadState (LP v c) m) => v -> c -> m () varEq v c = setVarBounds v (Equ c) varLeq v c = setVarBounds v (UBound c)@@ -143,7 +145,8 @@ {-# SPECIALIZE varBds :: (Ord v, Ord c) => v -> c -> c -> LPM v c (), 	(Ord v, Ord c, Monad m) => v -> c -> c -> LPT v c m () #-} -- | Bounds the value of a variable on both sides.  If you constrain a variable more than once,--- the constraints will be combined.+-- the constraints will be combined.  If the constraints are mutually contradictory,+-- an error will be generated.  This is more efficient than adding an equivalent function constraint. varBds :: (Ord v, Ord c, MonadState (LP v c) m) => v -> c -> c -> m () varBds v l u = setVarBounds v (Bound l u) @@ -188,6 +191,8 @@ 	(Ord v, Ord c, Monad m) => v -> Bounds c -> LPT v c m () #-} -- | The most general way to set constraints on a variable. -- If you constrain a variable more than once, the constraints will be combined.+-- If you combine mutually contradictory constraints, an error will be generated.+-- This is more efficient than creating an equivalent function constraint. setVarBounds :: (Ord v, Ord c, MonadState (LP v c) m) => v -> Bounds c -> m () setVarBounds var bds = modify addBds where 	addBds lp@LP{..} = lp{varBounds = insertWith mappend var bds varBounds}

@@ -2,16 +2,14 @@  module Data.LinearProgram.LinFunc (LinFunc, Module(..), var, varSum, (*&), vsum, combination, linCombination) where -import Control.Monad+import Control.Applicative  import qualified Data.Map as M import qualified Data.IntMap as IM import Data.Ratio import Data.Array.Base import Data.Array.IArray--- import Data.Array.Unboxed --- import Data.LinFunc.TH import Data.LinearProgram.LinFunc.Class  -- | @'LinFunc' v c@ is a linear combination of variables of type @v@ with coefficients@@ -52,8 +50,8 @@ instance Module r m => Module r (a -> m) where 	(*^) = fmap . (*^) 	zero = const zero-	(^+^) = liftM2 (^+^)-	(^-^) = liftM2 (^-^)+	(^+^) = liftA2 (^+^)+	(^-^) = liftA2 (^-^) 	neg = fmap neg  instance (Ord k, Module r m) => Module r (M.Map k m) where

@@ -1,24 +1,136 @@-{-# LANGUAGE RecordWildCards #-}-module Data.LinearProgram.Spec where+{-# LANGUAGE TupleSections, RecordWildCards, DeriveFunctor #-}+module Data.LinearProgram.Spec (Constraint(..), VarTypes, ObjectiveFunc, VarBounds, LP(..),+	mapVars, mapVals) where --- import Control.DeepSeq--- import Data.Bounds+import Control.Applicative ((<$>))+import Control.Monad++import Data.Char (isSpace)+import Data.Monoid+import Data.Map hiding (map)++import Text.ParserCombinators.ReadP+ import Data.LinearProgram.LinFunc import Data.LinearProgram.Types-import Data.Map  data Constraint v c = Constr (Maybe String) 			(LinFunc v c)-			(Bounds c) deriving (Read, Show)+			(Bounds c) deriving (Functor) type VarTypes v = Map v VarKind type ObjectiveFunc = LinFunc type VarBounds v c = Map v (Bounds c) +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, Functor)++showBds :: Show c => String -> Bounds c -> String+showBds expr bds = case bds of+	Free	-> expr ++ " free"+	Equ x	-> expr ++ " = " ++ show x+	LBound x -> expr ++ " >= " ++ show x+	UBound x -> expr ++ " <= " ++ show x+	Bound l u -> show l ++ " <= " ++ expr ++ " <= " ++ show u++showFunc :: (Show v, Num c, Ord c) => LinFunc v c -> String+showFunc func = case assocs func of+	[]	-> "0"+	((v,c):vcs) ->+		show c ++ " " ++ map replaceSpace (show v) ++ +			concatMap showTerm vcs+	where	showTerm (v, c) = case compare c 0 of+			EQ	-> ""+			GT	-> " + " ++ show c ++ " " ++ show v+			LT	-> " - " ++ show (negate c) ++ " " ++ show v+		+replaceSpace :: Char -> Char+replaceSpace c+	| isSpace c	= '_'+	| otherwise	= c++instance (Show v, Num c, Ord c) => Show (Constraint v c) where+	show (Constr lab func bds) = maybe "" (++ ": ") lab +++		showBds (showFunc func) bds++instance (Read v, Ord v, Read c, Ord c, Num c) => Read (Constraint v c) where+	readsPrec _= readP_to_S $ liftM toConstr (lab <++ nolab) where+		toConstr (l, f, bds) = Constr l (fromList f) bds+		lab = do	skipSpaces+				label <- manyTill get (skipSpaces >> char ':')+				(_, f, bds) <- nolab+				return (Just label, f, bds)+		nolab = liftM (\ (f, bds) -> (Nothing, f, bds)) $ readBds readConst readFunc+		readFunc = (do	c <- readCoef readConst+				v <- readVar+				liftM ((v, c):) readFunc) <++ return []+		readConst = readS_to_P reads+		readVar = readS_to_P reads++readCoef :: Num c => ReadP c -> ReadP c+readCoef readC = between skipSpaces skipSpaces $ +	(do	char '+'+		skipSpaces+		readC') <+++	(do	char '-'+		skipSpaces+		negate <$> readC') <++ readC'+	where	readC' = readC <++ return 1++optMaybe :: ReadP a -> ReadP (Maybe a)+optMaybe p = fmap Just p <++ return Nothing++readBds :: Ord c => ReadP c -> ReadP a -> ReadP (a, Bounds c)+readBds cst expr = do+	left <- optMaybe (do	lb <- cst+				skipSpaces+				rel <- readRelation+				return (lb, rel))+	skipSpaces+	f <- expr+	skipSpaces+	right <- optMaybe (do	rel <- readRelation+				skipSpaces+				ub <- cst+				return (ub, revOrd rel))+	return (f, getBd left `mappend` getBd right)+	where	revOrd :: Ordering -> Ordering+		revOrd GT = LT+		revOrd LT = GT+		revOrd EQ = EQ+		getBd :: Maybe (c, Ordering) -> Bounds c+		getBd Nothing = Free+		getBd (Just (x, cmp)) = case cmp of+			EQ	-> Equ x+			GT	-> LBound x+			LT	-> UBound x+		readRelation = choice [char '<' >> optional (char '=') >> return LT,+			char '=' >> return EQ,+			char '>' >> optional (char '=') >> return GT]++-- | Applies the specified function to the variables in the linear program.+-- If multiple variables in the original program are mapped to the same variable in the new program,+-- in general, we set those variables to all be equal, as follows.+-- * In linear functions, including the objective function and the constraints,+-- 	coefficients will be added together.  For instance, if @v1,v2@ are mapped to the same+-- 	variable @v'@, then a linear function of the form @c1 *& v1 ^+^ c2 *& v2@ will be mapped to+-- 	@(c1 ^+^ c2) *& v'@.+-- * In variable bounds, bounds will be combined.  An error will be thrown if the bounds+-- 	are mutually contradictory.+-- * In variable kinds, the most restrictive kind will be retained.+mapVars :: (Ord v', Ord c, Module r c) => (v -> v') -> LP v c -> LP v' c+mapVars f LP{..} =  +	LP{objective = mapKeysWith (^+^) f objective, +		constraints = [Constr lab (mapKeysWith (^+^) f func) bd | Constr lab func bd <- constraints],+		varBounds = mapKeysWith mappend f varBounds,+		varTypes = mapKeysWith mappend f varTypes, ..}++-- | Applies the specified function to the constants in the linear program.  This is only safe+-- for a monotonic function.+mapVals :: (Ord c', Module r c') => (c -> c') -> LP v c -> LP v c'+mapVals = fmap+ -- 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`

@@ -1,4 +1,5 @@-module Data.LinearProgram.Types where+{-# LANGUAGE DeriveFunctor #-}+module Data.LinearProgram.Types (VarKind(..), Direction(..), Bounds(..)) where  -- import Control.DeepSeq @@ -17,7 +18,7 @@ -- instance NFData Direction  data Bounds a =-	Free | LBound a | UBound a | Equ a | Bound a a deriving (Eq, Show, Read)+	Free | LBound a | UBound a | Equ a | Bound a a deriving (Eq, Show, Read, Functor)  -- instance NFData (Bounds a) @@ -26,14 +27,22 @@ 	mempty = Free 	Free `mappend` bd = bd 	bd `mappend` Free = bd-	Equ a `mappend` _ = Equ a-	_ `mappend` Equ a = Equ a+	Equ a `mappend` Equ b+		| a == b	= Equ a+		| otherwise	= infeasible 	LBound a `mappend` LBound b = LBound (max a b)-	LBound l `mappend` UBound u = Bound l u-	UBound u `mappend` LBound l = Bound l u-	LBound a `mappend` Bound l u = Bound (max a l) u-	Bound l u `mappend` LBound a = Bound (max a l) u+	LBound l `mappend` UBound u = bound l u+	UBound u `mappend` LBound l = bound l u+	LBound a `mappend` Bound l u = bound (max a l) u+	Bound l u `mappend` LBound a = bound (max a l) u 	UBound a `mappend` UBound b = UBound (min a b)-	UBound a `mappend` Bound l u = Bound l (min a u)-	Bound l u `mappend` UBound a = Bound l (min a u)-	Bound l u `mappend` Bound l' u' = Bound (max l l') (min u u')+	UBound a `mappend` Bound l u = bound l (min a u)+	Bound l u `mappend` UBound a = bound l (min a u)+	Bound l u `mappend` Bound l' u' = bound (max l l') (min u u')++infeasible :: Bounds a+infeasible = error "Mutually contradictory constraints found."++bound :: Ord a => a -> a -> Bounds a+bound l u	| l <= u	= Bound l u+		| otherwise	= infeasible

@@ -1,5 +1,5 @@ Name:           glpk-hs-Version:        0.0.4+Version:        0.1.0 Author:         Louis Wasserman License:        GPL License-file:   LICENSE