Skip to content

Commit 772e032

Browse files
rasheedjarasheedja
committed
Implement and use LinearSystem
- used after adding slack variables - realised I need to allow empty expressions to keep things simple - so refactored that, too - todo: tests for new functions
1 parent 73050bb commit 772e032

File tree

15 files changed

+443
-368
lines changed

15 files changed

+443
-368
lines changed

‎simplex-method.cabal‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -29,6 +29,7 @@ library
2929
exposed-modules:
3030
Linear.Constraint.Generic.Types
3131
Linear.Constraint.Linear.Types
32+
Linear.Constraint.Linear.Util
3233
Linear.Constraint.Simple.Types
3334
Linear.Constraint.Simple.Util
3435
Linear.Constraint.Types
@@ -44,6 +45,7 @@ library
4445
Linear.SlackForm.Types
4546
Linear.SlackForm.Util
4647
Linear.System.Linear.Types
48+
Linear.System.Linear.Util
4749
Linear.System.Simple.Types
4850
Linear.System.Simple.Util
4951
Linear.System.Types

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -8,7 +8,7 @@
88
module Linear.Constraint.Simple.Types where
99

1010
import Linear.Constraint.Generic.Types (GenericConstraint)
11-
import Linear.Expr.Types (Expr)
11+
import Linear.Expr.Types (ExprVarsOnly)
1212
import Linear.Var.Types (SimplexNum)
1313

14-
type SimpleConstraint = GenericConstraint Expr SimplexNum
14+
type SimpleConstraint = GenericConstraint ExprVarsOnly SimplexNum

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

Lines changed: 78 additions & 62 deletions
Original file line numberDiff line numberDiff line change
@@ -8,32 +8,50 @@
88
module Linear.Constraint.Simple.Util where
99

1010
import qualified Data.List as L
11-
import Data.List.NonEmpty (NonEmpty (..))
12-
import qualified Data.List.NonEmpty as NE
1311
import qualified Data.Set as Set
1412
import Linear.Constraint.Generic.Types
15-
( GenericConstraint ((:<=), (:==), (:>=))
13+
( GenericConstraint (..)
1614
)
1715
import Linear.Constraint.Simple.Types (SimpleConstraint)
1816
import Linear.Constraint.Types (Constraint)
19-
import Linear.Expr.Types (Expr (Expr))
17+
import Linear.Expr.Types (Expr (..), ExprVarsOnly (..))
2018
import Linear.Expr.Util
21-
( exprToList
19+
( exprToExprVarsOnly
20+
, exprToList
2221
, exprVars
22+
, exprVarsOnlyToExpr
2323
, listToExpr
2424
, simplifyExpr
25+
, simplifyExprVarsOnly
2526
, substVarExpr
27+
, substVarExprVarsOnly
2628
, subtractExpr
2729
, sumExprConstTerms
2830
, zeroConstExpr
2931
)
30-
import Linear.Term.Types (Term (CoeffTerm, ConstTerm, VarTerm))
32+
import Linear.Term.Types (Term (..), TermVarsOnly (..))
3133
import Linear.Var.Types (Var)
3234

33-
substVarSimpleConstraint :: Var -> Expr -> SimpleConstraint -> SimpleConstraint
34-
substVarSimpleConstraint var varReplacement (a :<= b) = substVarExpr var varReplacement a :<= b
35-
substVarSimpleConstraint var varReplacement (a :>= b) = substVarExpr var varReplacement a :>= b
36-
substVarSimpleConstraint var varReplacement (a :== b) = substVarExpr var varReplacement a :== b
35+
substVarSimpleConstraintExpr ::
36+
Var -> Expr -> SimpleConstraint -> SimpleConstraint
37+
substVarSimpleConstraintExpr var varReplacement (a :<= b) =
38+
let newExpr = substVarExpr var varReplacement (exprVarsOnlyToExpr a)
39+
newConstraint = newExpr :<= Expr [ConstTerm b]
40+
in constraintToSimpleConstraint newConstraint
41+
substVarSimpleConstraintExpr var varReplacement (a :>= b) =
42+
let newExpr = substVarExpr var varReplacement (exprVarsOnlyToExpr a)
43+
newConstraint = newExpr :>= Expr [ConstTerm b]
44+
in constraintToSimpleConstraint newConstraint
45+
substVarSimpleConstraintExpr var varReplacement (a :== b) =
46+
let newExpr = substVarExpr var varReplacement (exprVarsOnlyToExpr a)
47+
newConstraint = newExpr :== Expr [ConstTerm b]
48+
in constraintToSimpleConstraint newConstraint
49+
50+
substVarSimpleConstraint ::
51+
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
3755

3856
constraintToSimpleConstraint :: Constraint -> SimpleConstraint
3957
constraintToSimpleConstraint constraint =
@@ -51,79 +69,77 @@ constraintToSimpleConstraint constraint =
5169
aWithoutConst = simplifyExpr . zeroConstExpr $ a
5270
bWithoutConst = simplifyExpr . zeroConstExpr $ b
5371

54-
lhs = subtractExpr aWithoutConst bWithoutConst
55-
calcRhs a b = rhs
56-
where
57-
aConsts = sumExprConstTerms a
58-
bConsts = sumExprConstTerms b
59-
rhs = bConsts - aConsts
60-
61-
aWithoutConst = simplifyExpr . zeroConstExpr $ a
62-
bWithoutConst = simplifyExpr . zeroConstExpr $ b
63-
64-
lhs = subtractExpr aWithoutConst bWithoutConst
72+
lhs' = subtractExpr aWithoutConst bWithoutConst
73+
lhs = case exprToExprVarsOnly lhs' of
74+
Right exprVarsOnly -> exprVarsOnly
75+
Left err ->
76+
error $
77+
"constraintToSimpleConstraint: lhs is not ExprVarsOnly. Details: " <> err
6578

6679
-- normalize simple constraints by moving all constants to the right
67-
normalizeSimpleConstraint :: SimpleConstraint -> SimpleConstraint
68-
normalizeSimpleConstraint (expr :<= num) =
69-
let exprList = exprToList expr
80+
-- normalizeSimpleConstraint :: SimpleConstraint -> SimpleConstraint
81+
-- normalizeSimpleConstraint (expr :<= num) =
82+
-- let exprList = exprToList expr
7083

71-
isConstTerm (ConstTerm _) = True
72-
isConstTerm _ = False
84+
-- isConstTerm (ConstTerm _) = True
85+
-- isConstTerm _ = False
7386

74-
(sumExprConstTerms, nonConstTerms) = L.partition isConstTerm exprList
87+
-- (sumExprConstTerms, nonConstTerms) = L.partition isConstTerm exprList
7588

76-
constTermsVal = sum . map (\case (ConstTerm c) -> c; _ -> 0) $ sumExprConstTerms
89+
-- constTermsVal = sum . map (\case (ConstTerm c) -> c; _ -> 0) $ sumExprConstTerms
7790

78-
newExpr = listToExpr nonConstTerms
79-
newNum = num - constTermsVal
80-
in newExpr :<= newNum
81-
normalizeSimpleConstraint (expr :>= num) =
82-
let exprList = exprToList expr
91+
-- newExpr = listToExpr nonConstTerms
92+
-- newNum = num - constTermsVal
93+
-- in newExpr :<= newNum
94+
-- normalizeSimpleConstraint (expr :>= num) =
95+
-- let exprList = exprToList expr
8396

84-
isConstTerm (ConstTerm _) = True
85-
isConstTerm _ = False
97+
-- isConstTerm (ConstTerm _) = True
98+
-- isConstTerm _ = False
8699

87-
(sumExprConstTerms, nonConstTerms) = L.partition isConstTerm exprList
100+
-- (sumExprConstTerms, nonConstTerms) = L.partition isConstTerm exprList
88101

89-
constTermsVal = sum . map (\case (ConstTerm c) -> c; _ -> 0) $ sumExprConstTerms
102+
-- constTermsVal = sum . map (\case (ConstTerm c) -> c; _ -> 0) $ sumExprConstTerms
90103

91-
newExpr = listToExpr nonConstTerms
92-
newNum = num - constTermsVal
93-
in newExpr :>= newNum
94-
normalizeSimpleConstraint (expr :== num) =
95-
let exprList = exprToList expr
104+
-- newExpr = listToExpr nonConstTerms
105+
-- newNum = num - constTermsVal
106+
-- in newExpr :>= newNum
107+
-- normalizeSimpleConstraint (expr :== num) =
108+
-- let exprList = exprToList expr
96109

97-
isConstTerm (ConstTerm _) = True
98-
isConstTerm _ = False
110+
-- isConstTerm (ConstTerm _) = True
111+
-- isConstTerm _ = False
99112

100-
(sumExprConstTerms, nonConstTerms) = L.partition isConstTerm exprList
113+
-- (sumExprConstTerms, nonConstTerms) = L.partition isConstTerm exprList
101114

102-
constTermsVal = sum . map (\case (ConstTerm c) -> c; _ -> 0) $ sumExprConstTerms
115+
-- constTermsVal = sum . map (\case (ConstTerm c) -> c; _ -> 0) $ sumExprConstTerms
103116

104-
newExpr = listToExpr nonConstTerms
105-
newNum = num - constTermsVal
106-
in newExpr :== newNum
117+
-- newExpr = listToExpr nonConstTerms
118+
-- newNum = num - constTermsVal
119+
-- in newExpr :== newNum
107120

108121
-- | Simplify coeff constraints by dividing the coefficient from both sides
109122
simplifyCoeff :: SimpleConstraint -> SimpleConstraint
110-
simplifyCoeff expr@(Expr (CoeffTerm coeff var :| []) :<= num)
123+
simplifyCoeff expr@(ExprVarsOnly [CoeffTermVO coeff var] :<= num)
111124
| coeff == 0 = expr
112-
| coeff > 0 = Expr (VarTerm var :| []) :<= (num / coeff)
113-
| coeff < 0 = Expr (VarTerm var :| []) :>= (num / coeff)
114-
simplifyCoeff expr@(Expr (CoeffTerm coeff var :| []) :>= num)
125+
| coeff > 0 = ExprVarsOnly [VarTermVO var] :<= (num / coeff)
126+
| coeff < 0 = ExprVarsOnly [VarTermVO var] :>= (num / coeff)
127+
simplifyCoeff expr@(ExprVarsOnly [CoeffTermVO coeff var] :>= num)
115128
| coeff == 0 = expr
116-
| coeff > 0 = Expr (VarTerm var :| []) :>= (num / coeff)
117-
| coeff < 0 = Expr (VarTerm var :| []) :<= (num / coeff)
118-
simplifyCoeff expr@(Expr (CoeffTerm coeff var :| []) :== num) = if coeff == 0 then expr else Expr (VarTerm var :| []) :== (num / coeff)
129+
| coeff > 0 = ExprVarsOnly [VarTermVO var] :>= (num / coeff)
130+
| coeff < 0 = ExprVarsOnly [VarTermVO var] :<= (num / coeff)
131+
simplifyCoeff expr@(ExprVarsOnly [CoeffTermVO coeff var] :== num) =
132+
if coeff == 0
133+
then expr
134+
else ExprVarsOnly [VarTermVO var] :== (num / coeff)
119135
simplifyCoeff expr = expr
120136

121137
simplifySimpleConstraint :: SimpleConstraint -> SimpleConstraint
122-
simplifySimpleConstraint (expr :<= num) = simplifyCoeff . normalizeSimpleConstraint $ simplifyExpr expr :<= num
123-
simplifySimpleConstraint (expr :>= num) = simplifyCoeff . normalizeSimpleConstraint $ simplifyExpr expr :>= num
124-
simplifySimpleConstraint (expr :== num) = simplifyCoeff . normalizeSimpleConstraint $ simplifyExpr expr :== num
138+
simplifySimpleConstraint (expr :<= num) = simplifyCoeff $ simplifyExprVarsOnly expr :<= num
139+
simplifySimpleConstraint (expr :>= num) = simplifyCoeff $ simplifyExprVarsOnly expr :>= num
140+
simplifySimpleConstraint (expr :== num) = simplifyCoeff $ simplifyExprVarsOnly expr :== num
125141

126142
simpleConstraintVars :: SimpleConstraint -> Set.Set Var
127-
simpleConstraintVars (expr :<= _) = exprVars expr
128-
simpleConstraintVars (expr :>= _) = exprVars expr
129-
simpleConstraintVars (expr :== _) = exprVars expr
143+
simpleConstraintVars (expr :<= _) = exprVars . exprVarsOnlyToExpr $ expr
144+
simpleConstraintVars (expr :>= _) = exprVars . exprVarsOnlyToExpr $ expr
145+
simpleConstraintVars (expr :== _) = exprVars . exprVarsOnlyToExpr $ expr

‎src/Linear/Expr/Types.hs‎

Lines changed: 8 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -7,22 +7,21 @@
77
-- Stability: experimental
88
module Linear.Expr.Types where
99

10-
import qualified Data.List.NonEmpty as NE
11-
import GHC.Base (liftA2)
1210
import GHC.Generics (Generic)
1311
import Linear.Term.Types (Term, TermVarsOnly)
1412
import Test.QuickCheck (Arbitrary (..))
15-
import Test.QuickCheck.Gen (suchThat)
1613

17-
newtype Expr = Expr {unExpr :: NE.NonEmpty Term}
14+
-- TODO: Use normal lists
15+
-- treat empty expr as 0
16+
newtype Expr = Expr {unExpr :: [Term]}
1817
deriving
1918
( Show
2019
, Read
2120
, Eq
2221
, Generic
2322
)
2423

25-
newtype ExprVarsOnly = ExprVarsOnly {unExprVarsOnly :: NE.NonEmpty TermVarsOnly}
24+
newtype ExprVarsOnly = ExprVarsOnly {unExprVarsOnly :: [TermVarsOnly]}
2625
deriving
2726
( Show
2827
, Read
@@ -31,4 +30,7 @@ newtype ExprVarsOnly = ExprVarsOnly {unExprVarsOnly :: NE.NonEmpty TermVarsOnly}
3130
)
3231

3332
instance Arbitrary Expr where
34-
arbitrary = Expr . NE.fromList <$> arbitrary `suchThat` (not . null)
33+
arbitrary = Expr <$> arbitrary
34+
35+
instance Arbitrary ExprVarsOnly where
36+
arbitrary = ExprVarsOnly <$> arbitrary

‎src/Linear/Expr/Util.hs‎

Lines changed: 43 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -8,28 +8,34 @@
88
module Linear.Expr.Util where
99

1010
import Data.List.NonEmpty (NonEmpty (..))
11-
import qualified Data.List.NonEmpty as NE
1211
import qualified Data.Maybe as Maybe
1312
import qualified Data.Set as Set
1413
import Linear.Expr.Types (Expr (..), ExprVarsOnly (..))
15-
import Linear.Term.Types (Term (..))
14+
import Linear.Term.Types (Term (..), TermVarsOnly (..))
1615
import Linear.Term.Util
1716
( negateTerm
1817
, normalizeTerms
18+
, normalizeTermsVarsOnly
1919
, simplifyTerm
20+
, termVarsOnlyToTerm
2021
, unsafeTermToTermVarsOnly
2122
, zeroConstTerm
2223
)
2324
import Linear.Var.Types (SimplexNum, Var)
2425

2526
-- | Convert an 'Expr' to a list of 'Term's.
2627
exprToList :: Expr -> [Term]
27-
exprToList (Expr t) = NE.toList t
28+
exprToList = unExpr
29+
30+
exprVarsOnlyToList :: ExprVarsOnly -> [TermVarsOnly]
31+
exprVarsOnlyToList = unExprVarsOnly
2832

2933
-- | Convert a list of 'Term's to an 'Expr'.
3034
listToExpr :: [Term] -> Expr
31-
listToExpr [] = Expr $ ConstTerm 0 :| [] -- TODO: Maybe throw an error?
32-
listToExpr ts = Expr $ NE.fromList ts
35+
listToExpr = Expr
36+
37+
listToExprVarsOnly :: [TermVarsOnly] -> ExprVarsOnly
38+
listToExprVarsOnly = ExprVarsOnly
3339

3440
exprVars :: Expr -> Set.Set Var
3541
exprVars = Set.fromList . Maybe.mapMaybe termVars . exprToList
@@ -39,23 +45,32 @@ exprVars = Set.fromList . Maybe.mapMaybe termVars . exprToList
3945
termVars (CoeffTerm _ v) = Just v
4046
termVars (VarTerm v) = Just v
4147

48+
exprVarsOnlyVars :: ExprVarsOnly -> Set.Set Var
49+
exprVarsOnlyVars = exprVars . exprVarsOnlyToExpr
50+
51+
exprVarsOnlyMaxVar :: ExprVarsOnly -> Var
52+
exprVarsOnlyMaxVar = maximum . exprVarsOnlyVars
53+
4254
simplifyExpr :: Expr -> Expr
4355
simplifyExpr = listToExpr . normalizeTerms . exprToList
4456

57+
simplifyExprVarsOnly :: ExprVarsOnly -> ExprVarsOnly
58+
simplifyExprVarsOnly = listToExprVarsOnly . normalizeTermsVarsOnly . exprVarsOnlyToList
59+
4560
sumExprConstTerms :: Expr -> SimplexNum
4661
sumExprConstTerms (Expr ts) = sumExprConstTerms ts
4762
where
48-
sumExprConstTerms = sum . Maybe.mapMaybe termConst . NE.toList
63+
sumExprConstTerms = sum . Maybe.mapMaybe termConst
4964

5065
termConst :: Term -> Maybe SimplexNum
5166
termConst (ConstTerm c) = Just c
5267
termConst _ = Nothing
5368

5469
zeroConstExpr :: Expr -> Expr
55-
zeroConstExpr (Expr ts) = Expr $ NE.map zeroConstTerm ts
70+
zeroConstExpr (Expr ts) = Expr $ map zeroConstTerm ts
5671

5772
negateExpr :: Expr -> Expr
58-
negateExpr (Expr ts) = Expr $ NE.map negateTerm ts
73+
negateExpr (Expr ts) = Expr $ map negateTerm ts
5974

6075
addExpr :: Expr -> Expr -> Expr
6176
addExpr e1 e2 =
@@ -90,12 +105,29 @@ substVarExpr var varReplacement = simplifyExpr . listToExpr . aux . exprToList
90105
else t : aux ts
91106
(ConstTerm _) -> t : aux ts
92107

108+
substVarExprVarsOnly :: Var -> ExprVarsOnly -> ExprVarsOnly -> ExprVarsOnly
109+
substVarExprVarsOnly var varReplacement expr =
110+
let varReplacement' = exprVarsOnlyToExpr varReplacement
111+
expr' = exprVarsOnlyToExpr expr
112+
result' = substVarExpr var varReplacement' expr'
113+
in unsafeExprToExprVarsOnly result'
114+
115+
unsafeExprToExprVarsOnly :: Expr -> ExprVarsOnly
116+
unsafeExprToExprVarsOnly (Expr ts) = ExprVarsOnly (map unsafeTermToTermVarsOnly ts)
117+
93118
exprToExprVarsOnly :: Expr -> Either String ExprVarsOnly
94-
exprToExprVarsOnly (Expr ts) = do
119+
exprToExprVarsOnly expr@(Expr ts) = do
95120
if any isConstTerm ts
96-
then Left "safeExprToExprVarsOnly: Expr contains ConstTerm"
97-
else Right $ ExprVarsOnly (NE.map unsafeTermToTermVarsOnly ts)
121+
then
122+
if sumExprConstTerms expr == 0
123+
then Right $ ExprVarsOnly []
124+
else
125+
Left $ "safeExprToExprVarsOnly: Expr contains ConstTerm. Expr: " <> show expr
126+
else Right $ unsafeExprToExprVarsOnly expr
98127
where
99128
isConstTerm :: Term -> Bool
100129
isConstTerm (ConstTerm _) = True
101130
isConstTerm _ = False
131+
132+
exprVarsOnlyToExpr :: ExprVarsOnly -> Expr
133+
exprVarsOnlyToExpr (ExprVarsOnly ts) = Expr $ map termVarsOnlyToTerm ts

0 commit comments

Comments
 (0)