├── LICENSE
├── README.md
├── Setup.hs
├── changelog
├── limp.cabal
├── src
    └── Numeric
    │   └── Limp
    │       ├── Canon.hs
    │       ├── Canon
    │           ├── Analyse
    │           │   └── Constants.hs
    │           ├── Constraint.hs
    │           ├── Convert.hs
    │           ├── Linear.hs
    │           ├── Pretty.hs
    │           ├── Program.hs
    │           ├── Simplify.hs
    │           └── Simplify
    │           │   ├── Bounder.hs
    │           │   ├── Crunch.hs
    │           │   └── Subst.hs
    │       ├── Error.hs
    │       ├── Program.hs
    │       ├── Program
    │           ├── Bounds.hs
    │           ├── Constraint.hs
    │           ├── Eval.hs
    │           ├── Linear.hs
    │           ├── Program.hs
    │           └── ResultKind.hs
    │       ├── Rep.hs
    │       ├── Rep
    │           ├── Arbitrary.hs
    │           ├── IntDouble.hs
    │           └── Rep.hs
    │       └── Solve
    │           ├── Branch
    │               └── Simple.hs
    │           └── Simplex
    │               ├── Maps.hs
    │               └── StandardForm.hs
└── tests
    ├── Arbitrary
        ├── Assignment.hs
        ├── Program.hs
        └── Var.hs
    ├── BranchExample.hs
    ├── Convert.hs
    ├── Main.hs
    ├── SimplexExample.hs
    ├── Simplexs.hs
    └── Simplify.hs


/LICENSE:
--------------------------------------------------------------------------------
 1 | Copyright (c) 2014 <copyright holders>
 2 | 
 3 | Permission is hereby granted, free of charge, to any person obtaining a copy
 4 | of this software and associated documentation files (the "Software"), to deal
 5 | in the Software without restriction, including without limitation the rights
 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
 7 | copies of the Software, and to permit persons to whom the Software is
 8 | furnished to do so, subject to the following conditions:
 9 | 
10 | The above copyright notice and this permission notice shall be included in
11 | all copies or substantial portions of the Software.
12 | 
13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
19 | THE SOFTWARE.
20 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | limp
 2 | ====
 3 | 
 4 | This package provides two representations for linear programs: "Numeric.Limp.Program", which is what I expect end-users to use, and
 5 | "Numeric.Limp.Canon", which is simpler, but would be less nice for writing linear programs.
 6 | You can convert programs from the Program representation to the Canon representation using "Numeric.Limp.Canon.Convert", and then pretty-print the program using "Numeric.Limp.Canon.Pretty".
 7 | 
 8 | There is a very simple branch-and-bound solver in "Numeric.Limp.Solve.Branch.Simple", and a simplex solver for relaxed (real only) programs in "Numeric.Limp.Solve.Simplex.Maps".
 9 | See the limp-cbc package for a simple external solver.
10 | 
11 | 


--------------------------------------------------------------------------------
/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 | 


--------------------------------------------------------------------------------
/changelog:
--------------------------------------------------------------------------------
 1 | 0.3.2.3, 2018/11/13:
 2 |   * Fix pretty-printing bug: printed programs did not include final 'End' line, so cbc could not parse the programs
 3 |   * Relax the upper bound for containers dependency (contributed by @fumieval)
 4 |   * Update test dependencies
 5 |   * Update package description
 6 | 
 7 | 0.3.2.2, 2018/06/04:
 8 |   * Build -Wall clean with GHC 8.4.3
 9 |   * Relax the upper bound for base dependency
10 |   * Add missing semigroup instances (contributed by @fumieval)
11 | 
12 | 0.3.2.1, 2015/07/21:
13 |   * Naive implementations of two solving algorithms:
14 |     * Branch-and-bound algorithm for mixed programs
15 |     * Simplex algorithm for relaxed (real) programs
16 |   * Add tests to package description
17 | 
18 | 0.3.2.0, 2014/11/02:
19 |   * Error handling for simplifier
20 | 
21 | 0.3.1.0, 2014/09/19:
22 |   * Simplifier for Canon programs
23 |   * Pretty-printer for Canon programs
24 | 
25 | 0.3.0.0, 2014/09/03:
26 |   * Simplify Canonical representation
27 |   * Add evaluator for Program representation
28 | 
29 | 0.1.0.0, 2014/06/04:
30 |   * Initial release
31 | 


--------------------------------------------------------------------------------
/limp.cabal:
--------------------------------------------------------------------------------
 1 | name:                limp
 2 | version:             0.3.2.3
 3 | synopsis:            representation of Integer Linear Programs
 4 | description:         This package provides two representations for linear programs: "Numeric.Limp.Program", which is what I expect end-users to use, and
 5 |                      "Numeric.Limp.Canon", which is simpler, but would be less nice for writing linear programs.
 6 |                      You can convert programs from the Program representation to the Canon representation using "Numeric.Limp.Canon.Convert", and then pretty-print the program using "Numeric.Limp.Canon.Pretty".
 7 | 
 8 |                      There is a very simple branch-and-bound solver in "Numeric.Limp.Solve.Branch.Simple", and a simplex solver for relaxed (real only) programs in "Numeric.Limp.Solve.Simplex.Maps".
 9 |                      See the limp-cbc package for a simple external solver.
10 | 
11 | license:             MIT
12 | license-file:        LICENSE
13 | author:              Amos Robinson
14 | maintainer:          amos.robinson@gmail.com
15 | category:            Numeric
16 | build-type:          Simple
17 | cabal-version:       >=1.10
18 | homepage:            https://github.com/amosr/limp
19 | extra-source-files:  README.md changelog
20 | 
21 | 
22 | source-repository head
23 |     type: git
24 |     location: git://github.com/amosr/limp.git
25 | 
26 | library
27 |   hs-source-dirs: src
28 |   exposed-modules:
29 |         Numeric.Limp.Rep
30 |         Numeric.Limp.Rep.Rep
31 |         Numeric.Limp.Rep.Arbitrary
32 |         Numeric.Limp.Rep.IntDouble
33 |         Numeric.Limp.Error
34 | 
35 |         Numeric.Limp.Program.Bounds
36 |         Numeric.Limp.Program.Constraint
37 |         Numeric.Limp.Program.Eval
38 |         Numeric.Limp.Program.Linear
39 |         Numeric.Limp.Program.Program
40 |         Numeric.Limp.Program.ResultKind
41 |         Numeric.Limp.Program
42 | 
43 |         Numeric.Limp.Canon.Linear
44 |         Numeric.Limp.Canon.Constraint
45 |         Numeric.Limp.Canon.Convert
46 |         Numeric.Limp.Canon.Program
47 |         Numeric.Limp.Canon.Pretty
48 |         Numeric.Limp.Canon
49 |         Numeric.Limp.Canon.Analyse.Constants
50 |         Numeric.Limp.Canon.Simplify.Bounder
51 |         Numeric.Limp.Canon.Simplify.Crunch
52 |         Numeric.Limp.Canon.Simplify.Subst
53 |         Numeric.Limp.Canon.Simplify
54 | 
55 |         Numeric.Limp.Solve.Simplex.StandardForm
56 |         Numeric.Limp.Solve.Simplex.Maps
57 |         Numeric.Limp.Solve.Branch.Simple
58 | 
59 |   build-depends:
60 |         base        >= 4.9 && < 5,
61 |         containers  >= 0.5 && < 0.7
62 | 
63 |   ghc-options: -Wall -fno-warn-orphans
64 |   default-language: Haskell2010
65 |   default-extensions:       TemplateHaskell TypeFamilies FlexibleContexts GeneralizedNewtypeDeriving DataKinds GADTs RankNTypes StandaloneDeriving FlexibleInstances
66 | 
67 | 
68 | test-suite test
69 |   type: exitcode-stdio-1.0
70 |   main-is: Main.hs
71 |   hs-source-dirs: tests
72 |   other-modules:
73 |         Arbitrary.Assignment
74 |         Arbitrary.Program
75 |         Arbitrary.Var
76 |         BranchExample
77 |         Convert
78 |         SimplexExample
79 |         Simplexs
80 |         Simplify
81 |   build-depends:
82 |         base        < 5,
83 |         containers  >= 0.5 && < 0.7,
84 |         tasty,
85 |         tasty-th    == 0.1.*,
86 |         tasty-quickcheck >= 0.8,
87 |         QuickCheck,
88 |         limp
89 | 
90 |   default-language: Haskell2010
91 |   default-extensions:       TemplateHaskell TypeFamilies FlexibleContexts GeneralizedNewtypeDeriving DataKinds GADTs RankNTypes StandaloneDeriving FlexibleInstances
92 | 


--------------------------------------------------------------------------------
/src/Numeric/Limp/Canon.hs:
--------------------------------------------------------------------------------
 1 | -- | A simpler representation of programs.
 2 | -- The frontend representation ("Numeric.Limp.Program") has many different kinds of constraints
 3 | -- (@<=@, @<@, @==@, @between@), as well as constant additions on each linear function
 4 | -- (eg. @x + 2y + 5@).
 5 | -- The so-called canonical representation removes the constant addition from each linear constraint,
 6 | -- and converts each constraint (@Lin Op Lin@) to (@Num <= Lin <= Num@).
 7 | --
 8 | -- The most interesting function here is 'Numeric.Limp.Canon.Convert.program' for converting
 9 | -- from Program representation to Canon.
10 | module Numeric.Limp.Canon
11 |     ( module Numeric.Limp.Canon.Linear
12 |     , module Numeric.Limp.Canon.Constraint
13 |     , module Numeric.Limp.Canon.Program
14 |     , module Numeric.Limp.Canon.Convert
15 |     ) where
16 | 
17 | import Numeric.Limp.Canon.Linear
18 | import Numeric.Limp.Canon.Constraint
19 | import Numeric.Limp.Canon.Program
20 | import Numeric.Limp.Canon.Convert
21 | 
22 | 


--------------------------------------------------------------------------------
/src/Numeric/Limp/Canon/Analyse/Constants.hs:
--------------------------------------------------------------------------------
 1 | -- | Analyse a program to find all constants
 2 | module Numeric.Limp.Canon.Analyse.Constants where
 3 | import Numeric.Limp.Canon.Program
 4 | import Numeric.Limp.Rep
 5 | import Numeric.Limp.Error
 6 | 
 7 | import qualified Data.Map as M
 8 | 
 9 | 
10 | -- | Find the constants in a program, only by looking at the bounds with lo==up.
11 | -- (See "Numeric.Limp.Canon.Simplify.Stride" to convert constraints to bounds)
12 | constantsProgram :: (Ord z, Ord r, Rep c) => Program z r c -> Either Infeasible (Assignment z r c)
13 | constantsProgram p
14 |  = mkAss $ concatMap eq $ M.toList $ _bounds p
15 |  where
16 | 
17 |   eq (var, (Just lo, Just up))
18 |    | lo == up
19 |    = [(var, lo)]
20 | 
21 |   eq _
22 |    = []
23 | 
24 |   mkAss ms
25 |    = do zs  <- mapM tkLeft  ms
26 |         rs  <- mapM tkRight ms
27 |         return $ Assignment (M.fromList $ concat zs)
28 |                             (M.fromList $ concat rs)
29 | 
30 |   tkLeft (Left z, v)
31 | 
32 |    -- Wow! What if the bounds aren't integral?
33 |    -- Well, I guess the ILP solver will eventually figure out it's infeasible.
34 |    -- Maybe it would be nice to trigger that error here.
35 |    | v /= (fromZ $ truncate v)
36 |    = Left InfeasibleNotIntegral
37 | 
38 |    | otherwise
39 |    = return [(z, truncate v)]
40 | 
41 |   tkLeft _
42 |    = return []
43 | 
44 |   tkRight (Right r, v)
45 |    = return [(r, v)]
46 |   tkRight _
47 |    = return []
48 | 
49 | 


--------------------------------------------------------------------------------
/src/Numeric/Limp/Canon/Constraint.hs:
--------------------------------------------------------------------------------
 1 | -- | Representation of linear constraints
 2 | module Numeric.Limp.Canon.Constraint where
 3 | import Numeric.Limp.Rep
 4 | import Numeric.Limp.Canon.Linear
 5 | 
 6 | import qualified Data.Set as S
 7 | 
 8 | -- | Conjunction of simple constraints
 9 | data Constraint z r c
10 |  = Constraint [Constraint1 z r c]
11 | 
12 | -- | A simple constraint
13 | data Constraint1 z r c
14 |  -- | Maybe a lower bound, a linear function, and maybe an upper bound.
15 |  --
16 |  -- In order to be meaningful, at least one of lower or upper bound should be @Just@.
17 |  = C1 (Maybe (R c)) (Linear z r c) (Maybe (R c))
18 | 
19 | 
20 | -- | Check whether an assignment satisfies the constraint
21 | check :: (Rep c, Ord z, Ord r) => Assignment z r c -> Constraint z r c -> Bool
22 | check a (Constraint cs) = all go cs
23 |  where
24 |   ev l = evalR a l
25 | 
26 |   go (C1 lower lin upper)
27 |    = let lin' = ev lin
28 |      in  maybe True (<= lin') lower
29 |      &&  maybe True (lin' <=) upper
30 | 
31 | 
32 | -- | Get set of variables in constraint
33 | varsOfConstraint :: (Ord z, Ord r) => Constraint z r c -> S.Set (Either z r)
34 | varsOfConstraint (Constraint cs)
35 |  = S.unions
36 |  $ map get cs
37 |  where
38 |   get (C1 _ lin _)
39 |    = varsOfLinear lin
40 | 
41 | 


--------------------------------------------------------------------------------
/src/Numeric/Limp/Canon/Convert.hs:
--------------------------------------------------------------------------------
  1 | -- | Convert from "Numeric.Limp.Program" representation to simpler, so-called canonical representation.
  2 | module Numeric.Limp.Canon.Convert where
  3 | 
  4 | import Numeric.Limp.Rep
  5 | 
  6 | import Numeric.Limp.Canon.Constraint
  7 | import Numeric.Limp.Canon.Linear
  8 | import Numeric.Limp.Canon.Program
  9 | 
 10 | import qualified Numeric.Limp.Program.Bounds     as P
 11 | import qualified Numeric.Limp.Program.Constraint as P
 12 | import qualified Numeric.Limp.Program.Linear     as P
 13 | import qualified Numeric.Limp.Program.Program    as P
 14 | 
 15 | import qualified Data.Map as M
 16 | 
 17 | 
 18 | -- | Convert a Frontend 'P.Linear' into a Canon 'Linear'.
 19 | -- Returns the constant summand as well, as Canon Linear do not have these.
 20 | --
 21 | -- Should satisfy that
 22 | -- @forall a l. P.evalR a l == evalR a (fst $ linear l) + (snd $ linear l)@
 23 | linear :: (Rep c, Ord z, Ord r) => P.Linear z r c k -> (Linear z r c, R c)
 24 | linear (P.LZ ls co)
 25 |  = (mkLinear $ map conv ls, fromZ co)
 26 |  where
 27 |   conv (z,c) = (Left z, fromZ c)
 28 | linear (P.LR ls co)
 29 |  = (mkLinear ls, co)
 30 | 
 31 | -- | Convert a Frontend 'P.Constraint' into a Canon 'Constraint'.
 32 | --
 33 | -- Should satisfy that
 34 | -- @forall a c. P.check a c == check a (constraint c)@
 35 | constraint :: (Rep c, Ord z, Ord r) => P.Constraint z r c -> Constraint z r c
 36 | constraint z
 37 |  = Constraint $ go z
 38 |  where
 39 |   -- a <= b <==> b - a >= 0
 40 |   -- x + 1 <= y     ==> 1 <= y - x
 41 |   -- x + c <= y + d ==> -(d - c) <= y - x
 42 |   --
 43 |   -- x + c <= y + d
 44 |   --     c <= y + d - x
 45 |   -- c - d <= y - x
 46 |   -- -(d-c)<= y - x
 47 |   --
 48 |   cle l r
 49 |    = let (lin, co) = linear (r P..-. l)
 50 |      in  C1 (Just (-co)) lin Nothing
 51 | 
 52 |   -- a == b <==> a - b == 0
 53 |   ceq l r
 54 |    = let (lin, co) = linear (r P..-. l)
 55 |      in  C1 (Just (-co)) lin (Just (-co))
 56 | 
 57 |   go (l P.:== r)
 58 |    = [ceq l r]
 59 |   go (l P.:<= r)
 60 |    = [cle l r]
 61 |   go (l P.:>= r)
 62 |    = [cle r l]
 63 | 
 64 |   -- We know from the type of :< that both sides are int.
 65 |   -- That means we can safely convert (a < b) to (a + 1 <= b)
 66 |   go (l P.:<  r)
 67 |    = [cle (l P..+. P.c1) r]
 68 |   go (l P.:>  r)
 69 |    = [cle (r P..+. P.c1) l]
 70 | 
 71 |   go (P.Between a b c)
 72 |    = [cle a b, cle b c]
 73 |   go (a P.:&& b)
 74 |    = go a ++ go b
 75 |   go (_ P.:! a)
 76 |    = go a
 77 | 
 78 |   go  P.CTrue
 79 |    = []
 80 | 
 81 | 
 82 | 
 83 | -- | Convert a Frontend 'P.Program' into a Canon 'Program'.
 84 | --
 85 | -- If we had a solve function that worked on either, it would ideally satisfy
 86 | -- @forall p. P.solve p == solve (program p)@
 87 | --
 88 | -- However, due to potential non-determinism in solving functions, it could be possible to get a different, but still optimal, solution:
 89 | --
 90 | -- > forall p. let aP = P.solve p
 91 | -- >                p' = program p
 92 | -- >                a  =   solve p'
 93 | -- >            in P.eval aP (P._objective p) == eval a (_objective p')
 94 | -- >            &&  check a (P._constraints p) && check ...
 95 | --
 96 | program :: (Rep c, Ord z, Ord r) => P.Program z r c -> Program z r c
 97 | program p
 98 |  = Program obj constr bnds
 99 |  where
100 | 
101 |   obj
102 |    = case P._direction p of
103 |         P.Minimise -> fst $ linear $       obj_orig
104 |         P.Maximise -> fst $ linear $ P.neg obj_orig
105 |   obj_orig
106 |    = P._objective p
107 | 
108 |   constr
109 |    = constraint $ P._constraints p
110 | 
111 |   bnds
112 |    = M.fromListWith mergeBounds
113 |    $ map extract
114 |    $ P._bounds p
115 | 
116 |   extract :: Rep c => P.Bounds z r c -> (Either z r, (Maybe (R c), Maybe (R c)))
117 |   extract (P.BoundZ (l,k,u))
118 |    = (Left k, (fromZ <$> l, fromZ <$> u))
119 |   extract (P.BoundR (l,k,u))
120 |    = (Right k, (l,u))
121 | 
122 | 
123 | 


--------------------------------------------------------------------------------
/src/Numeric/Limp/Canon/Linear.hs:
--------------------------------------------------------------------------------
 1 | -- | Representation of subset of linear functions: only variables and coefficients, no constant summand
 2 | module Numeric.Limp.Canon.Linear where
 3 | import Numeric.Limp.Rep
 4 | 
 5 | import qualified Data.Map as M
 6 | import qualified Data.Set as S
 7 | 
 8 | 
 9 | -- | Linear function is represented as a map from either a integral variable or an real variable, to a real coefficient.
10 | data Linear z r c
11 |  = Linear (M.Map (Either z r) (R c))
12 | 
13 | deriving instance (Ord z, Ord r, Rep c) => Eq (Linear z r c)
14 | deriving instance (Ord z, Ord r, Rep c) => Ord (Linear z r c)
15 | 
16 | -- | Create linear function from list of variables and coefficients
17 | mkLinear :: (Ord z, Ord r, Rep c)
18 |          => [(Either z r, R c)]
19 |          -> Linear z r c
20 | mkLinear zrs
21 |  = Linear (M.fromListWith (+) zrs)
22 | 
23 | 
24 | -- | Evaluate linear function with given assignment
25 | evalR :: (Rep c, Ord z, Ord r) => Assignment z r c -> Linear z r c -> R c
26 | evalR a (Linear ls)
27 |  = sum (map get $ M.toList ls)
28 |  where
29 |   get (l, co) = zrOf a l * co
30 | 
31 | 
32 | -- | Find set of all variables mentioned in function
33 | varsOfLinear :: (Ord z, Ord r) => Linear z r c -> S.Set (Either z r)
34 | varsOfLinear (Linear m)
35 |  = M.keysSet m
36 | 
37 | 


--------------------------------------------------------------------------------
/src/Numeric/Limp/Canon/Pretty.hs:
--------------------------------------------------------------------------------
 1 | module Numeric.Limp.Canon.Pretty where
 2 | import Numeric.Limp.Canon.Constraint
 3 | import Numeric.Limp.Canon.Linear
 4 | import Numeric.Limp.Canon.Program
 5 | import Numeric.Limp.Rep
 6 | 
 7 | import qualified Data.Map as M
 8 | import qualified Data.Set as S
 9 | import Data.Either
10 | 
11 | instance (Show (Z c), Show (R c), Rep c, Show z, Show r, Ord z, Ord r) => Show (Program z r c) where
12 |  show = ppr show show
13 | 
14 | ppr :: (Show (Z c), Show (R c), Rep c, Show z, Show r, Ord z, Ord r) => (z -> String) -> (r -> String) -> Program z r c -> String
15 | ppr pZ pR p
16 |  = unlines
17 |  [ "Minimize"
18 |  , indent $ pprL $ _objective p
19 |  , "Subject to"
20 |  , pprCs $ _constraints p
21 |  , "Bounds"
22 |  , pprBs $ _bounds p
23 |  , "Generals"
24 |  , pprGs $ varsOfProgram p
25 |  , "End" ]
26 | 
27 |  where
28 |   indent = ("\t"++)
29 | 
30 |   pprV v
31 |    = filter (/=' ') $ either pZ pR v
32 | 
33 |   pprL (Linear m)
34 |    = pprLf
35 |    $ M.toList m
36 | 
37 |   pprLf xs@((_,c): _)
38 |    | c < 0
39 |    = "-" ++ pprLfs xs
40 |   pprLf xs
41 |    = pprLfs xs
42 | 
43 |   pprLfs []
44 |    = ""
45 |   pprLfs [x]
46 |    = pprL1 x
47 |   pprLfs (x : rs@((_,c):_) )
48 |    =  pprL1 x
49 |    ++ (if c >= 0 then " + " else " - ")
50 |    ++ pprLfs rs
51 | 
52 |   pprL1 (v,c) = show (abs c) ++ " " ++ pprV v
53 | 
54 |   pprCs (Constraint cs)
55 |    = unlines $ map indent $ concatMap pprC cs
56 | 
57 |   pprC (C1 lo f up)
58 |    =  case lo of
59 |        Nothing  -> []
60 |        Just lo' -> [pprL f ++ " >= " ++ show lo']
61 |    ++ case up of
62 |        Nothing  -> []
63 |        Just up' -> [pprL f ++ " <= " ++ show up']
64 | 
65 |   pprLo (Just l)
66 |    = show l ++ " <= "
67 |   pprLo Nothing
68 |    = ""
69 | 
70 |   pprUp (Just l)
71 |    = " <= " ++ show l
72 |   pprUp Nothing
73 |    = ""
74 | 
75 |   pprBs m
76 |    = unlines $ map (indent.pprB) $ M.toList m
77 | 
78 |   pprB (v, (lo,up))
79 |    = pprLo lo ++ pprV v ++ pprUp up
80 | 
81 |   pprGs fvs
82 |    = unlines $ map pprV
83 |    $ filter isLeft
84 |    $ S.toList fvs
85 | 
86 | 


--------------------------------------------------------------------------------
/src/Numeric/Limp/Canon/Program.hs:
--------------------------------------------------------------------------------
 1 | -- | Canon representation of linear program
 2 | module Numeric.Limp.Canon.Program where
 3 | 
 4 | import Numeric.Limp.Canon.Linear
 5 | import Numeric.Limp.Canon.Constraint
 6 | import Numeric.Limp.Rep
 7 | 
 8 | import Data.Map (Map)
 9 | import qualified Data.Map as M
10 | import Data.Set (Set)
11 | import qualified Data.Set as S
12 | 
13 | -- | A program represented by objective, constraints and bounds.
14 | -- There is no need for an optimisation direction; the objective is just negated.
15 | data Program z r c
16 |  = Program
17 |    { _objective     :: Linear z r c
18 |    , _constraints   :: Constraint z r c
19 |    , _bounds        :: Map (Either z r) (Maybe (R c), Maybe (R c))
20 |    }
21 | 
22 | 
23 | -- | Find set of all variables mentioned in program
24 | varsOfProgram :: (Ord z, Ord r) => Program z r c -> Set (Either z r)
25 | varsOfProgram p
26 |  = S.unions
27 |  [ varsOfLinear     $ _objective   p
28 |  , varsOfConstraint $ _constraints p
29 |  , M.keysSet        $ _bounds      p ]
30 | 
31 | 
32 | -- | Merge some lower and upper bounds
33 | mergeBounds :: Rep c => (Maybe (R c), Maybe (R c)) -> (Maybe (R c), Maybe (R c)) -> (Maybe (R c), Maybe (R c))
34 | mergeBounds (l1,u1) (l2,u2)
35 |  = ( mmaybe max l1 l2
36 |    , mmaybe min u1 u2 )
37 |  where
38 |   mmaybe f a b
39 |    = case (a,b) of
40 |     (Nothing, Nothing)
41 |      -> Nothing
42 |     (Nothing, Just b')
43 |      -> Just $ b'
44 |     (Just a', Nothing)
45 |      -> Just $ a'
46 |     (Just a', Just b')
47 |      -> Just $ f a' b'
48 | 
49 | 
50 | -- | Check whether an assignment satisfies the program's constraints and bounds
51 | checkProgram :: (Rep c, Ord z, Ord r) => Assignment z r c -> Program z r c -> Bool
52 | checkProgram a p
53 |  =  check a (_constraints p)
54 |  && checkBounds a (_bounds p)
55 | 
56 | checkBounds :: (Rep c, Ord z, Ord r) => Assignment z r c -> Map (Either z r) (Maybe (R c), Maybe (R c)) -> Bool
57 | checkBounds ass bs
58 |  =  M.foldr (&&) True (M.mapWithKey checkB bs)
59 |  where
60 |   checkB k (lo,up)
61 |    = let v = zrOf ass k
62 |      in maybe True (<=v) lo
63 |      && maybe True (v<=) up
64 |      
65 | 
66 | 


--------------------------------------------------------------------------------
/src/Numeric/Limp/Canon/Simplify.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE CPP #-}
 2 | -- | Perform some simple optimisations on program
 3 | module Numeric.Limp.Canon.Simplify where
 4 | import Numeric.Limp.Canon.Program
 5 | import Numeric.Limp.Rep
 6 | import Numeric.Limp.Error
 7 | 
 8 | import Numeric.Limp.Canon.Analyse.Constants
 9 | 
10 | import Numeric.Limp.Canon.Simplify.Bounder
11 | import Numeric.Limp.Canon.Simplify.Crunch
12 | import Numeric.Limp.Canon.Simplify.Subst
13 | 
14 | #if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,11,0)
15 | import Data.Semigroup
16 | #endif
17 | 
18 | simplify :: (Ord z, Ord r, Rep c) => Program z r c -> Either Infeasible (Assignment z r c, Program z r c)
19 | simplify p
20 |  = simplify' mempty p
21 | 
22 | simplify' :: (Ord z, Ord r, Rep c) => Assignment z r c -> Program z r c -> Either Infeasible (Assignment z r c, Program z r c)
23 | simplify' sub1 p
24 |  = do  let p'   = crunchProgram    p
25 |        p''  <- bounderProgram   p'
26 |        sub2 <- constantsProgram p''
27 |        if   assSize sub2 == 0
28 |        then return (sub1, p'')
29 |        else simplify' (sub1 <> sub2) (substProgram sub2 p'')
30 | 
31 | 
32 | 


--------------------------------------------------------------------------------
/src/Numeric/Limp/Canon/Simplify/Bounder.hs:
--------------------------------------------------------------------------------
 1 | -- | Convert linear constraints that only mention one variable to bounds
 2 | module Numeric.Limp.Canon.Simplify.Bounder where
 3 | import Numeric.Limp.Canon.Constraint
 4 | import Numeric.Limp.Canon.Linear
 5 | import Numeric.Limp.Canon.Program
 6 | import Numeric.Limp.Rep
 7 | import Numeric.Limp.Error
 8 | 
 9 | import Data.Either
10 | import qualified Data.Map as M
11 | 
12 | type Bound z r c = (Either z r, (Maybe (R c), Maybe (R c)))
13 | 
14 | 
15 | -- | Convert a single constraint into a bound, if possible.
16 | --
17 | -- > bounder $ Constraint (5 <= y <= 10)
18 | -- > == Bound (Just 5) y (Just 10)
19 | --
20 | -- > bounder $ Constraint (5 <= 2y <= 10)
21 | -- > == Bound (Just 2.5) y (Just 5)
22 | --
23 | -- > bounder $ Constraint (10 <= 2y <= 5)
24 | -- > == Left InfeasibleBoundEmpty
25 | --
26 | bounderConstraint1 :: (Ord z, Ord r, Rep c) => Constraint1 z r c -> Either Infeasible (Maybe (Bound z r c))
27 | bounderConstraint1 (C1 low (Linear mf) upp)
28 |  | M.size mf == 1
29 |  , [(k,c)]   <- M.toList mf
30 |  , c /= 0
31 |  = let fixup = (/ c)
32 |        low'  = fmap fixup low
33 |        upp'  = fmap fixup upp
34 |        bounds
35 |         | c >= 0
36 |         = (low',upp')
37 |         | otherwise
38 |         = (upp',low')
39 | 
40 |        valid
41 |         | (Just lo, Just hi) <- bounds
42 |         = lo <= hi
43 |         | otherwise
44 |         = True
45 | 
46 |    in  if  valid
47 |        then Right $ Just (k, bounds)
48 |        else Left InfeasibleNotIntegral
49 | 
50 |  | otherwise
51 |  = Right Nothing
52 |    
53 | 
54 | bounderConstraint :: (Ord z, Ord r, Rep c) => Constraint z r c -> Either Infeasible (Constraint z r c, [Bound z r c])
55 | bounderConstraint (Constraint cs)
56 |  = do   (cs', bs) <- partitionEithers <$> mapM bounderC cs
57 |         return      (Constraint cs', bs)
58 |  where
59 |   bounderC c
60 |    = do c' <- bounderConstraint1 c
61 |         return $ case c' of
62 |             Nothing -> Left c
63 |             Just b  -> Right b
64 |    
65 | 
66 | -- 
67 | bounderProgram :: (Ord z, Ord r, Rep c) => Program z r c -> Either Infeasible (Program z r c)
68 | bounderProgram p
69 |  = do   (c',bs) <- bounderConstraint $ _constraints p
70 |         return $ p
71 |             { _constraints = c'
72 |             , _bounds      = foldl merge (_bounds p) bs }
73 |  where
74 |   merge m (k,v)
75 |    = case M.lookup k m of
76 |      Just v'
77 |       -> M.insert k (mergeBounds v' v) m
78 |      Nothing
79 |       -> M.insert k                 v  m
80 | 
81 | 


--------------------------------------------------------------------------------
/src/Numeric/Limp/Canon/Simplify/Crunch.hs:
--------------------------------------------------------------------------------
 1 | -- | Crunch together all constraints with same linear function
 2 | module Numeric.Limp.Canon.Simplify.Crunch where
 3 | import Numeric.Limp.Canon.Constraint
 4 | import Numeric.Limp.Canon.Program
 5 | import Numeric.Limp.Rep
 6 | 
 7 | import Data.List
 8 | import Data.Function
 9 | import Data.Maybe
10 | 
11 | -- | Crunch the constraints in some program
12 | crunchProgram :: (Ord z, Ord r, Rep c) => Program z r c -> Program z r c
13 | crunchProgram p
14 |  = p { _constraints = crunchConstraint $ _constraints p }
15 | 
16 | -- | Crunch some constraints.
17 | -- Constraints with the same function, for example
18 | --
19 | -- >              2x + y    < 5
20 | -- > &&   0 <     2x + y
21 | -- > &&           2x + y    < 10
22 | --
23 | -- becomes
24 | --
25 | -- >      0 <     2x + y    < 5
26 | --
27 | -- This should satisfy:
28 | --
29 | -- > forall a c. check a c == check a (crunchConstraint c)
30 | -- > forall a.   length (checkConstraint c) <= length c
31 | --
32 | crunchConstraint :: (Ord z, Ord r, Rep c) => Constraint z r c -> Constraint z r c
33 | crunchConstraint (Constraint cs)
34 |  = Constraint
35 |  $ map crunchC
36 |  $ groupBy ((==) `on` getLin) cs
37 |  where
38 |   getLin (C1 _   lin _  ) = lin
39 |   getLow (C1 low _   _  ) = low
40 |   getUpp (C1 _   _   upp) = upp
41 | 
42 |   crunchC grp@(c:_)
43 |    = let low = compareMaybes maximum $ map getLow grp
44 |          upp = compareMaybes minimum $ map getUpp grp
45 |      in  C1 low (getLin c) upp
46 | 
47 |   crunchC []
48 |    = error "Impossible - groupBy should not produce empty lists"
49 | 
50 |   compareMaybes f ms
51 |    = case catMaybes ms of
52 |       ms'@(_:_) -> Just $ f ms'
53 |       []        -> Nothing
54 | 
55 | 


--------------------------------------------------------------------------------
/src/Numeric/Limp/Canon/Simplify/Subst.hs:
--------------------------------------------------------------------------------
  1 | -- | Substitute an assignment into functions, constraints and programs
  2 | module Numeric.Limp.Canon.Simplify.Subst where
  3 | import Numeric.Limp.Canon.Constraint
  4 | import Numeric.Limp.Canon.Linear
  5 | import Numeric.Limp.Canon.Program
  6 | import Numeric.Limp.Rep
  7 | 
  8 | import qualified Data.Map as M
  9 | 
 10 | 
 11 | -- | Substitute assignment into linear function.
 12 | -- However, 'Linear' isn't quite a linear function! That is, it doesn't have a constant summand.
 13 | -- So we must return the constant summand we lose.
 14 | --
 15 | -- Satisfies:
 16 | --
 17 | -- > forall a b f.
 18 | -- > let (f', c') = substLinear a f
 19 | -- > in  eval (a <> b) f == eval b f' + c'
 20 | --
 21 | -- > subst (x := 5) in 2x + y
 22 | -- > (y, 10)
 23 | --
 24 | substLinear :: (Ord z, Ord r, Rep c) => Assignment z r c -> Linear z r c -> (Linear z r c, R c)
 25 | substLinear (Assignment mz mr) (Linear mf)
 26 |  = ( Linear $ M.fromList $ concatMap update mf'
 27 |    ,          sum        $ map       getC   mf' )
 28 |  where
 29 |   mf' = M.toList mf
 30 | 
 31 |   get (v,co)
 32 |    | Left  z <- v
 33 |    , Just zv <- M.lookup z mz
 34 |    = Just $ fromZ zv * co
 35 |    | Right r <- v
 36 |    , Just rv <- M.lookup r mr
 37 |    = Just $       rv * co
 38 | 
 39 |    | otherwise
 40 |    = Nothing
 41 | 
 42 |   update vc
 43 |    | Just _ <- get vc
 44 |    = []
 45 |    | otherwise
 46 |    = [vc]
 47 | 
 48 |   getC vc
 49 |    | Just n <- get vc
 50 |    = n
 51 |    | otherwise
 52 |    = 0
 53 | 
 54 | 
 55 | -- | Substitute assignment into a single linear constraint.
 56 | -- See 'substConstraint'.
 57 | --
 58 | -- > 5 <= 2x + y <= 10
 59 | -- > subst (y := 3)
 60 | -- > 2 <= 2x     <= 7
 61 | --
 62 | substConstraint1 :: (Ord z, Ord r, Rep c) => Assignment z r c -> Constraint1 z r c -> Constraint1 z r c
 63 | substConstraint1 ass (C1 low lin upp)
 64 |  = let (lin', const') = substLinear ass lin
 65 |        fixup bound    = bound - const'
 66 |    in C1 (fmap fixup low) lin' (fmap fixup upp)
 67 | 
 68 | 
 69 | -- | Substitute assignment into a set of linear constraints.
 70 | -- Satisfies:
 71 | --
 72 | -- > forall a b f.
 73 | -- > let c' = substConstraint a c
 74 | -- > in  check (a <> b) c == check b c'
 75 | --
 76 | -- > subst (x := 5) in 15 <= 2x + y <= 20
 77 | -- > 5 <= y <= 10
 78 | --
 79 | substConstraint :: (Ord z, Ord r, Rep c) => Assignment z r c -> Constraint z r c -> Constraint z r c
 80 | substConstraint ass (Constraint cs)
 81 |  = Constraint
 82 |  $ map (substConstraint1 ass) cs
 83 | 
 84 | 
 85 | -- | Substitute assignment into a program.
 86 | -- What does this satisfy? Hm.
 87 | substProgram :: (Ord z, Ord r, Rep c) => Assignment z r c -> Program z r c -> Program z r c
 88 | substProgram ass@(Assignment mz mr) p
 89 |  = p
 90 |  { _objective   = fst $ substLinear     ass $ _objective   p
 91 |  , _constraints =       substConstraint ass $ _constraints p
 92 |  , _bounds      =       cullBounds          $ _bounds      p
 93 |  }
 94 |  where
 95 |   cullBounds
 96 |    = M.mapMaybeWithKey cullB
 97 | 
 98 |   cullB k v
 99 | 
100 |    | Left  z <- k
101 |    , Just  _ <- M.lookup z mz
102 |    = Nothing
103 |    | Right r <- k
104 |    , Just  _ <- M.lookup r mr
105 |    = Nothing
106 | 
107 |    | otherwise
108 |    = Just v
109 | 
110 | 
111 | 


--------------------------------------------------------------------------------
/src/Numeric/Limp/Error.hs:
--------------------------------------------------------------------------------
 1 | -- | Reasons an analysis, simplification or solution could fail
 2 | module Numeric.Limp.Error where
 3 | 
 4 | -- | Give reason for being infeasible, if possible
 5 | data Infeasible
 6 |  = InfeasibleNotIntegral
 7 |  -- ^ An integer variable is constrained to be equal to a non-int
 8 |  | InfeasibleBoundEmpty
 9 |  -- ^ The bound on a variable or constraint is empty - lower bound is above upper.
10 |  deriving (Eq,Show)
11 | 


--------------------------------------------------------------------------------
/src/Numeric/Limp/Program.hs:
--------------------------------------------------------------------------------
 1 | -- | Front-end representation of programs.
 2 | -- See 'Numeric.Limp.Program.Program.Program' for the entire program;
 3 | -- 'Numeric.Limp.Program.Constraint.Constraint' for constraints such as less than or equal, greater than, etc;
 4 | -- and 'Numeric.Limp.Program.Linear.Linear' for linear functions.
 5 | module Numeric.Limp.Program
 6 |     ( -- | Each variable can have a lower or upper bound.
 7 |       module Numeric.Limp.Program.Bounds
 8 |       -- | Constraints such as less than or equal, greater than or equal, between,...
 9 |     , module Numeric.Limp.Program.Constraint
10 |       -- | Functions for evaluating linear functions constraints for a given assignment of variables.
11 |     , module Numeric.Limp.Program.Eval
12 |       -- | Linear functions with constant coefficients on variables, and a constant addition.
13 |     , module Numeric.Limp.Program.Linear
14 |       -- | An entire program.
15 |     , module Numeric.Limp.Program.Program
16 |       -- | Linear functions are classified as either int-valued or real-valued,
17 |       -- so we define @KZ@ and @KR@ as data kinds to denote this in the type.
18 |     , module Numeric.Limp.Program.ResultKind
19 |     ) where
20 | 
21 | import Numeric.Limp.Program.Bounds
22 | import Numeric.Limp.Program.Constraint
23 | import Numeric.Limp.Program.Eval
24 | import Numeric.Limp.Program.Linear
25 | import Numeric.Limp.Program.Program
26 | import Numeric.Limp.Program.ResultKind
27 | 
28 | 


--------------------------------------------------------------------------------
/src/Numeric/Limp/Program/Bounds.hs:
--------------------------------------------------------------------------------
 1 | -- | Define upper and lower bounds of program variables.
 2 | module Numeric.Limp.Program.Bounds where
 3 | import Numeric.Limp.Rep
 4 | 
 5 | -- | Define upper and lower bounds of program variables.
 6 | -- Bounds may be specified multiple times: the intersection of all bounds is used.
 7 | data Bounds z r c
 8 |  = BoundZ (B (Z c) z)
 9 |  | BoundR (B (R c) r)
10 | 
11 | deriving instance (Show z, Show r, Show (Z c), Show (R c)) => (Show (Bounds z r c))
12 | 
13 | -- | Maybe a lower bound, the variable's name, and maybe an upper bound.
14 | type B rep v
15 |  = (Maybe rep, v, Maybe rep)
16 | 
17 | -- | Create a lower and upper bound for an integer variable.
18 | lowerUpperZ :: Rep c => Z c -> z -> Z c -> Bounds z r c
19 | lowerUpperZ l v u
20 |  = BoundZ (Just l, v, Just u)
21 | 
22 | -- | Create only a lower bound for an integer variable. 
23 | lowerZ :: Rep c => Z c -> z -> Bounds z r c
24 | lowerZ l v
25 |  = BoundZ (Just l, v, Nothing)
26 | 
27 | -- | Create only an upper bound for an integer variable. 
28 | upperZ :: Rep c => z -> Z c -> Bounds z r c
29 | upperZ v u
30 |  = BoundZ (Nothing, v, Just u)
31 | 
32 | -- | A binary integer variable: can only be @0@ or @1@.
33 | binary :: Rep c => z -> Bounds z r c
34 | binary v
35 |  = BoundZ (Just 0, v, Just 1)
36 | 
37 | -- | Create a lower and upper bound for a real variable.
38 | lowerUpperR :: Rep c => R c -> r -> R c -> Bounds z r c
39 | lowerUpperR l v u
40 |  = BoundR (Just l, v, Just u)
41 | 
42 | -- | Create only a lower bound for a real variable. 
43 | lowerR :: Rep c => R c -> r -> Bounds z r c
44 | lowerR l v
45 |  = BoundR (Just l, v, Nothing)
46 | 
47 | -- | Create only an upper bound for a real variable. 
48 | upperR :: Rep c => r -> R c -> Bounds z r c
49 | upperR v u
50 |  = BoundR (Nothing, v, Just u)
51 | 
52 | 
53 | 


--------------------------------------------------------------------------------
/src/Numeric/Limp/Program/Constraint.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE CPP #-}
 2 | module Numeric.Limp.Program.Constraint where
 3 | import Numeric.Limp.Program.Linear
 4 | import Numeric.Limp.Program.ResultKind
 5 | import Numeric.Limp.Rep
 6 | 
 7 | #if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,11,0)
 8 | import Data.Semigroup
 9 | #endif
10 | 
11 | -- | Different kind of constraints.
12 | --
13 | -- These are not all necessary, but I have a hunch that keeping some structure may be helpful in the future.
14 | --
15 | -- Constructors:
16 | --
17 | --   [@:==@]    Equality constraint
18 | --
19 | --   [@:<=@]    Less than or equal
20 | --
21 | --   [@:<@]     Strictly less than: this is only allowed for purely integer functions
22 | --
23 | --   [@:>=@]    Greater than or equal
24 | --
25 | --   [@:>@]     Strictly greater than: this is only allowed for purely integer functions
26 | --
27 | --   [@Between@] @Between a b c@ is equivalent to @a :<= b :&& b :<= c@
28 | --
29 | --   [@:&&@]    Conjunction of two constraints
30 | --
31 | --   [@:!@]     @"name" :! constr@ Annotate a constraint with a name, or other useless information
32 | --
33 | --   [@CTrue@]  Trivially true constraint
34 | --
35 | 
36 | data Constraint z r c where
37 |  (:==)   :: Linear z r c k1  -> Linear z r c k2  -> Constraint z r c
38 |  (:<=)   :: Linear z r c k1  -> Linear z r c k2  -> Constraint z r c
39 |  (:<)    :: Linear z r c 'KZ -> Linear z r c 'KZ -> Constraint z r c
40 |  (:>=)   :: Linear z r c k1  -> Linear z r c k2  -> Constraint z r c
41 |  (:>)    :: Linear z r c 'KZ -> Linear z r c 'KZ -> Constraint z r c
42 |  Between :: Linear z r c k1  -> Linear z r c k2  -> Linear z r c k3   -> Constraint z r c
43 |  (:&&)   :: Constraint z r c -> Constraint z r c -> Constraint z r c
44 |  (:!)    :: String           -> Constraint z r c -> Constraint z r c
45 |  CTrue   ::                                         Constraint z r c
46 | 
47 | deriving instance (Show z, Show r, Show (Z c), Show (R c)) => (Show (Constraint z r c))
48 | 
49 | infix  5 :==
50 | infix  5 :<=
51 | infix  5 :<
52 | infix  5 :>=
53 | infix  5 :>
54 | infix  4 :!
55 | infixr 3 :&&
56 | 
57 | instance Semigroup (Constraint z r c) where
58 |  (<>) = (:&&)
59 | 
60 | instance Monoid (Constraint z r c) where
61 |  mempty  = CTrue
62 |  mappend = (:&&)
63 | 


--------------------------------------------------------------------------------
/src/Numeric/Limp/Program/Eval.hs:
--------------------------------------------------------------------------------
 1 | -- | Functions for evaluating linear functions and checking constraints.
 2 | module Numeric.Limp.Program.Eval where
 3 | import Numeric.Limp.Rep
 4 | import Numeric.Limp.Program.Bounds
 5 | import Numeric.Limp.Program.Constraint
 6 | import Numeric.Limp.Program.Linear
 7 | import Numeric.Limp.Program.Program
 8 | import Numeric.Limp.Program.ResultKind
 9 | 
10 | -- | Evaluate a linear function with given assignment.
11 | -- If the linear function is purely integral, a @Z@ will be returned; otherwise, @R@.
12 | eval :: (Rep c, Ord z, Ord r) => Assignment z r c -> Linear z r c k -> KRep k c
13 | eval a (LZ ls c)
14 |  = sum (map get ls) + c
15 |  where
16 |   get (l, co) = zOf a l * co
17 | 
18 | eval a (LR ls c)
19 |  = sum (map get ls) + c
20 |  where
21 |   get (l, co) = zrOf a l * co
22 | 
23 | 
24 | -- | Evaluate a linear function with given assignment, returning real value.
25 | evalR :: (Rep c, Ord z, Ord r) => Assignment z r c -> Linear z r c k -> R c
26 | evalR a l@(LZ{}) = fromZ (eval a l)
27 | evalR a l@(LR{}) =        eval a l
28 | 
29 | 
30 | -- | Check whether assignment satisfies constraint.
31 | check :: (Rep c, Ord z, Ord r) => Assignment z r c -> Constraint z r c -> Bool
32 | check ass = go
33 |  where
34 |   go (a :== b)
35 |    = evalR ass a == evalR ass b
36 |   go (a :<= b)
37 |    = evalR ass a <= evalR ass b
38 |   go (a :>= b)
39 |    = evalR ass a >= evalR ass b
40 | 
41 |   -- They are both ints, so no conversion to R is necessary
42 |   go (a :<  b)
43 |    = eval  ass a <  eval  ass b
44 |   go (a :>  b)
45 |    = eval  ass a >  eval  ass b
46 | 
47 |   go (Between a b c)
48 |    = evalR ass a <= evalR ass b && evalR ass b <= evalR ass c
49 |   go (a :&& b)
50 |    = go a && go b
51 |   go (_ :! a)
52 |    = go a
53 | 
54 |   go CTrue
55 |    = True
56 | 
57 | -- | Check whether an assignment satisfies the program's constraints and bounds
58 | checkProgram :: (Rep c, Ord z, Ord r) => Assignment z r c -> Program z r c -> Bool
59 | checkProgram a p
60 |  =  check a (_constraints p)
61 |  && checkBounds a (_bounds p)
62 | 
63 | checkBounds :: (Rep c, Ord z, Ord r) => Assignment z r c -> [Bounds z r c] -> Bool
64 | checkBounds ass bs
65 |  = all checkB bs
66 |  where
67 |   checkB (BoundZ (lo,z',up))
68 |    = checkBo (zOf ass z') lo up
69 |   checkB (BoundR (lo,r',up))
70 |    = checkBo (rOf ass r') lo up
71 | 
72 |   checkBo v lo up
73 |    =  maybe True (<=v) lo
74 |    && maybe True (v<=) up
75 |      
76 | 
77 | 


--------------------------------------------------------------------------------
/src/Numeric/Limp/Program/Linear.hs:
--------------------------------------------------------------------------------
  1 | -- | Representation, constructors and limited arithmetic on linear functions.
  2 | --
  3 | -- The linear function is indexed by its result type: either purely integer (@KZ@) or mixed/real (@KR@).
  4 | -- This index is used to allow strictly-less-than constraints only on integer functions,
  5 | -- and to allow retrieving integer values from purely integer functions.
  6 | --
  7 | module Numeric.Limp.Program.Linear
  8 |     ( Linear(..)
  9 |     , toR
 10 | 
 11 |     , z, z1
 12 |     , r, r1
 13 | 
 14 |     , con, conZ, conR
 15 |     , c0, c1
 16 | 
 17 |     , neg
 18 |     , (.*), (*.)
 19 |     , (.+.), (.-.) )
 20 |      where
 21 | import Numeric.Limp.Rep
 22 | import Numeric.Limp.Program.ResultKind
 23 | 
 24 | -- | Any linear function can be converted into a real linear function.
 25 | toR :: Rep c => Linear z r c k -> Linear z r c 'KR
 26 | toR (LZ ls co) = LR (map go ls) (fromZ co)
 27 |  where
 28 |   go (z',c') = (Left z', fromZ c')
 29 | toR l@(LR{}) =        l
 30 | 
 31 | 
 32 | -- | Integral variable
 33 | z :: Rep c => z -> Z c -> Linear z r c 'KZ
 34 | z z' c
 35 |  = LZ [(z', c)] 0
 36 | 
 37 | -- | Integral variable with coefficient 1
 38 | z1 :: Rep c => z -> Linear z r c 'KZ
 39 | z1 z'
 40 |  = z z' 1
 41 | 
 42 | -- | Real variable
 43 | r :: Rep c => r -> R c -> Linear z r c 'KR
 44 | r r' c
 45 |  = LR [(Right r', c)] 0
 46 | 
 47 | -- | Real variable with coefficient 1
 48 | r1 :: Rep c => r -> Linear z r c 'KR
 49 | r1 r'
 50 |  = r r' 1
 51 | 
 52 | 
 53 | -- | An integral constant summand
 54 | con :: Rep c => Z c -> Linear z r c 'KZ
 55 | con c'
 56 |  = LZ [] c'
 57 | 
 58 | -- | An integral constant summand
 59 | conZ :: Rep c => Z c -> Linear z r c 'KZ
 60 | conZ = con
 61 | 
 62 | -- | Constant @0@
 63 | c0 :: Rep c => Linear z r c 'KZ
 64 | c0 = con 0
 65 | -- | Constant @1@
 66 | c1 :: Rep c => Linear z r c 'KZ
 67 | c1 = con 1
 68 | 
 69 | -- | A real constant
 70 | conR :: Rep c => R c -> Linear z r c 'KR
 71 | conR c'
 72 |  = LR [] c'
 73 | 
 74 | -- | Helper for applying function to second element of tuple
 75 | on2 :: (b -> c) -> (a, b) -> (a, c)
 76 | on2 f (a,b) = (a, f b)
 77 | 
 78 | -- | Negate a linear function.
 79 | -- Negation does not change the kind.
 80 | neg :: Rep c => Linear z r c k -> Linear z r c k
 81 | neg (LZ ls c)
 82 |  = LZ (map (on2 negate) ls) (negate c)
 83 | neg (LR ls c)
 84 |  = LR (map (on2 negate) ls) (negate c)
 85 | 
 86 | 
 87 | -- | Multiply a linear function by some constant.
 88 | --
 89 | -- Note that you cannot multiply a linear function by another linear function, as the result would likely be non-linear!
 90 | (.*) :: Rep c => Linear z r c k -> KRep k c -> Linear z r c k
 91 | (.*) (LZ ls c) z'
 92 |  = LZ (map (on2 (*z')) ls) (c * z')
 93 | (.*) (LR ls c) r'
 94 |  = LR (map (on2 (*r')) ls) (c * r')
 95 | 
 96 | -- | Multiply a linear function by some constant.
 97 | (*.) :: Rep c => KRep k c -> Linear z r c k -> Linear z r c k
 98 | (*.) = flip (.*)
 99 | 
100 | 
101 | -- | Add two linear functions together. They can have different result types.
102 | (.+.) :: Rep c => Linear z r c k1 -> Linear z r c k2 -> Linear z r c (KMerge k1 k2)
103 | (.+.) a b
104 |  = case (a,b) of
105 |     (LZ{}, LZ{}) -> add_KZ      a      b
106 |     (LR{}, LZ{}) -> add_KR      a (toR b)
107 |     (LZ{}, LR{}) -> add_KR (toR a)     b
108 |     (LR{}, LR{}) -> add_KR      a      b
109 |  where
110 |   add_KZ :: Rep c => Linear z r c 'KZ -> Linear z r c 'KZ -> Linear z r c 'KZ
111 |   add_KZ (LZ ls lc) (LZ rs rc) = LZ (ls ++ rs) (lc + rc)
112 | 
113 |   add_KR :: Rep c => Linear z r c 'KR -> Linear z r c 'KR -> Linear z r c 'KR
114 |   add_KR (LR ls lc) (LR rs rc) = LR (ls ++ rs) (lc + rc)
115 | 
116 | 
117 | 
118 | -- | Subtract one linear function from another. They can have different result types.
119 | (.-.) :: Rep c => Linear z r c k1 -> Linear z r c k2 -> Linear z r c (KMerge k1 k2)
120 | (.-.) a b
121 |  = a .+. neg b
122 | 
123 | 
124 | infix  7 *.
125 | infix  7 .*
126 | infixl 6 .+.
127 | infixl 6 .-.
128 | 
129 | 


--------------------------------------------------------------------------------
/src/Numeric/Limp/Program/Program.hs:
--------------------------------------------------------------------------------
 1 | -- | Definition of a whole program
 2 | module Numeric.Limp.Program.Program where
 3 | 
 4 | import Numeric.Limp.Program.Bounds
 5 | import Numeric.Limp.Program.Constraint
 6 | import Numeric.Limp.Program.Linear
 7 | import Numeric.Limp.Program.ResultKind
 8 | import Numeric.Limp.Rep
 9 | 
10 | -- | Direction to optimise program in: minimise or maximise.
11 | data Direction
12 |  = Minimise
13 |  | Maximise
14 |    deriving Show
15 | 
16 | -- | Whole program, parameterised by:
17 | --
18 | --   [@z@] type of integer variables
19 | --   [@r@] type of real variables
20 | --   [@c@] representation of integers and reals (see 'Numeric.Limp.Rep.Rep')
21 | --
22 | data Program z r c
23 |  = Program {
24 |    -- | Optimisation direction
25 |      _direction     :: Direction
26 |    -- | The objective function
27 |    , _objective     :: Linear z r c 'KR
28 |    -- | All constraints bundled up with @:&&@.
29 |    , _constraints   :: Constraint z r c
30 |    -- | Upper and lower bounds of variables.
31 |    -- Not all variables need to be mentioned, and if variables are mentioned multiple times, the intersection is used.
32 |    , _bounds        :: [Bounds z r c]
33 |    }
34 | 
35 | deriving instance (Show z, Show r, Show (Z c), Show (R c)) => (Show (Program z r c))
36 | 
37 | program :: Rep c => Direction -> Linear z r c k -> Constraint z r c -> [Bounds z r c] -> Program z r c
38 | program dir obj constr bounds
39 |  = Program dir (toR obj) constr bounds
40 | 
41 | minimise :: Rep c => Linear z r c k -> Constraint z r c -> [Bounds z r c] -> Program z r c
42 | minimise
43 |  = program Minimise
44 |  
45 | 
46 | maximise :: Rep c => Linear z r c k -> Constraint z r c -> [Bounds z r c] -> Program z r c
47 | maximise
48 |  = program Maximise
49 | 
50 | 


--------------------------------------------------------------------------------
/src/Numeric/Limp/Program/ResultKind.hs:
--------------------------------------------------------------------------------
 1 | -- | Type-level functions on result types.
 2 | --
 3 | -- Linear functions are classified as either int-valued or real-valued,
 4 | -- so we define @KZ@ and @KR@ as data kinds to denote this in the type.
 5 | --
 6 | module Numeric.Limp.Program.ResultKind where
 7 | import Numeric.Limp.Rep
 8 | 
 9 | 
10 | -- | Classify the result type of a linear function to either integral or real:
11 | data K
12 |  -- | Integral @Z@
13 |  = KZ
14 |  -- | Real or mixed @R@
15 |  | KR
16 | 
17 | 
18 | -- | Representation of either integral of real linear functions:
19 | -- a list of variables with coefficients, plus a constant summand.
20 | data Linear z r c k where
21 |  LZ :: [(z, Z c)]          -> (Z c) -> Linear z r c 'KZ
22 |  LR :: [(Either z r, R c)] -> (R c) -> Linear z r c 'KR
23 | 
24 | deriving instance (Show z, Show r, Show (Z c), Show (R c)) => (Show (Linear z r c k))
25 | 
26 | 
27 | -- | Find the result type of merging, or adding, two linear functions:
28 | -- adding two integers produces an integer, while adding a real on either side produces a real.
29 | type family KMerge (a :: K) (b :: K) :: K where
30 |  KMerge 'KZ 'KZ = 'KZ
31 |  KMerge 'KR  b  = 'KR
32 |  KMerge  a  'KR = 'KR
33 | 
34 | -- | Convert a @K@ to its actual representation (@Z@ or @R@).
35 | type family KRep (a :: K) :: * -> * where
36 |  KRep 'KZ = Z
37 |  KRep 'KR = R
38 | 
39 | 
40 | 
41 | 


--------------------------------------------------------------------------------
/src/Numeric/Limp/Rep.hs:
--------------------------------------------------------------------------------
 1 | -- | Representation of integers (Z) and reals (R) of similar precision.
 2 | -- Programs are abstracted over this, so that ideally in the future we could have a
 3 | -- solver that produces Integers and Rationals, instead of just Ints and Doubles.
 4 | --
 5 | -- We bundle Z and R up into a single representation instead of abstracting over both,
 6 | -- because we must be able to convert from Z to R without loss.
 7 | --
 8 | module Numeric.Limp.Rep
 9 |     ( module Numeric.Limp.Rep.Rep
10 |     , module Numeric.Limp.Rep.IntDouble )
11 |     where
12 | 
13 | import Numeric.Limp.Rep.Rep
14 | import Numeric.Limp.Rep.IntDouble
15 | 
16 | 


--------------------------------------------------------------------------------
/src/Numeric/Limp/Rep/Arbitrary.hs:
--------------------------------------------------------------------------------
 1 | -- | Arbitrary precision number representation
 2 | module Numeric.Limp.Rep.Arbitrary where
 3 | import Numeric.Limp.Rep.Rep
 4 | 
 5 | -- | A representation that uses arbitrary-sized Integers and Rationals
 6 | data Arbitrary
 7 | 
 8 | instance Rep Arbitrary where
 9 |  -- | Automatically defer numeric operations to the native int.
10 |  newtype Z Arbitrary = Z Integer
11 |     deriving (Ord,Eq,Integral,Real,Num,Enum)
12 |  newtype R Arbitrary = R Rational
13 |     deriving (Ord,Eq,Num,Enum,Fractional,Real,RealFrac)
14 | 
15 | -- | Define show manually, so we can strip out the "Z" and "R" prefixes.
16 | instance Show (Z Arbitrary) where
17 |  show (Z i) = show i
18 | 
19 | instance Show (R Arbitrary) where
20 |  show (R i) = show i
21 | 
22 | 
23 | 


--------------------------------------------------------------------------------
/src/Numeric/Limp/Rep/IntDouble.hs:
--------------------------------------------------------------------------------
 1 | -- | Fixed/floating precision number representation
 2 | module Numeric.Limp.Rep.IntDouble where
 3 | import Numeric.Limp.Rep.Rep
 4 | 
 5 | -- | A representation that uses native 64-bit ints and 64-bit doubles.
 6 | -- Really, this should be 32-bit ints.
 7 | data IntDouble
 8 | 
 9 | instance Rep IntDouble where
10 |  -- | Automatically defer numeric operations to the native int.
11 |  newtype Z IntDouble = Z Int
12 |     deriving (Ord,Eq,Integral,Real,Num,Enum)
13 |  newtype R IntDouble = R Double
14 |     deriving (Ord,Eq,Num,Enum,Fractional,Real,RealFrac)
15 | 
16 | -- | Define show manually, so we can strip out the "Z" and "R" prefixes.
17 | instance Show (Z IntDouble) where
18 |  show (Z i) = show i
19 | 
20 | instance Show (R IntDouble) where
21 |  show (R i) = show i
22 | 
23 | 
24 | 
25 | -- | Convert a wrapped (R IntDouble) to an actual Double.
26 | unwrapR :: R IntDouble -> Double
27 | unwrapR (R d) = d
28 | 
29 | 
30 | 


--------------------------------------------------------------------------------
/src/Numeric/Limp/Rep/Rep.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE CPP #-}
 2 | -- | Representation of integers (Z) and reals (R) of similar precision.
 3 | -- Programs are abstracted over this, so that ideally in the future we could have a
 4 | -- solver that produces Integers and Rationals, instead of just Ints and Doubles.
 5 | --
 6 | -- We bundle Z and R up into a single representation instead of abstracting over both,
 7 | -- because we must be able to convert from Z to R without loss.
 8 | --
 9 | module Numeric.Limp.Rep.Rep where
10 | 
11 | import Data.Map (Map)
12 | import qualified Data.Map as M
13 | 
14 | #if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,11,0)
15 | import Data.Semigroup
16 | #endif
17 | 
18 | -- | The Representation class. Requires its members @Z c@ and @R c@ to be @Num@, @Ord@ and @Eq@.
19 | --
20 | -- For some reason, for type inference to work, the members must be @data@ instead of @type@.
21 | -- This gives some minor annoyances when unpacking them. See 'unwrapR' below.
22 | --
23 | class ( Num (Z c), Ord (Z c), Eq (Z c), Integral (Z c)
24 |       , Num (R c), Ord (R c), Eq (R c), RealFrac (R c)) => Rep c where
25 | 
26 |  -- | Integers
27 |  data Z c
28 |  -- | Real numbers
29 |  data R c
30 | 
31 |  -- | Convert an integer to a real. This should not lose any precision.
32 |  -- (whereas @fromIntegral 1000 :: Word8@ would lose precision)
33 |  fromZ :: Z c -> R c
34 |  fromZ = fromIntegral
35 | 
36 | 
37 | -- | An assignment from variables to values.
38 | -- Maps integer variables to integers, and real variables to reals.
39 | data Assignment z r c
40 |  = Assignment (Map z (Z c)) (Map r (R c))
41 | 
42 | deriving instance (Show (Z c), Show (R c), Show z, Show r) => Show (Assignment z r c)
43 | 
44 | instance (Ord z, Ord r) => Semigroup (Assignment z r c) where
45 |  (<>) = mappend
46 | 
47 | instance (Ord z, Ord r) => Monoid (Assignment z r c) where
48 |  mempty = Assignment M.empty M.empty
49 |  mappend (Assignment z1 r1) (Assignment z2 r2)
50 |   = Assignment (M.union z1 z2) (M.union r1 r2)
51 | 
52 | 
53 | -- | Retrieve value of integer variable - or 0, if there is no value.
54 | zOf :: (Rep c, Ord z) => Assignment z r c -> z -> Z c
55 | zOf (Assignment zs _) z
56 |  = maybe 0 id $ M.lookup z zs
57 | 
58 | -- | Retrieve value of real variable - or 0, if there is no value.
59 | rOf :: (Rep c, Ord r) => Assignment z r c -> r -> R c
60 | rOf (Assignment _ rs) r
61 |  = maybe 0 id $ M.lookup r rs
62 | 
63 | -- | Retrieve value of an integer or real variable, with result cast to a real regardless.
64 | zrOf :: (Rep c, Ord z, Ord r) => Assignment z r c -> Either z r -> R c
65 | zrOf a = either (fromZ . zOf a) (rOf a)
66 | 
67 | assSize :: Assignment z r c -> Int
68 | assSize (Assignment mz mr)
69 |  = M.size mz + M.size mr
70 | 


--------------------------------------------------------------------------------
/src/Numeric/Limp/Solve/Branch/Simple.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE CPP #-}
 2 | -- | The simplest, stupidest possible branch and bound algorithm.
 3 | --
 4 | --
 5 | module Numeric.Limp.Solve.Branch.Simple
 6 |     (branch, makeIntegral)
 7 |     where
 8 | import Numeric.Limp.Canon.Program
 9 | import Numeric.Limp.Canon.Simplify
10 | import Numeric.Limp.Rep
11 | 
12 | import Control.Monad
13 | import qualified Data.Map as M
14 | 
15 | #if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,11,0)
16 | import Data.Semigroup
17 | #endif
18 | 
19 | branch
20 |     :: (Ord z, Ord r, Rep c)
21 |     => (Program z r c -> Maybe (Assignment () (Either z r) c, R c))
22 |     -> Program z r c
23 |     -> Maybe (Assignment z r c, R c)
24 | branch solver start_prog
25 |  = go mempty start_prog
26 |  where
27 |   go ass p
28 |    -- TODO:
29 |    -- simp can actually change the objective function
30 |    -- because Canon doesn't store a constant summand on the objective.
31 |    -- we really need to return the modified summand and take that into account when
32 |    -- choosing between two integer assignments.
33 |    | Right (ass', p') <- simplify' ass p
34 |    = do  (assRelax,co) <- solver p'
35 |          case makeIntegral assRelax of
36 |           Left (var, val)
37 |            -> branchon p' ass' (Left var) val
38 |           Right r
39 |            -> Just (ass' <> r, co)
40 |    | otherwise
41 |    = Nothing
42 | 
43 |   branchon p ass var val
44 |    = let lo = addBound p var (Just (fromZ $ truncate val + 1), Nothing)
45 |          up = addBound p var (Nothing, Just (fromZ $ truncate val))
46 |          loB     = go ass lo
47 |          upB     = go ass up
48 |      in case (loB, upB) of
49 |         (Just (a1, o1), Just (a2, o2))
50 |          | o1 > o2
51 |          -> Just (a1, o1)
52 |          | otherwise
53 |          -> Just (a2, o2)
54 |         (Just r, Nothing)
55 |          -> Just r
56 |         (Nothing, Just r)
57 |          -> Just r
58 |         (Nothing, Nothing)
59 |          -> Nothing
60 |      
61 | 
62 |   addBound p v b
63 |    = let bs = _bounds p
64 |          b' = maybe (Nothing,Nothing) id
65 |             $ M.lookup v bs
66 |      in  p { _bounds = M.insert v (mergeBounds b b') bs }
67 | 
68 | makeIntegral
69 |     :: (Ord z, Ord r, Rep c)
70 |     => Assignment () (Either z r) c
71 |     -> Either (z, R c)
72 |               (Assignment z r c)
73 | makeIntegral (Assignment _ vs)
74 |  =   uncurry Assignment
75 |  <$> foldM go (M.empty, M.empty) (M.toList vs)
76 |  where
77 |   go (zs,rs) (var, val)
78 |    = case var of
79 |       Right r
80 |        -> return (zs, M.insert r val rs)
81 |       Left z
82 |        | val' <- truncate val
83 |        , val == fromZ val'
84 |        -> return (M.insert z val' zs, rs)
85 |        | otherwise
86 |        -> Left (z, val)
87 | 
88 | 


--------------------------------------------------------------------------------
/src/Numeric/Limp/Solve/Simplex/Maps.hs:
--------------------------------------------------------------------------------
  1 | -- | The simplest, stupidest possible simplex algorithm.
  2 | -- The idea here is to be slow, but "obviously correct" so other algorithms
  3 | -- can be verified against it.
  4 | --
  5 | -- That's the plan, at least. For now this is just a first cut of trying to implement simplex.
  6 | --
  7 | module Numeric.Limp.Solve.Simplex.Maps
  8 |     where
  9 | import Numeric.Limp.Rep
 10 | 
 11 | import Numeric.Limp.Solve.Simplex.StandardForm
 12 | 
 13 | import Control.Arrow
 14 | import qualified Data.Map as M
 15 | import Data.Function (on)
 16 | import Data.List (minimumBy, sortBy)
 17 | 
 18 | 
 19 | -- | Result of a single pivot attempt
 20 | data IterateResult z r c
 21 |     -- | Maximum reached!
 22 |     = Done
 23 |     -- | Pivot was made
 24 |     | Progress (Standard z r c)
 25 |     -- | No progress can be made: unbounded along the objective
 26 |     | Stuck
 27 | 
 28 | deriving instance (Show z, Show r, Show (R c)) => Show (IterateResult z r c)
 29 | 
 30 | 
 31 | -- | Try to find a pivot and then perform it.
 32 | -- We're assuming, at this stage, that the existing solution is feasible.
 33 | simplex1 :: (Ord z, Ord r, Rep c)
 34 |         => Standard z r c -> IterateResult z r c
 35 | simplex1 s
 36 |  -- Check if there are any positive columns in the objective:
 37 |  = case pivotCols of
 38 |     -- if there are none, we are already at the maximum
 39 |     []
 40 |      -> Done
 41 |     -- there are some; try to find the first pivot row that works
 42 |     _
 43 |      -> go pivotCols
 44 |  where
 45 | 
 46 |   -- Check if there's any row worth pivoting on for this column.
 47 |   -- We're trying to see if we can increase the value of this
 48 |   -- column's variable from zero.
 49 |   go ((pc,_):pcs)
 50 |    = case pivotRowForCol s pc of
 51 |        Nothing -> go pcs
 52 |        Just pr
 53 |         -> Progress
 54 |         -- Perform the pivot.
 55 |         -- This moves the variable pr out of the basis, and pc into the basis.
 56 |          $ pivot s (pr,pc)
 57 | 
 58 |   -- We've tried all the pivot columns and failed.
 59 |   -- This means there's no edge we can take to increase our objective,
 60 |   -- so it must be unbounded.
 61 |   go []
 62 |    = Stuck
 63 | 
 64 | 
 65 |   -- We want to find some positive column from the objective.
 66 |   -- In fact, find all of them and order descending.
 67 |   pivotCols
 68 |    = let ls  = M.toList $ fst $ _objective s
 69 |          kvs = sortBy (compare `on` (negate . snd)) ls
 70 |      in  filter ((>0) . snd) kvs
 71 | 
 72 | 
 73 | -- | Find pivot row for given column.
 74 | -- We're trying to find a way to increase the value of
 75 | -- column from zero, and the returned row will be decreased to zero.
 76 | -- Since all variables are >= 0, we cannot return a row that would set the column to negative.
 77 | pivotRowForCol :: (Ord z, Ord r, Rep c)
 78 |         => Standard z r c
 79 |         -> StandardVar z r
 80 |         -> Maybe (StandardVar z r)
 81 | pivotRowForCol s col
 82 |  = fmap   fst
 83 |  $ minBy' (compare `on` snd)
 84 |  $ concatMap (\(n,r)
 85 |            -> let rv = lookupRow r col
 86 |                   o  = objOfRow  r
 87 |               in if    rv > 0
 88 |                  then [(n, o / rv)]
 89 |                  else [])
 90 |  $ M.toList
 91 |  $ _constraints s
 92 | 
 93 | -- | Find minimum, or nothing if empty
 94 | minBy' :: (a -> a -> Ordering) -> [a] -> Maybe a
 95 | minBy' _ []
 96 |  = Nothing
 97 | minBy' f ls
 98 |  = Just $ minimumBy f ls
 99 | 
100 | 
101 | -- | Perform pivot for given row and column.
102 | -- We normalise row so that row.column = 1
103 | --
104 | -- > norm = row / row[column]
105 | --
106 | -- Then, for all other rows including the objective,
107 | -- we want to make sure its column entry is zero:
108 | --
109 | -- > row' = row - row[column]*norm
110 | --
111 | -- In the end, this means "column" will be an identity column, or a basis column.
112 | --
113 | pivot   :: (Ord z, Ord r, Rep c)
114 |         => Standard z r c
115 |         -> (StandardVar z r, StandardVar z r)
116 |         -> Standard z r c
117 | pivot s (pr,pc)
118 |  = let norm = normaliseRow
119 |        -- All other rows
120 |        rest = filter ((/=pr) . fst) $ M.toList $ _constraints s
121 |    in Standard
122 |     { _constraints = M.fromList ((pc, norm) : map (id *** fixup norm) rest)
123 |     , _objective   = fixup norm $ _objective s
124 |     , _substs      = _substs s }
125 |  where
126 |   -- norm = row / row[column]
127 |   normaliseRow
128 |    | Just row@(rm, ro) <- M.lookup pr $ _constraints s
129 |    = let c' = lookupRow row pc
130 |      in  (M.map (/c') rm, ro / c')
131 | 
132 |    -- Pivot would not be chosen if row doesn't exist..
133 |    | otherwise
134 |    = (M.empty, 0)
135 | 
136 |   -- row' = row - row[column]*norm
137 |   fixup (nm,no) row@(rm,ro)
138 |    = let co = lookupRow row pc
139 |      in  {- row' = row - co*norm -}
140 |          ( M.unionWith (+) rm (M.map ((-co)*) nm)
141 |          , ro - co * no )
142 | 
143 | 
144 | -- | Single phase of simplex.
145 | -- Keep repeating until no progress can be made.
146 | single_simplex :: (Ord z, Ord r, Rep c)
147 |         => Standard z r c -> Maybe (Standard z r c)
148 | single_simplex s
149 |  = case simplex1 s of
150 |     Done        -> Just     s
151 |     Progress s' -> single_simplex  s'
152 |     Stuck       -> Nothing
153 | 
154 | 
155 | -- | Two phase:
156 | --  first, find a satisfying solution.
157 | --  then, solve simplex as normal.
158 | simplex
159 |         :: (Ord z, Ord r, Rep c)
160 |         => Standard z r c -> Maybe (Standard z r c)
161 | simplex s
162 |  =   find_initial_sat s
163 |  >>= single_simplex
164 | 
165 | -- | Find a satisfying solution.
166 | --   if there are any rows with negative values, this means their basic values are negative
167 | --   (which is not satisfying the x >= 0 constraint)
168 | --   these negative-valued rows must be pivoted around using modified pivot criteria
169 | find_initial_sat
170 |         :: (Ord z, Ord r, Rep c)
171 |         => Standard z r c -> Maybe (Standard z r c)
172 | find_initial_sat s
173 |  = case negative_val_rows of
174 |     []      -> Just s
175 |     rs      -> go rs
176 |  where
177 |   -- Find all rows with negative values
178 |   -- because their current value is not feasible
179 |   negative_val_rows
180 |    = filter ((<0) . objOfRow . snd)
181 |    $ M.toList
182 |    $ _constraints s
183 | 
184 |   -- Find largest negative (closest to zero) to pivot on:
185 |   -- pivoting on a negative will negate the value, setting it to positive
186 |   min_of_row (_,(rm,_))
187 |    = minBy' (compare `on` (negate . snd))
188 |    $ filter ((<0) . snd)
189 |    $ M.toList rm
190 | 
191 | 
192 |   -- There is no feasible solution
193 |   go []
194 |    = Nothing
195 | 
196 |   -- Try pivoting on the rows 
197 |   go (r:rs)
198 |    | Just (pc,_) <- min_of_row r
199 |    , Just  pr    <- pivotRowForNegatives pc
200 |    = simplex
201 |    $ pivot s (pr, pc)
202 | 
203 |    | otherwise
204 |    = go rs
205 | 
206 |   -- opposite of pivotRowForCol...
207 |   pivotRowForNegatives col
208 |    = fmap   fst
209 |    $ minBy' (compare `on` (negate . snd))
210 |    $ concatMap (\(n,r)
211 |              -> let rv = lookupRow r col
212 |                     o  = objOfRow  r
213 |                 in if    rv < 0
214 |                    then [(n, o / rv)]
215 |                    else [])
216 |    $ M.toList
217 |    $ _constraints s
218 | 
219 | 
220 |   
221 | 
222 | -- Get map of each constraint's value
223 | assignmentAll :: (Rep c)
224 |         => Standard z r c
225 |         -> (M.Map (StandardVar z r) (R c), R c)
226 | assignmentAll s
227 |  = ( M.map    val (_constraints s)
228 |    , objOfRow     (_objective  s))
229 |  where
230 |   val (_, v)
231 |    = v
232 | 
233 | -- Perform reverse substitution on constraint values
234 | -- to get original values (see StandardForm)
235 | assignment
236 |         :: (Ord z, Ord r, Rep c)
237 |         => Standard z r c
238 |         -> (Assignment () (Either z r) c, R c)
239 | assignment s
240 |  = ( Assignment M.empty $ M.union vs' rs'
241 |    , o )
242 |  where
243 |   (vs, o) = assignmentAll s
244 | 
245 |   vs'     = M.fromList
246 |           $ concatMap only_svs
247 |           $ M.toList vs
248 | 
249 |   rs'     = M.map eval $ _substs s
250 | 
251 |   eval (lin,co)
252 |           = M.foldr (+) co
253 |           $ M.mapWithKey (\k r -> r * (maybe 0 id $ M.lookup k vs))
254 |           $ lin
255 | 
256 |   only_svs (SV v, val)
257 |    = [(v, val)]
258 |   only_svs _
259 |    = []
260 | 
261 | 
262 | 
263 | -- Junk ---------------
264 | 
265 | -- | Minimise whatever variables are 'basic' in given standard
266 | -- input must not already have an objective row "SVO",
267 | -- because the existing objective is added as a new row with that name
268 | minimise_basics
269 |         :: (Ord z, Ord r, Rep c)
270 |         => Standard z r c -> Standard z r c
271 | minimise_basics s
272 |  = s
273 |  { _objective   = (M.map (const (1)) $ _constraints s, 0)
274 |  , _constraints = M.insert SVO (_objective s) (_constraints s)
275 |  }
276 | 
277 | -- | Find the basic variables and "price them out" of the objective function,
278 | -- by subtracting multiples of the basic row from objective
279 | pricing_out 
280 |         :: (Ord z, Ord r, Rep c)
281 |         => Standard z r c -> Standard z r c
282 | pricing_out s
283 |  = s
284 |  { _objective = M.foldrWithKey  go
285 |                     (_objective   s)
286 |                     (_constraints s)
287 |  }
288 |  where
289 |   go v row@(rm,ro) obj@(om,oo)
290 |    | coeff <- lookupRow obj v
291 |    , coeff /= 0
292 |    , rowv  <- lookupRow row v
293 |    , mul   <- -(coeff / rowv)
294 |    = -- rowv = 1
295 |      -- obj' = obj - (coeff/rowv)*row
296 |      ( M.unionWith (+) om (M.map (mul*) rm)
297 |      , oo + mul*ro )
298 |    | otherwise
299 |    = obj
300 | 
301 | -- | Pull the previously-hidden objective out of constraints, and use it
302 | drop_fake_objective
303 |         :: (Ord z, Ord r, Rep c)
304 |         => Standard z r c -> Standard z r c
305 | drop_fake_objective s
306 |  | cs     <- _constraints s
307 |  , Just o <- M.lookup SVO cs
308 |  = s
309 |  { _objective   = o
310 |  , _constraints = M.delete SVO cs }
311 | 
312 |  | otherwise
313 |  = s
314 | 
315 | 
316 | 
317 | 


--------------------------------------------------------------------------------
/src/Numeric/Limp/Solve/Simplex/StandardForm.hs:
--------------------------------------------------------------------------------
  1 | -- | Standard form for programs: only equalities and all variables >= 0
  2 | -- To convert an arbitrary program to this form, we need to:
  3 | --
  4 | -- Convert unconstrained (-inf <= x <= +inf) variable into two separate parts, x+ and x-
  5 | --  wherever x occurs, it will be replaced with "x+" - "x-".
  6 | --
  7 | -- Convert variables with non-zero lower bounds (c <= x) to a new variable x', so that
  8 | --  x = x' + c
  9 | --
 10 | -- The opposite of these conversions must be performed when extracting a variable assignment
 11 | -- from the solved program.
 12 | --
 13 | -- All constraints are converted into a less-than with a constant on the right, and then
 14 | -- these less-than constraints (f <= c) have a slack variable s added such that
 15 | --  f + s == c && s >= 0
 16 | --
 17 | module Numeric.Limp.Solve.Simplex.StandardForm
 18 |     where
 19 | import Numeric.Limp.Rep
 20 | import Numeric.Limp.Canon.Constraint
 21 | import Numeric.Limp.Canon.Linear
 22 | import qualified Numeric.Limp.Canon.Program as C
 23 | 
 24 | import qualified Data.Map as M
 25 | import qualified Data.Set as S
 26 | 
 27 | 
 28 | -- | A single linear function with a constant summand
 29 | type StandardRow z r c
 30 |     = (StandardLinear z r c, R c)
 31 | 
 32 | -- | Entire program in standard form, as well as substitutions required to extract an assignment
 33 | data Standard z r c
 34 |     = Standard
 35 |     { _objective   :: StandardRow z r c
 36 |     , _constraints :: M.Map (StandardVar z r) (StandardRow z r c)
 37 |     , _substs      :: StandardSubst z r c
 38 |     }
 39 | deriving instance (Show z, Show r, Show (R c)) => Show (Standard z r c)
 40 | 
 41 | type StandardSubst  z r c
 42 |     = M.Map (Either z r) (StandardRow z r c)
 43 | 
 44 | type StandardLinear z r c
 45 |     = M.Map (StandardVar z r) (R c)
 46 | 
 47 | data StandardVar z r
 48 |     -- | A normal variable
 49 |     = SV (Either z r)
 50 | 
 51 |     -- | A slack variable, introduced to make less-eq constraints into equalities
 52 |     | SVS Int
 53 |     -- | Magic objective, used when hiding an existing objective as a constraint
 54 |     -- and creating a new objective
 55 |     | SVO 
 56 | 
 57 |     -- | When a variable has a lower bound other than 0, we replace all occurences with
 58 |     -- with a new version minus the lower bound.
 59 |     -- x >= 5
 60 |     -- ==>
 61 |     -- Lx - 5 >= 5
 62 |     -- ==>
 63 |     -- Lx >= 0
 64 |     | SVLower (Either z r)
 65 | 
 66 |     -- | When unconstrained variables are encountered, they are replaced with
 67 |     -- x = SVPos x - SVNeg x
 68 |     -- so both parts can be constrained to >= 0.
 69 |     | SVPos (Either z r)
 70 |     | SVNeg (Either z r)
 71 |     deriving (Eq, Ord, Show)
 72 | 
 73 | 
 74 | -- | Sum a list of linear functions together
 75 | addLinears
 76 |     :: (Ord z, Ord r, Rep c)
 77 |     => [(StandardLinear z r c, R c)] -> (StandardLinear z r c, R c)
 78 | addLinears []
 79 |  = (M.empty, 0)
 80 | addLinears ((lin,co):rs)
 81 |  = let (lin',co') = addLinears rs
 82 |    in  (M.unionWith (+) lin lin', co + co')
 83 | 
 84 | 
 85 | -- | Perform substitution over a linear function/row
 86 | substLinear
 87 |     :: (Ord z, Ord r, Rep c)
 88 |     => StandardSubst z r c -> (StandardLinear z r c, R c) -> (StandardLinear z r c, R c)
 89 | substLinear sub (lin, co)
 90 |  = let (lin', co') = addLinears 
 91 |                    $ map subby 
 92 |                    $ M.toList lin
 93 |    in (lin', co + co')
 94 |  where
 95 |   subby (var, coeff)
 96 |    = case var of
 97 |       SV s
 98 |        | Just (vs,cnst) <- M.lookup s sub
 99 |        -> (M.map (*coeff) vs, -cnst * coeff)
100 |       _
101 |        -> (M.fromList [(var, coeff)], 0)
102 | 
103 | 
104 | -- | Convert canon program into standard form
105 | standard :: (Ord z, Ord r, Rep c)
106 |         => C.Program z r c
107 |         -> Standard z r c
108 | standard p
109 |  = Standard
110 |  { _objective   = objective
111 |  , _constraints = constraints
112 |  , _substs      = substs }
113 |  where
114 |   fv = C.varsOfProgram p
115 |   bs = C._bounds p
116 | 
117 |   -- Objective is just negated
118 |   objective
119 |    = substLinear substs
120 |     ( M.map negate
121 |       $ standardOfLinear $ C._objective p
122 |     , 0)
123 | 
124 |   -- Constraints are created for original program's bounds and constraints
125 |   -- and substitution is performed.
126 |   -- Each constraint/row receives its own slack variable.
127 |   constraints
128 |    = M.fromList
129 |    $ zipWith (\c s -> (s, substLinear substs $ c s))
130 |    ( constrs ++ bounds )
131 |    ( map SVS [1..] )
132 | 
133 |   -- Union of all substitutions
134 |   substs
135 |    = M.fromList
136 |    $ concatMap substOf
137 |    $ S.toList fv
138 | 
139 |   -- Substitution for "x" ==> "x+" - "x-"
140 |   negPos v
141 |    = [(v, (M.fromList [(SVPos v, 1), (SVNeg v, -1)], 0))]
142 | 
143 |   -- Look at bounds of variables and decide
144 |   substOf v
145 |    = case M.lookup v bs of
146 |      -- Unconstrained, so it can be negative
147 |      Nothing
148 |       -> negPos v
149 |      Just (Nothing, Nothing)
150 |       -> negPos v
151 |      Just (Just 0, _)
152 |       -> []
153 |      -- Nonzero lower bound, so replace: v = v' + n
154 |      Just (Just n, _)
155 |       -> [(v, (M.fromList [(SVLower v, 1)], n)) ]
156 |      _
157 |       -> []
158 | 
159 |   bounds
160 |    = concatMap linearOfBound
161 |    $ M.toList
162 |    $ C._bounds p
163 | 
164 |   linearOfBound (v,binds)
165 |    = case binds of
166 |      (_, Just n)
167 |       -> [\s -> (M.fromList [(SV v, 1), (s, 1)], n)]
168 |      _
169 |       -> []
170 | 
171 |   Constraint cs = C._constraints p
172 |   constrs
173 |    = concatMap linearOfConstraint cs
174 |   linearOfConstraint (C1 lo lin up)
175 |    = let lin' = standardOfLinear lin
176 |    in case (lo,up) of
177 |       (Nothing,Nothing)
178 |        -> []
179 |       (Just lo', Nothing)
180 |        -> [ lt lo' lin' ]
181 |       (Nothing,  Just up')
182 |        -> [ gt up' lin' ]
183 |       (Just lo', Just up')
184 |        -> [ lt lo' lin'
185 |           , gt up' lin' ]
186 | 
187 | 
188 |   lt lo lin s
189 |    = ( M.union (M.map negate lin) (M.fromList [(s,1)])
190 |      , negate lo )
191 |   gt up lin s
192 |    = ( M.union lin (M.fromList [(s, 1)])
193 |      , up )
194 | 
195 |   standardOfLinear (Linear lin)
196 |    = M.mapKeysMonotonic SV lin
197 | 
198 | 
199 | --- 5 <= x1 <= 40
200 | -- ==>
201 | -- x1 subst Lx1+5
202 | -- Lx1 + 5 <= 40
203 | -- ==>
204 | -- Lx1 <= 35
205 | 
206 | -- assignmentOfMap :: Standard z r c -> M.Map (StandardVar z r) (R c) -> Assignment z r c
207 | 
208 | 
209 | 
210 | -- Simple helpers ----------
211 | 
212 | -- | Get the coefficient of a variable in given row
213 | lookupRow :: (Ord z, Ord r, Rep c)
214 |     => StandardRow z r c
215 |     -> StandardVar z r
216 |     -> R c
217 | lookupRow (r,_) v
218 |  = case M.lookup v r of
219 |     Nothing -> 0
220 |     Just vv -> vv
221 | 
222 | -- | Get objective or basis value of a row
223 | objOfRow
224 |     :: StandardRow z r c
225 |     -> R c
226 | objOfRow = snd
227 | 
228 | 


--------------------------------------------------------------------------------
/tests/Arbitrary/Assignment.hs:
--------------------------------------------------------------------------------
 1 | module Arbitrary.Assignment where
 2 | 
 3 | import Numeric.Limp.Rep
 4 | 
 5 | import Arbitrary.Var
 6 | 
 7 | import Test.QuickCheck
 8 | import Control.Applicative
 9 | import Data.Map (fromList)
10 | 
11 | type Assignment' = Assignment ZVar RVar IntDouble
12 | 
13 | instance Arbitrary (Z IntDouble) where
14 |  arbitrary = Z <$> arbitrary
15 | 
16 | instance Arbitrary (R IntDouble) where
17 |  arbitrary = R <$> (fromIntegral <$> (arbitrary :: Gen Int))
18 | 
19 | 
20 | instance Arbitrary (Assignment ZVar RVar IntDouble) where
21 |  arbitrary = arbitrary >>= assignment
22 | 
23 | 
24 | assignment :: Vars -> Gen Assignment'
25 | assignment (Vars zs rs)
26 |  = do   zs' <- listOf (elements zs)
27 |         zvs <- infiniteListOf arbitrary
28 | 
29 |         rs' <- listOf (elements rs)
30 |         rvs <- infiniteListOf arbitrary
31 | 
32 |         return $ Assignment (fromList $ zs' `zip` zvs) (fromList $ rs' `zip` rvs)
33 | 
34 | 


--------------------------------------------------------------------------------
/tests/Arbitrary/Program.hs:
--------------------------------------------------------------------------------
 1 | module Arbitrary.Program where
 2 | 
 3 | import qualified Numeric.Limp.Program as P
 4 | import Numeric.Limp.Rep
 5 | 
 6 | import Arbitrary.Var
 7 | import Arbitrary.Assignment
 8 | 
 9 | import Test.QuickCheck
10 | import Control.Applicative
11 | 
12 | type Program' = P.Program ZVar RVar IntDouble
13 | 
14 | data ProgramAss = ProgramAss Program' Assignment'
15 |  deriving Show
16 | 
17 | instance Arbitrary ProgramAss where
18 |  arbitrary
19 |   = do  a <- arbitrary
20 |         ProgramAss <$> program a <*> assignment a
21 | 
22 | instance Arbitrary Program' where
23 |  arbitrary = arbitrary >>= program
24 | 
25 | 
26 | program :: Vars -> Gen Program'
27 | program vs
28 |  = do   dir  <- elements [P.Minimise, P.Maximise]
29 |         
30 |         obj  <- linearR        vs
31 |         cons <- constraints    vs
32 |         bnds <- listOf (bounds vs)
33 | 
34 |         return $ P.program dir obj cons bnds
35 | 
36 | 
37 | linearR :: Vars -> Gen (P.Linear ZVar RVar IntDouble P.KR)
38 | linearR (Vars zs rs)
39 |  = do   let vs = map Left zs ++ map Right rs
40 |         vs' <- listOf1 (elements vs)
41 |         cs' <- infiniteListOf arbitrary
42 |         summand <- arbitrary
43 |         return $ P.LR (vs' `zip` cs') summand
44 | 
45 | linearZ :: Vars -> Gen (P.Linear ZVar RVar IntDouble P.KZ)
46 | linearZ (Vars zs _rs)
47 |  = do   vs' <- listOf1 (elements zs)
48 |         cs' <- infiniteListOf arbitrary
49 |         summand <- arbitrary
50 |         return $ P.LZ (vs' `zip` cs') summand
51 | 
52 | 
53 | constraints :: Vars -> Gen (P.Constraint ZVar RVar IntDouble)
54 | constraints vs
55 |  = oneof
56 |  [ (P.:==)   <$> lR <*> lR
57 |  , (P.:<=)   <$> lR <*> lR
58 |  , (P.:<)    <$> lZ <*> lZ
59 |  , (P.:>=)   <$> lR <*> lR
60 |  , (P.:>)    <$> lZ <*> lZ
61 |  , P.Between <$> lR <*> lR <*> lR
62 |  , (P.:&&)   <$> constraints vs <*> constraints vs
63 |  , return P.CTrue ]
64 |  where
65 |   lR = linearR vs
66 |   lZ = linearZ vs
67 | 
68 | 
69 | bounds :: Vars -> Gen (P.Bounds ZVar RVar IntDouble)
70 | bounds (Vars zs rs)
71 |  = oneof [bZ, bR]
72 |  where
73 |   bZ = do   v <- elements zs
74 |             a <- arbitrary
75 |             b <- arbitrary
76 |             return $ P.BoundZ (a,v,b)
77 | 
78 |   bR = do   v <- elements rs
79 |             a <- arbitrary
80 |             b <- arbitrary
81 |             return $ P.BoundR (a,v,b)
82 | 
83 | 


--------------------------------------------------------------------------------
/tests/Arbitrary/Var.hs:
--------------------------------------------------------------------------------
 1 | module Arbitrary.Var where
 2 | import Test.QuickCheck
 3 | 
 4 | data ZVar = ZVar String
 5 |  deriving (Eq,Ord)
 6 | 
 7 | instance Show ZVar where
 8 |  show (ZVar z) = "z$" ++ z
 9 | 
10 | instance Arbitrary ZVar where
11 |  arbitrary
12 |         -- 26 variables should be enough for anyone!
13 |   = do  c <- elements ['a'..'z']
14 |         return $ ZVar [c]
15 | 
16 | 
17 | data RVar = RVar String
18 |  deriving (Eq,Ord)
19 | 
20 | instance Show RVar where
21 |  show (RVar r) = "r$" ++ r
22 | 
23 | instance Arbitrary RVar where
24 |  arbitrary
25 |   = do  c <- elements ['a'..'z']
26 |         return $ RVar [c]
27 | 
28 | 
29 | data Vars = Vars [ZVar] [RVar]
30 |  deriving Show
31 | 
32 | instance Arbitrary Vars where
33 |  arbitrary
34 |   = do  NonEmpty zs   <- arbitrary :: Gen (NonEmptyList ZVar)
35 |         NonEmpty rs   <- arbitrary :: Gen (NonEmptyList RVar)
36 |         return $ Vars zs rs
37 | 
38 | 
39 | 


--------------------------------------------------------------------------------
/tests/BranchExample.hs:
--------------------------------------------------------------------------------
 1 | module BranchExample where
 2 | 
 3 | import Numeric.Limp.Rep.Rep     as R
 4 | import Numeric.Limp.Rep.Arbitrary     as R
 5 | import Numeric.Limp.Program as P
 6 | import Numeric.Limp.Canon   as C
 7 | import Numeric.Limp.Solve.Simplex.Maps   as SM
 8 | import Numeric.Limp.Solve.Simplex.StandardForm   as ST
 9 | import Numeric.Limp.Solve.Branch.Simple  as B
10 | 
11 | import Numeric.Limp.Canon.Pretty
12 | import Debug.Trace
13 | 
14 | import Control.Applicative
15 | 
16 | -- Dead simple ones -------------------------
17 | -- x = 2
18 | prog1 :: P.Program String String R.Arbitrary
19 | prog1
20 |  = P.maximise
21 |     -- objective
22 |         (z "x" 1)
23 |     -- subject to
24 |      (   z "x"  2 :<= con 5
25 |      :&& z "x"  4 :>= con 7)
26 |     []
27 | 
28 | -- x = 1, y = 2
29 | prog2 :: P.Program String String R.Arbitrary
30 | prog2
31 |  = P.minimise
32 |     -- objective
33 |         (z "x" 1 .+. z "y" 1)
34 |     -- subject to
35 |      (   z "x"  2 :<= con 5 -- z "y" 1 .+. con 1
36 |      :&& z "x"  1 :>= con 1 
37 |      :&& z "y"  1 :<= con 4
38 |      :&& z "y"  1 :>= con 1)
39 |     [ lowerZ 0 "x" 
40 |     , lowerZ 0 "y" ]
41 | 
42 | 
43 | xkcd :: Direction -> P.Program String String R.Arbitrary
44 | xkcd dir = P.program dir
45 |            ( z1 mf .+.
46 |              z1 ff .+.
47 |              z1 ss .+.
48 |              z1 hw .+.
49 |              z1 ms .+.
50 |              z1 sp )
51 |            ( z mf mfp .+.
52 |              z ff ffp .+.
53 |              z ss ssp .+.
54 |              z hw hwp .+.
55 |              z ms msp .+.
56 |              z sp spp :== con 1505 )
57 |            [ lowerZ 0 mf
58 |            , lowerZ 0 ff
59 |            , lowerZ 0 ss
60 |            , lowerZ 0 hw
61 |            , lowerZ 0 ms
62 |            , lowerZ 0 sp
63 |             ]
64 |   where
65 |     (mf, mfp) = ("mixed-fruit",       215)
66 |     (ff, ffp) = ("french-fries",      275)
67 |     (ss, ssp) = ("side-salad",        335)
68 |     (hw, hwp) = ("hot-wings",         355)
69 |     (ms, msp) = ("mozzarella-sticks", 420)
70 |     (sp, spp) = ("sampler-plate",     580)
71 | 
72 | test :: (Show z, Show r, Ord z, Ord r)
73 |      => P.Program z r R.Arbitrary -> IO ()
74 | test prog
75 |  = let prog' = C.program prog
76 |        
77 |        simpl p = SM.simplex $ ST.standard p
78 | 
79 |        solver p
80 |         | st <- ST.standard p
81 |         -- , trace (ppr show show p) True
82 |         , Just s' <- SM.simplex st
83 |         -- , trace ("SAT") True
84 |         , ass <- SM.assignment s'
85 |          = Just ass
86 |         | otherwise
87 |         -- , trace ("unsat") True
88 |         = Nothing
89 |        bb    = B.branch solver
90 |    in  do   
91 |             -- putStrLn (show (simpl prog'))
92 |             -- putStrLn (show (solver prog'))
93 |             putStrLn (show (bb prog'))
94 | 
95 | 


--------------------------------------------------------------------------------
/tests/Convert.hs:
--------------------------------------------------------------------------------
 1 | module Convert where
 2 | 
 3 | import Numeric.Limp.Program as P
 4 | import Numeric.Limp.Canon   as C
 5 | 
 6 | import Arbitrary.Program
 7 | import Data.Monoid
 8 | 
 9 | import Test.Tasty.QuickCheck
10 | import Test.Tasty.TH
11 | 
12 | 
13 | tests = $(testGroupGenerator)
14 | 
15 | prop_constraints_converted :: ProgramAss -> Bool
16 | prop_constraints_converted (ProgramAss p a)
17 |  =  P.checkProgram a  p
18 |  == C.checkProgram a (C.program p)
19 | 
20 | 


--------------------------------------------------------------------------------
/tests/Main.hs:
--------------------------------------------------------------------------------
 1 | 
 2 | import Test.Tasty
 3 | 
 4 | import qualified Convert
 5 | import qualified Simplify
 6 | 
 7 | main = defaultMain properties
 8 | 
 9 | properties :: TestTree
10 | properties
11 |  = testGroup "Properties"
12 |  [ Convert.tests
13 |  , Simplify.tests
14 |  ]
15 | 
16 | 


--------------------------------------------------------------------------------
/tests/SimplexExample.hs:
--------------------------------------------------------------------------------
 1 | module SimplexExample where
 2 | 
 3 | import Numeric.Limp.Rep     as R
 4 | import Numeric.Limp.Program as P
 5 | import Numeric.Limp.Canon   as C
 6 | import Numeric.Limp.Solve.Simplex.Maps      as SM
 7 | import Numeric.Limp.Solve.Simplex.StandardForm  as ST
 8 | 
 9 | import Control.Monad
10 | import qualified Data.Map as M
11 | 
12 | 
13 | data Xs = X1 | X2 | X3
14 |  deriving (Eq, Ord, Show)
15 | 
16 | prog :: P.Program () Xs R.IntDouble
17 | prog
18 |  = P.maximise
19 |     -- objective
20 |         (r X1 60 .+. r X2  30 .+. r X3  20)
21 |     -- subject to
22 |      (   r X1  8 .+. r X2   6 .+. r X3   1 :<= con 48
23 |      :&& r X1  2 .+. r X2 1.5 .+. r X3 0.5 :<= con  8
24 |      :&& r X1  4 .+. r X2   2 .+. r X3 1.5 :<= con 20
25 |      :&&             r X2   1              :<= con  5)
26 |     -- bounds ommitted for now
27 |     [ lowerR 0 X1 , lowerR 0 X2 , lowerR 0 X3 ]
28 |     -- []
29 | 
30 | test :: IO Bool
31 | test
32 |  = case SM.simplex $ ST.standard $ C.program prog of
33 |    Nothing
34 |     -> do   putStrLn "Error: simplex returned Nothing"
35 |             putStrLn (show $ ST.standard $ C.program prog)
36 |             putStrLn (show $ SM.simplex1 $ ST.standard $ C.program prog)
37 |             return False
38 | 
39 |    Just s
40 |     -> do   let (Assignment _ vars,obj) = SM.assignment s
41 |             let vars'      = M.toList vars
42 |             let e_vars = [(Right X1, 2.0), (Right X3, 8.0)] :: [(Either () Xs, R IntDouble)]
43 |             let e_obj  = -280
44 |             putStrLn "Vars:"
45 |             putStrLn (show vars')
46 |             putStrLn "Obj:"
47 |             putStrLn (show obj)
48 | 
49 |             when (obj /= e_obj) $
50 |                 putStrLn ("Bad objective: should be " ++ show e_obj)
51 |             when (vars' /= e_vars) $
52 |                 putStrLn ("Bad vars: should be "      ++ show e_vars)
53 | 
54 |             return (obj == e_obj && vars' == e_vars)
55 | 
56 | 


--------------------------------------------------------------------------------
/tests/Simplexs.hs:
--------------------------------------------------------------------------------
  1 | module Simplexs where
  2 | 
  3 | import Numeric.Limp.Rep.Rep     as R
  4 | import Numeric.Limp.Rep.Arbitrary     as R
  5 | import Numeric.Limp.Program as P
  6 | import Numeric.Limp.Canon   as C
  7 | import Numeric.Limp.Solve.Simplex.Maps      as SM
  8 | import Numeric.Limp.Solve.Simplex.StandardForm  as ST
  9 | 
 10 | import qualified Data.Map as M
 11 | 
 12 | 
 13 | data Xs = X1 | X2 | X3
 14 |  deriving (Eq, Ord, Show)
 15 | 
 16 | -- Dead simple ones -------------------------
 17 | -- x1 = 10
 18 | prog1 :: P.Program () Xs R.Arbitrary
 19 | prog1
 20 |  = P.maximise
 21 |     -- objective
 22 |         (r X1 1)
 23 |     -- subject to
 24 |      (   r X1  1 :<= con 10)
 25 |     -- bounds omitted for now
 26 |     []
 27 | 
 28 | -- x1 = 10
 29 | prog2 :: P.Program () Xs R.Arbitrary
 30 | prog2
 31 |  = P.maximise
 32 |     -- objective
 33 |         (r X1 1)
 34 |     -- subject to
 35 |      (   r X1  1 :<= con 10)
 36 |     [ lowerR 0 X1 ]
 37 | 
 38 | -- x1 = 0
 39 | prog3 :: P.Program () Xs R.Arbitrary
 40 | prog3
 41 |  = P.minimise
 42 |     -- objective
 43 |         (r X1 1)
 44 |     -- subject to
 45 |      (   r X1  1 :<= con 10)
 46 |     [ lowerR 0 X1 ]
 47 | 
 48 | -- Unbounded!
 49 | prog4 :: P.Program () Xs R.Arbitrary
 50 | prog4
 51 |  = P.minimise
 52 |     -- objective
 53 |         (r X1 1)
 54 |     -- subject to
 55 |      (   r X1  1 :<= con 10)
 56 |     []
 57 | 
 58 | 
 59 | -- Two constraints! --------------
 60 | 
 61 | -- x = 10
 62 | prog5 :: P.Program () Xs R.Arbitrary
 63 | prog5
 64 |  = P.maximise
 65 |     -- objective
 66 |         (r X1 1)
 67 |     -- subject to
 68 |      (   r X1  1 :<= con 10
 69 |      :&& r X1  1 :>= con (-10))
 70 |     []
 71 | 
 72 | -- x = -10
 73 | prog6 :: P.Program () Xs R.Arbitrary
 74 | prog6
 75 |  = P.minimise
 76 |     -- objective
 77 |         (r X1 1)
 78 |     -- subject to
 79 |      (   r X1  1 :<= con 10
 80 |      :&& r X1  1 :>= con (-10))
 81 |     []
 82 | 
 83 | 
 84 | -- Now two variables -------------
 85 | -- x1 = 20, x2 = 10
 86 | prog7 :: P.Program () Xs R.Arbitrary
 87 | prog7
 88 |  = P.maximise
 89 |     -- objective
 90 |         (r X1 1 .+. r X2 1)
 91 |     -- subject to
 92 |      (   r X1  1 :<= r X2 2
 93 |      :&& r X2  1 :<= con 10)
 94 |     [lowerR 0 X1, lowerR 0 X2]
 95 | 
 96 | -- x1 = 20, x2 = 10
 97 | prog8 :: P.Program () Xs R.Arbitrary
 98 | prog8
 99 |  = P.maximise
100 |     -- objective
101 |         (r X1 1 .+. r X2 1)
102 |     -- subject to
103 |      (   r X1  1 :<= r X2 2
104 |      :&& r X2  1 :<= con 10)
105 |     [] -- [lowerR 0 X1, lowerR 0 X2]
106 | 
107 | -- Something where vars=0 isn't sat ------
108 | -- x1 = 8
109 | prog9 :: P.Program () Xs R.Arbitrary
110 | prog9
111 |  = P.minimise
112 |     -- objective
113 |         (r X1 1)
114 |     -- subject to
115 |      (   r X1  1 :>= con 8 
116 |      :&& r X1  1 :<= con 10)
117 |     [lowerR 0 X1]
118 | 
119 | -- x1 = 10
120 | prog10 :: P.Program () Xs R.Arbitrary
121 | prog10
122 |  = P.maximise
123 |     -- objective
124 |         (r X1 1)
125 |     -- subject to
126 |      (   r X1  1 :>= con 8 
127 |      :&& r X1  1 :<= con 10)
128 |     [lowerR 0 X1]
129 | 
130 | 
131 | 
132 | -- An equality constraint ------------
133 | -- x1 = 10
134 | prog11 :: P.Program () Xs R.Arbitrary
135 | prog11
136 |  = P.maximise
137 |     -- objective
138 |         (r X1 1)
139 |     -- subject to
140 |      (   r X1  1 :== con 10 )
141 |     [lowerR 0 X1]
142 | 
143 | -- x1 = 10
144 | prog12 :: P.Program () Xs R.Arbitrary
145 | prog12
146 |  = P.minimise
147 |     -- objective
148 |         (r X1 1)
149 |     -- subject to
150 |      (   r X1  1 :== con 10 )
151 |     [lowerR 0 X1]
152 | 
153 | 
154 | -- From wikipedia ----------------
155 | -- x1 = 2.142..., x3 = 3.571...
156 | prog13 :: P.Program () Xs R.Arbitrary
157 | prog13
158 |  = P.minimise
159 |     -- objective
160 |         (r X1 (-2) .+. r X2 (-3) .+. r X3 (-4))
161 |     -- subject to
162 |      (   r X1  3   .+. r X2 2    .+. r X3 1 :== con 10
163 |      :&& r X1  2   .+. r X2 5    .+. r X3 3 :== con 15)
164 |     [lowerR 0 X1
165 |     ,lowerR 0 X2
166 |     ,lowerR 0 X3]
167 | 
168 | -- x1 = 1.818..., x2 = 2.272...
169 | prog14 :: P.Program () Xs R.Arbitrary
170 | prog14
171 |  = P.maximise
172 |     -- objective
173 |         (r X1 (-2) .+. r X2 (-3) .+. r X3 (-4))
174 |     -- subject to
175 |      (   r X1  3   .+. r X2 2    .+. r X3 1 :== con 10
176 |      :&& r X1  2   .+. r X2 5    .+. r X3 3 :== con 15)
177 |     [lowerR 0 X1
178 |     ,lowerR 0 X2
179 |     ,lowerR 0 X3]
180 | 
181 | -- An equality constraint on unconstrained (+-) ------------
182 | -- x1 = 10
183 | prog15 :: P.Program () Xs R.Arbitrary
184 | prog15
185 |  = P.maximise
186 |     -- objective
187 |         (r X1 1)
188 |     -- subject to
189 |      (   r X1  1 :== con 10 )
190 |     []
191 | 
192 | -- A lower bound greater than zero ------------
193 | -- x1 = 5
194 | prog16 :: P.Program () Xs R.Arbitrary
195 | prog16
196 |  = P.minimise
197 |     -- objective
198 |         (r X1 1)
199 |     -- subject to
200 |      (   r X1  1 :<= con 30 )
201 |     [lowerR 5 X1]
202 | 
203 | -- Lower and upper bounds -------
204 | -- x1 = 5
205 | prog17 :: P.Program () Xs R.Arbitrary
206 | prog17
207 |  = P.minimise
208 |     -- objective
209 |         (r X1 1)
210 |     -- subject to
211 |      (   r X1  1 :<= con 30 )
212 |     [lowerUpperR 5 X1 10]
213 | -- x1 = 10
214 | prog18 :: P.Program () Xs R.Arbitrary
215 | prog18
216 |  = P.maximise
217 |     -- objective
218 |         (r X1 1)
219 |     -- subject to
220 |      (   r X1  1 :<= con 30 )
221 |     [lowerUpperR 5 X1 10]
222 | 
223 | -- x1 = 1, x2 = 2
224 | prog19 :: P.Program () Xs R.Arbitrary
225 | prog19
226 |  = P.minimise
227 |     (r X1 1 .+. r X2 1)
228 |     (    r X1 2 :<= r X2 1
229 |     :&&  r X1 1 :>= con 1)
230 |     [ lowerR 0 X1
231 |     , lowerR 0 X2]
232 | 
233 | 
234 | -- error uncovered by branch -------
235 | -- x1 = 1
236 | -- x2 = 1.870...
237 | prog20 :: P.Program () Xs R.Arbitrary
238 | prog20
239 |  = P.minimise
240 |     -- x1 = mozzarella
241 |     -- x2 = sampler plate
242 |     (r1 X1 .+. r1 X2)
243 |     (r X1 420 .+. r X2 580 :== con 1505)
244 |     [ lowerR 1 X1
245 |     , lowerUpperR 0 X2 2 ]
246 | 
247 | {-
248 | Minimize
249 | 	1.0 "french-fries" + 1.0 "hot-wings" + 1.0 "mixed-fruit" + 1.0 "mozzarella-sticks" + 1.0 "sampler-plate" + 1.0 "side-salad"
250 | Subject to
251 | 	-275.0 "french-fries" - 355.0 "hot-wings" - 215.0 "mixed-fruit" - 420.0 "mozzarella-sticks" - 580.0 "sampler-plate" - 335.0 "side-salad" >= -1505.0
252 | 	-275.0 "french-fries" - 355.0 "hot-wings" - 215.0 "mixed-fruit" - 420.0 "mozzarella-sticks" - 580.0 "sampler-plate" - 335.0 "side-salad" <= -1505.0
253 | 
254 | Bounds
255 | 	0.0 <= "french-fries"
256 | 	0.0 <= "hot-wings"
257 | 	0.0 <= "mixed-fruit"
258 | 	1.0 <= "mozzarella-sticks"
259 | 	0.0 <= "sampler-plate" <= 2.0
260 | 	0.0 <= "side-salad"
261 | -}
262 | 
263 | -- nonzero lower bound with non-1 coeff
264 | -- x1 = 2.5
265 | prog21 :: P.Program () Xs R.Arbitrary
266 | prog21
267 |  = P.minimise
268 |     (r1 X1)
269 |     (r X1 2 :>= con 5)
270 |     [ lowerR 1 X1 ]
271 | 
272 | -- eq bound with non-1 coeff
273 | -- x1 = 1, x2 = 3
274 | prog22 :: P.Program () Xs R.Arbitrary
275 | prog22
276 |  = P.minimise
277 |     (r1 X1 .+. r1 X2)
278 |     (r X1 2 .+. r X2 1 :>= con 5)
279 |     [ lowerUpperR 1 X1 1
280 |     , lowerR 0 X2]
281 | 
282 | 
283 | std :: (Ord z, Ord r, Rep c) => P.Program z r c -> Standard z r c
284 | std = ST.standard . C.program
285 | 
286 | 
287 | 
288 | 
289 | test :: P.Program () Xs R.Arbitrary -> IO Bool
290 | test p
291 |  = case SM.simplex $ ST.standard $ C.program p of
292 |    Nothing
293 |     -> do   putStrLn "Error: simplex returned Nothing"
294 |             putStrLn (show $ ST.standard $ C.program p)
295 |             putStrLn (show $ SM.simplex1 $ ST.standard $ C.program p)
296 |             return False
297 | 
298 |    Just s
299 |     -> do   let (Assignment _ vars,obj) = SM.assignment s
300 |             let vars'      = M.toList vars
301 | 
302 |             putStrLn (show $ ST.standard $ C.program p)
303 |             putStrLn (show $ SM.simplex1 $ ST.standard $ C.program p)
304 | 
305 |             putStrLn "Vars:"
306 |             putStrLn (show vars')
307 |             putStrLn "Obj:"
308 |             putStrLn (show obj)
309 | 
310 |             return True
311 | 
312 | 


--------------------------------------------------------------------------------
/tests/Simplify.hs:
--------------------------------------------------------------------------------
  1 | module Simplify where
  2 | 
  3 | import Numeric.Limp.Program as P
  4 | import Numeric.Limp.Canon   as C
  5 | import Numeric.Limp.Canon.Simplify as CS
  6 | import Numeric.Limp.Canon.Simplify.Subst as CS
  7 | import Numeric.Limp.Canon.Simplify.Bounder as CS
  8 | import Numeric.Limp.Canon.Simplify.Crunch as CS
  9 | 
 10 | import Numeric.Limp.Canon.Pretty
 11 | 
 12 | import Arbitrary.Assignment     as Arb
 13 | import Arbitrary.Var            as Arb
 14 | import Arbitrary.Program        as Arb
 15 | import Data.Monoid
 16 | 
 17 | import Test.Tasty.QuickCheck
 18 | import Test.Tasty.TH
 19 | 
 20 | import Debug.Trace
 21 | 
 22 | tests = $(testGroupGenerator)
 23 | 
 24 | prop_bounder :: ProgramAss -> Property
 25 | prop_bounder (ProgramAss p a)
 26 |  = let cp     = C.program p
 27 |        cp'    = CS.bounderProgram cp
 28 |        valcp  = C.checkProgram a cp
 29 |        valcp'
 30 |         | Right p' <- cp'
 31 |         = C.checkProgram a p'
 32 |         -- Infeasible, so assignment is false
 33 |         | otherwise
 34 |         = False
 35 |    in  counterexample
 36 |        (unlines
 37 |          [ "CP: " ++ show cp
 38 |          , "CP':" ++ show cp'
 39 |          , "Val: " ++ show (valcp, valcp')])
 40 |        $ valcp == valcp'
 41 | 
 42 | 
 43 | prop_crunch :: ProgramAss -> Property
 44 | prop_crunch (ProgramAss p a)
 45 |  = let cp     = C.program p
 46 |        cp'    = CS.crunchProgram cp
 47 |        valcp  = C.checkProgram a cp
 48 |        valcp' = C.checkProgram a cp'
 49 |    in  counterexample
 50 |        (unlines
 51 |          [ "CP: " ++ show cp
 52 |          , "CP':" ++ show cp'
 53 |          , "Val: " ++ show (valcp, valcp')])
 54 |        $ valcp == valcp'
 55 | 
 56 | 
 57 | -- | I don't think this property is very interesting.
 58 | -- The real property should be something like:
 59 | --
 60 | -- > solve cp == solve (simplify cp)
 61 | --
 62 | prop_simplify :: Program' -> Property
 63 | prop_simplify p
 64 |  = let cp = C.program p
 65 |        simp = CS.simplify cp
 66 |    in  case simp of
 67 |        Left _
 68 |         -> property True
 69 |        Right (a', cp')
 70 |         -> let valcp  = C.checkProgram a' cp
 71 |                valcp' = C.checkProgram a' cp'
 72 |            in  counterexample
 73 |            (unlines
 74 |              [ "CP: " ++ show cp
 75 |              , "CP':" ++ show cp'
 76 |              , "Ass:" ++ show a'
 77 |              , "Val: " ++ show (valcp, valcp')])
 78 |            $ valcp == valcp'
 79 | 
 80 | 
 81 | prop_subst_linear :: Vars -> Property
 82 | prop_subst_linear vs
 83 |  = forAll (Arb.linearR    vs) $ \f ->
 84 |    forAll (Arb.assignment vs) $ \a ->
 85 |    forAll (Arb.assignment vs) $ \b ->
 86 |      let (fc, _)   = C.linear f
 87 |          (fc', c') = substLinear a fc
 88 |      in  C.evalR (a <> b) fc == C.evalR b fc' + c'
 89 | 
 90 | 
 91 | -- subst can actually make a failing program pass.
 92 | -- so this test needs to be implication, not equivalence.
 93 | prop_subst_program :: Vars -> Property
 94 | prop_subst_program vs
 95 |  = forAll (Arb.program    vs) $ \f ->
 96 |    forAll (Arb.assignment vs) $ \a ->
 97 |    forAll (Arb.assignment vs) $ \b ->
 98 |      let fc    = C.program f
 99 |          fc'   = substProgram a fc
100 |          both  = a <> b
101 |          valcp = C.checkProgram both fc 
102 |          valcp'= C.checkProgram b fc'
103 |      in counterexample 
104 |          (unlines
105 |          [ "CP: " ++ show fc
106 |          , "CP':" ++ show fc'
107 |          , "Ass:" ++ show both
108 |          , "Val: " ++ show (valcp, valcp')])
109 |        $ if valcp then valcp' else True
110 | 
111 | 


--------------------------------------------------------------------------------