packages feed

cplex-hs 0.4.0.4 → 0.5.0.0

raw patch · 4 files changed

+213/−96 lines, 4 files

Files

cplex-hs.cabal view
@@ -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
+ src/Data/Internal.hs view
@@ -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)++
src/Data/LP.hs view
@@ -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
src/Data/LP/Backend/Cplex.hs view
@@ -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)]