diff --git a/cplex-hs.cabal b/cplex-hs.cabal --- a/cplex-hs.cabal +++ b/cplex-hs.cabal @@ -1,5 +1,5 @@ name: cplex-hs -version: 0.4.0.4 +version: 0.5.0.0 synopsis: high-level CPLEX interface -- description: License: BSD3 @@ -19,9 +19,10 @@ Library default-language: Haskell2010 exposed-modules: CPLEX.Core, - CPLEX.Param - CPLEX.Bindings - Data.LP + CPLEX.Param, + CPLEX.Bindings, + Data.LP, + Data.Internal, Data.LP.Backend.Cplex -- other-modules: Build-depends: base < 5.0 diff --git a/src/Data/Internal.hs b/src/Data/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Internal.hs @@ -0,0 +1,92 @@ +-- {-# LANGUAGE NoImplicitPrelude #-} +-- import qualified Prelude as P + +module Data.Internal ( + Map(..), + Variable(..), + Bound(..), + Bounds(..), + Constraints(..), + Optimization(..), + Type(..), + MIPSolution(..), + LPSolution(..), + ) + where + +import Data.List (intercalate) +import qualified Data.Vector as V +import qualified Data.HashMap.Strict as M +import Data.Hashable +import Data.Monoid +import qualified Data.HashSet as S + +type Map k v = M.HashMap k v + +data Variable a = Double :# a + +data Bound x = x :< Double + | x :> Double + | x := Double + deriving Show + +newtype Constraints a = Constraints [ Bound [Variable a] ] + +simplifyVars :: (Eq a, Hashable a) => [Variable a] -> [Variable a] +simplifyVars vars = map (\(v,c) -> c :# v) $ M.toList $ + foldr (\(c :# v) m -> M.insertWith (+) v c m) M.empty vars +simplifyBounds (xs :< b) = (simplifyVars xs) :< b +simplifyBounds (xs := b) = (simplifyVars xs) := b +simplifyBounds (xs :> b) = (simplifyVars xs) :> b + +simplifyConstraints :: (Eq a, Hashable a) => Constraints a -> Constraints a +simplifyConstraints (Constraints cs) = Constraints $ map simplifyBounds cs + +removeEmptyConstraints :: (Eq a, Hashable a) => Constraints a -> Constraints a +removeEmptyConstraints (Constraints cs) = Constraints $ filter isNonEmpty cs + where + isNonEmpty ([] :< b) = False + isNonEmpty ([] := b) = False + isNonEmpty ([] :> b) = False + isNonEmpty _ = True + +data Optimization a = Maximize [Variable a] + | Minimize [Variable a] + +data Type = TContinuous | TInteger | TBinary + +instance (Show a) => Show (Variable a) where + show (d :# v) + | d == (-1) = "-" ++ (show v) + | d == 1 = (show v) + | otherwise = (show d) ++ "x" ++ (show v) + +instance Show a => Show (Optimization a) where + show (Minimize xs) = "Minimize\n\t" ++ (intercalate "+" $ map show xs) + show (Maximize xs) = "Maximize\n\t" ++ (intercalate "+" $ map show xs) + +showVars xs = intercalate " + " $ map show $ zipWith (:#) xs [0..] + +instance (Show a) => Show (Constraints a) where + show (Constraints bounds) = "\nSubject to\n" ++ (unlines $ map (\a -> "\t" ++ a) $ + map getVarSigns bounds) + +printVars xs = intercalate " + " $ map show xs +getVarSigns (x :< v) = (printVars x) ++ " <= " ++ (show v) +getVarSigns (x :> v) = (printVars x) ++ " >= " ++ (show v) +getVarSigns (x := v) = (printVars x) ++ " == " ++ (show v) + +instance Show Type where + show TContinuous = "Continous" + show TInteger = "Integer" + show TBinary = "Binary" + + +type Bounds = [Bound Int] + + +data MIPSolution a = MIPSolution { mipOptimalSol :: Bool, mipObjVal :: Double, mipVars :: Map a Double } deriving (Show) + +data LPSolution a = LPSolution { lpOptimalSol :: Bool, lpObjVal :: Double, lpVars :: Map a Double, lpDualVars :: V.Vector Double, lpBasisVars :: Maybe (S.HashSet a)} deriving (Show) + + diff --git a/src/Data/LP.hs b/src/Data/LP.hs --- a/src/Data/LP.hs +++ b/src/Data/LP.hs @@ -1,104 +1,134 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} -module Data.LP(Variable(..) - ,Bound(..) +module Data.LP( -- Variable(..) + Constraint(..) ,Constraints(..) + ,Algebra(..) ,Optimization(..) - ,(<+>) - ,Bounds(..) - ,Type(..) + ,sum + ,forall + ,I.Type(..) ,MixedIntegerProblem(..) ,LinearProblem(..) - ,MIPSolution(..) - ,LPSolution(..) - ,simplifyConstraints - ,removeEmptyConstraints + ,I.MIPSolution(..) + ,I.LPSolution(..) + ,simplify + ,buildConstraints + ,buildObjective ) where +import Data.Monoid import Data.List (intercalate) -import qualified Data.Vector as V +import qualified Prelude as P import qualified Data.HashMap.Strict as M +import Prelude hiding ((*), sum) +import qualified Data.Internal as I import Data.Hashable -import Data.Monoid -import qualified Data.HashSet as S -type Map k v = M.HashMap k v +data Algebra x = Constant Double + | Double :* x + | LinearCombination [Algebra x] -data Variable a = Double :# a +infixr 1 :< +data Constraint x = Algebra x :< Algebra x + | Algebra x := Algebra x + | Algebra x :> Algebra x + deriving (Show) -data Bound x = x :< Double - | x :> Double - | x := Double - deriving Show +data Constraints x = Constraints [Constraint x] -newtype Constraints a = Constraints [ Bound [Variable a] ] +instance Monoid (Constraints a) where + (Constraints xs) `mappend` (Constraints ys) = Constraints $ xs ++ ys + mempty = Constraints [] -simplifyVars :: (Eq a, Hashable a) => [Variable a] -> [Variable a] -simplifyVars vars = map (\(v,c) -> c :# v) $ M.toList $ - foldr (\(c :# v) m -> M.insertWith (+) v c m) M.empty vars -simplifyBounds (xs :< b) = (simplifyVars xs) :< b -simplifyBounds (xs := b) = (simplifyVars xs) := b -simplifyBounds (xs :> b) = (simplifyVars xs) :> b +instance (Eq x, Hashable x, Show x) => Show (Algebra x) where + show (Constant d) = show d + show (d :* x) = show d <> show x + show l = intercalate " + " $ map show xs + where LinearCombination xs = simplify l -simplifyConstraints :: (Eq a, Hashable a) => Constraints a -> Constraints a -simplifyConstraints (Constraints cs) = Constraints $ map simplifyBounds cs -removeEmptyConstraints :: (Eq a, Hashable a) => Constraints a -> Constraints a -removeEmptyConstraints (Constraints cs) = Constraints $ filter isNonEmpty cs - where - isNonEmpty ([] :< b) = False - isNonEmpty ([] := b) = False - isNonEmpty ([] :> b) = False - isNonEmpty _ = True - -instance Monoid a => Monoid (Constraints a) where - (Constraints xs) `mappend` (Constraints ys) = Constraints $ xs <> ys - mempty = Constraints [] - -Constraints v1 <+> Constraints v2 = Constraints $ v1 ++ v2 +(*) :: Double -> x -> Algebra x +a * b = a :* b -data Optimization a = Maximize [Variable a] - | Minimize [Variable a] +instance Num (Algebra x) where + fromInteger i = Constant $ fromIntegral i + (LinearCombination xs) + (LinearCombination ys) = LinearCombination $ xs ++ ys + a1 + (LinearCombination xs) = LinearCombination (a1:xs) + (LinearCombination xs) + a2 = LinearCombination (xs++[a2]) + (Constant a) + (Constant b) = Constant (a+b) + a + b = LinearCombination [a,b] + negate (Constant d) = Constant $ negate d + negate (d :* v) = (negate d) :* v + negate (LinearCombination xs) = LinearCombination $ map negate xs -data Type = TContinuous | TInteger | TBinary +data Optimization x = Maximize (Algebra x) + | Minimize (Algebra x) + deriving (Show) -instance (Show a) => Show (Variable a) where - show (d :# v) - | d == (-1) = "-" ++ (show v) - | d == 1 = (show v) - | otherwise = (show d) ++ "x" ++ (show v) +sum :: [a] -> (a -> Algebra x) -> Algebra x +sum xs f = P.sum $ map f xs -instance Show a => Show (Optimization a) where - show (Minimize xs) = "Minimize\n\t" ++ (intercalate "+" $ map show xs) - show (Maximize xs) = "Maximize\n\t" ++ (intercalate "+" $ map show xs) +forall = flip map -showVars xs = intercalate " + " $ map show $ zipWith (:#) xs [0..] +simplify :: (Eq a, Hashable a) => Algebra a -> Algebra a +simplify a@(Constant d) = a +simplify a@(0 :* x) = Constant 0 +simplify a@(d :* x) = a +simplify i@(LinearCombination xs) = const + (LinearCombination $ map (\(v,c) -> c :* v) $ M.toList $ + foldr (\(v,c) m -> M.insertWith (+) v c m) M.empty $ getVars i) + where const = Constant $ getConstant i -instance (Show a) => Show (Constraints a) where - show (Constraints bounds) = "\nSubject to\n" ++ (unlines $ map (\a -> "\t" ++ a) $ - map getVarSigns bounds) +getConstant (Constant c) = c +getConstant (d :* v) = 0 +getConstant (LinearCombination xs) = P.sum $ map getConstant xs -printVars xs = intercalate " + " $ map show xs -getVarSigns (x :< v) = (printVars x) ++ " <= " ++ (show v) -getVarSigns (x :> v) = (printVars x) ++ " >= " ++ (show v) -getVarSigns (x := v) = (printVars x) ++ " == " ++ (show v) +getVars :: Algebra x -> [(x,Double)] +getVars (d :* v) = [(v,d)] +getVars (LinearCombination xs) = map aux $ filter (\u -> case u of + d :* v -> True + _ -> False) xs + where aux (d :* v) = (v,d) -instance Show Type where - show TContinuous = "Continous" - show TInteger = "Integer" - show TBinary = "Binary" +buildConstraint :: forall x. (Hashable x, Eq x) => Constraint x -> I.Bound [I.Variable x] +buildConstraint constr = case constr of + (_ :< _ ) -> lhs I.:< rhs + (_ := _ ) -> lhs I.:= rhs + (_ :> _ ) -> lhs I.:> rhs + where + v = simplify (ol + (negate or) ) + vars :: [(x,Double)] = getVars v + lhs :: [I.Variable x] = map (\(v,d) -> d I.:# v) vars + rhs = negate $ getConstant v + ol = case constr of + (a :< _) -> a + (a := _) -> a + (a :> _) -> a + or = case constr of + (_ :< b) -> b + (_ := b) -> b + (_ :> b) -> b +buildConstraints :: (Eq x, Hashable x) => Constraints x -> I.Constraints x +buildConstraints (Constraints constrs) = I.Constraints $ map buildConstraint constrs -type Bounds = [Bound Int] +buildObjective :: forall x. (Eq x, Hashable x) => Optimization x -> I.Optimization x +buildObjective inp = case inp of + Minimize _ -> I.Minimize obj + Maximize _ -> I.Maximize obj + where + v = simplify (o) + vars :: [(x,Double)] = getVars v + obj :: [I.Variable x] = map (\(v,d) -> d I.:# v) vars + o = case inp of + Minimize vs -> vs + Maximize vs -> vs + data LinearProblem a = LP (Optimization a) (Constraints a) [(a, Maybe Double, Maybe Double)] - deriving Show + -- deriving Show data MixedIntegerProblem a = MILP (Optimization a) (Constraints a) [(a, Maybe Double, Maybe Double)] - [(a,Type)] - deriving Show - -data MIPSolution a = MIPSolution { mipOptimalSol :: Bool, mipObjVal :: Double, mipVars :: Map a Double } deriving (Show) - -data LPSolution a = LPSolution { lpOptimalSol :: Bool, lpObjVal :: Double, lpVars :: Map a Double, lpDualVars :: V.Vector Double, lpBasisVars :: Maybe (S.HashSet a)} deriving (Show) - + [(a,I.Type)] + -- deriving Show diff --git a/src/Data/LP/Backend/Cplex.hs b/src/Data/LP/Backend/Cplex.hs --- a/src/Data/LP/Backend/Cplex.hs +++ b/src/Data/LP/Backend/Cplex.hs @@ -14,7 +14,8 @@ import CPLEX.Param import CPLEX.Core hiding (Bound) --import Foreign.C (CInt) -import Data.LP +import Data.Internal +import qualified Data.LP as LP import qualified Data.Vector.Storable as VS import Foreign.Ptr import Foreign.ForeignPtr(newForeignPtr_) @@ -28,9 +29,6 @@ import Data.Ord (comparing) import qualified Data.HashSet as S - -type Map k v = M.HashMap k v - data CallBacks a = ActiveCallBacks {cutcb :: Maybe (UserCutCallBack a), inccb :: Maybe (UserIncumbentCallBack), lazycb :: Maybe (UserCutCallBack a) } defaultCallBacks :: CallBacks a @@ -49,8 +47,6 @@ type IncumbentCallBackM a = (ReaderT IncumbentCallBackArgs IO a) type UserIncumbentCallBack = Double -> VS.Vector Double -> IncumbentCallBackM Bool - - incumbentcallback :: UserIncumbentCallBack -> CIncumbentCallback incumbentcallback usercb env' cbdata wherefrom cbhandle objVal xs isfeas useraction = do let env = CpxEnv env' @@ -66,17 +62,13 @@ poke isfeas (if isFeas then 1 else 0) return 0 - -cutcallback :: (Eq a, Hashable a) => VarDic a -> RevDic a -> UserCutCallBack a -> CCutCallback -cutcallback vardic revdic usercb env' cbdata wherefrom cbhandle ptrUser = do - let env = CpxEnv env' - runReaderT usercb $ CutCallBackArgs env cbdata wherefrom cbhandle ptrUser vardic revdic - lazycallback :: (Eq a, Hashable a) => VarDic a -> RevDic a -> UserCutCallBack a -> CCutCallback lazycallback vardic revdic usercb env' cbdata wherefrom cbhandle ptrUser = do let env = CpxEnv env' runReaderT usercb $ CutCallBackArgs env cbdata wherefrom cbhandle ptrUser vardic revdic +cutcallback :: (Eq a, Hashable a) => VarDic a -> RevDic a -> UserCutCallBack a -> CCutCallback +cutcallback = lazycallback getCallBackLp :: (Eq a, Hashable a) => CutCallBackM a CpxLp getCallBackLp = do @@ -172,13 +164,15 @@ varsToVector vs = V.fromList $ map snd $ sortBy (comparing fst) $ map (\(c :# i) -> (i,c)) vs -solLP :: (Eq a, Hashable a) => LinearProblem a -> ParamValues -> IO (LPSolution a) -solLP (LP objective_ constraints_ bounds_) params = withEnv $ \env -> do +solLP :: (Eq a, Hashable a) => LP.LinearProblem a -> ParamValues -> IO (LPSolution a) +solLP (LP.LP objective__ constraints__ bounds_) params = withEnv $ \env -> do --setIntParam env CPX_PARAM_SCRIND cpx_ON --setIntParam env CPX_PARAM_DATACHECK cpx_ON mapM_ (\(p,v) -> setIntParam env p (fromIntegral v)) params withLp env "testprob" $ \lp -> do let + constraints_ = LP.buildConstraints constraints__ + objective_ = LP.buildObjective objective__ dic = generateVarDic constraints_ objective_ bounds_ revDic = M.fromList $ map (\(a,b) -> (b,a)) $ M.toList dic objective = tokenizeObj objective_ dic @@ -213,15 +207,17 @@ let basis' = basism >>= \basis -> Just $ S.fromList $ map (\(i,c) -> revDic M.! i) $ filter(\(i,c) -> c == 1) $ zip [0..] $ V.toList $ VS.convert basis return $ LPSolution (solStat sol == CPX_STAT_OPTIMAL) (solObj sol) ( m ) (VS.convert $ solPi sol) basis' -solMIP :: (Eq a, Hashable a) => MixedIntegerProblem a -> ParamValues -> CallBacks a -> IO (MIPSolution a) +solMIP :: (Eq a, Hashable a) => LP.MixedIntegerProblem a -> ParamValues -> CallBacks a -> IO (MIPSolution a) solMIP = solMIP' M.empty -solMIP' :: (Eq a, Hashable a) => Map a Double -> MixedIntegerProblem a -> ParamValues -> CallBacks a -> IO (MIPSolution a) -solMIP' warmStart (MILP objective_ constraints_ bounds_ types_ ) params (ActiveCallBacks {..}) = withEnv $ \env -> do +solMIP' :: (Eq a, Hashable a) => Map a Double -> LP.MixedIntegerProblem a -> ParamValues -> CallBacks a -> IO (MIPSolution a) +solMIP' warmStart (LP.MILP objective__ constraints__ bounds_ types_ ) params (ActiveCallBacks {..}) = withEnv $ \env -> do -- setIntParam env CPX_PARAM_SCRIND 1 -- setIntParam env CPX_PARAM_DATACHECK 1 mapM_ (\(p,v) -> setIntParam env p (fromIntegral v)) params withLp env "clu" $ \lp -> do let + constraints_ = LP.buildConstraints constraints__ + objective_ = LP.buildObjective objective__ dic = generateVarDic constraints_ objective_ bounds_ revDic = M.fromList $ map (\(a,b) -> (b,a)) $ M.toList dic objective = tokenizeObj objective_ dic @@ -283,12 +279,10 @@ let m = M.fromList $ zip (map (revDic M.!) [0..length vars - 1]) vars return $ MIPSolution (solStat sol == CPXMIP_OPTIMAL) (solObj sol) m -typeToCPX :: Data.LP.Type -> CPLEX.Core.Type +typeToCPX :: Data.Internal.Type -> CPLEX.Core.Type typeToCPX (TInteger) = CPX_INTEGER typeToCPX (TContinuous) = CPX_CONTINUOUS typeToCPX (TBinary) = CPX_BINARY - - generateVarDic :: (Eq a, Hashable a) => Constraints a -> Optimization a -> [(a, Maybe Double, Maybe Double)]