glpk-hs 0.3.4 → 0.3.5

raw patch · 8 files changed

+254/−253 lines, 8 filessetup-changednew-uploaderPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Control/Monad/LPMonad/Internal.hs +89/−91
• Control/Monad/LPMonad/Supply.hs +11/−11
• Data/LinearProgram/GLPK/Types.hs +19/−12
• Data/LinearProgram/Spec.hs +78/−92
• Data/LinearProgram/Types.hs +48/−39
• Setup.hs +2/−0
• Setup.lhs +0/−4
• glpk-hs.cabal +7/−4

@@ -1,55 +1,53 @@ {-# LANGUAGE BangPatterns, FlexibleContexts, RecordWildCards #-}  module Control.Monad.LPMonad.Internal (--- 	module Data.LinearProgram.Common,-	-- * Monad definitions-	LPM,-	LPT,-	runLPM,-	runLPT,-	execLPM,-	execLPT,-	evalLPM,-	evalLPT,-	-- * Constructing the LP-	-- ** Objective configuration-	setDirection,-	setObjective,-	addObjective,-	addWeightedObjective,-	-- ** Two-function constraints-	leq,-	equal,-	geq,-	leq',-	equal',-	geq',-	-- ** One-function constraints-	leqTo,-	equalTo,-	geqTo,-	constrain,-	leqTo',-	equalTo',-	geqTo',-	constrain',-	-- ** Variable constraints-	varLeq,-	varEq,-	varGeq,-	varBds,-	setVarBounds,-	setVarKind,--- 	newVariables,--- 	newVariables'-	) where+--         module Data.LinearProgram.Common,+        -- * Monad definitions+        LPM,+        LPT,+        runLPM,+        runLPT,+        execLPM,+        execLPT,+        evalLPM,+        evalLPT,+        -- * Constructing the LP+        -- ** Objective configuration+        setDirection,+        setObjective,+        addObjective,+        addWeightedObjective,+        -- ** Two-function constraints+        leq,+        equal,+        geq,+        leq',+        equal',+        geq',+        -- ** One-function constraints+        leqTo,+        equalTo,+        geqTo,+        constrain,+        leqTo',+        equalTo',+        geqTo',+        constrain',+        -- ** Variable constraints+        varLeq,+        varEq,+        varGeq,+        varBds,+        setVarBounds,+        setVarKind,+--         newVariables,+--         newVariables'+        ) where  import Control.Monad.State.Strict import Control.Monad.Identity  import Data.Map-import Data.Monoid-import Data.Functor  import Data.LinearProgram.Common @@ -88,11 +86,11 @@ setDirection dir = modify (\ lp -> lp{direction = dir})  {-# SPECIALIZE equal :: (Ord v, Group c) => LinFunc v c -> LinFunc v c -> LPM v c (),-	(Ord v, Group c, Monad m) => LinFunc v c -> LinFunc v c -> LPT v c m () #-}+        (Ord v, Group c, Monad m) => LinFunc v c -> LinFunc v c -> LPT v c m () #-} {-# SPECIALIZE leq :: (Ord v, Group c) => LinFunc v c -> LinFunc v c -> LPM v c (),-	(Ord v, Group c, Monad m) => LinFunc v c -> LinFunc v c -> LPT v c m () #-}+        (Ord v, Group c, Monad m) => LinFunc v c -> LinFunc v c -> LPT v c m () #-} {-# SPECIALIZE geq :: (Ord v, Group c) => LinFunc v c -> LinFunc v c -> LPM v c (),-	(Ord v, Group c, Monad m) => LinFunc v c -> LinFunc v c -> LPT v c m () #-}+        (Ord v, Group c, Monad m) => LinFunc v c -> LinFunc v c -> LPT v c m () #-} -- | Specifies the relationship between two functions in the variables.  So, for example, --  -- > equal (f ^+^ g) h@@ -104,11 +102,11 @@ geq = flip leq  {-# SPECIALIZE equal' :: (Ord v, Group c) => String -> LinFunc v c -> LinFunc v c -> LPM v c (),-	(Ord v, Group c, Monad m) => String -> LinFunc v c -> LinFunc v c -> LPT v c m () #-}+        (Ord v, Group c, Monad m) => String -> LinFunc v c -> LinFunc v c -> LPT v c m () #-} {-# SPECIALIZE geq' :: (Ord v, Group c) => String -> LinFunc v c -> LinFunc v c -> LPM v c (),-	(Ord v, Group c, Monad m) => String -> LinFunc v c -> LinFunc v c -> LPT v c m () #-}+        (Ord v, Group c, Monad m) => String -> LinFunc v c -> LinFunc v c -> LPT v c m () #-} {-# SPECIALIZE leq' :: (Ord v, Group c) => String -> LinFunc v c -> LinFunc v c -> LPM v c (),-	(Ord v, Group c, Monad m) => String -> LinFunc v c -> LinFunc v c -> LPT v c m () #-}+        (Ord v, Group c, Monad m) => String -> LinFunc v c -> LinFunc v c -> LPT v c m () #-} -- | Specifies the relationship between two functions in the variables, with a label on the constraint. equal', leq', geq' :: (Ord v, Group c, MonadState (LP v c) m) => String -> LinFunc v c -> LinFunc v c -> m () equal' lab f g = equalTo' lab (f ^-^ g) zero@@ -125,11 +123,11 @@ geqTo f v = constrain f (LBound v)  {-# SPECIALIZE equalTo' :: String -> LinFunc v c -> c -> LPM v c (),-	Monad m => String -> LinFunc v c -> c -> LPT v c m () #-}+        Monad m => String -> LinFunc v c -> c -> LPT v c m () #-} {-# SPECIALIZE geqTo' :: String -> LinFunc v c -> c -> LPM v c (),-	Monad m => String -> LinFunc v c -> c -> LPT v c m () #-}+        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 () #-}+        Monad m => String -> LinFunc v c -> c -> LPT v c m () #-} -- | 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)@@ -137,45 +135,45 @@ geqTo' lab f v = constrain' lab f (LBound v)  -- {-# SPECIALIZE newVariables :: (Ord v, Enum v) => Int -> LPM v c [v],--- 	(Ord v, Enum v, Monad m) => Int -> LPT v c m [v] #-}+--         (Ord v, Enum v, Monad m) => Int -> LPT v c m [v] #-} -- -- | Returns a list of @k@ unused variables.  If the program is currently empty, -- -- starts at @'toEnum' 0@.  Otherwise, if @v@ is the biggest variable currently in use -- -- (by the 'Ord' ordering), then this returns @take k (tail [v..])@, which uses the 'Enum' -- -- implementation.  Note that if the 'Enum' instance doesn't play well with 'Ord', -- -- bad things can happen. -- newVariables :: (MonadState (LP v c) m, Ord v, Enum v) => Int -> m [v]--- newVariables !k = do	LP{..} <- get--- 			let allVars0 = () <$ objective `union`--- 				unions [() <$ f | Constr _ f _ <- constraints] `union`--- 				(() <$ varBounds) `union` (() <$ varTypes)--- 			case minViewWithKey allVars0 of--- 				Nothing	-> return $ take k [toEnum 0..]--- 				Just ((start, _), _)--- 					-> return $ take k $ tail [start..]--- 					+-- newVariables !k = do        LP{..} <- get+--                         let allVars0 = () <$ objective `union`+--                                 unions [() <$ f | Constr _ f _ <- constraints] `union`+--                                 (() <$ varBounds) `union` (() <$ varTypes)+--                         case minViewWithKey allVars0 of+--                                 Nothing        -> return $ take k [toEnum 0..]+--                                 Just ((start, _), _)+--                                         -> return $ take k $ tail [start..]+--                                          -- {-# SPECIALIZE newVariables' :: (Ord v, Enum v) => LPM v c [v],--- 	(Ord v, Enum v, Monad m) => LPT v c m [v] #-}+--         (Ord v, Enum v, Monad m) => LPT v c m [v] #-} -- -- | Returns an infinite list of unused variables.  If the program is currently empty, -- -- starts at @'toEnum' 0@.  Otherwise, if @v@ is the biggest variable currently in use -- -- (by the 'Ord' ordering), then this returns @tail [v..]@, which uses the 'Enum' -- -- implementation.  Note that if the 'Enum' instance doesn't play well with 'Ord', -- -- bad things can happen. -- newVariables' :: (MonadState (LP v c) m, Ord v, Enum v) => m [v]--- newVariables' = do	LP{..} <- get--- 			let allVars0 = () <$ objective `union`--- 				unions [() <$ f | Constr _ f _ <- constraints] `union`--- 				(() <$ varBounds) `union` (() <$ varTypes)--- 			case minViewWithKey allVars0 of--- 				Nothing	-> return [toEnum 0..]--- 				Just ((start, _), _)--- 					-> return $ tail [start..]+-- newVariables' = do        LP{..} <- get+--                         let allVars0 = () <$ objective `union`+--                                 unions [() <$ f | Constr _ f _ <- constraints] `union`+--                                 (() <$ varBounds) `union` (() <$ varTypes)+--                         case minViewWithKey allVars0 of+--                                 Nothing        -> return [toEnum 0..]+--                                 Just ((start, _), _)+--                                         -> return $ tail [start..]  {-# SPECIALIZE varEq :: (Ord v, Ord c) => v -> c -> LPM v c (),-	(Ord v, Ord c, Monad m) => v -> c -> LPT v c m () #-}+        (Ord v, Ord c, Monad m) => v -> c -> LPT v c m () #-} {-# SPECIALIZE varLeq :: (Ord v, Ord c) => v -> c -> LPM v c (),-	(Ord v, Ord c, Monad m) => v -> c -> LPT v c m () #-}+        (Ord v, Ord c, Monad m) => v -> c -> LPT v c m () #-} {-# SPECIALIZE varGeq :: (Ord v, Ord c) => v -> c -> LPM v c (),-	(Ord v, Ord c, Monad m) => v -> c -> LPT v c m () #-}+        (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.  If the constraints are mutually contradictory, -- an error will be generated.  This is more efficient than adding an equivalent function constraint.@@ -185,7 +183,7 @@ varGeq v c = setVarBounds v (LBound c)  {-# 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 () #-}+        (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.  If the constraints are mutually contradictory, -- an error will be generated.  This is more efficient than adding an equivalent function constraint.@@ -193,55 +191,55 @@ varBds v l u = setVarBounds v (Bound l u)  {-# SPECIALIZE constrain :: LinFunc v c -> Bounds c -> LPM v c (),-	Monad m => LinFunc v c -> Bounds c -> LPT v c m () #-}+        Monad m => LinFunc v c -> Bounds c -> LPT v c m () #-} -- | The most general form of an unlabeled constraint. constrain :: MonadState (LP v c) m => LinFunc v c -> Bounds c -> m () constrain f bds = modify addConstr where-	addConstr lp@LP{..}-		= lp{constraints = Constr Nothing f bds:constraints}+        addConstr lp@LP{..}+                = lp{constraints = Constr Nothing f bds:constraints}  {-# SPECIALIZE constrain' :: String -> LinFunc v c -> Bounds c -> LPM v c (),-	Monad m => String -> LinFunc v c -> Bounds c -> LPT v c m () #-}+        Monad m => String -> LinFunc v c -> Bounds c -> LPT v c m () #-} -- | The most general form of a labeled constraint. constrain' :: MonadState (LP v c) m => String -> LinFunc v c -> Bounds c -> m () constrain' lab f bds = modify addConstr where-	addConstr lp@LP{..}-		= lp{constraints = Constr (Just lab) f bds:constraints}+        addConstr lp@LP{..}+                = lp{constraints = Constr (Just lab) f bds:constraints}  {-# SPECIALIZE setObjective :: LinFunc v c -> LPM v c (),-	Monad m => LinFunc v c -> LPT v c m () #-}+        Monad m => LinFunc v c -> LPT v c m () #-} -- | Sets the objective function, overwriting the previous objective function. setObjective :: MonadState (LP v c) m => LinFunc v c -> m () setObjective obj = modify setObj where-	setObj lp = lp{objective = obj}+        setObj lp = lp{objective = obj}  {-# SPECIALIZE addObjective :: (Ord v, Group c) => LinFunc v c -> LPM v c (),-	(Ord v, Group c, Monad m) => LinFunc v c -> LPT v c m () #-}+        (Ord v, Group c, Monad m) => LinFunc v c -> LPT v c m () #-} -- | Adds this function to the objective function. addObjective :: (Ord v, Group c, MonadState (LP v c) m) => LinFunc v c -> m () addObjective obj = modify addObj where-	addObj lp@LP{..} = lp {objective = obj ^+^ objective}+        addObj lp@LP{..} = lp {objective = obj ^+^ objective}  {-# SPECIALIZE addWeightedObjective :: (Ord v, Module r c) => r -> LinFunc v c -> LPM v c (),-	(Ord v, Module r c, Monad m) => r -> LinFunc v c -> LPT v c m () #-}+        (Ord v, Module r c, Monad m) => r -> LinFunc v c -> LPT v c m () #-} -- | Adds this function to the objective function, with the specified weight.  Equivalent to -- @'addObjective' (wt '*^' obj)@. addWeightedObjective :: (Ord v, Module r c, MonadState (LP v c) m) => r -> LinFunc v c -> m () addWeightedObjective wt obj = addObjective (wt *^ obj)  {-# SPECIALIZE setVarBounds :: (Ord v, Ord c) => v -> Bounds c -> LPM v c (),-	(Ord v, Ord c, Monad m) => v -> Bounds c -> LPT v c m () #-}+        (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}+        addBds lp@LP{..} = lp{varBounds = insertWith mappend var bds varBounds}  {-# SPECIALIZE setVarKind :: Ord v => v -> VarKind -> LPM v c (),-	(Ord v, Monad m) => v -> VarKind -> LPT v c m () #-}+        (Ord v, Monad m) => v -> VarKind -> LPT v c m () #-} -- | Sets the kind ('type') of a variable.  See 'VarKind'. setVarKind :: (Ord v, MonadState (LP v c) m) => v -> VarKind -> m () setVarKind v k = modify setK where-	setK lp@LP{..} = lp{varTypes = insertWith mappend v k varTypes}+        setK lp@LP{..} = lp{varTypes = insertWith mappend v k varTypes}

@@ -8,7 +8,7 @@ import Control.Monad.RWS.Class import Control.Monad.Cont.Class import Control.Monad.Error.Class-+import Control.Applicative import Control.Monad.LPMonad.Supply.Class  -- | A type suitable for use as a linear program variable.@@ -21,24 +21,24 @@ runVSupply = runIdentity . runVSupplyT  -- | A monad transformer capable of supplying unique variables.-newtype VSupplyT m a = VSupplyT (StateT Var m a) deriving (Functor, Monad, MonadPlus, MonadTrans, MonadReader r, MonadWriter w, MonadCont,-	MonadIO, MonadFix, MonadError e)+newtype VSupplyT m a = VSupplyT (StateT Var m a) deriving (Functor, Applicative, Monad, Alternative, MonadPlus, MonadTrans, MonadReader r, MonadWriter w, MonadCont,+        MonadIO, MonadFix, MonadError e)  runVSupplyT :: Monad m => VSupplyT m a -> m a runVSupplyT (VSupplyT m) = evalStateT m (Var 0)  instance Show Var where-	show (Var x) = "x_" ++ show x+        show (Var x) = "x_" ++ show x  instance Read Var where-	readsPrec _ ('x':'_':xs) = [(Var x, s') | (x, s') <- reads xs]-	readsPrec _ _ = []+        readsPrec _ ('x':'_':xs) = [(Var x, s') | (x, s') <- reads xs]+        readsPrec _ _ = []  instance MonadState s m => MonadState s (VSupplyT m) where-	get = lift get-	put = lift . put+        get = lift get+        put = lift . put  instance Monad m => MonadSupply Var (VSupplyT m) where-	{-# SPECIALIZE instance MonadSupply Var VSupply #-}-	supplyNew = VSupplyT $ StateT $ \ v -> return (v, succ v)-	supplyN n = VSupplyT $ StateT $ \ (Var x) -> return (map Var [x..x+n-1], Var (x + n))+        {-# SPECIALIZE instance MonadSupply Var VSupply #-}+        supplyNew = VSupplyT $ StateT $ \ v -> return (v, succ v)+        supplyN n = VSupplyT $ StateT $ \ (Var x) -> return (map Var [x..x+n-1], Var (x + n))

@@ -3,6 +3,7 @@ module Data.LinearProgram.GLPK.Types where  import Control.Monad.Trans (MonadIO (..))+import Control.Monad (ap)  import Foreign.Ptr import Foreign.ForeignPtr@@ -13,10 +14,10 @@ data GlpProb  data ReturnCode = Success | InvalidBasis | SingularMatrix | IllConditionedMatrix | -	InvalidBounds | SolverFailed | ObjLowerLimReached | ObjUpperLimReached | -	IterLimReached | TimeLimReached | NoPrimalFeasible | NoDualFeasible | RootLPOptMissing |-	SearchTerminated | MipGapTolReached | NoPrimDualFeasSolution | NoConvergence |-	NumericalInstability | InvalidData | ResultOutOfRange deriving (Eq, Show, Enum)+        InvalidBounds | SolverFailed | ObjLowerLimReached | ObjUpperLimReached | +        IterLimReached | TimeLimReached | NoPrimalFeasible | NoDualFeasible | RootLPOptMissing |+        SearchTerminated | MipGapTolReached | NoPrimDualFeasSolution | NoConvergence |+        NumericalInstability | InvalidData | ResultOutOfRange deriving (Eq, Show, Enum)  gaveAnswer :: ReturnCode -> Bool gaveAnswer = flip elem [Success, IterLimReached, TimeLimReached, SearchTerminated, MipGapTolReached]@@ -24,18 +25,24 @@ newtype GLPK a = GLP {execGLPK :: Ptr GlpProb -> IO a}  runGLPK :: GLPK a -> IO a-runGLPK m = do	lp <- newForeignPtr glpDelProb =<< glpCreateProb-		withForeignPtr lp (execGLPK m)+runGLPK m = do  lp <- newForeignPtr glpDelProb =<< glpCreateProb+                withForeignPtr lp (execGLPK m)  instance Monad GLPK where-	{-# INLINE return #-}-	{-# INLINE (>>=) #-}-	return x = GLP $ \ _ -> return x-	m >>= k = GLP $ \ lp -> do	x <- execGLPK m lp-					execGLPK (k x) lp+        {-# INLINE return #-}+        {-# INLINE (>>=) #-}+        return x = GLP $ \ _ -> return x+        m >>= k = GLP $ \ lp -> do      x <- execGLPK m lp+                                        execGLPK (k x) lp+instance Functor GLPK where+  fmap f (GLP k) = GLP $ \p -> fmap f (k p) +instance Applicative GLPK where+  pure = return+  (<*>) = ap+ instance MonadIO GLPK where-	liftIO m = GLP (const m)+        liftIO m = GLP (const m)  data MsgLev = MsgOff | MsgErr | MsgOn | MsgAll deriving (Eq, Enum, Read, Show) data BranchingTechnique = FirstFrac | LastFrac | MostFrac | DrTom | HybridP deriving (Eq, Enum, Read, Show)

@@ -1,14 +1,11 @@ {-# LANGUAGE TupleSections, RecordWildCards, DeriveFunctor #-} module Data.LinearProgram.Spec (Constraint(..), VarTypes, ObjectiveFunc, VarBounds, LP(..),-	mapVars, mapVals, allVars) where+        mapVars, mapVals, allVars) where -import Control.Applicative ((<$>)) import Control.DeepSeq import Control.Monad  import Data.Char (isSpace)-import Data.Monoid-import Data.Functor import Data.Map hiding (map, foldl)  import Text.ParserCombinators.ReadP@@ -19,8 +16,8 @@ -- | Representation of a linear constraint on the variables, possibly labeled. -- The function may be bounded both above and below. data Constraint v c = Constr (Maybe String)-			(LinFunc v c)-			(Bounds c) deriving (Functor)+                        (LinFunc v c)+                        (Bounds c) deriving (Functor) -- | A mapping from variables to their types.  Variables not mentioned are assumed to be continuous, type VarTypes v = Map v VarKind -- | An objective function for a linear program.@@ -31,94 +28,94 @@ -- | The specification of a linear programming problem with variables in @v@ and coefficients/constants in @c@. --   Note: the 'Read' and 'Show' implementations do not correspond to any particular linear program specification format. 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)+                  varBounds :: VarBounds v c, varTypes :: VarTypes v} deriving (Read, Show, Functor)  allVars :: Ord v => LP v c -> Map v () allVars LP{..} = foldl union ((() <$ objective) `union` (() <$ varBounds) `union` (() <$ varTypes))-	[() <$ f | Constr _ f _ <- constraints]+        [() <$ f | Constr _ f _ <- constraints]  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+        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, Show 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-		+        []      -> "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+        | isSpace c     = '_'+        | otherwise     = c  instance (Show v, Num c, Ord c, Show c) => Show (Constraint v c) where-	show (Constr lab func bds) = maybe "" (++ ": ") lab ++-		showBds (showFunc func) bds+        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+        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+        (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]+        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]  {-# SPECIALIZE mapVars :: Ord v' => (v -> v') -> LP v Double -> LP v' Double #-} -- | Applies the specified function to the variables in the linear program.@@ -126,20 +123,20 @@ -- 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'@.+--      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.+--      are mutually contradictory. --  -- * In variable kinds, the most restrictive kind will be retained. mapVars :: (Ord v', Ord c, Group 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, ..}+        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.@@ -147,19 +144,8 @@ mapVals = fmap  instance (NFData v, NFData c) => NFData (Constraint v c) where-	rnf (Constr lab f b) = lab `deepseq` f `deepseq` rnf b+        rnf (Constr lab f b) = lab `deepseq` f `deepseq` rnf b  instance (NFData v, NFData c) => NFData (LP v c) where-	rnf LP{..} = direction `deepseq` objective `deepseq` constraints `deepseq`-		varBounds `deepseq` rnf varTypes--instance NFData VarKind-instance NFData Direction-instance NFData c => NFData (Bounds c) where-	rnf Free = ()-	rnf (Equ c) = rnf c-	rnf (LBound c) = rnf c-	rnf (UBound c) = rnf c-	rnf (Bound l u) = l `deepseq` rnf u--- instance (NFData k, NFData a) => NFData (Map k a) where--- 	rnf m = foldrWithKey (\ k a -> deepseq k . deepseq a) () m+        rnf LP{..} = direction `deepseq` objective `deepseq` constraints `deepseq`+                varBounds `deepseq` rnf varTypes

@@ -1,63 +1,72 @@-{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFunctor, DeriveGeneric #-} module Data.LinearProgram.Types (VarKind(..), Direction(..), Bounds(..)) where  import Control.DeepSeq- import Data.Monoid+import GHC.Generics -data VarKind = ContVar | IntVar | BinVar deriving (Eq, Ord, Enum, Show, Read)+data VarKind = ContVar | IntVar | BinVar deriving (Eq, Ord, Enum, Show, Read, Generic)  -- instance NFData VarKind  instance Monoid VarKind where-	mempty = ContVar-	mappend = max+        mempty = ContVar+        mappend = max -data Direction = Min | Max deriving (Eq, Ord, Enum, Show, Read)+data Direction = Min | Max deriving (Eq, Ord, Enum, Show, Read, Generic)  -- instance NFData Direction  data Bounds a =-	Free | LBound !a | UBound !a | Equ !a | Bound !a !a deriving (Eq, Show, Read, Functor)+        Free | LBound !a | UBound !a | Equ !a | Bound !a !a deriving (Eq, Show, Read, Functor) +instance NFData VarKind+instance NFData Direction+instance NFData c => NFData (Bounds c) where+        rnf Free = ()+        rnf (Equ c) = rnf c+        rnf (LBound c) = rnf c+        rnf (UBound c) = rnf c+        rnf (Bound l u) = l `deepseq` rnf u+ -- instance NFData (Bounds a)  -- Bounds form a monoid under intersection. instance Ord a => Monoid (Bounds a) where-	mempty = Free-	Free `mappend` bd = bd-	bd `mappend` Free = bd-	Equ a `mappend` Equ b-		| a == b	= Equ a-	Equ a `mappend` UBound b-		| a <= b	= Equ a-	Equ a `mappend` LBound b-		| a >= b	= Equ a-	Equ a `mappend` Bound l u-		| a >= l && a <= u-				= Equ a-	Equ _ `mappend` _ = infeasible-	UBound b `mappend` Equ a-		| a <= b	= Equ a-	LBound b `mappend` Equ a-		| a >= b	= Equ a-	Bound l u `mappend` Equ a-		| a >= l && a <= u-				= Equ a-	_ `mappend` Equ _ = 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-	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')+        mempty = Free+        Free `mappend` bd = bd+        bd `mappend` Free = bd+        Equ a `mappend` Equ b+                | a == b        = Equ a+        Equ a `mappend` UBound b+                | a <= b        = Equ a+        Equ a `mappend` LBound b+                | a >= b        = Equ a+        Equ a `mappend` Bound l u+                | a >= l && a <= u+                                = Equ a+        Equ _ `mappend` _ = infeasible+        UBound b `mappend` Equ a+                | a <= b        = Equ a+        LBound b `mappend` Equ a+                | a >= b        = Equ a+        Bound l u `mappend` Equ a+                | a >= l && a <= u+                                = Equ a+        _ `mappend` Equ _ = 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+        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')  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+bound l u       | l <= u        = Bound l u+                | otherwise     = infeasible

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -1,4 +0,0 @@-#! /usr/bin/env runhaskell--> import Distribution.Simple-> main = defaultMain

@@ -1,9 +1,9 @@ Name:           glpk-hs-Version:        0.3.4+Version:        0.3.5 Author:         Louis Wasserman License:        BSD3 License-file:   LICENSE-Maintainer:     Louis Wasserman <wasserman.louis@gmail.com>+Maintainer:     Jean-Philippe Bernardy <jeanphilippe.bernardy@gmail.com> Stability:      experimental Synopsis:       Comprehensive GLPK linear programming bindings Description:@@ -17,11 +17,14 @@     of options available.  Category:      Math-cabal-version: >= 1.4-cabal-version:  >= 1.2+cabal-version: >= 1.6 build-type:     Simple  extra-source-files: examples/example1.hs++source-repository head+  type: git+  location: https://github.com/jyp/glpk-hs  library   Build-Depends:    base >= 4 && < 5, array, containers, mtl, deepseq