From d68fb49cad1a5bba7e52c7ff464d15c867052d0f Mon Sep 17 00:00:00 2001 From: Justin Bedo Date: Tue, 28 Oct 2014 10:19:49 +1100 Subject: Add support for binary/integer contraints; Change to hash maps to speed up variable LUT for large number of variables. --- LinProg.cabal | 2 +- Math/LinProg/LP.hs | 14 ++++++++++++++ Math/LinProg/LPSolve.hs | 15 ++++++++++++--- Math/LinProg/LPSolve/FFI.hs | 10 ++++++++++ Math/LinProg/Types.hs | 17 ++++++++++++++--- default.nix | 2 ++ 6 files changed, 53 insertions(+), 7 deletions(-) diff --git a/LinProg.cabal b/LinProg.cabal index 3d246a9..3751020 100644 --- a/LinProg.cabal +++ b/LinProg.cabal @@ -20,7 +20,7 @@ library other-modules: Math.LinProg.LPSolve.FFI extra-libraries: lpsolve55 extensions: DeriveFunctor, FlexibleInstances, FlexibleContexts, UndecidableInstances, TemplateHaskell, ScopedTypeVariables, ForeignFunctionInterface, ViewPatterns - build-depends: base >=4.7 && <4.8, recursion-schemes >=4.1 && <4.2, free >=4.9 && <4.10, containers >=0.5 && <0.6, lens >=4.4 && <4.5, mtl >=2.1 && <2.2, QuickCheck + build-depends: base >=4.7 && <4.8, recursion-schemes >=4.1 && <4.2, free >=4.9 && <4.10, containers >=0.5 && <0.6, lens >=4.4 && <4.5, mtl >=2.1 && <2.2, QuickCheck, unordered-containers, hashable -- hs-source-dirs: default-language: Haskell2010 ghc-options: -Wall -fno-warn-missing-signatures -fno-warn-name-shadowing diff --git a/Math/LinProg/LP.hs b/Math/LinProg/LP.hs index 18d2068..d1a1cf1 100644 --- a/Math/LinProg/LP.hs +++ b/Math/LinProg/LP.hs @@ -20,6 +20,8 @@ module Math.LinProg.LP ( ,objective ,equals ,leqs + ,ints + ,bins ) where import Data.List @@ -35,6 +37,8 @@ data CompilerS t v = CompilerS { _objective :: LinExpr t v ,_equals :: [Equation t v] ,_leqs :: [Equation t v] + ,_bins :: [v] + ,_ints :: [v] } deriving (Eq) $(makeLenses ''CompilerS) @@ -45,12 +49,16 @@ compile ast = compile' ast initCompilerS where compile' (Free (Objective a c)) state = compile' c $ state & objective +~ a compile' (Free (EqConstraint a b c)) state = compile' c $ state & equals %~ (split (a-b):) compile' (Free (LeqConstraint a b c)) state = compile' c $ state & leqs %~ (split (a-b):) + compile' (Free (Integer a b)) state = compile' b $ state & ints %~ (a:) + compile' (Free (Binary a b)) state = compile' b $ state & bins %~ (a:) compile' _ state = state initCompilerS = CompilerS 0 [] [] + [] + [] -- | Shows a compiled state as LP format. Requires variable ids are strings. instance (Show t, Num t, Ord t) => Show (CompilerS t String) where @@ -62,6 +70,10 @@ instance (Show t, Num t, Ord t) => Show (CompilerS t String) where ,if hasUnbounded then Just (intercalate "\n" $ map (\(a, b) -> showEq a ++ " <= " ++ show (negate b)) unbounded) else Nothing ,if hasBounded then Just "Bounds" else Nothing ,if hasBounded then Just (intercalate "\n" $ map (\(l, v, u) -> show l ++ " <= " ++ v ++ " <= " ++ show u) bounded) else Nothing + ,if hasInts then Just "General" else Nothing + ,if hasInts then Just (unwords $ s ^. ints) else Nothing + ,if hasBins then Just "Binary" else Nothing + ,if hasBins then Just (unwords $ s ^. bins) else Nothing ] where showEq = unwords . map (\(a, b) -> render b ++ " " ++ a) . varTerms @@ -71,6 +83,8 @@ instance (Show t, Num t, Ord t) => Show (CompilerS t String) where hasUnbounded = not (null unbounded) hasEqs = not (null (s^.equals)) hasST = hasUnbounded || hasEqs + hasInts = not . null $ s ^. ints + hasBins = not . null $ s ^. bins render x = (if x >= 0 then "+" else "") ++ show x diff --git a/Math/LinProg/LPSolve.hs b/Math/LinProg/LPSolve.hs index baa5d7e..5299d94 100644 --- a/Math/LinProg/LPSolve.hs +++ b/Math/LinProg/LPSolve.hs @@ -26,14 +26,15 @@ import Math.LinProg.LPSolve.FFI hiding (solve) import qualified Math.LinProg.LPSolve.FFI as F import Math.LinProg.LP import Math.LinProg.Types -import qualified Data.Map.Strict as M +import qualified Data.HashMap.Strict as M +import Data.Hashable import Prelude hiding (EQ) -solve :: (Eq v, Ord v) => LinProg Double v () -> IO (Maybe ResultCode, [(v, Double)]) +solve :: (Hashable v, Eq v, Ord v) => LinProg Double v () -> IO (Maybe ResultCode, [(v, Double)]) solve = solveWithTimeout 0 -- | Solves an LP using lp_solve. -solveWithTimeout :: (Eq v, Ord v) => Integer -> LinProg Double v () -> IO (Maybe ResultCode, [(v, Double)]) +solveWithTimeout :: (Hashable v, Eq v, Ord v) => Integer -> LinProg Double v () -> IO (Maybe ResultCode, [(v, Double)]) solveWithTimeout t (compile -> lp) = do model <- makeLP nconstr nvars case model of @@ -59,6 +60,14 @@ solveWithTimeout t (compile -> lp) = do setRHS m i c return () + -- Ints + forM_ (lp ^. ints) $ \v -> do + setInt m (varLUT M.! v) + + -- Bins + forM_ (lp ^. bins) $ \v -> do + setBin m (varLUT M.! v) + -- Objective forM_ (varTerms (lp ^. objective)) $ \(v, w) -> do void $ setMat m 0 (varLUT M.! v) w diff --git a/Math/LinProg/LPSolve/FFI.hs b/Math/LinProg/LPSolve/FFI.hs index ddc7798..ff0bc16 100644 --- a/Math/LinProg/LPSolve/FFI.hs +++ b/Math/LinProg/LPSolve/FFI.hs @@ -5,6 +5,8 @@ module Math.LinProg.LPSolve.FFI ( ,LPRec ,setConstrType ,setTimeout + ,setInt + ,setBin ,makeLP ,freeLP ,setMat @@ -52,6 +54,8 @@ foreign import ccall "solve" c_solve :: LPRec -> IO CInt foreign import ccall "get_variables" c_get_variables :: LPRec -> Ptr CDouble -> IO CChar foreign import ccall "set_constr_type" c_set_constr_type :: LPRec -> CInt -> CInt -> IO CChar foreign import ccall "set_timeout" c_set_timeout :: LPRec -> CLong -> IO () +foreign import ccall "set_int" c_set_int :: LPRec -> CInt -> CChar -> IO CChar +foreign import ccall "set_binary" c_set_binary :: LPRec -> CInt -> CChar -> IO CChar setTimeout :: LPRec -> Integer -> IO () setTimeout lp x = c_set_timeout lp (fromIntegral x) @@ -76,6 +80,12 @@ setMat a b c d = fromIntegral <$> c_set_mat a (fromIntegral b) (fromIntegral c) setRHS :: LPRec -> Int -> Double -> IO Word8 setRHS a b c = fromIntegral <$> c_set_rh a (fromIntegral b) (realToFrac c) +setInt :: LPRec -> Int -> IO Word8 +setInt m a = fromIntegral <$> c_set_int m (fromIntegral a) 1 + +setBin :: LPRec -> Int -> IO Word8 +setBin m a = fromIntegral <$> c_set_binary m (fromIntegral a) 1 + solve :: LPRec -> IO ResultCode solve lp = (lut M.!) . fromIntegral <$> c_solve lp where diff --git a/Math/LinProg/Types.hs b/Math/LinProg/Types.hs index 2a81918..4819dd3 100644 --- a/Math/LinProg/Types.hs +++ b/Math/LinProg/Types.hs @@ -26,14 +26,17 @@ module Math.LinProg.Types ( ,(<:) ,(=:) ,(>:) + ,bin + ,int ) where import Data.Functor.Foldable import Control.Monad.Free -import qualified Data.Map.Strict as M +import qualified Data.HashMap.Strict as M import Test.QuickCheck import Control.Applicative import Data.List +import Data.Hashable -- | Base AST for expressions. Expressions have factors or type t and -- variables referenced by ids of type v. @@ -117,7 +120,7 @@ rewrite = cata rewrite' where rewrite' a = Fix a -- | Reduces an expression to the variable terms -varTerms :: (Num t, Eq t, Ord v) => LinExpr t v -> [(v, t)] +varTerms :: (Num t, Eq t, Hashable v, Eq v) => LinExpr t v -> [(v, t)] varTerms = M.toList . cata go . rewrite where go (Wvar w a) = M.fromList [(a, w)] go (Add a b) = M.unionWith (+) a b @@ -141,6 +144,8 @@ prettyPrint = cata prettyPrint' where -- in the data type). data LinProg' t v a = Objective !(LinExpr t v) !a + | Integer !v !a + | Binary !v !a | EqConstraint !(LinExpr t v) !(LinExpr t v) !a | LeqConstraint !(LinExpr t v) !(LinExpr t v) !a deriving (Show, Eq, Functor) @@ -155,10 +160,16 @@ a =: b = liftF (EqConstraint a b ()) -- | Define an inequality (less than equal) contraint a <: b = liftF (LeqConstraint a b ()) --- + -- | Define an inequality (greater than equal) contraint b >: a = liftF (LeqConstraint a b ()) +-- | Declare a variable to be binary +bin (Fix (Var v)) = liftF (Binary v ()) + +-- | Declare a variable to be integral +int (Fix (Var v)) = liftF (Integer v ()) + infix 4 =: infix 4 <: infix 4 >: diff --git a/default.nix b/default.nix index e2d13af..acadb7a 100644 --- a/default.nix +++ b/default.nix @@ -3,6 +3,7 @@ , haskellPackages ? (import {}).haskellPackages }: let inherit (haskellPackages) cabal + unorderedContainers QuickCheck recursionSchemes lens @@ -16,6 +17,7 @@ in cabal.mkDerivation (self: { src = ./.; isLibrary = true; buildDepends = [ + unorderedContainers QuickCheck recursionSchemes lens -- cgit v1.2.3