Skip to content

Commit f9571d7

Browse files
rasheedjarasheedja
committed
wip
1 parent dd7fe5a commit f9571d7

File tree

20 files changed

+650
-565
lines changed

20 files changed

+650
-565
lines changed

‎src/Linear/Constraint/Linear/Types.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,8 @@ import Linear.Expr.Types (ExprVarsOnly)
1111
import Linear.Var.Types (SimplexNum)
1212

1313
-- lhs == rhs
14+
-- TODO: Should I move this? Typicially, this would for a 'LinearConstraint', but I'm renaming 'Constraint' to 'LinearConstraint'.
15+
-- TODO: Maybe I should move 'Constraint' here?
1416
data LinearEquation = LinearEquation
1517
{ lhs :: ExprVarsOnly
1618
, rhs :: SimplexNum

‎src/Linear/Constraint/Simple/Types.hs‎

Lines changed: 10 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -10,5 +10,14 @@ module Linear.Constraint.Simple.Types where
1010
import Linear.Constraint.Generic.Types (GenericConstraint)
1111
import Linear.Expr.Types (ExprVarsOnly)
1212
import Linear.Var.Types (SimplexNum)
13+
import GHC.Generics (Generic)
14+
import Test.QuickCheck (Arbitrary (..))
1315

14-
type SimpleConstraint = GenericConstraint ExprVarsOnly SimplexNum
16+
newtype SimpleConstraint = SimpleConstraint { unSimpleConstraint :: GenericConstraint ExprVarsOnly SimplexNum }
17+
deriving (Show, Eq, Read, Generic)
18+
19+
instance Arbitrary SimpleConstraint where
20+
arbitrary = SimpleConstraint <$> arbitrary
21+
22+
class CanBeSimpleConstraint a where
23+
toSimpleConstraint :: a -> SimpleConstraint

‎src/Linear/Constraint/Simple/Util.hs‎

Lines changed: 32 additions & 74 deletions
Original file line numberDiff line numberDiff line change
@@ -12,8 +12,8 @@ import qualified Data.Set as Set
1212
import Linear.Constraint.Generic.Types
1313
( GenericConstraint (..)
1414
)
15-
import Linear.Constraint.Simple.Types (SimpleConstraint)
16-
import Linear.Constraint.Types (Constraint)
15+
import Linear.Constraint.Simple.Types (SimpleConstraint (..))
16+
import Linear.Constraint.Types (Constraint (..))
1717
import Linear.Expr.Types (Expr (..), ExprVarsOnly (..))
1818
import Linear.Expr.Util
1919
( exprToExprVarsOnly
@@ -34,31 +34,31 @@ import Linear.Var.Types (Var)
3434

3535
substVarSimpleConstraintExpr ::
3636
Var -> Expr -> SimpleConstraint -> SimpleConstraint
37-
substVarSimpleConstraintExpr var varReplacement (a :<= b) =
37+
substVarSimpleConstraintExpr var varReplacement (SimpleConstraint (a :<= b)) =
3838
let newExpr = substVarExpr var varReplacement (exprVarsOnlyToExpr a)
3939
newConstraint = newExpr :<= Expr [ConstTerm b]
40-
in constraintToSimpleConstraint newConstraint
41-
substVarSimpleConstraintExpr var varReplacement (a :>= b) =
40+
in constraintToSimpleConstraint $ Constraint newConstraint
41+
substVarSimpleConstraintExpr var varReplacement (SimpleConstraint (a :>= b)) =
4242
let newExpr = substVarExpr var varReplacement (exprVarsOnlyToExpr a)
4343
newConstraint = newExpr :>= Expr [ConstTerm b]
44-
in constraintToSimpleConstraint newConstraint
45-
substVarSimpleConstraintExpr var varReplacement (a :== b) =
44+
in constraintToSimpleConstraint $ Constraint newConstraint
45+
substVarSimpleConstraintExpr var varReplacement (SimpleConstraint (a :== b)) =
4646
let newExpr = substVarExpr var varReplacement (exprVarsOnlyToExpr a)
4747
newConstraint = newExpr :== Expr [ConstTerm b]
48-
in constraintToSimpleConstraint newConstraint
48+
in constraintToSimpleConstraint $ Constraint newConstraint
4949

5050
substVarSimpleConstraint ::
5151
Var -> ExprVarsOnly -> SimpleConstraint -> SimpleConstraint
52-
substVarSimpleConstraint var varReplacement (a :<= b) = substVarExprVarsOnly var varReplacement a :<= b
53-
substVarSimpleConstraint var varReplacement (a :>= b) = substVarExprVarsOnly var varReplacement a :>= b
54-
substVarSimpleConstraint var varReplacement (a :== b) = substVarExprVarsOnly var varReplacement a :== b
52+
substVarSimpleConstraint var varReplacement (SimpleConstraint (a :<= b)) = SimpleConstraint $ substVarExprVarsOnly var varReplacement a :<= b
53+
substVarSimpleConstraint var varReplacement (SimpleConstraint (a :>= b)) = SimpleConstraint $ substVarExprVarsOnly var varReplacement a :>= b
54+
substVarSimpleConstraint var varReplacement (SimpleConstraint (a :== b)) = SimpleConstraint $ substVarExprVarsOnly var varReplacement a :== b
5555

5656
constraintToSimpleConstraint :: Constraint -> SimpleConstraint
5757
constraintToSimpleConstraint constraint =
5858
case constraint of
59-
(a :<= b) -> uncurry (:<=) (calcLhsRhs a b)
60-
(a :>= b) -> uncurry (:>=) (calcLhsRhs a b)
61-
(a :== b) -> uncurry (:==) (calcLhsRhs a b)
59+
Constraint (a :<= b) -> SimpleConstraint $ uncurry (:<=) (calcLhsRhs a b)
60+
Constraint (a :>= b) -> SimpleConstraint $ uncurry (:>=) (calcLhsRhs a b)
61+
Constraint (a :== b) -> SimpleConstraint $ uncurry (:==) (calcLhsRhs a b)
6262
where
6363
calcLhsRhs a b = (lhs, rhs)
6464
where
@@ -76,70 +76,28 @@ constraintToSimpleConstraint constraint =
7676
error $
7777
"constraintToSimpleConstraint: lhs is not ExprVarsOnly. Details: " <> err
7878

79-
-- normalize simple constraints by moving all constants to the right
80-
-- normalizeSimpleConstraint :: SimpleConstraint -> SimpleConstraint
81-
-- normalizeSimpleConstraint (expr :<= num) =
82-
-- let exprList = exprToList expr
83-
84-
-- isConstTerm (ConstTerm _) = True
85-
-- isConstTerm _ = False
86-
87-
-- (sumExprConstTerms, nonConstTerms) = L.partition isConstTerm exprList
88-
89-
-- constTermsVal = sum . map (\case (ConstTerm c) -> c; _ -> 0) $ sumExprConstTerms
90-
91-
-- newExpr = listToExpr nonConstTerms
92-
-- newNum = num - constTermsVal
93-
-- in newExpr :<= newNum
94-
-- normalizeSimpleConstraint (expr :>= num) =
95-
-- let exprList = exprToList expr
96-
97-
-- isConstTerm (ConstTerm _) = True
98-
-- isConstTerm _ = False
99-
100-
-- (sumExprConstTerms, nonConstTerms) = L.partition isConstTerm exprList
101-
102-
-- constTermsVal = sum . map (\case (ConstTerm c) -> c; _ -> 0) $ sumExprConstTerms
103-
104-
-- newExpr = listToExpr nonConstTerms
105-
-- newNum = num - constTermsVal
106-
-- in newExpr :>= newNum
107-
-- normalizeSimpleConstraint (expr :== num) =
108-
-- let exprList = exprToList expr
109-
110-
-- isConstTerm (ConstTerm _) = True
111-
-- isConstTerm _ = False
112-
113-
-- (sumExprConstTerms, nonConstTerms) = L.partition isConstTerm exprList
114-
115-
-- constTermsVal = sum . map (\case (ConstTerm c) -> c; _ -> 0) $ sumExprConstTerms
116-
117-
-- newExpr = listToExpr nonConstTerms
118-
-- newNum = num - constTermsVal
119-
-- in newExpr :== newNum
120-
12179
-- | Simplify coeff constraints by dividing the coefficient from both sides
12280
simplifyCoeff :: SimpleConstraint -> SimpleConstraint
123-
simplifyCoeff expr@(ExprVarsOnly [CoeffTermVO coeff var] :<= num)
124-
| coeff == 0 = expr
125-
| coeff > 0 = ExprVarsOnly [VarTermVO var] :<= (num / coeff)
126-
| coeff < 0 = ExprVarsOnly [VarTermVO var] :>= (num / coeff)
127-
simplifyCoeff expr@(ExprVarsOnly [CoeffTermVO coeff var] :>= num)
128-
| coeff == 0 = expr
129-
| coeff > 0 = ExprVarsOnly [VarTermVO var] :>= (num / coeff)
130-
| coeff < 0 = ExprVarsOnly [VarTermVO var] :<= (num / coeff)
131-
simplifyCoeff expr@(ExprVarsOnly [CoeffTermVO coeff var] :== num) =
81+
simplifyCoeff simpleConstraint@(SimpleConstraint (ExprVarsOnly [CoeffTermVO coeff var] :<= num))
82+
| coeff == 0 = simpleConstraint
83+
| coeff > 0 = SimpleConstraint $ ExprVarsOnly [VarTermVO var] :<= (num / coeff)
84+
| coeff < 0 = SimpleConstraint $ ExprVarsOnly [VarTermVO var] :>= (num / coeff)
85+
simplifyCoeff simpleConstraint@(SimpleConstraint (ExprVarsOnly [CoeffTermVO coeff var] :>= num))
86+
| coeff == 0 = simpleConstraint
87+
| coeff > 0 = SimpleConstraint $ ExprVarsOnly [VarTermVO var] :>= (num / coeff)
88+
| coeff < 0 = SimpleConstraint $ ExprVarsOnly [VarTermVO var] :<= (num / coeff)
89+
simplifyCoeff simpleConstraint@(SimpleConstraint (ExprVarsOnly [CoeffTermVO coeff var] :== num)) =
13290
if coeff == 0
133-
then expr
134-
else ExprVarsOnly [VarTermVO var] :== (num / coeff)
135-
simplifyCoeff expr = expr
91+
then simpleConstraint
92+
else SimpleConstraint $ ExprVarsOnly [VarTermVO var] :== (num / coeff)
93+
simplifyCoeff simpleConstraint = simpleConstraint
13694

13795
simplifySimpleConstraint :: SimpleConstraint -> SimpleConstraint
138-
simplifySimpleConstraint (expr :<= num) = simplifyCoeff $ simplifyExprVarsOnly expr :<= num
139-
simplifySimpleConstraint (expr :>= num) = simplifyCoeff $ simplifyExprVarsOnly expr :>= num
140-
simplifySimpleConstraint (expr :== num) = simplifyCoeff $ simplifyExprVarsOnly expr :== num
96+
simplifySimpleConstraint (SimpleConstraint (expr :<= num)) = simplifyCoeff . SimpleConstraint $ simplifyExprVarsOnly expr :<= num
97+
simplifySimpleConstraint (SimpleConstraint (expr :>= num)) = simplifyCoeff . SimpleConstraint $ simplifyExprVarsOnly expr :>= num
98+
simplifySimpleConstraint (SimpleConstraint (expr :== num)) = simplifyCoeff . SimpleConstraint $ simplifyExprVarsOnly expr :== num
14199

142100
simpleConstraintVars :: SimpleConstraint -> Set.Set Var
143-
simpleConstraintVars (expr :<= _) = exprVars . exprVarsOnlyToExpr $ expr
144-
simpleConstraintVars (expr :>= _) = exprVars . exprVarsOnlyToExpr $ expr
145-
simpleConstraintVars (expr :== _) = exprVars . exprVarsOnlyToExpr $ expr
101+
simpleConstraintVars (SimpleConstraint (expr :<= _)) = exprVars . exprVarsOnlyToExpr $ expr
102+
simpleConstraintVars (SimpleConstraint (expr :>= _)) = exprVars . exprVarsOnlyToExpr $ expr
103+
simpleConstraintVars (SimpleConstraint (expr :== _)) = exprVars . exprVarsOnlyToExpr $ expr

‎src/Linear/Constraint/Types.hs‎

Lines changed: 7 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,12 @@ import qualified Data.Set as Set
1111
import GHC.Generics (Generic)
1212
import Linear.Constraint.Generic.Types (GenericConstraint)
1313
import Linear.Expr.Types (Expr)
14+
import Test.QuickCheck (Arbitrary (..))
1415

1516
-- Input
16-
type Constraint = GenericConstraint Expr Expr
17+
-- TODO: Consider LinearConstraint
18+
newtype Constraint = Constraint {unConstraint :: GenericConstraint Expr Expr}
19+
deriving (Show, Eq, Read, Generic)
20+
21+
instance Arbitrary Constraint where
22+
arbitrary = Constraint <$> arbitrary

‎src/Linear/Constraint/Util.hs‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -11,11 +11,11 @@ import qualified Data.Set as Set
1111
import Linear.Constraint.Generic.Types
1212
( GenericConstraint ((:<=), (:==), (:>=))
1313
)
14-
import Linear.Constraint.Types (Constraint)
14+
import Linear.Constraint.Types (Constraint (..))
1515
import Linear.Expr.Util (exprVars)
1616
import Linear.Var.Types (Var)
1717

1818
constraintVars :: Constraint -> Set.Set Var
19-
constraintVars (lhs :<= rhs) = exprVars lhs <> exprVars rhs
20-
constraintVars (lhs :>= rhs) = exprVars lhs <> exprVars rhs
21-
constraintVars (lhs :== rhs) = exprVars lhs <> exprVars rhs
19+
constraintVars (Constraint (lhs :<= rhs)) = exprVars lhs <> exprVars rhs
20+
constraintVars (Constraint (lhs :>= rhs)) = exprVars lhs <> exprVars rhs
21+
constraintVars (Constraint (lhs :== rhs)) = exprVars lhs <> exprVars rhs

‎src/Linear/Expr/Types.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -11,8 +11,8 @@ import GHC.Generics (Generic)
1111
import Linear.Term.Types (Term, TermVarsOnly)
1212
import Test.QuickCheck (Arbitrary (..))
1313

14-
-- TODO: Use normal lists
1514
-- treat empty expr as 0
15+
-- Consider a version with a num instance, use + and * operators for the input
1616
newtype Expr = Expr {unExpr :: [Term]}
1717
deriving
1818
( Show

‎src/Linear/Expr/Util.hs‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -121,8 +121,7 @@ exprToExprVarsOnly expr@(Expr ts) = do
121121
then
122122
if sumExprConstTerms expr == 0
123123
then Right $ ExprVarsOnly []
124-
else
125-
Left $ "safeExprToExprVarsOnly: Expr contains ConstTerm. Expr: " <> show expr
124+
else Left $ "safeExprToExprVarsOnly: Expr contains ConstTerm. Expr: " <> show expr
126125
else Right $ unsafeExprToExprVarsOnly expr
127126
where
128127
isConstTerm :: Term -> Bool

‎src/Linear/Simplex/Solver/Types.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -2,15 +2,15 @@ module Linear.Simplex.Solver.Types where
22

33
import qualified Data.Map as Map
44
import GHC.Generics (Generic)
5-
import Linear.Expr.Types (Expr)
5+
import Linear.Expr.Types (ExprVarsOnly)
66
import Linear.System.Linear.Types (CanBeLinearSystem)
77
import Linear.Var.Types (SimplexNum, Var)
88

99
data OptimisationDirection = Minimize | Maximize
1010
deriving (Show, Eq, GHC.Generics.Generic)
1111

1212
data Objective = Objective
13-
{ expr :: Linear.Expr.Types.Expr -- TODO: this should be ExprVarsOnly
13+
{ expr :: Linear.Expr.Types.ExprVarsOnly
1414
, direction :: OptimisationDirection
1515
}
1616
deriving (Show, Eq, GHC.Generics.Generic)

‎src/Linear/SlackForm/Types.hs‎

Lines changed: 17 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -7,18 +7,30 @@
77
-- Stability: experimental
88
module Linear.SlackForm.Types where
99

10+
import qualified Data.Set as Set
1011
import GHC.Generics (Generic)
11-
import Linear.Expr.Types (Expr)
12-
import Linear.System.Linear.Types (LinearSystem)
12+
import Linear.Constraint.Linear.Types (LinearEquation (..))
13+
import Linear.Expr.Types (ExprVarsOnly)
14+
import Linear.Expr.Util (exprVarsOnlyVars)
15+
import Linear.System.Linear.Types (LinearSystem (..))
16+
import Linear.System.Simple.Types
1317
import Linear.Var.Types (SimplexNum, Var)
1418

1519
-- Expr == SimplexNum
20+
-- TODO: think about a better name for this type, CanonicalForm?
1621
data SlackForm = SlackForm
17-
{ maxObjective :: Expr -- TODO: should be ExprVarsOnly
22+
{ maxObjective :: ExprVarsOnly
1823
, constraints :: LinearSystem
19-
, vars :: [Var] -- all vars are non-negative
24+
, vars :: Set.Set Var -- all vars are non-negative
2025
}
2126
deriving (Show, Eq, Read, Generic)
2227

2328
class CanBeSlackForm a where
24-
toSlackForm :: a -> SlackForm
29+
toSlackForm :: a -> ExprVarsOnly -> SlackForm
30+
31+
instance CanBeSlackForm LinearSystem where
32+
toSlackForm ls obj =
33+
SlackForm
34+
obj
35+
ls
36+
(Set.unions $ map (exprVarsOnlyVars . lhs) ls.unLinearSystem)

‎src/Linear/SlackForm/Util.hs‎

Lines changed: 16 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -7,13 +7,15 @@
77
-- Stability: experimental
88
module Linear.SlackForm.Util where
99

10+
import qualified Data.Bifunctor as Bifunctor
1011
import qualified Data.Map as Map
1112
import qualified Data.Maybe as Maybe
1213
import Linear.Constraint.Generic.Types
1314
( GenericConstraint ((:<=), (:==), (:>=))
1415
)
1516
import Linear.Constraint.Linear.Types (LinearEquation (..))
1617
import qualified Linear.Constraint.Linear.Util as CLU
18+
import Linear.Constraint.Simple.Types (SimpleConstraint (..))
1719
import Linear.Constraint.Simple.Util
1820
( substVarSimpleConstraintExpr
1921
)
@@ -22,7 +24,7 @@ import Linear.Expr.Util (exprVarsOnlyToExpr)
2224
import Linear.System.Linear.Types (LinearSystem (..))
2325
import qualified Linear.System.Linear.Util as SLU
2426
import Linear.System.Simple.Types
25-
( SimpleSystem
27+
( SimpleSystem (..)
2628
, simplifySimpleSystem
2729
)
2830
import qualified Linear.System.Simple.Types as SST
@@ -37,28 +39,29 @@ import Linear.Var.Types (Bounds (..), Var, VarBounds)
3739
-- First step here https://en.wikipedia.org/wiki/Simplex_algorithm#Standard_form
3840
eliminateNonZeroLowerBounds ::
3941
SimpleSystem -> Map.Map Var Expr -> (Map.Map Var Expr, SimpleSystem)
40-
eliminateNonZeroLowerBounds constraints eliminatedVarsMap = aux [] constraints
42+
eliminateNonZeroLowerBounds constraints eliminatedVarsMap = aux [] constraints.unSimpleSystem
4143
where
4244
-- Eliminate non-zero lower bounds
43-
44-
aux :: SimpleSystem -> SimpleSystem -> (Map.Map Var Expr, SimpleSystem)
45+
aux ::
46+
[SimpleConstraint] -> [SimpleConstraint] -> (Map.Map Var Expr, SimpleSystem)
4547
aux _ [] = (eliminatedVarsMap, constraints)
4648
aux checked (c : cs) = case c of
4749
-- x >= 5
48-
(ExprVarsOnly (VarTermVO var : []) :>= lowerBound) ->
50+
(SimpleConstraint (ExprVarsOnly [VarTermVO var] :>= lowerBound)) ->
4951
if lowerBound == 0
5052
then aux (checked ++ [c]) cs
5153
else
52-
let newVar = SST.findHighestVar constraints + 1
54+
let newVar = SST.nextAvailableVar constraints
5355
-- y >= 0
54-
newVarLowerBound = ExprVarsOnly (VarTermVO newVar : []) :>= 0
56+
newVarLowerBound = SimpleConstraint $ ExprVarsOnly [VarTermVO newVar] :>= 0
5557

5658
-- x = y + 5
5759
substOldVarWith = Expr (VarTerm newVar : [ConstTerm lowerBound])
5860
substFn = substVarSimpleConstraintExpr var substOldVarWith
5961

6062
newConstraints =
61-
simplifySimpleSystem $ map substFn checked ++ newVarLowerBound : map substFn cs
63+
simplifySimpleSystem . SimpleSystem $
64+
map substFn checked ++ newVarLowerBound : map substFn cs
6265
updatedEliminatedVarsMap = Map.insert var substOldVarWith eliminatedVarsMap
6366
in eliminateNonZeroLowerBounds newConstraints updatedEliminatedVarsMap -- TODO: Make more efficient if needed
6467
-- TODO: (do) Deal with == ?
@@ -71,13 +74,12 @@ eliminateNonZeroLowerBounds constraints eliminatedVarsMap = aux [] constraints
7174
-- Return system of equalities and the slack variables
7275
addSlackVariables :: SimpleSystem -> ([Var], LinearSystem)
7376
addSlackVariables constraints =
74-
let nextAvailableVar = SST.findHighestVar constraints + 1
75-
in aux constraints nextAvailableVar []
77+
let nextAvailableVar = SST.nextAvailableVar constraints
78+
in aux constraints.unSimpleSystem nextAvailableVar []
7679
where
77-
aux :: SimpleSystem -> Var -> [Var] -> ([Var], LinearSystem)
7880
aux [] _ slackVars = (slackVars, LinearSystem [])
7981
aux (c : cs) nextVar slackVars = case c of
80-
(expr@(ExprVarsOnly exprTs) :<= num) ->
82+
(SimpleConstraint (ExprVarsOnly exprTs :<= num)) ->
8183
let slackVar = nextVar
8284
newNextVar = nextVar + 1
8385
newExpr = ExprVarsOnly $ exprTs ++ [VarTermVO slackVar]
@@ -86,7 +88,7 @@ addSlackVariables constraints =
8688
in ( nextVar : newSlackVars
8789
, SLU.prependLinearEquation (LinearEquation newExpr num) newConstraints
8890
)
89-
(expr@(ExprVarsOnly exprTs) :>= num) ->
91+
(SimpleConstraint (ExprVarsOnly exprTs :>= num)) ->
9092
let slackVar = nextVar
9193
newNextVar = nextVar + 1
9294
newExpr = ExprVarsOnly $ exprTs ++ [CoeffTermVO (-1) slackVar]
@@ -95,7 +97,7 @@ addSlackVariables constraints =
9597
in ( nextVar : newSlackVars
9698
, SLU.prependLinearEquation (LinearEquation newExpr num) newConstraints
9799
)
98-
(expr :== num) ->
100+
(SimpleConstraint (expr :== num)) ->
99101
let (newSlackVars, newConstraints) = aux cs nextVar slackVars
100102
in ( newSlackVars
101103
, SLU.prependLinearEquation (LinearEquation expr num) newConstraints
@@ -126,7 +128,6 @@ eliminateUnrestrictedLowerBounds constraints varBoundMap eliminatedVarsMap = aux
126128
newConstraints =
127129
LinearSystem $
128130
map (CLU.substVarWith var substOldVarWith) (unLinearSystem constraints) -- TODO: simplify?
129-
-- TODO: Update this name
130131
updatedEliminatedVarsMap = Map.insert var (exprVarsOnlyToExpr substOldVarWith) eliminatedVarsMap
131132
in eliminateUnrestrictedLowerBounds
132133
newConstraints

0 commit comments

Comments
 (0)