diff --git a/cbits/Cbc.cpp b/cbits/Cbc.cpp --- a/cbits/Cbc.cpp +++ b/cbits/Cbc.cpp @@ -1,5 +1,5 @@ -#include -#include +#include +#include #define FROM_CPP #include "Cbc.h" diff --git a/examples/Base.hs b/examples/Base.hs deleted file mode 100644 --- a/examples/Base.hs +++ /dev/null @@ -1,36 +0,0 @@ -module Base where - -import Numeric.Limp.Rep -import Numeric.Limp.Program -import Numeric.Limp.Solvers.Cbc - -data V0 - -deriving instance Ord V0 -deriving instance Eq V0 -deriving instance Show V0 - -data V2 = A | B - deriving (Ord, Eq, Show) - - -solve_problem :: (Show z, Show r, Ord z, Ord r) => (Direction -> Program z r IntDouble) -> IO () -solve_problem problem - = do let a1 = solve $ problem Minimise - putStrLn "*** Minimise *** " - show_result a1 - - let a2 = solve $ problem Maximise - putStrLn "*** Maximise *** " - show_result a2 - -show_result :: (Show z, Show r, Ord z, Ord r) => Either Error (Assignment z r IntDouble) -> IO () -show_result as - = case as of - Left e - -> do putStrLn "Error:" - print e - Right a - -> do putStrLn "Success:" - print a - diff --git a/examples/Clustering.hs b/examples/Clustering.hs deleted file mode 100644 --- a/examples/Clustering.hs +++ /dev/null @@ -1,114 +0,0 @@ --- Example program based on one generated by our fusion/clustering algorithm --- --- sum1 = fold (+) 0 xs --- nor1 = map (/ sum1) xs --- ys = filter (> 0) xs --- sum2 = fold (+) 0 ys --- nor2 = map (/ sum2) xs --- - -module Clustering (clustering) where - -import Base -import Numeric.Limp.Rep -import Numeric.Limp.Program - -import qualified Numeric.Limp.Canon as C -import qualified Numeric.Limp.Canon.Pretty as C - --- | One for each combinator -data Node - = Sum1 | Nor1 | Ys | Sum2 | Nor2 - deriving (Ord, Eq, Show) - --- | The integer variables: --- forall a b. 0 <= F a b <= 1 :: Z --- F a b == 0 iff a and b are fused -data VZ - = F Node Node - deriving (Ord, Eq, Show) - --- | The real variables: --- forall a b. F a b == 0 ==> O a == O b --- O a > O b if edge from a to b -data VR - = O Node - deriving (Ord, Eq, Show) - - -problem1 :: Direction -> Program VZ VR IntDouble -problem1 dir - = program dir - objective - constraints - bounds - ---Minimise 5f(sum1, ys) + 1f(sum1, sum2) --- + 5f(sum1, nor2) + 5f(ys, sum2) --- + 5f(ys, nor1) + 5f(sum2, nor1) --- + 5f(nor1, nor2) -objective - = f100 Sum1 Ys .+. f1 Sum1 Sum2 - .+. f100 Sum1 Nor2 .+. f100 Ys Sum2 - .+. f100 Ys Nor1 .+. f1 Sum2 Nor1 - .+. f100 Nor1 Nor2 - ---Subject to --- f(sum1, ys) ≤ f(sum1, sum2) --- f(sum2, ys) ≤ f(sum1, sum2) --- -5f(sum1, ys) ≤ o(ys) - o(sum1) ≤ 5f(sum1, ys) --- -5f(sum1, sum2) ≤ o(sum2) - o(sum1) ≤ 5f(sum1, sum2) --- 1f(ys, sum2) ≤ o(sum2) - o(ys) ≤ 5f(ys, sum2) --- -5f(nor1, nor2) ≤ o(nor2) - o(nor1) ≤ 5f(nor1, nor2) --- o(sum1) < o(nor1) --- o(sum2) < o(nor2) --- -constraints - = filt Sum1 Sum2 Ys - :&& filt Sum2 Nor1 Ys - :&& odiff (-5) Sum1 Ys 5 - :&& odiff (-5) Sum1 Sum2 5 - :&& odiff 1 Ys Sum2 5 - :&& odiff (-5) Ys Nor1 5 - :&& odiff (-5) Nor1 Nor2 5 - :&& odiff (-5) Sum1 Nor2 5 - :&& odiff (-5) Sum2 Nor1 5 - :&& o Sum1 `lt` o Nor1 - :&& o Sum2 `lt` o Nor2 - where - - o = r1 . O - - lt a b = a .+. c1 :<= b - - filt a b c - = f1 a c :<= f1 a b - :&& f1 b c :<= f1 a b - - odiff p a b q - = Between (p *. f1 a b) (o b .-. o a) (q *. f1 a b) - -bounds - = [ binary $ F Sum1 Sum2 - , binary $ F Sum1 Ys - , binary $ F Sum1 Nor2 - , binary $ F Ys Sum2 - , binary $ F Nor1 Ys - , binary $ F Nor1 Sum2 - , binary $ F Nor1 Nor2 - ] - -f100 :: Node -> Node -> Linear VZ VR IntDouble KZ -f100 a b - = 100 *. f1 a b - -f1 :: Node -> Node -> Linear VZ VR IntDouble KZ -f1 a b - = z1 $ F (min a b) (max a b) - - -clustering :: IO () -clustering - = do solve_problem problem1 - putStr (show $ C.program $ problem1 Minimise) - diff --git a/examples/Infeasible.hs b/examples/Infeasible.hs deleted file mode 100644 --- a/examples/Infeasible.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Infeasible (infeasible) where - -import Base -import Numeric.Limp.Rep -import Numeric.Limp.Program - --- Minimise 1 --- Subject to a >= b + 1 --- b >= a + 1 -problem1 :: Direction -> Program V0 V2 IntDouble -problem1 dir - = program dir - c1 - ( r1 A :>= r1 B .+. c1 - :&& r1 B :>= r1 A .+. c1) - [] - -infeasible :: IO () -infeasible - = do solve_problem problem1 - diff --git a/examples/Simple.hs b/examples/Simple.hs deleted file mode 100644 --- a/examples/Simple.hs +++ /dev/null @@ -1,59 +0,0 @@ -module Simple (simple) where - -import Base -import Numeric.Limp.Rep -import Numeric.Limp.Program - --- Minimise a + b --- Subject to a + 2b >= 3 --- Where 0 <= a <= 10 :: Z --- 0 <= b <= 10 :: R -problem1 :: Direction -> Program String String IntDouble -problem1 dir - = program dir - (z1 "a" .+. r1 "b" ) - (z1 "a" .+. r "b" 2 :>= con 3) - [ lowerUpperZ 0 "a" 10 - , lowerUpperR 0 "b" 10 ] - --- As above, but swap coefficients on >= 3 constraint. --- --- Minimise a + b --- Subject to 2a + b >= 3 --- Where 0 <= a <= 10 :: Z --- 0 <= b <= 10 :: R -problem2 :: Direction -> Program String String IntDouble -problem2 dir - = program dir - (z1 "a" .+. r1 "b" ) - (z "a" 2 .+. r1 "b" :>= con 3) - [ lowerUpperZ 0 "a" 10 - , lowerUpperR 0 "b" 10 ] - - --- Leave out the bounds on variables --- --- Minimise a + b --- Subject to a >= b --- b >= a --- a >= 3 --- b <= 10 --- Where a :: Z --- b :: R -problem3 :: Direction -> Program String String IntDouble -problem3 dir - = program dir - (z1 "a" .+. r1 "b") - ( z1 "a" :>= r1 "b" - :&& r1 "b" :>= z1 "a" - :&& z1 "a" :>= con 3 - :&& r1 "b" :<= con 10) - [ ] - - -simple :: IO () -simple - = do solve_problem problem1 - solve_problem problem2 - solve_problem problem3 - diff --git a/examples/Stupid.hs b/examples/Stupid.hs deleted file mode 100644 --- a/examples/Stupid.hs +++ /dev/null @@ -1,19 +0,0 @@ --- Stupid examples that might just fail -module Stupid (stupid) where - -import Base -import Numeric.Limp.Rep -import Numeric.Limp.Program - -problem1 :: Direction -> Program String String IntDouble -problem1 dir - = program dir - c1 - CTrue - [] - -stupid :: IO () -stupid - = do solve_problem problem1 - - diff --git a/limp-cbc.cabal b/limp-cbc.cabal --- a/limp-cbc.cabal +++ b/limp-cbc.cabal @@ -1,5 +1,5 @@ name: limp-cbc -version: 0.3.2.1 +version: 0.3.2.2 synopsis: bindings for integer linear programming solver Coin/CBC description: very simple binding to external solver, CBC. CBC is somewhat faster than GLPK, and also has a more permissive licence. @@ -279,10 +279,10 @@ Numeric.Limp.Solvers.Cbc.Internal.Foreign Numeric.Limp.Solvers.Cbc.Internal.Wrapper build-depends: - base < 5, + base >= 4.9 && < 5, containers == 0.5.*, - vector == 0.10.*, - limp == 0.3.2.* + vector >= 0.10 && < 0.13, + limp == 0.3.2.2 ghc-options: -Wall -fno-warn-orphans default-language: Haskell2010 @@ -291,7 +291,8 @@ build-tools: c2hs if !flag(embedded) - extra-libraries: Cbc Clp CbcSolver Cgl Osi OsiCbc OsiClp OsiCommonTests CoinUtils CoinMP stdc++ + extra-libraries: stdc++ + pkgconfig-depends: cbc include-dirs: cbits includes: Cbc.h c-sources: cbits/Cbc.cpp @@ -506,17 +507,19 @@ cbits/coin/OsiSolverBranch.cpp cbits/coin/OsiSolverInterface.cpp -test-suite test +test-suite examples type: exitcode-stdio-1.0 hs-source-dirs: examples main-is: Test.hs - other-modules: - Base - Clustering - Infeasible - Simple - Stupid build-depends: base, limp, limp-cbc + default-language: Haskell2010 + default-extensions: TemplateHaskell TypeFamilies FlexibleContexts GeneralizedNewtypeDeriving DataKinds GADTs RankNTypes StandaloneDeriving + +test-suite test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base, limp, limp-cbc, tasty, tasty-quickcheck, QuickCheck default-language: Haskell2010 default-extensions: TemplateHaskell TypeFamilies FlexibleContexts GeneralizedNewtypeDeriving DataKinds GADTs RankNTypes StandaloneDeriving diff --git a/src/Numeric/Limp/Solvers/Cbc/Error.hs b/src/Numeric/Limp/Solvers/Cbc/Error.hs --- a/src/Numeric/Limp/Solvers/Cbc/Error.hs +++ b/src/Numeric/Limp/Solvers/Cbc/Error.hs @@ -2,5 +2,5 @@ data Error = Infeasible - deriving Show + deriving (Show, Eq, Ord) diff --git a/src/Numeric/Limp/Solvers/Cbc/Internal/Foreign.chs b/src/Numeric/Limp/Solvers/Cbc/Internal/Foreign.chs --- a/src/Numeric/Limp/Solvers/Cbc/Internal/Foreign.chs +++ b/src/Numeric/Limp/Solvers/Cbc/Internal/Foreign.chs @@ -4,8 +4,6 @@ import Foreign import Foreign.C -import Control.Applicative - import qualified Data.Vector.Storable as V import Data.Vector.Storable (Vector) @@ -73,11 +71,14 @@ getSolution :: CbcModel -> IO (Vector Double) -getSolution m +getSolution m@(CbcModel fp) = do ncols <- fromIntegral <$> withCbcModel m {#call getNumCols#} vd <- unsafeCoerce <$> withCbcModel m {#call getBestSolution#} + arr <- V.generateM ncols (peekElemOff vd) - V.generateM ncols (peekElemOff vd) + -- The model owns the array, so ensure we keep it around until after we've read the whole array + touchForeignPtr fp + return arr {#fun setObjSense as ^ diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, TupleSections #-} +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.QuickCheck.Property +import Data.IORef +import Data.Void +import Data.Either +import Numeric.Limp.Solvers.Cbc (solve, Error(..)) +import Numeric.Limp.Program +import Numeric.Limp.Rep.IntDouble +import Numeric.Limp.Solvers.Cbc.MatrixRepr (matrixReprOfProgram) + +import qualified Numeric.Limp.Canon as Canon +import qualified Numeric.Limp.Canon.Pretty as Canon + +main :: IO () +main = defaultMain limpTest + +instance Arbitrary (Program Int Void IntDouble) where + arbitrary = do + let + vars :: [Int] + vars = [1 .. 10] + bounds = map binary vars + obj = LZ ((,1) <$> vars) 0 + constraints <- fmap mconcat . vectorOf 5 $ do + vars1 <- sublistOf vars + return $ LZ ((,1) <$> vars1) 0 :== c1 + return $ minimise obj constraints bounds + +limpTest :: TestTree +limpTest = testProperty "limp" $ \(prog1 :: Program Int Void IntDouble) -> + ioProperty $ do + -- prevent CSE + v <- newIORef prog1 + prog2 <- readIORef v + let sol1 = solve prog1 + sol2 = solve prog2 + score1 = eval <$> sol1 <*> pure (_objective prog1) + score2 = eval <$> sol2 <*> pure (_objective prog2) + valid1 = checkProgram <$> sol1 <*> pure prog1 + valid2 = checkProgram <$> sol2 <*> pure prog2 + return $ + classify (isRight sol1) "feasible" $ + if score1 == score2 + then property True + else property $ + MkResult (Just False) True + ("\n" ++ show (score1,valid1,sol1) ++ + "\n" ++ show (score2,valid2,sol2) ++ + "\n\n" ++ ppr prog1) + Nothing False Nothing mempty mempty mempty [show prog1] + +ppr :: Program Int Void IntDouble -> String +ppr p0 = + let p = Canon.program p0 + m = matrixReprOfProgram p + lp = Canon.ppr (("Z"++) . show) (("R"++) . show) p + in lp ++ "\n\n" ++ show m + +{- + (Right -9.223372036854776e18,Right (Assignment (fromList [(1,-9223372036854775808),(2,0),(3,0),(4,1),(5,1),(6,0),(7,0),(8,1),(9,0),(10,0)]) (fromList []))) + (Right 3.0,Right (Assignment (fromList [(1,0),(2,0),(3,0),(4,1),(5,1),(6,0),(7,0),(8,1),(9,0),(10,0)]) (fromList []))) + Minimize + 1.0 Z1 + 1.0 Z2 + 1.0 Z3 + 1.0 Z4 + 1.0 Z5 + 1.0 Z6 + 1.0 Z7 + 1.0 Z8 + 1.0 Z9 + 1.0 Z10 + Subject to + -1.0 Z1 - 1.0 Z2 - 1.0 Z6 - 1.0 Z8 - 1.0 Z10 >= -1.0 + -1.0 Z1 - 1.0 Z2 - 1.0 Z6 - 1.0 Z8 - 1.0 Z10 <= -1.0 + -1.0 Z1 - 1.0 Z2 - 1.0 Z5 - 1.0 Z7 - 1.0 Z9 >= -1.0 + -1.0 Z1 - 1.0 Z2 - 1.0 Z5 - 1.0 Z7 - 1.0 Z9 <= -1.0 + -1.0 Z5 >= -1.0 + -1.0 Z5 <= -1.0 + -1.0 Z1 - 1.0 Z4 - 1.0 Z7 - 1.0 Z9 >= -1.0 + -1.0 Z1 - 1.0 Z4 - 1.0 Z7 - 1.0 Z9 <= -1.0 + -1.0 Z7 - 1.0 Z8 >= -1.0 + -1.0 Z7 - 1.0 Z8 <= -1.0 + + Bounds + 0.0 <= Z1 <= 1.0 + 0.0 <= Z2 <= 1.0 + 0.0 <= Z3 <= 1.0 + 0.0 <= Z4 <= 1.0 + 0.0 <= Z5 <= 1.0 + 0.0 <= Z6 <= 1.0 + 0.0 <= Z7 <= 1.0 + 0.0 <= Z8 <= 1.0 + 0.0 <= Z9 <= 1.0 + 0.0 <= Z10 <= 1.0 + + Generals + Z1 + Z2 + Z3 + Z4 + Z5 + Z6 + Z7 + Z8 + Z9 + Z10 +-}