From ad4d8e3e96080077585ffa7fb596426cfbcdde41 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Fri, 14 Jul 2023 15:56:09 +0100 Subject: [PATCH 01/47] Initial refactor - much better types + Use types which are way clearer + Some docs + Use lens where they make things easier + New types required quite a significant factor of the codebase + TODO: + Cleanup + Further refactoring/polishing + I want type names to reflect those typically used when talking about simplex methods + But first, I need to learn what the actual terms are + I'd also like to simplify a lot of these functions + The refactor has made it easier for me to think about these functions, which makes it easier to simplify them --- README.md | 24 +- fourmolu.yaml | 10 +- simplex-method.cabal | 16 +- src/Linear/Simplex/Prettify.hs | 46 +- src/Linear/Simplex/Simplex.hs | 464 +++++++++++++------ src/Linear/Simplex/Types.hs | 222 +++++++-- src/Linear/Simplex/Util.hs | 313 +++++++++---- test/Spec.hs | 2 +- test/TestFunctions.hs | 795 +++++++++++++++++---------------- 9 files changed, 1179 insertions(+), 713 deletions(-) diff --git a/README.md b/README.md index 1bf5244..6151440 100644 --- a/README.md +++ b/README.md @@ -20,21 +20,21 @@ The `PolyConstraint` type, as well as other custom types required by this librar ```haskell data PolyConstraint = - LEQ VarConstMap Rational | - GEQ VarConstMap Rational | - EQ VarConstMap Rational deriving (Show, Eq); + LEQ Vars Rational | + GEQ Vars Rational | + EQ Vars Rational deriving (Show, Eq); ``` -And `VarConstMap` is defined as: +And `Vars` is defined as: ```haskell -type VarConstMap = [(Integer, Rational)] +type Vars = [(Integer, Rational)] ``` -A `VarConstMap` is treated as a list of `Integer` variables mapped to their `Rational` coefficients, with an implicit `+` between each element in the list. +A `Vars` is treated as a list of `Integer` variables mapped to their `Rational` coefficients, with an implicit `+` between each element in the list. For example: `[(1, 2), (2, (-3)), (1, 3)]` is equivalent to `(2x1 + (-3x2) + 3x1)`. -And a `PolyConstraint` is an inequality/equality where the LHS is a `VarConstMap` and the RHS is a `Rational`. +And a `PolyConstraint` is an inequality/equality where the LHS is a `Vars` and the RHS is a `Rational`. For example: `LEQ [(1, 2), (2, (-3)), (1, 3)] 60` is equivalent to `(2x1 + (-3x2) + 3x1) <= 60`. Passing a `[PolyConstraint]` to `findFeasibleSolution` will return a feasible solution if it exists as well as a list of slack variables, artificial variables, and a variable that can be safely used to represent the objective for phase two. @@ -42,24 +42,24 @@ Passing a `[PolyConstraint]` to `findFeasibleSolution` will return a feasible so The feasible system is returned as the type `DictionaryForm`: ```haskell -type DictionaryForm = [(Integer, VarConstMap)] +type DictionaryForm = [(Integer, Vars)] ``` -`DictionaryForm` can be thought of as a list of equations, where the `Integer` represents a basic variable on the LHS that is equal to the RHS represented as a `VarConstMap`. In this `VarConstMap`, the `Integer` -1 is used internally to represent a `Rational` number. +`DictionaryForm` can be thought of as a list of equations, where the `Integer` represents a basic variable on the LHS that is equal to the RHS represented as a `Vars`. In this `Vars`, the `Integer` -1 is used internally to represent a `Rational` number. ### Phase Two `optimizeFeasibleSystem` performs phase two of the simplex method, and has the type: ```haskell -data ObjectiveFunction = Max VarConstMap | Min VarConstMap deriving (Show, Eq) +data ObjectiveFunction = Max Vars | Min Vars deriving (Show, Eq) optimizeFeasibleSystem :: ObjectiveFunction -> DictionaryForm -> [Integer] -> [Integer] -> Integer -> Maybe (Integer, [(Integer, Rational)]) ``` We first pass an `ObjectiveFunction`. Then we give a feasible system in `DictionaryForm`, a list of slack variables, a list of artificial variables, and a variable to represent the objective. -`optimizeFeasibleSystem` Maximizes/Minimizes the linear equation represented as a `VarConstMap` in the given `ObjectiveFunction`. +`optimizeFeasibleSystem` Maximizes/Minimizes the linear equation represented as a `Vars` in the given `ObjectiveFunction`. The first item of the returned pair is the `Integer` variable representing the objective. The second item is a list of `Integer` variables mapped to their optimized values. If a variable is not in this list, the variable is equal to 0. @@ -87,7 +87,7 @@ There are similar functions for `DictionaryForm` as well as other custom types i ## Usage notes -You must only use positive `Integer` variables in a `VarConstMap`. +You must only use positive `Integer` variables in a `Vars`. This implementation assumes that the user only provides positive `Integer` variables; the `Integer` -1, for example, is sometimes used to represent a `Rational` number. ## Example diff --git a/fourmolu.yaml b/fourmolu.yaml index cb7e946..b778c1d 100644 --- a/fourmolu.yaml +++ b/fourmolu.yaml @@ -2,14 +2,14 @@ indentation: 2 column-limit: none function-arrows: trailing comma-style: leading -import-export-style: diff-friendly +import-export-style: leading indent-wheres: true record-brace-space: true newlines-between-decls: 1 -haddock-style: multi-line -haddock-style-module: -let-style: auto -in-style: right-align +haddock-style: single-line +haddock-style-module: single-line +let-style: inline +in-style: left-align single-constraint-parens: always unicode: never respectful: true diff --git a/simplex-method.cabal b/simplex-method.cabal index 80ceb5b..6e8bf3f 100644 --- a/simplex-method.cabal +++ b/simplex-method.cabal @@ -27,9 +27,17 @@ source-repository head common common-extensions default-extensions: + DataKinds + DeriveFunctor + DeriveGeneric + DuplicateRecordFields + FlexibleContexts LambdaCase + OverloadedLabels + RecordWildCards TupleSections - + TypeApplications + ImportQualifiedPost library import: common-extensions exposed-modules: @@ -40,7 +48,10 @@ library hs-source-dirs: src build-depends: - base >=4.7 && <5 + base + , containers + , generic-lens + , lens default-language: Haskell2010 test-suite simplex-haskell-test @@ -54,4 +65,5 @@ test-suite simplex-haskell-test build-depends: base >=4.7 && <5 , simplex-method + , containers default-language: Haskell2010 diff --git a/src/Linear/Simplex/Prettify.hs b/src/Linear/Simplex/Prettify.hs index c422590..0aff555 100644 --- a/src/Linear/Simplex/Prettify.hs +++ b/src/Linear/Simplex/Prettify.hs @@ -1,36 +1,42 @@ -{- | -Module : Linear.Simplex.Prettify -Description : Prettifier for "Linear.Simplex.Types" types -Copyright : (c) Junaid Rasheed, 2020-2022 -License : BSD-3 -Maintainer : jrasheed178@gmail.com -Stability : experimental +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE RankNTypes #-} -Converts "Linear.Simplex.Types" types into human-readable 'String's --} +-- | +-- Module : Linear.Simplex.Prettify +-- Description : Prettifier for "Linear.Simplex.Types" types +-- Copyright : (c) Junaid Rasheed, 2020-2022 +-- License : BSD-3 +-- Maintainer : jrasheed178@gmail.com +-- Stability : experimental +-- +-- Converts "Linear.Simplex.Types" types into human-readable 'String's module Linear.Simplex.Prettify where +import Control.Lens +import Data.Generics.Labels () +import Data.Map qualified as M import Data.Ratio -import Linear.Simplex.Types as T +import Linear.Simplex.Types -- | Convert a 'VarConstMap' into a human-readable 'String' -prettyShowVarConstMap :: VarConstMap -> String -prettyShowVarConstMap [] = "" -prettyShowVarConstMap [(v, c)] = prettyShowRational c ++ " * x" ++ show v ++ "" +prettyShowVarConstMap :: VarLitMapSum -> String +prettyShowVarConstMap = aux . M.toList where - prettyShowRational r = - if r < 0 - then "(" ++ r' ++ ")" - else r' + aux [] = "" + aux ((vName, vCoeff) : vs) = prettyShowRational vCoeff ++ " * " ++ show vName ++ " + " ++ aux vs where - r' = if denominator r == 1 then show (numerator r) else show (numerator r) ++ " / " ++ show (numerator r) -prettyShowVarConstMap ((v, c) : vcs) = prettyShowVarConstMap [(v, c)] ++ " + " ++ prettyShowVarConstMap vcs + prettyShowRational r = + if r < 0 + then "(" ++ r' ++ ")" + else r' + where + r' = if denominator r == 1 then show (numerator r) else show (numerator r) ++ " / " ++ show (numerator r) -- | Convert a 'PolyConstraint' into a human-readable 'String' prettyShowPolyConstraint :: PolyConstraint -> String prettyShowPolyConstraint (LEQ vcm r) = prettyShowVarConstMap vcm ++ " <= " ++ show r prettyShowPolyConstraint (GEQ vcm r) = prettyShowVarConstMap vcm ++ " >= " ++ show r -prettyShowPolyConstraint (T.EQ vcm r) = prettyShowVarConstMap vcm ++ " == " ++ show r +prettyShowPolyConstraint (Linear.Simplex.Types.EQ vcm r) = prettyShowVarConstMap vcm ++ " == " ++ show r -- | Convert an 'ObjectiveFunction' into a human-readable 'String' prettyShowObjectiveFunction :: ObjectiveFunction -> String diff --git a/src/Linear/Simplex/Simplex.hs b/src/Linear/Simplex/Simplex.hs index 71b2a3d..e8571fe 100644 --- a/src/Linear/Simplex/Simplex.hs +++ b/src/Linear/Simplex/Simplex.hs @@ -1,22 +1,26 @@ -{- | -Module : Linear.Simplex.Simplex -Description : Implements the twoPhaseSimplex method -Copyright : (c) Junaid Rasheed, 2020-2022 -License : BSD-3 -Maintainer : jrasheed178@gmail.com -Stability : experimental - -Module implementing the two-phase simplex method. -'findFeasibleSolution' performs phase one of the two-phase simplex method. -'optimizeFeasibleSystem' performs phase two of the two-phase simplex method. -'twoPhaseSimplex' performs both phases of the two-phase simplex method. --} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Linear.Simplex.Simplex +-- Description : Implements the twoPhaseSimplex method +-- Copyright : (c) Junaid Rasheed, 2020-2022 +-- License : BSD-3 +-- Maintainer : jrasheed178@gmail.com +-- Stability : experimental +-- +-- Module implementing the two-phase simplex method. +-- 'findFeasibleSolution' performs phase one of the two-phase simplex method. +-- 'optimizeFeasibleSystem' performs phase two of the two-phase simplex method. +-- 'twoPhaseSimplex' performs both phases of the two-phase simplex method. module Linear.Simplex.Simplex (findFeasibleSolution, optimizeFeasibleSystem, twoPhaseSimplex) where +import Control.Lens import Data.Bifunctor import Data.List -import Data.Maybe (fromMaybe, mapMaybe) +import Data.Map qualified as M +import Data.Maybe (fromJust, fromMaybe, mapMaybe) import Data.Ratio (denominator, numerator, (%)) +import GHC.Real (Ratio) import Linear.Simplex.Types import Linear.Simplex.Util import Prelude hiding (EQ) @@ -25,23 +29,38 @@ import Prelude hiding (EQ) trace s a = a -{- | Find a feasible solution for the given system of 'PolyConstraint's by performing the first phase of the two-phase simplex method - All 'Integer' variables in the 'PolyConstraint' must be positive. - If the system is infeasible, return 'Nothing' - Otherwise, return the feasible system in 'DictionaryForm' as well as a list of slack variables, a list artificial variables, and the objective variable. --} -findFeasibleSolution :: [PolyConstraint] -> Maybe (DictionaryForm, [Integer], [Integer], Integer) +-- | Find a feasible solution for the given system of 'PolyConstraint's by performing the first phase of the two-phase simplex method +-- All 'Integer' variables in the 'PolyConstraint' must be positive. +-- If the system is infeasible, return 'Nothing' +-- Otherwise, return the feasible system in 'Dict' as well as a list of slack variables, a list artificial variables, and the objective variable. +findFeasibleSolution :: [PolyConstraint] -> Maybe FeasibleSystem findFeasibleSolution unsimplifiedSystem = if null artificialVars -- No artificial vars, we have a feasible system - then Just (systemWithBasicVarsAsDictionary, slackVars, artificialVars, objectiveVar) - else case simplexPivot (createObjectiveDict artificialObjective objectiveVar : systemWithBasicVarsAsDictionary) of + then Just $ FeasibleSystem systemWithBasicVarsAsDictionary slackVars artificialVars objectiveVar + else -- else case simplexPivot (objectiveVar, artificialObjective ^. #objective) systemWithBasicVarsAsDictionary of + case simplexPivot artificialPivotObjective systemWithBasicVarsAsDictionary of Just phase1Dict -> - let eliminateArtificialVarsFromPhase1Tableau = map (second (filter (\(v, _) -> v `notElem` artificialVars))) phase1Dict - in case lookup objectiveVar eliminateArtificialVarsFromPhase1Tableau of + let eliminateArtificialVarsFromPhase1Tableau = + M.map + ( \DictValue {..} -> + DictValue + { varMapSum = M.filterWithKey (\k _ -> k `notElem` artificialVars) varMapSum + , .. + } + ) + phase1Dict + in case M.lookup objectiveVar eliminateArtificialVarsFromPhase1Tableau of Nothing -> trace "objective row not found in phase 1 tableau" Nothing -- Should this be an error? Just row -> - if fromMaybe 0 (lookup (-1) row) == 0 - then Just (eliminateArtificialVarsFromPhase1Tableau, slackVars, artificialVars, objectiveVar) + if row ^. #constant == 0 + then + Just $ + FeasibleSystem + { dict = eliminateArtificialVarsFromPhase1Tableau + , slackVars = slackVars + , artificialVars = artificialVars + , objectiveVar = objectiveVar + } else trace "rhs not zero after phase 1, thus original tableau is infeasible" Nothing Nothing -> Nothing where @@ -51,9 +70,9 @@ findFeasibleSolution unsimplifiedSystem = maximum $ map ( \case - LEQ vcm _ -> maximum (map fst vcm) - GEQ vcm _ -> maximum (map fst vcm) - EQ vcm _ -> maximum (map fst vcm) + LEQ vcm _ -> maximum (map fst $ M.toList vcm) + GEQ vcm _ -> maximum (map fst $ M.toList vcm) + EQ vcm _ -> maximum (map fst $ M.toList vcm) ) system @@ -67,7 +86,7 @@ findFeasibleSolution unsimplifiedSystem = systemWithBasicVarsAsDictionary = tableauInDictionaryForm systemWithBasicVars - artificialObjective = createArtificialObjective systemWithBasicVarsAsDictionary artificialVars + artificialPivotObjective = createArtificialPivotObjective systemWithBasicVarsAsDictionary artificialVars objectiveVar = finalMaxVar + 1 @@ -77,16 +96,22 @@ findFeasibleSolution unsimplifiedSystem = -- If a constraint is already EQ, set the basic var to Nothing. -- Final system is a list of equalities for the given system. -- To be feasible, all vars must be >= 0. - systemInStandardForm :: [PolyConstraint] -> Integer -> [Integer] -> ([(Maybe Integer, PolyConstraint)], [Integer]) + -- TODO: Maybe add equation type, and make this an equation + -- TODO: If we add an equation type, some other types should become aliases (e.g., TableauRow) + -- TODO: Proposed return type: ([(Maybe Var, PolyConstraint)], [Var]) + -- (I.e., Partial tableau with slack vars) + -- TODO: Look into an intermediary system type + -- Have a type level guarantee for slack vars with 1/-1 coeff + systemInStandardForm :: [PolyConstraint] -> Var -> [Var] -> ([(Maybe Var, PolyConstraint)], [Var]) systemInStandardForm [] _ sVars = ([], sVars) systemInStandardForm (EQ v r : xs) maxVar sVars = ((Nothing, EQ v r) : newSystem, newSlackVars) where (newSystem, newSlackVars) = systemInStandardForm xs maxVar sVars - systemInStandardForm (LEQ v r : xs) maxVar sVars = ((Just newSlackVar, EQ (v ++ [(newSlackVar, 1)]) r) : newSystem, newSlackVars) + systemInStandardForm (LEQ v r : xs) maxVar sVars = ((Just newSlackVar, EQ (M.insert newSlackVar 1 v) r) : newSystem, newSlackVars) where newSlackVar = maxVar + 1 (newSystem, newSlackVars) = systemInStandardForm xs newSlackVar (newSlackVar : sVars) - systemInStandardForm (GEQ v r : xs) maxVar sVars = ((Just newSlackVar, EQ (v ++ [(newSlackVar, -1)]) r) : newSystem, newSlackVars) + systemInStandardForm (GEQ v r : xs) maxVar sVars = ((Just newSlackVar, EQ (M.insert newSlackVar (-1) v) r) : newSystem, newSlackVars) where newSlackVar = maxVar + 1 (newSystem, newSlackVars) = systemInStandardForm xs newSlackVar (newSlackVar : sVars) @@ -98,103 +123,211 @@ findFeasibleSolution unsimplifiedSystem = -- Final system will be a feasible artificial system. -- We keep track of artificial vars in the second item of the returned pair so they can be eliminated once phase 1 is complete. -- If an artificial var would normally be negative, we negate the row so we can keep artificial variables equal to 1 - systemWithArtificialVars :: [(Maybe Integer, PolyConstraint)] -> Integer -> (Tableau, [Integer]) - systemWithArtificialVars [] _ = ([], []) + systemWithArtificialVars :: [(Maybe Var, PolyConstraint)] -> Var -> (Tableau, [Var]) + systemWithArtificialVars [] _ = (M.empty, []) systemWithArtificialVars ((mVar, EQ v r) : pcs) maxVar = case mVar of Nothing -> if r >= 0 - then ((newArtificialVar, (v ++ [(newArtificialVar, 1)], r)) : newSystemWithNewMaxVar, newArtificialVar : artificialVarsWithNewMaxVar) - else ((newArtificialVar, (v ++ [(newArtificialVar, -1)], r)) : newSystemWithNewMaxVar, newArtificialVar : artificialVarsWithNewMaxVar) + then (M.insert newArtificialVar (TableauRow {lhs = M.insert newArtificialVar 1 v, rhs = r}) newSystemWithNewMaxVar, newArtificialVar : artificialVarsWithNewMaxVar) + else (M.insert newArtificialVar (TableauRow {lhs = M.insert newArtificialVar (-1) v, rhs = r}) newSystemWithNewMaxVar, newArtificialVar : artificialVarsWithNewMaxVar) Just basicVar -> - case lookup basicVar v of + case M.lookup basicVar v of Just basicVarCoeff -> if r == 0 - then ((basicVar, (v, r)) : newSystemWithoutNewMaxVar, artificialVarsWithoutNewMaxVar) + then (M.insert basicVar (TableauRow {lhs = v, rhs = r}) newSystemWithoutNewMaxVar, artificialVarsWithoutNewMaxVar) else if r > 0 then if basicVarCoeff >= 0 -- Should only be 1 in the standard call path - then ((basicVar, (v, r)) : newSystemWithoutNewMaxVar, artificialVarsWithoutNewMaxVar) - else ((newArtificialVar, (v ++ [(newArtificialVar, 1)], r)) : newSystemWithNewMaxVar, newArtificialVar : artificialVarsWithNewMaxVar) -- Slack var is negative, r is positive (when original constraint was GEQ) + then (M.insert basicVar (TableauRow {lhs = v, rhs = r}) newSystemWithoutNewMaxVar, artificialVarsWithoutNewMaxVar) + else (M.insert newArtificialVar (TableauRow {lhs = M.insert newArtificialVar 1 v, rhs = r}) newSystemWithNewMaxVar, newArtificialVar : artificialVarsWithNewMaxVar) -- Slack var is negative, r is positive (when original constraint was GEQ) else -- r < 0 if basicVarCoeff <= 0 -- Should only be -1 in the standard call path - then ((basicVar, (v, r)) : newSystemWithoutNewMaxVar, artificialVarsWithoutNewMaxVar) - else ((newArtificialVar, (v ++ [(newArtificialVar, -1)], r)) : newSystemWithNewMaxVar, newArtificialVar : artificialVarsWithNewMaxVar) -- Slack var is negative, r is negative (when original constraint was LEQ) + then (M.insert basicVar (TableauRow {lhs = v, rhs = r}) newSystemWithoutNewMaxVar, artificialVarsWithoutNewMaxVar) + else (M.insert newArtificialVar (TableauRow {lhs = M.insert newArtificialVar (-1) v, rhs = r}) newSystemWithNewMaxVar, newArtificialVar : artificialVarsWithNewMaxVar) -- Slack var is negative, r is negative (when original constraint was LEQ) + Nothing -> error "1" -- undefined where newArtificialVar = maxVar + 1 (newSystemWithNewMaxVar, artificialVarsWithNewMaxVar) = systemWithArtificialVars pcs newArtificialVar (newSystemWithoutNewMaxVar, artificialVarsWithoutNewMaxVar) = systemWithArtificialVars pcs maxVar + systemWithArtificialVars _ _ = error "2" -- undefined + + -- phase1PivotObjective :: PivotObjective + -- phase1PivotObjective = + -- PivotObjective + -- { variable = objectiveVar + -- , function = if isMax objFunction then objFunction ^. #objective else M.map negate (objFunction ^. #objective) + -- , constants = M.empty + -- } -- Create an artificial objective using the given 'Integer' list of artificialVars and the given 'DictionaryForm'. -- The artificial 'ObjectiveFunction' is the negated sum of all artificial vars. - createArtificialObjective :: DictionaryForm -> [Integer] -> ObjectiveFunction - createArtificialObjective rows artificialVars = Max negatedSumWithoutArtificialVars + -- createArtificialObjective :: DictionaryForm -> [Integer] -> ObjectiveFunction + -- createArtificialObjective rows artificialVars = Max negatedSumWithoutArtificialVars + -- where + -- rowsToAdd = filter (\(i, _) -> i `elem` artificialVars) rows + -- negatedRows = map (\(_, vcm) -> map (second negate) vcm) rowsToAdd + -- negatedSum = foldSumVarConstMap ((sort . concat) negatedRows) + -- negatedSumWithoutArtificialVars = filter (\(v, _) -> v `notElem` artificialVars) negatedSum + + createArtificialPivotObjective :: Dict -> [Var] -> PivotObjective + createArtificialPivotObjective rows artificialVars = + PivotObjective + { variable = objectiveVar + , function = foldVarLitMap $ map (^. #varMapSum) negatedRowsWithoutArtificialVars + } where - rowsToAdd = filter (\(i, _) -> i `elem` artificialVars) rows - negatedRows = map (\(_, vcm) -> map (second negate) vcm) rowsToAdd - negatedSum = foldSumVarConstMap ((sort . concat) negatedRows) - negatedSumWithoutArtificialVars = filter (\(v, _) -> v `notElem` artificialVars) negatedSum - -{- | Optimize a feasible system by performing the second phase of the two-phase simplex method. - We first pass an 'ObjectiveFunction'. - Then, the feasible system in 'DictionaryForm' as well as a list of slack variables, a list artificial variables, and the objective variable. - Returns a pair with the first item being the 'Integer' variable equal to the 'ObjectiveFunction' - and the second item being a map of the values of all 'Integer' variables appearing in the system, including the 'ObjectiveFunction'. --} -optimizeFeasibleSystem :: ObjectiveFunction -> DictionaryForm -> [Integer] -> [Integer] -> Integer -> Maybe (Integer, [(Integer, Rational)]) -optimizeFeasibleSystem unsimplifiedObjFunction phase1Dict slackVars artificialVars objectiveVar = + -- test2 = foldr (+) 0 test + + -- test3 :: [Ratio Integer] + -- test3 = undefined + + -- test = map (^. #constant) negatedRowsWithoutArtificialVars + -- Filter out non-artificial entries + rowsToAdd = M.filterWithKey (\k _ -> k `elem` artificialVars) rows + -- Negate rows, discard keys and artificial vars since the pivot objective does not care about them + negatedRowsWithoutArtificialVars = + map + ( \(_, DictValue {..}) -> + DictValue + { varMapSum = M.map negate $ M.filterWithKey (\k _ -> k `notElem` artificialVars) varMapSum + , constant = negate constant + } + ) + $ M.toList rowsToAdd + +-- | Optimize a feasible system by performing the second phase of the two-phase simplex method. +-- We first pass an 'ObjectiveFunction'. +-- Then, the feasible system in 'DictionaryForm' as well as a list of slack variables, a list artificial variables, and the objective variable. +-- Returns a pair with the first item being the 'Integer' variable equal to the 'ObjectiveFunction' +-- and the second item being a map of the values of all 'Integer' variables appearing in the system, including the 'ObjectiveFunction'. +optimizeFeasibleSystem :: ObjectiveFunction -> FeasibleSystem -> Maybe Result +optimizeFeasibleSystem unsimplifiedObjFunction (FeasibleSystem {dict = phase1Dict, ..}) = if null artificialVars - then displayResults . dictionaryFormToTableau <$> simplexPivot (createObjectiveDict objFunction objectiveVar : phase1Dict) - else displayResults . dictionaryFormToTableau <$> simplexPivot (createObjectiveDict phase2ObjFunction objectiveVar : tail phase1Dict) + then -- then displayResults . dictionaryFormToTableau <$> simplexPivot (createObjectiveDict objFunction objectiveVar : phase1Dict) + -- else displayResults . dictionaryFormToTableau <$> simplexPivot (createObjectiveDict phase2ObjFunction objectiveVar : tail phase1Dict) + displayResults . dictionaryFormToTableau <$> simplexPivot phase1PivotObjective phase1Dict + else displayResults . dictionaryFormToTableau <$> simplexPivot phase2PivotObjective phase1Dict where objFunction = simplifyObjectiveFunction unsimplifiedObjFunction - displayResults :: Tableau -> (Integer, [(Integer, Rational)]) + displayResults :: Tableau -> Result displayResults tableau = - ( objectiveVar - , case objFunction of - Max _ -> - map - (second snd) - $ filter (\(basicVar, _) -> basicVar `notElem` slackVars ++ artificialVars) tableau - Min _ -> - map -- We maximized -objVar, so we negate the objVar to get the final value - (\(basicVar, row) -> if basicVar == objectiveVar then (basicVar, negate (snd row)) else (basicVar, snd row)) - $ filter (\(basicVar, _) -> basicVar `notElem` slackVars ++ artificialVars) tableau - ) - - phase2Objective = - (foldSumVarConstMap . sort) $ - concatMap - ( \(var, coeff) -> - case lookup var phase1Dict of - Nothing -> [(var, coeff)] - Just row -> map (second (* coeff)) row - ) - (getObjective objFunction) + Result + { objectiveVar = objectiveVar + , varValMap = extractVarVals + } + where + extractVarVals = + let tableauWithOriginalVars = + M.filterWithKey + ( \basicVarName _ -> + basicVarName `notElem` slackVars ++ artificialVars + ) + tableau + in case objFunction of + Max _ -> + M.map + ( \tableauRow -> + tableauRow ^. #rhs + ) + tableauWithOriginalVars + Min _ -> + M.mapWithKey -- We maximized -objVar, so we negate the objVar to get the final value + ( \basicVarName tableauRow -> + if basicVarName == objectiveVar + then negate $ tableauRow ^. #rhs + else tableauRow ^. #rhs + ) + tableauWithOriginalVars + + phase1PivotObjective :: PivotObjective + phase1PivotObjective = + PivotObjective + { variable = objectiveVar + , function = if isMax objFunction then objFunction ^. #objective else M.map negate (objFunction ^. #objective) + -- , constants = M.empty + } + + -- TODO: New type for Phase2Objective + phase2PivotObjective :: PivotObjective + phase2PivotObjective = + PivotObjective + { variable = objectiveVar + , function = calcVarMap + -- , constants = calcConstants + } + where + -- type VarLitMapSum = M.Map Var SimplexNum + -- (foldSumVarConstMap . sort) $ + + -- combineMaps = + -- M.mapWithKey + -- (\var varValMap -> + -- case M.lookup var calcConstants of + -- Just constant -> + -- DictValue + -- { varMapSum = M.singleton var varValMap + -- , constant = constant + -- } + -- Nothing -> error "Bad branch" + -- ) + -- $ calcVarMap + + calcConstants :: VarLitMap + calcConstants = + M.mapWithKey + ( \var coeff -> + case M.lookup var phase1Dict of + Nothing -> 0 + Just row -> (row ^. #constant) * coeff + ) + $ objFunction ^. #objective - phase2ObjFunction = if isMax objFunction then Max phase2Objective else Min phase2Objective + calcVarMap :: VarLitMapSum + calcVarMap = + M.fromList + $ concatMap + ( \(var, coeff) -> + let multiplyWith = if isMax objFunction then coeff else -coeff + in case M.lookup var phase1Dict of + Nothing -> + -- DictValue + -- { varMapSum = M.singleton var coeff + -- , constant = 0 + -- } + [(var, multiplyWith)] + Just row -> map (second (* multiplyWith)) (M.toList $ row ^. #varMapSum) + -- row + -- & #varMapSum %~ M.map (* coeff) + -- & #constant %~ (* coeff) -- TODO: Apply 0 + -- map (second (* coeff)) row + ) + $ M.toList (objFunction ^. #objective) -{- | Perform the two phase simplex method with a given 'ObjectiveFunction' a system of 'PolyConstraint's. - Assumes the 'ObjectiveFunction' and 'PolyConstraint' is not empty. - Returns a pair with the first item being the 'Integer' variable equal to the 'ObjectiveFunction' - and the second item being a map of the values of all 'Integer' variables appearing in the system, including the 'ObjectiveFunction'. --} -twoPhaseSimplex :: ObjectiveFunction -> [PolyConstraint] -> Maybe (Integer, [(Integer, Rational)]) +-- phase2ObjFunction = +-- undefined +-- if isMax objFunction then Max phase2ObjectiveRow else Min phase2ObjectiveRow + +-- | Perform the two phase simplex method with a given 'ObjectiveFunction' a system of 'PolyConstraint's. +-- Assumes the 'ObjectiveFunction' and 'PolyConstraint' is not empty. +-- Returns a pair with the first item being the 'Integer' variable equal to the 'ObjectiveFunction' +-- and the second item being a map of the values of all 'Integer' variables appearing in the system, including the 'ObjectiveFunction'. +twoPhaseSimplex :: ObjectiveFunction -> [PolyConstraint] -> Maybe Result twoPhaseSimplex objFunction unsimplifiedSystem = case findFeasibleSolution unsimplifiedSystem of - Just r@(phase1Dict, slackVars, artificialVars, objectiveVar) -> optimizeFeasibleSystem objFunction phase1Dict slackVars artificialVars objectiveVar + Just feasibleSystem -> optimizeFeasibleSystem objFunction feasibleSystem Nothing -> Nothing -- | Perform the simplex pivot algorithm on a system with basic vars, assume that the first row is the 'ObjectiveFunction'. -simplexPivot :: DictionaryForm -> Maybe DictionaryForm -simplexPivot dictionary = +simplexPivot :: PivotObjective -> Dict -> Maybe Dict +simplexPivot objective@(PivotObjective {variable = objectiveVar, function = objectiveVal, ..}) dictionary = trace (show dictionary) $ - case mostPositive (head dictionary) of + case mostPositive objectiveVal of Nothing -> trace "all neg \n" @@ -203,8 +336,8 @@ simplexPivot dictionary = Just dictionary Just pivotNonBasicVar -> - let mPivotBasicVar = ratioTest (tail dictionary) pivotNonBasicVar Nothing Nothing - in case mPivotBasicVar of + let mPivotBasicVar = ratioTest dictionary pivotNonBasicVar Nothing Nothing + in case mPivotBasicVar of Nothing -> trace ("Ratio test failed on non-basic var: " ++ show pivotNonBasicVar ++ "\n" ++ show dictionary) Nothing Just pivotBasicVar -> trace @@ -212,46 +345,48 @@ simplexPivot dictionary = trace (show dictionary) simplexPivot + objective (pivot pivotBasicVar pivotNonBasicVar dictionary) where - ratioTest :: DictionaryForm -> Integer -> Maybe Integer -> Maybe Rational -> Maybe Integer - ratioTest [] _ mCurrentMinBasicVar _ = mCurrentMinBasicVar - ratioTest ((basicVar, lp) : xs) mostNegativeVar mCurrentMinBasicVar mCurrentMin = - case lookup mostNegativeVar lp of - Nothing -> ratioTest xs mostNegativeVar mCurrentMinBasicVar mCurrentMin - Just currentCoeff -> - let rhs = fromMaybe 0 (lookup (-1) lp) - in if currentCoeff >= 0 || rhs < 0 - then -- trace (show currentCoeff) - ratioTest xs mostNegativeVar mCurrentMinBasicVar mCurrentMin -- rhs was already in right side in original tableau, so should be above zero - -- Coeff needs to be negative since it has been moved to the RHS - else case mCurrentMin of - Nothing -> ratioTest xs mostNegativeVar (Just basicVar) (Just (rhs / currentCoeff)) - Just currentMin -> - if (rhs / currentCoeff) >= currentMin - then ratioTest xs mostNegativeVar (Just basicVar) (Just (rhs / currentCoeff)) - else ratioTest xs mostNegativeVar mCurrentMinBasicVar mCurrentMin - - mostPositive :: (Integer, VarConstMap) -> Maybe Integer - mostPositive (_, lp) = - case findLargestCoeff lp Nothing of - Just (largestVar, largestCoeff) -> - if largestCoeff <= 0 + ratioTest :: Dict -> Var -> Maybe Var -> Maybe Rational -> Maybe Var + ratioTest dict = aux (M.toList dict) + where + aux :: [(Var, DictValue)] -> Var -> Maybe Var -> Maybe Rational -> Maybe Var + aux [] _ mCurrentMinBasicVar _ = mCurrentMinBasicVar + aux (x@(basicVar, dictEquation) : xs) mostNegativeVar mCurrentMinBasicVar mCurrentMin = + case M.lookup mostNegativeVar (dictEquation ^. #varMapSum) of + Nothing -> aux xs mostNegativeVar mCurrentMinBasicVar mCurrentMin + Just currentCoeff -> + let dictEquationConstant = dictEquation ^. #constant + in if currentCoeff >= 0 || dictEquationConstant < 0 + then -- trace (show currentCoeff) + aux xs mostNegativeVar mCurrentMinBasicVar mCurrentMin -- constant was already in right side in original tableau, so should be above zero + -- Coeff needs to be negative since it has been moved to the RHS + else case mCurrentMin of + Nothing -> aux xs mostNegativeVar (Just basicVar) (Just (dictEquationConstant / currentCoeff)) + Just currentMin -> + if (dictEquationConstant / currentCoeff) >= currentMin + then aux xs mostNegativeVar (Just basicVar) (Just (dictEquationConstant / currentCoeff)) + else aux xs mostNegativeVar mCurrentMinBasicVar mCurrentMin + + mostPositive :: VarLitMapSum -> Maybe Var + mostPositive varLitMap = + case findLargestCoeff (M.toList varLitMap) Nothing of + Just (largestVarName, largestVarCoeff) -> + if largestVarCoeff <= 0 then Nothing - else Just largestVar + else Just largestVarName Nothing -> trace "No variables in first row when looking for most positive" Nothing where - findLargestCoeff :: VarConstMap -> Maybe (Integer, Rational) -> Maybe (Integer, Rational) + findLargestCoeff :: [(Var, SimplexNum)] -> Maybe (Var, SimplexNum) -> Maybe (Var, SimplexNum) findLargestCoeff [] mCurrentMax = mCurrentMax - findLargestCoeff ((var, coeff) : xs) mCurrentMax = - if var == (-1) - then findLargestCoeff xs mCurrentMax - else case mCurrentMax of - Nothing -> findLargestCoeff xs (Just (var, coeff)) - Just currentMax -> - if snd currentMax >= coeff - then findLargestCoeff xs mCurrentMax - else findLargestCoeff xs (Just (var, coeff)) + findLargestCoeff (v@(vName, vCoeff) : vs) mCurrentMax = + case mCurrentMax of + Nothing -> findLargestCoeff vs (Just v) + Just (_, currentMaxCoeff) -> + if currentMaxCoeff >= vCoeff + then findLargestCoeff vs mCurrentMax + else findLargestCoeff vs (Just v) -- Pivot a dictionary using the two given variables. -- The first variable is the leaving (non-basic) variable. @@ -259,25 +394,62 @@ simplexPivot dictionary = -- Expects the entering variable to be present in the row containing the leaving variable. -- Expects each row to have a unique basic variable. -- Expects each basic variable to not appear on the RHS of any equation. - pivot :: Integer -> Integer -> DictionaryForm -> DictionaryForm - pivot leavingVariable enteringVariable rows = - case lookup enteringVariable basicRow of - Just nonBasicCoeff -> + pivot :: Var -> Var -> Dict -> Dict + pivot leavingVariable enteringVariable dict = + -- case basicRow ^. #equation ^? folded . filtered (\vt -> enteringVariable == vt ^. #name) of + case M.lookup enteringVariable (dictEntertingRow ^. #varMapSum) of + Just enteringVariableCoeff -> updatedRows where -- Move entering variable to basis, update other variables in row appropriately - pivotEquation = (enteringVariable, map (second (/ negate nonBasicCoeff)) ((leavingVariable, -1) : filter ((enteringVariable /=) . fst) basicRow)) + pivotEnteringRow :: DictValue + pivotEnteringRow = + dictEntertingRow + & #varMapSum + %~ ( \basicEquation -> + uncurry + M.insert + newEnteringVarTerm + (filterOutEnteringVarTerm basicEquation) + & traverse + %~ divideByNegatedEnteringVariableCoeff + ) + & #constant + %~ divideByNegatedEnteringVariableCoeff + where + newEnteringVarTerm = (leavingVariable, -1) + divideByNegatedEnteringVariableCoeff = (/ negate enteringVariableCoeff) + -- Substitute pivot equation into other rows - updatedRows = - map - ( \(basicVar, vMap) -> - if leavingVariable == basicVar - then pivotEquation - else case lookup enteringVariable vMap of - Just subsCoeff -> (basicVar, (foldSumVarConstMap . sort) (map (second (subsCoeff *)) (snd pivotEquation) ++ filter ((enteringVariable /=) . fst) vMap)) - Nothing -> (basicVar, vMap) - ) - rows - Nothing -> trace "non basic variable not found in basic row" undefined + updatedRows :: Dict + updatedRows = M.mapWithKey f dict + where + -- Dict + -- { objective = f $ dict ^. #objectiveFunction + -- , entries = fmap f $ dict ^. #entries + -- } + + f entryVar entryVal = + if leavingVariable == entryVar + then pivotEnteringRow + else case M.lookup enteringVariable (entryVal ^. #varMapSum) of + Just subsCoeff -> + entryVal + & #varMapSum + %~ ( combineVarLitMapSums + (pivotEnteringRow ^. #varMapSum <&> (subsCoeff *)) + . filterOutEnteringVarTerm + ) + Nothing -> entryVal + Nothing -> error "pivot: non basic variable not found in basic row" where - (_, basicRow) = head $ filter ((leavingVariable ==) . fst) rows + -- \| The entering row, i.e., the row in the dict which is the value of + -- leavingVariable. + dictEntertingRow = + fromMaybe + (error "pivot: Basic variable not found in Dict") + $ M.lookup leavingVariable dict + + -- basicDictEquation = basicDictEntry ^. #rhs + + filterOutEnteringVarTerm = M.filterWithKey (\vName _ -> vName /= enteringVariable) diff --git a/src/Linear/Simplex/Types.hs b/src/Linear/Simplex/Types.hs index 19cb78e..dff2247 100644 --- a/src/Linear/Simplex/Types.hs +++ b/src/Linear/Simplex/Types.hs @@ -1,52 +1,182 @@ -{- | -Module : Linear.Simplex.Types -Description : Custom types -Copyright : (c) Junaid Rasheed, 2020-2022 -License : BSD-3 -Maintainer : jrasheed178@gmail.com -Stability : experimental --} +-- | +-- Module : Linear.Simplex.Types +-- Description : Custom types +-- Copyright : (c) Junaid Rasheed, 2020-2022 +-- License : BSD-3 +-- Maintainer : jrasheed178@gmail.com +-- Stability : experimental module Linear.Simplex.Types where -{- | List of 'Integer' variables with their 'Rational' coefficients. - There is an implicit addition between elements in this list. - Users must only provide positive integer variables. +import Control.Lens +import Data.Generics.Labels () +import Data.List (sort) +import Data.Map qualified as M +import GHC.Generics (Generic) - Example: [(2, 3), (6, (-1), (2, 1))] is equivalent to 3x2 + (-x6) + x2. --} -type VarConstMap = [(Integer, Rational)] +type Var = Int -{- | For specifying constraints in a system. - The LHS is a 'VarConstMap', and the RHS, is a 'Rational' number. - LEQ [(1, 2), (2, 1)] 3.5 is equivalent to 2x1 + x2 <= 3.5. - Users must only provide positive integer variables. +-- TODO: Experiment with speed vs string vars type Var = Int +-- TODO: Could also just use (Eq var => var) directly - Example: LEQ [(2, 3), (6, (-1), (2, 1))] 12.3 is equivalent to 3x2 + (-x6) + x2 <= 12.3. --} +type SimplexNum = Rational + +type SystemRow = PolyConstraint + +type System = [SystemRow] + +-- Basically, a tableau where the basic variable may be empty. +-- All non-empty basic vars are slack vars +data SystemWithSlackVarRow = SystemInStandardFormRow + { mSlackVar :: Maybe Var + -- ^ This is Nothing iff the row does not have a slack variable + , row :: TableauRow + } + +type SystemWithSlackVars = [SystemWithSlackVarRow] + +-- data SystemInStandardForm = SystemInStandardForm +-- { mBasicVar :: Maybe Var} + +-- type SystemInStandardForm + +-- data VarTerm = VarTerm +-- { name :: Var +-- , coeff :: SimplexNum +-- } +-- deriving (Show, Read, Eq, Generic) + +data FeasibleSystem = FeasibleSystem + { dict :: Dict + , slackVars :: [Var] + , artificialVars :: [Var] + , objectiveVar :: Var + } + +data Result = Result + { objectiveVar :: Var + , varValMap :: VarLitMap + } + deriving (Show, Read, Eq, Generic) + +data SimplexMeta = SimplexMeta + { objective :: ObjectiveFunction + , feasibleSystem :: Maybe FeasibleSystem + , optimisedResult :: Maybe Result + } + +type VarLitMap = M.Map Var SimplexNum + +-- TURN THIS INTO A FUNCTION +-- instance Ord VarTerm where +-- x <= y = (x ^. #name) <= (y ^. #name) + +-- | List of variables with their 'SimplexNum' coefficients. +-- There is an implicit addition between elements in this list. +-- +-- Example: [Var "x" 3, Var "y" -1, Var "z" 1] is equivalent to 3x + (-y) + z. +type VarLitMapSum = VarLitMap + +-- type VarLitMapSum = [VarLitMapSumEntry] + +-- data VarLitMapSumEntry = +-- VarLitMapSumEntry +-- { name :: Var +-- , coeff :: SimplexNum +-- } + +-- TODO: newtype VarTermSum = VarTermSum [VarTerm] +-- TODO: similar for other aliases + +-- | For specifying constraints in a system. +-- The LHS is a 'Vars', and the RHS, is a 'SimplexNum' number. +-- LEQ [(1, 2), (2, 1)] 3.5 is equivalent to 2x1 + x2 <= 3.5. +-- Users must only provide positive integer variables. +-- +-- Example: LEQ [Var "x" 3, Var "y" -1, Var "x" 1] 12.3 is equivalent to 3x + (-y) + x <= 12.3. data PolyConstraint - = LEQ VarConstMap Rational - | GEQ VarConstMap Rational - | EQ VarConstMap Rational - deriving (Show, Eq) - -{- | Create an objective function. - We can either 'Max'imize or 'Min'imize a 'VarConstMap'. --} -data ObjectiveFunction = Max VarConstMap | Min VarConstMap deriving (Show, Eq) - -{- | A 'Tableau' of equations. - Each pair in the list is a row. - The first item in the pair specifies which 'Integer' variable is basic in the equation. - The second item in the pair is an equation. - The 'VarConstMap' in the second equation is a list of variables with their coefficients. - The RHS of the equation is a 'Rational' constant. --} -type Tableau = [(Integer, (VarConstMap, Rational))] - -{- | Type representing equations. - Each pair in the list is one equation. - The first item of the pair is the basic variable, and is on the LHS of the equation with a coefficient of one. - The RHS is represented using a `VarConstMap`. - The integer variable -1 is used to represent a 'Rational' on the RHS --} -type DictionaryForm = [(Integer, VarConstMap)] + = LEQ {lhs :: VarLitMapSum, rhs :: SimplexNum} + | GEQ {lhs :: VarLitMapSum, rhs :: SimplexNum} + | EQ {lhs :: VarLitMapSum, rhs :: SimplexNum} + deriving (Show, Read, Eq, Generic) + +-- | Create an objective function. +-- We can either 'Max'imize or 'Min'imize a 'VarTermSum'. +-- TODO: Can the objective function contain a constant? +-- It can, but it's not useful. We just care about minimising/maximising vars, +-- not the actual value of the objective function +data ObjectiveFunction = Max {objective :: VarLitMapSum} | Min {objective :: VarLitMapSum} deriving (Show, Read, Eq, Generic) + +-- | TODO: Maybe we want this type +-- TODO: A better/alternative name +data Equation = Equation + { lhs :: VarLitMapSum + , rhs :: SimplexNum } + +-- | value for entry. lhs = rhs. TODO: finish +data TableauRow = TableauRow + { lhs :: VarLitMapSum + , rhs :: SimplexNum + } + deriving (Show, Read, Eq, Generic) + +-- | Entry for a simplex 'Tableau' of equations. +-- The LHS' is a 'VarTermSum'. +-- The RHS of the equation is a 'SimplexNum' constant. +-- The LHS is equal to the RHS. +-- type TableauRows = M.Map Var TableauRow + +-- data TableauObjective = TableauObjective { basicVar :: Var, row :: TableauRow } deriving (Show, Read, Eq, Generic) + +-- data TableauEntry = TableauEntry +-- { basicVarName :: Var +-- , lhs :: VarLitMapSum +-- , rhs :: SimplexNum +-- } +-- deriving (Show, Read, Eq, Generic) + +-- | A simplex 'Tableu' of equations. +-- Each element in the list is a row. +type Tableau = M.Map Var TableauRow + +-- data Tableau = Tableau +-- { objective :: TableauObjective +-- , rows :: TableauRows +-- } +-- deriving (Show, Read, Eq, Generic) + +-- | Values for a 'DictEntry'. TODO: varMapSum + constant +-- TODO: DictValue -> DictRow +data DictValue = DictValue + { varMapSum :: VarLitMapSum + , constant :: SimplexNum + } + deriving (Show, Read, Eq, Generic) + +-- | A single entry for a simplex `Dict`. +-- The LHS is a `Var` and specifies a basic variable. +-- The RHS is a 'DictEquation'. +-- The LHS is equal to the RHS. +-- type DictEntries = M.Map Var DictEntryValue + +-- data DictObjective = DictObjective { lhs :: Var, rhs :: DictEntryValue } deriving (Show, Read, Eq, Generic) + +-- data DictEntry = DictEntry +-- { lhs :: Var +-- , rhs :: DictEquation +-- } +-- deriving (Show, Read, Eq, Generic) + +-- | A simplex 'Dict' +-- One quation represents the objective function. +-- Each pair in the list is one equation in the system we're working with. +-- data Dict = Dict +-- { objective :: DictObjective +-- , entries :: DictEntries +-- } +-- deriving (Show, Read, Eq, Generic) +type Dict = M.Map Var DictValue + +data PivotObjective = PivotObjective + { variable :: Var + , function :: VarLitMapSum + } diff --git a/src/Linear/Simplex/Util.hs b/src/Linear/Simplex/Util.hs index f661a76..8b80ae9 100644 --- a/src/Linear/Simplex/Util.hs +++ b/src/Linear/Simplex/Util.hs @@ -1,17 +1,22 @@ -{- | -Module : Linear.Simplex.Util -Description : Helper functions -Copyright : (c) Junaid Rasheed, 2020-2022 -License : BSD-3 -Maintainer : jrasheed178@gmail.com -Stability : experimental - -Helper functions for performing the two-phase simplex method. --} +-- | +-- Module : Linear.Simplex.Util +-- Description : Helper functions +-- Copyright : (c) Junaid Rasheed, 2020-2022 +-- License : BSD-3 +-- Maintainer : jrasheed178@gmail.com +-- Stability : experimental +-- +-- Helper functions for performing the two-phase simplex method. module Linear.Simplex.Util where +import Control.Lens import Data.Bifunctor +import Data.Generics.Labels () +import Data.Generics.Product (field) import Data.List +import Data.Map qualified as Map +import Data.Map.Merge.Lazy qualified as MapMerge +import Data.Maybe (fromMaybe) import Linear.Simplex.Types import Prelude hiding (EQ) @@ -20,15 +25,9 @@ isMax :: ObjectiveFunction -> Bool isMax (Max _) = True isMax (Min _) = False --- | Extract the objective ('VarConstMap') from an 'ObjectiveFunction' -getObjective :: ObjectiveFunction -> VarConstMap -getObjective (Max o) = o -getObjective (Min o) = o - -{- | Simplifies a system of 'PolyConstraint's by first calling 'simplifyPolyConstraint', - then reducing 'LEQ' and 'GEQ' with same LHS and RHS (and other similar situations) into 'EQ', - and finally removing duplicate elements using 'nub'. --} +-- | Simplifies a system of 'PolyConstraint's by first calling 'simplifyPolyConstraint', +-- then reducing 'LEQ' and 'GEQ' with same LHS and RHS (and other similar situations) into 'EQ', +-- and finally removing duplicate elements using 'nub'. simplifySystem :: [PolyConstraint] -> [PolyConstraint] simplifySystem = nub . reduceSystem . map simplifyPolyConstraint where @@ -44,7 +43,7 @@ simplifySystem = nub . reduceSystem . map simplifyPolyConstraint _ -> False ) pcs - in if null matchingConstraints + in if null matchingConstraints then LEQ lhs rhs : reduceSystem pcs else EQ lhs rhs : reduceSystem (pcs \\ matchingConstraints) -- Reduce GEQ with matching LEQ and EQ into EQ @@ -57,7 +56,7 @@ simplifySystem = nub . reduceSystem . map simplifyPolyConstraint _ -> False ) pcs - in if null matchingConstraints + in if null matchingConstraints then GEQ lhs rhs : reduceSystem pcs else EQ lhs rhs : reduceSystem (pcs \\ matchingConstraints) -- Reduce EQ with matching LEQ and GEQ into EQ @@ -70,79 +69,217 @@ simplifySystem = nub . reduceSystem . map simplifyPolyConstraint _ -> False ) pcs - in if null matchingConstraints + in if null matchingConstraints then EQ lhs rhs : reduceSystem pcs else EQ lhs rhs : reduceSystem (pcs \\ matchingConstraints) --- | Simplify an 'ObjectiveFunction' by first 'sort'ing and then calling 'foldSumVarConstMap' on the 'VarConstMap'. +-- | Simplify an 'ObjectiveFunction' by first 'sort'ing and then calling 'foldSumVarConstMap' on the 'Vars'. simplifyObjectiveFunction :: ObjectiveFunction -> ObjectiveFunction -simplifyObjectiveFunction (Max varConstMap) = Max (foldSumVarConstMap (sort varConstMap)) -simplifyObjectiveFunction (Min varConstMap) = Min (foldSumVarConstMap (sort varConstMap)) +-- simplifyObjectiveFunction (Max vars) = Max (foldSumVarConstMap (sort vars)) +-- simplifyObjectiveFunction (Min vars) = Min (foldSumVarConstMap (sort vars)) +simplifyObjectiveFunction (Max vars) = Max vars +simplifyObjectiveFunction (Min vars) = Min vars --- | Simplify a 'PolyConstraint' by first 'sort'ing and then calling 'foldSumVarConstMap' on the 'VarConstMap'. +-- | Simplify a 'PolyConstraint' by first 'sort'ing and then calling 'foldSumVarConstMap' on the 'Vars'. simplifyPolyConstraint :: PolyConstraint -> PolyConstraint -simplifyPolyConstraint (LEQ varConstMap rhs) = LEQ (foldSumVarConstMap (sort varConstMap)) rhs -simplifyPolyConstraint (GEQ varConstMap rhs) = GEQ (foldSumVarConstMap (sort varConstMap)) rhs -simplifyPolyConstraint (EQ varConstMap rhs) = EQ (foldSumVarConstMap (sort varConstMap)) rhs - --- | Add a sorted list of 'VarConstMap's, folding where the variables are equal -foldSumVarConstMap :: [(Integer, Rational)] -> [(Integer, Rational)] -foldSumVarConstMap [] = [] -foldSumVarConstMap [(v, c)] = [(v, c)] -foldSumVarConstMap ((v1, c1) : (v2, c2) : vcm) = - if v1 == v2 - then - let newC = c1 + c2 - in if newC == 0 - then foldSumVarConstMap vcm - else foldSumVarConstMap $ (v1, c1 + c2) : vcm - else (v1, c1) : foldSumVarConstMap ((v2, c2) : vcm) - --- | Get a map of the value of every 'Integer' variable in a 'Tableau' -displayTableauResults :: Tableau -> [(Integer, Rational)] -displayTableauResults = map (\(basicVar, (_, rhs)) -> (basicVar, rhs)) - --- | Get a map of the value of every 'Integer' variable in a 'DictionaryForm' -displayDictionaryResults :: DictionaryForm -> [(Integer, Rational)] -displayDictionaryResults dict = displayTableauResults $ dictionaryFormToTableau dict +-- simplifyPolyConstraint (LEQ vars rhs) = LEQ (foldSumVarConstMap (sort vars)) rhs +-- simplifyPolyConstraint (GEQ vars rhs) = GEQ (foldSumVarConstMap (sort vars)) rhs +-- simplifyPolyConstraint (EQ vars rhs) = EQ (foldSumVarConstMap (sort vars)) rhs +simplifyPolyConstraint (LEQ vars rhs) = LEQ vars rhs +simplifyPolyConstraint (GEQ vars rhs) = GEQ vars rhs +simplifyPolyConstraint (EQ vars rhs) = EQ vars rhs + +-- | Add a sorted list of 'Vars's, folding where the variables are equal +-- foldSumVarConstMap :: VarLitMapSum -> VarLitMapSum +-- foldSumVarConstMap [] = [] +-- foldSumVarConstMap v@[_] = v +-- foldSumVarConstMap (v1 : v2 : vcm) = +-- if v1 == v2 +-- then +-- let c1 = v1 ^. #coeff +-- c2 = v2 ^. #coeff +-- newC = c1 + c2 +-- in if newC == 0 +-- then foldSumVarConstMap vcm +-- else foldSumVarConstMap $ (v1 & #coeff .~ newC) : vcm +-- else v1 : foldSumVarConstMap (v2 : vcm) + +-- | Get a map of the value of every variable in a 'Tableau' +-- displayTableauResults :: Tableau -> Map.Map Var SimplexNum +-- displayTableauResults = Map.fromList . map (\entry -> (entry ^. #basicVarName, entry ^. #rhs)) + +-- | Get a map of the value of every variable in a 'Dict' +-- displayDictionaryResults :: Dict -> Map.Map Var SimplexNum +-- displayDictionaryResults dict = displayTableauResults $ dictionaryFormToTableau dict -- | Map the given 'Integer' variable to the given 'ObjectiveFunction', for entering into 'DictionaryForm'. -createObjectiveDict :: ObjectiveFunction -> Integer -> (Integer, VarConstMap) -createObjectiveDict (Max obj) objectiveVar = (objectiveVar, obj) -createObjectiveDict (Min obj) objectiveVar = (objectiveVar, map (second negate) obj) - -{- | Converts a 'Tableau' to 'DictionaryForm'. - We do this by isolating the basic variable on the LHS, ending up with all non basic variables and a 'Rational' constant on the RHS. - (-1) is used to represent the rational constant. --} -tableauInDictionaryForm :: Tableau -> DictionaryForm -tableauInDictionaryForm [] = [] -tableauInDictionaryForm ((basicVar, (vcm, r)) : rows) = - (basicVar, (-1, r / basicCoeff) : map (\(v, c) -> (v, negate c / basicCoeff)) nonBasicVars) : tableauInDictionaryForm rows - where - basicCoeff = if null basicVars then 1 else snd $ head basicVars - (basicVars, nonBasicVars) = partition (\(v, _) -> v == basicVar) vcm - -{- | Converts a 'DictionaryForm' to a 'Tableau'. - This is done by moving all non-basic variables from the right to the left. - The rational constant (represented by the 'Integer' variable -1) stays on the right. - The basic variables will have a coefficient of 1 in the 'Tableau'. --} -dictionaryFormToTableau :: DictionaryForm -> Tableau -dictionaryFormToTableau [] = [] -dictionaryFormToTableau ((basicVar, row) : rows) = - (basicVar, ((basicVar, 1) : map (second negate) nonBasicVars, r)) : dictionaryFormToTableau rows - where - (rationalConstant, nonBasicVars) = partition (\(v, _) -> v == (-1)) row - r = if null rationalConstant then 0 else (snd . head) rationalConstant -- If there is no rational constant found in the right side, the rational constant is 0. - -{- | If this function is given 'Nothing', return 'Nothing'. - Otherwise, we 'lookup' the 'Integer' given in the first item of the pair in the map given in the second item of the pair. - This is typically used to extract the value of the 'ObjectiveFunction' after calling 'Linear.Simplex.Simplex.twoPhaseSimplex'. --} -extractObjectiveValue :: Maybe (Integer, [(Integer, Rational)]) -> Maybe Rational -extractObjectiveValue Nothing = Nothing -extractObjectiveValue (Just (objVar, results)) = - case lookup objVar results of +-- createObjectiveDict :: ObjectiveFunction -> Var -> DictObjective +-- createObjectiveDict (Max obj) objectiveVar = +-- DictObjective +-- { lhs = objectiveVar +-- , rhs = +-- DictEntryValue +-- { varMapSum = obj +-- , constant = 0 -- FIXME: was 1? prob should be 0 +-- } +-- } +-- createObjectiveDict (Min obj) objectiveVar = +-- DictObjective +-- { lhs = objectiveVar +-- , rhs = +-- DictEntryValue +-- { varMapSum = Map.map negate obj +-- , constant = 0 -- FIXME: was 1? +-- } +-- } + +-- data DictEntryValue = DictEntryValue +-- { varMapSum :: VarLitMapSum +-- , constant :: SimplexNum +-- } +-- deriving (Show, Read, Eq, Generic) + +-- data TableauRowValue = TableauRowValue +-- { lhs :: VarLitMapSum +-- , rhs :: SimplexNum +-- } +-- deriving (Show, Read, Eq, Generic) + +-- | Converts a 'Dict' to a 'Tableau' using 'dictEntryToTableauEntry'. +-- FIXME: maybe remove this line. The basic variables will have a coefficient of 1 in the 'Tableau'. +dictionaryFormToTableau :: Dict -> Tableau +dictionaryFormToTableau = + Map.mapWithKey + ( \basicVar (DictValue {..}) -> + TableauRow + { lhs = Map.insert basicVar 1 $ negate <$> varMapSum + , rhs = constant + } + ) + +-- { objective = +-- let objecitveBasicVar = objective ^. #lhs +-- objectiveRow = objective ^. #rhs +-- in TableauObjective +-- { basicVar = objecitveBasicVar +-- , row = dictEntryValueToTableauRowValue objecitveBasicVar objectiveRow +-- } +-- , rows = Map.mapWithKey dictEntryValueToTableauRowValue entries +-- } +-- where +-- \| Converts a 'DictEntry' to a 'TableauEntry'. +-- This is done by moving all non-basic variables from the right to the left. +-- The rational constant stays on the right. +-- FIXME: check The basic variables will have a coefficient of 1 in the 'TableauEntry'. + +-- | Converts a 'Tableau' to a 'Dict' using 'tableauEntryToDictEntry'. +-- We do this by isolating the basic variable on the LHS, ending up with all non basic variables and a 'SimplexNum' constant on the RHS. +tableauInDictionaryForm :: Tableau -> Dict +tableauInDictionaryForm = + Map.mapWithKey + ( \basicVar (TableauRow {..}) -> + let basicVarCoeff = fromMaybe 1 $ Map.lookup basicVar lhs + in DictValue + { varMapSum = + Map.map + (\c -> negate c / basicVarCoeff) + $ Map.delete basicVar lhs + , constant = rhs / basicVarCoeff + } + ) + +-- Dict +-- { objective = +-- let objecitveBasicVar = objective ^. #basicVar +-- objectiveRow = objective ^. #row +-- in DictObjective +-- { lhs = objecitveBasicVar +-- , rhs = tableauRowValueToDictEntryValue objecitveBasicVar objectiveRow +-- } +-- , entries = Map.mapWithKey tableauRowValueToDictEntryValue rows +-- } +-- where +-- -- \| Converts a 'Tableau' to a 'Dict'. +-- -- We do this by isolating the basic variable on the LHS, ending up with all non basic variables and a 'SimplexNum' constant on the RHS. +-- -- FIXME: check The basic variables will have a coefficient of 1 in the 'DictEntry'. +-- tableauRowValueToDictEntryValue :: Var -> TableauRow -> DictEntryValue +-- tableauRowValueToDictEntryValue basicVarName (TableauRow {..}) = +-- DictEntryValue +-- { varMapSum = +-- Map.map +-- (\c -> negate c / basicVarCoeff) +-- $ Map.delete basicVarName lhs +-- , constant = rhs / basicVarCoeff +-- } +-- where +-- mBasicVarCoeff = Map.lookup basicVarName lhs +-- basicVarCoeff = fromMaybe 1 mBasicVarCoeff + +-- | If this function is given 'Nothing', return 'Nothing'. +-- Otherwise, we 'lookup' the 'Integer' given in the first item of the pair in the map given in the second item of the pair. +-- This is typically used to extract the value of the 'ObjectiveFunction' after calling 'Linear.Simplex.Simplex.twoPhaseSimplex'. +extractObjectiveValue :: Maybe Result -> Maybe SimplexNum +extractObjectiveValue = fmap $ \result -> + case Map.lookup (result ^. #objectiveVar) (result ^. #varValMap) of Nothing -> error "Objective not found in results when extracting objective value" - r -> r + Just r -> r + +-- | Combines two 'VarLitMapSums together by summing values with matching keys +combineVarLitMapSums :: VarLitMapSum -> VarLitMapSum -> VarLitMapSum +combineVarLitMapSums = + MapMerge.merge + (MapMerge.mapMaybeMissing keepVal) + (MapMerge.mapMaybeMissing keepVal) + (MapMerge.zipWithMaybeMatched sumVals) + where + keepVal = const pure + sumVals k v1 v2 = Just $ v1 + v2 + +-- -- | Apply a function to the objective function and another to each entry in a +-- -- 'Dict' +-- applyDict :: (DictEntries -> DictEntries) -> (DictEntries -> DictEntries) -> Dict -> Dict +-- applyDict fObj fDict (Dict {..}) = +-- Dict +-- { objective = fObj objectiveFunction +-- , entries = fmap fDict entries +-- } + +-- -- Apply a single function to all entries in a 'Dict', including the objective function +-- applyDictSimple :: (DictEntries -> DictEntries) -> Dict -> Dict +-- applyDictSimple f = applyDict f f + +foldDictValue :: [DictValue] -> DictValue +foldDictValue [] = error "Empty list of DictValues given to foldDictValue" +foldDictValue [x] = x +foldDictValue (DictValue { varMapSum = vm1, constant = c1 } : DictValue { varMapSum = vm2, constant = c2 } : dvs) = + let combinedDictValue = + DictValue + { varMapSum = foldVarLitMap [vm1, vm2] + , constant = c1 + c2 + } + in foldDictValue $ combinedDictValue : dvs + +-- type VarLitMap = M.Map Var SimplexNum + +foldVarLitMap :: [VarLitMap] -> VarLitMap +foldVarLitMap [] = error "Empty list of VarLitMaps given to foldVarLitMap" +foldVarLitMap [x] = x +foldVarLitMap (vm1 : vm2 : vms) = + let combinedVars = nub $ Map.keys vm1 <> Map.keys vm2 + + combinedVarMap = + Map.fromList $ map + (\var -> + let mVm1VarVal = Map.lookup var vm1 + mVm2VarVal = Map.lookup var vm2 + in + (var, + case (mVm1VarVal, mVm2VarVal) of + (Just vm1VarVal, Just vm2VarVal) -> vm1VarVal + vm2VarVal + (Just vm1VarVal, Nothing) -> vm1VarVal + (Nothing, Just vm2VarVal) -> vm2VarVal + (Nothing, Nothing) -> error "Reached unreachable branch in foldDictValue" + ) + ) + combinedVars + in foldVarLitMap $ combinedVarMap : vms diff --git a/test/Spec.hs b/test/Spec.hs index f1c9919..78675e0 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -11,7 +11,7 @@ main = runTests testsList runTests [] = putStrLn "All tests passed" runTests (((testObjective, testConstraints), expectedResult) : tests) = let testResult = twoPhaseSimplex testObjective testConstraints - in if testResult == expectedResult + in if testResult == expectedResult then runTests tests else do putStrLn "The following test failed: \n" diff --git a/test/TestFunctions.hs b/test/TestFunctions.hs index cc0852b..8e42b9d 100644 --- a/test/TestFunctions.hs +++ b/test/TestFunctions.hs @@ -3,105 +3,110 @@ module TestFunctions where import Data.Ratio import Linear.Simplex.Types import Prelude hiding (EQ) +import qualified Data.Map as M -testsList :: [((ObjectiveFunction, [PolyConstraint]), Maybe (Integer, [(Integer, Rational)]))] +testsList :: [((ObjectiveFunction, [PolyConstraint]), Maybe Result)] testsList = - [ (test1, Just (7, [(7, 29 % 1), (1, 3 % 1), (2, 4 % 1)])) - , (test2, Just (7, [(7, 0 % 1)])) + [ (test1, Just (Result 7 (M.fromList [(7, 29), (1, 3), (2, 4)]))) + , (test2, Just (Result 7 (M.fromList [(7, 0)]))) , (test3, Nothing) - , (test4, Just (11, [(11, 237 % 7), (1, 24 % 7), (2, 33 % 7)])) - , (test5, Just (9, [(9, 3 % 5), (2, 14 % 5), (3, 17 % 5)])) + , (test4, Just (Result 11 (M.fromList [(11, 237 % 7), (1, 24 % 7), (2, 33 % 7)]))) + , (test5, Just (Result 9 (M.fromList [(9, 3 % 5), (2, 14 % 5), (3, 17 % 5)]))) , (test6, Nothing) - , (test7, Just (8, [(8, 1 % 1), (2, 2 % 1), (1, 3 % 1)])) - , (test8, Just (8, [(8, (-1) % 4), (2, 9 % 2), (1, 17 % 4)])) - , (test9, Just (7, [(7, 5 % 1), (3, 2 % 1), (4, 1 % 1)])) - , (test10, Just (7, [(7, 8 % 1), (1, 2 % 1), (2, 6 % 1)])) - , (test11, Just (8, [(8, 20 % 1), (4, 16 % 1), (3, 6 % 1)])) - , (test12, Just (8, [(8, 6 % 1), (4, 2 % 1), (5, 2 % 1)])) - , (test13, Just (6, [(6, 150 % 1), (2, 150 % 1)])) - , (test14, Just (6, [(6, 40 % 3), (2, 40 % 3)])) + , (test7, Just (Result 8 (M.fromList [(8, 1), (2, 2), (1, 3)]))) + , (test8, Just (Result 8 (M.fromList [(8, (-1) % 4), (2, 9 % 2), (1, 17 % 4)]))) + , (test9, Just (Result 7 (M.fromList [(7, 5), (3, 2), (4, 1)]))) + , (test10, Just (Result 7 (M.fromList [(7, 8), (1, 2), (2, 6)]))) + , (test11, Just (Result 8 (M.fromList [(8, 20), (4, 16), (3, 6)]))) + , (test12, Just (Result 8 (M.fromList [(8, 6), (4, 2), (5, 2)]))) + , (test13, Just (Result 6 (M.fromList [(6, 150), (2, 150)]))) + , (test14, Just (Result 6 (M.fromList [(6, 40 % 3), (2, 40 % 3)]))) , (test15, Nothing) - , (test16, Just (6, [(6, 75 % 1), (1, 75 % 2)])) - , (test17, Just (7, [(7, (-120) % 1), (1, 20 % 1)])) - , (test18, Just (7, [(7, 10 % 1), (3, 5 % 1)])) + , (test16, Just (Result 6 (M.fromList [(6, 75), (1, 75 % 2)]))) + , (test17, Just (Result 7 (M.fromList [(7, (-120)), (1, 20)]))) + , (test18, Just (Result 7 (M.fromList [(7, 10), (3, 5)]))) , (test19, Nothing) , (test20, Nothing) - , (test21, Just (7, [(7, 250 % 1), (2, 50 % 1)])) - , (test22, Just (7, [(7, 0 % 1)])) + , (test21, Just (Result 7 (M.fromList [(7, 250), (2, 50)]))) + , (test22, Just (Result 7 (M.fromList [(7, 0)]))) , (test23, Nothing) - , (test24, Just (10, [(10, 300 % 1), (3, 150 % 1)])) - , (test25, Just (3, [(3, 15 % 1), (1, 15 % 1)])) - , (test26, Just (6, [(6, 20 % 1), (1, 10 % 1), (2, 10 % 1)])) - , (test27, Just (3, [(3, 0 % 1)])) - , (test28, Just (6, [(6, 0 % 1), (2, 10 % 1)])) + , (test24, Just (Result 10 (M.fromList [(10, 300), (3, 150)]))) + , (test25, Just (Result 3 (M.fromList [(3, 15), (1, 15)]))) + , (test26, Just (Result 6 (M.fromList [(6, 20), (1, 10), (2, 10)]))) + , (test27, Just (Result 3 (M.fromList [(3, 0)]))) + , (test28, Just (Result 6 (M.fromList [(6, 0), (2, 10)]))) , (test29, Nothing) , (test30, Nothing) - , (testPolyPaver1, Just (12, [(12, 7 % 4), (2, 5 % 2), (1, 7 % 4), (3, 0 % 1)])) - , (testPolyPaver2, Just (12, [(12, 5 % 2), (2, 5 % 3), (1, 5 % 2), (3, 0 % 1)])) - , (testPolyPaver3, Just (12, [(12, 5 % 3), (2, 5 % 3), (1, 5 % 2), (3, 0 % 1)])) - , (testPolyPaver4, Just (12, [(12, 5 % 2), (2, 5 % 2), (1, 5 % 2), (3, 0 % 1)])) + , (testPolyPaver1, Just (Result 12 (M.fromList [(12, 7 % 4), (2, 5 % 2), (1, 7 % 4), (3, 0)]))) + , (testPolyPaver2, Just (Result 12 (M.fromList [(12, 5 % 2), (2, 5 % 3), (1, 5 % 2), (3, 0)]))) + , (testPolyPaver3, Just (Result 12 (M.fromList [(12, 5 % 3), (2, 5 % 3), (1, 5 % 2), (3, 0)]))) + , (testPolyPaver4, Just (Result 12 (M.fromList [(12, 5 % 2), (2, 5 % 2), (1, 5 % 2), (3, 0)]))) , (testPolyPaver5, Nothing) , (testPolyPaver6, Nothing) , (testPolyPaver7, Nothing) , (testPolyPaver8, Nothing) - , (testPolyPaver9, Just (12, [(12, 7 % 2), (2, 5 % 9), (1, 7 % 2), (3, 0 % 1)])) - , (testPolyPaver10, Just (12, [(12, 17 % 20), (2, 7 % 2), (1, 17 % 20), (3, 0 % 1)])) - , (testPolyPaver11, Just (12, [(12, 7 % 2), (2, 7 % 2), (1, 22 % 9)])) - , (testPolyPaver12, Just (12, [(12, 5 % 9), (2, 5 % 9), (1, 7 % 2), (3, 0 % 1)])) + , (testPolyPaver9, Just (Result 12 (M.fromList [(12, 7 % 2), (2, 5 % 9), (1, 7 % 2), (3, 0)]))) + , (testPolyPaver10, Just (Result 12 (M.fromList [(12, 17 % 20), (2, 7 % 2), (1, 17 % 20), (3, 0)]))) + , (testPolyPaver11, Just (Result 12 (M.fromList [(12, 7 % 2), (2, 7 % 2), (1, 22 % 9)]))) + , (testPolyPaver12, Just (Result 12 (M.fromList [(12, 5 % 9), (2, 5 % 9), (1, 7 % 2), (3, 0)]))) , (testPolyPaverTwoFs1, Nothing) , (testPolyPaverTwoFs2, Nothing) , (testPolyPaverTwoFs3, Nothing) , (testPolyPaverTwoFs4, Nothing) - , (testPolyPaverTwoFs5, Just (17, [(17, 5 % 2), (2, 45 % 22), (1, 5 % 2), (4, 0 % 1)])) - , (testPolyPaverTwoFs6, Just (17, [(17, 45 % 22), (2, 5 % 2), (1, 45 % 22), (4, 0 % 1)])) - , (testPolyPaverTwoFs7, Just (17, [(17, 5 % 2), (2, 5 % 2), (1, 5 % 2), (4, 0 % 1)])) - , (testPolyPaverTwoFs8, Just (17, [(17, 45 % 22), (2, 45 % 22), (1, 5 % 2), (4, 0 % 1)])) - , (testLeqGeqBugMin1, Just (5, [(5, 3 % 1), (1, 3 % 1), (2, 3 % 1)])) - , (testLeqGeqBugMax1, Just (5, [(5, 3 % 1), (1, 3 % 1), (2, 3 % 1)])) - , (testLeqGeqBugMin2, Just (5, [(5, 3 % 1), (1, 3 % 1), (2, 3 % 1)])) - , (testLeqGeqBugMax2, Just (5, [(5, 3 % 1), (1, 3 % 1), (2, 3 % 1)])) - , (testQuickCheck1, Just (10, [(10, (-370) % 1), (2, 26 % 1), (1, 5 % 3)])) - , (testQuickCheck2, Just (8, [(8, (-2) % 9), (1, 14 % 9), (2, 8 % 9)])) - , (testQuickCheck3, Just (7, [(7, (-8) % 1), (2, 2 % 1)])) + , (testPolyPaverTwoFs5, Just (Result 17 (M.fromList [(17, 5 % 2), (2, 45 % 22), (1, 5 % 2), (4, 0)]))) + , (testPolyPaverTwoFs6, Just (Result 17 (M.fromList [(17, 45 % 22), (2, 5 % 2), (1, 45 % 22), (4, 0)]))) + , (testPolyPaverTwoFs7, Just (Result 17 (M.fromList [(17, 5 % 2), (2, 5 % 2), (1, 5 % 2), (4, 0)]))) + , (testPolyPaverTwoFs8, Just (Result 17 (M.fromList [(17, 45 % 22), (2, 45 % 22), (1, 5 % 2), (4, 0)]))) + , (testLeqGeqBugMin1, Just (Result 5 (M.fromList [(5, 3), (1, 3), (2, 3)]))) + , (testLeqGeqBugMax1, Just (Result 5 (M.fromList [(5, 3), (1, 3), (2, 3)]))) + , (testLeqGeqBugMin2, Just (Result 5 (M.fromList [(5, 3), (1, 3), (2, 3)]))) + , (testLeqGeqBugMax2, Just (Result 5 (M.fromList [(5, 3), (1, 3), (2, 3)]))) + , (testQuickCheck1, Just (Result 10 (M.fromList [(10, (-370)), (2, 26), (1, 5 % 3)]))) + , (testQuickCheck2, Just (Result 8 (M.fromList [(8, (-2) % 9), (1, 14 % 9), (2, 8 % 9)]))) + , (testQuickCheck3, Just (Result 7 (M.fromList [(7, (-8)), (2, 2)]))) ] +testLeqGeqBugMin1 :: (ObjectiveFunction, [PolyConstraint]) testLeqGeqBugMin1 = - ( Min [(1, 1)] + ( Min (M.fromList [(1, 1)]) , - [ GEQ [(1, 1 % 1)] (3 % 1) - , LEQ [(1, 1 % 1)] (3 % 1) - , GEQ [(2, 1 % 1)] (3 % 1) - , LEQ [(2, 1 % 1)] (3 % 1) + [ GEQ (M.fromList [(1, 1)]) 3 + , LEQ (M.fromList [(1, 1)]) 3 + , GEQ (M.fromList [(2, 1)]) 3 + , LEQ (M.fromList [(2, 1)]) 3 ] ) +testLeqGeqBugMax1 :: (ObjectiveFunction, [PolyConstraint]) testLeqGeqBugMax1 = - ( Min [(1, 1)] + ( Min (M.fromList [(1, 1)]) , - [ GEQ [(1, 1 % 1)] (3 % 1) - , LEQ [(1, 1 % 1)] (3 % 1) - , GEQ [(2, 1 % 1)] (3 % 1) - , LEQ [(2, 1 % 1)] (3 % 1) + [ GEQ (M.fromList [(1, 1)]) 3 + , LEQ (M.fromList [(1, 1)]) 3 + , GEQ (M.fromList [(2, 1)]) 3 + , LEQ (M.fromList [(2, 1)]) 3 ] ) +testLeqGeqBugMin2 :: (ObjectiveFunction, [PolyConstraint]) testLeqGeqBugMin2 = - ( Min [(1, 1)] + ( Min (M.fromList [(1, 1)]) , - [ GEQ [(1, 1 % 1)] (3 % 1) - , LEQ [(1, 1 % 1)] (3 % 1) - , GEQ [(2, 1 % 1)] (3 % 1) - , LEQ [(2, 1 % 1)] (3 % 1) + [ GEQ (M.fromList [(1, 1)]) 3 + , LEQ (M.fromList [(1, 1)]) 3 + , GEQ (M.fromList [(2, 1)]) 3 + , LEQ (M.fromList [(2, 1)]) 3 ] ) +testLeqGeqBugMax2 :: (ObjectiveFunction, [PolyConstraint]) testLeqGeqBugMax2 = - ( Min [(1, 1)] + ( Min (M.fromList [(1, 1)]) , - [ GEQ [(1, 1 % 1)] (3 % 1) - , LEQ [(1, 1 % 1)] (3 % 1) - , GEQ [(2, 1 % 1)] (3 % 1) - , LEQ [(2, 1 % 1)] (3 % 1) + [ GEQ (M.fromList [(1, 1)]) 3 + , LEQ (M.fromList [(1, 1)]) 3 + , GEQ (M.fromList [(2, 1)]) 3 + , LEQ (M.fromList [(2, 1)]) 3 ] ) @@ -109,45 +114,45 @@ testLeqGeqBugMax2 = -- Solution: obj = 29, 1 = 3, 2 = 4, test1 :: (ObjectiveFunction, [PolyConstraint]) test1 = - ( Max [(1, 3), (2, 5)] + ( Max (M.fromList [(1, 3), (2, 5)]) , - [ LEQ [(1, 3), (2, 1)] 15 - , LEQ [(1, 1), (2, 1)] 7 - , LEQ [(2, 1)] 4 - , LEQ [(1, -1), (2, 2)] 6 + [ LEQ (M.fromList [(1, 3), (2, 1)]) 15 + , LEQ (M.fromList [(1, 1), (2, 1)]) 7 + , LEQ (M.fromList [(2, 1)]) 4 + , LEQ (M.fromList [(1, -1), (2, 2)]) 6 ] ) test2 :: (ObjectiveFunction, [PolyConstraint]) test2 = - ( Min [(1, 3), (2, 5)] + ( Min (M.fromList [(1, 3), (2, 5)]) , - [ LEQ [(1, 3), (2, 1)] 15 - , LEQ [(1, 1), (2, 1)] 7 - , LEQ [(2, 1)] 4 - , LEQ [(1, -1), (2, 2)] 6 + [ LEQ (M.fromList [(1, 3), (2, 1)]) 15 + , LEQ (M.fromList [(1, 1), (2, 1)]) 7 + , LEQ (M.fromList [(2, 1)]) 4 + , LEQ (M.fromList [(1, -1), (2, 2)]) 6 ] ) test3 :: (ObjectiveFunction, [PolyConstraint]) test3 = - ( Max [(1, 3), (2, 5)] + ( Max (M.fromList [(1, 3), (2, 5)]) , - [ GEQ [(1, 3), (2, 1)] 15 - , GEQ [(1, 1), (2, 1)] 7 - , GEQ [(2, 1)] 4 - , GEQ [(1, -1), (2, 2)] 6 + [ GEQ (M.fromList [(1, 3), (2, 1)]) 15 + , GEQ (M.fromList [(1, 1), (2, 1)]) 7 + , GEQ (M.fromList [(2, 1)]) 4 + , GEQ (M.fromList [(1, -1), (2, 2)]) 6 ] ) test4 :: (ObjectiveFunction, [PolyConstraint]) test4 = - ( Min [(1, 3), (2, 5)] + ( Min (M.fromList [(1, 3), (2, 5)]) , - [ GEQ [(1, 3), (2, 1)] 15 - , GEQ [(1, 1), (2, 1)] 7 - , GEQ [(2, 1)] 4 - , GEQ [(1, -1), (2, 2)] 6 + [ GEQ (M.fromList [(1, 3), (2, 1)]) 15 + , GEQ (M.fromList [(1, 1), (2, 1)]) 7 + , GEQ (M.fromList [(2, 1)]) 4 + , GEQ (M.fromList [(1, -1), (2, 2)]) 6 ] ) @@ -156,41 +161,41 @@ test4 = -- requires two phases test5 :: (ObjectiveFunction, [PolyConstraint]) test5 = - ( Max [(1, 1), (2, -1), (3, 1)] + ( Max (M.fromList [(1, 1), (2, -1), (3, 1)]) , - [ LEQ [(1, 2), (2, -1), (3, 2)] 4 - , LEQ [(1, 2), (2, -3), (3, 1)] (-5) - , LEQ [(1, -1), (2, 1), (3, -2)] (-1) + [ LEQ (M.fromList [(1, 2), (2, -1), (3, 2)]) 4 + , LEQ (M.fromList [(1, 2), (2, -3), (3, 1)]) (-5) + , LEQ (M.fromList [(1, -1), (2, 1), (3, -2)]) (-1) ] ) test6 :: (ObjectiveFunction, [PolyConstraint]) test6 = - ( Min [(1, 1), (2, -1), (3, 1)] + ( Min (M.fromList [(1, 1), (2, -1), (3, 1)]) , - [ LEQ [(1, 2), (2, -1), (3, 2)] 4 - , LEQ [(1, 2), (2, -3), (3, 1)] (-5) - , LEQ [(1, -1), (2, 1), (3, -2)] (-1) + [ LEQ (M.fromList [(1, 2), (2, -1), (3, 2)]) 4 + , LEQ (M.fromList [(1, 2), (2, -3), (3, 1)]) (-5) + , LEQ (M.fromList [(1, -1), (2, 1), (3, -2)]) (-1) ] ) test7 :: (ObjectiveFunction, [PolyConstraint]) test7 = - ( Max [(1, 1), (2, -1), (3, 1)] + ( Max (M.fromList [(1, 1), (2, -1), (3, 1)]) , - [ GEQ [(1, 2), (2, -1), (3, 2)] 4 - , GEQ [(1, 2), (2, -3), (3, 1)] (-5) - , GEQ [(1, -1), (2, 1), (3, -2)] (-1) + [ GEQ (M.fromList [(1, 2), (2, -1), (3, 2)]) 4 + , GEQ (M.fromList [(1, 2), (2, -3), (3, 1)]) (-5) + , GEQ (M.fromList [(1, -1), (2, 1), (3, -2)]) (-1) ] ) test8 :: (ObjectiveFunction, [PolyConstraint]) test8 = - ( Min [(1, 1), (2, -1), (3, 1)] + ( Min (M.fromList [(1, 1), (2, -1), (3, 1)]) , - [ GEQ [(1, 2), (2, -1), (3, 2)] 4 - , GEQ [(1, 2), (2, -3), (3, 1)] (-5) - , GEQ [(1, -1), (2, 1), (3, -2)] (-1) + [ GEQ (M.fromList [(1, 2), (2, -1), (3, 2)]) 4 + , GEQ (M.fromList [(1, 2), (2, -3), (3, 1)]) (-5) + , GEQ (M.fromList [(1, -1), (2, 1), (3, -2)]) (-1) ] ) @@ -199,19 +204,20 @@ test8 = -- requires two phases test9 :: (ObjectiveFunction, [PolyConstraint]) test9 = - ( Min [(1, 1), (2, 1), (3, 2), (4, 1)] + ( Min (M.fromList [(1, 1), (2, 1), (3, 2), (4, 1)]) , - [ EQ [(1, 1), (3, 2), (4, -2)] 2 - , EQ [(2, 1), (3, 1), (4, 4)] 6 + [ EQ (M.fromList [(1, 1), (3, 2), (4, -2)]) 2 + , EQ (M.fromList [(2, 1), (3, 1), (4, 4)]) 6 ] ) test10 :: (ObjectiveFunction, [PolyConstraint]) test10 = - ( Max [(1, 1), (2, 1), (3, 2), (4, 1)] + ( Min (M.fromList [(1, 1), (2, 1), (3, 2), (4, 1)]) , - [ EQ [(1, 1), (3, 2), (4, -2)] 2 - , EQ [(2, 1), (3, 1), (4, 4)] 6 + [ EQ (M.fromList [(1, 1), (3, 2), (4, -2)]) 2 + , EQ (M.fromList [(2, 1), (3, 1), (4, 4)]) 6 + , GEQ (M.fromList [(1, -1), (2, -1), (3, -2), (4, -1)]) (-2) ] ) @@ -220,19 +226,19 @@ test10 = -- Solution: obj = 20, 3 = 6, 4 = 16 wq test11 :: (ObjectiveFunction, [PolyConstraint]) test11 = - ( Max [(3, -2), (4, 2), (5, 1)] + ( Max (M.fromList [(3, -2), (4, 2), (5, 1)]) , - [ EQ [(3, -2), (4, 1), (5, 1)] 4 - , EQ [(3, 3), (4, -1), (5, 2)] 2 + [ EQ (M.fromList [(3, -2), (4, 1), (5, 1)]) 4 + , EQ (M.fromList [(3, 3), (4, -1), (5, 2)]) 2 ] ) test12 :: (ObjectiveFunction, [PolyConstraint]) test12 = - ( Min [(3, -2), (4, 2), (5, 1)] + ( Min (M.fromList [(3, -2), (4, 2), (5, 1)]) , - [ EQ [(3, -2), (4, 1), (5, 1)] 4 - , EQ [(3, 3), (4, -1), (5, 2)] 2 + [ EQ (M.fromList [(3, -2), (4, 1), (5, 1)]) 4 + , EQ (M.fromList [(3, 3), (4, -1), (5, 2)]) 2 ] ) @@ -241,37 +247,37 @@ test12 = -- requires two phases test13 :: (ObjectiveFunction, [PolyConstraint]) test13 = - ( Max [(1, 2), (2, 1)] + ( Max (M.fromList [(1, 2), (2, 1)]) , - [ LEQ [(1, 4), (2, 1)] 150 - , LEQ [(1, 2), (2, -3)] (-40) + [ LEQ (M.fromList [(1, 4), (2, 1)]) 150 + , LEQ (M.fromList [(1, 2), (2, -3)]) (-40) ] ) test14 :: (ObjectiveFunction, [PolyConstraint]) test14 = - ( Min [(1, 2), (2, 1)] + ( Min (M.fromList [(1, 2), (2, 1)]) , - [ LEQ [(1, 4), (2, 1)] 150 - , LEQ [(1, 2), (2, -3)] (-40) + [ LEQ (M.fromList [(1, 4), (2, 1)]) 150 + , LEQ (M.fromList [(1, 2), (2, -3)]) (-40) ] ) test15 :: (ObjectiveFunction, [PolyConstraint]) test15 = - ( Max [(1, 2), (2, 1)] + ( Max (M.fromList [(1, 2), (2, 1)]) , - [ GEQ [(1, 4), (2, 1)] 150 - , GEQ [(1, 2), (2, -3)] (-40) + [ GEQ (M.fromList [(1, 4), (2, 1)]) 150 + , GEQ (M.fromList [(1, 2), (2, -3)]) (-40) ] ) test16 :: (ObjectiveFunction, [PolyConstraint]) test16 = - ( Min [(1, 2), (2, 1)] + ( Min (M.fromList [(1, 2), (2, 1)]) , - [ GEQ [(1, 4), (2, 1)] 150 - , GEQ [(1, 2), (2, -3)] (-40) + [ GEQ (M.fromList [(1, 4), (2, 1)]) 150 + , GEQ (M.fromList [(1, 2), (2, -3)]) (-40) ] ) @@ -279,41 +285,41 @@ test16 = -- Solution: obj = 120, 1 = 20, 2 = 0, 3 = 0, objVar was negated so actual val is -120 test17 :: (ObjectiveFunction, [PolyConstraint]) test17 = - ( Min [(1, -6), (2, -4), (3, 2)] + ( Min (M.fromList [(1, -6), (2, -4), (3, 2)]) , - [ LEQ [(1, 1), (2, 1), (3, 4)] 20 - , LEQ [(2, -5), (3, 5)] 100 - , LEQ [(1, 1), (3, 1), (1, 1)] 400 + [ LEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 + , LEQ (M.fromList [(2, -5), (3, 5)]) 100 + , LEQ (M.fromList [(1, 1), (3, 1), (1, 1)]) 400 ] ) test18 :: (ObjectiveFunction, [PolyConstraint]) test18 = - ( Max [(1, -6), (2, -4), (3, 2)] + ( Max (M.fromList [(1, -6), (2, -4), (3, 2)]) , - [ LEQ [(1, 1), (2, 1), (3, 4)] 20 - , LEQ [(2, -5), (3, 5)] 100 - , LEQ [(1, 1), (3, 1), (1, 1)] 400 + [ LEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 + , LEQ (M.fromList [(2, -5), (3, 5)]) 100 + , LEQ (M.fromList [(1, 1), (3, 1), (1, 1)]) 400 ] ) test19 :: (ObjectiveFunction, [PolyConstraint]) test19 = - ( Min [(1, -6), (2, -4), (3, 2)] + ( Min (M.fromList [(1, -6), (2, -4), (3, 2)]) , - [ GEQ [(1, 1), (2, 1), (3, 4)] 20 - , GEQ [(2, -5), (3, 5)] 100 - , GEQ [(1, 1), (3, 1), (1, 1)] 400 + [ GEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 + , GEQ (M.fromList [(2, -5), (3, 5)]) 100 + , GEQ (M.fromList [(1, 1), (3, 1), (1, 1)]) 400 ] ) test20 :: (ObjectiveFunction, [PolyConstraint]) test20 = - ( Max [(1, -6), (2, -4), (3, 2)] + ( Max (M.fromList [(1, -6), (2, -4), (3, 2)]) , - [ GEQ [(1, 1), (2, 1), (3, 4)] 20 - , GEQ [(2, -5), (3, 5)] 100 - , GEQ [(1, 1), (3, 1), (1, 1)] 400 + [ GEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 + , GEQ (M.fromList [(2, -5), (3, 5)]) 100 + , GEQ (M.fromList [(1, 1), (3, 1), (1, 1)]) 400 ] ) @@ -321,113 +327,113 @@ test20 = -- Solution: obj = 250, 1 = 0, 2 = 50, 3 = 0 test21 :: (ObjectiveFunction, [PolyConstraint]) test21 = - ( Max [(1, 3), (2, 5), (3, 2)] + ( Max (M.fromList [(1, 3),(2, 5),(3, 2)]) , - [ LEQ [(1, 5), (2, 1), (3, 4)] 50 - , LEQ [(1, 1), (2, -1), (3, 1)] 150 - , LEQ [(1, 2), (2, 1), (3, 2)] 100 + [ LEQ (M.fromList [(1, 5),(2, 1),(3, 4)]) 50 + , LEQ (M.fromList [(1, 1),(2, -1),(3, 1)]) 150 + , LEQ (M.fromList [(1, 2),(2, 1),(3, 2)]) 100 ] ) -test22 :: (ObjectiveFunction, [PolyConstraint]) +test22 :: (ObjectiveFunction, [PolyConstraint]) test22 = - ( Min [(1, 3), (2, 5), (3, 2)] + ( Min (M.fromList [(1, 3),(2, 5),(3, 2)]) , - [ LEQ [(1, 5), (2, 1), (3, 4)] 50 - , LEQ [(1, 1), (2, -1), (3, 1)] 150 - , LEQ [(1, 2), (2, 1), (3, 2)] 100 + [ LEQ (M.fromList [(1, 5),(2, 1),(3, 4)]) 50 + , LEQ (M.fromList [(1, 1),(2, -1),(3, 1)]) 150 + , LEQ (M.fromList [(1, 2),(2, 1),(3, 2)]) 100 ] ) test23 :: (ObjectiveFunction, [PolyConstraint]) test23 = - ( Max [(1, 3), (2, 5), (3, 2)] + ( Max (M.fromList [(1, 3),(2, 5),(3, 2)]) , - [ GEQ [(1, 5), (2, 1), (3, 4)] 50 - , GEQ [(1, 1), (2, -1), (3, 1)] 150 - , GEQ [(1, 2), (2, 1), (3, 2)] 100 + [ GEQ (M.fromList [(1, 5),(2, 1),(3, 4)]) 50 + , GEQ (M.fromList [(1, 1),(2, -1),(3, 1)]) 150 + , GEQ (M.fromList [(1, 2),(2, 1),(3, 2)]) 100 ] ) test24 :: (ObjectiveFunction, [PolyConstraint]) test24 = - ( Min [(1, 3), (2, 5), (3, 2)] + ( Min (M.fromList [(1, 3),(2, 5),(3, 2)]) , - [ GEQ [(1, 5), (2, 1), (3, 4)] 50 - , GEQ [(1, 1), (2, -1), (3, 1)] 150 - , GEQ [(1, 2), (2, 1), (3, 2)] 100 + [ GEQ (M.fromList [(1, 5),(2, 1),(3, 4)]) 50 + , GEQ (M.fromList [(1, 1),(2, -1),(3, 1)]) 150 + , GEQ (M.fromList [(1, 2),(2, 1),(3, 2)]) 100 ] ) test25 :: (ObjectiveFunction, [PolyConstraint]) test25 = - ( Max [(1, 1)] + ( Max (M.fromList [(1, 1)]) , - [ LEQ [(1, 1)] 15 + [ LEQ (M.fromList [(1, 1)]) 15 ] ) test26 :: (ObjectiveFunction, [PolyConstraint]) test26 = - ( Max [(1, 2)] + ( Max (M.fromList [(1, 2)]) , - [ LEQ [(1, 2)] 20 - , GEQ [(2, 1)] 10 + [ LEQ (M.fromList [(1, 2)]) 20 + , GEQ (M.fromList [(2, 1)]) 10 ] ) -test27 :: (ObjectiveFunction, [PolyConstraint]) +test27 :: (ObjectiveFunction, [PolyConstraint]) test27 = - ( Min [(1, 1)] + ( Min (M.fromList [(1, 1)]) , - [ LEQ [(1, 1)] 15 + [ LEQ (M.fromList [(1, 1)]) 15 ] ) test28 :: (ObjectiveFunction, [PolyConstraint]) test28 = - ( Min [(1, 2)] + ( Min (M.fromList [(1, 2)]) , - [ LEQ [(1, 2)] 20 - , GEQ [(2, 1)] 10 + [ LEQ (M.fromList [(1, 2)]) 20 + , GEQ (M.fromList [(2, 1)]) 10 ] ) test29 :: (ObjectiveFunction, [PolyConstraint]) test29 = - ( Max [(1, 1)] + ( Max (M.fromList [(1, 1)]) , - [ LEQ [(1, 1)] 15 - , GEQ [(1, 1)] 15.01 + [ LEQ (M.fromList [(1, 1)]) 15 + , GEQ (M.fromList [(1, 1)]) 15.01 ] ) test30 :: (ObjectiveFunction, [PolyConstraint]) test30 = - ( Max [(1, 1)] + ( Max (M.fromList [(1, 1)]) , - [ LEQ [(1, 1)] 15 - , GEQ [(1, 1)] 15.01 - , GEQ [(2, 1)] 10 + [ LEQ (M.fromList [(1, 1)]) 15 + , GEQ (M.fromList [(1, 1)]) 15.01 + , GEQ (M.fromList [(2, 1)]) 10 ] ) -- Tests for systems similar to those from PolyPaver2 testPolyPaver1 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaver1 = - ( Min [(1, 1)] + ( Min (M.fromList [(1, 1)]) , - [ LEQ [(1, dx1l), (2, dx2l), (3, (-1))] ((-yl) + (dx1l * x1l) + (dx2l * x2l)) -- -4, This will need an artificial variable - , GEQ [(1, dx1r), (2, dx2r), (3, (-1))] ((-yr) + (dx1r * x1l) + (dx2r * x2l)) -- -5 - , GEQ [(1, 1)] x1l - , LEQ [(1, 1)] x1r - , GEQ [(2, 1)] x2l - , LEQ [(2, 1)] x2r - , LEQ [(3, 1)] 0 + [ LEQ (M.fromList [(1, dx1l),(2, dx2l),(3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) + , GEQ (M.fromList [(1, dx1r),(2, dx2r),(3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) + , GEQ (M.fromList [(1, 1)]) x1l + , LEQ (M.fromList [(1, 1)]) x1r + , GEQ (M.fromList [(2, 1)]) x2l + , LEQ (M.fromList [(2, 1)]) x2r + , LEQ (M.fromList [(3, 1)]) 0 ] ) where - x1l = 0.0 + x1l = 0.0 x1r = 2.5 x2l = 0.0 x2r = 2.5 @@ -440,20 +446,20 @@ testPolyPaver1 = testPolyPaver2 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaver2 = - ( Max [(1, 1)] + ( Max (M.fromList [(1, 1)]) , - [ LEQ [(1, dx1l), (2, dx2l), (3, (-1))] ((-yl) + (dx1l * x1l) + (dx2l * x2l)) -- -4, This will need an artificial variable - , GEQ [(1, dx1r), (2, dx2r), (3, (-1))] ((-yr) + (dx1r * x1l) + (dx2r * x2l)) -- -5 - , GEQ [(1, 1)] x1l - , LEQ [(1, 1)] x1r - , GEQ [(2, 1)] x2l - , LEQ [(2, 1)] x2r - , LEQ [(3, 1)] 0 + [ LEQ (M.fromList [(1, dx1l),(2, dx2l),(3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) + , GEQ (M.fromList [(1, dx1r),(2, dx2r),(3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) + , GEQ (M.fromList [(1, 1)]) x1l + , LEQ (M.fromList [(1, 1)]) x1r + , GEQ (M.fromList [(2, 1)]) x2l + , LEQ (M.fromList [(2, 1)]) x2r + , LEQ (M.fromList [(3, 1)]) 0 ] ) where x1l = 0.0 - x1r = 2.5 + x1r = 2.5 x2l = 0.0 x2r = 2.5 dx1l = -1 @@ -465,22 +471,22 @@ testPolyPaver2 = testPolyPaver3 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaver3 = - ( Min [(2, 1)] + ( Min (M.fromList [(2, 1)]) , - [ LEQ [(1, dx1l), (2, dx2l), (3, (-1))] ((-yl) + (dx1l * x1l) + (dx2l * x2l)) -- -4, This will need an artificial variable - , GEQ [(1, dx1r), (2, dx2r), (3, (-1))] ((-yr) + (dx1r * x1l) + (dx2r * x2l)) -- -5 - , GEQ [(1, 1)] x1l - , LEQ [(1, 1)] x1r - , GEQ [(2, 1)] x2l - , LEQ [(2, 1)] x2r - , LEQ [(3, 1)] 0 + [ LEQ (M.fromList [(1, dx1l),(2, dx2l),(3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) + , GEQ (M.fromList [(1, dx1r),(2, dx2r),(3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) + , GEQ (M.fromList [(1, 1)]) x1l + , LEQ (M.fromList [(1, 1)]) x1r + , GEQ (M.fromList [(2, 1)]) x2l + , LEQ (M.fromList [(2, 1)]) x2r + , LEQ (M.fromList [(3, 1)]) 0 ] ) where x1l = 0.0 x1r = 2.5 x2l = 0.0 - x2r = 2.5 + x2r = 2.5 dx1l = -1 dx1r = -0.9 dx2l = -0.9 @@ -488,25 +494,25 @@ testPolyPaver3 = yl = 4 yr = 5 -testPolyPaver4 :: (ObjectiveFunction, [PolyConstraint]) +testPolyPaver4 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaver4 = - ( Max [(2, 1)] + ( Max (M.fromList [(2, 1)]) , - [ LEQ [(1, dx1l), (2, dx2l), (3, (-1))] ((-yl) + (dx1l * x1l) + (dx2l * x2l)) -- -4, This will need an artificial variable - , GEQ [(1, dx1r), (2, dx2r), (3, (-1))] ((-yr) + (dx1r * x1l) + (dx2r * x2l)) -- -5 - , GEQ [(1, 1)] x1l - , LEQ [(1, 1)] x1r - , GEQ [(2, 1)] x2l - , LEQ [(2, 1)] x2r - , LEQ [(3, 1)] 0 + [ LEQ (M.fromList [(1, dx1l),(2, dx2l),(3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) + , GEQ (M.fromList [(1, dx1r),(2, dx2r),(3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) + , GEQ (M.fromList [(1, 1)]) x1l + , LEQ (M.fromList [(1, 1)]) x1r + , GEQ (M.fromList [(2, 1)]) x2l + , LEQ (M.fromList [(2, 1)]) x2r + , LEQ (M.fromList [(3, 1)]) 0 ] ) where x1l = 0.0 x1r = 2.5 - x2l = 0.0 + x2l = 0.0 x2r = 2.5 - dx1l = -1 + dx1l = -1 dx1r = -0.9 dx2l = -0.9 dx2r = -0.8 @@ -515,20 +521,20 @@ testPolyPaver4 = testPolyPaver5 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaver5 = - ( Max [(1, 1)] + ( Max (M.fromList [(1, 1)]) , - [ LEQ [(1, dx1l), (2, dx2l), (3, (-1))] ((-yl) + (dx1l * x1l) + (dx2l * x2l)) -- -4, This will need an artificial variable - , GEQ [(1, dx1r), (2, dx2r), (3, (-1))] ((-yr) + (dx1r * x1l) + (dx2r * x2l)) -- -5 - , GEQ [(1, 1)] x1l - , LEQ [(1, 1)] x1r - , GEQ [(2, 1)] x2l - , LEQ [(2, 1)] x2r - , LEQ [(3, 1)] 0 + [ LEQ (M.fromList [(1, dx1l),(2, dx2l),(3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) + , GEQ (M.fromList [(1, dx1r),(2, dx2r),(3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) + , GEQ (M.fromList [(1, 1)]) x1l + , LEQ (M.fromList [(1, 1)]) x1r + , GEQ (M.fromList [(2, 1)]) x2l + , LEQ (M.fromList [(2, 1)]) x2r + , LEQ (M.fromList [(3, 1)]) 0 ] ) where x1l = 0.0 - x1r = 1.5 + x1r = 1.5 x2l = 0.0 x2r = 1.5 dx1l = -1 @@ -540,15 +546,15 @@ testPolyPaver5 = testPolyPaver6 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaver6 = - ( Min [(1, 1)] + ( Min (M.fromList [(1, 1)]) , - [ LEQ [(1, dx1l), (2, dx2l), (3, (-1))] ((-yl) + (dx1l * x1l) + (dx2l * x2l)) -- -4, This will need an artificial variable - , GEQ [(1, dx1r), (2, dx2r), (3, (-1))] ((-yr) + (dx1r * x1l) + (dx2r * x2l)) -- -5 - , GEQ [(1, 1)] x1l - , LEQ [(1, 1)] x1r - , GEQ [(2, 1)] x2l - , LEQ [(2, 1)] x2r - , LEQ [(3, 1)] 0 + [ LEQ (M.fromList [(1, dx1l),(2, dx2l),(3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) + , GEQ (M.fromList [(1, dx1r),(2, dx2r),(3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) + , GEQ (M.fromList [(1, 1)]) x1l + , LEQ (M.fromList [(1, 1)]) x1r + , GEQ (M.fromList [(2, 1)]) x2l + , LEQ (M.fromList [(2, 1)]) x2r + , LEQ (M.fromList [(3, 1)]) 0 ] ) where @@ -557,7 +563,7 @@ testPolyPaver6 = x2l = 0.0 x2r = 1.5 dx1l = -1 - dx1r = -0.9 + dx1r = -0.9 dx2l = -0.9 dx2r = -0.8 yl = 4 @@ -565,15 +571,15 @@ testPolyPaver6 = testPolyPaver7 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaver7 = - ( Max [(2, 1)] + ( Max (M.fromList [(2, 1)]) , - [ LEQ [(1, dx1l), (2, dx2l), (3, (-1))] ((-yl) + (dx1l * x1l) + (dx2l * x2l)) -- -4, This will need an artificial variable - , GEQ [(1, dx1r), (2, dx2r), (3, (-1))] ((-yr) + (dx1r * x1l) + (dx2r * x2l)) -- -5 - , GEQ [(1, 1)] x1l - , LEQ [(1, 1)] x1r - , GEQ [(2, 1)] x2l - , LEQ [(2, 1)] x2r - , LEQ [(3, 1)] 0 + [ LEQ (M.fromList [(1, dx1l),(2, dx2l),(3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) + , GEQ (M.fromList [(1, dx1r),(2, dx2r),(3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) + , GEQ (M.fromList [(1, 1)]) x1l + , LEQ (M.fromList [(1, 1)]) x1r + , GEQ (M.fromList [(2, 1)]) x2l + , LEQ (M.fromList [(2, 1)]) x2r + , LEQ (M.fromList [(3, 1)]) 0 ] ) where @@ -584,21 +590,21 @@ testPolyPaver7 = dx1l = -1 dx1r = -0.9 dx2l = -0.9 - dx2r = -0.8 + dx2r = -0.8 yl = 4 yr = 5 testPolyPaver8 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaver8 = - ( Min [(2, 1)] + ( Min (M.fromList [(2, 1)]) , - [ LEQ [(1, dx1l), (2, dx2l), (3, (-1))] ((-yl) + (dx1l * x1l) + (dx2l * x2l)) -- -4, This will need an artificial variable - , GEQ [(1, dx1r), (2, dx2r), (3, (-1))] ((-yr) + (dx1r * x1l) + (dx2r * x2l)) -- -5 - , GEQ [(1, 1)] x1l - , LEQ [(1, 1)] x1r - , GEQ [(2, 1)] x2l - , LEQ [(2, 1)] x2r - , LEQ [(3, 1)] 0 + [ LEQ (M.fromList [(1, dx1l),(2, dx2l),(3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) + , GEQ (M.fromList [(1, dx1r),(2, dx2r),(3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) + , GEQ (M.fromList [(1, 1)]) x1l + , LEQ (M.fromList [(1, 1)]) x1r + , GEQ (M.fromList [(2, 1)]) x2l + , LEQ (M.fromList [(2, 1)]) x2r + , LEQ (M.fromList [(3, 1)]) 0 ] ) where @@ -608,52 +614,52 @@ testPolyPaver8 = x2r = 1.5 dx1l = -1 dx1r = -0.9 - dx2l = -0.9 + dx2l = -0.9 dx2r = -0.8 yl = 4 yr = 5 testPolyPaver9 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaver9 = - ( Max [(1, 1)] + ( Max (M.fromList [(1, 1)]) , - [ LEQ [(1, dx1l), (2, dx2l), (3, (-1))] ((-yl) + (dx1l * x1l) + (dx2l * x2l)) -- -4, This will need an artificial variable - , GEQ [(1, dx1r), (2, dx2r), (3, (-1))] ((-yr) + (dx1r * x1l) + (dx2r * x2l)) -- -5 - , GEQ [(1, 1)] x1l - , LEQ [(1, 1)] x1r - , GEQ [(2, 1)] x2l - , LEQ [(2, 1)] x2r - , LEQ [(3, 1)] 0 + [ LEQ (M.fromList [(1, dx1l),(2, dx2l),(3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) + , GEQ (M.fromList [(1, dx1r),(2, dx2r),(3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) + , GEQ (M.fromList [(1, 1)]) x1l + , LEQ (M.fromList [(1, 1)]) x1r + , GEQ (M.fromList [(2, 1)]) x2l + , LEQ (M.fromList [(2, 1)]) x2r + , LEQ (M.fromList [(3, 1)]) 0 ] ) where x1l = 0.0 x1r = 3.5 - x2l = 0.0 + x2l = 0.0 x2r = 3.5 dx1l = -1 dx1r = -0.9 dx2l = -0.9 dx2r = -0.8 - yl = 4 + yl = 4 yr = 5 testPolyPaver10 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaver10 = - ( Min [(1, 1)] - , - [ LEQ [(1, dx1l), (2, dx2l), (3, (-1))] ((-yl) + (dx1l * x1l) + (dx2l * x2l)) -- -4, This will need an artificial variable - , GEQ [(1, dx1r), (2, dx2r), (3, (-1))] ((-yr) + (dx1r * x1l) + (dx2r * x2l)) -- -5 - , GEQ [(1, 1)] x1l - , LEQ [(1, 1)] x1r - , GEQ [(2, 1)] x2l - , LEQ [(2, 1)] x2r - , LEQ [(3, 1)] 0 + ( Min (M.fromList [(1, 1)]) + , + [ LEQ (M.fromList [(1, dx1l),(2, dx2l),(3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) + , GEQ (M.fromList [(1, dx1r),(2, dx2r),(3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) + , GEQ (M.fromList [(1, 1)]) x1l + , LEQ (M.fromList [(1, 1)]) x1r + , GEQ (M.fromList [(2, 1)]) x2l + , LEQ (M.fromList [(2, 1)]) x2r + , LEQ (M.fromList [(3, 1)]) 0 ] ) where x1l = 0.0 - x1r = 3.5 + x1r = 3.5 x2l = 0.0 x2r = 3.5 dx1l = -1 @@ -663,17 +669,17 @@ testPolyPaver10 = yl = 4 yr = 5 -testPolyPaver11 :: (ObjectiveFunction, [PolyConstraint]) +testPolyPaver11 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaver11 = - ( Max [(2, 1)] + ( Max (M.fromList [(2, 1)]) , - [ LEQ [(1, dx1l), (2, dx2l), (3, (-1))] ((-yl) + (dx1l * x1l) + (dx2l * x2l)) -- -4, This will need an artificial variable - , GEQ [(1, dx1r), (2, dx2r), (3, (-1))] ((-yr) + (dx1r * x1l) + (dx2r * x2l)) -- -5 - , GEQ [(1, 1)] x1l - , LEQ [(1, 1)] x1r - , GEQ [(2, 1)] x2l - , LEQ [(2, 1)] x2r - , LEQ [(3, 1)] 0 + [ LEQ (M.fromList [(1, dx1l),(2, dx2l),(3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) + , GEQ (M.fromList [(1, dx1r),(2, dx2r),(3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) + , GEQ (M.fromList [(1, 1)]) x1l + , LEQ (M.fromList [(1, 1)]) x1r + , GEQ (M.fromList [(2, 1)]) x2l + , LEQ (M.fromList [(2, 1)]) x2r + , LEQ (M.fromList [(3, 1)]) 0 ] ) where @@ -690,15 +696,15 @@ testPolyPaver11 = testPolyPaver12 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaver12 = - ( Min [(2, 1)] + ( Min (M.fromList [(2, 1)]) , - [ LEQ [(1, dx1l), (2, dx2l), (3, (-1))] ((-yl) + (dx1l * x1l) + (dx2l * x2l)) -- -4, This will need an artificial variable - , GEQ [(1, dx1r), (2, dx2r), (3, (-1))] ((-yr) + (dx1r * x1l) + (dx2r * x2l)) -- -5 - , GEQ [(1, 1)] x1l - , LEQ [(1, 1)] x1r - , GEQ [(2, 1)] x2l - , LEQ [(2, 1)] x2r - , LEQ [(3, 1)] 0 + [ LEQ (M.fromList [(1, dx1l),(2, dx2l),(3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) + , GEQ (M.fromList [(1, dx1r),(2, dx2r),(3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) + , GEQ (M.fromList [(1, 1)]) x1l + , LEQ (M.fromList [(1, 1)]) x1r + , GEQ (M.fromList [(2, 1)]) x2l + , LEQ (M.fromList [(2, 1)]) x2r + , LEQ (M.fromList [(3, 1)]) 0 ] ) where @@ -715,18 +721,18 @@ testPolyPaver12 = testPolyPaverTwoFs1 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaverTwoFs1 = - ( Max [(1, 1)] + ( Max (M.fromList [(1, 1)]) , - [ LEQ [(1, f1dx1l), (2, f1dx2l), (3, (-1))] ((-f1yl) + (f1dx1l * x1l) + (f1dx2l * x2l)) -- -4, This will need an artificial variable - , GEQ [(1, f1dx1r), (2, f1dx2r), (3, (-1))] ((-f1yr) + (f1dx1r * x1l) + (f1dx2r * x2l)) - , LEQ [(1, f2dx1l), (2, f2dx2l), (4, (-1))] ((-f2yl) + (f2dx1l * x1l) + (f2dx2l * x2l)) - , GEQ [(1, f2dx1r), (2, f2dx2r), (4, (-1))] ((-f2yr) + (f2dx1r * x1l) + (f2dx2r * x2l)) - , GEQ [(1, 1)] x1l - , LEQ [(1, 1)] x1r - , GEQ [(2, 1)] x2l - , LEQ [(2, 1)] x2r - , LEQ [(3, 1)] 0 - , LEQ [(4, 1)] 0 + [ LEQ (M.fromList [(1, f1dx1l),(2, f1dx2l),(3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) + , GEQ (M.fromList [(1, f1dx1r),(2, f1dx2r),(3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) + , LEQ (M.fromList [(1, f2dx1l),(2, f2dx2l),(4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) + , GEQ (M.fromList [(1, f2dx1r),(2, f2dx2r),(4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) + , GEQ (M.fromList [(1, 1)]) x1l + , LEQ (M.fromList [(1, 1)]) x1r + , GEQ (M.fromList [(2, 1)]) x2l + , LEQ (M.fromList [(2, 1)]) x2r + , LEQ (M.fromList [(3, 1)]) 0 + , LEQ (M.fromList [(4, 1)]) 0 ] ) where @@ -749,18 +755,18 @@ testPolyPaverTwoFs1 = testPolyPaverTwoFs2 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaverTwoFs2 = - ( Min [(1, 1)] + ( Min (M.fromList [(1, 1)]) , - [ LEQ [(1, f1dx1l), (2, f1dx2l), (3, (-1))] ((-f1yl) + (f1dx1l * x1l) + (f1dx2l * x2l)) -- -4, This will need an artificial variable - , GEQ [(1, f1dx1r), (2, f1dx2r), (3, (-1))] ((-f1yr) + (f1dx1r * x1l) + (f1dx2r * x2l)) - , LEQ [(1, f2dx1l), (2, f2dx2l), (4, (-1))] ((-f2yl) + (f2dx1l * x1l) + (f2dx2l * x2l)) - , GEQ [(1, f2dx1r), (2, f2dx2r), (4, (-1))] ((-f2yr) + (f2dx1r * x1l) + (f2dx2r * x2l)) - , GEQ [(1, 1)] x1l - , LEQ [(1, 1)] x1r - , GEQ [(2, 1)] x2l - , LEQ [(2, 1)] x2r - , LEQ [(3, 1)] 0 - , LEQ [(4, 1)] 0 + [ LEQ (M.fromList [(1, f1dx1l),(2, f1dx2l),(3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) + , GEQ (M.fromList [(1, f1dx1r),(2, f1dx2r),(3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) + , LEQ (M.fromList [(1, f2dx1l),(2, f2dx2l),(4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) + , GEQ (M.fromList [(1, f2dx1r),(2, f2dx2r),(4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) + , GEQ (M.fromList [(1, 1)]) x1l + , LEQ (M.fromList [(1, 1)]) x1r + , GEQ (M.fromList [(2, 1)]) x2l + , LEQ (M.fromList [(2, 1)]) x2r + , LEQ (M.fromList [(3, 1)]) 0 + , LEQ (M.fromList [(4, 1)]) 0 ] ) where @@ -769,7 +775,7 @@ testPolyPaverTwoFs2 = x2l = 0.0 x2r = 2.5 f1dx1l = -1 - f1dx1r = -0.9 + f1dx1r = -0.9 f1dx2l = -0.9 f1dx2r = -0.8 f1yl = 4 @@ -783,18 +789,18 @@ testPolyPaverTwoFs2 = testPolyPaverTwoFs3 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaverTwoFs3 = - ( Max [(2, 1)] + ( Max (M.fromList [(2, 1)]) , - [ LEQ [(1, f1dx1l), (2, f1dx2l), (3, (-1))] ((-f1yl) + (f1dx1l * x1l) + (f1dx2l * x2l)) -- -4, This will need an artificial variable - , GEQ [(1, f1dx1r), (2, f1dx2r), (3, (-1))] ((-f1yr) + (f1dx1r * x1l) + (f1dx2r * x2l)) - , LEQ [(1, f2dx1l), (2, f2dx2l), (4, (-1))] ((-f2yl) + (f2dx1l * x1l) + (f2dx2l * x2l)) - , GEQ [(1, f2dx1r), (2, f2dx2r), (4, (-1))] ((-f2yr) + (f2dx1r * x1l) + (f2dx2r * x2l)) - , GEQ [(1, 1)] x1l - , LEQ [(1, 1)] x1r - , GEQ [(2, 1)] x2l - , LEQ [(2, 1)] x2r - , LEQ [(3, 1)] 0 - , LEQ [(4, 1)] 0 + [ LEQ (M.fromList [(1, f1dx1l),(2, f1dx2l),(3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) + , GEQ (M.fromList [(1, f1dx1r),(2, f1dx2r),(3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) + , LEQ (M.fromList [(1, f2dx1l),(2, f2dx2l),(4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) + , GEQ (M.fromList [(1, f2dx1r),(2, f2dx2r),(4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) + , GEQ (M.fromList [(1, 1)]) x1l + , LEQ (M.fromList [(1, 1)]) x1r + , GEQ (M.fromList [(2, 1)]) x2l + , LEQ (M.fromList [(2, 1)]) x2r + , LEQ (M.fromList [(3, 1)]) 0 + , LEQ (M.fromList [(4, 1)]) 0 ] ) where @@ -806,7 +812,7 @@ testPolyPaverTwoFs3 = f1dx1r = -0.9 f1dx2l = -0.9 f1dx2r = -0.8 - f1yl = 4 + f1yl = 4 f1yr = 5 f2dx1l = -1 f2dx1r = -0.9 @@ -817,18 +823,18 @@ testPolyPaverTwoFs3 = testPolyPaverTwoFs4 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaverTwoFs4 = - ( Min [(2, 1)] + ( Min (M.fromList [(2, 1)]) , - [ LEQ [(1, f1dx1l), (2, f1dx2l), (3, (-1))] ((-f1yl) + (f1dx1l * x1l) + (f1dx2l * x2l)) -- -4, This will need an artificial variable - , GEQ [(1, f1dx1r), (2, f1dx2r), (3, (-1))] ((-f1yr) + (f1dx1r * x1l) + (f1dx2r * x2l)) - , LEQ [(1, f2dx1l), (2, f2dx2l), (4, (-1))] ((-f2yl) + (f2dx1l * x1l) + (f2dx2l * x2l)) - , GEQ [(1, f2dx1r), (2, f2dx2r), (4, (-1))] ((-f2yr) + (f2dx1r * x1l) + (f2dx2r * x2l)) - , GEQ [(1, 1)] x1l - , LEQ [(1, 1)] x1r - , GEQ [(2, 1)] x2l - , LEQ [(2, 1)] x2r - , LEQ [(3, 1)] 0 - , LEQ [(4, 1)] 0 + [ LEQ (M.fromList [(1, f1dx1l),(2, f1dx2l),(3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) + , GEQ (M.fromList [(1, f1dx1r),(2, f1dx2r),(3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) + , LEQ (M.fromList [(1, f2dx1l),(2, f2dx2l),(4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) + , GEQ (M.fromList [(1, f2dx1r),(2, f2dx2r),(4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) + , GEQ (M.fromList [(1, 1)]) x1l + , LEQ (M.fromList [(1, 1)]) x1r + , GEQ (M.fromList [(2, 1)]) x2l + , LEQ (M.fromList [(2, 1)]) x2r + , LEQ (M.fromList [(3, 1)]) 0 + , LEQ (M.fromList [(4, 1)]) 0 ] ) where @@ -851,18 +857,18 @@ testPolyPaverTwoFs4 = testPolyPaverTwoFs5 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaverTwoFs5 = - ( Max [(1, 1)] + ( Max (M.fromList [(1, 1)]) , - [ LEQ [(1, f1dx1l), (2, f1dx2l), (3, (-1))] ((-f1yl) + (f1dx1l * x1l) + (f1dx2l * x2l)) -- -4, This will need an artificial variable - , GEQ [(1, f1dx1r), (2, f1dx2r), (3, (-1))] ((-f1yr) + (f1dx1r * x1l) + (f1dx2r * x2l)) - , LEQ [(1, f2dx1l), (2, f2dx2l), (4, (-1))] ((-f2yl) + (f2dx1l * x1l) + (f2dx2l * x2l)) - , GEQ [(1, f2dx1r), (2, f2dx2r), (4, (-1))] ((-f2yr) + (f2dx1r * x1l) + (f2dx2r * x2l)) - , GEQ [(1, 1)] x1l -- don't need variable >= 0, already assumed - , LEQ [(1, 1)] x1r - , GEQ [(2, 1)] x2l - , LEQ [(2, 1)] x2r - , LEQ [(3, 1)] 0 - , LEQ [(4, 1)] 0 + [ LEQ (M.fromList [(1, f1dx1l),(2, f1dx2l),(3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) + , GEQ (M.fromList [(1, f1dx1r),(2, f1dx2r),(3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) + , LEQ (M.fromList [(1, f2dx1l),(2, f2dx2l),(4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) + , GEQ (M.fromList [(1, f2dx1r),(2, f2dx2r),(4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) + , GEQ (M.fromList [(1, 1)]) x1l + , LEQ (M.fromList [(1, 1)]) x1r + , GEQ (M.fromList [(2, 1)]) x2l + , LEQ (M.fromList [(2, 1)]) x2r + , LEQ (M.fromList [(3, 1)]) 0 + , LEQ (M.fromList [(4, 1)]) 0 ] ) where @@ -882,21 +888,21 @@ testPolyPaverTwoFs5 = f2dx2r = -0.66 f2yl = 3 f2yr = 4 - + testPolyPaverTwoFs6 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaverTwoFs6 = - ( Min [(1, 1)] + ( Min (M.fromList [(1, 1)]) , - [ LEQ [(1, f1dx1l), (2, f1dx2l), (3, (-1))] ((-f1yl) + (f1dx1l * x1l) + (f1dx2l * x2l)) -- -4, This will need an artificial variable - , GEQ [(1, f1dx1r), (2, f1dx2r), (3, (-1))] ((-f1yr) + (f1dx1r * x1l) + (f1dx2r * x2l)) - , LEQ [(1, f2dx1l), (2, f2dx2l), (4, (-1))] ((-f2yl) + (f2dx1l * x1l) + (f2dx2l * x2l)) - , GEQ [(1, f2dx1r), (2, f2dx2r), (4, (-1))] ((-f2yr) + (f2dx1r * x1l) + (f2dx2r * x2l)) - , GEQ [(1, 1)] x1l -- don't need variable >= 0, already assumed - , LEQ [(1, 1)] x1r - , GEQ [(2, 1)] x2l - , LEQ [(2, 1)] x2r - , LEQ [(3, 1)] 0 - , LEQ [(4, 1)] 0 + [ LEQ (M.fromList [(1, f1dx1l),(2, f1dx2l),(3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) + , GEQ (M.fromList [(1, f1dx1r),(2, f1dx2r),(3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) + , LEQ (M.fromList [(1, f2dx1l),(2, f2dx2l),(4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) + , GEQ (M.fromList [(1, f2dx1r),(2, f2dx2r),(4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) + , GEQ (M.fromList [(1, 1)]) x1l + , LEQ (M.fromList [(1, 1)]) x1r + , GEQ (M.fromList [(2, 1)]) x2l + , LEQ (M.fromList [(2, 1)]) x2r + , LEQ (M.fromList [(3, 1)]) 0 + , LEQ (M.fromList [(4, 1)]) 0 ] ) where @@ -906,7 +912,7 @@ testPolyPaverTwoFs6 = x2r = 2.5 f1dx1l = -1 f1dx1r = -0.9 - f1dx2l = -0.9 + f1dx2l = -0.9 f1dx2r = -0.8 f1yl = 4 f1yr = 5 @@ -919,18 +925,18 @@ testPolyPaverTwoFs6 = testPolyPaverTwoFs7 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaverTwoFs7 = - ( Max [(2, 1)] + ( Max (M.fromList [(2, 1)]) , - [ LEQ [(1, f1dx1l), (2, f1dx2l), (3, (-1))] ((-f1yl) + (f1dx1l * x1l) + (f1dx2l * x2l)) -- -4, This will need an artificial variable - , GEQ [(1, f1dx1r), (2, f1dx2r), (3, (-1))] ((-f1yr) + (f1dx1r * x1l) + (f1dx2r * x2l)) - , LEQ [(1, f2dx1l), (2, f2dx2l), (4, (-1))] ((-f2yl) + (f2dx1l * x1l) + (f2dx2l * x2l)) - , GEQ [(1, f2dx1r), (2, f2dx2r), (4, (-1))] ((-f2yr) + (f2dx1r * x1l) + (f2dx2r * x2l)) - , GEQ [(1, 1)] x1l -- don't need variable >= 0, already assumed - , LEQ [(1, 1)] x1r - , GEQ [(2, 1)] x2l - , LEQ [(2, 1)] x2r - , LEQ [(3, 1)] 0 - , LEQ [(4, 1)] 0 + [ LEQ (M.fromList [(1, f1dx1l),(2, f1dx2l),(3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) + , GEQ (M.fromList [(1, f1dx1r),(2, f1dx2r),(3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) + , LEQ (M.fromList [(1, f2dx1l),(2, f2dx2l),(4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) + , GEQ (M.fromList [(1, f2dx1r),(2, f2dx2r),(4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) + , GEQ (M.fromList [(1, 1)]) x1l + , LEQ (M.fromList [(1, 1)]) x1r + , GEQ (M.fromList [(2, 1)]) x2l + , LEQ (M.fromList [(2, 1)]) x2r + , LEQ (M.fromList [(3, 1)]) 0 + , LEQ (M.fromList [(4, 1)]) 0 ] ) where @@ -941,7 +947,7 @@ testPolyPaverTwoFs7 = f1dx1l = -1 f1dx1r = -0.9 f1dx2l = -0.9 - f1dx2r = -0.8 + f1dx2r = -0.8 f1yl = 4 f1yr = 5 f2dx1l = -0.66 @@ -953,18 +959,18 @@ testPolyPaverTwoFs7 = testPolyPaverTwoFs8 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaverTwoFs8 = - ( Min [(2, 1)] + ( Min (M.fromList [(2, 1)]) , - [ LEQ [(1, f1dx1l), (2, f1dx2l), (3, (-1))] ((-f1yl) + (f1dx1l * x1l) + (f1dx2l * x2l)) -- -4, This will need an artificial variable - , GEQ [(1, f1dx1r), (2, f1dx2r), (3, (-1))] ((-f1yr) + (f1dx1r * x1l) + (f1dx2r * x2l)) - , LEQ [(1, f2dx1l), (2, f2dx2l), (4, (-1))] ((-f2yl) + (f2dx1l * x1l) + (f2dx2l * x2l)) - , GEQ [(1, f2dx1r), (2, f2dx2r), (4, (-1))] ((-f2yr) + (f2dx1r * x1l) + (f2dx2r * x2l)) - , GEQ [(1, 1)] x1l -- don't need variable >= 0, already assumed - , LEQ [(1, 1)] x1r - , GEQ [(2, 1)] x2l - , LEQ [(2, 1)] x2r - , LEQ [(3, 1)] 0 - , LEQ [(4, 1)] 0 + [ LEQ (M.fromList [(1, f1dx1l),(2, f1dx2l),(3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) + , GEQ (M.fromList [(1, f1dx1r),(2, f1dx2r),(3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) + , LEQ (M.fromList [(1, f2dx1l),(2, f2dx2l),(4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) + , GEQ (M.fromList [(1, f2dx1r),(2, f2dx2r),(4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) + , GEQ (M.fromList [(1, 1)]) x1l + , LEQ (M.fromList [(1, 1)]) x1r + , GEQ (M.fromList [(2, 1)]) x2l + , LEQ (M.fromList [(2, 1)]) x2r + , LEQ (M.fromList [(3, 1)]) 0 + , LEQ (M.fromList [(4, 1)]) 0 ] ) where @@ -978,7 +984,7 @@ testPolyPaverTwoFs8 = f1dx2r = -0.8 f1yl = 4 f1yr = 5 - f2dx1l = -0.66 + f2dx1l = -0.66 f2dx1r = -0.66 f2dx2l = -0.66 f2dx2r = -0.66 @@ -990,35 +996,38 @@ testPolyPaverTwoFs8 = -- SoPlex gives -400 for the following system but -370 is the optimized solution -- simplex-haskell gives -370 -- SoPlex gives -370 if we simplify the system before sending it to SoPlex +testQuickCheck1 :: (ObjectiveFunction, [PolyConstraint]) testQuickCheck1 = - ( Max [(1, -6), (1, -8), (1, 9), (1, 10), (1, 8), (2, -15), (1, 13), (1, -14), (2, 0)] + ( Max (M.fromList [(1, -6), (1, -8), (1, 9), (1, 10), (1, 8), (2, -15), (1, 13), (1, -14), (2, 0)]) , - [ EQ [(1, 5), (1, 6), (2, -2), (1, 7), (1, 6), (2, 0)] (-12) - , GEQ [(1, 11), (1, 0), (1, -5), (1, -12), (1, -14), (2, 11)] (-7) - , GEQ [(1, -12), (1, -7), (1, -2), (2, -9), (1, 3), (1, 5), (1, -15), (2, 14)] (-8) - , GEQ [(1, 13), (1, 1), (1, -11), (2, 0)] 5 - , LEQ [(1, -10), (1, -14), (1, 4), (1, -2), (1, -10), (1, -5), (1, -11)] (-1) + [ EQ (M.fromList [(1, 5), (1, 6), (2, -2), (1, 7), (1, 6), (2, 0)]) (-12) + , GEQ (M.fromList [(1, 11), (1, 0), (1, -5), (1, -12), (1, -14), (2, 11)]) (-7) + , GEQ (M.fromList [(1, -12), (1, -7), (1, -2), (2, -9), (1, 3), (1, 5), (1, -15), (2, 14)]) (-8) + , GEQ (M.fromList [(1, 13), (1, 1), (1, -11), (2, 0)]) 5 + , LEQ (M.fromList [(1, -10), (1, -14), (1, 4), (1, -2), (1, -10), (1, -5), (1, -11)]) (-1) ] ) -- If we do not call simplifyPolyConstraints before we start the simplex algorithm, the following return a wrong solution -- Correct solution is -2/9 +testQuickCheck2 :: (ObjectiveFunction, [PolyConstraint]) testQuickCheck2 = - ( Max [(1, -3), (2, 5)] + ( Max (M.fromList [(1, -3), (2, 5)]) , - [ LEQ [(2, -1), (1, -6), (2, 7)] 4 - , LEQ [(1, 1), (2, -4), (3, 3)] (-2) - , LEQ [(2, 6), (1, -4), (2, 1)] 0 + [ LEQ (M.fromList [(2, -1), (1, -6), (2, 7)]) 4 + , LEQ (M.fromList [(1, 1), (2, -4), (3, 3)]) (-2) + , LEQ (M.fromList [(2, 6), (1, -4), (2, 1)]) 0 ] ) -- This test will fail if the objective function is not simplified +testQuickCheck3 :: (ObjectiveFunction, [PolyConstraint]) testQuickCheck3 = - ( Min [(2, 0), (2, -4)] + ( Min (M.fromList [(2, 0), (2, -4)]) , - [ GEQ [(1, 5), (2, 4)] (-4) - , LEQ [(1, -1), (2, -1)] 2 - , LEQ [(2, 1)] 2 - , GEQ [(1, -5), (2, -1), (2, 1)] (-5) + [ GEQ (M.fromList [(1, 5), (2, 4)]) (-4) + , LEQ (M.fromList [(1, -1), (2, -1)]) 2 + , LEQ (M.fromList [(2, 1)]) 2 + , GEQ (M.fromList [(1, -5), (2, -1), (2, 1)]) (-5) ] ) From 9f3e54c47ed6065101d3d3a550f2045462974f2a Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Fri, 14 Jul 2023 16:27:36 +0100 Subject: [PATCH 02/47] Run formatter --- src/Linear/Simplex/Types.hs | 3 +- src/Linear/Simplex/Util.hs | 32 +++--- test/TestFunctions.hs | 210 ++++++++++++++++++------------------ 3 files changed, 123 insertions(+), 122 deletions(-) diff --git a/src/Linear/Simplex/Types.hs b/src/Linear/Simplex/Types.hs index dff2247..9f407d5 100644 --- a/src/Linear/Simplex/Types.hs +++ b/src/Linear/Simplex/Types.hs @@ -110,7 +110,8 @@ data ObjectiveFunction = Max {objective :: VarLitMapSum} | Min {objective :: Var -- TODO: A better/alternative name data Equation = Equation { lhs :: VarLitMapSum - , rhs :: SimplexNum } + , rhs :: SimplexNum + } -- | value for entry. lhs = rhs. TODO: finish data TableauRow = TableauRow diff --git a/src/Linear/Simplex/Util.hs b/src/Linear/Simplex/Util.hs index 8b80ae9..efbb147 100644 --- a/src/Linear/Simplex/Util.hs +++ b/src/Linear/Simplex/Util.hs @@ -251,9 +251,9 @@ combineVarLitMapSums = foldDictValue :: [DictValue] -> DictValue foldDictValue [] = error "Empty list of DictValues given to foldDictValue" foldDictValue [x] = x -foldDictValue (DictValue { varMapSum = vm1, constant = c1 } : DictValue { varMapSum = vm2, constant = c2 } : dvs) = +foldDictValue (DictValue {varMapSum = vm1, constant = c1} : DictValue {varMapSum = vm2, constant = c2} : dvs) = let combinedDictValue = - DictValue + DictValue { varMapSum = foldVarLitMap [vm1, vm2] , constant = c1 + c2 } @@ -268,18 +268,18 @@ foldVarLitMap (vm1 : vm2 : vms) = let combinedVars = nub $ Map.keys vm1 <> Map.keys vm2 combinedVarMap = - Map.fromList $ map - (\var -> - let mVm1VarVal = Map.lookup var vm1 - mVm2VarVal = Map.lookup var vm2 - in - (var, - case (mVm1VarVal, mVm2VarVal) of - (Just vm1VarVal, Just vm2VarVal) -> vm1VarVal + vm2VarVal - (Just vm1VarVal, Nothing) -> vm1VarVal - (Nothing, Just vm2VarVal) -> vm2VarVal - (Nothing, Nothing) -> error "Reached unreachable branch in foldDictValue" - ) - ) - combinedVars + Map.fromList $ + map + ( \var -> + let mVm1VarVal = Map.lookup var vm1 + mVm2VarVal = Map.lookup var vm2 + in ( var + , case (mVm1VarVal, mVm2VarVal) of + (Just vm1VarVal, Just vm2VarVal) -> vm1VarVal + vm2VarVal + (Just vm1VarVal, Nothing) -> vm1VarVal + (Nothing, Just vm2VarVal) -> vm2VarVal + (Nothing, Nothing) -> error "Reached unreachable branch in foldDictValue" + ) + ) + combinedVars in foldVarLitMap $ combinedVarMap : vms diff --git a/test/TestFunctions.hs b/test/TestFunctions.hs index 8e42b9d..e4eb3a2 100644 --- a/test/TestFunctions.hs +++ b/test/TestFunctions.hs @@ -1,9 +1,9 @@ module TestFunctions where +import Data.Map qualified as M import Data.Ratio import Linear.Simplex.Types import Prelude hiding (EQ) -import qualified Data.Map as M testsList :: [((ObjectiveFunction, [PolyConstraint]), Maybe Result)] testsList = @@ -327,41 +327,41 @@ test20 = -- Solution: obj = 250, 1 = 0, 2 = 50, 3 = 0 test21 :: (ObjectiveFunction, [PolyConstraint]) test21 = - ( Max (M.fromList [(1, 3),(2, 5),(3, 2)]) + ( Max (M.fromList [(1, 3), (2, 5), (3, 2)]) , - [ LEQ (M.fromList [(1, 5),(2, 1),(3, 4)]) 50 - , LEQ (M.fromList [(1, 1),(2, -1),(3, 1)]) 150 - , LEQ (M.fromList [(1, 2),(2, 1),(3, 2)]) 100 + [ LEQ (M.fromList [(1, 5), (2, 1), (3, 4)]) 50 + , LEQ (M.fromList [(1, 1), (2, -1), (3, 1)]) 150 + , LEQ (M.fromList [(1, 2), (2, 1), (3, 2)]) 100 ] ) -test22 :: (ObjectiveFunction, [PolyConstraint]) +test22 :: (ObjectiveFunction, [PolyConstraint]) test22 = - ( Min (M.fromList [(1, 3),(2, 5),(3, 2)]) + ( Min (M.fromList [(1, 3), (2, 5), (3, 2)]) , - [ LEQ (M.fromList [(1, 5),(2, 1),(3, 4)]) 50 - , LEQ (M.fromList [(1, 1),(2, -1),(3, 1)]) 150 - , LEQ (M.fromList [(1, 2),(2, 1),(3, 2)]) 100 + [ LEQ (M.fromList [(1, 5), (2, 1), (3, 4)]) 50 + , LEQ (M.fromList [(1, 1), (2, -1), (3, 1)]) 150 + , LEQ (M.fromList [(1, 2), (2, 1), (3, 2)]) 100 ] ) test23 :: (ObjectiveFunction, [PolyConstraint]) test23 = - ( Max (M.fromList [(1, 3),(2, 5),(3, 2)]) + ( Max (M.fromList [(1, 3), (2, 5), (3, 2)]) , - [ GEQ (M.fromList [(1, 5),(2, 1),(3, 4)]) 50 - , GEQ (M.fromList [(1, 1),(2, -1),(3, 1)]) 150 - , GEQ (M.fromList [(1, 2),(2, 1),(3, 2)]) 100 + [ GEQ (M.fromList [(1, 5), (2, 1), (3, 4)]) 50 + , GEQ (M.fromList [(1, 1), (2, -1), (3, 1)]) 150 + , GEQ (M.fromList [(1, 2), (2, 1), (3, 2)]) 100 ] ) test24 :: (ObjectiveFunction, [PolyConstraint]) test24 = - ( Min (M.fromList [(1, 3),(2, 5),(3, 2)]) + ( Min (M.fromList [(1, 3), (2, 5), (3, 2)]) , - [ GEQ (M.fromList [(1, 5),(2, 1),(3, 4)]) 50 - , GEQ (M.fromList [(1, 1),(2, -1),(3, 1)]) 150 - , GEQ (M.fromList [(1, 2),(2, 1),(3, 2)]) 100 + [ GEQ (M.fromList [(1, 5), (2, 1), (3, 4)]) 50 + , GEQ (M.fromList [(1, 1), (2, -1), (3, 1)]) 150 + , GEQ (M.fromList [(1, 2), (2, 1), (3, 2)]) 100 ] ) @@ -382,7 +382,7 @@ test26 = ] ) -test27 :: (ObjectiveFunction, [PolyConstraint]) +test27 :: (ObjectiveFunction, [PolyConstraint]) test27 = ( Min (M.fromList [(1, 1)]) , @@ -423,17 +423,17 @@ testPolyPaver1 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaver1 = ( Min (M.fromList [(1, 1)]) , - [ LEQ (M.fromList [(1, dx1l),(2, dx2l),(3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r),(2, dx2r),(3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) + [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) + , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r + , LEQ (M.fromList [(1, 1)]) x1r , GEQ (M.fromList [(2, 1)]) x2l , LEQ (M.fromList [(2, 1)]) x2r , LEQ (M.fromList [(3, 1)]) 0 ] ) where - x1l = 0.0 + x1l = 0.0 x1r = 2.5 x2l = 0.0 x2r = 2.5 @@ -448,18 +448,18 @@ testPolyPaver2 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaver2 = ( Max (M.fromList [(1, 1)]) , - [ LEQ (M.fromList [(1, dx1l),(2, dx2l),(3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r),(2, dx2r),(3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) + [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) + , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) , GEQ (M.fromList [(1, 1)]) x1l , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l + , GEQ (M.fromList [(2, 1)]) x2l , LEQ (M.fromList [(2, 1)]) x2r , LEQ (M.fromList [(3, 1)]) 0 ] ) where x1l = 0.0 - x1r = 2.5 + x1r = 2.5 x2l = 0.0 x2r = 2.5 dx1l = -1 @@ -473,8 +473,8 @@ testPolyPaver3 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaver3 = ( Min (M.fromList [(2, 1)]) , - [ LEQ (M.fromList [(1, dx1l),(2, dx2l),(3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r),(2, dx2r),(3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) + [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) + , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) , GEQ (M.fromList [(1, 1)]) x1l , LEQ (M.fromList [(1, 1)]) x1r , GEQ (M.fromList [(2, 1)]) x2l @@ -486,7 +486,7 @@ testPolyPaver3 = x1l = 0.0 x1r = 2.5 x2l = 0.0 - x2r = 2.5 + x2r = 2.5 dx1l = -1 dx1r = -0.9 dx2l = -0.9 @@ -494,25 +494,25 @@ testPolyPaver3 = yl = 4 yr = 5 -testPolyPaver4 :: (ObjectiveFunction, [PolyConstraint]) +testPolyPaver4 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaver4 = ( Max (M.fromList [(2, 1)]) , - [ LEQ (M.fromList [(1, dx1l),(2, dx2l),(3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r),(2, dx2r),(3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) + [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) + , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) , GEQ (M.fromList [(1, 1)]) x1l , LEQ (M.fromList [(1, 1)]) x1r , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r + , LEQ (M.fromList [(2, 1)]) x2r , LEQ (M.fromList [(3, 1)]) 0 ] ) where x1l = 0.0 x1r = 2.5 - x2l = 0.0 + x2l = 0.0 x2r = 2.5 - dx1l = -1 + dx1l = -1 dx1r = -0.9 dx2l = -0.9 dx2r = -0.8 @@ -523,8 +523,8 @@ testPolyPaver5 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaver5 = ( Max (M.fromList [(1, 1)]) , - [ LEQ (M.fromList [(1, dx1l),(2, dx2l),(3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r),(2, dx2r),(3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) + [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) + , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) , GEQ (M.fromList [(1, 1)]) x1l , LEQ (M.fromList [(1, 1)]) x1r , GEQ (M.fromList [(2, 1)]) x2l @@ -534,7 +534,7 @@ testPolyPaver5 = ) where x1l = 0.0 - x1r = 1.5 + x1r = 1.5 x2l = 0.0 x2r = 1.5 dx1l = -1 @@ -548,12 +548,12 @@ testPolyPaver6 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaver6 = ( Min (M.fromList [(1, 1)]) , - [ LEQ (M.fromList [(1, dx1l),(2, dx2l),(3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r),(2, dx2r),(3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) + [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) + , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) , GEQ (M.fromList [(1, 1)]) x1l , LEQ (M.fromList [(1, 1)]) x1r , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r + , LEQ (M.fromList [(2, 1)]) x2r , LEQ (M.fromList [(3, 1)]) 0 ] ) @@ -563,7 +563,7 @@ testPolyPaver6 = x2l = 0.0 x2r = 1.5 dx1l = -1 - dx1r = -0.9 + dx1r = -0.9 dx2l = -0.9 dx2r = -0.8 yl = 4 @@ -573,9 +573,9 @@ testPolyPaver7 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaver7 = ( Max (M.fromList [(2, 1)]) , - [ LEQ (M.fromList [(1, dx1l),(2, dx2l),(3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r),(2, dx2r),(3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l + [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) + , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) + , GEQ (M.fromList [(1, 1)]) x1l , LEQ (M.fromList [(1, 1)]) x1r , GEQ (M.fromList [(2, 1)]) x2l , LEQ (M.fromList [(2, 1)]) x2r @@ -590,7 +590,7 @@ testPolyPaver7 = dx1l = -1 dx1r = -0.9 dx2l = -0.9 - dx2r = -0.8 + dx2r = -0.8 yl = 4 yr = 5 @@ -598,8 +598,8 @@ testPolyPaver8 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaver8 = ( Min (M.fromList [(2, 1)]) , - [ LEQ (M.fromList [(1, dx1l),(2, dx2l),(3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r),(2, dx2r),(3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) + [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) + , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) , GEQ (M.fromList [(1, 1)]) x1l , LEQ (M.fromList [(1, 1)]) x1r , GEQ (M.fromList [(2, 1)]) x2l @@ -614,7 +614,7 @@ testPolyPaver8 = x2r = 1.5 dx1l = -1 dx1r = -0.9 - dx2l = -0.9 + dx2l = -0.9 dx2r = -0.8 yl = 4 yr = 5 @@ -623,8 +623,8 @@ testPolyPaver9 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaver9 = ( Max (M.fromList [(1, 1)]) , - [ LEQ (M.fromList [(1, dx1l),(2, dx2l),(3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r),(2, dx2r),(3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) + [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) + , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) , GEQ (M.fromList [(1, 1)]) x1l , LEQ (M.fromList [(1, 1)]) x1r , GEQ (M.fromList [(2, 1)]) x2l @@ -635,21 +635,21 @@ testPolyPaver9 = where x1l = 0.0 x1r = 3.5 - x2l = 0.0 + x2l = 0.0 x2r = 3.5 dx1l = -1 dx1r = -0.9 dx2l = -0.9 dx2r = -0.8 - yl = 4 + yl = 4 yr = 5 testPolyPaver10 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaver10 = ( Min (M.fromList [(1, 1)]) - , - [ LEQ (M.fromList [(1, dx1l),(2, dx2l),(3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r),(2, dx2r),(3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) + , + [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) + , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) , GEQ (M.fromList [(1, 1)]) x1l , LEQ (M.fromList [(1, 1)]) x1r , GEQ (M.fromList [(2, 1)]) x2l @@ -659,7 +659,7 @@ testPolyPaver10 = ) where x1l = 0.0 - x1r = 3.5 + x1r = 3.5 x2l = 0.0 x2r = 3.5 dx1l = -1 @@ -669,12 +669,12 @@ testPolyPaver10 = yl = 4 yr = 5 -testPolyPaver11 :: (ObjectiveFunction, [PolyConstraint]) +testPolyPaver11 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaver11 = ( Max (M.fromList [(2, 1)]) , - [ LEQ (M.fromList [(1, dx1l),(2, dx2l),(3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r),(2, dx2r),(3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) + [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) + , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) , GEQ (M.fromList [(1, 1)]) x1l , LEQ (M.fromList [(1, 1)]) x1r , GEQ (M.fromList [(2, 1)]) x2l @@ -698,8 +698,8 @@ testPolyPaver12 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaver12 = ( Min (M.fromList [(2, 1)]) , - [ LEQ (M.fromList [(1, dx1l),(2, dx2l),(3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r),(2, dx2r),(3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) + [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) + , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) , GEQ (M.fromList [(1, 1)]) x1l , LEQ (M.fromList [(1, 1)]) x1r , GEQ (M.fromList [(2, 1)]) x2l @@ -723,10 +723,10 @@ testPolyPaverTwoFs1 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaverTwoFs1 = ( Max (M.fromList [(1, 1)]) , - [ LEQ (M.fromList [(1, f1dx1l),(2, f1dx2l),(3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) - , GEQ (M.fromList [(1, f1dx1r),(2, f1dx2r),(3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) - , LEQ (M.fromList [(1, f2dx1l),(2, f2dx2l),(4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) - , GEQ (M.fromList [(1, f2dx1r),(2, f2dx2r),(4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) + [ LEQ (M.fromList [(1, f1dx1l), (2, f1dx2l), (3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) + , GEQ (M.fromList [(1, f1dx1r), (2, f1dx2r), (3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) + , LEQ (M.fromList [(1, f2dx1l), (2, f2dx2l), (4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) + , GEQ (M.fromList [(1, f2dx1r), (2, f2dx2r), (4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) , GEQ (M.fromList [(1, 1)]) x1l , LEQ (M.fromList [(1, 1)]) x1r , GEQ (M.fromList [(2, 1)]) x2l @@ -757,10 +757,10 @@ testPolyPaverTwoFs2 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaverTwoFs2 = ( Min (M.fromList [(1, 1)]) , - [ LEQ (M.fromList [(1, f1dx1l),(2, f1dx2l),(3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) - , GEQ (M.fromList [(1, f1dx1r),(2, f1dx2r),(3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) - , LEQ (M.fromList [(1, f2dx1l),(2, f2dx2l),(4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) - , GEQ (M.fromList [(1, f2dx1r),(2, f2dx2r),(4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) + [ LEQ (M.fromList [(1, f1dx1l), (2, f1dx2l), (3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) + , GEQ (M.fromList [(1, f1dx1r), (2, f1dx2r), (3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) + , LEQ (M.fromList [(1, f2dx1l), (2, f2dx2l), (4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) + , GEQ (M.fromList [(1, f2dx1r), (2, f2dx2r), (4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) , GEQ (M.fromList [(1, 1)]) x1l , LEQ (M.fromList [(1, 1)]) x1r , GEQ (M.fromList [(2, 1)]) x2l @@ -775,7 +775,7 @@ testPolyPaverTwoFs2 = x2l = 0.0 x2r = 2.5 f1dx1l = -1 - f1dx1r = -0.9 + f1dx1r = -0.9 f1dx2l = -0.9 f1dx2r = -0.8 f1yl = 4 @@ -791,10 +791,10 @@ testPolyPaverTwoFs3 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaverTwoFs3 = ( Max (M.fromList [(2, 1)]) , - [ LEQ (M.fromList [(1, f1dx1l),(2, f1dx2l),(3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) - , GEQ (M.fromList [(1, f1dx1r),(2, f1dx2r),(3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) - , LEQ (M.fromList [(1, f2dx1l),(2, f2dx2l),(4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) - , GEQ (M.fromList [(1, f2dx1r),(2, f2dx2r),(4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) + [ LEQ (M.fromList [(1, f1dx1l), (2, f1dx2l), (3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) + , GEQ (M.fromList [(1, f1dx1r), (2, f1dx2r), (3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) + , LEQ (M.fromList [(1, f2dx1l), (2, f2dx2l), (4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) + , GEQ (M.fromList [(1, f2dx1r), (2, f2dx2r), (4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) , GEQ (M.fromList [(1, 1)]) x1l , LEQ (M.fromList [(1, 1)]) x1r , GEQ (M.fromList [(2, 1)]) x2l @@ -812,7 +812,7 @@ testPolyPaverTwoFs3 = f1dx1r = -0.9 f1dx2l = -0.9 f1dx2r = -0.8 - f1yl = 4 + f1yl = 4 f1yr = 5 f2dx1l = -1 f2dx1r = -0.9 @@ -825,14 +825,14 @@ testPolyPaverTwoFs4 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaverTwoFs4 = ( Min (M.fromList [(2, 1)]) , - [ LEQ (M.fromList [(1, f1dx1l),(2, f1dx2l),(3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) - , GEQ (M.fromList [(1, f1dx1r),(2, f1dx2r),(3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) - , LEQ (M.fromList [(1, f2dx1l),(2, f2dx2l),(4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) - , GEQ (M.fromList [(1, f2dx1r),(2, f2dx2r),(4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) + [ LEQ (M.fromList [(1, f1dx1l), (2, f1dx2l), (3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) + , GEQ (M.fromList [(1, f1dx1r), (2, f1dx2r), (3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) + , LEQ (M.fromList [(1, f2dx1l), (2, f2dx2l), (4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) + , GEQ (M.fromList [(1, f2dx1r), (2, f2dx2r), (4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) , GEQ (M.fromList [(1, 1)]) x1l , LEQ (M.fromList [(1, 1)]) x1r , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r + , LEQ (M.fromList [(2, 1)]) x2r , LEQ (M.fromList [(3, 1)]) 0 , LEQ (M.fromList [(4, 1)]) 0 ] @@ -859,11 +859,11 @@ testPolyPaverTwoFs5 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaverTwoFs5 = ( Max (M.fromList [(1, 1)]) , - [ LEQ (M.fromList [(1, f1dx1l),(2, f1dx2l),(3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) - , GEQ (M.fromList [(1, f1dx1r),(2, f1dx2r),(3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) - , LEQ (M.fromList [(1, f2dx1l),(2, f2dx2l),(4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) - , GEQ (M.fromList [(1, f2dx1r),(2, f2dx2r),(4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l + [ LEQ (M.fromList [(1, f1dx1l), (2, f1dx2l), (3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) + , GEQ (M.fromList [(1, f1dx1r), (2, f1dx2r), (3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) + , LEQ (M.fromList [(1, f2dx1l), (2, f2dx2l), (4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) + , GEQ (M.fromList [(1, f2dx1r), (2, f2dx2r), (4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) + , GEQ (M.fromList [(1, 1)]) x1l , LEQ (M.fromList [(1, 1)]) x1r , GEQ (M.fromList [(2, 1)]) x2l , LEQ (M.fromList [(2, 1)]) x2r @@ -888,21 +888,21 @@ testPolyPaverTwoFs5 = f2dx2r = -0.66 f2yl = 3 f2yr = 4 - + testPolyPaverTwoFs6 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaverTwoFs6 = ( Min (M.fromList [(1, 1)]) , - [ LEQ (M.fromList [(1, f1dx1l),(2, f1dx2l),(3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) - , GEQ (M.fromList [(1, f1dx1r),(2, f1dx2r),(3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) - , LEQ (M.fromList [(1, f2dx1l),(2, f2dx2l),(4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) - , GEQ (M.fromList [(1, f2dx1r),(2, f2dx2r),(4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) + [ LEQ (M.fromList [(1, f1dx1l), (2, f1dx2l), (3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) + , GEQ (M.fromList [(1, f1dx1r), (2, f1dx2r), (3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) + , LEQ (M.fromList [(1, f2dx1l), (2, f2dx2l), (4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) + , GEQ (M.fromList [(1, f2dx1r), (2, f2dx2r), (4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) , GEQ (M.fromList [(1, 1)]) x1l , LEQ (M.fromList [(1, 1)]) x1r , GEQ (M.fromList [(2, 1)]) x2l , LEQ (M.fromList [(2, 1)]) x2r , LEQ (M.fromList [(3, 1)]) 0 - , LEQ (M.fromList [(4, 1)]) 0 + , LEQ (M.fromList [(4, 1)]) 0 ] ) where @@ -912,7 +912,7 @@ testPolyPaverTwoFs6 = x2r = 2.5 f1dx1l = -1 f1dx1r = -0.9 - f1dx2l = -0.9 + f1dx2l = -0.9 f1dx2r = -0.8 f1yl = 4 f1yr = 5 @@ -927,10 +927,10 @@ testPolyPaverTwoFs7 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaverTwoFs7 = ( Max (M.fromList [(2, 1)]) , - [ LEQ (M.fromList [(1, f1dx1l),(2, f1dx2l),(3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) - , GEQ (M.fromList [(1, f1dx1r),(2, f1dx2r),(3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) - , LEQ (M.fromList [(1, f2dx1l),(2, f2dx2l),(4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) - , GEQ (M.fromList [(1, f2dx1r),(2, f2dx2r),(4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) + [ LEQ (M.fromList [(1, f1dx1l), (2, f1dx2l), (3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) + , GEQ (M.fromList [(1, f1dx1r), (2, f1dx2r), (3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) + , LEQ (M.fromList [(1, f2dx1l), (2, f2dx2l), (4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) + , GEQ (M.fromList [(1, f2dx1r), (2, f2dx2r), (4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) , GEQ (M.fromList [(1, 1)]) x1l , LEQ (M.fromList [(1, 1)]) x1r , GEQ (M.fromList [(2, 1)]) x2l @@ -947,7 +947,7 @@ testPolyPaverTwoFs7 = f1dx1l = -1 f1dx1r = -0.9 f1dx2l = -0.9 - f1dx2r = -0.8 + f1dx2r = -0.8 f1yl = 4 f1yr = 5 f2dx1l = -0.66 @@ -961,10 +961,10 @@ testPolyPaverTwoFs8 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaverTwoFs8 = ( Min (M.fromList [(2, 1)]) , - [ LEQ (M.fromList [(1, f1dx1l),(2, f1dx2l),(3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) - , GEQ (M.fromList [(1, f1dx1r),(2, f1dx2r),(3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) - , LEQ (M.fromList [(1, f2dx1l),(2, f2dx2l),(4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) - , GEQ (M.fromList [(1, f2dx1r),(2, f2dx2r),(4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) + [ LEQ (M.fromList [(1, f1dx1l), (2, f1dx2l), (3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) + , GEQ (M.fromList [(1, f1dx1r), (2, f1dx2r), (3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) + , LEQ (M.fromList [(1, f2dx1l), (2, f2dx2l), (4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) + , GEQ (M.fromList [(1, f2dx1r), (2, f2dx2r), (4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) , GEQ (M.fromList [(1, 1)]) x1l , LEQ (M.fromList [(1, 1)]) x1r , GEQ (M.fromList [(2, 1)]) x2l @@ -984,7 +984,7 @@ testPolyPaverTwoFs8 = f1dx2r = -0.8 f1yl = 4 f1yr = 5 - f2dx1l = -0.66 + f2dx1l = -0.66 f2dx1r = -0.66 f2dx2l = -0.66 f2dx2r = -0.66 @@ -1021,7 +1021,7 @@ testQuickCheck2 = ) -- This test will fail if the objective function is not simplified -testQuickCheck3 :: (ObjectiveFunction, [PolyConstraint]) +testQuickCheck3 :: (ObjectiveFunction, [PolyConstraint]) testQuickCheck3 = ( Min (M.fromList [(2, 0), (2, -4)]) , From 2e6845a666d66d9e6d34f9bba3dcc1a8d7c7d5a8 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 29 Jul 2023 13:40:40 +0100 Subject: [PATCH 03/47] `FeasibleSystem` instances --- src/Linear/Simplex/Types.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Linear/Simplex/Types.hs b/src/Linear/Simplex/Types.hs index 9f407d5..0e98015 100644 --- a/src/Linear/Simplex/Types.hs +++ b/src/Linear/Simplex/Types.hs @@ -50,7 +50,7 @@ data FeasibleSystem = FeasibleSystem , slackVars :: [Var] , artificialVars :: [Var] , objectiveVar :: Var - } + } deriving (Show, Read, Eq, Generic) data Result = Result { objectiveVar :: Var From 785283f554a1f83ee57a8a0e4e0b7af4524ad6ed Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 29 Jul 2023 13:41:43 +0100 Subject: [PATCH 04/47] Re-add stack --- package.yaml | 49 +++++++++++++++++++++++++++++++ simplex-method.cabal | 42 ++++++++++++--------------- stack.yaml | 68 ++++++++++++++++++++++++++++++++++++++++++++ stack.yaml.lock | 12 ++++++++ 4 files changed, 147 insertions(+), 24 deletions(-) create mode 100644 package.yaml create mode 100644 stack.yaml create mode 100644 stack.yaml.lock diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..985a728 --- /dev/null +++ b/package.yaml @@ -0,0 +1,49 @@ +name: simplex-method +version: 0.1.0.0 +github: "rasheedja/simplex-method" +license: BSD3 +author: "Junaid Rasheed" +maintainer: "jrasheed178@gmail.com" +copyright: "BSD-3" + +extra-source-files: +- README.md +- ChangeLog.md + +# Metadata used when publishing your package +synopsis: Implementation of the two-phase simplex method in exact rational arithmetic +category: Math, Maths, Mathematics, Optimisation, Optimization, Linear Programming + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README on GitHub at + +dependencies: +- base >= 4.14 && < 5 +- containers >= 0.6.5.1 && < 0.7 +- generic-lens >= 2.2.0 && < 2.3 +- lens >= 5.1.0 && < 5.2 + +default-extensions: + DataKinds + DeriveFunctor + DeriveGeneric + DuplicateRecordFields + FlexibleContexts + LambdaCase + OverloadedLabels + RecordWildCards + TupleSections + TypeApplications + ImportQualifiedPost + +library: + source-dirs: src + +tests: + simplex-haskell-test: + main: Spec.hs + source-dirs: test + dependencies: + - simplex-method diff --git a/simplex-method.cabal b/simplex-method.cabal index 6e8bf3f..fac6d5b 100644 --- a/simplex-method.cabal +++ b/simplex-method.cabal @@ -1,6 +1,6 @@ -cabal-version: 3.6 +cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.35.1. -- -- see: https://github.com/sol/hpack @@ -14,7 +14,7 @@ bug-reports: https://github.com/rasheedja/simplex-method/issues author: Junaid Rasheed maintainer: jrasheed178@gmail.com copyright: BSD-3 -license: BSD-3-Clause +license: BSD3 license-file: LICENSE build-type: Simple extra-source-files: @@ -25,45 +25,39 @@ source-repository head type: git location: https://github.com/rasheedja/simplex-method -common common-extensions - default-extensions: - DataKinds - DeriveFunctor - DeriveGeneric - DuplicateRecordFields - FlexibleContexts - LambdaCase - OverloadedLabels - RecordWildCards - TupleSections - TypeApplications - ImportQualifiedPost library - import: common-extensions exposed-modules: Linear.Simplex.Prettify Linear.Simplex.Simplex Linear.Simplex.Types Linear.Simplex.Util + other-modules: + Paths_simplex_method hs-source-dirs: src + default-extensions: + DataKinds DeriveFunctor DeriveGeneric DuplicateRecordFields FlexibleContexts LambdaCase OverloadedLabels RecordWildCards TupleSections TypeApplications ImportQualifiedPost build-depends: - base - , containers - , generic-lens - , lens + base >=4.14 && <5 + , containers >=0.6.5.1 && <0.7 + , generic-lens >=2.2.0 && <2.3 + , lens >=5.1.0 && <5.2 default-language: Haskell2010 test-suite simplex-haskell-test - import: common-extensions type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: TestFunctions + Paths_simplex_method hs-source-dirs: test + default-extensions: + DataKinds DeriveFunctor DeriveGeneric DuplicateRecordFields FlexibleContexts LambdaCase OverloadedLabels RecordWildCards TupleSections TypeApplications ImportQualifiedPost build-depends: - base >=4.7 && <5 + base >=4.14 && <5 + , containers >=0.6.5.1 && <0.7 + , generic-lens >=2.2.0 && <2.3 + , lens >=5.1.0 && <5.2 , simplex-method - , containers default-language: Haskell2010 diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..a6e3737 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,68 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# resolver: ./custom-snapshot.yaml +# resolver: https://example.com/snapshots/2018-01-01.yaml +resolver: lts-20.26 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# subdirs: +# - auto-update +# - wai +packages: +- . +# Dependency packages to be pulled from upstream that are not in the resolver. +# These entries can reference officially published versions as well as +# forks / in-progress versions pinned to a git hash. For example: +# +# extra-deps: +# - acme-missiles-0.3 +# - git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# +# extra-deps: {} + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=2.5" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor + +system-ghc: true diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 0000000..ea5a850 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,12 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: [] +snapshots: +- completed: + sha256: 5a59b2a405b3aba3c00188453be172b85893cab8ebc352b1ef58b0eae5d248a2 + size: 650475 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/26.yaml + original: lts-20.26 From d8f1929514bd2a844fde984539a6f87acd2049eb Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 29 Jul 2023 17:51:09 +0100 Subject: [PATCH 05/47] (wip) fix pivoting issues --- package.yaml | 4 ++ simplex-method.cabal | 4 +- src/Linear/Simplex/Simplex.hs | 125 ++++++++++++++++++++++------------ src/Linear/Simplex/Types.hs | 6 ++ src/Linear/Simplex/Util.hs | 3 + 5 files changed, 95 insertions(+), 47 deletions(-) diff --git a/package.yaml b/package.yaml index 985a728..09c56d3 100644 --- a/package.yaml +++ b/package.yaml @@ -37,6 +37,10 @@ default-extensions: TupleSections TypeApplications ImportQualifiedPost + OverloadedRecordDot + DuplicateRecordFields + NamedFieldPuns + DisambiguateRecordFields library: source-dirs: src diff --git a/simplex-method.cabal b/simplex-method.cabal index fac6d5b..c474270 100644 --- a/simplex-method.cabal +++ b/simplex-method.cabal @@ -36,7 +36,7 @@ library hs-source-dirs: src default-extensions: - DataKinds DeriveFunctor DeriveGeneric DuplicateRecordFields FlexibleContexts LambdaCase OverloadedLabels RecordWildCards TupleSections TypeApplications ImportQualifiedPost + DataKinds DeriveFunctor DeriveGeneric DuplicateRecordFields FlexibleContexts LambdaCase OverloadedLabels RecordWildCards TupleSections TypeApplications ImportQualifiedPost OverloadedRecordDot DuplicateRecordFields NamedFieldPuns DisambiguateRecordFields build-depends: base >=4.14 && <5 , containers >=0.6.5.1 && <0.7 @@ -53,7 +53,7 @@ test-suite simplex-haskell-test hs-source-dirs: test default-extensions: - DataKinds DeriveFunctor DeriveGeneric DuplicateRecordFields FlexibleContexts LambdaCase OverloadedLabels RecordWildCards TupleSections TypeApplications ImportQualifiedPost + DataKinds DeriveFunctor DeriveGeneric DuplicateRecordFields FlexibleContexts LambdaCase OverloadedLabels RecordWildCards TupleSections TypeApplications ImportQualifiedPost OverloadedRecordDot DuplicateRecordFields NamedFieldPuns DisambiguateRecordFields build-depends: base >=4.14 && <5 , containers >=0.6.5.1 && <0.7 diff --git a/src/Linear/Simplex/Simplex.hs b/src/Linear/Simplex/Simplex.hs index e8571fe..47799a1 100644 --- a/src/Linear/Simplex/Simplex.hs +++ b/src/Linear/Simplex/Simplex.hs @@ -25,7 +25,8 @@ import Linear.Simplex.Types import Linear.Simplex.Util import Prelude hiding (EQ) --- import Debug.Trace (trace) +import Debug.Trace qualified as T +import qualified Data.Bifunctor as Bifunctor trace s a = a @@ -179,6 +180,7 @@ findFeasibleSolution unsimplifiedSystem = PivotObjective { variable = objectiveVar , function = foldVarLitMap $ map (^. #varMapSum) negatedRowsWithoutArtificialVars + , constant = sum $ map (^. #constant) negatedRowsWithoutArtificialVars } where -- test2 = foldr (+) 0 test @@ -189,7 +191,11 @@ findFeasibleSolution unsimplifiedSystem = -- test = map (^. #constant) negatedRowsWithoutArtificialVars -- Filter out non-artificial entries rowsToAdd = M.filterWithKey (\k _ -> k `elem` artificialVars) rows + negatedRows = M.map (\(DictValue rowVarMapSum rowConstant) -> DictValue (M.map negate rowVarMapSum) (negate rowConstant)) rowsToAdd + -- negatedRowsSum = foldVarLitMap $ map $ M.toList (^. #varMapSum) negatedRows -- Negate rows, discard keys and artificial vars since the pivot objective does not care about them + -- negatedRowsMapSum = foldSumVarConstMap + -- negatedRowsConstSum = _ negatedRowsWithoutArtificialVars = map ( \(_, DictValue {..}) -> @@ -206,12 +212,13 @@ findFeasibleSolution unsimplifiedSystem = -- Returns a pair with the first item being the 'Integer' variable equal to the 'ObjectiveFunction' -- and the second item being a map of the values of all 'Integer' variables appearing in the system, including the 'ObjectiveFunction'. optimizeFeasibleSystem :: ObjectiveFunction -> FeasibleSystem -> Maybe Result -optimizeFeasibleSystem unsimplifiedObjFunction (FeasibleSystem {dict = phase1Dict, ..}) = +optimizeFeasibleSystem unsimplifiedObjFunction fsys@(FeasibleSystem {dict = phase1Dict, ..}) = + T.trace ("feasible system: " <> show fsys) $ if null artificialVars then -- then displayResults . dictionaryFormToTableau <$> simplexPivot (createObjectiveDict objFunction objectiveVar : phase1Dict) -- else displayResults . dictionaryFormToTableau <$> simplexPivot (createObjectiveDict phase2ObjFunction objectiveVar : tail phase1Dict) - displayResults . dictionaryFormToTableau <$> simplexPivot phase1PivotObjective phase1Dict - else displayResults . dictionaryFormToTableau <$> simplexPivot phase2PivotObjective phase1Dict + T.trace "null" $ displayResults . dictionaryFormToTableau <$> simplexPivot phase1PivotObjective phase1Dict + else T.trace "notnull" $ displayResults . dictionaryFormToTableau <$> simplexPivot phase2PivotObjective phase1Dict where objFunction = simplifyObjectiveFunction unsimplifiedObjFunction @@ -250,7 +257,7 @@ optimizeFeasibleSystem unsimplifiedObjFunction (FeasibleSystem {dict = phase1Dic PivotObjective { variable = objectiveVar , function = if isMax objFunction then objFunction ^. #objective else M.map negate (objFunction ^. #objective) - -- , constants = M.empty + , constant = 0 } -- TODO: New type for Phase2Objective @@ -259,7 +266,7 @@ optimizeFeasibleSystem unsimplifiedObjFunction (FeasibleSystem {dict = phase1Dic PivotObjective { variable = objectiveVar , function = calcVarMap - -- , constants = calcConstants + , constant = calcConstants } where -- type VarLitMapSum = M.Map Var SimplexNum @@ -278,21 +285,22 @@ optimizeFeasibleSystem unsimplifiedObjFunction (FeasibleSystem {dict = phase1Dic -- ) -- $ calcVarMap - calcConstants :: VarLitMap + calcConstants :: SimplexNum calcConstants = - M.mapWithKey - ( \var coeff -> - case M.lookup var phase1Dict of + sum $ map + ( \(var, coeff) -> + let multiplyWith = if isMax objFunction then coeff else -coeff + in case M.lookup var phase1Dict of Nothing -> 0 - Just row -> (row ^. #constant) * coeff + Just row -> (row ^. #constant) * multiplyWith ) - $ objFunction ^. #objective + $ M.toList (objFunction ^. #objective) calcVarMap :: VarLitMapSum calcVarMap = - M.fromList - $ concatMap - ( \(var, coeff) -> + -- M.fromList + foldVarLitMap $ + map (M.fromList . ( \(var, coeff) -> let multiplyWith = if isMax objFunction then coeff else -coeff in case M.lookup var phase1Dict of Nothing -> @@ -306,8 +314,7 @@ optimizeFeasibleSystem unsimplifiedObjFunction (FeasibleSystem {dict = phase1Dic -- & #varMapSum %~ M.map (* coeff) -- & #constant %~ (* coeff) -- TODO: Apply 0 -- map (second (* coeff)) row - ) - $ M.toList (objFunction ^. #objective) + )) (M.toList (objFunction ^. #objective)) -- phase2ObjFunction = -- undefined @@ -319,34 +326,40 @@ optimizeFeasibleSystem unsimplifiedObjFunction (FeasibleSystem {dict = phase1Dic -- and the second item being a map of the values of all 'Integer' variables appearing in the system, including the 'ObjectiveFunction'. twoPhaseSimplex :: ObjectiveFunction -> [PolyConstraint] -> Maybe Result twoPhaseSimplex objFunction unsimplifiedSystem = + -- TODO: Distinguish between infeasible and unpotimisable case findFeasibleSolution unsimplifiedSystem of - Just feasibleSystem -> optimizeFeasibleSystem objFunction feasibleSystem - Nothing -> Nothing + Just feasibleSystem -> T.trace "feasible" optimizeFeasibleSystem objFunction feasibleSystem + Nothing -> T.trace "infeasible" Nothing -- | Perform the simplex pivot algorithm on a system with basic vars, assume that the first row is the 'ObjectiveFunction'. simplexPivot :: PivotObjective -> Dict -> Maybe Dict -simplexPivot objective@(PivotObjective {variable = objectiveVar, function = objectiveVal, ..}) dictionary = - trace (show dictionary) $ - case mostPositive objectiveVal of +simplexPivot objective@(PivotObjective {variable = objectiveVar, function = objectiveFunc, constant = objectiveConstant}) dictionary = + T.trace ("obj: " <> show objective <> "\n" <> show dictionary) + T.trace (show dictionary) $ + case mostPositive objectiveFunc of Nothing -> - trace + T.trace "all neg \n" - trace + T.trace ("obj: " <> show objective <> "\n" <> show dictionary) + T.trace (show dictionary) - Just - dictionary + Just (insertPivotObjectiveToDict objective dictionary) Just pivotNonBasicVar -> let mPivotBasicVar = ratioTest dictionary pivotNonBasicVar Nothing Nothing - in case mPivotBasicVar of - Nothing -> trace ("Ratio test failed on non-basic var: " ++ show pivotNonBasicVar ++ "\n" ++ show dictionary) Nothing + in T.trace ("most pos: " <> show pivotNonBasicVar) $ case mPivotBasicVar of + Nothing -> T.trace ("Ratio test failed on non-basic var: " ++ show pivotNonBasicVar ++ "\n" ++ show dictionary) Nothing Just pivotBasicVar -> - trace - "one pos \n" - trace - (show dictionary) + let pivotResult = pivot pivotBasicVar pivotNonBasicVar (insertPivotObjectiveToDict objective dictionary) + pivotedObj = + let pivotedObjEntry = fromMaybe (error "Can't find obj after pivoting") $ M.lookup objectiveVar pivotResult + in objective & #function .~ (pivotedObjEntry ^. #varMapSum) & #constant .~ (pivotedObjEntry ^. #constant) + pivotedDict = M.delete objectiveVar pivotResult + in + T.trace "one pos \n" $ + T.trace ("obj: " <> show objective <> "\n" <> show dictionary) $ simplexPivot - objective - (pivot pivotBasicVar pivotNonBasicVar dictionary) + pivotedObj + pivotedDict where ratioTest :: Dict -> Var -> Maybe Var -> Maybe Rational -> Maybe Var ratioTest dict = aux (M.toList dict) @@ -374,9 +387,9 @@ simplexPivot objective@(PivotObjective {variable = objectiveVar, function = obje case findLargestCoeff (M.toList varLitMap) Nothing of Just (largestVarName, largestVarCoeff) -> if largestVarCoeff <= 0 - then Nothing + then T.trace "negative" Nothing else Just largestVarName - Nothing -> trace "No variables in first row when looking for most positive" Nothing + Nothing -> T.trace "No variables in first row when looking for most positive" Nothing where findLargestCoeff :: [(Var, SimplexNum)] -> Maybe (Var, SimplexNum) -> Maybe (Var, SimplexNum) findLargestCoeff [] mCurrentMax = mCurrentMax @@ -407,12 +420,13 @@ simplexPivot objective@(PivotObjective {variable = objectiveVar, function = obje dictEntertingRow & #varMapSum %~ ( \basicEquation -> - uncurry - M.insert - newEnteringVarTerm + -- uncurry + M.insert + leavingVariable + (-1) (filterOutEnteringVarTerm basicEquation) & traverse - %~ divideByNegatedEnteringVariableCoeff + %~ divideByNegatedEnteringVariableCoeff ) & #constant %~ divideByNegatedEnteringVariableCoeff @@ -422,7 +436,10 @@ simplexPivot objective@(PivotObjective {variable = objectiveVar, function = obje -- Substitute pivot equation into other rows updatedRows :: Dict - updatedRows = M.mapWithKey f dict + updatedRows = + -- M.mapWithKey f dict + M.fromList $ map (uncurry f2) $ M.toList dict + -- Bifunctor.bimap f2 dict where -- Dict -- { objective = f $ dict ^. #objectiveFunction @@ -431,16 +448,34 @@ simplexPivot objective@(PivotObjective {variable = objectiveVar, function = obje f entryVar entryVal = if leavingVariable == entryVar - then pivotEnteringRow + then pivotEnteringRow --TODO: UPDATE KEY else case M.lookup enteringVariable (entryVal ^. #varMapSum) of Just subsCoeff -> entryVal & #varMapSum - %~ ( combineVarLitMapSums + .~ combineVarLitMapSums (pivotEnteringRow ^. #varMapSum <&> (subsCoeff *)) - . filterOutEnteringVarTerm - ) + (filterOutEnteringVarTerm (entryVal ^. #varMapSum)) + & #constant + .~ + ((subsCoeff * (pivotEnteringRow ^. #constant)) + entryVal ^. #constant) Nothing -> entryVal + + f2 :: Var -> DictValue -> (Var, DictValue) + f2 entryVar entryVal = + if leavingVariable == entryVar + then (enteringVariable, pivotEnteringRow) --TODO: UPDATE KEY + else case M.lookup enteringVariable (entryVal ^. #varMapSum) of + Just subsCoeff -> + (entryVar, entryVal + & #varMapSum + .~ combineVarLitMapSums + (pivotEnteringRow ^. #varMapSum <&> (subsCoeff *)) + (filterOutEnteringVarTerm (entryVal ^. #varMapSum)) + & #constant + .~ + ((subsCoeff * (pivotEnteringRow ^. #constant)) + entryVal ^. #constant)) + Nothing -> (entryVar, entryVal) Nothing -> error "pivot: non basic variable not found in basic row" where -- \| The entering row, i.e., the row in the dict which is the value of diff --git a/src/Linear/Simplex/Types.hs b/src/Linear/Simplex/Types.hs index 0e98015..ac43bdb 100644 --- a/src/Linear/Simplex/Types.hs +++ b/src/Linear/Simplex/Types.hs @@ -55,6 +55,10 @@ data FeasibleSystem = FeasibleSystem data Result = Result { objectiveVar :: Var , varValMap :: VarLitMap + -- TODO: + -- Maybe VarLitMap + -- , feasible :: Bool + -- , optimisable :: Bool } deriving (Show, Read, Eq, Generic) @@ -180,4 +184,6 @@ type Dict = M.Map Var DictValue data PivotObjective = PivotObjective { variable :: Var , function :: VarLitMapSum + , constant :: SimplexNum } + deriving (Show, Read, Eq, Generic) diff --git a/src/Linear/Simplex/Util.hs b/src/Linear/Simplex/Util.hs index efbb147..fb8f3fa 100644 --- a/src/Linear/Simplex/Util.hs +++ b/src/Linear/Simplex/Util.hs @@ -283,3 +283,6 @@ foldVarLitMap (vm1 : vm2 : vms) = ) combinedVars in foldVarLitMap $ combinedVarMap : vms + +insertPivotObjectiveToDict :: PivotObjective -> Dict -> Dict +insertPivotObjectiveToDict objective dict = Map.insert (objective.variable) (DictValue {varMapSum = objective.function, constant = objective.constant}) dict From 33ad19f627d964886d698c16d39fcadee523e9fc Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Fri, 11 Aug 2023 16:51:31 +0100 Subject: [PATCH 06/47] Switch CI to stack --- .github/workflows/haskell.yml | 27 ++++++++++++++------------- 1 file changed, 14 insertions(+), 13 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 7de7f26..5b034de 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -41,35 +41,36 @@ jobs: id: setup with: ghc-version: ${{ matrix.ghc-version }} - # Defaults, added for clarity: - cabal-version: 'latest' - cabal-update: true + enable-stack: true - - name: Installed minor versions of GHC and Cabal + - name: Installed minor versions of GHC, Cabal, and Stack shell: bash run: | GHC_VERSION=$(ghc --numeric-version) CABAL_VERSION=$(cabal --numeric-version) + STACK_VERSION=$(stack --numeric-version) echo "GHC_VERSION=${GHC_VERSION}" >> "${GITHUB_ENV}" echo "CABAL_VERSION=${CABAL_VERSION}" >> "${GITHUB_ENV}" + echo "STACK_VERSION=${STACK_VERSION}" >> "${GITHUB_ENV}" - name: Configure the build run: | - cabal configure --enable-tests --enable-benchmarks --disable-documentation - cabal build --dry-run + # cabal configure --enable-tests --enable-benchmarks --disable-documentation + # cabal build --dry-run + stack build --test --bench --no-haddock --dry-run # The last step generates dist-newstyle/cache/plan.json for the cache key. - name: Restore cached dependencies uses: actions/cache/restore@v3 id: cache with: - path: ${{ steps.setup.outputs.cabal-store }} - key: ${{ runner.os }}-ghc-${{ env.GHC_VERSION }}-cabal-${{ env.CABAL_VERSION }}-plan-${{ hashFiles('**/plan.json') }} + path: .stack-work + key: ${{ runner.os }}-ghc-${{ env.GHC_VERSION }}-stack-${{ env.STACK_VERSION }}-plan-${{ hashFiles('**/plan.json') }} restore-keys: | - ${{ runner.os }}-ghc-${{ env.GHC_VERSION }}-cabal-${{ env.CABAL_VERSION }}- + ${{ runner.os }}-ghc-${{ env.GHC_VERSION }}-stack-${{ env.STACK_VERSION }}- - name: Install dependencies - run: cabal build all --only-dependencies + run: stack build --only-dependencies # Cache dependencies already here, so that we do not have to rebuild them should the subsequent steps fail. - name: Save cached dependencies @@ -78,14 +79,14 @@ jobs: if: ${{ !steps.cache.outputs.cache-hit || steps.cache.outputs.cache-primary-key != steps.cache.outputs.cache-matched-key }} with: - path: ${{ steps.setup.outputs.cabal-store }} + path: .stack-work key: ${{ steps.cache.outputs.cache-primary-key }} - name: Build - run: cabal build all + run: stack build - name: Run tests - run: cabal test all + run: stack test - name: Check cabal file run: cabal check From 9a322d6df2d49c72890ea83e78d89e30813d6e29 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Fri, 11 Aug 2023 17:00:25 +0100 Subject: [PATCH 07/47] Use stack to build haddocks --- .github/workflows/haskell.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 5b034de..300de6e 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -92,4 +92,4 @@ jobs: run: cabal check - name: Build documentation - run: cabal haddock all \ No newline at end of file + run: stack haddock \ No newline at end of file From 160c2535ca5387e9502f420a037843dc5e03e26b Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Fri, 11 Aug 2023 17:14:03 +0100 Subject: [PATCH 08/47] Run formatter --- package.yaml | 1 - simplex-method.cabal | 4 +- src/Linear/Simplex/Simplex.hs | 127 ++++++++++++++++++---------------- src/Linear/Simplex/Types.hs | 5 +- src/Linear/Simplex/Util.hs | 4 +- test/TestFunctions.hs | 2 +- 6 files changed, 76 insertions(+), 67 deletions(-) diff --git a/package.yaml b/package.yaml index 09c56d3..4907887 100644 --- a/package.yaml +++ b/package.yaml @@ -36,7 +36,6 @@ default-extensions: RecordWildCards TupleSections TypeApplications - ImportQualifiedPost OverloadedRecordDot DuplicateRecordFields NamedFieldPuns diff --git a/simplex-method.cabal b/simplex-method.cabal index c474270..dd726c3 100644 --- a/simplex-method.cabal +++ b/simplex-method.cabal @@ -36,7 +36,7 @@ library hs-source-dirs: src default-extensions: - DataKinds DeriveFunctor DeriveGeneric DuplicateRecordFields FlexibleContexts LambdaCase OverloadedLabels RecordWildCards TupleSections TypeApplications ImportQualifiedPost OverloadedRecordDot DuplicateRecordFields NamedFieldPuns DisambiguateRecordFields + DataKinds DeriveFunctor DeriveGeneric DuplicateRecordFields FlexibleContexts LambdaCase OverloadedLabels RecordWildCards TupleSections TypeApplications OverloadedRecordDot DuplicateRecordFields NamedFieldPuns DisambiguateRecordFields build-depends: base >=4.14 && <5 , containers >=0.6.5.1 && <0.7 @@ -53,7 +53,7 @@ test-suite simplex-haskell-test hs-source-dirs: test default-extensions: - DataKinds DeriveFunctor DeriveGeneric DuplicateRecordFields FlexibleContexts LambdaCase OverloadedLabels RecordWildCards TupleSections TypeApplications ImportQualifiedPost OverloadedRecordDot DuplicateRecordFields NamedFieldPuns DisambiguateRecordFields + DataKinds DeriveFunctor DeriveGeneric DuplicateRecordFields FlexibleContexts LambdaCase OverloadedLabels RecordWildCards TupleSections TypeApplications OverloadedRecordDot DuplicateRecordFields NamedFieldPuns DisambiguateRecordFields build-depends: base >=4.14 && <5 , containers >=0.6.5.1 && <0.7 diff --git a/src/Linear/Simplex/Simplex.hs b/src/Linear/Simplex/Simplex.hs index 47799a1..0995c6d 100644 --- a/src/Linear/Simplex/Simplex.hs +++ b/src/Linear/Simplex/Simplex.hs @@ -17,7 +17,7 @@ module Linear.Simplex.Simplex (findFeasibleSolution, optimizeFeasibleSystem, two import Control.Lens import Data.Bifunctor import Data.List -import Data.Map qualified as M +import qualified Data.Map as M import Data.Maybe (fromJust, fromMaybe, mapMaybe) import Data.Ratio (denominator, numerator, (%)) import GHC.Real (Ratio) @@ -25,8 +25,8 @@ import Linear.Simplex.Types import Linear.Simplex.Util import Prelude hiding (EQ) -import Debug.Trace qualified as T import qualified Data.Bifunctor as Bifunctor +import qualified Debug.Trace as T trace s a = a @@ -214,11 +214,11 @@ findFeasibleSolution unsimplifiedSystem = optimizeFeasibleSystem :: ObjectiveFunction -> FeasibleSystem -> Maybe Result optimizeFeasibleSystem unsimplifiedObjFunction fsys@(FeasibleSystem {dict = phase1Dict, ..}) = T.trace ("feasible system: " <> show fsys) $ - if null artificialVars - then -- then displayResults . dictionaryFormToTableau <$> simplexPivot (createObjectiveDict objFunction objectiveVar : phase1Dict) - -- else displayResults . dictionaryFormToTableau <$> simplexPivot (createObjectiveDict phase2ObjFunction objectiveVar : tail phase1Dict) - T.trace "null" $ displayResults . dictionaryFormToTableau <$> simplexPivot phase1PivotObjective phase1Dict - else T.trace "notnull" $ displayResults . dictionaryFormToTableau <$> simplexPivot phase2PivotObjective phase1Dict + if null artificialVars + then -- then displayResults . dictionaryFormToTableau <$> simplexPivot (createObjectiveDict objFunction objectiveVar : phase1Dict) + -- else displayResults . dictionaryFormToTableau <$> simplexPivot (createObjectiveDict phase2ObjFunction objectiveVar : tail phase1Dict) + T.trace "null" $ displayResults . dictionaryFormToTableau <$> simplexPivot phase1PivotObjective phase1Dict + else T.trace "notnull" $ displayResults . dictionaryFormToTableau <$> simplexPivot phase2PivotObjective phase1Dict where objFunction = simplifyObjectiveFunction unsimplifiedObjFunction @@ -287,34 +287,39 @@ optimizeFeasibleSystem unsimplifiedObjFunction fsys@(FeasibleSystem {dict = phas calcConstants :: SimplexNum calcConstants = - sum $ map - ( \(var, coeff) -> - let multiplyWith = if isMax objFunction then coeff else -coeff - in case M.lookup var phase1Dict of - Nothing -> 0 - Just row -> (row ^. #constant) * multiplyWith - ) + sum + $ map + ( \(var, coeff) -> + let multiplyWith = if isMax objFunction then coeff else -coeff + in case M.lookup var phase1Dict of + Nothing -> 0 + Just row -> (row ^. #constant) * multiplyWith + ) $ M.toList (objFunction ^. #objective) calcVarMap :: VarLitMapSum calcVarMap = -- M.fromList - foldVarLitMap $ - map (M.fromList . ( \(var, coeff) -> - let multiplyWith = if isMax objFunction then coeff else -coeff - in case M.lookup var phase1Dict of - Nothing -> - -- DictValue - -- { varMapSum = M.singleton var coeff - -- , constant = 0 - -- } - [(var, multiplyWith)] - Just row -> map (second (* multiplyWith)) (M.toList $ row ^. #varMapSum) - -- row - -- & #varMapSum %~ M.map (* coeff) - -- & #constant %~ (* coeff) -- TODO: Apply 0 - -- map (second (* coeff)) row - )) (M.toList (objFunction ^. #objective)) + foldVarLitMap $ + map + ( M.fromList + . ( \(var, coeff) -> + let multiplyWith = if isMax objFunction then coeff else -coeff + in case M.lookup var phase1Dict of + Nothing -> + -- DictValue + -- { varMapSum = M.singleton var coeff + -- , constant = 0 + -- } + [(var, multiplyWith)] + Just row -> map (second (* multiplyWith)) (M.toList $ row ^. #varMapSum) + -- row + -- & #varMapSum %~ M.map (* coeff) + -- & #constant %~ (* coeff) -- TODO: Apply 0 + -- map (second (* coeff)) row + ) + ) + (M.toList (objFunction ^. #objective)) -- phase2ObjFunction = -- undefined @@ -334,16 +339,20 @@ twoPhaseSimplex objFunction unsimplifiedSystem = -- | Perform the simplex pivot algorithm on a system with basic vars, assume that the first row is the 'ObjectiveFunction'. simplexPivot :: PivotObjective -> Dict -> Maybe Dict simplexPivot objective@(PivotObjective {variable = objectiveVar, function = objectiveFunc, constant = objectiveConstant}) dictionary = - T.trace ("obj: " <> show objective <> "\n" <> show dictionary) - T.trace (show dictionary) $ - case mostPositive objectiveFunc of + T.trace + ("obj: " <> show objective <> "\n" <> show dictionary) + T.trace + (show dictionary) + $ case mostPositive objectiveFunc of Nothing -> T.trace "all neg \n" - T.trace ("obj: " <> show objective <> "\n" <> show dictionary) + T.trace + ("obj: " <> show objective <> "\n" <> show dictionary) T.trace (show dictionary) - Just (insertPivotObjectiveToDict objective dictionary) + Just + (insertPivotObjectiveToDict objective dictionary) Just pivotNonBasicVar -> let mPivotBasicVar = ratioTest dictionary pivotNonBasicVar Nothing Nothing in T.trace ("most pos: " <> show pivotNonBasicVar) $ case mPivotBasicVar of @@ -352,14 +361,13 @@ simplexPivot objective@(PivotObjective {variable = objectiveVar, function = obje let pivotResult = pivot pivotBasicVar pivotNonBasicVar (insertPivotObjectiveToDict objective dictionary) pivotedObj = let pivotedObjEntry = fromMaybe (error "Can't find obj after pivoting") $ M.lookup objectiveVar pivotResult - in objective & #function .~ (pivotedObjEntry ^. #varMapSum) & #constant .~ (pivotedObjEntry ^. #constant) + in objective & #function .~ (pivotedObjEntry ^. #varMapSum) & #constant .~ (pivotedObjEntry ^. #constant) pivotedDict = M.delete objectiveVar pivotResult - in - T.trace "one pos \n" $ - T.trace ("obj: " <> show objective <> "\n" <> show dictionary) $ - simplexPivot - pivotedObj - pivotedDict + in T.trace "one pos \n" $ + T.trace ("obj: " <> show objective <> "\n" <> show dictionary) $ + simplexPivot + pivotedObj + pivotedDict where ratioTest :: Dict -> Var -> Maybe Var -> Maybe Rational -> Maybe Var ratioTest dict = aux (M.toList dict) @@ -426,7 +434,7 @@ simplexPivot objective@(PivotObjective {variable = objectiveVar, function = obje (-1) (filterOutEnteringVarTerm basicEquation) & traverse - %~ divideByNegatedEnteringVariableCoeff + %~ divideByNegatedEnteringVariableCoeff ) & #constant %~ divideByNegatedEnteringVariableCoeff @@ -439,8 +447,9 @@ simplexPivot objective@(PivotObjective {variable = objectiveVar, function = obje updatedRows = -- M.mapWithKey f dict M.fromList $ map (uncurry f2) $ M.toList dict - -- Bifunctor.bimap f2 dict where + -- Bifunctor.bimap f2 dict + -- Dict -- { objective = f $ dict ^. #objectiveFunction -- , entries = fmap f $ dict ^. #entries @@ -448,33 +457,33 @@ simplexPivot objective@(PivotObjective {variable = objectiveVar, function = obje f entryVar entryVal = if leavingVariable == entryVar - then pivotEnteringRow --TODO: UPDATE KEY + then pivotEnteringRow -- TODO: UPDATE KEY else case M.lookup enteringVariable (entryVal ^. #varMapSum) of Just subsCoeff -> entryVal & #varMapSum .~ combineVarLitMapSums - (pivotEnteringRow ^. #varMapSum <&> (subsCoeff *)) - (filterOutEnteringVarTerm (entryVal ^. #varMapSum)) + (pivotEnteringRow ^. #varMapSum <&> (subsCoeff *)) + (filterOutEnteringVarTerm (entryVal ^. #varMapSum)) & #constant - .~ - ((subsCoeff * (pivotEnteringRow ^. #constant)) + entryVal ^. #constant) + .~ ((subsCoeff * (pivotEnteringRow ^. #constant)) + entryVal ^. #constant) Nothing -> entryVal f2 :: Var -> DictValue -> (Var, DictValue) f2 entryVar entryVal = - if leavingVariable == entryVar - then (enteringVariable, pivotEnteringRow) --TODO: UPDATE KEY + if leavingVariable == entryVar + then (enteringVariable, pivotEnteringRow) -- TODO: UPDATE KEY else case M.lookup enteringVariable (entryVal ^. #varMapSum) of Just subsCoeff -> - (entryVar, entryVal - & #varMapSum - .~ combineVarLitMapSums - (pivotEnteringRow ^. #varMapSum <&> (subsCoeff *)) - (filterOutEnteringVarTerm (entryVal ^. #varMapSum)) - & #constant - .~ - ((subsCoeff * (pivotEnteringRow ^. #constant)) + entryVal ^. #constant)) + ( entryVar + , entryVal + & #varMapSum + .~ combineVarLitMapSums + (pivotEnteringRow ^. #varMapSum <&> (subsCoeff *)) + (filterOutEnteringVarTerm (entryVal ^. #varMapSum)) + & #constant + .~ ((subsCoeff * (pivotEnteringRow ^. #constant)) + entryVal ^. #constant) + ) Nothing -> (entryVar, entryVal) Nothing -> error "pivot: non basic variable not found in basic row" where diff --git a/src/Linear/Simplex/Types.hs b/src/Linear/Simplex/Types.hs index ac43bdb..cccd57e 100644 --- a/src/Linear/Simplex/Types.hs +++ b/src/Linear/Simplex/Types.hs @@ -10,7 +10,7 @@ module Linear.Simplex.Types where import Control.Lens import Data.Generics.Labels () import Data.List (sort) -import Data.Map qualified as M +import qualified Data.Map as M import GHC.Generics (Generic) type Var = Int @@ -50,7 +50,8 @@ data FeasibleSystem = FeasibleSystem , slackVars :: [Var] , artificialVars :: [Var] , objectiveVar :: Var - } deriving (Show, Read, Eq, Generic) + } + deriving (Show, Read, Eq, Generic) data Result = Result { objectiveVar :: Var diff --git a/src/Linear/Simplex/Util.hs b/src/Linear/Simplex/Util.hs index fb8f3fa..3751ac8 100644 --- a/src/Linear/Simplex/Util.hs +++ b/src/Linear/Simplex/Util.hs @@ -14,8 +14,8 @@ import Data.Bifunctor import Data.Generics.Labels () import Data.Generics.Product (field) import Data.List -import Data.Map qualified as Map -import Data.Map.Merge.Lazy qualified as MapMerge +import qualified Data.Map as Map +import qualified Data.Map.Merge.Lazy as MapMerge import Data.Maybe (fromMaybe) import Linear.Simplex.Types import Prelude hiding (EQ) diff --git a/test/TestFunctions.hs b/test/TestFunctions.hs index e4eb3a2..886a510 100644 --- a/test/TestFunctions.hs +++ b/test/TestFunctions.hs @@ -1,6 +1,6 @@ module TestFunctions where -import Data.Map qualified as M +import qualified Data.Map as M import Data.Ratio import Linear.Simplex.Types import Prelude hiding (EQ) From fbd8dc5517aee73270b112ae973998d698d6624d Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Fri, 11 Aug 2023 17:31:54 +0100 Subject: [PATCH 09/47] Matrix test windows and macos --- .github/workflows/haskell.yml | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 300de6e..b002374 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -24,15 +24,9 @@ jobs: strategy: fail-fast: false matrix: - os: [ubuntu-latest] + os: [windows-latest, macos-latest, ubuntu-latest] ghc-version: ['9.6', '9.4', '9.2', '9.0', '8.10'] - include: - - os: windows-latest - ghc-version: '9.6' - - os: macos-latest - ghc-version: '9.6' - steps: - uses: actions/checkout@v3 From 1cf530723aa132d5452df33d95b33b2f4af7257a Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Fri, 11 Aug 2023 17:32:46 +0100 Subject: [PATCH 10/47] Remove ghc 8.10 from CI --- .github/workflows/haskell.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index b002374..4577ffa 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -25,7 +25,7 @@ jobs: fail-fast: false matrix: os: [windows-latest, macos-latest, ubuntu-latest] - ghc-version: ['9.6', '9.4', '9.2', '9.0', '8.10'] + ghc-version: ['9.6', '9.4', '9.2', '9.0'] steps: - uses: actions/checkout@v3 From e4f1c6615d3cdc385d31e7ed97505d4156ead8cd Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 12 Aug 2023 17:33:59 +0100 Subject: [PATCH 11/47] Make CI fail when tests fail --- test/Spec.hs | 26 ++++++++++++++------------ 1 file changed, 14 insertions(+), 12 deletions(-) diff --git a/test/Spec.hs b/test/Spec.hs index 78675e0..0fadfc6 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -14,15 +14,17 @@ runTests (((testObjective, testConstraints), expectedResult) : tests) = in if testResult == expectedResult then runTests tests else do - putStrLn "The following test failed: \n" - putStrLn ("Objective Function (Non-prettified): " ++ show testObjective) - putStrLn ("Constraints (Non-prettified): " ++ show testConstraints) - putStrLn "====================================\n" - putStrLn ("Objective Function (Prettified): " ++ prettyShowObjectiveFunction testObjective) - putStrLn "Constraints (Prettified): " - putStrLn (concatMap ((\c -> "\t" ++ prettyShowPolyConstraint c ++ "\n")) testConstraints) - putStrLn "====================================\n" - putStrLn ("Expected Solution (Full): " ++ show expectedResult) - putStrLn ("Actual Solution (Full): " ++ show testResult) - putStrLn ("Expected Solution (Objective): " ++ show (extractObjectiveValue expectedResult)) - putStrLn ("Actual Solution (Objective): " ++ show (extractObjectiveValue testResult)) + let msg = "\nThe following test failed: " + <> ("\nObjective Function (Non-prettified): " ++ show testObjective) + <> ("\nConstraints (Non-prettified): " ++ show testConstraints) + <> "\n====================================" + <> ("\nObjective Function (Prettified): " ++ prettyShowObjectiveFunction testObjective) + <> "\nConstraints (Prettified): " + <> "\n" <> concatMap (\c -> "\t" ++ prettyShowPolyConstraint c ++ "\n") testConstraints + <> "\n====================================" + <> ("\nExpected Solution (Full): " ++ show expectedResult) + <> ("\nActual Solution (Full): " ++ show testResult) + <> ("\nExpected Solution (Objective): " ++ show (extractObjectiveValue expectedResult)) + <> ("\nActual Solution (Objective): " ++ show (extractObjectiveValue testResult)) + <> "\n" + fail msg From 0bc9d61a83e6c58ede9679814b7ed29bfebcae5e Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 12 Aug 2023 17:38:46 +0100 Subject: [PATCH 12/47] Run formatter --- test/Spec.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/test/Spec.hs b/test/Spec.hs index 0fadfc6..2002aef 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -14,13 +14,15 @@ runTests (((testObjective, testConstraints), expectedResult) : tests) = in if testResult == expectedResult then runTests tests else do - let msg = "\nThe following test failed: " + let msg = + "\nThe following test failed: " <> ("\nObjective Function (Non-prettified): " ++ show testObjective) <> ("\nConstraints (Non-prettified): " ++ show testConstraints) <> "\n====================================" <> ("\nObjective Function (Prettified): " ++ prettyShowObjectiveFunction testObjective) <> "\nConstraints (Prettified): " - <> "\n" <> concatMap (\c -> "\t" ++ prettyShowPolyConstraint c ++ "\n") testConstraints + <> "\n" + <> concatMap (\c -> "\t" ++ prettyShowPolyConstraint c ++ "\n") testConstraints <> "\n====================================" <> ("\nExpected Solution (Full): " ++ show expectedResult) <> ("\nActual Solution (Full): " ++ show testResult) From de157590a1ffdb6c7fdea45337888e429124b794 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 12 Aug 2023 17:57:40 +0100 Subject: [PATCH 13/47] Fix broken tests + test10 was broken due to an LLM sneakily adding extra constraints and changing objective + testQuickCheck1/2 were broken because the constraints were built using `Map.fromList` with duplicate keys + only one of the key values were used, others were ignored --- test/TestFunctions.hs | 23 +++++++++-------------- 1 file changed, 9 insertions(+), 14 deletions(-) diff --git a/test/TestFunctions.hs b/test/TestFunctions.hs index 886a510..d228dd3 100644 --- a/test/TestFunctions.hs +++ b/test/TestFunctions.hs @@ -213,11 +213,10 @@ test9 = test10 :: (ObjectiveFunction, [PolyConstraint]) test10 = - ( Min (M.fromList [(1, 1), (2, 1), (3, 2), (4, 1)]) + ( Max (M.fromList [(1, 1), (2, 1), (3, 2), (4, 1)]) , [ EQ (M.fromList [(1, 1), (3, 2), (4, -2)]) 2 , EQ (M.fromList [(2, 1), (3, 1), (4, 4)]) 6 - , GEQ (M.fromList [(1, -1), (2, -1), (3, -2), (4, -1)]) (-2) ] ) @@ -993,30 +992,26 @@ testPolyPaverTwoFs8 = -- Test cases produced by old simplex-haskell/SoPlex QuickCheck prop --- SoPlex gives -400 for the following system but -370 is the optimized solution --- simplex-haskell gives -370 --- SoPlex gives -370 if we simplify the system before sending it to SoPlex testQuickCheck1 :: (ObjectiveFunction, [PolyConstraint]) testQuickCheck1 = - ( Max (M.fromList [(1, -6), (1, -8), (1, 9), (1, 10), (1, 8), (2, -15), (1, 13), (1, -14), (2, 0)]) + ( Max (M.fromList [(1, 12), (2, -15)]) , - [ EQ (M.fromList [(1, 5), (1, 6), (2, -2), (1, 7), (1, 6), (2, 0)]) (-12) - , GEQ (M.fromList [(1, 11), (1, 0), (1, -5), (1, -12), (1, -14), (2, 11)]) (-7) - , GEQ (M.fromList [(1, -12), (1, -7), (1, -2), (2, -9), (1, 3), (1, 5), (1, -15), (2, 14)]) (-8) - , GEQ (M.fromList [(1, 13), (1, 1), (1, -11), (2, 0)]) 5 - , LEQ (M.fromList [(1, -10), (1, -14), (1, 4), (1, -2), (1, -10), (1, -5), (1, -11)]) (-1) + [ EQ (M.fromList [(1, 24), (2, -2)]) (-12) + , GEQ (M.fromList [(1, -20), (2, 11)]) (-7) + , GEQ (M.fromList [(1, -28), (2, 5)]) (-8) + , GEQ (M.fromList [(1, 3), (2, 0)]) 5 + , LEQ (M.fromList [(1, -48)]) (-1) ] ) --- If we do not call simplifyPolyConstraints before we start the simplex algorithm, the following return a wrong solution -- Correct solution is -2/9 testQuickCheck2 :: (ObjectiveFunction, [PolyConstraint]) testQuickCheck2 = ( Max (M.fromList [(1, -3), (2, 5)]) , - [ LEQ (M.fromList [(2, -1), (1, -6), (2, 7)]) 4 + [ LEQ (M.fromList [(1, -6), (2, 6)]) 4 , LEQ (M.fromList [(1, 1), (2, -4), (3, 3)]) (-2) - , LEQ (M.fromList [(2, 6), (1, -4), (2, 1)]) 0 + , LEQ (M.fromList [(2, 7), (1, -4)]) 0 ] ) From c511b041ff2947e67245d2a645947e4f2aee2e26 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 12 Aug 2023 18:00:46 +0100 Subject: [PATCH 14/47] polishing --- src/Linear/Simplex/Simplex.hs | 126 ++++++------------------------- src/Linear/Simplex/Types.hs | 76 +------------------ src/Linear/Simplex/Util.hs | 135 +--------------------------------- 3 files changed, 28 insertions(+), 309 deletions(-) diff --git a/src/Linear/Simplex/Simplex.hs b/src/Linear/Simplex/Simplex.hs index 0995c6d..c07cfd7 100644 --- a/src/Linear/Simplex/Simplex.hs +++ b/src/Linear/Simplex/Simplex.hs @@ -26,7 +26,6 @@ import Linear.Simplex.Util import Prelude hiding (EQ) import qualified Data.Bifunctor as Bifunctor -import qualified Debug.Trace as T trace s a = a @@ -38,8 +37,7 @@ findFeasibleSolution :: [PolyConstraint] -> Maybe FeasibleSystem findFeasibleSolution unsimplifiedSystem = if null artificialVars -- No artificial vars, we have a feasible system then Just $ FeasibleSystem systemWithBasicVarsAsDictionary slackVars artificialVars objectiveVar - else -- else case simplexPivot (objectiveVar, artificialObjective ^. #objective) systemWithBasicVarsAsDictionary of - case simplexPivot artificialPivotObjective systemWithBasicVarsAsDictionary of + else case simplexPivot artificialPivotObjective systemWithBasicVarsAsDictionary of Just phase1Dict -> let eliminateArtificialVarsFromPhase1Tableau = M.map @@ -97,12 +95,6 @@ findFeasibleSolution unsimplifiedSystem = -- If a constraint is already EQ, set the basic var to Nothing. -- Final system is a list of equalities for the given system. -- To be feasible, all vars must be >= 0. - -- TODO: Maybe add equation type, and make this an equation - -- TODO: If we add an equation type, some other types should become aliases (e.g., TableauRow) - -- TODO: Proposed return type: ([(Maybe Var, PolyConstraint)], [Var]) - -- (I.e., Partial tableau with slack vars) - -- TODO: Look into an intermediary system type - -- Have a type level guarantee for slack vars with 1/-1 coeff systemInStandardForm :: [PolyConstraint] -> Var -> [Var] -> ([(Maybe Var, PolyConstraint)], [Var]) systemInStandardForm [] _ sVars = ([], sVars) systemInStandardForm (EQ v r : xs) maxVar sVars = ((Nothing, EQ v r) : newSystem, newSlackVars) @@ -155,25 +147,7 @@ findFeasibleSolution unsimplifiedSystem = (newSystemWithNewMaxVar, artificialVarsWithNewMaxVar) = systemWithArtificialVars pcs newArtificialVar (newSystemWithoutNewMaxVar, artificialVarsWithoutNewMaxVar) = systemWithArtificialVars pcs maxVar - systemWithArtificialVars _ _ = error "2" -- undefined - - -- phase1PivotObjective :: PivotObjective - -- phase1PivotObjective = - -- PivotObjective - -- { variable = objectiveVar - -- , function = if isMax objFunction then objFunction ^. #objective else M.map negate (objFunction ^. #objective) - -- , constants = M.empty - -- } - - -- Create an artificial objective using the given 'Integer' list of artificialVars and the given 'DictionaryForm'. - -- The artificial 'ObjectiveFunction' is the negated sum of all artificial vars. - -- createArtificialObjective :: DictionaryForm -> [Integer] -> ObjectiveFunction - -- createArtificialObjective rows artificialVars = Max negatedSumWithoutArtificialVars - -- where - -- rowsToAdd = filter (\(i, _) -> i `elem` artificialVars) rows - -- negatedRows = map (\(_, vcm) -> map (second negate) vcm) rowsToAdd - -- negatedSum = foldSumVarConstMap ((sort . concat) negatedRows) - -- negatedSumWithoutArtificialVars = filter (\(v, _) -> v `notElem` artificialVars) negatedSum + systemWithArtificialVars _ _ = error "systemWithArtificialVars: given system includes non-EQ constraints" createArtificialPivotObjective :: Dict -> [Var] -> PivotObjective createArtificialPivotObjective rows artificialVars = @@ -183,19 +157,10 @@ findFeasibleSolution unsimplifiedSystem = , constant = sum $ map (^. #constant) negatedRowsWithoutArtificialVars } where - -- test2 = foldr (+) 0 test - - -- test3 :: [Ratio Integer] - -- test3 = undefined - - -- test = map (^. #constant) negatedRowsWithoutArtificialVars -- Filter out non-artificial entries rowsToAdd = M.filterWithKey (\k _ -> k `elem` artificialVars) rows negatedRows = M.map (\(DictValue rowVarMapSum rowConstant) -> DictValue (M.map negate rowVarMapSum) (negate rowConstant)) rowsToAdd - -- negatedRowsSum = foldVarLitMap $ map $ M.toList (^. #varMapSum) negatedRows -- Negate rows, discard keys and artificial vars since the pivot objective does not care about them - -- negatedRowsMapSum = foldSumVarConstMap - -- negatedRowsConstSum = _ negatedRowsWithoutArtificialVars = map ( \(_, DictValue {..}) -> @@ -212,16 +177,12 @@ findFeasibleSolution unsimplifiedSystem = -- Returns a pair with the first item being the 'Integer' variable equal to the 'ObjectiveFunction' -- and the second item being a map of the values of all 'Integer' variables appearing in the system, including the 'ObjectiveFunction'. optimizeFeasibleSystem :: ObjectiveFunction -> FeasibleSystem -> Maybe Result -optimizeFeasibleSystem unsimplifiedObjFunction fsys@(FeasibleSystem {dict = phase1Dict, ..}) = - T.trace ("feasible system: " <> show fsys) $ +optimizeFeasibleSystem objFunction fsys@(FeasibleSystem {dict = phase1Dict, ..}) = + trace ("feasible system: " <> show fsys) $ if null artificialVars - then -- then displayResults . dictionaryFormToTableau <$> simplexPivot (createObjectiveDict objFunction objectiveVar : phase1Dict) - -- else displayResults . dictionaryFormToTableau <$> simplexPivot (createObjectiveDict phase2ObjFunction objectiveVar : tail phase1Dict) - T.trace "null" $ displayResults . dictionaryFormToTableau <$> simplexPivot phase1PivotObjective phase1Dict - else T.trace "notnull" $ displayResults . dictionaryFormToTableau <$> simplexPivot phase2PivotObjective phase1Dict + then trace "null" $ displayResults . dictionaryFormToTableau <$> simplexPivot phase1PivotObjective phase1Dict + else trace "notnull" $ displayResults . dictionaryFormToTableau <$> simplexPivot phase2PivotObjective phase1Dict where - objFunction = simplifyObjectiveFunction unsimplifiedObjFunction - displayResults :: Tableau -> Result displayResults tableau = Result @@ -260,7 +221,6 @@ optimizeFeasibleSystem unsimplifiedObjFunction fsys@(FeasibleSystem {dict = phas , constant = 0 } - -- TODO: New type for Phase2Objective phase2PivotObjective :: PivotObjective phase2PivotObjective = PivotObjective @@ -269,22 +229,6 @@ optimizeFeasibleSystem unsimplifiedObjFunction fsys@(FeasibleSystem {dict = phas , constant = calcConstants } where - -- type VarLitMapSum = M.Map Var SimplexNum - -- (foldSumVarConstMap . sort) $ - - -- combineMaps = - -- M.mapWithKey - -- (\var varValMap -> - -- case M.lookup var calcConstants of - -- Just constant -> - -- DictValue - -- { varMapSum = M.singleton var varValMap - -- , constant = constant - -- } - -- Nothing -> error "Bad branch" - -- ) - -- $ calcVarMap - calcConstants :: SimplexNum calcConstants = sum @@ -299,7 +243,6 @@ optimizeFeasibleSystem unsimplifiedObjFunction fsys@(FeasibleSystem {dict = phas calcVarMap :: VarLitMapSum calcVarMap = - -- M.fromList foldVarLitMap $ map ( M.fromList @@ -307,24 +250,12 @@ optimizeFeasibleSystem unsimplifiedObjFunction fsys@(FeasibleSystem {dict = phas let multiplyWith = if isMax objFunction then coeff else -coeff in case M.lookup var phase1Dict of Nothing -> - -- DictValue - -- { varMapSum = M.singleton var coeff - -- , constant = 0 - -- } [(var, multiplyWith)] Just row -> map (second (* multiplyWith)) (M.toList $ row ^. #varMapSum) - -- row - -- & #varMapSum %~ M.map (* coeff) - -- & #constant %~ (* coeff) -- TODO: Apply 0 - -- map (second (* coeff)) row ) ) (M.toList (objFunction ^. #objective)) --- phase2ObjFunction = --- undefined --- if isMax objFunction then Max phase2ObjectiveRow else Min phase2ObjectiveRow - -- | Perform the two phase simplex method with a given 'ObjectiveFunction' a system of 'PolyConstraint's. -- Assumes the 'ObjectiveFunction' and 'PolyConstraint' is not empty. -- Returns a pair with the first item being the 'Integer' variable equal to the 'ObjectiveFunction' @@ -333,38 +264,36 @@ twoPhaseSimplex :: ObjectiveFunction -> [PolyConstraint] -> Maybe Result twoPhaseSimplex objFunction unsimplifiedSystem = -- TODO: Distinguish between infeasible and unpotimisable case findFeasibleSolution unsimplifiedSystem of - Just feasibleSystem -> T.trace "feasible" optimizeFeasibleSystem objFunction feasibleSystem - Nothing -> T.trace "infeasible" Nothing + Just feasibleSystem -> trace "feasible" optimizeFeasibleSystem objFunction feasibleSystem + Nothing -> trace "infeasible" Nothing -- | Perform the simplex pivot algorithm on a system with basic vars, assume that the first row is the 'ObjectiveFunction'. simplexPivot :: PivotObjective -> Dict -> Maybe Dict simplexPivot objective@(PivotObjective {variable = objectiveVar, function = objectiveFunc, constant = objectiveConstant}) dictionary = - T.trace + trace ("obj: " <> show objective <> "\n" <> show dictionary) - T.trace - (show dictionary) $ case mostPositive objectiveFunc of Nothing -> - T.trace + trace "all neg \n" - T.trace + trace ("obj: " <> show objective <> "\n" <> show dictionary) - T.trace + trace (show dictionary) Just (insertPivotObjectiveToDict objective dictionary) Just pivotNonBasicVar -> let mPivotBasicVar = ratioTest dictionary pivotNonBasicVar Nothing Nothing - in T.trace ("most pos: " <> show pivotNonBasicVar) $ case mPivotBasicVar of - Nothing -> T.trace ("Ratio test failed on non-basic var: " ++ show pivotNonBasicVar ++ "\n" ++ show dictionary) Nothing + in trace ("most pos: " <> show pivotNonBasicVar) $ case mPivotBasicVar of + Nothing -> trace ("Ratio test failed on non-basic var: " ++ show pivotNonBasicVar ++ "\n" ++ show dictionary) Nothing Just pivotBasicVar -> let pivotResult = pivot pivotBasicVar pivotNonBasicVar (insertPivotObjectiveToDict objective dictionary) pivotedObj = let pivotedObjEntry = fromMaybe (error "Can't find obj after pivoting") $ M.lookup objectiveVar pivotResult in objective & #function .~ (pivotedObjEntry ^. #varMapSum) & #constant .~ (pivotedObjEntry ^. #constant) pivotedDict = M.delete objectiveVar pivotResult - in T.trace "one pos \n" $ - T.trace ("obj: " <> show objective <> "\n" <> show dictionary) $ + in trace "one pos \n" $ + trace ("obj: " <> show objective <> "\n" <> show dictionary) $ simplexPivot pivotedObj pivotedDict @@ -380,9 +309,7 @@ simplexPivot objective@(PivotObjective {variable = objectiveVar, function = obje Just currentCoeff -> let dictEquationConstant = dictEquation ^. #constant in if currentCoeff >= 0 || dictEquationConstant < 0 - then -- trace (show currentCoeff) - aux xs mostNegativeVar mCurrentMinBasicVar mCurrentMin -- constant was already in right side in original tableau, so should be above zero - -- Coeff needs to be negative since it has been moved to the RHS + then aux xs mostNegativeVar mCurrentMinBasicVar mCurrentMin else case mCurrentMin of Nothing -> aux xs mostNegativeVar (Just basicVar) (Just (dictEquationConstant / currentCoeff)) Just currentMin -> @@ -395,9 +322,9 @@ simplexPivot objective@(PivotObjective {variable = objectiveVar, function = obje case findLargestCoeff (M.toList varLitMap) Nothing of Just (largestVarName, largestVarCoeff) -> if largestVarCoeff <= 0 - then T.trace "negative" Nothing + then trace "negative" Nothing else Just largestVarName - Nothing -> T.trace "No variables in first row when looking for most positive" Nothing + Nothing -> trace "No variables in first row when looking for most positive" Nothing where findLargestCoeff :: [(Var, SimplexNum)] -> Maybe (Var, SimplexNum) -> Maybe (Var, SimplexNum) findLargestCoeff [] mCurrentMax = mCurrentMax @@ -417,7 +344,6 @@ simplexPivot objective@(PivotObjective {variable = objectiveVar, function = obje -- Expects each basic variable to not appear on the RHS of any equation. pivot :: Var -> Var -> Dict -> Dict pivot leavingVariable enteringVariable dict = - -- case basicRow ^. #equation ^? folded . filtered (\vt -> enteringVariable == vt ^. #name) of case M.lookup enteringVariable (dictEntertingRow ^. #varMapSum) of Just enteringVariableCoeff -> updatedRows @@ -445,19 +371,11 @@ simplexPivot objective@(PivotObjective {variable = objectiveVar, function = obje -- Substitute pivot equation into other rows updatedRows :: Dict updatedRows = - -- M.mapWithKey f dict M.fromList $ map (uncurry f2) $ M.toList dict where - -- Bifunctor.bimap f2 dict - - -- Dict - -- { objective = f $ dict ^. #objectiveFunction - -- , entries = fmap f $ dict ^. #entries - -- } - f entryVar entryVal = if leavingVariable == entryVar - then pivotEnteringRow -- TODO: UPDATE KEY + then pivotEnteringRow else case M.lookup enteringVariable (entryVal ^. #varMapSum) of Just subsCoeff -> entryVal @@ -472,7 +390,7 @@ simplexPivot objective@(PivotObjective {variable = objectiveVar, function = obje f2 :: Var -> DictValue -> (Var, DictValue) f2 entryVar entryVal = if leavingVariable == entryVar - then (enteringVariable, pivotEnteringRow) -- TODO: UPDATE KEY + then (enteringVariable, pivotEnteringRow) else case M.lookup enteringVariable (entryVal ^. #varMapSum) of Just subsCoeff -> ( entryVar @@ -494,6 +412,4 @@ simplexPivot objective@(PivotObjective {variable = objectiveVar, function = obje (error "pivot: Basic variable not found in Dict") $ M.lookup leavingVariable dict - -- basicDictEquation = basicDictEntry ^. #rhs - filterOutEnteringVarTerm = M.filterWithKey (\vName _ -> vName /= enteringVariable) diff --git a/src/Linear/Simplex/Types.hs b/src/Linear/Simplex/Types.hs index cccd57e..aa2c986 100644 --- a/src/Linear/Simplex/Types.hs +++ b/src/Linear/Simplex/Types.hs @@ -15,16 +15,13 @@ import GHC.Generics (Generic) type Var = Int --- TODO: Experiment with speed vs string vars type Var = Int --- TODO: Could also just use (Eq var => var) directly - type SimplexNum = Rational type SystemRow = PolyConstraint type System = [SystemRow] --- Basically, a tableau where the basic variable may be empty. +-- A 'Tableau' where the basic variable may be empty. -- All non-empty basic vars are slack vars data SystemWithSlackVarRow = SystemInStandardFormRow { mSlackVar :: Maybe Var @@ -34,17 +31,6 @@ data SystemWithSlackVarRow = SystemInStandardFormRow type SystemWithSlackVars = [SystemWithSlackVarRow] --- data SystemInStandardForm = SystemInStandardForm --- { mBasicVar :: Maybe Var} - --- type SystemInStandardForm - --- data VarTerm = VarTerm --- { name :: Var --- , coeff :: SimplexNum --- } --- deriving (Show, Read, Eq, Generic) - data FeasibleSystem = FeasibleSystem { dict :: Dict , slackVars :: [Var] @@ -71,27 +57,12 @@ data SimplexMeta = SimplexMeta type VarLitMap = M.Map Var SimplexNum --- TURN THIS INTO A FUNCTION --- instance Ord VarTerm where --- x <= y = (x ^. #name) <= (y ^. #name) - -- | List of variables with their 'SimplexNum' coefficients. -- There is an implicit addition between elements in this list. -- -- Example: [Var "x" 3, Var "y" -1, Var "z" 1] is equivalent to 3x + (-y) + z. type VarLitMapSum = VarLitMap --- type VarLitMapSum = [VarLitMapSumEntry] - --- data VarLitMapSumEntry = --- VarLitMapSumEntry --- { name :: Var --- , coeff :: SimplexNum --- } - --- TODO: newtype VarTermSum = VarTermSum [VarTerm] --- TODO: similar for other aliases - -- | For specifying constraints in a system. -- The LHS is a 'Vars', and the RHS, is a 'SimplexNum' number. -- LEQ [(1, 2), (2, 1)] 3.5 is equivalent to 2x1 + x2 <= 3.5. @@ -106,9 +77,6 @@ data PolyConstraint -- | Create an objective function. -- We can either 'Max'imize or 'Min'imize a 'VarTermSum'. --- TODO: Can the objective function contain a constant? --- It can, but it's not useful. We just care about minimising/maximising vars, --- not the actual value of the objective function data ObjectiveFunction = Max {objective :: VarLitMapSum} | Min {objective :: VarLitMapSum} deriving (Show, Read, Eq, Generic) -- | TODO: Maybe we want this type @@ -118,60 +86,24 @@ data Equation = Equation , rhs :: SimplexNum } --- | value for entry. lhs = rhs. TODO: finish +-- | Value for 'Tableau'. lhs = rhs. data TableauRow = TableauRow { lhs :: VarLitMapSum , rhs :: SimplexNum } deriving (Show, Read, Eq, Generic) --- | Entry for a simplex 'Tableau' of equations. --- The LHS' is a 'VarTermSum'. --- The RHS of the equation is a 'SimplexNum' constant. --- The LHS is equal to the RHS. --- type TableauRows = M.Map Var TableauRow - --- data TableauObjective = TableauObjective { basicVar :: Var, row :: TableauRow } deriving (Show, Read, Eq, Generic) - --- data TableauEntry = TableauEntry --- { basicVarName :: Var --- , lhs :: VarLitMapSum --- , rhs :: SimplexNum --- } --- deriving (Show, Read, Eq, Generic) - -- | A simplex 'Tableu' of equations. --- Each element in the list is a row. +-- Each entry in the map is a row. type Tableau = M.Map Var TableauRow --- data Tableau = Tableau --- { objective :: TableauObjective --- , rows :: TableauRows --- } --- deriving (Show, Read, Eq, Generic) - --- | Values for a 'DictEntry'. TODO: varMapSum + constant --- TODO: DictValue -> DictRow +-- | Values for a 'DictEntry'. data DictValue = DictValue { varMapSum :: VarLitMapSum , constant :: SimplexNum } deriving (Show, Read, Eq, Generic) --- | A single entry for a simplex `Dict`. --- The LHS is a `Var` and specifies a basic variable. --- The RHS is a 'DictEquation'. --- The LHS is equal to the RHS. --- type DictEntries = M.Map Var DictEntryValue - --- data DictObjective = DictObjective { lhs :: Var, rhs :: DictEntryValue } deriving (Show, Read, Eq, Generic) - --- data DictEntry = DictEntry --- { lhs :: Var --- , rhs :: DictEquation --- } --- deriving (Show, Read, Eq, Generic) - -- | A simplex 'Dict' -- One quation represents the objective function. -- Each pair in the list is one equation in the system we're working with. diff --git a/src/Linear/Simplex/Util.hs b/src/Linear/Simplex/Util.hs index 3751ac8..66656c8 100644 --- a/src/Linear/Simplex/Util.hs +++ b/src/Linear/Simplex/Util.hs @@ -29,7 +29,7 @@ isMax (Min _) = False -- then reducing 'LEQ' and 'GEQ' with same LHS and RHS (and other similar situations) into 'EQ', -- and finally removing duplicate elements using 'nub'. simplifySystem :: [PolyConstraint] -> [PolyConstraint] -simplifySystem = nub . reduceSystem . map simplifyPolyConstraint +simplifySystem = nub . reduceSystem where reduceSystem :: [PolyConstraint] -> [PolyConstraint] reduceSystem [] = [] @@ -73,78 +73,6 @@ simplifySystem = nub . reduceSystem . map simplifyPolyConstraint then EQ lhs rhs : reduceSystem pcs else EQ lhs rhs : reduceSystem (pcs \\ matchingConstraints) --- | Simplify an 'ObjectiveFunction' by first 'sort'ing and then calling 'foldSumVarConstMap' on the 'Vars'. -simplifyObjectiveFunction :: ObjectiveFunction -> ObjectiveFunction --- simplifyObjectiveFunction (Max vars) = Max (foldSumVarConstMap (sort vars)) --- simplifyObjectiveFunction (Min vars) = Min (foldSumVarConstMap (sort vars)) -simplifyObjectiveFunction (Max vars) = Max vars -simplifyObjectiveFunction (Min vars) = Min vars - --- | Simplify a 'PolyConstraint' by first 'sort'ing and then calling 'foldSumVarConstMap' on the 'Vars'. -simplifyPolyConstraint :: PolyConstraint -> PolyConstraint --- simplifyPolyConstraint (LEQ vars rhs) = LEQ (foldSumVarConstMap (sort vars)) rhs --- simplifyPolyConstraint (GEQ vars rhs) = GEQ (foldSumVarConstMap (sort vars)) rhs --- simplifyPolyConstraint (EQ vars rhs) = EQ (foldSumVarConstMap (sort vars)) rhs -simplifyPolyConstraint (LEQ vars rhs) = LEQ vars rhs -simplifyPolyConstraint (GEQ vars rhs) = GEQ vars rhs -simplifyPolyConstraint (EQ vars rhs) = EQ vars rhs - --- | Add a sorted list of 'Vars's, folding where the variables are equal --- foldSumVarConstMap :: VarLitMapSum -> VarLitMapSum --- foldSumVarConstMap [] = [] --- foldSumVarConstMap v@[_] = v --- foldSumVarConstMap (v1 : v2 : vcm) = --- if v1 == v2 --- then --- let c1 = v1 ^. #coeff --- c2 = v2 ^. #coeff --- newC = c1 + c2 --- in if newC == 0 --- then foldSumVarConstMap vcm --- else foldSumVarConstMap $ (v1 & #coeff .~ newC) : vcm --- else v1 : foldSumVarConstMap (v2 : vcm) - --- | Get a map of the value of every variable in a 'Tableau' --- displayTableauResults :: Tableau -> Map.Map Var SimplexNum --- displayTableauResults = Map.fromList . map (\entry -> (entry ^. #basicVarName, entry ^. #rhs)) - --- | Get a map of the value of every variable in a 'Dict' --- displayDictionaryResults :: Dict -> Map.Map Var SimplexNum --- displayDictionaryResults dict = displayTableauResults $ dictionaryFormToTableau dict - --- | Map the given 'Integer' variable to the given 'ObjectiveFunction', for entering into 'DictionaryForm'. --- createObjectiveDict :: ObjectiveFunction -> Var -> DictObjective --- createObjectiveDict (Max obj) objectiveVar = --- DictObjective --- { lhs = objectiveVar --- , rhs = --- DictEntryValue --- { varMapSum = obj --- , constant = 0 -- FIXME: was 1? prob should be 0 --- } --- } --- createObjectiveDict (Min obj) objectiveVar = --- DictObjective --- { lhs = objectiveVar --- , rhs = --- DictEntryValue --- { varMapSum = Map.map negate obj --- , constant = 0 -- FIXME: was 1? --- } --- } - --- data DictEntryValue = DictEntryValue --- { varMapSum :: VarLitMapSum --- , constant :: SimplexNum --- } --- deriving (Show, Read, Eq, Generic) - --- data TableauRowValue = TableauRowValue --- { lhs :: VarLitMapSum --- , rhs :: SimplexNum --- } --- deriving (Show, Read, Eq, Generic) - -- | Converts a 'Dict' to a 'Tableau' using 'dictEntryToTableauEntry'. -- FIXME: maybe remove this line. The basic variables will have a coefficient of 1 in the 'Tableau'. dictionaryFormToTableau :: Dict -> Tableau @@ -157,22 +85,7 @@ dictionaryFormToTableau = } ) --- { objective = --- let objecitveBasicVar = objective ^. #lhs --- objectiveRow = objective ^. #rhs --- in TableauObjective --- { basicVar = objecitveBasicVar --- , row = dictEntryValueToTableauRowValue objecitveBasicVar objectiveRow --- } --- , rows = Map.mapWithKey dictEntryValueToTableauRowValue entries --- } --- where --- \| Converts a 'DictEntry' to a 'TableauEntry'. --- This is done by moving all non-basic variables from the right to the left. --- The rational constant stays on the right. --- FIXME: check The basic variables will have a coefficient of 1 in the 'TableauEntry'. - --- | Converts a 'Tableau' to a 'Dict' using 'tableauEntryToDictEntry'. +-- | Converts a 'Tableau' to a 'Dict'. -- We do this by isolating the basic variable on the LHS, ending up with all non basic variables and a 'SimplexNum' constant on the RHS. tableauInDictionaryForm :: Tableau -> Dict tableauInDictionaryForm = @@ -188,33 +101,6 @@ tableauInDictionaryForm = } ) --- Dict --- { objective = --- let objecitveBasicVar = objective ^. #basicVar --- objectiveRow = objective ^. #row --- in DictObjective --- { lhs = objecitveBasicVar --- , rhs = tableauRowValueToDictEntryValue objecitveBasicVar objectiveRow --- } --- , entries = Map.mapWithKey tableauRowValueToDictEntryValue rows --- } --- where --- -- \| Converts a 'Tableau' to a 'Dict'. --- -- We do this by isolating the basic variable on the LHS, ending up with all non basic variables and a 'SimplexNum' constant on the RHS. --- -- FIXME: check The basic variables will have a coefficient of 1 in the 'DictEntry'. --- tableauRowValueToDictEntryValue :: Var -> TableauRow -> DictEntryValue --- tableauRowValueToDictEntryValue basicVarName (TableauRow {..}) = --- DictEntryValue --- { varMapSum = --- Map.map --- (\c -> negate c / basicVarCoeff) --- $ Map.delete basicVarName lhs --- , constant = rhs / basicVarCoeff --- } --- where --- mBasicVarCoeff = Map.lookup basicVarName lhs --- basicVarCoeff = fromMaybe 1 mBasicVarCoeff - -- | If this function is given 'Nothing', return 'Nothing'. -- Otherwise, we 'lookup' the 'Integer' given in the first item of the pair in the map given in the second item of the pair. -- This is typically used to extract the value of the 'ObjectiveFunction' after calling 'Linear.Simplex.Simplex.twoPhaseSimplex'. @@ -235,19 +121,6 @@ combineVarLitMapSums = keepVal = const pure sumVals k v1 v2 = Just $ v1 + v2 --- -- | Apply a function to the objective function and another to each entry in a --- -- 'Dict' --- applyDict :: (DictEntries -> DictEntries) -> (DictEntries -> DictEntries) -> Dict -> Dict --- applyDict fObj fDict (Dict {..}) = --- Dict --- { objective = fObj objectiveFunction --- , entries = fmap fDict entries --- } - --- -- Apply a single function to all entries in a 'Dict', including the objective function --- applyDictSimple :: (DictEntries -> DictEntries) -> Dict -> Dict --- applyDictSimple f = applyDict f f - foldDictValue :: [DictValue] -> DictValue foldDictValue [] = error "Empty list of DictValues given to foldDictValue" foldDictValue [x] = x @@ -259,8 +132,6 @@ foldDictValue (DictValue {varMapSum = vm1, constant = c1} : DictValue {varMapSum } in foldDictValue $ combinedDictValue : dvs --- type VarLitMap = M.Map Var SimplexNum - foldVarLitMap :: [VarLitMap] -> VarLitMap foldVarLitMap [] = error "Empty list of VarLitMaps given to foldVarLitMap" foldVarLitMap [x] = x @@ -285,4 +156,4 @@ foldVarLitMap (vm1 : vm2 : vms) = in foldVarLitMap $ combinedVarMap : vms insertPivotObjectiveToDict :: PivotObjective -> Dict -> Dict -insertPivotObjectiveToDict objective dict = Map.insert (objective.variable) (DictValue {varMapSum = objective.function, constant = objective.constant}) dict +insertPivotObjectiveToDict objective = Map.insert (objective.variable) (DictValue {varMapSum = objective.function, constant = objective.constant}) From eeed31c5bcf0c39f235f2bfb497d0e1c5781e932 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 12 Aug 2023 18:03:53 +0100 Subject: [PATCH 15/47] Lens getters -> RecordDot getters --- src/Linear/Simplex/Simplex.hs | 46 +++++++++++++++++------------------ src/Linear/Simplex/Util.hs | 2 +- 2 files changed, 24 insertions(+), 24 deletions(-) diff --git a/src/Linear/Simplex/Simplex.hs b/src/Linear/Simplex/Simplex.hs index c07cfd7..9365c65 100644 --- a/src/Linear/Simplex/Simplex.hs +++ b/src/Linear/Simplex/Simplex.hs @@ -51,7 +51,7 @@ findFeasibleSolution unsimplifiedSystem = in case M.lookup objectiveVar eliminateArtificialVarsFromPhase1Tableau of Nothing -> trace "objective row not found in phase 1 tableau" Nothing -- Should this be an error? Just row -> - if row ^. #constant == 0 + if row.constant == 0 then Just $ FeasibleSystem @@ -153,8 +153,8 @@ findFeasibleSolution unsimplifiedSystem = createArtificialPivotObjective rows artificialVars = PivotObjective { variable = objectiveVar - , function = foldVarLitMap $ map (^. #varMapSum) negatedRowsWithoutArtificialVars - , constant = sum $ map (^. #constant) negatedRowsWithoutArtificialVars + , function = foldVarLitMap $ map (.varMapSum) negatedRowsWithoutArtificialVars + , constant = sum $ map (.constant) negatedRowsWithoutArtificialVars } where -- Filter out non-artificial entries @@ -201,15 +201,15 @@ optimizeFeasibleSystem objFunction fsys@(FeasibleSystem {dict = phase1Dict, ..}) Max _ -> M.map ( \tableauRow -> - tableauRow ^. #rhs + tableauRow.rhs ) tableauWithOriginalVars Min _ -> M.mapWithKey -- We maximized -objVar, so we negate the objVar to get the final value ( \basicVarName tableauRow -> if basicVarName == objectiveVar - then negate $ tableauRow ^. #rhs - else tableauRow ^. #rhs + then negate $ tableauRow.rhs + else tableauRow.rhs ) tableauWithOriginalVars @@ -217,7 +217,7 @@ optimizeFeasibleSystem objFunction fsys@(FeasibleSystem {dict = phase1Dict, ..}) phase1PivotObjective = PivotObjective { variable = objectiveVar - , function = if isMax objFunction then objFunction ^. #objective else M.map negate (objFunction ^. #objective) + , function = if isMax objFunction then objFunction.objective else M.map negate (objFunction.objective) , constant = 0 } @@ -237,9 +237,9 @@ optimizeFeasibleSystem objFunction fsys@(FeasibleSystem {dict = phase1Dict, ..}) let multiplyWith = if isMax objFunction then coeff else -coeff in case M.lookup var phase1Dict of Nothing -> 0 - Just row -> (row ^. #constant) * multiplyWith + Just row -> (row.constant) * multiplyWith ) - $ M.toList (objFunction ^. #objective) + $ M.toList (objFunction.objective) calcVarMap :: VarLitMapSum calcVarMap = @@ -251,10 +251,10 @@ optimizeFeasibleSystem objFunction fsys@(FeasibleSystem {dict = phase1Dict, ..}) in case M.lookup var phase1Dict of Nothing -> [(var, multiplyWith)] - Just row -> map (second (* multiplyWith)) (M.toList $ row ^. #varMapSum) + Just row -> map (second (* multiplyWith)) (M.toList $ row.varMapSum) ) ) - (M.toList (objFunction ^. #objective)) + (M.toList (objFunction.objective)) -- | Perform the two phase simplex method with a given 'ObjectiveFunction' a system of 'PolyConstraint's. -- Assumes the 'ObjectiveFunction' and 'PolyConstraint' is not empty. @@ -290,7 +290,7 @@ simplexPivot objective@(PivotObjective {variable = objectiveVar, function = obje let pivotResult = pivot pivotBasicVar pivotNonBasicVar (insertPivotObjectiveToDict objective dictionary) pivotedObj = let pivotedObjEntry = fromMaybe (error "Can't find obj after pivoting") $ M.lookup objectiveVar pivotResult - in objective & #function .~ (pivotedObjEntry ^. #varMapSum) & #constant .~ (pivotedObjEntry ^. #constant) + in objective & #function .~ (pivotedObjEntry.varMapSum) & #constant .~ (pivotedObjEntry.constant) pivotedDict = M.delete objectiveVar pivotResult in trace "one pos \n" $ trace ("obj: " <> show objective <> "\n" <> show dictionary) $ @@ -304,10 +304,10 @@ simplexPivot objective@(PivotObjective {variable = objectiveVar, function = obje aux :: [(Var, DictValue)] -> Var -> Maybe Var -> Maybe Rational -> Maybe Var aux [] _ mCurrentMinBasicVar _ = mCurrentMinBasicVar aux (x@(basicVar, dictEquation) : xs) mostNegativeVar mCurrentMinBasicVar mCurrentMin = - case M.lookup mostNegativeVar (dictEquation ^. #varMapSum) of + case M.lookup mostNegativeVar (dictEquation.varMapSum) of Nothing -> aux xs mostNegativeVar mCurrentMinBasicVar mCurrentMin Just currentCoeff -> - let dictEquationConstant = dictEquation ^. #constant + let dictEquationConstant = dictEquation.constant in if currentCoeff >= 0 || dictEquationConstant < 0 then aux xs mostNegativeVar mCurrentMinBasicVar mCurrentMin else case mCurrentMin of @@ -344,7 +344,7 @@ simplexPivot objective@(PivotObjective {variable = objectiveVar, function = obje -- Expects each basic variable to not appear on the RHS of any equation. pivot :: Var -> Var -> Dict -> Dict pivot leavingVariable enteringVariable dict = - case M.lookup enteringVariable (dictEntertingRow ^. #varMapSum) of + case M.lookup enteringVariable (dictEntertingRow.varMapSum) of Just enteringVariableCoeff -> updatedRows where @@ -376,31 +376,31 @@ simplexPivot objective@(PivotObjective {variable = objectiveVar, function = obje f entryVar entryVal = if leavingVariable == entryVar then pivotEnteringRow - else case M.lookup enteringVariable (entryVal ^. #varMapSum) of + else case M.lookup enteringVariable (entryVal.varMapSum) of Just subsCoeff -> entryVal & #varMapSum .~ combineVarLitMapSums - (pivotEnteringRow ^. #varMapSum <&> (subsCoeff *)) - (filterOutEnteringVarTerm (entryVal ^. #varMapSum)) + (pivotEnteringRow.varMapSum <&> (subsCoeff *)) + (filterOutEnteringVarTerm (entryVal.varMapSum)) & #constant - .~ ((subsCoeff * (pivotEnteringRow ^. #constant)) + entryVal ^. #constant) + .~ ((subsCoeff * (pivotEnteringRow.constant)) + entryVal.constant) Nothing -> entryVal f2 :: Var -> DictValue -> (Var, DictValue) f2 entryVar entryVal = if leavingVariable == entryVar then (enteringVariable, pivotEnteringRow) - else case M.lookup enteringVariable (entryVal ^. #varMapSum) of + else case M.lookup enteringVariable (entryVal.varMapSum) of Just subsCoeff -> ( entryVar , entryVal & #varMapSum .~ combineVarLitMapSums - (pivotEnteringRow ^. #varMapSum <&> (subsCoeff *)) - (filterOutEnteringVarTerm (entryVal ^. #varMapSum)) + (pivotEnteringRow.varMapSum <&> (subsCoeff *)) + (filterOutEnteringVarTerm (entryVal.varMapSum)) & #constant - .~ ((subsCoeff * (pivotEnteringRow ^. #constant)) + entryVal ^. #constant) + .~ ((subsCoeff * (pivotEnteringRow.constant)) + entryVal.constant) ) Nothing -> (entryVar, entryVal) Nothing -> error "pivot: non basic variable not found in basic row" diff --git a/src/Linear/Simplex/Util.hs b/src/Linear/Simplex/Util.hs index 66656c8..5cf288d 100644 --- a/src/Linear/Simplex/Util.hs +++ b/src/Linear/Simplex/Util.hs @@ -106,7 +106,7 @@ tableauInDictionaryForm = -- This is typically used to extract the value of the 'ObjectiveFunction' after calling 'Linear.Simplex.Simplex.twoPhaseSimplex'. extractObjectiveValue :: Maybe Result -> Maybe SimplexNum extractObjectiveValue = fmap $ \result -> - case Map.lookup (result ^. #objectiveVar) (result ^. #varValMap) of + case Map.lookup result.objectiveVar result.varValMap of Nothing -> error "Objective not found in results when extracting objective value" Just r -> r From 5b8327dfc456f5469ecf43f13e10c7cc061ba22d Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 9 Sep 2023 15:20:46 +0100 Subject: [PATCH 16/47] Add logging, improve docs, more tests, handle edge cases + Control.Monad.Logger used for logging + Documented various functions + Handled some edge cases which shouldn't be possible (and log warnings/errors when we reach these edge cases) --- package.yaml | 12 +- simplex-method.cabal | 14 +- src/Linear/Simplex/Simplex.hs | 252 ++++++++++++++++++++++------------ src/Linear/Simplex/Util.hs | 21 ++- stack.yaml | 2 +- stack.yaml.lock | 8 +- test/Spec.hs | 54 +++++--- test/TestFunctions.hs | 20 +++ 8 files changed, 260 insertions(+), 123 deletions(-) diff --git a/package.yaml b/package.yaml index 4907887..ac7e09b 100644 --- a/package.yaml +++ b/package.yaml @@ -23,23 +23,27 @@ dependencies: - base >= 4.14 && < 5 - containers >= 0.6.5.1 && < 0.7 - generic-lens >= 2.2.0 && < 2.3 -- lens >= 5.1.0 && < 5.2 +- lens >= 5.2.2 && < 5.3 +- monad-logger >= 0.3.40 && < 0.4 +- text >= 2.0.2 && < 2.1 +- time default-extensions: DataKinds DeriveFunctor DeriveGeneric + DisambiguateRecordFields DuplicateRecordFields FlexibleContexts LambdaCase OverloadedLabels + OverloadedRecordDot + OverloadedStrings RecordWildCards + TemplateHaskell TupleSections TypeApplications - OverloadedRecordDot - DuplicateRecordFields NamedFieldPuns - DisambiguateRecordFields library: source-dirs: src diff --git a/simplex-method.cabal b/simplex-method.cabal index dd726c3..843d28c 100644 --- a/simplex-method.cabal +++ b/simplex-method.cabal @@ -36,12 +36,15 @@ library hs-source-dirs: src default-extensions: - DataKinds DeriveFunctor DeriveGeneric DuplicateRecordFields FlexibleContexts LambdaCase OverloadedLabels RecordWildCards TupleSections TypeApplications OverloadedRecordDot DuplicateRecordFields NamedFieldPuns DisambiguateRecordFields + DataKinds DeriveFunctor DeriveGeneric DisambiguateRecordFields DuplicateRecordFields FlexibleContexts LambdaCase OverloadedLabels OverloadedRecordDot OverloadedStrings RecordWildCards TemplateHaskell TupleSections TypeApplications NamedFieldPuns build-depends: base >=4.14 && <5 , containers >=0.6.5.1 && <0.7 , generic-lens >=2.2.0 && <2.3 - , lens >=5.1.0 && <5.2 + , lens >=5.2.2 && <5.3 + , monad-logger >=0.3.40 && <0.4 + , text >=2.0.2 && <2.1 + , time default-language: Haskell2010 test-suite simplex-haskell-test @@ -53,11 +56,14 @@ test-suite simplex-haskell-test hs-source-dirs: test default-extensions: - DataKinds DeriveFunctor DeriveGeneric DuplicateRecordFields FlexibleContexts LambdaCase OverloadedLabels RecordWildCards TupleSections TypeApplications OverloadedRecordDot DuplicateRecordFields NamedFieldPuns DisambiguateRecordFields + DataKinds DeriveFunctor DeriveGeneric DisambiguateRecordFields DuplicateRecordFields FlexibleContexts LambdaCase OverloadedLabels OverloadedRecordDot OverloadedStrings RecordWildCards TemplateHaskell TupleSections TypeApplications NamedFieldPuns build-depends: base >=4.14 && <5 , containers >=0.6.5.1 && <0.7 , generic-lens >=2.2.0 && <2.3 - , lens >=5.1.0 && <5.2 + , lens >=5.2.2 && <5.3 + , monad-logger >=0.3.40 && <0.4 , simplex-method + , text >=2.0.2 && <2.1 + , time default-language: Haskell2010 diff --git a/src/Linear/Simplex/Simplex.hs b/src/Linear/Simplex/Simplex.hs index 9365c65..6363413 100644 --- a/src/Linear/Simplex/Simplex.hs +++ b/src/Linear/Simplex/Simplex.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} - -- | -- Module : Linear.Simplex.Simplex -- Description : Implements the twoPhaseSimplex method @@ -14,54 +12,90 @@ -- 'twoPhaseSimplex' performs both phases of the two-phase simplex method. module Linear.Simplex.Simplex (findFeasibleSolution, optimizeFeasibleSystem, twoPhaseSimplex) where +import Prelude hiding (EQ) + import Control.Lens +import Control.Monad (unless) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Logger import Data.Bifunctor import Data.List import qualified Data.Map as M import Data.Maybe (fromJust, fromMaybe, mapMaybe) import Data.Ratio (denominator, numerator, (%)) +import qualified Data.Text as Text import GHC.Real (Ratio) import Linear.Simplex.Types import Linear.Simplex.Util -import Prelude hiding (EQ) - -import qualified Data.Bifunctor as Bifunctor - -trace s a = a -- | Find a feasible solution for the given system of 'PolyConstraint's by performing the first phase of the two-phase simplex method --- All 'Integer' variables in the 'PolyConstraint' must be positive. +-- All variables in the 'PolyConstraint' must be positive. -- If the system is infeasible, return 'Nothing' -- Otherwise, return the feasible system in 'Dict' as well as a list of slack variables, a list artificial variables, and the objective variable. -findFeasibleSolution :: [PolyConstraint] -> Maybe FeasibleSystem -findFeasibleSolution unsimplifiedSystem = +findFeasibleSolution :: (MonadIO m, MonadLogger m) => [PolyConstraint] -> m (Maybe FeasibleSystem) +findFeasibleSolution unsimplifiedSystem = do + logMsg LevelInfo $ "findFeasibleSolution: Looking for solution for " <> showT unsimplifiedSystem if null artificialVars -- No artificial vars, we have a feasible system - then Just $ FeasibleSystem systemWithBasicVarsAsDictionary slackVars artificialVars objectiveVar - else case simplexPivot artificialPivotObjective systemWithBasicVarsAsDictionary of - Just phase1Dict -> - let eliminateArtificialVarsFromPhase1Tableau = - M.map - ( \DictValue {..} -> - DictValue - { varMapSum = M.filterWithKey (\k _ -> k `notElem` artificialVars) varMapSum - , .. - } - ) - phase1Dict - in case M.lookup objectiveVar eliminateArtificialVarsFromPhase1Tableau of - Nothing -> trace "objective row not found in phase 1 tableau" Nothing -- Should this be an error? - Just row -> - if row.constant == 0 - then - Just $ - FeasibleSystem - { dict = eliminateArtificialVarsFromPhase1Tableau - , slackVars = slackVars - , artificialVars = artificialVars - , objectiveVar = objectiveVar + then do + logMsg LevelInfo "findFeasibleSolution: Feasible solution found with no artificial vars" + pure . Just $ FeasibleSystem systemWithBasicVarsAsDictionary slackVars artificialVars objectiveVar + else do + logMsg LevelInfo $ "findFeasibleSolution: Needed to create artificial vars. System with artificial vars (in Tableau form) = " <> showT systemWithBasicVars + mPhase1Dict <- simplexPivot artificialPivotObjective systemWithBasicVarsAsDictionary + case mPhase1Dict of + Just phase1Dict -> do + logMsg LevelInfo $ "findFeasibleSolution: System after pivoting with objective" <> showT artificialPivotObjective <> ": " <> showT phase1Dict + let eliminateArtificialVarsFromPhase1Tableau = + M.map + ( \DictValue {..} -> + DictValue + { varMapSum = M.filterWithKey (\k _ -> k `notElem` artificialVars) varMapSum + , .. } - else trace "rhs not zero after phase 1, thus original tableau is infeasible" Nothing - Nothing -> Nothing + ) + phase1Dict + case M.lookup objectiveVar eliminateArtificialVarsFromPhase1Tableau of + Nothing -> do + logMsg LevelWarn $ "findFeasibleSolution: Objective row not found after eliminatiing artificial vars. This is unexpected. System without artificial vars (in Dict form) = " <> showT eliminateArtificialVarsFromPhase1Tableau + -- If the objecitve row is not found, the system is feasible iff + -- the artificial vars sum to zero. The value of an artificial + -- variable is 0 if non-basic, and the RHS of the row if basic + let artificialVarsVals = map (\v -> maybe 0 (.constant) (M.lookup v eliminateArtificialVarsFromPhase1Tableau)) artificialVars + let artificialVarsValsSum = sum artificialVarsVals + if artificialVarsValsSum == 0 + then do + logMsg LevelInfo $ "findFeasibleSolution: Artifical variables sum up to 0, thus original tableau is feasible. System without artificial vars (in Dict form) = " <> showT eliminateArtificialVarsFromPhase1Tableau + pure . Just $ + FeasibleSystem + { dict = eliminateArtificialVarsFromPhase1Tableau + , slackVars = slackVars + , artificialVars = artificialVars + , objectiveVar = objectiveVar + } + else do + logMsg LevelInfo $ "findFeasibleSolution: Artifical variables sum up to " <> showT artificialVarsValsSum <> ", thus original tableau is infeasible. System without artificial vars (in Dict form) = " <> showT eliminateArtificialVarsFromPhase1Tableau + pure Nothing + Just row -> + if row.constant == 0 + then do + logMsg LevelInfo $ "findFeasibleSolution: Objective RHS is zero after pivoting, thus original tableau is feasible. feasible system (in Dict form) = " <> showT eliminateArtificialVarsFromPhase1Tableau + pure . Just $ + FeasibleSystem + { dict = eliminateArtificialVarsFromPhase1Tableau + , slackVars = slackVars + , artificialVars = artificialVars + , objectiveVar = objectiveVar + } + else do + unless (row.constant < 0) $ do + let errMsg = "findFeasibleSolution: Objective RHS is negative after pivoting. This should be impossible. System without artificial vars (in Dict form) = " <> show eliminateArtificialVarsFromPhase1Tableau + logMsg LevelError $ Text.pack errMsg + error errMsg + logMsg LevelInfo $ "findFeasibleSolution: Objective RHS not zero after phase 1, thus original tableau is infeasible. System without artificial vars (in Dict form) = " <> showT eliminateArtificialVarsFromPhase1Tableau + pure Nothing + Nothing -> do + logMsg LevelInfo $ "findFeasibleSolution: Infeasible solution found, could not pivot with objective " <> showT artificialPivotObjective <> " over system (in Dict form) = " <> showT systemWithBasicVarsAsDictionary + pure Nothing where system = simplifySystem unsimplifiedSystem @@ -149,6 +183,13 @@ findFeasibleSolution unsimplifiedSystem = (newSystemWithoutNewMaxVar, artificialVarsWithoutNewMaxVar) = systemWithArtificialVars pcs maxVar systemWithArtificialVars _ _ = error "systemWithArtificialVars: given system includes non-EQ constraints" + -- \| Takes a 'Dict' and a '[Var]' as input and returns a 'PivotObjective'. + -- The 'Dict' represents the tableau of a linear program with artificial + -- variables, and '[Var]' represents the artificial variables. + + -- The function first filters out the rows of the tableau that correspond + -- to the artificial variables, and negates them. It then computes the sum + -- of the negated rows, which represents the 'PivotObjective'. createArtificialPivotObjective :: Dict -> [Var] -> PivotObjective createArtificialPivotObjective rows artificialVars = PivotObjective @@ -176,13 +217,31 @@ findFeasibleSolution unsimplifiedSystem = -- Then, the feasible system in 'DictionaryForm' as well as a list of slack variables, a list artificial variables, and the objective variable. -- Returns a pair with the first item being the 'Integer' variable equal to the 'ObjectiveFunction' -- and the second item being a map of the values of all 'Integer' variables appearing in the system, including the 'ObjectiveFunction'. -optimizeFeasibleSystem :: ObjectiveFunction -> FeasibleSystem -> Maybe Result -optimizeFeasibleSystem objFunction fsys@(FeasibleSystem {dict = phase1Dict, ..}) = - trace ("feasible system: " <> show fsys) $ - if null artificialVars - then trace "null" $ displayResults . dictionaryFormToTableau <$> simplexPivot phase1PivotObjective phase1Dict - else trace "notnull" $ displayResults . dictionaryFormToTableau <$> simplexPivot phase2PivotObjective phase1Dict +optimizeFeasibleSystem :: (MonadIO m, MonadLogger m) => ObjectiveFunction -> FeasibleSystem -> m (Maybe Result) +optimizeFeasibleSystem objFunction fsys@(FeasibleSystem {dict = phase1Dict, ..}) = do + logMsg LevelInfo $ "optimizeFeasibleSystem: Optimizing feasible system " <> showT fsys <> " with objective " <> showT objFunction + if null artificialVars + then do + logMsg LevelInfo $ "optimizeFeasibleSystem: No artificial vars, system is feasible. Pivoting system (in dict form) " <> showT phase1Dict <> " with objective " <> showT normalObjective + fmap (displayResults . dictionaryFormToTableau) <$> simplexPivot normalObjective phase1Dict + else do + logMsg LevelInfo $ "optimizeFeasibleSystem: Artificial vars present. Pivoting system (in dict form) " <> showT phase1Dict <> " with objective " <> showT adjustedObjective + fmap (displayResults . dictionaryFormToTableau) <$> simplexPivot adjustedObjective phase1Dict where + -- \| displayResults takes a 'Tableau' and returns a 'Result'. The 'Tableau' + -- represents the final tableau of a linear program after the simplex + -- algorithm has been applied. The 'Result' contains the value of the + -- objective variable and a map of the values of all variables appearing + -- in the system, including the objective variable. + -- + -- The function first filters out the rows of the tableau that correspond + -- to the slack and artificial variables. It then extracts the values of + -- the remaining variables and stores them in a map. If the objective + -- function is a maximization problem, the map contains the values of the + -- variables as they appear in the final tableau. If the objective function + -- is a minimization problem, the map contains the values of the variables + -- as they appear in the final tableau, except for the objective variable, + -- which is negated. displayResults :: Tableau -> Result displayResults tableau = Result @@ -213,22 +272,34 @@ optimizeFeasibleSystem objFunction fsys@(FeasibleSystem {dict = phase1Dict, ..}) ) tableauWithOriginalVars - phase1PivotObjective :: PivotObjective - phase1PivotObjective = + -- \| Objective to use when optimising the linear program if no artificial + -- variables were necessary in the first phase. It is essentially the original + -- objective function, with a potential change of sign based on the type of + -- problem (Maximization or Minimization). + normalObjective :: PivotObjective + normalObjective = PivotObjective { variable = objectiveVar - , function = if isMax objFunction then objFunction.objective else M.map negate (objFunction.objective) + , function = if isMax objFunction then objFunction.objective else M.map negate objFunction.objective , constant = 0 } - phase2PivotObjective :: PivotObjective - phase2PivotObjective = + -- \| Objective to use when optimising the linear program if artificial + -- variables were necessary in the first phase. It is an adjustment to the + -- original objective function, where the linear coefficients are modified + -- by back-substitution of the values of the artificial variables. + adjustedObjective :: PivotObjective + adjustedObjective = PivotObjective { variable = objectiveVar , function = calcVarMap , constant = calcConstants } where + -- \| Compute the adjustment to the constant term of the objective + -- function. It adds up the products of the original coefficients and + -- the corresponding constant term (rhs) of each artificial variable + -- in the phase 1 'Dict'. calcConstants :: SimplexNum calcConstants = sum @@ -237,10 +308,14 @@ optimizeFeasibleSystem objFunction fsys@(FeasibleSystem {dict = phase1Dict, ..}) let multiplyWith = if isMax objFunction then coeff else -coeff in case M.lookup var phase1Dict of Nothing -> 0 - Just row -> (row.constant) * multiplyWith + Just row -> row.constant * multiplyWith ) - $ M.toList (objFunction.objective) + $ M.toList objFunction.objective + -- \| Compute the adjustment to the coefficients of the original + -- variables in the objective function. It performs back-substitution + -- of the variables in the original objective function using the + -- current value of each artificial variable in the phase 1 'Dict'. calcVarMap :: VarLitMapSum calcVarMap = foldVarLitMap $ @@ -254,49 +329,52 @@ optimizeFeasibleSystem objFunction fsys@(FeasibleSystem {dict = phase1Dict, ..}) Just row -> map (second (* multiplyWith)) (M.toList $ row.varMapSum) ) ) - (M.toList (objFunction.objective)) + (M.toList objFunction.objective) -- | Perform the two phase simplex method with a given 'ObjectiveFunction' a system of 'PolyConstraint's. -- Assumes the 'ObjectiveFunction' and 'PolyConstraint' is not empty. -- Returns a pair with the first item being the 'Integer' variable equal to the 'ObjectiveFunction' -- and the second item being a map of the values of all 'Integer' variables appearing in the system, including the 'ObjectiveFunction'. -twoPhaseSimplex :: ObjectiveFunction -> [PolyConstraint] -> Maybe Result -twoPhaseSimplex objFunction unsimplifiedSystem = - -- TODO: Distinguish between infeasible and unpotimisable - case findFeasibleSolution unsimplifiedSystem of - Just feasibleSystem -> trace "feasible" optimizeFeasibleSystem objFunction feasibleSystem - Nothing -> trace "infeasible" Nothing +twoPhaseSimplex :: (MonadIO m, MonadLogger m) => ObjectiveFunction -> [PolyConstraint] -> m (Maybe Result) +twoPhaseSimplex objFunction unsimplifiedSystem = do + logMsg LevelInfo $ "twoPhaseSimplex: Solving system " <> showT unsimplifiedSystem <> " with objective " <> showT objFunction + phase1Result <- findFeasibleSolution unsimplifiedSystem + case phase1Result of + Just feasibleSystem -> do + logMsg LevelInfo $ "twoPhaseSimplex: Feasible system found for " <> showT unsimplifiedSystem <> "; Feasible system: " <> showT feasibleSystem + optimizedSystem <- optimizeFeasibleSystem objFunction feasibleSystem + logMsg LevelInfo $ "twoPhaseSimplex: Optimized system found for " <> showT unsimplifiedSystem <> "; Optimized system: " <> showT optimizedSystem + pure optimizedSystem + Nothing -> do + logMsg LevelInfo $ "twoPhaseSimplex: Phase 1 gives infeasible result for " <> showT unsimplifiedSystem + pure Nothing -- | Perform the simplex pivot algorithm on a system with basic vars, assume that the first row is the 'ObjectiveFunction'. -simplexPivot :: PivotObjective -> Dict -> Maybe Dict -simplexPivot objective@(PivotObjective {variable = objectiveVar, function = objectiveFunc, constant = objectiveConstant}) dictionary = - trace - ("obj: " <> show objective <> "\n" <> show dictionary) - $ case mostPositive objectiveFunc of - Nothing -> - trace - "all neg \n" - trace - ("obj: " <> show objective <> "\n" <> show dictionary) - trace - (show dictionary) - Just - (insertPivotObjectiveToDict objective dictionary) - Just pivotNonBasicVar -> - let mPivotBasicVar = ratioTest dictionary pivotNonBasicVar Nothing Nothing - in trace ("most pos: " <> show pivotNonBasicVar) $ case mPivotBasicVar of - Nothing -> trace ("Ratio test failed on non-basic var: " ++ show pivotNonBasicVar ++ "\n" ++ show dictionary) Nothing - Just pivotBasicVar -> - let pivotResult = pivot pivotBasicVar pivotNonBasicVar (insertPivotObjectiveToDict objective dictionary) - pivotedObj = - let pivotedObjEntry = fromMaybe (error "Can't find obj after pivoting") $ M.lookup objectiveVar pivotResult - in objective & #function .~ (pivotedObjEntry.varMapSum) & #constant .~ (pivotedObjEntry.constant) - pivotedDict = M.delete objectiveVar pivotResult - in trace "one pos \n" $ - trace ("obj: " <> show objective <> "\n" <> show dictionary) $ - simplexPivot - pivotedObj - pivotedDict +simplexPivot :: (MonadIO m, MonadLogger m) => PivotObjective -> Dict -> m (Maybe Dict) +simplexPivot objective@(PivotObjective {variable = objectiveVar, function = objectiveFunc, constant = objectiveConstant}) dictionary = do + logMsg LevelInfo $ "simplexPivot: Pivoting with objective " <> showT objective <> " over system (in Dict form) = " <> showT dictionary + case mostPositive objectiveFunc of + Nothing -> do + logMsg LevelInfo $ "simplexPivot: Pivoting complete as no positive variables found in objective " <> showT objective <> " over system (in Dict form) = " <> showT dictionary + pure $ Just (insertPivotObjectiveToDict objective dictionary) + Just pivotNonBasicVar -> do + logMsg LevelInfo $ "simplexPivot: Non-basic pivoting variable in objective, determined by largest coefficient = " <> showT pivotNonBasicVar + let mPivotBasicVar = ratioTest dictionary pivotNonBasicVar Nothing Nothing + case mPivotBasicVar of + Nothing -> do + logMsg LevelInfo $ "simplexPivot: Ratio test failed with non-basic variable = " <> showT pivotNonBasicVar <> " over system (in Dict form) = " <> showT dictionary + pure Nothing + Just pivotBasicVar -> do + logMsg LevelInfo $ "simplexPivot: Basic pivoting variable determined by ratio test = " <> showT pivotBasicVar + let pivotResult = pivot pivotBasicVar pivotNonBasicVar (insertPivotObjectiveToDict objective dictionary) + pivotedObj = + let pivotedObjEntry = fromMaybe (error "simplexPivot: Can't find objective after pivoting") $ M.lookup objectiveVar pivotResult + in objective & #function .~ pivotedObjEntry.varMapSum & #constant .~ pivotedObjEntry.constant + pivotedDict = M.delete objectiveVar pivotResult + logMsg LevelInfo $ "simplexPivot: Pivoting complete, pivoted objective = " <> showT pivotedObj <> " over system (in Dict form) = " <> showT pivotedDict + simplexPivot + pivotedObj + pivotedDict where ratioTest :: Dict -> Var -> Maybe Var -> Maybe Rational -> Maybe Var ratioTest dict = aux (M.toList dict) @@ -304,7 +382,7 @@ simplexPivot objective@(PivotObjective {variable = objectiveVar, function = obje aux :: [(Var, DictValue)] -> Var -> Maybe Var -> Maybe Rational -> Maybe Var aux [] _ mCurrentMinBasicVar _ = mCurrentMinBasicVar aux (x@(basicVar, dictEquation) : xs) mostNegativeVar mCurrentMinBasicVar mCurrentMin = - case M.lookup mostNegativeVar (dictEquation.varMapSum) of + case M.lookup mostNegativeVar dictEquation.varMapSum of Nothing -> aux xs mostNegativeVar mCurrentMinBasicVar mCurrentMin Just currentCoeff -> let dictEquationConstant = dictEquation.constant @@ -322,9 +400,9 @@ simplexPivot objective@(PivotObjective {variable = objectiveVar, function = obje case findLargestCoeff (M.toList varLitMap) Nothing of Just (largestVarName, largestVarCoeff) -> if largestVarCoeff <= 0 - then trace "negative" Nothing + then Nothing else Just largestVarName - Nothing -> trace "No variables in first row when looking for most positive" Nothing + Nothing -> Nothing where findLargestCoeff :: [(Var, SimplexNum)] -> Maybe (Var, SimplexNum) -> Maybe (Var, SimplexNum) findLargestCoeff [] mCurrentMax = mCurrentMax diff --git a/src/Linear/Simplex/Util.hs b/src/Linear/Simplex/Util.hs index 5cf288d..63ceb37 100644 --- a/src/Linear/Simplex/Util.hs +++ b/src/Linear/Simplex/Util.hs @@ -10,6 +10,8 @@ module Linear.Simplex.Util where import Control.Lens +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Logger (LogLevel (..), LogLine, MonadLogger, logDebug, logError, logInfo, logWarn) import Data.Bifunctor import Data.Generics.Labels () import Data.Generics.Product (field) @@ -17,6 +19,9 @@ import Data.List import qualified Data.Map as Map import qualified Data.Map.Merge.Lazy as MapMerge import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import Data.Time (getCurrentTime) +import Data.Time.Format.ISO8601 (iso8601Show) import Linear.Simplex.Types import Prelude hiding (EQ) @@ -156,4 +161,18 @@ foldVarLitMap (vm1 : vm2 : vms) = in foldVarLitMap $ combinedVarMap : vms insertPivotObjectiveToDict :: PivotObjective -> Dict -> Dict -insertPivotObjectiveToDict objective = Map.insert (objective.variable) (DictValue {varMapSum = objective.function, constant = objective.constant}) +insertPivotObjectiveToDict objective = Map.insert objective.variable (DictValue {varMapSum = objective.function, constant = objective.constant}) + +showT :: (Show a) => a -> T.Text +showT = T.pack . show + +logMsg :: (MonadIO m, MonadLogger m) => LogLevel -> T.Text -> m () +logMsg lvl msg = do + currTime <- T.pack . iso8601Show <$> liftIO getCurrentTime + let msgToLog = currTime <> ": " <> msg + case lvl of + LevelDebug -> $logDebug msgToLog + LevelInfo -> $logInfo msgToLog + LevelWarn -> $logWarn msgToLog + LevelError -> $logError msgToLog + LevelOther otherLvl -> error "logMsg: LevelOther is not implemented" diff --git a/stack.yaml b/stack.yaml index a6e3737..adb7804 100644 --- a/stack.yaml +++ b/stack.yaml @@ -17,7 +17,7 @@ # # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-20.26 +resolver: lts-21.6 # User packages to be built. # Various formats can be used as shown in the example below. diff --git a/stack.yaml.lock b/stack.yaml.lock index ea5a850..8272e63 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -6,7 +6,7 @@ packages: [] snapshots: - completed: - sha256: 5a59b2a405b3aba3c00188453be172b85893cab8ebc352b1ef58b0eae5d248a2 - size: 650475 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/26.yaml - original: lts-20.26 + sha256: 2e7d4a730d8eb5373b2d383fac84efcf7c81e3b7a5fce71b4c2e19a1768f25a6 + size: 640239 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/6.yaml + original: lts-21.6 diff --git a/test/Spec.hs b/test/Spec.hs index 2002aef..6babc2e 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,32 +1,42 @@ module Main where +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Logger + import Linear.Simplex.Prettify import Linear.Simplex.Simplex +import Linear.Simplex.Types import Linear.Simplex.Util + import TestFunctions main :: IO () -main = runTests testsList +main = runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ runTests testsList -runTests [] = putStrLn "All tests passed" +runTests :: (MonadLogger m, MonadFail m, MonadIO m) => [((ObjectiveFunction, [PolyConstraint]), Maybe Result)] -> m () +runTests [] = do + liftIO $ putStrLn "All tests passed" + pure () runTests (((testObjective, testConstraints), expectedResult) : tests) = - let testResult = twoPhaseSimplex testObjective testConstraints - in if testResult == expectedResult - then runTests tests - else do - let msg = - "\nThe following test failed: " - <> ("\nObjective Function (Non-prettified): " ++ show testObjective) - <> ("\nConstraints (Non-prettified): " ++ show testConstraints) - <> "\n====================================" - <> ("\nObjective Function (Prettified): " ++ prettyShowObjectiveFunction testObjective) - <> "\nConstraints (Prettified): " - <> "\n" - <> concatMap (\c -> "\t" ++ prettyShowPolyConstraint c ++ "\n") testConstraints - <> "\n====================================" - <> ("\nExpected Solution (Full): " ++ show expectedResult) - <> ("\nActual Solution (Full): " ++ show testResult) - <> ("\nExpected Solution (Objective): " ++ show (extractObjectiveValue expectedResult)) - <> ("\nActual Solution (Objective): " ++ show (extractObjectiveValue testResult)) - <> "\n" - fail msg + do + testResult <- twoPhaseSimplex testObjective testConstraints + if testResult == expectedResult + then runTests tests + else do + let msg = + "\nThe following test failed: " + <> ("\nObjective Function (Non-prettified): " ++ show testObjective) + <> ("\nConstraints (Non-prettified): " ++ show testConstraints) + <> "\n====================================" + <> ("\nObjective Function (Prettified): " ++ prettyShowObjectiveFunction testObjective) + <> "\nConstraints (Prettified): " + <> "\n" + <> concatMap (\c -> "\t" ++ prettyShowPolyConstraint c ++ "\n") testConstraints + <> "\n====================================" + <> ("\nExpected Solution (Full): " ++ show expectedResult) + <> ("\nActual Solution (Full): " ++ show testResult) + <> ("\nExpected Solution (Objective): " ++ show (extractObjectiveValue expectedResult)) + <> ("\nActual Solution (Objective): " ++ show (extractObjectiveValue testResult)) + <> "\n" + fail msg diff --git a/test/TestFunctions.hs b/test/TestFunctions.hs index d228dd3..b2af317 100644 --- a/test/TestFunctions.hs +++ b/test/TestFunctions.hs @@ -37,6 +37,8 @@ testsList = , (test28, Just (Result 6 (M.fromList [(6, 0), (2, 10)]))) , (test29, Nothing) , (test30, Nothing) + , (test31, Just (Result 5 (M.fromList [(2, 1 % 1), (5, 0 % 1)]))) + , (test32, Nothing) , (testPolyPaver1, Just (Result 12 (M.fromList [(12, 7 % 4), (2, 5 % 2), (1, 7 % 4), (3, 0)]))) , (testPolyPaver2, Just (Result 12 (M.fromList [(12, 5 % 2), (2, 5 % 3), (1, 5 % 2), (3, 0)]))) , (testPolyPaver3, Just (Result 12 (M.fromList [(12, 5 % 3), (2, 5 % 3), (1, 5 % 2), (3, 0)]))) @@ -417,6 +419,24 @@ test30 = ] ) +test31 :: (ObjectiveFunction, [PolyConstraint]) +test31 = + ( Min (M.fromList [(1, 1)]) + , + [ GEQ (M.fromList [(1, 1), (2, 1)]) 1 + , GEQ (M.fromList [(1, 1), (2, 1)]) 1 + ] + ) + +test32 :: (ObjectiveFunction, [PolyConstraint]) +test32 = + ( Min (M.fromList [(1, 1)]) + , + [ GEQ (M.fromList [(1, 1), (2, 1)]) 2 + , LEQ (M.fromList [(1, 1), (2, 1)]) 1 + ] + ) + -- Tests for systems similar to those from PolyPaver2 testPolyPaver1 :: (ObjectiveFunction, [PolyConstraint]) testPolyPaver1 = From eb5ac07dc1f8309d78bff73cee5f766ef2149adc Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 9 Sep 2023 15:22:55 +0100 Subject: [PATCH 17/47] fixme --- src/Linear/Simplex/Simplex.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Linear/Simplex/Simplex.hs b/src/Linear/Simplex/Simplex.hs index 6363413..a874c90 100644 --- a/src/Linear/Simplex/Simplex.hs +++ b/src/Linear/Simplex/Simplex.hs @@ -400,7 +400,7 @@ simplexPivot objective@(PivotObjective {variable = objectiveVar, function = obje case findLargestCoeff (M.toList varLitMap) Nothing of Just (largestVarName, largestVarCoeff) -> if largestVarCoeff <= 0 - then Nothing + then Nothing else Just largestVarName Nothing -> Nothing where From 28aa9c5d1cdd49634fe4ca7f37779f0c604bda66 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 30 Sep 2023 11:58:50 +0100 Subject: [PATCH 18/47] Improve logging --- src/Linear/Simplex/Simplex.hs | 27 ++++++++++++++------------- 1 file changed, 14 insertions(+), 13 deletions(-) diff --git a/src/Linear/Simplex/Simplex.hs b/src/Linear/Simplex/Simplex.hs index a874c90..a682cdb 100644 --- a/src/Linear/Simplex/Simplex.hs +++ b/src/Linear/Simplex/Simplex.hs @@ -40,7 +40,7 @@ findFeasibleSolution unsimplifiedSystem = do logMsg LevelInfo "findFeasibleSolution: Feasible solution found with no artificial vars" pure . Just $ FeasibleSystem systemWithBasicVarsAsDictionary slackVars artificialVars objectiveVar else do - logMsg LevelInfo $ "findFeasibleSolution: Needed to create artificial vars. System with artificial vars (in Tableau form) = " <> showT systemWithBasicVars + logMsg LevelInfo $ "findFeasibleSolution: Needed to create artificial vars. System with artificial vars (in Tableau form) " <> showT systemWithBasicVars mPhase1Dict <- simplexPivot artificialPivotObjective systemWithBasicVarsAsDictionary case mPhase1Dict of Just phase1Dict -> do @@ -56,7 +56,7 @@ findFeasibleSolution unsimplifiedSystem = do phase1Dict case M.lookup objectiveVar eliminateArtificialVarsFromPhase1Tableau of Nothing -> do - logMsg LevelWarn $ "findFeasibleSolution: Objective row not found after eliminatiing artificial vars. This is unexpected. System without artificial vars (in Dict form) = " <> showT eliminateArtificialVarsFromPhase1Tableau + logMsg LevelWarn $ "findFeasibleSolution: Objective row not found after eliminatiing artificial vars. This is unexpected. System without artificial vars (in Dict form) " <> showT eliminateArtificialVarsFromPhase1Tableau -- If the objecitve row is not found, the system is feasible iff -- the artificial vars sum to zero. The value of an artificial -- variable is 0 if non-basic, and the RHS of the row if basic @@ -64,7 +64,7 @@ findFeasibleSolution unsimplifiedSystem = do let artificialVarsValsSum = sum artificialVarsVals if artificialVarsValsSum == 0 then do - logMsg LevelInfo $ "findFeasibleSolution: Artifical variables sum up to 0, thus original tableau is feasible. System without artificial vars (in Dict form) = " <> showT eliminateArtificialVarsFromPhase1Tableau + logMsg LevelInfo $ "findFeasibleSolution: Artifical variables sum up to 0, thus original tableau is feasible. System without artificial vars (in Dict form) " <> showT eliminateArtificialVarsFromPhase1Tableau pure . Just $ FeasibleSystem { dict = eliminateArtificialVarsFromPhase1Tableau @@ -73,12 +73,12 @@ findFeasibleSolution unsimplifiedSystem = do , objectiveVar = objectiveVar } else do - logMsg LevelInfo $ "findFeasibleSolution: Artifical variables sum up to " <> showT artificialVarsValsSum <> ", thus original tableau is infeasible. System without artificial vars (in Dict form) = " <> showT eliminateArtificialVarsFromPhase1Tableau + logMsg LevelInfo $ "findFeasibleSolution: Artifical variables sum up to " <> showT artificialVarsValsSum <> ", thus original tableau is infeasible. System without artificial vars (in Dict form) " <> showT eliminateArtificialVarsFromPhase1Tableau pure Nothing Just row -> if row.constant == 0 then do - logMsg LevelInfo $ "findFeasibleSolution: Objective RHS is zero after pivoting, thus original tableau is feasible. feasible system (in Dict form) = " <> showT eliminateArtificialVarsFromPhase1Tableau + logMsg LevelInfo $ "findFeasibleSolution: Objective RHS is zero after pivoting, thus original tableau is feasible. feasible system (in Dict form) " <> showT eliminateArtificialVarsFromPhase1Tableau pure . Just $ FeasibleSystem { dict = eliminateArtificialVarsFromPhase1Tableau @@ -88,13 +88,13 @@ findFeasibleSolution unsimplifiedSystem = do } else do unless (row.constant < 0) $ do - let errMsg = "findFeasibleSolution: Objective RHS is negative after pivoting. This should be impossible. System without artificial vars (in Dict form) = " <> show eliminateArtificialVarsFromPhase1Tableau + let errMsg = "findFeasibleSolution: Objective RHS is negative after pivoting. This should be impossible. System without artificial vars (in Dict form) " <> show eliminateArtificialVarsFromPhase1Tableau logMsg LevelError $ Text.pack errMsg error errMsg - logMsg LevelInfo $ "findFeasibleSolution: Objective RHS not zero after phase 1, thus original tableau is infeasible. System without artificial vars (in Dict form) = " <> showT eliminateArtificialVarsFromPhase1Tableau + logMsg LevelInfo $ "findFeasibleSolution: Objective RHS not zero after phase 1, thus original tableau is infeasible. System without artificial vars (in Dict form) " <> showT eliminateArtificialVarsFromPhase1Tableau pure Nothing Nothing -> do - logMsg LevelInfo $ "findFeasibleSolution: Infeasible solution found, could not pivot with objective " <> showT artificialPivotObjective <> " over system (in Dict form) = " <> showT systemWithBasicVarsAsDictionary + logMsg LevelInfo $ "findFeasibleSolution: Infeasible solution found, could not pivot with objective " <> showT artificialPivotObjective <> " over system (in Dict form) " <> showT systemWithBasicVarsAsDictionary pure Nothing where system = simplifySystem unsimplifiedSystem @@ -352,26 +352,27 @@ twoPhaseSimplex objFunction unsimplifiedSystem = do -- | Perform the simplex pivot algorithm on a system with basic vars, assume that the first row is the 'ObjectiveFunction'. simplexPivot :: (MonadIO m, MonadLogger m) => PivotObjective -> Dict -> m (Maybe Dict) simplexPivot objective@(PivotObjective {variable = objectiveVar, function = objectiveFunc, constant = objectiveConstant}) dictionary = do - logMsg LevelInfo $ "simplexPivot: Pivoting with objective " <> showT objective <> " over system (in Dict form) = " <> showT dictionary + logMsg LevelInfo $ "simplexPivot: Pivoting with objective " <> showT objective <> " over system (in Dict form) " <> showT dictionary case mostPositive objectiveFunc of Nothing -> do - logMsg LevelInfo $ "simplexPivot: Pivoting complete as no positive variables found in objective " <> showT objective <> " over system (in Dict form) = " <> showT dictionary + logMsg LevelInfo $ "simplexPivot: Pivoting complete as no positive variables found in objective " <> showT objective <> " over system (in Dict form) " <> showT dictionary pure $ Just (insertPivotObjectiveToDict objective dictionary) Just pivotNonBasicVar -> do logMsg LevelInfo $ "simplexPivot: Non-basic pivoting variable in objective, determined by largest coefficient = " <> showT pivotNonBasicVar let mPivotBasicVar = ratioTest dictionary pivotNonBasicVar Nothing Nothing case mPivotBasicVar of Nothing -> do - logMsg LevelInfo $ "simplexPivot: Ratio test failed with non-basic variable = " <> showT pivotNonBasicVar <> " over system (in Dict form) = " <> showT dictionary + logMsg LevelInfo $ "simplexPivot: Ratio test failed with non-basic variable " <> showT pivotNonBasicVar <> " over system (in Dict form) " <> showT dictionary pure Nothing Just pivotBasicVar -> do - logMsg LevelInfo $ "simplexPivot: Basic pivoting variable determined by ratio test = " <> showT pivotBasicVar + logMsg LevelInfo $ "simplexPivot: Basic pivoting variable determined by ratio test " <> showT pivotBasicVar + logMsg LevelInfo $ "simplexPivot: Pivoting with basic var " <> showT pivotBasicVar <> ", non-basic var " <> showT pivotNonBasicVar <> ", objective " <> showT objective <> " over system (in Dict form) " <> showT dictionary let pivotResult = pivot pivotBasicVar pivotNonBasicVar (insertPivotObjectiveToDict objective dictionary) pivotedObj = let pivotedObjEntry = fromMaybe (error "simplexPivot: Can't find objective after pivoting") $ M.lookup objectiveVar pivotResult in objective & #function .~ pivotedObjEntry.varMapSum & #constant .~ pivotedObjEntry.constant pivotedDict = M.delete objectiveVar pivotResult - logMsg LevelInfo $ "simplexPivot: Pivoting complete, pivoted objective = " <> showT pivotedObj <> " over system (in Dict form) = " <> showT pivotedDict + logMsg LevelInfo $ "simplexPivot: Pivoted, Recursing with new pivoting objective " <> showT pivotedObj <> " for new pivoted system (in Dict form) " <> showT pivotedDict simplexPivot pivotedObj pivotedDict From f2009eaa7821caa8053833c7f9a47d1f8a34d945 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 30 Sep 2023 12:21:10 +0100 Subject: [PATCH 19/47] Fourmolu upgrade: limit lines to 120 chars --- fourmolu.yaml | 2 +- src/Linear/Simplex/Simplex.hs | 126 +++++++++++++++++++++++++++------- src/Linear/Simplex/Types.hs | 3 +- 3 files changed, 104 insertions(+), 27 deletions(-) diff --git a/fourmolu.yaml b/fourmolu.yaml index b778c1d..9b7746d 100644 --- a/fourmolu.yaml +++ b/fourmolu.yaml @@ -1,5 +1,5 @@ indentation: 2 -column-limit: none +column-limit: 120 function-arrows: trailing comma-style: leading import-export-style: leading diff --git a/src/Linear/Simplex/Simplex.hs b/src/Linear/Simplex/Simplex.hs index a682cdb..e68a044 100644 --- a/src/Linear/Simplex/Simplex.hs +++ b/src/Linear/Simplex/Simplex.hs @@ -40,11 +40,17 @@ findFeasibleSolution unsimplifiedSystem = do logMsg LevelInfo "findFeasibleSolution: Feasible solution found with no artificial vars" pure . Just $ FeasibleSystem systemWithBasicVarsAsDictionary slackVars artificialVars objectiveVar else do - logMsg LevelInfo $ "findFeasibleSolution: Needed to create artificial vars. System with artificial vars (in Tableau form) " <> showT systemWithBasicVars + logMsg LevelInfo $ + "findFeasibleSolution: Needed to create artificial vars. System with artificial vars (in Tableau form) " + <> showT systemWithBasicVars mPhase1Dict <- simplexPivot artificialPivotObjective systemWithBasicVarsAsDictionary case mPhase1Dict of Just phase1Dict -> do - logMsg LevelInfo $ "findFeasibleSolution: System after pivoting with objective" <> showT artificialPivotObjective <> ": " <> showT phase1Dict + logMsg LevelInfo $ + "findFeasibleSolution: System after pivoting with objective" + <> showT artificialPivotObjective + <> ": " + <> showT phase1Dict let eliminateArtificialVarsFromPhase1Tableau = M.map ( \DictValue {..} -> @@ -56,7 +62,9 @@ findFeasibleSolution unsimplifiedSystem = do phase1Dict case M.lookup objectiveVar eliminateArtificialVarsFromPhase1Tableau of Nothing -> do - logMsg LevelWarn $ "findFeasibleSolution: Objective row not found after eliminatiing artificial vars. This is unexpected. System without artificial vars (in Dict form) " <> showT eliminateArtificialVarsFromPhase1Tableau + logMsg LevelWarn $ + "findFeasibleSolution: Objective row not found after eliminatiing artificial vars. This is unexpected. System without artificial vars (in Dict form) " + <> showT eliminateArtificialVarsFromPhase1Tableau -- If the objecitve row is not found, the system is feasible iff -- the artificial vars sum to zero. The value of an artificial -- variable is 0 if non-basic, and the RHS of the row if basic @@ -64,7 +72,9 @@ findFeasibleSolution unsimplifiedSystem = do let artificialVarsValsSum = sum artificialVarsVals if artificialVarsValsSum == 0 then do - logMsg LevelInfo $ "findFeasibleSolution: Artifical variables sum up to 0, thus original tableau is feasible. System without artificial vars (in Dict form) " <> showT eliminateArtificialVarsFromPhase1Tableau + logMsg LevelInfo $ + "findFeasibleSolution: Artifical variables sum up to 0, thus original tableau is feasible. System without artificial vars (in Dict form) " + <> showT eliminateArtificialVarsFromPhase1Tableau pure . Just $ FeasibleSystem { dict = eliminateArtificialVarsFromPhase1Tableau @@ -73,12 +83,18 @@ findFeasibleSolution unsimplifiedSystem = do , objectiveVar = objectiveVar } else do - logMsg LevelInfo $ "findFeasibleSolution: Artifical variables sum up to " <> showT artificialVarsValsSum <> ", thus original tableau is infeasible. System without artificial vars (in Dict form) " <> showT eliminateArtificialVarsFromPhase1Tableau + logMsg LevelInfo $ + "findFeasibleSolution: Artifical variables sum up to " + <> showT artificialVarsValsSum + <> ", thus original tableau is infeasible. System without artificial vars (in Dict form) " + <> showT eliminateArtificialVarsFromPhase1Tableau pure Nothing Just row -> if row.constant == 0 then do - logMsg LevelInfo $ "findFeasibleSolution: Objective RHS is zero after pivoting, thus original tableau is feasible. feasible system (in Dict form) " <> showT eliminateArtificialVarsFromPhase1Tableau + logMsg LevelInfo $ + "findFeasibleSolution: Objective RHS is zero after pivoting, thus original tableau is feasible. feasible system (in Dict form) " + <> showT eliminateArtificialVarsFromPhase1Tableau pure . Just $ FeasibleSystem { dict = eliminateArtificialVarsFromPhase1Tableau @@ -88,13 +104,21 @@ findFeasibleSolution unsimplifiedSystem = do } else do unless (row.constant < 0) $ do - let errMsg = "findFeasibleSolution: Objective RHS is negative after pivoting. This should be impossible. System without artificial vars (in Dict form) " <> show eliminateArtificialVarsFromPhase1Tableau + let errMsg = + "findFeasibleSolution: Objective RHS is negative after pivoting. This should be impossible. System without artificial vars (in Dict form) " + <> show eliminateArtificialVarsFromPhase1Tableau logMsg LevelError $ Text.pack errMsg error errMsg - logMsg LevelInfo $ "findFeasibleSolution: Objective RHS not zero after phase 1, thus original tableau is infeasible. System without artificial vars (in Dict form) " <> showT eliminateArtificialVarsFromPhase1Tableau + logMsg LevelInfo $ + "findFeasibleSolution: Objective RHS not zero after phase 1, thus original tableau is infeasible. System without artificial vars (in Dict form) " + <> showT eliminateArtificialVarsFromPhase1Tableau pure Nothing Nothing -> do - logMsg LevelInfo $ "findFeasibleSolution: Infeasible solution found, could not pivot with objective " <> showT artificialPivotObjective <> " over system (in Dict form) " <> showT systemWithBasicVarsAsDictionary + logMsg LevelInfo $ + "findFeasibleSolution: Infeasible solution found, could not pivot with objective " + <> showT artificialPivotObjective + <> " over system (in Dict form) " + <> showT systemWithBasicVarsAsDictionary pure Nothing where system = simplifySystem unsimplifiedSystem @@ -156,8 +180,14 @@ findFeasibleSolution unsimplifiedSystem = do case mVar of Nothing -> if r >= 0 - then (M.insert newArtificialVar (TableauRow {lhs = M.insert newArtificialVar 1 v, rhs = r}) newSystemWithNewMaxVar, newArtificialVar : artificialVarsWithNewMaxVar) - else (M.insert newArtificialVar (TableauRow {lhs = M.insert newArtificialVar (-1) v, rhs = r}) newSystemWithNewMaxVar, newArtificialVar : artificialVarsWithNewMaxVar) + then + ( M.insert newArtificialVar (TableauRow {lhs = M.insert newArtificialVar 1 v, rhs = r}) newSystemWithNewMaxVar + , newArtificialVar : artificialVarsWithNewMaxVar + ) + else + ( M.insert newArtificialVar (TableauRow {lhs = M.insert newArtificialVar (-1) v, rhs = r}) newSystemWithNewMaxVar + , newArtificialVar : artificialVarsWithNewMaxVar + ) Just basicVar -> case M.lookup basicVar v of Just basicVarCoeff -> @@ -168,12 +198,18 @@ findFeasibleSolution unsimplifiedSystem = do then if basicVarCoeff >= 0 -- Should only be 1 in the standard call path then (M.insert basicVar (TableauRow {lhs = v, rhs = r}) newSystemWithoutNewMaxVar, artificialVarsWithoutNewMaxVar) - else (M.insert newArtificialVar (TableauRow {lhs = M.insert newArtificialVar 1 v, rhs = r}) newSystemWithNewMaxVar, newArtificialVar : artificialVarsWithNewMaxVar) -- Slack var is negative, r is positive (when original constraint was GEQ) + else + ( M.insert newArtificialVar (TableauRow {lhs = M.insert newArtificialVar 1 v, rhs = r}) newSystemWithNewMaxVar + , newArtificialVar : artificialVarsWithNewMaxVar -- Slack var is negative, r is positive (when original constraint was GEQ) + ) else -- r < 0 if basicVarCoeff <= 0 -- Should only be -1 in the standard call path then (M.insert basicVar (TableauRow {lhs = v, rhs = r}) newSystemWithoutNewMaxVar, artificialVarsWithoutNewMaxVar) - else (M.insert newArtificialVar (TableauRow {lhs = M.insert newArtificialVar (-1) v, rhs = r}) newSystemWithNewMaxVar, newArtificialVar : artificialVarsWithNewMaxVar) -- Slack var is negative, r is negative (when original constraint was LEQ) + else + ( M.insert newArtificialVar (TableauRow {lhs = M.insert newArtificialVar (-1) v, rhs = r}) newSystemWithNewMaxVar + , newArtificialVar : artificialVarsWithNewMaxVar -- Slack var is negative, r is negative (when original constraint was LEQ) + ) Nothing -> error "1" -- undefined where newArtificialVar = maxVar + 1 @@ -219,13 +255,22 @@ findFeasibleSolution unsimplifiedSystem = do -- and the second item being a map of the values of all 'Integer' variables appearing in the system, including the 'ObjectiveFunction'. optimizeFeasibleSystem :: (MonadIO m, MonadLogger m) => ObjectiveFunction -> FeasibleSystem -> m (Maybe Result) optimizeFeasibleSystem objFunction fsys@(FeasibleSystem {dict = phase1Dict, ..}) = do - logMsg LevelInfo $ "optimizeFeasibleSystem: Optimizing feasible system " <> showT fsys <> " with objective " <> showT objFunction + logMsg LevelInfo $ + "optimizeFeasibleSystem: Optimizing feasible system " <> showT fsys <> " with objective " <> showT objFunction if null artificialVars then do - logMsg LevelInfo $ "optimizeFeasibleSystem: No artificial vars, system is feasible. Pivoting system (in dict form) " <> showT phase1Dict <> " with objective " <> showT normalObjective + logMsg LevelInfo $ + "optimizeFeasibleSystem: No artificial vars, system is feasible. Pivoting system (in dict form) " + <> showT phase1Dict + <> " with objective " + <> showT normalObjective fmap (displayResults . dictionaryFormToTableau) <$> simplexPivot normalObjective phase1Dict else do - logMsg LevelInfo $ "optimizeFeasibleSystem: Artificial vars present. Pivoting system (in dict form) " <> showT phase1Dict <> " with objective " <> showT adjustedObjective + logMsg LevelInfo $ + "optimizeFeasibleSystem: Artificial vars present. Pivoting system (in dict form) " + <> showT phase1Dict + <> " with objective " + <> showT adjustedObjective fmap (displayResults . dictionaryFormToTableau) <$> simplexPivot adjustedObjective phase1Dict where -- \| displayResults takes a 'Tableau' and returns a 'Result'. The 'Tableau' @@ -337,13 +382,22 @@ optimizeFeasibleSystem objFunction fsys@(FeasibleSystem {dict = phase1Dict, ..}) -- and the second item being a map of the values of all 'Integer' variables appearing in the system, including the 'ObjectiveFunction'. twoPhaseSimplex :: (MonadIO m, MonadLogger m) => ObjectiveFunction -> [PolyConstraint] -> m (Maybe Result) twoPhaseSimplex objFunction unsimplifiedSystem = do - logMsg LevelInfo $ "twoPhaseSimplex: Solving system " <> showT unsimplifiedSystem <> " with objective " <> showT objFunction + logMsg LevelInfo $ + "twoPhaseSimplex: Solving system " <> showT unsimplifiedSystem <> " with objective " <> showT objFunction phase1Result <- findFeasibleSolution unsimplifiedSystem case phase1Result of Just feasibleSystem -> do - logMsg LevelInfo $ "twoPhaseSimplex: Feasible system found for " <> showT unsimplifiedSystem <> "; Feasible system: " <> showT feasibleSystem + logMsg LevelInfo $ + "twoPhaseSimplex: Feasible system found for " + <> showT unsimplifiedSystem + <> "; Feasible system: " + <> showT feasibleSystem optimizedSystem <- optimizeFeasibleSystem objFunction feasibleSystem - logMsg LevelInfo $ "twoPhaseSimplex: Optimized system found for " <> showT unsimplifiedSystem <> "; Optimized system: " <> showT optimizedSystem + logMsg LevelInfo $ + "twoPhaseSimplex: Optimized system found for " + <> showT unsimplifiedSystem + <> "; Optimized system: " + <> showT optimizedSystem pure optimizedSystem Nothing -> do logMsg LevelInfo $ "twoPhaseSimplex: Phase 1 gives infeasible result for " <> showT unsimplifiedSystem @@ -352,27 +406,49 @@ twoPhaseSimplex objFunction unsimplifiedSystem = do -- | Perform the simplex pivot algorithm on a system with basic vars, assume that the first row is the 'ObjectiveFunction'. simplexPivot :: (MonadIO m, MonadLogger m) => PivotObjective -> Dict -> m (Maybe Dict) simplexPivot objective@(PivotObjective {variable = objectiveVar, function = objectiveFunc, constant = objectiveConstant}) dictionary = do - logMsg LevelInfo $ "simplexPivot: Pivoting with objective " <> showT objective <> " over system (in Dict form) " <> showT dictionary + logMsg LevelInfo $ + "simplexPivot: Pivoting with objective " <> showT objective <> " over system (in Dict form) " <> showT dictionary case mostPositive objectiveFunc of Nothing -> do - logMsg LevelInfo $ "simplexPivot: Pivoting complete as no positive variables found in objective " <> showT objective <> " over system (in Dict form) " <> showT dictionary + logMsg LevelInfo $ + "simplexPivot: Pivoting complete as no positive variables found in objective " + <> showT objective + <> " over system (in Dict form) " + <> showT dictionary pure $ Just (insertPivotObjectiveToDict objective dictionary) Just pivotNonBasicVar -> do - logMsg LevelInfo $ "simplexPivot: Non-basic pivoting variable in objective, determined by largest coefficient = " <> showT pivotNonBasicVar + logMsg LevelInfo $ + "simplexPivot: Non-basic pivoting variable in objective, determined by largest coefficient = " <> showT pivotNonBasicVar let mPivotBasicVar = ratioTest dictionary pivotNonBasicVar Nothing Nothing case mPivotBasicVar of Nothing -> do - logMsg LevelInfo $ "simplexPivot: Ratio test failed with non-basic variable " <> showT pivotNonBasicVar <> " over system (in Dict form) " <> showT dictionary + logMsg LevelInfo $ + "simplexPivot: Ratio test failed with non-basic variable " + <> showT pivotNonBasicVar + <> " over system (in Dict form) " + <> showT dictionary pure Nothing Just pivotBasicVar -> do logMsg LevelInfo $ "simplexPivot: Basic pivoting variable determined by ratio test " <> showT pivotBasicVar - logMsg LevelInfo $ "simplexPivot: Pivoting with basic var " <> showT pivotBasicVar <> ", non-basic var " <> showT pivotNonBasicVar <> ", objective " <> showT objective <> " over system (in Dict form) " <> showT dictionary + logMsg LevelInfo $ + "simplexPivot: Pivoting with basic var " + <> showT pivotBasicVar + <> ", non-basic var " + <> showT pivotNonBasicVar + <> ", objective " + <> showT objective + <> " over system (in Dict form) " + <> showT dictionary let pivotResult = pivot pivotBasicVar pivotNonBasicVar (insertPivotObjectiveToDict objective dictionary) pivotedObj = let pivotedObjEntry = fromMaybe (error "simplexPivot: Can't find objective after pivoting") $ M.lookup objectiveVar pivotResult in objective & #function .~ pivotedObjEntry.varMapSum & #constant .~ pivotedObjEntry.constant pivotedDict = M.delete objectiveVar pivotResult - logMsg LevelInfo $ "simplexPivot: Pivoted, Recursing with new pivoting objective " <> showT pivotedObj <> " for new pivoted system (in Dict form) " <> showT pivotedDict + logMsg LevelInfo $ + "simplexPivot: Pivoted, Recursing with new pivoting objective " + <> showT pivotedObj + <> " for new pivoted system (in Dict form) " + <> showT pivotedDict simplexPivot pivotedObj pivotedDict diff --git a/src/Linear/Simplex/Types.hs b/src/Linear/Simplex/Types.hs index aa2c986..9dd201e 100644 --- a/src/Linear/Simplex/Types.hs +++ b/src/Linear/Simplex/Types.hs @@ -77,7 +77,8 @@ data PolyConstraint -- | Create an objective function. -- We can either 'Max'imize or 'Min'imize a 'VarTermSum'. -data ObjectiveFunction = Max {objective :: VarLitMapSum} | Min {objective :: VarLitMapSum} deriving (Show, Read, Eq, Generic) +data ObjectiveFunction = Max {objective :: VarLitMapSum} | Min {objective :: VarLitMapSum} + deriving (Show, Read, Eq, Generic) -- | TODO: Maybe we want this type -- TODO: A better/alternative name From 18c497b0590c98993a7f964e45b2eabda54610e6 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 30 Sep 2023 12:23:51 +0100 Subject: [PATCH 20/47] Upgrade fourmolu action, specify fourmolu version --- .github/workflows/haskell.yml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 4577ffa..f578812 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -17,7 +17,9 @@ jobs: steps: - uses: actions/checkout@v3 - - uses: haskell-actions/run-fourmolu@v7 + - uses: haskell-actions/run-fourmolu@v9 + with: + version: "0.14.0.0" build: name: GHC ${{ matrix.ghc-version }} on ${{ matrix.os }} runs-on: ${{ matrix.os }} From de2a7bf4a25b1adc1a2abc34c17bf8aef3367fac Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 30 Sep 2023 12:33:49 +0100 Subject: [PATCH 21/47] Bump package version --- package.yaml | 2 +- simplex-method.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/package.yaml b/package.yaml index ac7e09b..b45be0d 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: simplex-method -version: 0.1.0.0 +version: 0.2.0.0 github: "rasheedja/simplex-method" license: BSD3 author: "Junaid Rasheed" diff --git a/simplex-method.cabal b/simplex-method.cabal index 843d28c..c33f580 100644 --- a/simplex-method.cabal +++ b/simplex-method.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: simplex-method -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Implementation of the two-phase simplex method in exact rational arithmetic description: Please see the README on GitHub at category: Math, Maths, Mathematics, Optimisation, Optimization, Linear Programming From c2f60d2f7162cb70909e3af42141ec603e34d689 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 30 Sep 2023 13:07:23 +0100 Subject: [PATCH 22/47] Bump lts --- stack.yaml | 2 +- stack.yaml.lock | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/stack.yaml b/stack.yaml index adb7804..51e350e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -17,7 +17,7 @@ # # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-21.6 +resolver: lts-21.13 # User packages to be built. # Various formats can be used as shown in the example below. diff --git a/stack.yaml.lock b/stack.yaml.lock index 8272e63..d968e8d 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -6,7 +6,7 @@ packages: [] snapshots: - completed: - sha256: 2e7d4a730d8eb5373b2d383fac84efcf7c81e3b7a5fce71b4c2e19a1768f25a6 - size: 640239 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/6.yaml - original: lts-21.6 + sha256: 8017c7970c2a8a9510c60cc70ac245d59e0c34eb932b91d37af09fe59855d854 + size: 640038 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/13.yaml + original: lts-21.13 From ebd2099602305d1c1e0edb885c67e7e06b0f32fe Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Fri, 24 Nov 2023 17:03:04 +0000 Subject: [PATCH 23/47] some helper functions --- src/Linear/Simplex/Util.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Linear/Simplex/Util.hs b/src/Linear/Simplex/Util.hs index 63ceb37..61688c5 100644 --- a/src/Linear/Simplex/Util.hs +++ b/src/Linear/Simplex/Util.hs @@ -176,3 +176,9 @@ logMsg lvl msg = do LevelWarn -> $logWarn msgToLog LevelError -> $logError msgToLog LevelOther otherLvl -> error "logMsg: LevelOther is not implemented" + +extractTableauValues :: Tableau -> Map.Map Var SimplexNum +extractTableauValues = Map.map (.rhs) + +extractDictValues :: Dict -> Map.Map Var SimplexNum +extractDictValues = Map.map (.constant) From af6e3640075584caf424671428de0d9760eb7cc2 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Fri, 24 Nov 2023 17:06:47 +0000 Subject: [PATCH 24/47] Rename Linaer.Simplex.Simplex to Linear.Simplex.Solver.TwoPhase + I like this name better + Allows for alternative solvers --- README.md | 2 +- simplex-method.cabal | 2 +- src/Linear/Simplex/{Simplex.hs => Solver/TwoPhase.hs} | 4 ++-- src/Linear/Simplex/Util.hs | 2 +- test/Spec.hs | 2 +- 5 files changed, 6 insertions(+), 6 deletions(-) rename src/Linear/Simplex/{Simplex.hs => Solver/TwoPhase.hs} (99%) diff --git a/README.md b/README.md index 6151440..f391970 100644 --- a/README.md +++ b/README.md @@ -4,7 +4,7 @@ ## Quick Overview -The `Linear.Simplex.Simplex` module contain both phases of the simplex method. +The `Linear.Simplex.Solver.TwoPhase` module contain both phases of the two-phase simplex method. ### Phase One diff --git a/simplex-method.cabal b/simplex-method.cabal index c33f580..fc9f040 100644 --- a/simplex-method.cabal +++ b/simplex-method.cabal @@ -28,7 +28,7 @@ source-repository head library exposed-modules: Linear.Simplex.Prettify - Linear.Simplex.Simplex + Linear.Simplex.Solver.TwoPhase Linear.Simplex.Types Linear.Simplex.Util other-modules: diff --git a/src/Linear/Simplex/Simplex.hs b/src/Linear/Simplex/Solver/TwoPhase.hs similarity index 99% rename from src/Linear/Simplex/Simplex.hs rename to src/Linear/Simplex/Solver/TwoPhase.hs index e68a044..4c827ea 100644 --- a/src/Linear/Simplex/Simplex.hs +++ b/src/Linear/Simplex/Solver/TwoPhase.hs @@ -1,5 +1,5 @@ -- | --- Module : Linear.Simplex.Simplex +-- Module : Linear.Simplex.Simplex.TwoPhase -- Description : Implements the twoPhaseSimplex method -- Copyright : (c) Junaid Rasheed, 2020-2022 -- License : BSD-3 @@ -10,7 +10,7 @@ -- 'findFeasibleSolution' performs phase one of the two-phase simplex method. -- 'optimizeFeasibleSystem' performs phase two of the two-phase simplex method. -- 'twoPhaseSimplex' performs both phases of the two-phase simplex method. -module Linear.Simplex.Simplex (findFeasibleSolution, optimizeFeasibleSystem, twoPhaseSimplex) where +module Linear.Simplex.Solver.TwoPhase (findFeasibleSolution, optimizeFeasibleSystem, twoPhaseSimplex) where import Prelude hiding (EQ) diff --git a/src/Linear/Simplex/Util.hs b/src/Linear/Simplex/Util.hs index 61688c5..527c005 100644 --- a/src/Linear/Simplex/Util.hs +++ b/src/Linear/Simplex/Util.hs @@ -108,7 +108,7 @@ tableauInDictionaryForm = -- | If this function is given 'Nothing', return 'Nothing'. -- Otherwise, we 'lookup' the 'Integer' given in the first item of the pair in the map given in the second item of the pair. --- This is typically used to extract the value of the 'ObjectiveFunction' after calling 'Linear.Simplex.Simplex.twoPhaseSimplex'. +-- This is typically used to extract the value of the 'ObjectiveFunction' after calling 'Linear.Simplex.Solver.TwoPhase.twoPhaseSimplex'. extractObjectiveValue :: Maybe Result -> Maybe SimplexNum extractObjectiveValue = fmap $ \result -> case Map.lookup result.objectiveVar result.varValMap of diff --git a/test/Spec.hs b/test/Spec.hs index 6babc2e..4a8ad55 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -5,7 +5,7 @@ import Control.Monad.IO.Class import Control.Monad.Logger import Linear.Simplex.Prettify -import Linear.Simplex.Simplex +import Linear.Simplex.Solver.TwoPhase import Linear.Simplex.Types import Linear.Simplex.Util From 9bd3cc0d3d35b6b8327324c52def48bd48c9a348 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Fri, 24 Nov 2023 17:30:10 +0000 Subject: [PATCH 25/47] Fix caching + I was using the cabal plan as a key, now I use stack files/cabal generated files --- .github/workflows/haskell.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index f578812..cf0f64c 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -61,7 +61,7 @@ jobs: id: cache with: path: .stack-work - key: ${{ runner.os }}-ghc-${{ env.GHC_VERSION }}-stack-${{ env.STACK_VERSION }}-plan-${{ hashFiles('**/plan.json') }} + key: ${{ runner.os }}-ghc-${{ env.GHC_VERSION }}-stack-${{ env.STACK_VERSION }}-deps-${{ hashFiles('**/stack.yaml', '**/package.yaml', '**/simplex-method.cabal') }} restore-keys: | ${{ runner.os }}-ghc-${{ env.GHC_VERSION }}-stack-${{ env.STACK_VERSION }}- From fb1cc4036b3da55a7e38580c1489a2cbd7326b22 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Fri, 24 Nov 2023 18:10:25 +0000 Subject: [PATCH 26/47] Update lts --- stack.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack.yaml b/stack.yaml index 51e350e..eab5650 100644 --- a/stack.yaml +++ b/stack.yaml @@ -17,7 +17,7 @@ # # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-21.13 +resolver: lts-21.22 # User packages to be built. # Various formats can be used as shown in the example below. From 45cee63fb6a31275cb26cec558926b9fad8814ab Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Fri, 24 Nov 2023 18:30:30 +0000 Subject: [PATCH 27/47] Diagnose caching issues --- .github/workflows/haskell.yml | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index cf0f64c..974c30c 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -64,10 +64,25 @@ jobs: key: ${{ runner.os }}-ghc-${{ env.GHC_VERSION }}-stack-${{ env.STACK_VERSION }}-deps-${{ hashFiles('**/stack.yaml', '**/package.yaml', '**/simplex-method.cabal') }} restore-keys: | ${{ runner.os }}-ghc-${{ env.GHC_VERSION }}-stack-${{ env.STACK_VERSION }}- + + - name: Find .stack-work directories + run: find . -name .stack-work + + - name: Check root directory after restore + run: ls -la . + + - name: Check .stack-work directory after restore + run: ls -la .stack-work - name: Install dependencies run: stack build --only-dependencies + - name: Check root directory before save + run: ls -la . + + - name: Check .stack-work directory before save + run: ls -la .stack-work + # Cache dependencies already here, so that we do not have to rebuild them should the subsequent steps fail. - name: Save cached dependencies uses: actions/cache/save@v3 From 4aec1cd466e4bc133015ef5e801d031aba59775c Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Fri, 24 Nov 2023 19:04:10 +0000 Subject: [PATCH 28/47] Try fixing caching --- .github/workflows/haskell.yml | 50 +++++++++++++++++------------------ 1 file changed, 24 insertions(+), 26 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 974c30c..37a94d8 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -56,45 +56,43 @@ jobs: stack build --test --bench --no-haddock --dry-run # The last step generates dist-newstyle/cache/plan.json for the cache key. - - name: Restore cached dependencies + - name: Restore .stack-work dependencies uses: actions/cache/restore@v3 - id: cache + id: cache-restore-stack-work with: path: .stack-work - key: ${{ runner.os }}-ghc-${{ env.GHC_VERSION }}-stack-${{ env.STACK_VERSION }}-deps-${{ hashFiles('**/stack.yaml', '**/package.yaml', '**/simplex-method.cabal') }} + key: ${{ runner.os }}-ghc-${{ env.GHC_VERSION }}-stack-${{ env.STACK_VERSION }}-stack-work-${{ hashFiles('stack.yaml') }}-${{ hashFiles('package.yaml') }}-${{ hashFiles('**/*.hs') }} restore-keys: | - ${{ runner.os }}-ghc-${{ env.GHC_VERSION }}-stack-${{ env.STACK_VERSION }}- + ${{ runner.os }}-ghc-${{ env.GHC_VERSION }}-stack-${{ env.STACK_VERSION }}-stack-work- - - name: Find .stack-work directories - run: find . -name .stack-work - - - name: Check root directory after restore - run: ls -la . - - - name: Check .stack-work directory after restore - run: ls -la .stack-work + - name: Restore ~/.stack dependencies + uses: actions/cache/restore@v3 + id: cache-restore-stack-global + with: + path: ~/.stack + key: ${{ runner.os }}-ghc-${{ env.GHC_VERSION }}-stack-${{ env.STACK_VERSION }}-stack-global-${{ hashFiles('stack.yaml') }}-${{ hashFiles('package.yaml') }} + restore-keys: | + ${{ runner.os }}-ghc-${{ env.GHC_VERSION }}-stack-${{ env.STACK_VERSION }}-stack-global- - name: Install dependencies run: stack build --only-dependencies - - name: Check root directory before save - run: ls -la . - - - name: Check .stack-work directory before save - run: ls -la .stack-work + - name: Build + run: stack build - # Cache dependencies already here, so that we do not have to rebuild them should the subsequent steps fail. - - name: Save cached dependencies + - name: Save .stack-work dependencies uses: actions/cache/save@v3 - # Caches are immutable, trying to save with the same key would error. - if: ${{ !steps.cache.outputs.cache-hit - || steps.cache.outputs.cache-primary-key != steps.cache.outputs.cache-matched-key }} + id: cache-save-stack-work with: path: .stack-work - key: ${{ steps.cache.outputs.cache-primary-key }} - - - name: Build - run: stack build + key: ${{ steps.cache-restore-stack-work.outputs.cache-primary-key }} + + - name: Save ~/.stack dependencies + uses: actions/cache/save@v3 + id: cache-save-stack-global + with: + path: ~/.stack + key: ${{ steps.cache-restore-stack-global.outputs.cache-primary-key }} - name: Run tests run: stack test From 04538663c82c7e390ac35a6e05bb9d438a1d88f5 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Fri, 24 Nov 2023 19:04:39 +0000 Subject: [PATCH 29/47] Remove windows from CI + Don't want to spend effor fixing windows caching --- .github/workflows/haskell.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 37a94d8..fb6b858 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -26,7 +26,7 @@ jobs: strategy: fail-fast: false matrix: - os: [windows-latest, macos-latest, ubuntu-latest] + os: [macos-latest, ubuntu-latest] ghc-version: ['9.6', '9.4', '9.2', '9.0'] steps: From cd8d39958e81457600ef76deba7b7ed9a71e46c8 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Fri, 24 Nov 2023 19:25:58 +0000 Subject: [PATCH 30/47] Update workflow step labels --- .github/workflows/haskell.yml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index fb6b858..ab7646e 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -56,7 +56,7 @@ jobs: stack build --test --bench --no-haddock --dry-run # The last step generates dist-newstyle/cache/plan.json for the cache key. - - name: Restore .stack-work dependencies + - name: Restore .stack-work cache uses: actions/cache/restore@v3 id: cache-restore-stack-work with: @@ -65,7 +65,7 @@ jobs: restore-keys: | ${{ runner.os }}-ghc-${{ env.GHC_VERSION }}-stack-${{ env.STACK_VERSION }}-stack-work- - - name: Restore ~/.stack dependencies + - name: Restore ~/.stack cache uses: actions/cache/restore@v3 id: cache-restore-stack-global with: @@ -74,20 +74,20 @@ jobs: restore-keys: | ${{ runner.os }}-ghc-${{ env.GHC_VERSION }}-stack-${{ env.STACK_VERSION }}-stack-global- - - name: Install dependencies + - name: Build dependencies run: stack build --only-dependencies - - name: Build + - name: Build the package run: stack build - - name: Save .stack-work dependencies + - name: Save .stack-work cache uses: actions/cache/save@v3 id: cache-save-stack-work with: path: .stack-work key: ${{ steps.cache-restore-stack-work.outputs.cache-primary-key }} - - name: Save ~/.stack dependencies + - name: Save ~/.stack cache uses: actions/cache/save@v3 id: cache-save-stack-global with: From f4407a643eefd2596b4a9d7cd63d32819ebddb37 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 25 Nov 2023 13:05:35 +0000 Subject: [PATCH 31/47] Update stack yaml lock --- stack.yaml.lock | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/stack.yaml.lock b/stack.yaml.lock index d968e8d..e8d3cc7 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -6,7 +6,7 @@ packages: [] snapshots: - completed: - sha256: 8017c7970c2a8a9510c60cc70ac245d59e0c34eb932b91d37af09fe59855d854 - size: 640038 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/13.yaml - original: lts-21.13 + sha256: afd5ba64ab602cabc2d3942d3d7e7dd6311bc626dcb415b901eaf576cb62f0ea + size: 640060 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/22.yaml + original: lts-21.22 From 86254136a75fcd45a26250522c404dad445518c6 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 25 Nov 2023 13:05:47 +0000 Subject: [PATCH 32/47] Add windows + caching to ci --- .github/workflows/haskell.yml | 38 ++++++++++++++++++++++++++++------- 1 file changed, 31 insertions(+), 7 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index ab7646e..e303f4f 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -26,7 +26,7 @@ jobs: strategy: fail-fast: false matrix: - os: [macos-latest, ubuntu-latest] + os: [windows-latest, macos-latest, ubuntu-latest] ghc-version: ['9.6', '9.4', '9.2', '9.0'] steps: @@ -65,34 +65,58 @@ jobs: restore-keys: | ${{ runner.os }}-ghc-${{ env.GHC_VERSION }}-stack-${{ env.STACK_VERSION }}-stack-work- - - name: Restore ~/.stack cache + - name: Restore ~/.stack cache (Unix) uses: actions/cache/restore@v3 - id: cache-restore-stack-global + id: cache-restore-stack-global-unix + if: runner.os == 'Linux' || runner.os == 'macOS' with: path: ~/.stack key: ${{ runner.os }}-ghc-${{ env.GHC_VERSION }}-stack-${{ env.STACK_VERSION }}-stack-global-${{ hashFiles('stack.yaml') }}-${{ hashFiles('package.yaml') }} restore-keys: | ${{ runner.os }}-ghc-${{ env.GHC_VERSION }}-stack-${{ env.STACK_VERSION }}-stack-global- + - name: Restore %APPDATA%\stack, %LOCALAPPDATA%\Programs\stack cache (Windows) + uses: actions/cache/restore@v3 + id: cache-restore-stack-global-windows + if: runner.os == 'Windows' + with: + path: | + ~\AppData\Roaming\stack + ~\AppData\Local\Programs\stack + key: ${{ runner.os }}-ghc-${{ env.GHC_VERSION }}-stack-${{ env.STACK_VERSION }}-stack-global-${{ hashFiles('stack.yaml') }}-${{ hashFiles('package.yaml') }} + restore-keys: | + ${{ runner.os }}-ghc-${{ env.GHC_VERSION }}-stack-${{ env.STACK_VERSION }}-stack-global- + - name: Build dependencies run: stack build --only-dependencies - name: Build the package run: stack build - - name: Save .stack-work cache + - name: Save .stack-work cache (Unix) uses: actions/cache/save@v3 id: cache-save-stack-work + if: runner.os == 'Linux' || runner.os == 'macOS' with: path: .stack-work key: ${{ steps.cache-restore-stack-work.outputs.cache-primary-key }} - - - name: Save ~/.stack cache + + - name: Save %APPDATA%\stack, %LOCALAPPDATA%\Programs\stack cache (Windows) + uses: actions/cache/save@v3 + if: runner.os == 'Windows' + with: + path: | + ~\AppData\Roaming\stack + ~\AppData\Local\Programs\stack + key: ${{ steps.cache-restore-stack-global-windows.outputs.cache-primary-key }} + + - name: Save ~/.stack cache (Unix) uses: actions/cache/save@v3 id: cache-save-stack-global + if: runner.os == 'Linux' || runner.os == 'macOS' with: path: ~/.stack - key: ${{ steps.cache-restore-stack-global.outputs.cache-primary-key }} + key: ${{ steps.cache-restore-stack-global-unix.outputs.cache-primary-key }} - name: Run tests run: stack test From 38ddffa24515a27f0e8c0e92873391cc55d5978b Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 25 Nov 2023 13:12:13 +0000 Subject: [PATCH 33/47] Save .stack-work for windows too --- .github/workflows/haskell.yml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index e303f4f..16090b3 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -93,10 +93,9 @@ jobs: - name: Build the package run: stack build - - name: Save .stack-work cache (Unix) + - name: Save .stack-work cache uses: actions/cache/save@v3 id: cache-save-stack-work - if: runner.os == 'Linux' || runner.os == 'macOS' with: path: .stack-work key: ${{ steps.cache-restore-stack-work.outputs.cache-primary-key }} From 542fb3d01b73327e572c6b0989ecec7059da83b4 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 25 Nov 2023 13:20:55 +0000 Subject: [PATCH 34/47] Only save when cache is not hit --- .github/workflows/haskell.yml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 16090b3..92d3748 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -96,6 +96,7 @@ jobs: - name: Save .stack-work cache uses: actions/cache/save@v3 id: cache-save-stack-work + if: steps.cache-restore-stack-work.outputs.cache-hit != 'true' with: path: .stack-work key: ${{ steps.cache-restore-stack-work.outputs.cache-primary-key }} @@ -103,6 +104,7 @@ jobs: - name: Save %APPDATA%\stack, %LOCALAPPDATA%\Programs\stack cache (Windows) uses: actions/cache/save@v3 if: runner.os == 'Windows' + && steps.cache-restore-stack-global-windows.outputs.cache-hit != 'true' with: path: | ~\AppData\Roaming\stack @@ -112,7 +114,8 @@ jobs: - name: Save ~/.stack cache (Unix) uses: actions/cache/save@v3 id: cache-save-stack-global - if: runner.os == 'Linux' || runner.os == 'macOS' + if: (runner.os == 'Linux' || runner.os == 'macOS') + && steps.cache-restore-stack-global-unix.outputs.cache-hit != 'true' with: path: ~/.stack key: ${{ steps.cache-restore-stack-global-unix.outputs.cache-primary-key }} From b024b6b527276a21df3969b4570319187396a093 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 25 Nov 2023 14:18:24 +0000 Subject: [PATCH 35/47] Update ChangeLog --- ChangeLog.md | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/ChangeLog.md b/ChangeLog.md index 341ac1f..5e6fb45 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,9 +2,18 @@ ## Unreleased changes +## [v0.2.0.0](https://github.com/rasheedja/LPPaver/tree/v0.2.0.0) + - Setup CI - Use fourmolu formatter -- Switch to Cabal +- Add better types +- Use lens +- Use RecordDot syntax +- Add logging +- Improve Docs +- More Tests +- Bump Stackage LTS +- Rename Linear.Simplex.Simplex -> Linear.Simplex.TwoPhase.Simplex ## [v0.1.0.0](https://github.com/rasheedja/LPPaver/tree/v0.1.0.0) From 38b55a27d455194360fa19e3aa357e4889502084 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 25 Nov 2023 14:19:21 +0000 Subject: [PATCH 36/47] Update copyright dates --- LICENSE | 2 +- src/Linear/Simplex/Prettify.hs | 2 +- src/Linear/Simplex/Solver/TwoPhase.hs | 2 +- src/Linear/Simplex/Types.hs | 2 +- src/Linear/Simplex/Util.hs | 2 +- 5 files changed, 5 insertions(+), 5 deletions(-) diff --git a/LICENSE b/LICENSE index ca254af..f0aec98 100644 --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Junaid Rasheed (c) 2020-2022 +Copyright Junaid Rasheed (c) 2020-2023 All rights reserved. diff --git a/src/Linear/Simplex/Prettify.hs b/src/Linear/Simplex/Prettify.hs index 0aff555..b19cc44 100644 --- a/src/Linear/Simplex/Prettify.hs +++ b/src/Linear/Simplex/Prettify.hs @@ -4,7 +4,7 @@ -- | -- Module : Linear.Simplex.Prettify -- Description : Prettifier for "Linear.Simplex.Types" types --- Copyright : (c) Junaid Rasheed, 2020-2022 +-- Copyright : (c) Junaid Rasheed, 2020-2023 -- License : BSD-3 -- Maintainer : jrasheed178@gmail.com -- Stability : experimental diff --git a/src/Linear/Simplex/Solver/TwoPhase.hs b/src/Linear/Simplex/Solver/TwoPhase.hs index 4c827ea..c7dfe83 100644 --- a/src/Linear/Simplex/Solver/TwoPhase.hs +++ b/src/Linear/Simplex/Solver/TwoPhase.hs @@ -1,7 +1,7 @@ -- | -- Module : Linear.Simplex.Simplex.TwoPhase -- Description : Implements the twoPhaseSimplex method --- Copyright : (c) Junaid Rasheed, 2020-2022 +-- Copyright : (c) Junaid Rasheed, 2020-2023 -- License : BSD-3 -- Maintainer : jrasheed178@gmail.com -- Stability : experimental diff --git a/src/Linear/Simplex/Types.hs b/src/Linear/Simplex/Types.hs index 9dd201e..5ea9019 100644 --- a/src/Linear/Simplex/Types.hs +++ b/src/Linear/Simplex/Types.hs @@ -1,7 +1,7 @@ -- | -- Module : Linear.Simplex.Types -- Description : Custom types --- Copyright : (c) Junaid Rasheed, 2020-2022 +-- Copyright : (c) Junaid Rasheed, 2020-2023 -- License : BSD-3 -- Maintainer : jrasheed178@gmail.com -- Stability : experimental diff --git a/src/Linear/Simplex/Util.hs b/src/Linear/Simplex/Util.hs index 527c005..99b1495 100644 --- a/src/Linear/Simplex/Util.hs +++ b/src/Linear/Simplex/Util.hs @@ -1,7 +1,7 @@ -- | -- Module : Linear.Simplex.Util -- Description : Helper functions --- Copyright : (c) Junaid Rasheed, 2020-2022 +-- Copyright : (c) Junaid Rasheed, 2020-2023 -- License : BSD-3 -- Maintainer : jrasheed178@gmail.com -- Stability : experimental From 8a9e15b11596fa96a06731f85b9fd76d1bf0832b Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 20 Apr 2024 15:48:44 +0100 Subject: [PATCH 37/47] wip --- README.md | 22 +- package.yaml | 8 +- simplex-method.cabal | 19 +- src/Linear/Simplex/DeriveBounds.hs | 112 +++ src/Linear/Simplex/Prettify.hs | 10 +- src/Linear/Simplex/Solver/TwoPhase.hs | 138 ++-- src/Linear/Simplex/Standardize.hs | 13 + src/Linear/Simplex/Types.hs | 490 +++++++++++- src/Linear/Simplex/Util.hs | 104 +-- test/Linear/Simplex/TypesSpec.hs | 541 +++++++++++++ test/Spec.hs | 43 +- test/TestFunctions.hs | 1048 ------------------------- 12 files changed, 1310 insertions(+), 1238 deletions(-) create mode 100644 src/Linear/Simplex/DeriveBounds.hs create mode 100644 src/Linear/Simplex/Standardize.hs create mode 100644 test/Linear/Simplex/TypesSpec.hs delete mode 100644 test/TestFunctions.hs diff --git a/README.md b/README.md index f391970..705c1be 100644 --- a/README.md +++ b/README.md @@ -11,15 +11,15 @@ The `Linear.Simplex.Solver.TwoPhase` module contain both phases of the two-phase Phase one is implemented by `findFeasibleSolution`: ```haskell -findFeasibleSolution :: [PolyConstraint] -> Maybe (DictionaryForm, [Integer], [Integer], Integer) +findFeasibleSolution :: [StandardConstraint] -> Maybe (DictionaryForm, [Integer], [Integer], Integer) ``` -`findFeasibleSolution` takes a list of `PolyConstraint`s. -The `PolyConstraint` type, as well as other custom types required by this library, are defined in the `Linear.Simplex.Types` module. -`PolyConstraint` is defined as: +`findFeasibleSolution` takes a list of `StandardConstraint`s. +The `StandardConstraint` type, as well as other custom types required by this library, are defined in the `Linear.Simplex.Types` module. +`StandardConstraint` is defined as: ```haskell -data PolyConstraint = +data StandardConstraint = LEQ Vars Rational | GEQ Vars Rational | EQ Vars Rational deriving (Show, Eq); @@ -34,11 +34,11 @@ type Vars = [(Integer, Rational)] A `Vars` is treated as a list of `Integer` variables mapped to their `Rational` coefficients, with an implicit `+` between each element in the list. For example: `[(1, 2), (2, (-3)), (1, 3)]` is equivalent to `(2x1 + (-3x2) + 3x1)`. -And a `PolyConstraint` is an inequality/equality where the LHS is a `Vars` and the RHS is a `Rational`. +And a `StandardConstraint` is an inequality/equality where the LHS is a `Vars` and the RHS is a `Rational`. For example: `LEQ [(1, 2), (2, (-3)), (1, 3)] 60` is equivalent to `(2x1 + (-3x2) + 3x1) <= 60`. -Passing a `[PolyConstraint]` to `findFeasibleSolution` will return a feasible solution if it exists as well as a list of slack variables, artificial variables, and a variable that can be safely used to represent the objective for phase two. -`Nothing` is returned if the given `[PolyConstraint]` is infeasible. +Passing a `[StandardConstraint]` to `findFeasibleSolution` will return a feasible solution if it exists as well as a list of slack variables, artificial variables, and a variable that can be safely used to represent the objective for phase two. +`Nothing` is returned if the given `[StandardConstraint]` is infeasible. The feasible system is returned as the type `DictionaryForm`: ```haskell @@ -70,7 +70,7 @@ If a variable is not in this list, the variable is equal to 0. It has the type: ```haskell -twoPhaseSimplex :: ObjectiveFunction -> [PolyConstraint] -> Maybe (Integer, [(Integer, Rational)]) +twoPhaseSimplex :: ObjectiveFunction -> [StandardConstraint] -> Maybe (Integer, [(Integer, Rational)]) ``` The return type is the same as that of `optimizeFeasibleSystem` @@ -93,7 +93,7 @@ This implementation assumes that the user only provides positive `Integer` varia ## Example ```haskell -exampleFunction :: (ObjectiveFunction, [PolyConstraint]) +exampleFunction :: (ObjectiveFunction, [StandardConstraint]) exampleFunction = ( Max [(1, 3), (2, 5)], -- 3x1 + 5x2 @@ -122,7 +122,7 @@ Just ``` There are many more examples in test/TestFunctions.hs. -You may use `prettyShowVarConstMap`, `prettyShowPolyConstraint`, and `prettyShowObjectiveFunction` to convert these tests into a more human-readable format. +You may use `prettyShowVarConstMap`, `prettyShowStandardConstraint`, and `prettyShowObjectiveFunction` to convert these tests into a more human-readable format. ## Issues diff --git a/package.yaml b/package.yaml index b45be0d..8aadf2d 100644 --- a/package.yaml +++ b/package.yaml @@ -27,11 +27,14 @@ dependencies: - monad-logger >= 0.3.40 && < 0.4 - text >= 2.0.2 && < 2.1 - time +- hspec +- QuickCheck default-extensions: DataKinds DeriveFunctor DeriveGeneric + DerivingStrategies DisambiguateRecordFields DuplicateRecordFields FlexibleContexts @@ -50,7 +53,8 @@ library: tests: simplex-haskell-test: - main: Spec.hs - source-dirs: test + defaults: hspec/hspec@main dependencies: - simplex-method + - hspec + - QuickCheck diff --git a/simplex-method.cabal b/simplex-method.cabal index fc9f040..1f3c4a8 100644 --- a/simplex-method.cabal +++ b/simplex-method.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.1. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack @@ -27,8 +27,10 @@ source-repository head library exposed-modules: + Linear.Simplex.DeriveBounds Linear.Simplex.Prettify Linear.Simplex.Solver.TwoPhase + Linear.Simplex.Standardize Linear.Simplex.Types Linear.Simplex.Util other-modules: @@ -36,11 +38,13 @@ library hs-source-dirs: src default-extensions: - DataKinds DeriveFunctor DeriveGeneric DisambiguateRecordFields DuplicateRecordFields FlexibleContexts LambdaCase OverloadedLabels OverloadedRecordDot OverloadedStrings RecordWildCards TemplateHaskell TupleSections TypeApplications NamedFieldPuns + DataKinds DeriveFunctor DeriveGeneric DerivingStrategies DisambiguateRecordFields DuplicateRecordFields FlexibleContexts LambdaCase OverloadedLabels OverloadedRecordDot OverloadedStrings RecordWildCards TemplateHaskell TupleSections TypeApplications NamedFieldPuns build-depends: - base >=4.14 && <5 + QuickCheck + , base >=4.14 && <5 , containers >=0.6.5.1 && <0.7 , generic-lens >=2.2.0 && <2.3 + , hspec , lens >=5.2.2 && <5.3 , monad-logger >=0.3.40 && <0.4 , text >=2.0.2 && <2.1 @@ -51,19 +55,22 @@ test-suite simplex-haskell-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: - TestFunctions + Linear.Simplex.TypesSpec Paths_simplex_method hs-source-dirs: test default-extensions: - DataKinds DeriveFunctor DeriveGeneric DisambiguateRecordFields DuplicateRecordFields FlexibleContexts LambdaCase OverloadedLabels OverloadedRecordDot OverloadedStrings RecordWildCards TemplateHaskell TupleSections TypeApplications NamedFieldPuns + DataKinds DeriveFunctor DeriveGeneric DerivingStrategies DisambiguateRecordFields DuplicateRecordFields FlexibleContexts LambdaCase OverloadedLabels OverloadedRecordDot OverloadedStrings RecordWildCards TemplateHaskell TupleSections TypeApplications NamedFieldPuns build-depends: - base >=4.14 && <5 + QuickCheck + , base >=4.14 && <5 , containers >=0.6.5.1 && <0.7 , generic-lens >=2.2.0 && <2.3 + , hspec , lens >=5.2.2 && <5.3 , monad-logger >=0.3.40 && <0.4 , simplex-method , text >=2.0.2 && <2.1 , time default-language: Haskell2010 + build-tool-depends: hspec-discover:hspec-discover == 2.* diff --git a/src/Linear/Simplex/DeriveBounds.hs b/src/Linear/Simplex/DeriveBounds.hs new file mode 100644 index 0000000..867aaab --- /dev/null +++ b/src/Linear/Simplex/DeriveBounds.hs @@ -0,0 +1,112 @@ +module Linear.Simplex.DeriveBounds where + +import Prelude hiding (EQ) + +import Control.Applicative (liftA2) +import Control.Lens hiding (Const) +import Data.Generics.Labels () +import Data.List (sort) +import GHC.Generics (Generic) + +import Linear.Simplex.Types + +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (isNothing, fromMaybe) + +-- | Update the bounds for a variable in the map via intersection +updateBounds :: Var -> Bounds -> Map Var Bounds -> Map Var Bounds +updateBounds var newBounds boundsMap = + let existingBounds = Map.findWithDefault (Bounds Nothing Nothing) var boundsMap + updatedBounds = combineBounds newBounds existingBounds + in Map.insert var updatedBounds boundsMap + +-- Intersection of two bounds +combineBounds :: Bounds -> Bounds -> Bounds +combineBounds newBounds existingBounds = do + let newLowerBound = + case (newBounds.lowerBound, existingBounds.lowerBound) of + (Just newLowerBound, Just existingLowerBound) -> Just $ max newLowerBound existingLowerBound + (_, Just existingLowerBound) -> Just existingLowerBound + (Just newLowerBound, _) -> Just newLowerBound + (_, _) -> Nothing + let newUpperBound = + case (newBounds.upperBound, existingBounds.upperBound) of + (Just newUpperBound, Just existingUpperBound) -> Just $ max newUpperBound existingUpperBound + (_, Just existingUpperBound) -> Just existingUpperBound + (Just newUpperBound, _) -> Just newUpperBound + (_, _) -> Nothing + Bounds newLowerBound newUpperBound + +-- Helper to recursively analyze expressions and derive bounds +-- deriveBoundsFromExpr :: Expr -> Bounds -> (Var -> Bounds -> Map Var Bounds -> Map Var Bounds) +-- deriveBoundsFromExpr (Var v) bounds accMap = updateBounds v bounds accMap +-- deriveBoundsFromExpr (Const c) _ accMap = accMap +-- deriveBoundsFromExpr (e1 :+ e2) bounds accMap = +-- deriveBoundsFromExpr e1 bounds $ deriveBoundsFromExpr e2 bounds accMap +-- deriveBoundsFromExpr (e1 :-: e2) bounds accMap = +-- deriveBoundsFromExpr e1 bounds $ deriveBoundsFromExpr e2 bounds accMap +-- deriveBoundsFromExpr (e1 :*: e2) bounds accMap = +-- deriveBoundsFromExpr e1 bounds $ deriveBoundsFromExpr e2 bounds accMap +-- deriveBoundsFromExpr (e1 :/: e2) bounds accMap = +-- deriveBoundsFromExpr e1 bounds $ deriveBoundsFromExpr e2 bounds accMap + +-- Function to derive bounds from a single constraint for a variable +deriveVarBoundsFromConstraint :: Constraint -> Map Var Bounds -> Map Var Bounds +-- deriveVarBoundsFromConstraint (Var v :<=: Const u) accMap = updateBounds v (Bounds Nothing (Just u)) accMap +-- deriveVarBoundsFromConstraint (Var v :>=: Const l) accMap = updateBounds v (Bounds (Just l) Nothing) accMap +-- deriveVarBoundsFromConstraint (Var v :==: Const c) accMap = updateBounds v (Bounds (Just c) (Just c)) accMap +deriveVarBoundsFromConstraint _ accMap = accMap -- Ignore non-constant expressions + +-- Function to derive bounds for all variables in the constraints list +deriveBounds :: [Constraint] -> Map Var Bounds +deriveBounds constraints = foldr deriveVarBoundsFromConstraint Map.empty constraints + +-- data Bounds = Bounds +-- { lowerBound :: Maybe SimplexNum +-- , upperBound :: Maybe SimplexNum +-- } +-- deriving (Show, Read, Eq, Generic) + +validateBounds :: Map Var Bounds -> Bool +validateBounds boundsMap = all soundBounds $ Map.toList boundsMap + where + soundBounds (_, Bounds lowerBound upperBound) = + case (lowerBound, upperBound) of + (Just l, Just u) -> l <= u + (_, _) -> True + + +type AuxVarMap = Map.Map Var (Var, Var) + +splitNegativeVars :: Map Var Bounds -> (Map Var Bounds, AuxVarMap) +splitNegativeVars boundsMap = + let (newBoundsMap, auxMap, _) = Map.foldrWithKey splitVar (Map.empty, Map.empty, Map.size boundsMap + 1) boundsMap + in (newBoundsMap, auxMap) + where + splitVar var (Bounds lowerBound upperBound) (newBoundsMap, auxMap, nextVar) = + if fromMaybe (-1) lowerBound < 0 + then let var1 = nextVar + var2 = nextVar + 1 + newBounds = Bounds (Just 0) Nothing + in (Map.insert var1 newBounds $ Map.insert var2 newBounds newBoundsMap, + Map.insert var (var1, var2) auxMap, + nextVar + 2) + else (Map.insert var (Bounds lowerBound upperBound) newBoundsMap, auxMap, nextVar) + +-- PLAN: + +-- Accept systems with any kind of constraints (<=, >=, ==) +-- Identify all variables in the system and their bounds +-- For any variable with negative/unbounded lower bound, split it into two variables with lower bound 0 +-- So, say x has lower bound -1, then we split it into x1 and x2, where x1 >= 0 and x2 >= 0 +-- Then substitute x with x1 - x2 in all constraints +-- All variables now have non-negative lower bounds +-- Now, we proceed with the remaining transformations +-- Slack variables are introduced for all constraints +-- Artificial variables are introduced for all constraints with equality +-- and so on until we have a system in the standard form + +-- Maybe have a type for the standard system? It would be a list of linear equalities with a constant on the RHS +-- All variables >= 0 can be assumed, doesn't need to be in the type +-- The objective function can be considered separate, so not part of the standard system type? \ No newline at end of file diff --git a/src/Linear/Simplex/Prettify.hs b/src/Linear/Simplex/Prettify.hs index b19cc44..8536e89 100644 --- a/src/Linear/Simplex/Prettify.hs +++ b/src/Linear/Simplex/Prettify.hs @@ -32,11 +32,11 @@ prettyShowVarConstMap = aux . M.toList where r' = if denominator r == 1 then show (numerator r) else show (numerator r) ++ " / " ++ show (numerator r) --- | Convert a 'PolyConstraint' into a human-readable 'String' -prettyShowPolyConstraint :: PolyConstraint -> String -prettyShowPolyConstraint (LEQ vcm r) = prettyShowVarConstMap vcm ++ " <= " ++ show r -prettyShowPolyConstraint (GEQ vcm r) = prettyShowVarConstMap vcm ++ " >= " ++ show r -prettyShowPolyConstraint (Linear.Simplex.Types.EQ vcm r) = prettyShowVarConstMap vcm ++ " == " ++ show r +-- | Convert a 'StandardConstraint' into a human-readable 'String' +-- prettyShowStandardConstraint :: StandardConstraint -> String +-- prettyShowStandardConstraint (LEQ vcm r) = prettyShowVarConstMap vcm ++ " <= " ++ show r +-- prettyShowStandardConstraint (GEQ vcm r) = prettyShowVarConstMap vcm ++ " >= " ++ show r +-- prettyShowStandardConstraint (Linear.Simplex.Types.EQ vcm r) = prettyShowVarConstMap vcm ++ " == " ++ show r -- | Convert an 'ObjectiveFunction' into a human-readable 'String' prettyShowObjectiveFunction :: ObjectiveFunction -> String diff --git a/src/Linear/Simplex/Solver/TwoPhase.hs b/src/Linear/Simplex/Solver/TwoPhase.hs index c7dfe83..b1ddb4d 100644 --- a/src/Linear/Simplex/Solver/TwoPhase.hs +++ b/src/Linear/Simplex/Solver/TwoPhase.hs @@ -28,11 +28,11 @@ import GHC.Real (Ratio) import Linear.Simplex.Types import Linear.Simplex.Util --- | Find a feasible solution for the given system of 'PolyConstraint's by performing the first phase of the two-phase simplex method --- All variables in the 'PolyConstraint' must be positive. +-- | Find a feasible solution for the given system of 'StandardConstraint's by performing the first phase of the two-phase simplex method +-- All variables in the 'StandardConstraint' must be positive. -- If the system is infeasible, return 'Nothing' -- Otherwise, return the feasible system in 'Dict' as well as a list of slack variables, a list artificial variables, and the objective variable. -findFeasibleSolution :: (MonadIO m, MonadLogger m) => [PolyConstraint] -> m (Maybe FeasibleSystem) +findFeasibleSolution :: (MonadIO m, MonadLogger m) => [StandardConstraint] -> m (Maybe FeasibleSystem) findFeasibleSolution unsimplifiedSystem = do logMsg LevelInfo $ "findFeasibleSolution: Looking for solution for " <> showT unsimplifiedSystem if null artificialVars -- No artificial vars, we have a feasible system @@ -121,17 +121,19 @@ findFeasibleSolution unsimplifiedSystem = do <> showT systemWithBasicVarsAsDictionary pure Nothing where + simplifySystem = undefined + system = simplifySystem unsimplifiedSystem - maxVar = - maximum $ - map - ( \case - LEQ vcm _ -> maximum (map fst $ M.toList vcm) - GEQ vcm _ -> maximum (map fst $ M.toList vcm) - EQ vcm _ -> maximum (map fst $ M.toList vcm) - ) - system + maxVar = undefined + -- maximum $ + -- map + -- ( \case + -- LEQ vcm _ -> maximum (map fst $ M.toList vcm) + -- GEQ vcm _ -> maximum (map fst $ M.toList vcm) + -- EQ vcm _ -> maximum (map fst $ M.toList vcm) + -- ) + -- system (systemWithSlackVars, slackVars) = systemInStandardForm system maxVar [] @@ -147,76 +149,76 @@ findFeasibleSolution unsimplifiedSystem = do objectiveVar = finalMaxVar + 1 - -- Convert a system of 'PolyConstraint's to standard form; a system of only equations ('EQ'). + -- Convert a system of 'StandardConstraint's to standard form; a system of only equations ('EQ'). -- Add slack vars where necessary. -- This may give you an infeasible system if slack vars are negative when original variables are zero. -- If a constraint is already EQ, set the basic var to Nothing. -- Final system is a list of equalities for the given system. -- To be feasible, all vars must be >= 0. - systemInStandardForm :: [PolyConstraint] -> Var -> [Var] -> ([(Maybe Var, PolyConstraint)], [Var]) + systemInStandardForm :: [StandardConstraint] -> Var -> [Var] -> ([(Maybe Var, StandardConstraint)], [Var]) systemInStandardForm [] _ sVars = ([], sVars) - systemInStandardForm (EQ v r : xs) maxVar sVars = ((Nothing, EQ v r) : newSystem, newSlackVars) - where - (newSystem, newSlackVars) = systemInStandardForm xs maxVar sVars - systemInStandardForm (LEQ v r : xs) maxVar sVars = ((Just newSlackVar, EQ (M.insert newSlackVar 1 v) r) : newSystem, newSlackVars) - where - newSlackVar = maxVar + 1 - (newSystem, newSlackVars) = systemInStandardForm xs newSlackVar (newSlackVar : sVars) - systemInStandardForm (GEQ v r : xs) maxVar sVars = ((Just newSlackVar, EQ (M.insert newSlackVar (-1) v) r) : newSystem, newSlackVars) - where - newSlackVar = maxVar + 1 - (newSystem, newSlackVars) = systemInStandardForm xs newSlackVar (newSlackVar : sVars) + -- systemInStandardForm (EQ v r : xs) maxVar sVars = ((Nothing, EQ v r) : newSystem, newSlackVars) + -- where + -- (newSystem, newSlackVars) = systemInStandardForm xs maxVar sVars + -- systemInStandardForm (LEQ v r : xs) maxVar sVars = ((Just newSlackVar, EQ (M.insert newSlackVar 1 v) r) : newSystem, newSlackVars) + -- where + -- newSlackVar = maxVar + 1 + -- (newSystem, newSlackVars) = systemInStandardForm xs newSlackVar (newSlackVar : sVars) + -- systemInStandardForm (GEQ v r : xs) maxVar sVars = ((Just newSlackVar, EQ (M.insert newSlackVar (-1) v) r) : newSystem, newSlackVars) + -- where + -- newSlackVar = maxVar + 1 + -- (newSystem, newSlackVars) = systemInStandardForm xs newSlackVar (newSlackVar : sVars) - -- Add artificial vars to a system of 'PolyConstraint's. + -- Add artificial vars to a system of 'StandardConstraint's. -- Artificial vars are added when: -- Basic var is Nothing (When the original constraint was already an EQ). -- Slack var is equal to a negative value (this is infeasible, all vars need to be >= 0). -- Final system will be a feasible artificial system. -- We keep track of artificial vars in the second item of the returned pair so they can be eliminated once phase 1 is complete. -- If an artificial var would normally be negative, we negate the row so we can keep artificial variables equal to 1 - systemWithArtificialVars :: [(Maybe Var, PolyConstraint)] -> Var -> (Tableau, [Var]) + systemWithArtificialVars :: [(Maybe Var, StandardConstraint)] -> Var -> (Tableau, [Var]) systemWithArtificialVars [] _ = (M.empty, []) - systemWithArtificialVars ((mVar, EQ v r) : pcs) maxVar = - case mVar of - Nothing -> - if r >= 0 - then - ( M.insert newArtificialVar (TableauRow {lhs = M.insert newArtificialVar 1 v, rhs = r}) newSystemWithNewMaxVar - , newArtificialVar : artificialVarsWithNewMaxVar - ) - else - ( M.insert newArtificialVar (TableauRow {lhs = M.insert newArtificialVar (-1) v, rhs = r}) newSystemWithNewMaxVar - , newArtificialVar : artificialVarsWithNewMaxVar - ) - Just basicVar -> - case M.lookup basicVar v of - Just basicVarCoeff -> - if r == 0 - then (M.insert basicVar (TableauRow {lhs = v, rhs = r}) newSystemWithoutNewMaxVar, artificialVarsWithoutNewMaxVar) - else - if r > 0 - then - if basicVarCoeff >= 0 -- Should only be 1 in the standard call path - then (M.insert basicVar (TableauRow {lhs = v, rhs = r}) newSystemWithoutNewMaxVar, artificialVarsWithoutNewMaxVar) - else - ( M.insert newArtificialVar (TableauRow {lhs = M.insert newArtificialVar 1 v, rhs = r}) newSystemWithNewMaxVar - , newArtificialVar : artificialVarsWithNewMaxVar -- Slack var is negative, r is positive (when original constraint was GEQ) - ) - else -- r < 0 + -- systemWithArtificialVars ((mVar, EQ v r) : pcs) maxVar = + -- case mVar of + -- Nothing -> + -- if r >= 0 + -- then + -- ( M.insert newArtificialVar (TableauRow {lhs = M.insert newArtificialVar 1 v, rhs = r}) newSystemWithNewMaxVar + -- , newArtificialVar : artificialVarsWithNewMaxVar + -- ) + -- else + -- ( M.insert newArtificialVar (TableauRow {lhs = M.insert newArtificialVar (-1) v, rhs = r}) newSystemWithNewMaxVar + -- , newArtificialVar : artificialVarsWithNewMaxVar + -- ) + -- Just basicVar -> + -- case M.lookup basicVar v of + -- Just basicVarCoeff -> + -- if r == 0 + -- then (M.insert basicVar (TableauRow {lhs = v, rhs = r}) newSystemWithoutNewMaxVar, artificialVarsWithoutNewMaxVar) + -- else + -- if r > 0 + -- then + -- if basicVarCoeff >= 0 -- Should only be 1 in the standard call path + -- then (M.insert basicVar (TableauRow {lhs = v, rhs = r}) newSystemWithoutNewMaxVar, artificialVarsWithoutNewMaxVar) + -- else + -- ( M.insert newArtificialVar (TableauRow {lhs = M.insert newArtificialVar 1 v, rhs = r}) newSystemWithNewMaxVar + -- , newArtificialVar : artificialVarsWithNewMaxVar -- Slack var is negative, r is positive (when original constraint was GEQ) + -- ) + -- else -- r < 0 - if basicVarCoeff <= 0 -- Should only be -1 in the standard call path - then (M.insert basicVar (TableauRow {lhs = v, rhs = r}) newSystemWithoutNewMaxVar, artificialVarsWithoutNewMaxVar) - else - ( M.insert newArtificialVar (TableauRow {lhs = M.insert newArtificialVar (-1) v, rhs = r}) newSystemWithNewMaxVar - , newArtificialVar : artificialVarsWithNewMaxVar -- Slack var is negative, r is negative (when original constraint was LEQ) - ) - Nothing -> error "1" -- undefined - where - newArtificialVar = maxVar + 1 + -- if basicVarCoeff <= 0 -- Should only be -1 in the standard call path + -- then (M.insert basicVar (TableauRow {lhs = v, rhs = r}) newSystemWithoutNewMaxVar, artificialVarsWithoutNewMaxVar) + -- else + -- ( M.insert newArtificialVar (TableauRow {lhs = M.insert newArtificialVar (-1) v, rhs = r}) newSystemWithNewMaxVar + -- , newArtificialVar : artificialVarsWithNewMaxVar -- Slack var is negative, r is negative (when original constraint was LEQ) + -- ) + -- Nothing -> error "1" -- undefined + -- where + -- newArtificialVar = maxVar + 1 - (newSystemWithNewMaxVar, artificialVarsWithNewMaxVar) = systemWithArtificialVars pcs newArtificialVar + -- (newSystemWithNewMaxVar, artificialVarsWithNewMaxVar) = systemWithArtificialVars pcs newArtificialVar - (newSystemWithoutNewMaxVar, artificialVarsWithoutNewMaxVar) = systemWithArtificialVars pcs maxVar + -- (newSystemWithoutNewMaxVar, artificialVarsWithoutNewMaxVar) = systemWithArtificialVars pcs maxVar systemWithArtificialVars _ _ = error "systemWithArtificialVars: given system includes non-EQ constraints" -- \| Takes a 'Dict' and a '[Var]' as input and returns a 'PivotObjective'. @@ -376,11 +378,11 @@ optimizeFeasibleSystem objFunction fsys@(FeasibleSystem {dict = phase1Dict, ..}) ) (M.toList objFunction.objective) --- | Perform the two phase simplex method with a given 'ObjectiveFunction' a system of 'PolyConstraint's. --- Assumes the 'ObjectiveFunction' and 'PolyConstraint' is not empty. +-- | Perform the two phase simplex method with a given 'ObjectiveFunction' a system of 'StandardConstraint's. +-- Assumes the 'ObjectiveFunction' and 'StandardConstraint' is not empty. -- Returns a pair with the first item being the 'Integer' variable equal to the 'ObjectiveFunction' -- and the second item being a map of the values of all 'Integer' variables appearing in the system, including the 'ObjectiveFunction'. -twoPhaseSimplex :: (MonadIO m, MonadLogger m) => ObjectiveFunction -> [PolyConstraint] -> m (Maybe Result) +twoPhaseSimplex :: (MonadIO m, MonadLogger m) => ObjectiveFunction -> [StandardConstraint] -> m (Maybe Result) twoPhaseSimplex objFunction unsimplifiedSystem = do logMsg LevelInfo $ "twoPhaseSimplex: Solving system " <> showT unsimplifiedSystem <> " with objective " <> showT objFunction diff --git a/src/Linear/Simplex/Standardize.hs b/src/Linear/Simplex/Standardize.hs new file mode 100644 index 0000000..e39d461 --- /dev/null +++ b/src/Linear/Simplex/Standardize.hs @@ -0,0 +1,13 @@ +module Linear.Simplex.Standardize where + +import Control.Lens +import Data.Generics.Labels () +import Data.List (sort) +import qualified Data.Map as M +import GHC.Generics (Generic) + +import Linear.Simplex.Types + +-- Add slack vars, need type of system with only equalities + +-- Add artificial vars, can we type check this somehow? Maybe with a phantom type? Is Tableau enough? diff --git a/src/Linear/Simplex/Types.hs b/src/Linear/Simplex/Types.hs index 5ea9019..f07f005 100644 --- a/src/Linear/Simplex/Types.hs +++ b/src/Linear/Simplex/Types.hs @@ -7,19 +7,486 @@ -- Stability : experimental module Linear.Simplex.Types where -import Control.Lens +import Control.Lens hiding (Const) import Data.Generics.Labels () -import Data.List (sort) +import qualified Data.Set as Set +import qualified Data.List as L +import qualified Data.List.NonEmpty as NE import qualified Data.Map as M import GHC.Generics (Generic) +import Control.Applicative ((<|>)) +import GHC.Base (liftA2) -type Var = Int +import Test.QuickCheck (Arbitrary(..), genericShrink, oneof) + +import qualified Debug.Trace as T + +-- Inputs: +-- linear expressions (>=,<=,==) linear expressions +-- Transformed into: +-- linear expressions (>=,<=,==) rational + +data Term = ConstTerm SimplexNum | CoeffTerm SimplexNum Var | VarTerm Var -- Consider VarTerm Var - note, we must consider normalizing this: Considered. It makes going to standard form easier due to type safety + deriving (Show, Read, Eq, Ord, Generic) + +instance Arbitrary Term where + arbitrary = oneof [ ConstTerm <$> arbitrary + , CoeffTerm <$> arbitrary <*> arbitrary + , VarTerm <$> arbitrary + ] + + shrink = genericShrink + +-- TODO: Test each function when reasonable +simplifyTerm :: Term -> Term +simplifyTerm (CoeffTerm 0 _) = ConstTerm 0 +simplifyTerm (CoeffTerm 1 v) = VarTerm v +simplifyTerm t = t + +negateTerm :: Term -> Term +negateTerm (ConstTerm c) = ConstTerm (-c) +negateTerm (CoeffTerm (-1) v) = VarTerm v +negateTerm (CoeffTerm c v) = CoeffTerm (-c) v +negateTerm (VarTerm v) = CoeffTerm (-1) v + +-- Consider [Term] +data Expr = Expr Term | Expr :+ Term -- | Expr :+ Expr + deriving (Show, Read, Eq, Generic) + +instance Arbitrary Expr where + arbitrary = oneof [ Expr <$> arbitrary + , liftA2 (:+) arbitrary arbitrary + ] + + shrink = genericShrink + +-- | Convert an 'Expr' to a list of 'Term's. +exprToList :: Expr -> [Term] +exprToList (Expr t) = [t] +exprToList (e :+ t) = exprToList e ++ [t] + +-- | Convert a list of 'Term's to an 'Expr'. +listToExpr :: [Term] -> Expr +listToExpr [] = Expr $ ConstTerm 0 +listToExpr (t : ts) = foldl (:+) (Expr t) ts + +-- expr: (Expr (CoeffTerm (1 % 1) 0) :+ CoeffTerm (1 % 2) (-1)) :+ CoeffTerm (2 % 1) (-1) +-- 1 = x +-- -1 = y +-- 1x + 0.5y + 2y +-- simplifiedExpr: (Expr (CoeffTerm (1 % 2) (-1)) :+ CoeffTerm (2 % 1) (-1)) :+ VarTerm 0 +-- 0.5y + 2y + x +-- simplifiedTwiceExpr: Expr (CoeffTerm (5 % 2) (-1)) :+ VarTerm 0 +-- 2.5y + x + +-- | Normalize a list of 'Term's where each term is added together. +normalizeTerms :: [Term] -> [Term] +normalizeTerms = L.sort . map simplifyTerm . combineTerms . L.sortBy orderForCombineTerms . map (varToCoeff . simplifyTerm) + where + orderForCombineTerms :: Term -> Term -> Ordering + orderForCombineTerms _ (VarTerm _) = error "Unexpected VarTerm in orderForCombineTerms" + orderForCombineTerms (VarTerm _) _ = error "Unexpected VarTerm in orderForCombineTerms" + orderForCombineTerms (ConstTerm c1) (ConstTerm c2) = compare c1 c2 + orderForCombineTerms (CoeffTerm c1 v1) (CoeffTerm c2 v2) = + case compare v1 v2 of + EQ -> compare c1 c2 + x -> x + orderForCombineTerms (ConstTerm _) (CoeffTerm _ _) = LT + orderForCombineTerms (CoeffTerm _ _) (ConstTerm _) = GT + + varToCoeff :: Term -> Term + varToCoeff (VarTerm v) = CoeffTerm 1 v + varToCoeff t = t + + combineTerms :: [Term] -> [Term] + combineTerms [] = [] + combineTerms [ConstTerm 0] = [] + combineTerms [CoeffTerm 0 _] = [] + combineTerms [x] = [x] + combineTerms allXs@(x1 : x2 : xs) = + -- T.trace (show allXs) $ + case (x1, x2) of + (ConstTerm 0, _) -> combineTerms (x2 : xs) + (_, ConstTerm 0) -> combineTerms (x1 : xs) + (CoeffTerm 0 _, _) -> combineTerms (x2 : xs) + (_, CoeffTerm 0 _) -> combineTerms (x1 : xs) + (ConstTerm c1, ConstTerm c2) -> if c1 + c2 == 0 then combineTerms xs else combineTerms (ConstTerm (c1 + c2) : xs) + (CoeffTerm c1 v1, CoeffTerm c2 v2) -> + if v1 == v2 + then combineTerms (CoeffTerm (c1 + c2) v1 : xs) + else x1 : combineTerms (x2 : xs) + _ -> x1 : combineTerms (x2 : xs) + +simplifyExpr :: Expr -> Expr +simplifyExpr = listToExpr . normalizeTerms . exprToList + +sumExprConstTerms :: Expr -> SimplexNum +sumExprConstTerms (Expr (ConstTerm c)) = c +sumExprConstTerms (Expr (CoeffTerm _ _)) = 0 +sumExprConstTerms (Expr (VarTerm _)) = 0 +sumExprConstTerms (e :+ t) = sumExprConstTerms e + sumExprConstTerms (Expr t) + +zeroConstTerm :: Term -> Term +zeroConstTerm (ConstTerm _) = ConstTerm 0 +zeroConstTerm t = t + +zeroConstExpr :: Expr -> Expr +zeroConstExpr (Expr t) = Expr (zeroConstTerm t) +zeroConstExpr (e :+ t) = zeroConstExpr e :+ zeroConstTerm t + +negateExpr :: Expr -> Expr +negateExpr = listToExpr . map negateTerm . exprToList + +addExpr :: Expr -> Expr -> Expr +addExpr e1 e2 = + -- Safe as Expr :+ Term is the only constructor + simplifyExpr . listToExpr $ (exprToList e1 <> exprToList e2) +subtractExpr :: Expr -> Expr -> Expr +subtractExpr e1 e2 = addExpr e1 (negateExpr e2) + +substVarExpr :: Var -> Expr -> Expr -> Expr +substVarExpr var varReplacement = simplifyExpr . listToExpr . aux . exprToList + where + replacementTerms = exprToList varReplacement + + aux :: [Term] -> [Term] + aux [] = [] + aux (t : ts) = case t of + (VarTerm tV) -> if tV == var then aux ts ++ replacementTerms else t : aux ts + (CoeffTerm tC tV) -> + if tV == var + then + let newReplacementTerms = + map + ( + simplifyTerm + . + \case + (CoeffTerm rC rV) -> CoeffTerm (tC * rC) rV + (VarTerm rV) -> CoeffTerm tC rV + (ConstTerm rC) -> ConstTerm (tC * rC) + ) + replacementTerms + in aux ts ++ newReplacementTerms + else t : aux ts + (ConstTerm _) -> t : aux ts + +-- substVarExpr :: Var -> Expr -> Expr -> Expr +-- substVarExpr var varReplacement = simplifyExpr . listToExpr . aux . exprToList +-- where +-- replacementTerms = exprToList varReplacement + +-- aux :: [Term] -> [Term] +-- aux [] = [] +-- aux (t : ts) = case t of +-- (VarTerm tV) -> if tV == var then replacementTerms ++ aux ts else t : aux ts +-- (CoeffTerm tC tV) -> +-- if tV == var +-- then +-- let newReplacementTerms = +-- map +-- ( +-- simplifyTerm +-- . +-- \case +-- (CoeffTerm rC rV) -> CoeffTerm (tC * rC) rV +-- (VarTerm rV) -> CoeffTerm tC rV +-- (ConstTerm rC) -> ConstTerm (tC * rC) +-- ) +-- replacementTerms +-- in newReplacementTerms ++ aux ts +-- else t : aux ts +-- (ConstTerm _) -> t : aux ts + +-- 3x + 5y - 2z as a Expr +-- tmpVarTerm = Expr (CoeffTerm 1 3) :+ CoeffTerm 1 5 :+ CoeffTerm 1 (-2) + +-- data Expr = Var Var | Const SimplexNum | Expr :+ Expr | Expr :-: Expr | Expr :*: Expr | Expr :/: Expr +-- deriving (Show, Read, Eq, Generic) + +-- consider moving to a new file if we want people to be able to change this type SimplexNum = Rational -type SystemRow = PolyConstraint +data GenericConstraint a b = a :<= b | a :>= b | a :== b + deriving (Show, Read, Eq, Generic) + +instance (Arbitrary a, Arbitrary b) => Arbitrary (GenericConstraint a b) where + arbitrary = oneof [ liftA2 (:<=) arbitrary arbitrary + , liftA2 (:>=) arbitrary arbitrary + , liftA2 (:==) arbitrary arbitrary + ] + shrink = genericShrink + +getGenericConstraintLHS :: GenericConstraint a b -> a +getGenericConstraintLHS (a :<= _) = a +getGenericConstraintLHS (a :>= _) = a +getGenericConstraintLHS (a :== _) = a + +getGenericConstraintRHS :: GenericConstraint a b -> b +getGenericConstraintRHS (_ :<= b) = b +getGenericConstraintRHS (_ :>= b) = b +getGenericConstraintRHS (_ :== b) = b + +-- Input +type Constraint = GenericConstraint Expr Expr + +-- data TermsOnlyVars = VarTerm' Var | CoeffTerm' SimplexNum Var +-- deriving (Show, Read, Eq, Generic) +-- data ExprVarsOnly = ExprVarsOnly [TermsOnlyVars] + +-- Internal TODO: change to Terms :: [Term] or [Term] +-- consider a term type with only variables +-- then have another type SimpleConstraint = GenericConstraint TermsOnlyVars SimplexNum +type SimpleConstraint = GenericConstraint Expr SimplexNum + +substVarSimpleConstraint :: Var -> Expr -> SimpleConstraint -> SimpleConstraint +substVarSimpleConstraint var varReplacement (a :<= b) = substVarExpr var varReplacement a :<= b +substVarSimpleConstraint var varReplacement (a :>= b) = substVarExpr var varReplacement a :>= b +substVarSimpleConstraint var varReplacement (a :== b) = substVarExpr var varReplacement a :== b + +constraintToSimpleConstraint :: Constraint -> SimpleConstraint +constraintToSimpleConstraint constraint = + case constraint of + (a :<= b) -> uncurry (:<=) (calcLhsRhs a b) + (a :>= b) -> uncurry (:>=) (calcLhsRhs a b) + (a :== b) -> uncurry (:==) (calcLhsRhs a b) + where + calcLhsRhs a b = (lhs, rhs) + where + aConsts = sumExprConstTerms a + bConsts = sumExprConstTerms b + rhs = bConsts - aConsts + + aWithoutConst = simplifyExpr . zeroConstExpr $ a + bWithoutConst = simplifyExpr . zeroConstExpr $ b + + lhs = subtractExpr aWithoutConst bWithoutConst + calcRhs a b = rhs + where + aConsts = sumExprConstTerms a + bConsts = sumExprConstTerms b + rhs = bConsts - aConsts + + aWithoutConst = simplifyExpr . zeroConstExpr $ a + bWithoutConst = simplifyExpr . zeroConstExpr $ b + + lhs = subtractExpr aWithoutConst bWithoutConst + +-- normalize simple constraints by moving all constants to the right +normalizeSimpleConstraint :: SimpleConstraint -> SimpleConstraint +normalizeSimpleConstraint (expr :<= num) = + let + exprList = exprToList expr + + isConstTerm (ConstTerm _) = True + isConstTerm _ = False -type System = [SystemRow] + (sumExprConstTerms, nonConstTerms) = L.partition isConstTerm exprList + + constTermsVal = sum . map (\case (ConstTerm c) -> c; _ -> 0) $ sumExprConstTerms + + newExpr = listToExpr nonConstTerms + newNum = num - constTermsVal + in newExpr :<= newNum +normalizeSimpleConstraint (expr :>= num) = + let + exprList = exprToList expr + + isConstTerm (ConstTerm _) = True + isConstTerm _ = False + + (sumExprConstTerms, nonConstTerms) = L.partition isConstTerm exprList + + constTermsVal = sum . map (\case (ConstTerm c) -> c; _ -> 0) $ sumExprConstTerms + + newExpr = listToExpr nonConstTerms + newNum = num - constTermsVal + in newExpr :>= newNum +normalizeSimpleConstraint (expr :== num) = + let + exprList = exprToList expr + + isConstTerm (ConstTerm _) = True + isConstTerm _ = False + + (sumExprConstTerms, nonConstTerms) = L.partition isConstTerm exprList + + constTermsVal = sum . map (\case (ConstTerm c) -> c; _ -> 0) $ sumExprConstTerms + + newExpr = listToExpr nonConstTerms + newNum = num - constTermsVal + in newExpr :== newNum + +-- | Simplify coeff constraints by dividing the coefficient from both sides +simplifyCoeff :: SimpleConstraint -> SimpleConstraint +simplifyCoeff expr@(Expr (CoeffTerm coeff var) :<= num) + | coeff == 0 = expr + | coeff > 0 = Expr (VarTerm var) :<= (num / coeff) + | coeff < 0 = Expr (VarTerm var) :>= (num / coeff) +simplifyCoeff expr@(Expr (CoeffTerm coeff var) :>= num) + | coeff == 0 = expr + | coeff > 0 = Expr (VarTerm var) :>= (num / coeff) + | coeff < 0 = Expr (VarTerm var) :<= (num / coeff) +simplifyCoeff expr@(Expr (CoeffTerm coeff var) :== num) = if coeff == 0 then expr else Expr (VarTerm var) :== (num / coeff) +simplifyCoeff expr = expr + +simplifySimpleConstraint :: SimpleConstraint -> SimpleConstraint +simplifySimpleConstraint (expr :<= num) = simplifyCoeff . normalizeSimpleConstraint $ simplifyExpr expr :<= num +simplifySimpleConstraint (expr :>= num) = simplifyCoeff . normalizeSimpleConstraint $ simplifyExpr expr :>= num +simplifySimpleConstraint (expr :== num) = simplifyCoeff . normalizeSimpleConstraint $ simplifyExpr expr :== num + +type SimpleSystem = [SimpleConstraint] + +simplifySimpleSystem :: SimpleSystem -> SimpleSystem +simplifySimpleSystem = map simplifySimpleConstraint + +data StandardFormRow = StandardFormRow + { lhs :: Expr + , rhs :: SimplexNum + } + deriving (Show, Read, Eq, Generic) + +-- | the system with slack variables +type StandardForm = [StandardFormRow] + +data Bounds = Bounds + { lowerBound :: Maybe SimplexNum + , upperBound :: Maybe SimplexNum + } + deriving (Show, Read, Eq, Generic) + +type Var = Int + +type VarBounds = M.Map Var Bounds + +-- | Merge two bounds, very simple +deriveBounds :: SimpleSystem -> VarBounds +deriveBounds = foldr updateBounds M.empty + where + updateBounds :: SimpleConstraint -> VarBounds -> VarBounds + updateBounds (Expr (VarTerm var) :<= num) = M.insertWith mergeBounds var (Bounds Nothing (Just num)) + updateBounds (Expr (VarTerm var) :>= num) = M.insertWith mergeBounds var (Bounds (Just num) Nothing) + updateBounds (Expr (VarTerm var) :== num) = M.insertWith mergeBounds var (Bounds (Just num) (Just num)) + updateBounds _ = id + + mergeBounds :: Bounds -> Bounds -> Bounds + mergeBounds (Bounds l1 u1) (Bounds l2 u2) = Bounds (liftA2 max l1 l2) (liftA2 min u1 u2) + +-- Eliminate inequalities which are outside the bounds +-- precondition: no zero coefficients +-- TODO: better name +removeUselessSystemBounds :: SimpleSystem -> VarBounds -> SimpleSystem +removeUselessSystemBounds constraints bounds = + filter + ( \case + (Expr (VarTerm var) :<= num) -> case M.lookup var bounds of + Just (Bounds _ (Just upper)) -> num <= upper + _ -> True + (Expr (VarTerm var) :>= num) -> case M.lookup var bounds of + Just (Bounds (Just lower) _) -> num >= lower + _ -> True + _ -> True + ) + constraints + +findHighestVar :: SimpleSystem -> Var +findHighestVar = maximum . map (maximum . map (\case (CoeffTerm _ v) -> v; _ -> 0) . exprToList . getGenericConstraintLHS) + +-- | Eliminate negative lower bounds via substitution +-- Return the system with the eliminated variables and a map of the eliminated variables to their equivalent expressions +-- First step here https://en.wikipedia.org/wiki/Simplex_algorithm#Standard_form +eliminateNonZeroLowerBounds :: SimpleSystem -> M.Map Var Expr -> (M.Map Var Expr, SimpleSystem) +eliminateNonZeroLowerBounds constraints eliminatedVarsMap = aux constraints + where + removeConstraint :: SimpleConstraint -> SimpleSystem -> SimpleSystem + removeConstraint c = filter (/= c) + + aux :: SimpleSystem -> (M.Map Var Expr, SimpleSystem) + aux [] = (eliminatedVarsMap, constraints) + aux (c : cs) = case c of + -- x >= 5 + (Expr (VarTerm var) :>= lowerBound) -> + if lowerBound == 0 + then aux cs + else + let newVar = findHighestVar constraints + 1 + -- y >= 0 + newVarLowerBound = Expr (VarTerm newVar) :>= 0 + + -- x = y + 5 + substOldVarWith = Expr (VarTerm newVar) :+ ConstTerm lowerBound + + newConstraints = simplifySimpleSystem $ newVarLowerBound : map (substVarSimpleConstraint var substOldVarWith) constraints + updatedEliminatedVarsMap = M.insert var substOldVarWith eliminatedVarsMap + in eliminateNonZeroLowerBounds newConstraints updatedEliminatedVarsMap -- TODO: Make more efficient if needed + _ -> aux cs + +-- Add slack variables... +-- Second step here https://en.wikipedia.org/wiki/Simplex_algorithm#Standard_form +-- Return system of equalities and the slack variables +addSlackVariables :: SimpleSystem -> ([Var], SimpleSystem) +addSlackVariables constraints = aux constraints newVar [] + where + newVar = findHighestVar constraints + 1 + + aux :: SimpleSystem -> Var -> [Var] -> ([Var], SimpleSystem) + aux [] _ slackVars = (slackVars, []) + aux (c : cs) nextVar slackVars = case c of + (expr :<= num) -> + let slackVar = newVar + newNextVar = nextVar + 1 + newExpr = expr :+ VarTerm slackVar + slackVarLowerBound = Expr (VarTerm slackVar) :>= 0 + (newSlackVars, newConstraints) = aux cs newNextVar slackVars + in (newVar : newSlackVars, newExpr :== num : slackVarLowerBound : newConstraints) + (expr :>= num) -> + let slackVar = newVar + newNextVar = nextVar + 1 + newExpr = expr :+ CoeffTerm (-1) slackVar + slackVarLowerBound = Expr (VarTerm slackVar) :>= 0 + (newSlackVars, newConstraints) = aux cs newNextVar slackVars + in (newVar : newSlackVars, newExpr :== num : slackVarLowerBound : newConstraints) + (expr :== num) -> + let (newSlackVars, newConstraints) = aux cs nextVar slackVars + in (newSlackVars, c : newConstraints) + +-- Eliminate unrestricted variables (lower bound unknown) +-- Third step here https://en.wikipedia.org/wiki/Simplex_algorithm#Standard_form +-- precondition: VarBounds accurate for SimpleSystem +eliminateUnrestrictedLowerBounds :: SimpleSystem -> VarBounds -> M.Map Var Expr -> (M.Map Var Expr, SimpleSystem) +eliminateUnrestrictedLowerBounds constraints varBoundMap eliminatedVarsMap = aux constraints (M.toList varBoundMap) + where + aux :: SimpleSystem -> [(Var, Bounds)] -> (M.Map Var Expr, SimpleSystem) + aux _ [] = (eliminatedVarsMap, constraints) + aux cs ((var, Bounds Nothing _): bounds) = + let newVarPlus = findHighestVar constraints + 1 + newVarMinus = newVarPlus + 1 + newVarPlusLowerBound = Expr (VarTerm newVarPlus) :>= 0 + newVarMinusLowerBound = Expr (VarTerm newVarMinus) :>= 0 + + -- oldVar = newVarPlus - newVarMinus + substOldVarWith = Expr (VarTerm newVarPlus) :+ CoeffTerm (-1) newVarMinus + + newConstraints = simplifySimpleSystem $ newVarPlusLowerBound : newVarMinusLowerBound : map (substVarSimpleConstraint var substOldVarWith) constraints + -- TODO: Update this name + updatedEliminatedVarsMap = M.insert var substOldVarWith eliminatedVarsMap + in eliminateUnrestrictedLowerBounds newConstraints (M.fromList bounds) updatedEliminatedVarsMap + +-- data Term = ConstTerm SimplexNum | CoeffTerm SimplexNum Var -- Consider VarTermnewVar +data StandardTerm = StandardTerm SimplexNum Var + deriving (Show, Read, Eq, Generic) + +-- Equality +data StandardConstraint = StandardConstraint [StandardTerm] SimplexNum + deriving (Show, Read, Eq, Generic) + +type StandardSystem = [StandardConstraint] + +-- Negative/no lower bounds +-- say x +-- x = x1 - x2 +-- x1, x2 >= 0 -- A 'Tableau' where the basic variable may be empty. -- All non-empty basic vars are slack vars @@ -64,16 +531,17 @@ type VarLitMap = M.Map Var SimplexNum type VarLitMapSum = VarLitMap -- | For specifying constraints in a system. --- The LHS is a 'Vars', and the RHS, is a 'SimplexNum' number. +-- The LHS is a 'VarLitMapSum', and the RHS, is a 'SimplexNum' number. -- LEQ [(1, 2), (2, 1)] 3.5 is equivalent to 2x1 + x2 <= 3.5. -- Users must only provide positive integer variables. -- -- Example: LEQ [Var "x" 3, Var "y" -1, Var "x" 1] 12.3 is equivalent to 3x + (-y) + x <= 12.3. -data PolyConstraint - = LEQ {lhs :: VarLitMapSum, rhs :: SimplexNum} - | GEQ {lhs :: VarLitMapSum, rhs :: SimplexNum} - | EQ {lhs :: VarLitMapSum, rhs :: SimplexNum} - deriving (Show, Read, Eq, Generic) + +-- data StandardConstraint +-- = LEQ {lhs :: VarLitMapSum, rhs :: SimplexNum} +-- | GEQ {lhs :: VarLitMapSum, rhs :: SimplexNum} +-- | EQ {lhs :: VarLitMapSum, rhs :: SimplexNum} +-- deriving (Show, Read, Eq, Generic) -- | Create an objective function. -- We can either 'Max'imize or 'Min'imize a 'VarTermSum'. diff --git a/src/Linear/Simplex/Util.hs b/src/Linear/Simplex/Util.hs index 99b1495..86b8a4d 100644 --- a/src/Linear/Simplex/Util.hs +++ b/src/Linear/Simplex/Util.hs @@ -30,53 +30,53 @@ isMax :: ObjectiveFunction -> Bool isMax (Max _) = True isMax (Min _) = False --- | Simplifies a system of 'PolyConstraint's by first calling 'simplifyPolyConstraint', +-- | Simplifies a system of 'StandardConstraint's by first calling 'simplifyStandardConstraint', -- then reducing 'LEQ' and 'GEQ' with same LHS and RHS (and other similar situations) into 'EQ', -- and finally removing duplicate elements using 'nub'. -simplifySystem :: [PolyConstraint] -> [PolyConstraint] -simplifySystem = nub . reduceSystem - where - reduceSystem :: [PolyConstraint] -> [PolyConstraint] - reduceSystem [] = [] - -- Reduce LEQ with matching GEQ and EQ into EQ - reduceSystem ((LEQ lhs rhs) : pcs) = - let matchingConstraints = - filter - ( \case - GEQ lhs' rhs' -> lhs == lhs' && rhs == rhs' - EQ lhs' rhs' -> lhs == lhs' && rhs == rhs' - _ -> False - ) - pcs - in if null matchingConstraints - then LEQ lhs rhs : reduceSystem pcs - else EQ lhs rhs : reduceSystem (pcs \\ matchingConstraints) - -- Reduce GEQ with matching LEQ and EQ into EQ - reduceSystem ((GEQ lhs rhs) : pcs) = - let matchingConstraints = - filter - ( \case - LEQ lhs' rhs' -> lhs == lhs' && rhs == rhs' - EQ lhs' rhs' -> lhs == lhs' && rhs == rhs' - _ -> False - ) - pcs - in if null matchingConstraints - then GEQ lhs rhs : reduceSystem pcs - else EQ lhs rhs : reduceSystem (pcs \\ matchingConstraints) - -- Reduce EQ with matching LEQ and GEQ into EQ - reduceSystem ((EQ lhs rhs) : pcs) = - let matchingConstraints = - filter - ( \case - LEQ lhs' rhs' -> lhs == lhs' && rhs == rhs' - GEQ lhs' rhs' -> lhs == lhs' && rhs == rhs' - _ -> False - ) - pcs - in if null matchingConstraints - then EQ lhs rhs : reduceSystem pcs - else EQ lhs rhs : reduceSystem (pcs \\ matchingConstraints) +-- simplifySystem :: [StandardConstraint] -> [StandardConstraint] +-- simplifySystem = nub . reduceSystem +-- where +-- reduceSystem :: [StandardConstraint] -> [StandardConstraint] +-- reduceSystem [] = [] +-- -- Reduce LEQ with matching GEQ and EQ into EQ +-- reduceSystem ((LEQ lhs rhs) : pcs) = +-- let matchingConstraints = +-- filter +-- ( \case +-- GEQ lhs' rhs' -> lhs == lhs' && rhs == rhs' +-- EQ lhs' rhs' -> lhs == lhs' && rhs == rhs' +-- _ -> False +-- ) +-- pcs +-- in if null matchingConstraints +-- then LEQ lhs rhs : reduceSystem pcs +-- else EQ lhs rhs : reduceSystem (pcs \\ matchingConstraints) +-- -- Reduce GEQ with matching LEQ and EQ into EQ +-- reduceSystem ((GEQ lhs rhs) : pcs) = +-- let matchingConstraints = +-- filter +-- ( \case +-- LEQ lhs' rhs' -> lhs == lhs' && rhs == rhs' +-- EQ lhs' rhs' -> lhs == lhs' && rhs == rhs' +-- _ -> False +-- ) +-- pcs +-- in if null matchingConstraints +-- then GEQ lhs rhs : reduceSystem pcs +-- else EQ lhs rhs : reduceSystem (pcs \\ matchingConstraints) +-- -- Reduce EQ with matching LEQ and GEQ into EQ +-- reduceSystem ((EQ lhs rhs) : pcs) = +-- let matchingConstraints = +-- filter +-- ( \case +-- LEQ lhs' rhs' -> lhs == lhs' && rhs == rhs' +-- GEQ lhs' rhs' -> lhs == lhs' && rhs == rhs' +-- _ -> False +-- ) +-- pcs +-- in if null matchingConstraints +-- then EQ lhs rhs : reduceSystem pcs +-- else EQ lhs rhs : reduceSystem (pcs \\ matchingConstraints) -- | Converts a 'Dict' to a 'Tableau' using 'dictEntryToTableauEntry'. -- FIXME: maybe remove this line. The basic variables will have a coefficient of 1 in the 'Tableau'. @@ -182,3 +182,17 @@ extractTableauValues = Map.map (.rhs) extractDictValues :: Dict -> Map.Map Var SimplexNum extractDictValues = Map.map (.constant) + +-- scanConstraintVars :: Constraint -> [Var] +-- scanConstraintVars (Var x <= c) = x : scanConstraintVars c +-- scanConstraintVars (c <= Var x) = x : scanConstraintVars c +-- scanConstraintVars (Var x >= c) = x : scanConstraintVars c +-- scanConstraintVars (c >= Var x) = x : scanConstraintVars c +-- scanConstraintVars (Var x == c) = x : scanConstraintVars c +-- scanConstraintVars (c == Var x) = x : scanConstraintVars c +-- scanConstraintVars (c1 <= c2) = scanConstraintVars c1 <> scanConstraintVars c2 +-- scanConstraintVars (c1 >= c2) = scanConstraintVars c1 <> scanConstraintVars c2 +-- scanConstraintVars (c1 == c2) = scanConstraintVars c1 <> scanConstraintVars c2 + +-- scanConstraintVarBounds :: Constraint -> VarBounds +-- scanConstraintVarBounds (Var x <= c) = Map.singleton x (Just c, Nothing) diff --git a/test/Linear/Simplex/TypesSpec.hs b/test/Linear/Simplex/TypesSpec.hs new file mode 100644 index 0000000..b2c4484 --- /dev/null +++ b/test/Linear/Simplex/TypesSpec.hs @@ -0,0 +1,541 @@ +module Linear.Simplex.TypesSpec (spec) where + +import Prelude + +import Control.Monad (forM) +import Data.Functor ((<&>)) +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import qualified Data.Set as Set +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck + +import Linear.Simplex.Types + +import qualified Debug.Trace as T + +termVar :: Term -> Maybe Var +termVar (VarTerm v) = Just v +termVar (CoeffTerm _ v) = Just v +termVar _ = Nothing + +exprVars :: Expr -> Set.Set Var +exprVars = Set.fromList . Maybe.catMaybes . map termVar . exprToList + +constraintVars :: Constraint -> Set.Set Var +constraintVars (lhs :<= rhs) = exprVars lhs <> exprVars rhs +constraintVars (lhs :>= rhs) = exprVars lhs <> exprVars rhs +constraintVars (lhs :== rhs) = exprVars lhs <> exprVars rhs + +simpleConstraintVars :: SimpleConstraint -> Set.Set Var +simpleConstraintVars (lhs :<= rhs) = exprVars lhs +simpleConstraintVars (lhs :>= rhs) = exprVars lhs +simpleConstraintVars (lhs :== rhs) = exprVars lhs + +simpleSystemVars :: SimpleSystem -> Set.Set Var +simpleSystemVars = Set.unions . map simpleConstraintVars + +-- data Term = ConstTerm SimplexNum | CoeffTerm SimplexNum Var | VarTerm Var -- Consider VarTerm Var - note, we must consider normalizing this: Considered. It makes going to standard form easier due to type safety +-- deriving (Show, Read, Eq, Ord, Generic) + +-- TODO: consider type NumberConstraint = GenericConstraint SimplexNum SimplexNum + +evalTerm :: VarLitMap -> Term -> SimplexNum +evalTerm _ (ConstTerm c) = c +evalTerm varMap (CoeffTerm c v) = c * (Map.findWithDefault (error $ "evalTerm: " <> show v <> " not found in varMap " <> show varMap) v varMap) +evalTerm varMap (VarTerm v) = Map.findWithDefault (error $ "evalTerm: " <> show v <> " not found in varMap " <> show varMap) v varMap + +evalExpr :: VarLitMap -> Expr -> SimplexNum +evalExpr varMap expr = sum $ map (evalTerm varMap) $ exprToList expr + +evalConstraint :: VarLitMap -> Constraint -> Bool +evalConstraint varMap (lhs :<= rhs) = evalExpr varMap lhs <= evalExpr varMap rhs +evalConstraint varMap (lhs :>= rhs) = evalExpr varMap lhs >= evalExpr varMap rhs +evalConstraint varMap (lhs :== rhs) = evalExpr varMap lhs == evalExpr varMap rhs + +evalSimpleConstraint :: VarLitMap -> SimpleConstraint -> Bool +evalSimpleConstraint varMap (lhs :<= rhs) = evalExpr varMap lhs <= rhs +evalSimpleConstraint varMap (lhs :>= rhs) = evalExpr varMap lhs >= rhs +evalSimpleConstraint varMap (lhs :== rhs) = evalExpr varMap lhs == rhs + +evalSimpleSystem :: VarLitMap -> SimpleSystem -> Bool +evalSimpleSystem varMap = all (evalSimpleConstraint varMap) + +genVarMap :: [Var] -> Gen VarLitMap +genVarMap vars = do + varVals <- forM vars $ const arbitrary + pure $ Map.fromList $ zip vars varVals + +spec :: Spec +spec = do + describe "Term" $ do + prop "simplifying leads to same evaluation" $ \term -> do + varMap <- maybe (pure Map.empty) (genVarMap . List.singleton) $ termVar term + let simplifiedTerm = simplifyTerm term + termEval = evalTerm varMap term + simplifiedTermEval = evalTerm varMap simplifiedTerm + pure $ + counterexample + ( "term: " + <> show term + <> "simplifiedTerm: " + <> show simplifiedTerm + <> "\nvarMap: " + <> show varMap + <> "\ntermEval: " + <> show termEval + <> "\nsimplifiedTermEval: " + <> show simplifiedTermEval + ) $ + evalTerm varMap (simplifyTerm term) == evalTerm varMap term + prop "simplifying twice is the same as simplifying once" $ \term -> do + let simplifiedTerm = simplifyTerm term + simplifiedTwiceTerm = simplifyTerm simplifiedTerm + counterexample + ( "term: " + <> show term + <> "\nsimplifiedTerm: " + <> show simplifiedTerm + <> "\nsimplifiedTwiceTerm: " + <> show simplifiedTwiceTerm + ) $ + simplifiedTwiceTerm == simplifiedTerm + prop "negating and evaluating is the same as negating the evaluation" $ \term -> do + varMap <- maybe (pure $ Map.empty) (genVarMap . List.singleton) $ termVar term + let + negatedTerm = negateTerm term + termEval = evalTerm varMap term + negatedTermEval = evalTerm varMap negatedTerm + pure $ + counterexample + ( "term: " + <> show term + <> "\nnegatedTerm: " + <> show negatedTerm + <> "\nvarMap: " + <> show varMap + <> "\ntermEval: " + <> show termEval + <> "\nnegatedTermEval: " + <> show negatedTermEval + ) $ + negate termEval == negatedTermEval + prop "negating twice is the same as not negating" $ \term -> do + let simplifiedTerm = simplifyTerm term + negatedTwiceSimpleTerm = negateTerm (negateTerm simplifiedTerm) + counterexample + ( "term: " + <> show term + <> "\nsimplifiedTerm: " + <> show simplifiedTerm + <> "\nnegatedTwiceSimpleTerm: " + <> show negatedTwiceSimpleTerm + ) $ + negatedTwiceSimpleTerm == simplifiedTerm + prop "zeroConstTerm correctly zeroes constant terms" $ \term -> do + let termZeroedConsts = zeroConstTerm term + counterexample + ( "term: " + <> show term + <> "\ntermZeroedConsts: " + <> show termZeroedConsts + ) $ + case term of + ConstTerm _ -> termZeroedConsts == ConstTerm 0 + _ -> termZeroedConsts == term + describe "Expr" $ do + prop "simplifying leads to same evaluation" $ \expr -> do + let vars = Set.toList $ exprVars expr + varMap <- genVarMap vars + pure $ evalExpr varMap (simplifyExpr expr) == evalExpr varMap expr + prop "simplifying twice is the same as simplifying once" $ \expr -> do + -- expr: (Expr (CoeffTerm (1 % 1) 0) :+ CoeffTerm (1 % 2) (-1)) :+ CoeffTerm (2 % 1) (-1) + -- 1 = x + -- -1 = y + -- 1x + 0.5y + 2y + -- simplifiedExpr: (Expr (CoeffTerm (1 % 2) (-1)) :+ CoeffTerm (2 % 1) (-1)) :+ VarTerm 0 + -- 0.5y + 2y + x + -- simplifiedTwiceExpr: Expr (CoeffTerm (5 % 2) (-1)) :+ VarTerm 0 + -- 2.5y + x + let simplifiedExpr = simplifyExpr expr + let simplifiedTwiceExpr = simplifyExpr simplifiedExpr + counterexample + ( "expr: " + <> show expr + <> "\nsimplifiedExpr: " + <> show simplifiedExpr + <> "\nsimplifiedTwiceExpr: " + <> show simplifiedTwiceExpr + ) $ + simplifiedTwiceExpr == simplifiedExpr + prop "composing listToExpr and exprToList is the same as id" $ \expr -> do + let exprConvertedTwice = listToExpr (exprToList expr) + counterexample + ( "expr: " + <> show expr + <> "\nexprConvertedTwice: " + <> show exprConvertedTwice + ) $ + exprConvertedTwice == expr + prop "summing c terms is the same as evaluating the expr with zero coefficients" $ \expr -> do + let vars = Set.toList $ exprVars expr + varMap = Map.fromList $ map (, 0) vars + constSum = sumExprConstTerms expr + exprEval = evalExpr varMap expr + counterexample + ( "expr: " + <> show expr + <> "\nvarMap: " + <> show varMap + <> "\nconstSum: " + <> show constSum + <> "\nexprEval: " + <> show exprEval + ) $ + constSum == exprEval + prop "negating and evaluating is the same as negating the evaluation" $ \expr -> do + let vars = Set.toList $ exprVars expr + varMap <- genVarMap vars + let negatedExpr = negateExpr expr + exprEval = evalExpr varMap expr + exprEvalNegated = negate exprEval + negatedExprEval = evalExpr varMap negatedExpr + pure $ counterexample + ( "expr: " + <> show expr + <> "\nnegatedExpr: " + <> show negatedExpr + <> "\nvarMap: " + <> show varMap + <> "\nexprEval: " + <> show exprEval + <> "\nexprEvalNegated: " + <> show exprEvalNegated + <> "\nnegatedExprEval: " + <> show negatedExprEval + ) $ + exprEvalNegated == negatedExprEval + prop "negating a simplified expression twice is the same as not negating" $ \expr -> do + let simplifiedExpr = simplifyExpr expr + negatedTwiceSimpleExpr = negateExpr (negateExpr simplifiedExpr) + counterexample + ( "expr: " + <> show expr + <> "\nsimplifiedExpr: " + <> show simplifiedExpr + <> "\nnegatedTwiceSimpleExpr: " + <> show negatedTwiceSimpleExpr + ) $ + negatedTwiceSimpleExpr == simplifiedExpr + prop "addExpr is the same as evaluating the sum of the exprs" $ \expr1 expr2 -> do + let vars = Set.toList $ exprVars expr1 <> exprVars expr2 + varMap <- genVarMap vars + let addExpr1Expr2 = addExpr expr1 expr2 + addExpr1Expr2Eval = evalExpr varMap addExpr1Expr2 + expr1Eval = evalExpr varMap expr1 + expr2Eval = evalExpr varMap expr2 + sumExpr1EvalExpr2Eval = expr1Eval + expr2Eval + pure $ counterexample + ("expr1: " + <> show expr1 + <> "\nexpr2: " + <> show expr2 + <> "\nvarMap:" + <> show varMap + <> "\naddExpr1Expr2: " + <> show addExpr1Expr2 + <> "\naddExpr1Expr2Eval: " + <> show addExpr1Expr2Eval + <> "\nexpr1Eval: " + <> show expr1Eval + <> "\nexpr2Eval: " + <> show expr2Eval + <> "\nexpr1EvalPlusExpr2Eval: " + <> show sumExpr1EvalExpr2Eval + ) $ addExpr1Expr2Eval == sumExpr1EvalExpr2Eval + prop "subtractExpr is the same as evaluating the difference of the exprs" $ \expr1 expr2 -> do + let vars = Set.toList $ exprVars expr1 <> exprVars expr2 + varMap <- genVarMap vars + let subtractExpr1Expr2 = subtractExpr expr1 expr2 + subtractExpr1Expr2Eval = evalExpr varMap subtractExpr1Expr2 + expr1Eval = evalExpr varMap expr1 + expr2Eval = evalExpr varMap expr2 + diffExpr1EvalExpr2Eval = expr1Eval - expr2Eval + pure $ counterexample + ("expr1: " + <> show expr1 + <> "\nexpr2: " + <> show expr2 + <> "\nvarMap:" + <> show varMap + <> "\nsubtractExpr1Expr2: " + <> show subtractExpr1Expr2 + <> "\nsubtractExpr1Expr2Eval: " + <> show subtractExpr1Expr2Eval + <> "\nexpr1Eval: " + <> show expr1Eval + <> "\nexpr2Eval: " + <> show expr2Eval + <> "\nexpr1EvalMinusExpr2Eval: " + <> show diffExpr1EvalExpr2Eval + ) $ subtractExpr1Expr2Eval == diffExpr1EvalExpr2Eval + prop "substVarExpr with the same variable is the same as simplfying" $ \expr -> do + let vars = Set.toList $ exprVars expr + var <- elements vars + varMap <- genVarMap vars + let varReplacement = Expr (VarTerm var) + exprSubst = substVarExpr var varReplacement expr + exprSimplified = simplifyExpr expr + exprSubstEval = evalExpr varMap exprSubst + exprSimplifiedEval = evalExpr varMap exprSimplified + pure $ + counterexample + ( "expr: " + <> show expr + <> "\nvar: " + <> show var + <> "\nvarMap: " + <> show varMap + <> "\nvarReplacement: " + <> show varReplacement + <> "\nsubstVarExpr: " + <> show exprSubst + <> "\nsimplifyExpr: " + <> show exprSimplified + <> "\nexprSubstEval: " + <> show exprSubstEval + <> "\nexprSimplifiedEval: " + <> show exprSimplifiedEval + ) $ + exprSubstEval == exprSimplifiedEval + prop "substVarExpr with a constant is the same as evaluating with the variable mapped to the constant" $ \expr c -> do + let varReplacement = Expr (ConstTerm c) + let vars = Set.toList $ exprVars expr + var <- elements vars + initialVarMap <- genVarMap vars + let varMap = Map.insert var c initialVarMap + substitutedExpr = substVarExpr var varReplacement expr + substitutedExprEval = evalExpr varMap substitutedExpr + exprEval = evalExpr varMap expr + pure $ + counterexample + ( "expr: " + <> show expr + <> "\nvar: " + <> show var + <> "\nconst: " + <> show c + <> "\nvarMap: " + <> show varMap + <> "\nvarReplacement: " + <> show varReplacement + <> "\nsubstitutedExpr: " + <> show substitutedExpr + <> "\nsubstitutedExprEval: " + <> show substitutedExprEval + <> "\nexprEval: " + <> show exprEval + ) $ + evalExpr varMap (substVarExpr var varReplacement expr) == evalExpr varMap expr + prop "substVarExpr with an expr is the same as evaluating with the variable mapped to the expr" $ \expr exprReplacement -> do + let vars = Set.toList $ exprVars expr <> exprVars exprReplacement + var <- elements vars + initialVarMap <- genVarMap vars + let exprReplacementEval = evalExpr initialVarMap exprReplacement + varMap = Map.insert var exprReplacementEval initialVarMap + substitutedExpr = substVarExpr var exprReplacement expr + exprEval = evalExpr varMap expr + substitutedExprEval = evalExpr initialVarMap substitutedExpr + pure $ + counterexample + ( "expr: " + <> show expr + <> "\nvar: " + <> show var + <> "\nexprReplacement: " + <> show exprReplacement + <> "\ninitialVarMap: " + <> show initialVarMap + <> "\nexprReplacementEval: " + <> show exprReplacementEval + <> "\nvarMap: " + <> show varMap + <> "\nsubstExpr: " + <> show substitutedExpr + <> "\nexprEval: " + <> show exprEval + <> "\nsubstExprEval: " + <> show substitutedExprEval + ) $ substitutedExprEval == exprEval + prop "zeroConstExpr correctly zeroes constant terms in expressions" $ \expr -> sumExprConstTerms (zeroConstExpr expr) == 0 + describe "SimpleConstraint" $ do + it "substVarSimpleConstraint with a constant is the same as evaluating with the variable mapped to the constant" $ do + property $ \simpleConstraint c -> do + let vars = Set.toList $ simpleConstraintVars simpleConstraint + var <- elements vars + let varReplacement = Expr (ConstTerm c) + initialVarMap <- genVarMap vars + let varMap = Map.insert var c initialVarMap + substitutedSimpleConstraint = substVarSimpleConstraint var varReplacement simpleConstraint + substitutedSimpleConstraintEval = evalSimpleConstraint varMap substitutedSimpleConstraint + simpleConstraintEval = evalSimpleConstraint varMap simpleConstraint + pure $ + counterexample + ( "simpleConstraint: " + <> show simpleConstraint + <> "\nvar: " + <> show var + <> "\nconst: " + <> show c + <> "\nvarMap: " + <> show varMap + <> "\nvarReplacement: " + <> show varReplacement + <> "\nsubstitutedSimpleConstraint: " + <> show substitutedSimpleConstraint + <> "\nsubstitutedSimpleConstraintEval: " + <> show substitutedSimpleConstraintEval + <> "\nsimpleConstraintEval: " + <> show simpleConstraintEval + ) $ + substitutedSimpleConstraintEval == simpleConstraintEval + it "substVarSimpleConstraint with an expr is the same as evaluating with the variable mapped to the expr" $ do + property $ \simpleConstraint exprReplacement -> do + let vars = Set.toList $ simpleConstraintVars simpleConstraint <> exprVars exprReplacement + var <- elements vars + initialVarMap <- genVarMap vars + let exprReplacementEval = evalExpr initialVarMap exprReplacement + varMap = Map.insert var exprReplacementEval initialVarMap + substitutedSimpleConstraint = substVarSimpleConstraint var exprReplacement simpleConstraint + simpleConstraintEval = evalSimpleConstraint varMap simpleConstraint + substitutedSimpleConstraintEval = evalSimpleConstraint initialVarMap substitutedSimpleConstraint + pure $ + counterexample + ( "simpleConstraint: " + <> show simpleConstraint + <> "\nvar: " + <> show var + <> "\nexprReplacement: " + <> show exprReplacement + <> "\ninitialVarMap: " + <> show initialVarMap + <> "\nexprReplacementEval: " + <> show exprReplacementEval + <> "\nvarMap: " + <> show varMap + <> "\nsubstitutedSimpleConstraint: " + <> show substitutedSimpleConstraint + <> "\nsimpleConstraintEval: " + <> show simpleConstraintEval + <> "\nsubstitutedSimpleConstraintEval: " + <> show substitutedSimpleConstraintEval + ) $ + substitutedSimpleConstraintEval == simpleConstraintEval + it "constraintToSimpleConstraint leads to the same evaluation" $ do + property $ \constraint -> do + let vars = Set.toList $ constraintVars constraint + varMap <- genVarMap vars + let simpleConstraint = constraintToSimpleConstraint constraint + constraintEval = evalConstraint varMap constraint + simpleConstraintEval = evalSimpleConstraint varMap simpleConstraint + pure $ + counterexample + ( "constraint: " + <> show constraint + <> "\nsimpleConstraint: " + <> show simpleConstraint + <> "\ninitialVarMap: " + <> show varMap + <> "\nconstraintEval: " + <> show constraintEval + <> "\nsimpleConstraintEval" + <> show simpleConstraintEval + ) $ + constraintEval == simpleConstraintEval + it "normalizeSimpleConstraint leads to the same evaluation" $ do + property $ \simpleConstraint -> do + let vars = Set.toList $ simpleConstraintVars simpleConstraint + varMap <- genVarMap vars + let normalizedSimpleConstraint = normalizeSimpleConstraint simpleConstraint + simpleConstraintEval = evalSimpleConstraint varMap simpleConstraint + normalizedSimpleConstraintEval = evalSimpleConstraint varMap normalizedSimpleConstraint + pure $ + counterexample + ( "simpleConstraint: " + <> show simpleConstraint + <> "\nnormalizedSimpleConstraint: " + <> show normalizedSimpleConstraint + <> "\ninitialVarMap: " + <> show varMap + <> "\nsimpleConstraintEval: " + <> show simpleConstraintEval + <> "\nnormalizedSimpleConstraintEval" + <> show normalizedSimpleConstraintEval + ) $ + simpleConstraintEval == normalizedSimpleConstraintEval + it "simplifyCoeff leads to the same evaluation" $ do + property $ \simpleConstraint -> do + let vars = Set.toList $ simpleConstraintVars simpleConstraint + varMap <- genVarMap vars + let simplifiedSimpleConstraint = simplifyCoeff simpleConstraint + simpleConstraintEval = evalSimpleConstraint varMap simpleConstraint + simplifiedSimpleConstraintEval = evalSimpleConstraint varMap simplifiedSimpleConstraint + pure $ + counterexample + ( "simpleConstraint: " + <> show simpleConstraint + <> "\nsimplifiedSimpleConstraint: " + <> show simplifiedSimpleConstraint + <> "\ninitialVarMap: " + <> show varMap + <> "\nsimpleConstraintEval: " + <> show simpleConstraintEval + <> "\nsimplifiedSimpleConstraintEval: " + <> show simplifiedSimpleConstraintEval + ) $ + simpleConstraintEval == simplifiedSimpleConstraintEval + it "simplifySimpleConstraint leads to the same evaluation" $ do + property $ \simpleConstraint -> do + let vars = Set.toList $ simpleConstraintVars simpleConstraint + varMap <- genVarMap vars + let simplifiedSimpleConstraint = simplifySimpleConstraint simpleConstraint + simpleConstraintEval = evalSimpleConstraint varMap simpleConstraint + simplifiedSimpleConstraintEval = evalSimpleConstraint varMap simplifiedSimpleConstraint + pure $ + counterexample + ( "simpleConstraint: " + <> show simpleConstraint + <> "\nsimplifiedSimpleConstraint: " + <> show simplifiedSimpleConstraint + <> "\ninitialVarMap: " + <> show varMap + <> "\nsimpleConstraintEval: " + <> show simpleConstraintEval + <> "\nsimplifiedSimpleConstraintEval: " + <> show simplifiedSimpleConstraintEval + ) $ + simpleConstraintEval == simplifiedSimpleConstraintEval + describe "SimpleSystem" $ do + it "simplifySimpleSystem leads to the same evaluation" $ do + property $ \simpleSystem -> do + let vars = Set.toList $ simpleSystemVars simpleSystem + varMap <- genVarMap vars + let simplifiedSimpleSystem = simplifySimpleSystem simpleSystem + simpleSystemEval = evalSimpleSystem varMap simpleSystem + simplifiedSimpleSystemEval = evalSimpleSystem varMap simplifiedSimpleSystem + pure $ + counterexample + ( "simpleSystem: " + <> show simpleSystem + <> "\nsimplifiedSimpleSystem: " + <> show simplifiedSimpleSystem + <> "\ninitialVarMap: " + <> show varMap + <> "\nsimpleSystemEval: " + <> show simpleSystemEval + <> "\nsimplifiedSimpleSystemEval: " + <> show simplifiedSimpleSystemEval + ) $ + simpleSystemEval == simplifiedSimpleSystemEval \ No newline at end of file diff --git a/test/Spec.hs b/test/Spec.hs index 4a8ad55..52ef578 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,42 +1 @@ -module Main where - -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Logger - -import Linear.Simplex.Prettify -import Linear.Simplex.Solver.TwoPhase -import Linear.Simplex.Types -import Linear.Simplex.Util - -import TestFunctions - -main :: IO () -main = runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ runTests testsList - -runTests :: (MonadLogger m, MonadFail m, MonadIO m) => [((ObjectiveFunction, [PolyConstraint]), Maybe Result)] -> m () -runTests [] = do - liftIO $ putStrLn "All tests passed" - pure () -runTests (((testObjective, testConstraints), expectedResult) : tests) = - do - testResult <- twoPhaseSimplex testObjective testConstraints - if testResult == expectedResult - then runTests tests - else do - let msg = - "\nThe following test failed: " - <> ("\nObjective Function (Non-prettified): " ++ show testObjective) - <> ("\nConstraints (Non-prettified): " ++ show testConstraints) - <> "\n====================================" - <> ("\nObjective Function (Prettified): " ++ prettyShowObjectiveFunction testObjective) - <> "\nConstraints (Prettified): " - <> "\n" - <> concatMap (\c -> "\t" ++ prettyShowPolyConstraint c ++ "\n") testConstraints - <> "\n====================================" - <> ("\nExpected Solution (Full): " ++ show expectedResult) - <> ("\nActual Solution (Full): " ++ show testResult) - <> ("\nExpected Solution (Objective): " ++ show (extractObjectiveValue expectedResult)) - <> ("\nActual Solution (Objective): " ++ show (extractObjectiveValue testResult)) - <> "\n" - fail msg +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} \ No newline at end of file diff --git a/test/TestFunctions.hs b/test/TestFunctions.hs deleted file mode 100644 index b2af317..0000000 --- a/test/TestFunctions.hs +++ /dev/null @@ -1,1048 +0,0 @@ -module TestFunctions where - -import qualified Data.Map as M -import Data.Ratio -import Linear.Simplex.Types -import Prelude hiding (EQ) - -testsList :: [((ObjectiveFunction, [PolyConstraint]), Maybe Result)] -testsList = - [ (test1, Just (Result 7 (M.fromList [(7, 29), (1, 3), (2, 4)]))) - , (test2, Just (Result 7 (M.fromList [(7, 0)]))) - , (test3, Nothing) - , (test4, Just (Result 11 (M.fromList [(11, 237 % 7), (1, 24 % 7), (2, 33 % 7)]))) - , (test5, Just (Result 9 (M.fromList [(9, 3 % 5), (2, 14 % 5), (3, 17 % 5)]))) - , (test6, Nothing) - , (test7, Just (Result 8 (M.fromList [(8, 1), (2, 2), (1, 3)]))) - , (test8, Just (Result 8 (M.fromList [(8, (-1) % 4), (2, 9 % 2), (1, 17 % 4)]))) - , (test9, Just (Result 7 (M.fromList [(7, 5), (3, 2), (4, 1)]))) - , (test10, Just (Result 7 (M.fromList [(7, 8), (1, 2), (2, 6)]))) - , (test11, Just (Result 8 (M.fromList [(8, 20), (4, 16), (3, 6)]))) - , (test12, Just (Result 8 (M.fromList [(8, 6), (4, 2), (5, 2)]))) - , (test13, Just (Result 6 (M.fromList [(6, 150), (2, 150)]))) - , (test14, Just (Result 6 (M.fromList [(6, 40 % 3), (2, 40 % 3)]))) - , (test15, Nothing) - , (test16, Just (Result 6 (M.fromList [(6, 75), (1, 75 % 2)]))) - , (test17, Just (Result 7 (M.fromList [(7, (-120)), (1, 20)]))) - , (test18, Just (Result 7 (M.fromList [(7, 10), (3, 5)]))) - , (test19, Nothing) - , (test20, Nothing) - , (test21, Just (Result 7 (M.fromList [(7, 250), (2, 50)]))) - , (test22, Just (Result 7 (M.fromList [(7, 0)]))) - , (test23, Nothing) - , (test24, Just (Result 10 (M.fromList [(10, 300), (3, 150)]))) - , (test25, Just (Result 3 (M.fromList [(3, 15), (1, 15)]))) - , (test26, Just (Result 6 (M.fromList [(6, 20), (1, 10), (2, 10)]))) - , (test27, Just (Result 3 (M.fromList [(3, 0)]))) - , (test28, Just (Result 6 (M.fromList [(6, 0), (2, 10)]))) - , (test29, Nothing) - , (test30, Nothing) - , (test31, Just (Result 5 (M.fromList [(2, 1 % 1), (5, 0 % 1)]))) - , (test32, Nothing) - , (testPolyPaver1, Just (Result 12 (M.fromList [(12, 7 % 4), (2, 5 % 2), (1, 7 % 4), (3, 0)]))) - , (testPolyPaver2, Just (Result 12 (M.fromList [(12, 5 % 2), (2, 5 % 3), (1, 5 % 2), (3, 0)]))) - , (testPolyPaver3, Just (Result 12 (M.fromList [(12, 5 % 3), (2, 5 % 3), (1, 5 % 2), (3, 0)]))) - , (testPolyPaver4, Just (Result 12 (M.fromList [(12, 5 % 2), (2, 5 % 2), (1, 5 % 2), (3, 0)]))) - , (testPolyPaver5, Nothing) - , (testPolyPaver6, Nothing) - , (testPolyPaver7, Nothing) - , (testPolyPaver8, Nothing) - , (testPolyPaver9, Just (Result 12 (M.fromList [(12, 7 % 2), (2, 5 % 9), (1, 7 % 2), (3, 0)]))) - , (testPolyPaver10, Just (Result 12 (M.fromList [(12, 17 % 20), (2, 7 % 2), (1, 17 % 20), (3, 0)]))) - , (testPolyPaver11, Just (Result 12 (M.fromList [(12, 7 % 2), (2, 7 % 2), (1, 22 % 9)]))) - , (testPolyPaver12, Just (Result 12 (M.fromList [(12, 5 % 9), (2, 5 % 9), (1, 7 % 2), (3, 0)]))) - , (testPolyPaverTwoFs1, Nothing) - , (testPolyPaverTwoFs2, Nothing) - , (testPolyPaverTwoFs3, Nothing) - , (testPolyPaverTwoFs4, Nothing) - , (testPolyPaverTwoFs5, Just (Result 17 (M.fromList [(17, 5 % 2), (2, 45 % 22), (1, 5 % 2), (4, 0)]))) - , (testPolyPaverTwoFs6, Just (Result 17 (M.fromList [(17, 45 % 22), (2, 5 % 2), (1, 45 % 22), (4, 0)]))) - , (testPolyPaverTwoFs7, Just (Result 17 (M.fromList [(17, 5 % 2), (2, 5 % 2), (1, 5 % 2), (4, 0)]))) - , (testPolyPaverTwoFs8, Just (Result 17 (M.fromList [(17, 45 % 22), (2, 45 % 22), (1, 5 % 2), (4, 0)]))) - , (testLeqGeqBugMin1, Just (Result 5 (M.fromList [(5, 3), (1, 3), (2, 3)]))) - , (testLeqGeqBugMax1, Just (Result 5 (M.fromList [(5, 3), (1, 3), (2, 3)]))) - , (testLeqGeqBugMin2, Just (Result 5 (M.fromList [(5, 3), (1, 3), (2, 3)]))) - , (testLeqGeqBugMax2, Just (Result 5 (M.fromList [(5, 3), (1, 3), (2, 3)]))) - , (testQuickCheck1, Just (Result 10 (M.fromList [(10, (-370)), (2, 26), (1, 5 % 3)]))) - , (testQuickCheck2, Just (Result 8 (M.fromList [(8, (-2) % 9), (1, 14 % 9), (2, 8 % 9)]))) - , (testQuickCheck3, Just (Result 7 (M.fromList [(7, (-8)), (2, 2)]))) - ] - -testLeqGeqBugMin1 :: (ObjectiveFunction, [PolyConstraint]) -testLeqGeqBugMin1 = - ( Min (M.fromList [(1, 1)]) - , - [ GEQ (M.fromList [(1, 1)]) 3 - , LEQ (M.fromList [(1, 1)]) 3 - , GEQ (M.fromList [(2, 1)]) 3 - , LEQ (M.fromList [(2, 1)]) 3 - ] - ) - -testLeqGeqBugMax1 :: (ObjectiveFunction, [PolyConstraint]) -testLeqGeqBugMax1 = - ( Min (M.fromList [(1, 1)]) - , - [ GEQ (M.fromList [(1, 1)]) 3 - , LEQ (M.fromList [(1, 1)]) 3 - , GEQ (M.fromList [(2, 1)]) 3 - , LEQ (M.fromList [(2, 1)]) 3 - ] - ) - -testLeqGeqBugMin2 :: (ObjectiveFunction, [PolyConstraint]) -testLeqGeqBugMin2 = - ( Min (M.fromList [(1, 1)]) - , - [ GEQ (M.fromList [(1, 1)]) 3 - , LEQ (M.fromList [(1, 1)]) 3 - , GEQ (M.fromList [(2, 1)]) 3 - , LEQ (M.fromList [(2, 1)]) 3 - ] - ) - -testLeqGeqBugMax2 :: (ObjectiveFunction, [PolyConstraint]) -testLeqGeqBugMax2 = - ( Min (M.fromList [(1, 1)]) - , - [ GEQ (M.fromList [(1, 1)]) 3 - , LEQ (M.fromList [(1, 1)]) 3 - , GEQ (M.fromList [(2, 1)]) 3 - , LEQ (M.fromList [(2, 1)]) 3 - ] - ) - --- From page 50 of 'Linear and Integer Programming Made Easy' --- Solution: obj = 29, 1 = 3, 2 = 4, -test1 :: (ObjectiveFunction, [PolyConstraint]) -test1 = - ( Max (M.fromList [(1, 3), (2, 5)]) - , - [ LEQ (M.fromList [(1, 3), (2, 1)]) 15 - , LEQ (M.fromList [(1, 1), (2, 1)]) 7 - , LEQ (M.fromList [(2, 1)]) 4 - , LEQ (M.fromList [(1, -1), (2, 2)]) 6 - ] - ) - -test2 :: (ObjectiveFunction, [PolyConstraint]) -test2 = - ( Min (M.fromList [(1, 3), (2, 5)]) - , - [ LEQ (M.fromList [(1, 3), (2, 1)]) 15 - , LEQ (M.fromList [(1, 1), (2, 1)]) 7 - , LEQ (M.fromList [(2, 1)]) 4 - , LEQ (M.fromList [(1, -1), (2, 2)]) 6 - ] - ) - -test3 :: (ObjectiveFunction, [PolyConstraint]) -test3 = - ( Max (M.fromList [(1, 3), (2, 5)]) - , - [ GEQ (M.fromList [(1, 3), (2, 1)]) 15 - , GEQ (M.fromList [(1, 1), (2, 1)]) 7 - , GEQ (M.fromList [(2, 1)]) 4 - , GEQ (M.fromList [(1, -1), (2, 2)]) 6 - ] - ) - -test4 :: (ObjectiveFunction, [PolyConstraint]) -test4 = - ( Min (M.fromList [(1, 3), (2, 5)]) - , - [ GEQ (M.fromList [(1, 3), (2, 1)]) 15 - , GEQ (M.fromList [(1, 1), (2, 1)]) 7 - , GEQ (M.fromList [(2, 1)]) 4 - , GEQ (M.fromList [(1, -1), (2, 2)]) 6 - ] - ) - --- From https://www.eng.uwaterloo.ca/~syde05/phase1.pdf --- Solution: obj = 3/5, 2 = 14/5, 3 = 17/5 --- requires two phases -test5 :: (ObjectiveFunction, [PolyConstraint]) -test5 = - ( Max (M.fromList [(1, 1), (2, -1), (3, 1)]) - , - [ LEQ (M.fromList [(1, 2), (2, -1), (3, 2)]) 4 - , LEQ (M.fromList [(1, 2), (2, -3), (3, 1)]) (-5) - , LEQ (M.fromList [(1, -1), (2, 1), (3, -2)]) (-1) - ] - ) - -test6 :: (ObjectiveFunction, [PolyConstraint]) -test6 = - ( Min (M.fromList [(1, 1), (2, -1), (3, 1)]) - , - [ LEQ (M.fromList [(1, 2), (2, -1), (3, 2)]) 4 - , LEQ (M.fromList [(1, 2), (2, -3), (3, 1)]) (-5) - , LEQ (M.fromList [(1, -1), (2, 1), (3, -2)]) (-1) - ] - ) - -test7 :: (ObjectiveFunction, [PolyConstraint]) -test7 = - ( Max (M.fromList [(1, 1), (2, -1), (3, 1)]) - , - [ GEQ (M.fromList [(1, 2), (2, -1), (3, 2)]) 4 - , GEQ (M.fromList [(1, 2), (2, -3), (3, 1)]) (-5) - , GEQ (M.fromList [(1, -1), (2, 1), (3, -2)]) (-1) - ] - ) - -test8 :: (ObjectiveFunction, [PolyConstraint]) -test8 = - ( Min (M.fromList [(1, 1), (2, -1), (3, 1)]) - , - [ GEQ (M.fromList [(1, 2), (2, -1), (3, 2)]) 4 - , GEQ (M.fromList [(1, 2), (2, -3), (3, 1)]) (-5) - , GEQ (M.fromList [(1, -1), (2, 1), (3, -2)]) (-1) - ] - ) - --- From page 49 of 'Linear and Integer Programming Made Easy' --- Solution: obj = -5, 3 = 2, 4 = 1, objVar was negated so actual val is 5 wa --- requires two phases -test9 :: (ObjectiveFunction, [PolyConstraint]) -test9 = - ( Min (M.fromList [(1, 1), (2, 1), (3, 2), (4, 1)]) - , - [ EQ (M.fromList [(1, 1), (3, 2), (4, -2)]) 2 - , EQ (M.fromList [(2, 1), (3, 1), (4, 4)]) 6 - ] - ) - -test10 :: (ObjectiveFunction, [PolyConstraint]) -test10 = - ( Max (M.fromList [(1, 1), (2, 1), (3, 2), (4, 1)]) - , - [ EQ (M.fromList [(1, 1), (3, 2), (4, -2)]) 2 - , EQ (M.fromList [(2, 1), (3, 1), (4, 4)]) 6 - ] - ) - --- Adapted from page 52 of 'Linear and Integer Programming Made Easy' --- Removed variables which do not appear in the system (these should be artificial variables) --- Solution: obj = 20, 3 = 6, 4 = 16 wq -test11 :: (ObjectiveFunction, [PolyConstraint]) -test11 = - ( Max (M.fromList [(3, -2), (4, 2), (5, 1)]) - , - [ EQ (M.fromList [(3, -2), (4, 1), (5, 1)]) 4 - , EQ (M.fromList [(3, 3), (4, -1), (5, 2)]) 2 - ] - ) - -test12 :: (ObjectiveFunction, [PolyConstraint]) -test12 = - ( Min (M.fromList [(3, -2), (4, 2), (5, 1)]) - , - [ EQ (M.fromList [(3, -2), (4, 1), (5, 1)]) 4 - , EQ (M.fromList [(3, 3), (4, -1), (5, 2)]) 2 - ] - ) - --- From page 59 of 'Linear and Integer Programming Made Easy' --- Solution: obj = 150, 1 = 0, 2 = 150 --- requires two phases -test13 :: (ObjectiveFunction, [PolyConstraint]) -test13 = - ( Max (M.fromList [(1, 2), (2, 1)]) - , - [ LEQ (M.fromList [(1, 4), (2, 1)]) 150 - , LEQ (M.fromList [(1, 2), (2, -3)]) (-40) - ] - ) - -test14 :: (ObjectiveFunction, [PolyConstraint]) -test14 = - ( Min (M.fromList [(1, 2), (2, 1)]) - , - [ LEQ (M.fromList [(1, 4), (2, 1)]) 150 - , LEQ (M.fromList [(1, 2), (2, -3)]) (-40) - ] - ) - -test15 :: (ObjectiveFunction, [PolyConstraint]) -test15 = - ( Max (M.fromList [(1, 2), (2, 1)]) - , - [ GEQ (M.fromList [(1, 4), (2, 1)]) 150 - , GEQ (M.fromList [(1, 2), (2, -3)]) (-40) - ] - ) - -test16 :: (ObjectiveFunction, [PolyConstraint]) -test16 = - ( Min (M.fromList [(1, 2), (2, 1)]) - , - [ GEQ (M.fromList [(1, 4), (2, 1)]) 150 - , GEQ (M.fromList [(1, 2), (2, -3)]) (-40) - ] - ) - --- From page 59 of 'Linear and Integer Programming Made Easy' --- Solution: obj = 120, 1 = 20, 2 = 0, 3 = 0, objVar was negated so actual val is -120 -test17 :: (ObjectiveFunction, [PolyConstraint]) -test17 = - ( Min (M.fromList [(1, -6), (2, -4), (3, 2)]) - , - [ LEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 - , LEQ (M.fromList [(2, -5), (3, 5)]) 100 - , LEQ (M.fromList [(1, 1), (3, 1), (1, 1)]) 400 - ] - ) - -test18 :: (ObjectiveFunction, [PolyConstraint]) -test18 = - ( Max (M.fromList [(1, -6), (2, -4), (3, 2)]) - , - [ LEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 - , LEQ (M.fromList [(2, -5), (3, 5)]) 100 - , LEQ (M.fromList [(1, 1), (3, 1), (1, 1)]) 400 - ] - ) - -test19 :: (ObjectiveFunction, [PolyConstraint]) -test19 = - ( Min (M.fromList [(1, -6), (2, -4), (3, 2)]) - , - [ GEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 - , GEQ (M.fromList [(2, -5), (3, 5)]) 100 - , GEQ (M.fromList [(1, 1), (3, 1), (1, 1)]) 400 - ] - ) - -test20 :: (ObjectiveFunction, [PolyConstraint]) -test20 = - ( Max (M.fromList [(1, -6), (2, -4), (3, 2)]) - , - [ GEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 - , GEQ (M.fromList [(2, -5), (3, 5)]) 100 - , GEQ (M.fromList [(1, 1), (3, 1), (1, 1)]) 400 - ] - ) - --- From page 59 of 'Linear and Integer Programming Made Easy' --- Solution: obj = 250, 1 = 0, 2 = 50, 3 = 0 -test21 :: (ObjectiveFunction, [PolyConstraint]) -test21 = - ( Max (M.fromList [(1, 3), (2, 5), (3, 2)]) - , - [ LEQ (M.fromList [(1, 5), (2, 1), (3, 4)]) 50 - , LEQ (M.fromList [(1, 1), (2, -1), (3, 1)]) 150 - , LEQ (M.fromList [(1, 2), (2, 1), (3, 2)]) 100 - ] - ) - -test22 :: (ObjectiveFunction, [PolyConstraint]) -test22 = - ( Min (M.fromList [(1, 3), (2, 5), (3, 2)]) - , - [ LEQ (M.fromList [(1, 5), (2, 1), (3, 4)]) 50 - , LEQ (M.fromList [(1, 1), (2, -1), (3, 1)]) 150 - , LEQ (M.fromList [(1, 2), (2, 1), (3, 2)]) 100 - ] - ) - -test23 :: (ObjectiveFunction, [PolyConstraint]) -test23 = - ( Max (M.fromList [(1, 3), (2, 5), (3, 2)]) - , - [ GEQ (M.fromList [(1, 5), (2, 1), (3, 4)]) 50 - , GEQ (M.fromList [(1, 1), (2, -1), (3, 1)]) 150 - , GEQ (M.fromList [(1, 2), (2, 1), (3, 2)]) 100 - ] - ) - -test24 :: (ObjectiveFunction, [PolyConstraint]) -test24 = - ( Min (M.fromList [(1, 3), (2, 5), (3, 2)]) - , - [ GEQ (M.fromList [(1, 5), (2, 1), (3, 4)]) 50 - , GEQ (M.fromList [(1, 1), (2, -1), (3, 1)]) 150 - , GEQ (M.fromList [(1, 2), (2, 1), (3, 2)]) 100 - ] - ) - -test25 :: (ObjectiveFunction, [PolyConstraint]) -test25 = - ( Max (M.fromList [(1, 1)]) - , - [ LEQ (M.fromList [(1, 1)]) 15 - ] - ) - -test26 :: (ObjectiveFunction, [PolyConstraint]) -test26 = - ( Max (M.fromList [(1, 2)]) - , - [ LEQ (M.fromList [(1, 2)]) 20 - , GEQ (M.fromList [(2, 1)]) 10 - ] - ) - -test27 :: (ObjectiveFunction, [PolyConstraint]) -test27 = - ( Min (M.fromList [(1, 1)]) - , - [ LEQ (M.fromList [(1, 1)]) 15 - ] - ) - -test28 :: (ObjectiveFunction, [PolyConstraint]) -test28 = - ( Min (M.fromList [(1, 2)]) - , - [ LEQ (M.fromList [(1, 2)]) 20 - , GEQ (M.fromList [(2, 1)]) 10 - ] - ) - -test29 :: (ObjectiveFunction, [PolyConstraint]) -test29 = - ( Max (M.fromList [(1, 1)]) - , - [ LEQ (M.fromList [(1, 1)]) 15 - , GEQ (M.fromList [(1, 1)]) 15.01 - ] - ) - -test30 :: (ObjectiveFunction, [PolyConstraint]) -test30 = - ( Max (M.fromList [(1, 1)]) - , - [ LEQ (M.fromList [(1, 1)]) 15 - , GEQ (M.fromList [(1, 1)]) 15.01 - , GEQ (M.fromList [(2, 1)]) 10 - ] - ) - -test31 :: (ObjectiveFunction, [PolyConstraint]) -test31 = - ( Min (M.fromList [(1, 1)]) - , - [ GEQ (M.fromList [(1, 1), (2, 1)]) 1 - , GEQ (M.fromList [(1, 1), (2, 1)]) 1 - ] - ) - -test32 :: (ObjectiveFunction, [PolyConstraint]) -test32 = - ( Min (M.fromList [(1, 1)]) - , - [ GEQ (M.fromList [(1, 1), (2, 1)]) 2 - , LEQ (M.fromList [(1, 1), (2, 1)]) 1 - ] - ) - --- Tests for systems similar to those from PolyPaver2 -testPolyPaver1 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaver1 = - ( Min (M.fromList [(1, 1)]) - , - [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 2.5 - x2l = 0.0 - x2r = 2.5 - dx1l = -1 - dx1r = -0.9 - dx2l = -0.9 - dx2r = -0.8 - yl = 4 - yr = 5 - -testPolyPaver2 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaver2 = - ( Max (M.fromList [(1, 1)]) - , - [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 2.5 - x2l = 0.0 - x2r = 2.5 - dx1l = -1 - dx1r = -0.9 - dx2l = -0.9 - dx2r = -0.8 - yl = 4 - yr = 5 - -testPolyPaver3 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaver3 = - ( Min (M.fromList [(2, 1)]) - , - [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 2.5 - x2l = 0.0 - x2r = 2.5 - dx1l = -1 - dx1r = -0.9 - dx2l = -0.9 - dx2r = -0.8 - yl = 4 - yr = 5 - -testPolyPaver4 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaver4 = - ( Max (M.fromList [(2, 1)]) - , - [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 2.5 - x2l = 0.0 - x2r = 2.5 - dx1l = -1 - dx1r = -0.9 - dx2l = -0.9 - dx2r = -0.8 - yl = 4 - yr = 5 - -testPolyPaver5 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaver5 = - ( Max (M.fromList [(1, 1)]) - , - [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 1.5 - x2l = 0.0 - x2r = 1.5 - dx1l = -1 - dx1r = -0.9 - dx2l = -0.9 - dx2r = -0.8 - yl = 4 - yr = 5 - -testPolyPaver6 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaver6 = - ( Min (M.fromList [(1, 1)]) - , - [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 1.5 - x2l = 0.0 - x2r = 1.5 - dx1l = -1 - dx1r = -0.9 - dx2l = -0.9 - dx2r = -0.8 - yl = 4 - yr = 5 - -testPolyPaver7 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaver7 = - ( Max (M.fromList [(2, 1)]) - , - [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 1.5 - x2l = 0.0 - x2r = 1.5 - dx1l = -1 - dx1r = -0.9 - dx2l = -0.9 - dx2r = -0.8 - yl = 4 - yr = 5 - -testPolyPaver8 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaver8 = - ( Min (M.fromList [(2, 1)]) - , - [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 1.5 - x2l = 0.0 - x2r = 1.5 - dx1l = -1 - dx1r = -0.9 - dx2l = -0.9 - dx2r = -0.8 - yl = 4 - yr = 5 - -testPolyPaver9 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaver9 = - ( Max (M.fromList [(1, 1)]) - , - [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 3.5 - x2l = 0.0 - x2r = 3.5 - dx1l = -1 - dx1r = -0.9 - dx2l = -0.9 - dx2r = -0.8 - yl = 4 - yr = 5 - -testPolyPaver10 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaver10 = - ( Min (M.fromList [(1, 1)]) - , - [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 3.5 - x2l = 0.0 - x2r = 3.5 - dx1l = -1 - dx1r = -0.9 - dx2l = -0.9 - dx2r = -0.8 - yl = 4 - yr = 5 - -testPolyPaver11 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaver11 = - ( Max (M.fromList [(2, 1)]) - , - [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 3.5 - x2l = 0.0 - x2r = 3.5 - dx1l = -1 - dx1r = -0.9 - dx2l = -0.9 - dx2r = -0.8 - yl = 4 - yr = 5 - -testPolyPaver12 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaver12 = - ( Min (M.fromList [(2, 1)]) - , - [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 3.5 - x2l = 0.0 - x2r = 3.5 - dx1l = -1 - dx1r = -0.9 - dx2l = -0.9 - dx2r = -0.8 - yl = 4 - yr = 5 - -testPolyPaverTwoFs1 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaverTwoFs1 = - ( Max (M.fromList [(1, 1)]) - , - [ LEQ (M.fromList [(1, f1dx1l), (2, f1dx2l), (3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) - , GEQ (M.fromList [(1, f1dx1r), (2, f1dx2r), (3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) - , LEQ (M.fromList [(1, f2dx1l), (2, f2dx2l), (4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) - , GEQ (M.fromList [(1, f2dx1r), (2, f2dx2r), (4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - , LEQ (M.fromList [(4, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 2.5 - x2l = 0.0 - x2r = 2.5 - f1dx1l = -1 - f1dx1r = -0.9 - f1dx2l = -0.9 - f1dx2r = -0.8 - f1yl = 4 - f1yr = 5 - f2dx1l = -1 - f2dx1r = -0.9 - f2dx2l = -0.9 - f2dx2r = -0.8 - f2yl = 1 - f2yr = 2 - -testPolyPaverTwoFs2 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaverTwoFs2 = - ( Min (M.fromList [(1, 1)]) - , - [ LEQ (M.fromList [(1, f1dx1l), (2, f1dx2l), (3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) - , GEQ (M.fromList [(1, f1dx1r), (2, f1dx2r), (3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) - , LEQ (M.fromList [(1, f2dx1l), (2, f2dx2l), (4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) - , GEQ (M.fromList [(1, f2dx1r), (2, f2dx2r), (4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - , LEQ (M.fromList [(4, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 2.5 - x2l = 0.0 - x2r = 2.5 - f1dx1l = -1 - f1dx1r = -0.9 - f1dx2l = -0.9 - f1dx2r = -0.8 - f1yl = 4 - f1yr = 5 - f2dx1l = -1 - f2dx1r = -0.9 - f2dx2l = -0.9 - f2dx2r = -0.8 - f2yl = 1 - f2yr = 2 - -testPolyPaverTwoFs3 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaverTwoFs3 = - ( Max (M.fromList [(2, 1)]) - , - [ LEQ (M.fromList [(1, f1dx1l), (2, f1dx2l), (3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) - , GEQ (M.fromList [(1, f1dx1r), (2, f1dx2r), (3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) - , LEQ (M.fromList [(1, f2dx1l), (2, f2dx2l), (4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) - , GEQ (M.fromList [(1, f2dx1r), (2, f2dx2r), (4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - , LEQ (M.fromList [(4, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 2.5 - x2l = 0.0 - x2r = 2.5 - f1dx1l = -1 - f1dx1r = -0.9 - f1dx2l = -0.9 - f1dx2r = -0.8 - f1yl = 4 - f1yr = 5 - f2dx1l = -1 - f2dx1r = -0.9 - f2dx2l = -0.9 - f2dx2r = -0.8 - f2yl = 1 - f2yr = 2 - -testPolyPaverTwoFs4 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaverTwoFs4 = - ( Min (M.fromList [(2, 1)]) - , - [ LEQ (M.fromList [(1, f1dx1l), (2, f1dx2l), (3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) - , GEQ (M.fromList [(1, f1dx1r), (2, f1dx2r), (3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) - , LEQ (M.fromList [(1, f2dx1l), (2, f2dx2l), (4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) - , GEQ (M.fromList [(1, f2dx1r), (2, f2dx2r), (4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - , LEQ (M.fromList [(4, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 2.5 - x2l = 0.0 - x2r = 2.5 - f1dx1l = -1 - f1dx1r = -0.9 - f1dx2l = -0.9 - f1dx2r = -0.8 - f1yl = 4 - f1yr = 5 - f2dx1l = -1 - f2dx1r = -0.9 - f2dx2l = -0.9 - f2dx2r = -0.8 - f2yl = 1 - f2yr = 2 - -testPolyPaverTwoFs5 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaverTwoFs5 = - ( Max (M.fromList [(1, 1)]) - , - [ LEQ (M.fromList [(1, f1dx1l), (2, f1dx2l), (3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) - , GEQ (M.fromList [(1, f1dx1r), (2, f1dx2r), (3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) - , LEQ (M.fromList [(1, f2dx1l), (2, f2dx2l), (4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) - , GEQ (M.fromList [(1, f2dx1r), (2, f2dx2r), (4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - , LEQ (M.fromList [(4, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 2.5 - x2l = 0.0 - x2r = 2.5 - f1dx1l = -1 - f1dx1r = -0.9 - f1dx2l = -0.9 - f1dx2r = -0.8 - f1yl = 4 - f1yr = 5 - f2dx1l = -0.66 - f2dx1r = -0.66 - f2dx2l = -0.66 - f2dx2r = -0.66 - f2yl = 3 - f2yr = 4 - -testPolyPaverTwoFs6 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaverTwoFs6 = - ( Min (M.fromList [(1, 1)]) - , - [ LEQ (M.fromList [(1, f1dx1l), (2, f1dx2l), (3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) - , GEQ (M.fromList [(1, f1dx1r), (2, f1dx2r), (3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) - , LEQ (M.fromList [(1, f2dx1l), (2, f2dx2l), (4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) - , GEQ (M.fromList [(1, f2dx1r), (2, f2dx2r), (4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - , LEQ (M.fromList [(4, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 2.5 - x2l = 0.0 - x2r = 2.5 - f1dx1l = -1 - f1dx1r = -0.9 - f1dx2l = -0.9 - f1dx2r = -0.8 - f1yl = 4 - f1yr = 5 - f2dx1l = -0.66 - f2dx1r = -0.66 - f2dx2l = -0.66 - f2dx2r = -0.66 - f2yl = 3 - f2yr = 4 - -testPolyPaverTwoFs7 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaverTwoFs7 = - ( Max (M.fromList [(2, 1)]) - , - [ LEQ (M.fromList [(1, f1dx1l), (2, f1dx2l), (3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) - , GEQ (M.fromList [(1, f1dx1r), (2, f1dx2r), (3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) - , LEQ (M.fromList [(1, f2dx1l), (2, f2dx2l), (4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) - , GEQ (M.fromList [(1, f2dx1r), (2, f2dx2r), (4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - , LEQ (M.fromList [(4, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 2.5 - x2l = 0.0 - x2r = 2.5 - f1dx1l = -1 - f1dx1r = -0.9 - f1dx2l = -0.9 - f1dx2r = -0.8 - f1yl = 4 - f1yr = 5 - f2dx1l = -0.66 - f2dx1r = -0.66 - f2dx2l = -0.66 - f2dx2r = -0.66 - f2yl = 3 - f2yr = 4 - -testPolyPaverTwoFs8 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaverTwoFs8 = - ( Min (M.fromList [(2, 1)]) - , - [ LEQ (M.fromList [(1, f1dx1l), (2, f1dx2l), (3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) - , GEQ (M.fromList [(1, f1dx1r), (2, f1dx2r), (3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) - , LEQ (M.fromList [(1, f2dx1l), (2, f2dx2l), (4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) - , GEQ (M.fromList [(1, f2dx1r), (2, f2dx2r), (4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - , LEQ (M.fromList [(4, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 2.5 - x2l = 0.0 - x2r = 2.5 - f1dx1l = -1 - f1dx1r = -0.9 - f1dx2l = -0.9 - f1dx2r = -0.8 - f1yl = 4 - f1yr = 5 - f2dx1l = -0.66 - f2dx1r = -0.66 - f2dx2l = -0.66 - f2dx2r = -0.66 - f2yl = 3 - f2yr = 4 - --- Test cases produced by old simplex-haskell/SoPlex QuickCheck prop - -testQuickCheck1 :: (ObjectiveFunction, [PolyConstraint]) -testQuickCheck1 = - ( Max (M.fromList [(1, 12), (2, -15)]) - , - [ EQ (M.fromList [(1, 24), (2, -2)]) (-12) - , GEQ (M.fromList [(1, -20), (2, 11)]) (-7) - , GEQ (M.fromList [(1, -28), (2, 5)]) (-8) - , GEQ (M.fromList [(1, 3), (2, 0)]) 5 - , LEQ (M.fromList [(1, -48)]) (-1) - ] - ) - --- Correct solution is -2/9 -testQuickCheck2 :: (ObjectiveFunction, [PolyConstraint]) -testQuickCheck2 = - ( Max (M.fromList [(1, -3), (2, 5)]) - , - [ LEQ (M.fromList [(1, -6), (2, 6)]) 4 - , LEQ (M.fromList [(1, 1), (2, -4), (3, 3)]) (-2) - , LEQ (M.fromList [(2, 7), (1, -4)]) 0 - ] - ) - --- This test will fail if the objective function is not simplified -testQuickCheck3 :: (ObjectiveFunction, [PolyConstraint]) -testQuickCheck3 = - ( Min (M.fromList [(2, 0), (2, -4)]) - , - [ GEQ (M.fromList [(1, 5), (2, 4)]) (-4) - , LEQ (M.fromList [(1, -1), (2, -1)]) 2 - , LEQ (M.fromList [(2, 1)]) 2 - , GEQ (M.fromList [(1, -5), (2, -1), (2, 1)]) (-5) - ] - ) From d1f2fc6422ad5c5adf3198852266ead2171ecfa5 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 18 May 2024 13:07:23 +0100 Subject: [PATCH 38/47] Test Bounds + Fix bug with mergeBounds --- src/Linear/Simplex/Types.hs | 18 +++- test/Linear/Simplex/TypesSpec.hs | 155 ++++++++++++++++++++++++++++++- 2 files changed, 171 insertions(+), 2 deletions(-) diff --git a/src/Linear/Simplex/Types.hs b/src/Linear/Simplex/Types.hs index f07f005..78bab87 100644 --- a/src/Linear/Simplex/Types.hs +++ b/src/Linear/Simplex/Types.hs @@ -371,7 +371,23 @@ deriveBounds = foldr updateBounds M.empty updateBounds _ = id mergeBounds :: Bounds -> Bounds -> Bounds - mergeBounds (Bounds l1 u1) (Bounds l2 u2) = Bounds (liftA2 max l1 l2) (liftA2 min u1 u2) + mergeBounds (Bounds l1 u1) (Bounds l2 u2) = Bounds (mergeLower l1 l2) (mergeUpper u1 u2) + where + mergeLower Nothing b = b + mergeLower a Nothing = a + mergeLower (Just a) (Just b) = Just (max a b) + + mergeUpper Nothing b = b + mergeUpper a Nothing = a + mergeUpper (Just a) (Just b) = Just (min a b) + +validateBounds :: VarBounds -> Bool +validateBounds boundsMap = all soundBounds $ M.toList boundsMap + where + soundBounds (_, Bounds lowerBound upperBound) = + case (lowerBound, upperBound) of + (Just l, Just u) -> l <= u + (_, _) -> True -- Eliminate inequalities which are outside the bounds -- precondition: no zero coefficients diff --git a/test/Linear/Simplex/TypesSpec.hs b/test/Linear/Simplex/TypesSpec.hs index b2c4484..0f2b427 100644 --- a/test/Linear/Simplex/TypesSpec.hs +++ b/test/Linear/Simplex/TypesSpec.hs @@ -538,4 +538,157 @@ spec = do <> "\nsimplifiedSimpleSystemEval: " <> show simplifiedSimpleSystemEval ) $ - simpleSystemEval == simplifiedSimpleSystemEval \ No newline at end of file + simpleSystemEval == simplifiedSimpleSystemEval + describe "Bounds" $ do + it "validateBounds finds that deriving bounds for a system where -1 <= x <= 1 has valid bounds" $ do + let simpleSystem = + [ Expr (VarTerm 0) :>= (-1) + , Expr (VarTerm 0) :<= 1 + ] + derivedBounds = deriveBounds simpleSystem + expectedBounds = Map.fromList [(0, Bounds (Just (-1)) (Just 1))] + derivedBounds `shouldBe` expectedBounds + validateBounds derivedBounds `shouldBe` True + it "validateBounds finds that deriving bounds for a system where 0 <= x <= 1 has valid bounds" $ do + let simpleSystem = + [ Expr (VarTerm 0) :>= 0 + , Expr (VarTerm 0) :<= 1 + ] + derivedBounds = deriveBounds simpleSystem + expectedBounds = Map.fromList [(0, Bounds (Just 0) (Just 1))] + derivedBounds `shouldBe` expectedBounds + validateBounds derivedBounds `shouldBe` True + it "validateBounds finds that deriving bounds for a system where 1 <= x <= 1 has valid bounds" $ do + let simpleSystem = + [ Expr (VarTerm 0) :>= 1 + , Expr (VarTerm 0) :<= 1 + ] + derivedBounds = deriveBounds simpleSystem + expectedBounds = Map.fromList [(0, Bounds (Just 1) (Just 1))] + derivedBounds `shouldBe` expectedBounds + validateBounds derivedBounds `shouldBe` True + it "validateBounds finds that deriving bounds for a system where 1 <= x <= 0 has invalid bounds" $ do + let simpleSystem = + [ Expr (VarTerm 0) :>= 1 + , Expr (VarTerm 0) :<= 0 + ] + derivedBounds = deriveBounds simpleSystem + expectedBounds = Map.fromList [(0, Bounds (Just 1) (Just 0))] + derivedBounds `shouldBe` expectedBounds + validateBounds derivedBounds `shouldBe` False + it "validateBounds finds that deriving bounds for a system where 0 <= x <= 1 and 1 <= y <= 3 has valid bounds" $ do + let simpleSystem = + [ Expr (VarTerm 0) :>= 0 + , Expr (VarTerm 0) :<= 1 + , Expr (VarTerm 1) :>= 1 + , Expr (VarTerm 1) :<= 3 + ] + derivedBounds = deriveBounds simpleSystem + expectedBounds = Map.fromList [(0, Bounds (Just 0) (Just 1)), (1, Bounds (Just 1) (Just 3))] + derivedBounds `shouldBe` expectedBounds + validateBounds derivedBounds `shouldBe` True + it "validateBounds finds that deriving bounds for a system where 1 <= x <= 0 and 3 <= y <= 1 has invalid bounds" $ do + let simpleSystem = + [ Expr (VarTerm 0) :>= 1 + , Expr (VarTerm 0) :<= 0 + , Expr (VarTerm 1) :>= 3 + , Expr (VarTerm 1) :<= 1 + ] + derivedBounds = deriveBounds simpleSystem + expectedBounds = Map.fromList [(0, Bounds (Just 1) (Just 0)), (1, Bounds (Just 3) (Just 1))] + derivedBounds `shouldBe` expectedBounds + validateBounds derivedBounds `shouldBe` False + it "validateBounds finds that deriving bounds for a system where 1 <= x <= 0 and 1 <= y <= 3 has invalid bounds" $ do + let simpleSystem = + [ Expr (VarTerm 0) :>= 1 + , Expr (VarTerm 0) :<= 0 + , Expr (VarTerm 1) :>= 1 + , Expr (VarTerm 1) :<= 3 + ] + derivedBounds = deriveBounds simpleSystem + expectedBounds = Map.fromList [(0, Bounds (Just 1) (Just 0)), (1, Bounds (Just 1) (Just 3))] + derivedBounds `shouldBe` expectedBounds + validateBounds derivedBounds `shouldBe` False + it "validateBounds finds that deriving bounds for a system where 0 <= x <= 1 and 3 <= y <= 1 has invalid bounds" $ do + let simpleSystem = + [ Expr (VarTerm 0) :>= 0 + , Expr (VarTerm 0) :<= 1 + , Expr (VarTerm 1) :>= 3 + , Expr (VarTerm 1) :<= 1 + ] + derivedBounds = deriveBounds simpleSystem + expectedBounds = Map.fromList [(0, Bounds (Just 0) (Just 1)), (1, Bounds (Just 3) (Just 1))] + derivedBounds `shouldBe` expectedBounds + validateBounds derivedBounds `shouldBe` False + it "removeUselessSystemBounds removes x <= 3 when bounds say x <= 2" $ do + let simpleSystem = + [ Expr (VarTerm 0) :<= 2 + , Expr (VarTerm 0) :<= 3 + ] + bounds = Map.fromList [(0, Bounds (Just 0) (Just 2))] + simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds + expectedSimpleSystem = [Expr (VarTerm 0) :<= 2] + simplifiedSimpleSystem `shouldBe` expectedSimpleSystem + it "removeUselessSystemBounds does not remove x <= 2 when bounds say x <= 2" $ do + let simpleSystem = + [ Expr (VarTerm 0) :<= 2 + ] + bounds = Map.fromList [(0, Bounds (Just 0) (Just 2))] + simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds + expectedSimpleSystem = [Expr (VarTerm 0) :<= 2] + simplifiedSimpleSystem `shouldBe` expectedSimpleSystem + it "removeUselessSystemBounds removes x >= 3 when bounds say x >= 4" $ do + let simpleSystem = + [ Expr (VarTerm 0) :>= 4 + , Expr (VarTerm 0) :>= 3 + ] + bounds = Map.fromList [(0, Bounds (Just 4) (Just 5))] + simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds + expectedSimpleSystem = [Expr (VarTerm 0) :>= 4] + simplifiedSimpleSystem `shouldBe` expectedSimpleSystem + it "removeUselessSystemBounds does not remove x >= 4 when bounds say x >= 4" $ do + let simpleSystem = + [ Expr (VarTerm 0) :>= 4 + ] + bounds = Map.fromList [(0, Bounds (Just 4) (Just 5))] + simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds + expectedSimpleSystem = [Expr (VarTerm 0) :>= 4] + simplifiedSimpleSystem `shouldBe` expectedSimpleSystem + it "removeUselessSystemBounds does not remove 0 <= x <= 2 when bounds say 0 <= x <= 2" $ do + let simpleSystem = + [ Expr (VarTerm 0) :>= 0 + , Expr (VarTerm 0) :<= 2 + ] + bounds = Map.fromList [(0, Bounds (Just 0) (Just 2))] + simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds + expectedSimpleSystem = [Expr (VarTerm 0) :>= 0, Expr (VarTerm 0) :<= 2] + simplifiedSimpleSystem `shouldBe` expectedSimpleSystem + it "removeUselessSystemBounds removes upper bound of 0 <= x <= 2 when bounds say 0 <= x <= 1" $ do + let simpleSystem = + [ Expr (VarTerm 0) :>= 0 + , Expr (VarTerm 0) :<= 2 + ] + bounds = Map.fromList [(0, Bounds (Just 0) (Just 1))] + simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds + expectedSimpleSystem = [Expr (VarTerm 0) :>= 0] + simplifiedSimpleSystem `shouldBe` expectedSimpleSystem + it "removeUselessSystemBounds removes lower bound of 0 <= x <= 2 when bounds say 1 <= x <= 2" $ do + let simpleSystem = + [ Expr (VarTerm 0) :>= 0 + , Expr (VarTerm 0) :<= 2 + ] + bounds = Map.fromList [(0, Bounds (Just 1) (Just 2))] + simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds + expectedSimpleSystem = [Expr (VarTerm 0) :<= 2] + simplifiedSimpleSystem `shouldBe` expectedSimpleSystem + it "removeUselssSystemBounds only removes constraints of the form x <= c" $ do + let simpleSystem = + [ Expr (VarTerm 0) :<= 2 + , Expr (VarTerm 0) :<= 3 + , Expr (CoeffTerm 2 0) :<= 6 + ] + bounds = Map.fromList [(0, Bounds (Just 0) (Just 2))] + simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds + expectedSimpleSystem = [Expr (VarTerm 0) :<= 2, Expr (CoeffTerm 2 0) :<= 6] + simplifiedSimpleSystem `shouldBe` expectedSimpleSystem + \ No newline at end of file From 79a5a6f4b9e8feded2662975070d7348b8f967b3 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 18 May 2024 13:20:10 +0100 Subject: [PATCH 39/47] Test findHighestVar + And fix bug with findHighestVar --- src/Linear/Simplex/Types.hs | 14 +++++++++++--- test/Linear/Simplex/TypesSpec.hs | 27 ++++++++++++++++++++++++++- 2 files changed, 37 insertions(+), 4 deletions(-) diff --git a/src/Linear/Simplex/Types.hs b/src/Linear/Simplex/Types.hs index 78bab87..d2310e2 100644 --- a/src/Linear/Simplex/Types.hs +++ b/src/Linear/Simplex/Types.hs @@ -341,6 +341,17 @@ type SimpleSystem = [SimpleConstraint] simplifySimpleSystem :: SimpleSystem -> SimpleSystem simplifySimpleSystem = map simplifySimpleConstraint +findHighestVar :: SimpleSystem -> Var +findHighestVar simpleSystem = + let + vars = [v | gc <- simpleSystem, + term <- exprToList $ getGenericConstraintLHS gc, + v <- case term of + VarTerm v -> [v] + CoeffTerm _ v -> [v] + _ -> []] + in maximum vars + data StandardFormRow = StandardFormRow { lhs :: Expr , rhs :: SimplexNum @@ -406,9 +417,6 @@ removeUselessSystemBounds constraints bounds = ) constraints -findHighestVar :: SimpleSystem -> Var -findHighestVar = maximum . map (maximum . map (\case (CoeffTerm _ v) -> v; _ -> 0) . exprToList . getGenericConstraintLHS) - -- | Eliminate negative lower bounds via substitution -- Return the system with the eliminated variables and a map of the eliminated variables to their equivalent expressions -- First step here https://en.wikipedia.org/wiki/Simplex_algorithm#Standard_form diff --git a/test/Linear/Simplex/TypesSpec.hs b/test/Linear/Simplex/TypesSpec.hs index 0f2b427..5baccee 100644 --- a/test/Linear/Simplex/TypesSpec.hs +++ b/test/Linear/Simplex/TypesSpec.hs @@ -539,6 +539,32 @@ spec = do <> show simplifiedSimpleSystemEval ) $ simpleSystemEval == simplifiedSimpleSystemEval + it "findHighestVar finds the highest variable in a simple system" $ do + let simpleSystem1 = + [ Expr (VarTerm 0) :>= 0 + , Expr (VarTerm 0) :<= 1 + , Expr (VarTerm 1) :>= 0 + , Expr (VarTerm 1) :<= 1 + ] + simpleSystem100 = + [ Expr (VarTerm 0) :<= 1 + , Expr (VarTerm 50) :<= 1 + , Expr (VarTerm 100) :<= 1 + ] + simpleSystem10 = + [ Expr (VarTerm (-10)) :<= 1 + , Expr (VarTerm 0) :<= 1 + , Expr (VarTerm 10) :<= 1 + ] + simpleSystemMinus10 = + [ Expr (VarTerm (-10)) :<= 1 + , Expr (VarTerm (-20)) :<= 1 + ] + + findHighestVar simpleSystem1 `shouldBe` 1 + findHighestVar simpleSystem100 `shouldBe` 100 + findHighestVar simpleSystem10 `shouldBe` 10 + findHighestVar simpleSystemMinus10 `shouldBe` (-10) describe "Bounds" $ do it "validateBounds finds that deriving bounds for a system where -1 <= x <= 1 has valid bounds" $ do let simpleSystem = @@ -691,4 +717,3 @@ spec = do simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds expectedSimpleSystem = [Expr (VarTerm 0) :<= 2, Expr (CoeffTerm 2 0) :<= 6] simplifiedSimpleSystem `shouldBe` expectedSimpleSystem - \ No newline at end of file From f5ac83e1847b94817f3aebce25bf0adebc396b1e Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 24 Aug 2024 18:12:32 +0100 Subject: [PATCH 40/47] split modules up reasonably + create new types for TermVarsOnly, ExprVarsOnly + Make Expr a non-empty list of terms + solver class for the future --- fourmolu.yaml | 4 +- package.yaml | 6 +- simplex-method.cabal | 30 +- src/Linear/Constraint/Generic/Types.hs | 33 + src/Linear/Constraint/Linear/Types.hs | 27 + src/Linear/Constraint/Simple/Types.hs | 14 + src/Linear/Constraint/Simple/Util.hs | 129 ++++ src/Linear/Constraint/Types.hs | 16 + src/Linear/Constraint/Util.hs | 21 + src/Linear/Expr/Types.hs | 34 + src/Linear/Expr/Util.hs | 101 +++ src/Linear/Simplex/DeriveBounds.hs | 112 ---- src/Linear/Simplex/Prettify.hs | 17 +- src/Linear/Simplex/Solver/TwoPhase.hs | 475 ++++++++------ src/Linear/Simplex/Solver/Types.hs | 25 + src/Linear/Simplex/Standardize.hs | 4 - src/Linear/Simplex/Types.hs | 487 +-------------- src/Linear/Simplex/Util.hs | 49 +- src/Linear/SlackForm/Types.hs | 24 + src/Linear/SlackForm/Util.hs | 123 ++++ src/Linear/System/Linear/Types.hs | 24 + src/Linear/System/Simple/Types.hs | 38 ++ src/Linear/System/Simple/Util.hs | 66 ++ src/Linear/System/Types.hs | 6 + src/Linear/Term/Types.hs | 31 + src/Linear/Term/Util.hs | 101 +++ src/Linear/Var/Types.hs | 16 + src/Linear/Var/Util.hs | 12 + test/Linear/Constraint/Simple/UtilSpec.hs | 183 ++++++ test/Linear/Expr/UtilSpec.hs | 269 ++++++++ test/Linear/Simplex/TypesSpec.hs | 719 ---------------------- test/Linear/SlackForm/UtilSpec.hs | 380 ++++++++++++ test/Linear/System/Simple/UtilSpec.hs | 256 ++++++++ test/Linear/Term/UtilSpec.hs | 133 ++++ test/Linear/Var/UtilSpec.hs | 21 + test/Spec.hs | 2 +- test/TestUtil.hs | 73 +++ 37 files changed, 2537 insertions(+), 1524 deletions(-) create mode 100644 src/Linear/Constraint/Generic/Types.hs create mode 100644 src/Linear/Constraint/Linear/Types.hs create mode 100644 src/Linear/Constraint/Simple/Types.hs create mode 100644 src/Linear/Constraint/Simple/Util.hs create mode 100644 src/Linear/Constraint/Types.hs create mode 100644 src/Linear/Constraint/Util.hs create mode 100644 src/Linear/Expr/Types.hs create mode 100644 src/Linear/Expr/Util.hs delete mode 100644 src/Linear/Simplex/DeriveBounds.hs create mode 100644 src/Linear/Simplex/Solver/Types.hs create mode 100644 src/Linear/SlackForm/Types.hs create mode 100644 src/Linear/SlackForm/Util.hs create mode 100644 src/Linear/System/Linear/Types.hs create mode 100644 src/Linear/System/Simple/Types.hs create mode 100644 src/Linear/System/Simple/Util.hs create mode 100644 src/Linear/System/Types.hs create mode 100644 src/Linear/Term/Types.hs create mode 100644 src/Linear/Term/Util.hs create mode 100644 src/Linear/Var/Types.hs create mode 100644 src/Linear/Var/Util.hs create mode 100644 test/Linear/Constraint/Simple/UtilSpec.hs create mode 100644 test/Linear/Expr/UtilSpec.hs delete mode 100644 test/Linear/Simplex/TypesSpec.hs create mode 100644 test/Linear/SlackForm/UtilSpec.hs create mode 100644 test/Linear/System/Simple/UtilSpec.hs create mode 100644 test/Linear/Term/UtilSpec.hs create mode 100644 test/Linear/Var/UtilSpec.hs create mode 100644 test/TestUtil.hs diff --git a/fourmolu.yaml b/fourmolu.yaml index 9b7746d..7d6d1f0 100644 --- a/fourmolu.yaml +++ b/fourmolu.yaml @@ -1,5 +1,5 @@ indentation: 2 -column-limit: 120 +column-limit: 80 function-arrows: trailing comma-style: leading import-export-style: leading @@ -12,5 +12,5 @@ let-style: inline in-style: left-align single-constraint-parens: always unicode: never -respectful: true +respectful: false fixities: [] diff --git a/package.yaml b/package.yaml index 8aadf2d..044dca5 100644 --- a/package.yaml +++ b/package.yaml @@ -52,9 +52,11 @@ library: source-dirs: src tests: - simplex-haskell-test: + simplex-method-test: defaults: hspec/hspec@main + main: Spec.hs + source-dirs: test dependencies: - - simplex-method - hspec - QuickCheck + - simplex-method diff --git a/simplex-method.cabal b/simplex-method.cabal index 1f3c4a8..ad954f4 100644 --- a/simplex-method.cabal +++ b/simplex-method.cabal @@ -27,12 +27,30 @@ source-repository head library exposed-modules: - Linear.Simplex.DeriveBounds + Linear.Constraint.Generic.Types + Linear.Constraint.Linear.Types + Linear.Constraint.Simple.Types + Linear.Constraint.Simple.Util + Linear.Constraint.Types + Linear.Constraint.Util + Linear.Expr.Types + Linear.Expr.Util Linear.Simplex.Prettify Linear.Simplex.Solver.TwoPhase + Linear.Simplex.Solver.Types Linear.Simplex.Standardize Linear.Simplex.Types Linear.Simplex.Util + Linear.SlackForm.Types + Linear.SlackForm.Util + Linear.System.Linear.Types + Linear.System.Simple.Types + Linear.System.Simple.Util + Linear.System.Types + Linear.Term.Types + Linear.Term.Util + Linear.Var.Types + Linear.Var.Util other-modules: Paths_simplex_method hs-source-dirs: @@ -51,11 +69,17 @@ library , time default-language: Haskell2010 -test-suite simplex-haskell-test +test-suite simplex-method-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: - Linear.Simplex.TypesSpec + Linear.Constraint.Simple.UtilSpec + Linear.Expr.UtilSpec + Linear.SlackForm.UtilSpec + Linear.System.Simple.UtilSpec + Linear.Term.UtilSpec + Linear.Var.UtilSpec + TestUtil Paths_simplex_method hs-source-dirs: test diff --git a/src/Linear/Constraint/Generic/Types.hs b/src/Linear/Constraint/Generic/Types.hs new file mode 100644 index 0000000..2f26a17 --- /dev/null +++ b/src/Linear/Constraint/Generic/Types.hs @@ -0,0 +1,33 @@ +-- | +-- Module : Linear.Constraint.Generic.Types +-- Description : Types for constraints in linear programming problems +-- Copyright : (c) Junaid Rasheed, 2020-2024 +-- License : BSD-3 +-- Maintainer : jrasheed178@gmail.com +-- Stability : experimental +module Linear.Constraint.Generic.Types where + +import Control.Applicative (liftA2) +import GHC.Generics (Generic) +import Test.QuickCheck (Arbitrary, arbitrary, genericShrink, oneof) + +data GenericConstraint a b = a :<= b | a :>= b | a :== b + deriving (Show, Read, Eq, Generic) + +instance (Arbitrary a, Arbitrary b) => Arbitrary (GenericConstraint a b) where + arbitrary = + oneof + [ liftA2 (:<=) arbitrary arbitrary + , liftA2 (:>=) arbitrary arbitrary + , liftA2 (:==) arbitrary arbitrary + ] + +getGenericConstraintLHS :: GenericConstraint a b -> a +getGenericConstraintLHS (a :<= _) = a +getGenericConstraintLHS (a :>= _) = a +getGenericConstraintLHS (a :== _) = a + +getGenericConstraintRHS :: GenericConstraint a b -> b +getGenericConstraintRHS (_ :<= b) = b +getGenericConstraintRHS (_ :>= b) = b +getGenericConstraintRHS (_ :== b) = b diff --git a/src/Linear/Constraint/Linear/Types.hs b/src/Linear/Constraint/Linear/Types.hs new file mode 100644 index 0000000..afa4b9f --- /dev/null +++ b/src/Linear/Constraint/Linear/Types.hs @@ -0,0 +1,27 @@ +-- | +-- Description: Types for linear constraints. +-- Copyright: (c) Junaid Rasheed, 2024 +-- License: BSD-3 +-- Maintainer: Junaid Rasheed +-- Stability: experimental +module Linear.Constraint.Linear.Types where + +import GHC.Generics (Generic) +import Linear.Expr.Types (Expr) +import Linear.Var.Types (SimplexNum) + +-- TODO: Expr -> ExprVarsOnly +-- lhs == rhs +data LinearEquation = LinearEquation + { lhs :: Expr + , rhs :: SimplexNum + } + deriving (Show, Eq, Read, Generic) + +-- class CanBeLinearEquation a where +-- toLinearEquation :: a -> LinearEquation +-- fromLinearEquation :: LinearEquation -> a + +-- instance CanBeLinearEquation LinearEquation where +-- toLinearEquation = id +-- fromLinearEquation = id diff --git a/src/Linear/Constraint/Simple/Types.hs b/src/Linear/Constraint/Simple/Types.hs new file mode 100644 index 0000000..aad774f --- /dev/null +++ b/src/Linear/Constraint/Simple/Types.hs @@ -0,0 +1,14 @@ +-- | +-- Module: Linear.Constraint.Simple.Types +-- Description: Types for simple linear constraints +-- Copyright: (c) Junaid Rasheed, 2020-2024 +-- License: BSD-3 +-- Maintainer: jrasheed178@gmail.com +-- Stability: experimental +module Linear.Constraint.Simple.Types where + +import Linear.Constraint.Generic.Types (GenericConstraint) +import Linear.Expr.Types (Expr) +import Linear.Var.Types (SimplexNum) + +type SimpleConstraint = GenericConstraint Expr SimplexNum diff --git a/src/Linear/Constraint/Simple/Util.hs b/src/Linear/Constraint/Simple/Util.hs new file mode 100644 index 0000000..4670947 --- /dev/null +++ b/src/Linear/Constraint/Simple/Util.hs @@ -0,0 +1,129 @@ +-- | +-- Module: Linear.Constraint.Simple.Util +-- Description: Utility functions for simple constraints +-- Copyright: (c) Junaid Rasheed, 2020-2024 +-- License: BSD-3 +-- Maintainer: jrasheed178@gmail.com +-- Stability: experimental +module Linear.Constraint.Simple.Util where + +import qualified Data.List as L +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Set as Set +import Linear.Constraint.Generic.Types + ( GenericConstraint ((:<=), (:==), (:>=)) + ) +import Linear.Constraint.Simple.Types (SimpleConstraint) +import Linear.Constraint.Types (Constraint) +import Linear.Expr.Types (Expr (Expr)) +import Linear.Expr.Util + ( exprToList + , exprVars + , listToExpr + , simplifyExpr + , substVarExpr + , subtractExpr + , sumExprConstTerms + , zeroConstExpr + ) +import Linear.Term.Types (Term (CoeffTerm, ConstTerm, VarTerm)) +import Linear.Var.Types (Var) + +substVarSimpleConstraint :: Var -> Expr -> SimpleConstraint -> SimpleConstraint +substVarSimpleConstraint var varReplacement (a :<= b) = substVarExpr var varReplacement a :<= b +substVarSimpleConstraint var varReplacement (a :>= b) = substVarExpr var varReplacement a :>= b +substVarSimpleConstraint var varReplacement (a :== b) = substVarExpr var varReplacement a :== b + +constraintToSimpleConstraint :: Constraint -> SimpleConstraint +constraintToSimpleConstraint constraint = + case constraint of + (a :<= b) -> uncurry (:<=) (calcLhsRhs a b) + (a :>= b) -> uncurry (:>=) (calcLhsRhs a b) + (a :== b) -> uncurry (:==) (calcLhsRhs a b) + where + calcLhsRhs a b = (lhs, rhs) + where + aConsts = sumExprConstTerms a + bConsts = sumExprConstTerms b + rhs = bConsts - aConsts + + aWithoutConst = simplifyExpr . zeroConstExpr $ a + bWithoutConst = simplifyExpr . zeroConstExpr $ b + + lhs = subtractExpr aWithoutConst bWithoutConst + calcRhs a b = rhs + where + aConsts = sumExprConstTerms a + bConsts = sumExprConstTerms b + rhs = bConsts - aConsts + + aWithoutConst = simplifyExpr . zeroConstExpr $ a + bWithoutConst = simplifyExpr . zeroConstExpr $ b + + lhs = subtractExpr aWithoutConst bWithoutConst + +-- normalize simple constraints by moving all constants to the right +normalizeSimpleConstraint :: SimpleConstraint -> SimpleConstraint +normalizeSimpleConstraint (expr :<= num) = + let exprList = exprToList expr + + isConstTerm (ConstTerm _) = True + isConstTerm _ = False + + (sumExprConstTerms, nonConstTerms) = L.partition isConstTerm exprList + + constTermsVal = sum . map (\case (ConstTerm c) -> c; _ -> 0) $ sumExprConstTerms + + newExpr = listToExpr nonConstTerms + newNum = num - constTermsVal + in newExpr :<= newNum +normalizeSimpleConstraint (expr :>= num) = + let exprList = exprToList expr + + isConstTerm (ConstTerm _) = True + isConstTerm _ = False + + (sumExprConstTerms, nonConstTerms) = L.partition isConstTerm exprList + + constTermsVal = sum . map (\case (ConstTerm c) -> c; _ -> 0) $ sumExprConstTerms + + newExpr = listToExpr nonConstTerms + newNum = num - constTermsVal + in newExpr :>= newNum +normalizeSimpleConstraint (expr :== num) = + let exprList = exprToList expr + + isConstTerm (ConstTerm _) = True + isConstTerm _ = False + + (sumExprConstTerms, nonConstTerms) = L.partition isConstTerm exprList + + constTermsVal = sum . map (\case (ConstTerm c) -> c; _ -> 0) $ sumExprConstTerms + + newExpr = listToExpr nonConstTerms + newNum = num - constTermsVal + in newExpr :== newNum + +-- | Simplify coeff constraints by dividing the coefficient from both sides +simplifyCoeff :: SimpleConstraint -> SimpleConstraint +simplifyCoeff expr@(Expr (CoeffTerm coeff var :| []) :<= num) + | coeff == 0 = expr + | coeff > 0 = Expr (VarTerm var :| []) :<= (num / coeff) + | coeff < 0 = Expr (VarTerm var :| []) :>= (num / coeff) +simplifyCoeff expr@(Expr (CoeffTerm coeff var :| []) :>= num) + | coeff == 0 = expr + | coeff > 0 = Expr (VarTerm var :| []) :>= (num / coeff) + | coeff < 0 = Expr (VarTerm var :| []) :<= (num / coeff) +simplifyCoeff expr@(Expr (CoeffTerm coeff var :| []) :== num) = if coeff == 0 then expr else Expr (VarTerm var :| []) :== (num / coeff) +simplifyCoeff expr = expr + +simplifySimpleConstraint :: SimpleConstraint -> SimpleConstraint +simplifySimpleConstraint (expr :<= num) = simplifyCoeff . normalizeSimpleConstraint $ simplifyExpr expr :<= num +simplifySimpleConstraint (expr :>= num) = simplifyCoeff . normalizeSimpleConstraint $ simplifyExpr expr :>= num +simplifySimpleConstraint (expr :== num) = simplifyCoeff . normalizeSimpleConstraint $ simplifyExpr expr :== num + +simpleConstraintVars :: SimpleConstraint -> Set.Set Var +simpleConstraintVars (expr :<= _) = exprVars expr +simpleConstraintVars (expr :>= _) = exprVars expr +simpleConstraintVars (expr :== _) = exprVars expr diff --git a/src/Linear/Constraint/Types.hs b/src/Linear/Constraint/Types.hs new file mode 100644 index 0000000..0c74884 --- /dev/null +++ b/src/Linear/Constraint/Types.hs @@ -0,0 +1,16 @@ +-- | +-- Module: Linear.Constraint.Types +-- Description: Types for linear constraints +-- Copyright: (c) Junaid Rasheed, 2020-2024 +-- License: BSD-3 +-- Maintainer: jrasheed178@gmail.com +-- Stability: experimental +module Linear.Constraint.Types where + +import qualified Data.Set as Set +import GHC.Generics (Generic) +import Linear.Constraint.Generic.Types (GenericConstraint) +import Linear.Expr.Types (Expr) + +-- Input +type Constraint = GenericConstraint Expr Expr diff --git a/src/Linear/Constraint/Util.hs b/src/Linear/Constraint/Util.hs new file mode 100644 index 0000000..334790f --- /dev/null +++ b/src/Linear/Constraint/Util.hs @@ -0,0 +1,21 @@ +-- | +-- Module: Linear.Constraint.Util +-- Description: Utility functions for constraints +-- Copyright: (c) Junaid Rasheed, 2020-2024 +-- License: BSD-3 +-- Maintainer: jrasheed178@gmail.com +-- Stability: experimental +module Linear.Constraint.Util where + +import qualified Data.Set as Set +import Linear.Constraint.Generic.Types + ( GenericConstraint ((:<=), (:==), (:>=)) + ) +import Linear.Constraint.Types (Constraint) +import Linear.Expr.Util (exprVars) +import Linear.Var.Types (Var) + +constraintVars :: Constraint -> Set.Set Var +constraintVars (lhs :<= rhs) = exprVars lhs <> exprVars rhs +constraintVars (lhs :>= rhs) = exprVars lhs <> exprVars rhs +constraintVars (lhs :== rhs) = exprVars lhs <> exprVars rhs diff --git a/src/Linear/Expr/Types.hs b/src/Linear/Expr/Types.hs new file mode 100644 index 0000000..b78a3c0 --- /dev/null +++ b/src/Linear/Expr/Types.hs @@ -0,0 +1,34 @@ +-- | +-- Module: Linear.Expr.Types +-- Description: Types for linear expressions +-- Copyright: (c) Junaid Rasheed, 2020-2024 +-- License: BSD-3 +-- Maintainer: jrasheed178@gmail.com +-- Stability: experimental +module Linear.Expr.Types where + +import qualified Data.List.NonEmpty as NE +import GHC.Base (liftA2) +import GHC.Generics (Generic) +import Linear.Term.Types (Term, TermVarsOnly) +import Test.QuickCheck (Arbitrary (..)) +import Test.QuickCheck.Gen (suchThat) + +newtype Expr = Expr {unExpr :: NE.NonEmpty Term} + deriving + ( Show + , Read + , Eq + , Generic + ) + +newtype ExprVarsOnly = ExprVarsOnly {unExprVarsOnly :: NE.NonEmpty TermVarsOnly} + deriving + ( Show + , Read + , Eq + , Generic + ) + +instance Arbitrary Expr where + arbitrary = Expr . NE.fromList <$> arbitrary `suchThat` (not . null) diff --git a/src/Linear/Expr/Util.hs b/src/Linear/Expr/Util.hs new file mode 100644 index 0000000..91c25f7 --- /dev/null +++ b/src/Linear/Expr/Util.hs @@ -0,0 +1,101 @@ +-- | +-- Module: Linear.Expr.Util +-- Description: Utility functions for linear expressions +-- Copyright: (c) Junaid Rasheed, 2020-2024 +-- License: BSD-3 +-- Maintainer: jrasheed178@gmail.com +-- Stability: experimental +module Linear.Expr.Util where + +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Maybe as Maybe +import qualified Data.Set as Set +import Linear.Expr.Types (Expr (..), ExprVarsOnly (..)) +import Linear.Term.Types (Term (..)) +import Linear.Term.Util + ( negateTerm + , normalizeTerms + , simplifyTerm + , unsafeTermToTermVarsOnly + , zeroConstTerm + ) +import Linear.Var.Types (SimplexNum, Var) + +-- | Convert an 'Expr' to a list of 'Term's. +exprToList :: Expr -> [Term] +exprToList (Expr t) = NE.toList t + +-- | Convert a list of 'Term's to an 'Expr'. +listToExpr :: [Term] -> Expr +listToExpr [] = Expr $ ConstTerm 0 :| [] -- TODO: Maybe throw an error? +listToExpr ts = Expr $ NE.fromList ts + +exprVars :: Expr -> Set.Set Var +exprVars = Set.fromList . Maybe.mapMaybe termVars . exprToList + where + termVars :: Term -> Maybe Var + termVars (ConstTerm _) = Nothing + termVars (CoeffTerm _ v) = Just v + termVars (VarTerm v) = Just v + +simplifyExpr :: Expr -> Expr +simplifyExpr = listToExpr . normalizeTerms . exprToList + +sumExprConstTerms :: Expr -> SimplexNum +sumExprConstTerms (Expr ts) = sumExprConstTerms ts + where + sumExprConstTerms = sum . Maybe.mapMaybe termConst . NE.toList + + termConst :: Term -> Maybe SimplexNum + termConst (ConstTerm c) = Just c + termConst _ = Nothing + +zeroConstExpr :: Expr -> Expr +zeroConstExpr (Expr ts) = Expr $ NE.map zeroConstTerm ts + +negateExpr :: Expr -> Expr +negateExpr (Expr ts) = Expr $ NE.map negateTerm ts + +addExpr :: Expr -> Expr -> Expr +addExpr e1 e2 = + -- Safe as Expr :+ Term is the only constructor + simplifyExpr . listToExpr $ (exprToList e1 <> exprToList e2) + +subtractExpr :: Expr -> Expr -> Expr +subtractExpr e1 e2 = addExpr e1 (negateExpr e2) + +substVarExpr :: Var -> Expr -> Expr -> Expr +substVarExpr var varReplacement = simplifyExpr . listToExpr . aux . exprToList + where + replacementTerms = exprToList varReplacement + + aux :: [Term] -> [Term] + aux [] = [] + aux (t : ts) = case t of + (VarTerm tV) -> if tV == var then aux ts ++ replacementTerms else t : aux ts + (CoeffTerm tC tV) -> + if tV == var + then + let newReplacementTerms = + map + ( simplifyTerm + . \case + (CoeffTerm rC rV) -> CoeffTerm (tC * rC) rV + (VarTerm rV) -> CoeffTerm tC rV + (ConstTerm rC) -> ConstTerm (tC * rC) + ) + replacementTerms + in aux ts ++ newReplacementTerms + else t : aux ts + (ConstTerm _) -> t : aux ts + +exprToExprVarsOnly :: Expr -> Either String ExprVarsOnly +exprToExprVarsOnly (Expr ts) = do + if any isConstTerm ts + then Left "safeExprToExprVarsOnly: Expr contains ConstTerm" + else Right $ ExprVarsOnly (NE.map unsafeTermToTermVarsOnly ts) + where + isConstTerm :: Term -> Bool + isConstTerm (ConstTerm _) = True + isConstTerm _ = False diff --git a/src/Linear/Simplex/DeriveBounds.hs b/src/Linear/Simplex/DeriveBounds.hs deleted file mode 100644 index 867aaab..0000000 --- a/src/Linear/Simplex/DeriveBounds.hs +++ /dev/null @@ -1,112 +0,0 @@ -module Linear.Simplex.DeriveBounds where - -import Prelude hiding (EQ) - -import Control.Applicative (liftA2) -import Control.Lens hiding (Const) -import Data.Generics.Labels () -import Data.List (sort) -import GHC.Generics (Generic) - -import Linear.Simplex.Types - -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe (isNothing, fromMaybe) - --- | Update the bounds for a variable in the map via intersection -updateBounds :: Var -> Bounds -> Map Var Bounds -> Map Var Bounds -updateBounds var newBounds boundsMap = - let existingBounds = Map.findWithDefault (Bounds Nothing Nothing) var boundsMap - updatedBounds = combineBounds newBounds existingBounds - in Map.insert var updatedBounds boundsMap - --- Intersection of two bounds -combineBounds :: Bounds -> Bounds -> Bounds -combineBounds newBounds existingBounds = do - let newLowerBound = - case (newBounds.lowerBound, existingBounds.lowerBound) of - (Just newLowerBound, Just existingLowerBound) -> Just $ max newLowerBound existingLowerBound - (_, Just existingLowerBound) -> Just existingLowerBound - (Just newLowerBound, _) -> Just newLowerBound - (_, _) -> Nothing - let newUpperBound = - case (newBounds.upperBound, existingBounds.upperBound) of - (Just newUpperBound, Just existingUpperBound) -> Just $ max newUpperBound existingUpperBound - (_, Just existingUpperBound) -> Just existingUpperBound - (Just newUpperBound, _) -> Just newUpperBound - (_, _) -> Nothing - Bounds newLowerBound newUpperBound - --- Helper to recursively analyze expressions and derive bounds --- deriveBoundsFromExpr :: Expr -> Bounds -> (Var -> Bounds -> Map Var Bounds -> Map Var Bounds) --- deriveBoundsFromExpr (Var v) bounds accMap = updateBounds v bounds accMap --- deriveBoundsFromExpr (Const c) _ accMap = accMap --- deriveBoundsFromExpr (e1 :+ e2) bounds accMap = --- deriveBoundsFromExpr e1 bounds $ deriveBoundsFromExpr e2 bounds accMap --- deriveBoundsFromExpr (e1 :-: e2) bounds accMap = --- deriveBoundsFromExpr e1 bounds $ deriveBoundsFromExpr e2 bounds accMap --- deriveBoundsFromExpr (e1 :*: e2) bounds accMap = --- deriveBoundsFromExpr e1 bounds $ deriveBoundsFromExpr e2 bounds accMap --- deriveBoundsFromExpr (e1 :/: e2) bounds accMap = --- deriveBoundsFromExpr e1 bounds $ deriveBoundsFromExpr e2 bounds accMap - --- Function to derive bounds from a single constraint for a variable -deriveVarBoundsFromConstraint :: Constraint -> Map Var Bounds -> Map Var Bounds --- deriveVarBoundsFromConstraint (Var v :<=: Const u) accMap = updateBounds v (Bounds Nothing (Just u)) accMap --- deriveVarBoundsFromConstraint (Var v :>=: Const l) accMap = updateBounds v (Bounds (Just l) Nothing) accMap --- deriveVarBoundsFromConstraint (Var v :==: Const c) accMap = updateBounds v (Bounds (Just c) (Just c)) accMap -deriveVarBoundsFromConstraint _ accMap = accMap -- Ignore non-constant expressions - --- Function to derive bounds for all variables in the constraints list -deriveBounds :: [Constraint] -> Map Var Bounds -deriveBounds constraints = foldr deriveVarBoundsFromConstraint Map.empty constraints - --- data Bounds = Bounds --- { lowerBound :: Maybe SimplexNum --- , upperBound :: Maybe SimplexNum --- } --- deriving (Show, Read, Eq, Generic) - -validateBounds :: Map Var Bounds -> Bool -validateBounds boundsMap = all soundBounds $ Map.toList boundsMap - where - soundBounds (_, Bounds lowerBound upperBound) = - case (lowerBound, upperBound) of - (Just l, Just u) -> l <= u - (_, _) -> True - - -type AuxVarMap = Map.Map Var (Var, Var) - -splitNegativeVars :: Map Var Bounds -> (Map Var Bounds, AuxVarMap) -splitNegativeVars boundsMap = - let (newBoundsMap, auxMap, _) = Map.foldrWithKey splitVar (Map.empty, Map.empty, Map.size boundsMap + 1) boundsMap - in (newBoundsMap, auxMap) - where - splitVar var (Bounds lowerBound upperBound) (newBoundsMap, auxMap, nextVar) = - if fromMaybe (-1) lowerBound < 0 - then let var1 = nextVar - var2 = nextVar + 1 - newBounds = Bounds (Just 0) Nothing - in (Map.insert var1 newBounds $ Map.insert var2 newBounds newBoundsMap, - Map.insert var (var1, var2) auxMap, - nextVar + 2) - else (Map.insert var (Bounds lowerBound upperBound) newBoundsMap, auxMap, nextVar) - --- PLAN: - --- Accept systems with any kind of constraints (<=, >=, ==) --- Identify all variables in the system and their bounds --- For any variable with negative/unbounded lower bound, split it into two variables with lower bound 0 --- So, say x has lower bound -1, then we split it into x1 and x2, where x1 >= 0 and x2 >= 0 --- Then substitute x with x1 - x2 in all constraints --- All variables now have non-negative lower bounds --- Now, we proceed with the remaining transformations --- Slack variables are introduced for all constraints --- Artificial variables are introduced for all constraints with equality --- and so on until we have a system in the standard form - --- Maybe have a type for the standard system? It would be a list of linear equalities with a constant on the RHS --- All variables >= 0 can be assumed, doesn't need to be in the type --- The objective function can be considered separate, so not part of the standard system type? \ No newline at end of file diff --git a/src/Linear/Simplex/Prettify.hs b/src/Linear/Simplex/Prettify.hs index 8536e89..647738a 100644 --- a/src/Linear/Simplex/Prettify.hs +++ b/src/Linear/Simplex/Prettify.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE RankNTypes #-} - -- | -- Module : Linear.Simplex.Prettify -- Description : Prettifier for "Linear.Simplex.Types" types @@ -12,11 +9,12 @@ -- Converts "Linear.Simplex.Types" types into human-readable 'String's module Linear.Simplex.Prettify where -import Control.Lens -import Data.Generics.Labels () -import Data.Map qualified as M -import Data.Ratio +import qualified Data.Map as M +import Data.Ratio (denominator, numerator) import Linear.Simplex.Types + ( ObjectiveFunction (Max, Min) + , VarLitMapSum + ) -- | Convert a 'VarConstMap' into a human-readable 'String' prettyShowVarConstMap :: VarLitMapSum -> String @@ -30,7 +28,10 @@ prettyShowVarConstMap = aux . M.toList then "(" ++ r' ++ ")" else r' where - r' = if denominator r == 1 then show (numerator r) else show (numerator r) ++ " / " ++ show (numerator r) + r' = + if denominator r == 1 + then show (numerator r) + else show (numerator r) ++ " / " ++ show (numerator r) -- | Convert a 'StandardConstraint' into a human-readable 'String' -- prettyShowStandardConstraint :: StandardConstraint -> String diff --git a/src/Linear/Simplex/Solver/TwoPhase.hs b/src/Linear/Simplex/Solver/TwoPhase.hs index b1ddb4d..ce07010 100644 --- a/src/Linear/Simplex/Solver/TwoPhase.hs +++ b/src/Linear/Simplex/Solver/TwoPhase.hs @@ -12,38 +12,77 @@ -- 'twoPhaseSimplex' performs both phases of the two-phase simplex method. module Linear.Simplex.Solver.TwoPhase (findFeasibleSolution, optimizeFeasibleSystem, twoPhaseSimplex) where -import Prelude hiding (EQ) - import Control.Lens + ( Traversable (traverse) + , (%~) + , (&) + , (.~) + , (<&>) + ) import Control.Monad (unless) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Logger -import Data.Bifunctor -import Data.List + ( LogLevel (LevelError, LevelInfo, LevelWarn) + , MonadLogger + ) +import Data.Bifunctor (Bifunctor (second)) +import Data.List (elem, map, maximum, notElem, null, sum, (++)) import qualified Data.Map as M import Data.Maybe (fromJust, fromMaybe, mapMaybe) import Data.Ratio (denominator, numerator, (%)) import qualified Data.Text as Text import GHC.Real (Ratio) import Linear.Simplex.Types + ( Dict + , DictValue (..) + , FeasibleSystem (..) + , ObjectiveFunction (..) + , PivotObjective (..) + , Result (..) + , StandardConstraint + , Tableau + , TableauRow (rhs) + , VarLitMapSum + ) import Linear.Simplex.Util + ( combineVarLitMapSums + , dictionaryFormToTableau + , foldVarLitMap + , insertPivotObjectiveToDict + , isMax + , logMsg + , showT + , tableauInDictionaryForm + ) +import Linear.Var.Types (SimplexNum, Var) +import Prelude hiding (EQ) -- | Find a feasible solution for the given system of 'StandardConstraint's by performing the first phase of the two-phase simplex method -- All variables in the 'StandardConstraint' must be positive. -- If the system is infeasible, return 'Nothing' -- Otherwise, return the feasible system in 'Dict' as well as a list of slack variables, a list artificial variables, and the objective variable. -findFeasibleSolution :: (MonadIO m, MonadLogger m) => [StandardConstraint] -> m (Maybe FeasibleSystem) +findFeasibleSolution :: + (MonadIO m, MonadLogger m) => [StandardConstraint] -> m (Maybe FeasibleSystem) findFeasibleSolution unsimplifiedSystem = do - logMsg LevelInfo $ "findFeasibleSolution: Looking for solution for " <> showT unsimplifiedSystem + logMsg LevelInfo $ + "findFeasibleSolution: Looking for solution for " <> showT unsimplifiedSystem if null artificialVars -- No artificial vars, we have a feasible system then do - logMsg LevelInfo "findFeasibleSolution: Feasible solution found with no artificial vars" - pure . Just $ FeasibleSystem systemWithBasicVarsAsDictionary slackVars artificialVars objectiveVar + logMsg + LevelInfo + "findFeasibleSolution: Feasible solution found with no artificial vars" + pure . Just $ + FeasibleSystem + systemWithBasicVarsAsDictionary + slackVars + artificialVars + objectiveVar else do logMsg LevelInfo $ "findFeasibleSolution: Needed to create artificial vars. System with artificial vars (in Tableau form) " <> showT systemWithBasicVars - mPhase1Dict <- simplexPivot artificialPivotObjective systemWithBasicVarsAsDictionary + mPhase1Dict <- + simplexPivot artificialPivotObjective systemWithBasicVarsAsDictionary case mPhase1Dict of Just phase1Dict -> do logMsg LevelInfo $ @@ -68,7 +107,11 @@ findFeasibleSolution unsimplifiedSystem = do -- If the objecitve row is not found, the system is feasible iff -- the artificial vars sum to zero. The value of an artificial -- variable is 0 if non-basic, and the RHS of the row if basic - let artificialVarsVals = map (\v -> maybe 0 (.constant) (M.lookup v eliminateArtificialVarsFromPhase1Tableau)) artificialVars + let artificialVarsVals = + map + ( \v -> maybe 0 (.constant) (M.lookup v eliminateArtificialVarsFromPhase1Tableau) + ) + artificialVars let artificialVarsValsSum = sum artificialVarsVals if artificialVarsValsSum == 0 then do @@ -126,14 +169,14 @@ findFeasibleSolution unsimplifiedSystem = do system = simplifySystem unsimplifiedSystem maxVar = undefined - -- maximum $ - -- map - -- ( \case - -- LEQ vcm _ -> maximum (map fst $ M.toList vcm) - -- GEQ vcm _ -> maximum (map fst $ M.toList vcm) - -- EQ vcm _ -> maximum (map fst $ M.toList vcm) - -- ) - -- system + -- maximum $ + -- map + -- ( \case + -- LEQ vcm _ -> maximum (map fst $ M.toList vcm) + -- GEQ vcm _ -> maximum (map fst $ M.toList vcm) + -- EQ vcm _ -> maximum (map fst $ M.toList vcm) + -- ) + -- system (systemWithSlackVars, slackVars) = systemInStandardForm system maxVar [] @@ -155,7 +198,11 @@ findFeasibleSolution unsimplifiedSystem = do -- If a constraint is already EQ, set the basic var to Nothing. -- Final system is a list of equalities for the given system. -- To be feasible, all vars must be >= 0. - systemInStandardForm :: [StandardConstraint] -> Var -> [Var] -> ([(Maybe Var, StandardConstraint)], [Var]) + systemInStandardForm :: + [StandardConstraint] -> + Var -> + [Var] -> + ([(Maybe Var, StandardConstraint)], [Var]) systemInStandardForm [] _ sVars = ([], sVars) -- systemInStandardForm (EQ v r : xs) maxVar sVars = ((Nothing, EQ v r) : newSystem, newSlackVars) -- where @@ -176,7 +223,8 @@ findFeasibleSolution unsimplifiedSystem = do -- Final system will be a feasible artificial system. -- We keep track of artificial vars in the second item of the returned pair so they can be eliminated once phase 1 is complete. -- If an artificial var would normally be negative, we negate the row so we can keep artificial variables equal to 1 - systemWithArtificialVars :: [(Maybe Var, StandardConstraint)] -> Var -> (Tableau, [Var]) + systemWithArtificialVars :: + [(Maybe Var, StandardConstraint)] -> Var -> (Tableau, [Var]) systemWithArtificialVars [] _ = (M.empty, []) -- systemWithArtificialVars ((mVar, EQ v r) : pcs) maxVar = -- case mVar of @@ -238,13 +286,18 @@ findFeasibleSolution unsimplifiedSystem = do where -- Filter out non-artificial entries rowsToAdd = M.filterWithKey (\k _ -> k `elem` artificialVars) rows - negatedRows = M.map (\(DictValue rowVarMapSum rowConstant) -> DictValue (M.map negate rowVarMapSum) (negate rowConstant)) rowsToAdd + negatedRows = + M.map + ( \(DictValue rowVarMapSum rowConstant) -> DictValue (M.map negate rowVarMapSum) (negate rowConstant) + ) + rowsToAdd -- Negate rows, discard keys and artificial vars since the pivot objective does not care about them negatedRowsWithoutArtificialVars = map ( \(_, DictValue {..}) -> DictValue - { varMapSum = M.map negate $ M.filterWithKey (\k _ -> k `notElem` artificialVars) varMapSum + { varMapSum = + M.map negate $ M.filterWithKey (\k _ -> k `notElem` artificialVars) varMapSum , constant = negate constant } ) @@ -255,10 +308,17 @@ findFeasibleSolution unsimplifiedSystem = do -- Then, the feasible system in 'DictionaryForm' as well as a list of slack variables, a list artificial variables, and the objective variable. -- Returns a pair with the first item being the 'Integer' variable equal to the 'ObjectiveFunction' -- and the second item being a map of the values of all 'Integer' variables appearing in the system, including the 'ObjectiveFunction'. -optimizeFeasibleSystem :: (MonadIO m, MonadLogger m) => ObjectiveFunction -> FeasibleSystem -> m (Maybe Result) +optimizeFeasibleSystem :: + (MonadIO m, MonadLogger m) => + ObjectiveFunction -> + FeasibleSystem -> + m (Maybe Result) optimizeFeasibleSystem objFunction fsys@(FeasibleSystem {dict = phase1Dict, ..}) = do logMsg LevelInfo $ - "optimizeFeasibleSystem: Optimizing feasible system " <> showT fsys <> " with objective " <> showT objFunction + "optimizeFeasibleSystem: Optimizing feasible system " + <> showT fsys + <> " with objective " + <> showT objFunction if null artificialVars then do logMsg LevelInfo $ @@ -266,14 +326,16 @@ optimizeFeasibleSystem objFunction fsys@(FeasibleSystem {dict = phase1Dict, ..}) <> showT phase1Dict <> " with objective " <> showT normalObjective - fmap (displayResults . dictionaryFormToTableau) <$> simplexPivot normalObjective phase1Dict + fmap (displayResults . dictionaryFormToTableau) + <$> simplexPivot normalObjective phase1Dict else do logMsg LevelInfo $ "optimizeFeasibleSystem: Artificial vars present. Pivoting system (in dict form) " <> showT phase1Dict <> " with objective " <> showT adjustedObjective - fmap (displayResults . dictionaryFormToTableau) <$> simplexPivot adjustedObjective phase1Dict + fmap (displayResults . dictionaryFormToTableau) + <$> simplexPivot adjustedObjective phase1Dict where -- \| displayResults takes a 'Tableau' and returns a 'Result'. The 'Tableau' -- represents the final tableau of a linear program after the simplex @@ -327,7 +389,10 @@ optimizeFeasibleSystem objFunction fsys@(FeasibleSystem {dict = phase1Dict, ..}) normalObjective = PivotObjective { variable = objectiveVar - , function = if isMax objFunction then objFunction.objective else M.map negate objFunction.objective + , function = + if isMax objFunction + then objFunction.objective + else M.map negate objFunction.objective , constant = 0 } @@ -382,10 +447,17 @@ optimizeFeasibleSystem objFunction fsys@(FeasibleSystem {dict = phase1Dict, ..}) -- Assumes the 'ObjectiveFunction' and 'StandardConstraint' is not empty. -- Returns a pair with the first item being the 'Integer' variable equal to the 'ObjectiveFunction' -- and the second item being a map of the values of all 'Integer' variables appearing in the system, including the 'ObjectiveFunction'. -twoPhaseSimplex :: (MonadIO m, MonadLogger m) => ObjectiveFunction -> [StandardConstraint] -> m (Maybe Result) +twoPhaseSimplex :: + (MonadIO m, MonadLogger m) => + ObjectiveFunction -> + [StandardConstraint] -> + m (Maybe Result) twoPhaseSimplex objFunction unsimplifiedSystem = do logMsg LevelInfo $ - "twoPhaseSimplex: Solving system " <> showT unsimplifiedSystem <> " with objective " <> showT objFunction + "twoPhaseSimplex: Solving system " + <> showT unsimplifiedSystem + <> " with objective " + <> showT objFunction phase1Result <- findFeasibleSolution unsimplifiedSystem case phase1Result of Just feasibleSystem -> do @@ -402,171 +474,206 @@ twoPhaseSimplex objFunction unsimplifiedSystem = do <> showT optimizedSystem pure optimizedSystem Nothing -> do - logMsg LevelInfo $ "twoPhaseSimplex: Phase 1 gives infeasible result for " <> showT unsimplifiedSystem + logMsg LevelInfo $ + "twoPhaseSimplex: Phase 1 gives infeasible result for " + <> showT unsimplifiedSystem pure Nothing -- | Perform the simplex pivot algorithm on a system with basic vars, assume that the first row is the 'ObjectiveFunction'. -simplexPivot :: (MonadIO m, MonadLogger m) => PivotObjective -> Dict -> m (Maybe Dict) -simplexPivot objective@(PivotObjective {variable = objectiveVar, function = objectiveFunc, constant = objectiveConstant}) dictionary = do - logMsg LevelInfo $ - "simplexPivot: Pivoting with objective " <> showT objective <> " over system (in Dict form) " <> showT dictionary - case mostPositive objectiveFunc of - Nothing -> do - logMsg LevelInfo $ - "simplexPivot: Pivoting complete as no positive variables found in objective " - <> showT objective - <> " over system (in Dict form) " - <> showT dictionary - pure $ Just (insertPivotObjectiveToDict objective dictionary) - Just pivotNonBasicVar -> do - logMsg LevelInfo $ - "simplexPivot: Non-basic pivoting variable in objective, determined by largest coefficient = " <> showT pivotNonBasicVar - let mPivotBasicVar = ratioTest dictionary pivotNonBasicVar Nothing Nothing - case mPivotBasicVar of - Nothing -> do - logMsg LevelInfo $ - "simplexPivot: Ratio test failed with non-basic variable " - <> showT pivotNonBasicVar - <> " over system (in Dict form) " - <> showT dictionary - pure Nothing - Just pivotBasicVar -> do - logMsg LevelInfo $ "simplexPivot: Basic pivoting variable determined by ratio test " <> showT pivotBasicVar - logMsg LevelInfo $ - "simplexPivot: Pivoting with basic var " - <> showT pivotBasicVar - <> ", non-basic var " - <> showT pivotNonBasicVar - <> ", objective " - <> showT objective - <> " over system (in Dict form) " - <> showT dictionary - let pivotResult = pivot pivotBasicVar pivotNonBasicVar (insertPivotObjectiveToDict objective dictionary) - pivotedObj = - let pivotedObjEntry = fromMaybe (error "simplexPivot: Can't find objective after pivoting") $ M.lookup objectiveVar pivotResult - in objective & #function .~ pivotedObjEntry.varMapSum & #constant .~ pivotedObjEntry.constant - pivotedDict = M.delete objectiveVar pivotResult - logMsg LevelInfo $ - "simplexPivot: Pivoted, Recursing with new pivoting objective " - <> showT pivotedObj - <> " for new pivoted system (in Dict form) " - <> showT pivotedDict - simplexPivot - pivotedObj - pivotedDict - where - ratioTest :: Dict -> Var -> Maybe Var -> Maybe Rational -> Maybe Var - ratioTest dict = aux (M.toList dict) - where - aux :: [(Var, DictValue)] -> Var -> Maybe Var -> Maybe Rational -> Maybe Var - aux [] _ mCurrentMinBasicVar _ = mCurrentMinBasicVar - aux (x@(basicVar, dictEquation) : xs) mostNegativeVar mCurrentMinBasicVar mCurrentMin = - case M.lookup mostNegativeVar dictEquation.varMapSum of - Nothing -> aux xs mostNegativeVar mCurrentMinBasicVar mCurrentMin - Just currentCoeff -> - let dictEquationConstant = dictEquation.constant - in if currentCoeff >= 0 || dictEquationConstant < 0 - then aux xs mostNegativeVar mCurrentMinBasicVar mCurrentMin - else case mCurrentMin of - Nothing -> aux xs mostNegativeVar (Just basicVar) (Just (dictEquationConstant / currentCoeff)) - Just currentMin -> - if (dictEquationConstant / currentCoeff) >= currentMin - then aux xs mostNegativeVar (Just basicVar) (Just (dictEquationConstant / currentCoeff)) - else aux xs mostNegativeVar mCurrentMinBasicVar mCurrentMin - - mostPositive :: VarLitMapSum -> Maybe Var - mostPositive varLitMap = - case findLargestCoeff (M.toList varLitMap) Nothing of - Just (largestVarName, largestVarCoeff) -> - if largestVarCoeff <= 0 - then Nothing - else Just largestVarName - Nothing -> Nothing - where - findLargestCoeff :: [(Var, SimplexNum)] -> Maybe (Var, SimplexNum) -> Maybe (Var, SimplexNum) - findLargestCoeff [] mCurrentMax = mCurrentMax - findLargestCoeff (v@(vName, vCoeff) : vs) mCurrentMax = - case mCurrentMax of - Nothing -> findLargestCoeff vs (Just v) - Just (_, currentMaxCoeff) -> - if currentMaxCoeff >= vCoeff - then findLargestCoeff vs mCurrentMax - else findLargestCoeff vs (Just v) +simplexPivot :: + (MonadIO m, MonadLogger m) => PivotObjective -> Dict -> m (Maybe Dict) +simplexPivot + objective@( PivotObjective + { variable = objectiveVar + , function = objectiveFunc + , constant = objectiveConstant + } + ) + dictionary = do + logMsg LevelInfo $ + "simplexPivot: Pivoting with objective " + <> showT objective + <> " over system (in Dict form) " + <> showT dictionary + case mostPositive objectiveFunc of + Nothing -> do + logMsg LevelInfo $ + "simplexPivot: Pivoting complete as no positive variables found in objective " + <> showT objective + <> " over system (in Dict form) " + <> showT dictionary + pure $ Just (insertPivotObjectiveToDict objective dictionary) + Just pivotNonBasicVar -> do + logMsg LevelInfo $ + "simplexPivot: Non-basic pivoting variable in objective, determined by largest coefficient = " + <> showT pivotNonBasicVar + let mPivotBasicVar = ratioTest dictionary pivotNonBasicVar Nothing Nothing + case mPivotBasicVar of + Nothing -> do + logMsg LevelInfo $ + "simplexPivot: Ratio test failed with non-basic variable " + <> showT pivotNonBasicVar + <> " over system (in Dict form) " + <> showT dictionary + pure Nothing + Just pivotBasicVar -> do + logMsg LevelInfo $ + "simplexPivot: Basic pivoting variable determined by ratio test " + <> showT pivotBasicVar + logMsg LevelInfo $ + "simplexPivot: Pivoting with basic var " + <> showT pivotBasicVar + <> ", non-basic var " + <> showT pivotNonBasicVar + <> ", objective " + <> showT objective + <> " over system (in Dict form) " + <> showT dictionary + let pivotResult = + pivot + pivotBasicVar + pivotNonBasicVar + (insertPivotObjectiveToDict objective dictionary) + pivotedObj = + let pivotedObjEntry = + fromMaybe (error "simplexPivot: Can't find objective after pivoting") $ + M.lookup objectiveVar pivotResult + in objective + & #function .~ pivotedObjEntry.varMapSum + & #constant .~ pivotedObjEntry.constant + pivotedDict = M.delete objectiveVar pivotResult + logMsg LevelInfo $ + "simplexPivot: Pivoted, Recursing with new pivoting objective " + <> showT pivotedObj + <> " for new pivoted system (in Dict form) " + <> showT pivotedDict + simplexPivot + pivotedObj + pivotedDict + where + ratioTest :: Dict -> Var -> Maybe Var -> Maybe Rational -> Maybe Var + ratioTest dict = aux (M.toList dict) + where + aux :: [(Var, DictValue)] -> Var -> Maybe Var -> Maybe Rational -> Maybe Var + aux [] _ mCurrentMinBasicVar _ = mCurrentMinBasicVar + aux (x@(basicVar, dictEquation) : xs) mostNegativeVar mCurrentMinBasicVar mCurrentMin = + case M.lookup mostNegativeVar dictEquation.varMapSum of + Nothing -> aux xs mostNegativeVar mCurrentMinBasicVar mCurrentMin + Just currentCoeff -> + let dictEquationConstant = dictEquation.constant + in if currentCoeff >= 0 || dictEquationConstant < 0 + then aux xs mostNegativeVar mCurrentMinBasicVar mCurrentMin + else case mCurrentMin of + Nothing -> + aux + xs + mostNegativeVar + (Just basicVar) + (Just (dictEquationConstant / currentCoeff)) + Just currentMin -> + if (dictEquationConstant / currentCoeff) >= currentMin + then + aux + xs + mostNegativeVar + (Just basicVar) + (Just (dictEquationConstant / currentCoeff)) + else aux xs mostNegativeVar mCurrentMinBasicVar mCurrentMin - -- Pivot a dictionary using the two given variables. - -- The first variable is the leaving (non-basic) variable. - -- The second variable is the entering (basic) variable. - -- Expects the entering variable to be present in the row containing the leaving variable. - -- Expects each row to have a unique basic variable. - -- Expects each basic variable to not appear on the RHS of any equation. - pivot :: Var -> Var -> Dict -> Dict - pivot leavingVariable enteringVariable dict = - case M.lookup enteringVariable (dictEntertingRow.varMapSum) of - Just enteringVariableCoeff -> - updatedRows - where - -- Move entering variable to basis, update other variables in row appropriately - pivotEnteringRow :: DictValue - pivotEnteringRow = - dictEntertingRow - & #varMapSum - %~ ( \basicEquation -> - -- uncurry - M.insert - leavingVariable - (-1) - (filterOutEnteringVarTerm basicEquation) - & traverse - %~ divideByNegatedEnteringVariableCoeff - ) - & #constant - %~ divideByNegatedEnteringVariableCoeff - where - newEnteringVarTerm = (leavingVariable, -1) - divideByNegatedEnteringVariableCoeff = (/ negate enteringVariableCoeff) + mostPositive :: VarLitMapSum -> Maybe Var + mostPositive varLitMap = + case findLargestCoeff (M.toList varLitMap) Nothing of + Just (largestVarName, largestVarCoeff) -> + if largestVarCoeff <= 0 + then Nothing + else Just largestVarName + Nothing -> Nothing + where + findLargestCoeff :: + [(Var, SimplexNum)] -> Maybe (Var, SimplexNum) -> Maybe (Var, SimplexNum) + findLargestCoeff [] mCurrentMax = mCurrentMax + findLargestCoeff (v@(vName, vCoeff) : vs) mCurrentMax = + case mCurrentMax of + Nothing -> findLargestCoeff vs (Just v) + Just (_, currentMaxCoeff) -> + if currentMaxCoeff >= vCoeff + then findLargestCoeff vs mCurrentMax + else findLargestCoeff vs (Just v) - -- Substitute pivot equation into other rows - updatedRows :: Dict - updatedRows = - M.fromList $ map (uncurry f2) $ M.toList dict - where - f entryVar entryVal = - if leavingVariable == entryVar - then pivotEnteringRow - else case M.lookup enteringVariable (entryVal.varMapSum) of - Just subsCoeff -> - entryVal - & #varMapSum - .~ combineVarLitMapSums - (pivotEnteringRow.varMapSum <&> (subsCoeff *)) - (filterOutEnteringVarTerm (entryVal.varMapSum)) - & #constant - .~ ((subsCoeff * (pivotEnteringRow.constant)) + entryVal.constant) - Nothing -> entryVal + -- Pivot a dictionary using the two given variables. + -- The first variable is the leaving (non-basic) variable. + -- The second variable is the entering (basic) variable. + -- Expects the entering variable to be present in the row containing the leaving variable. + -- Expects each row to have a unique basic variable. + -- Expects each basic variable to not appear on the RHS of any equation. + pivot :: Var -> Var -> Dict -> Dict + pivot leavingVariable enteringVariable dict = + case M.lookup enteringVariable (dictEntertingRow.varMapSum) of + Just enteringVariableCoeff -> + updatedRows + where + -- Move entering variable to basis, update other variables in row appropriately + pivotEnteringRow :: DictValue + pivotEnteringRow = + dictEntertingRow + & #varMapSum + %~ ( \basicEquation -> + -- uncurry + M.insert + leavingVariable + (-1) + (filterOutEnteringVarTerm basicEquation) + & traverse + %~ divideByNegatedEnteringVariableCoeff + ) + & #constant + %~ divideByNegatedEnteringVariableCoeff + where + newEnteringVarTerm = (leavingVariable, -1) + divideByNegatedEnteringVariableCoeff = (/ negate enteringVariableCoeff) - f2 :: Var -> DictValue -> (Var, DictValue) - f2 entryVar entryVal = - if leavingVariable == entryVar - then (enteringVariable, pivotEnteringRow) - else case M.lookup enteringVariable (entryVal.varMapSum) of - Just subsCoeff -> - ( entryVar - , entryVal + -- Substitute pivot equation into other rows + updatedRows :: Dict + updatedRows = + M.fromList $ map (uncurry f2) $ M.toList dict + where + f entryVar entryVal = + if leavingVariable == entryVar + then pivotEnteringRow + else case M.lookup enteringVariable (entryVal.varMapSum) of + Just subsCoeff -> + entryVal & #varMapSum .~ combineVarLitMapSums (pivotEnteringRow.varMapSum <&> (subsCoeff *)) (filterOutEnteringVarTerm (entryVal.varMapSum)) & #constant .~ ((subsCoeff * (pivotEnteringRow.constant)) + entryVal.constant) - ) - Nothing -> (entryVar, entryVal) - Nothing -> error "pivot: non basic variable not found in basic row" - where - -- \| The entering row, i.e., the row in the dict which is the value of - -- leavingVariable. - dictEntertingRow = - fromMaybe - (error "pivot: Basic variable not found in Dict") - $ M.lookup leavingVariable dict + Nothing -> entryVal + + f2 :: Var -> DictValue -> (Var, DictValue) + f2 entryVar entryVal = + if leavingVariable == entryVar + then (enteringVariable, pivotEnteringRow) + else case M.lookup enteringVariable (entryVal.varMapSum) of + Just subsCoeff -> + ( entryVar + , entryVal + & #varMapSum + .~ combineVarLitMapSums + (pivotEnteringRow.varMapSum <&> (subsCoeff *)) + (filterOutEnteringVarTerm (entryVal.varMapSum)) + & #constant + .~ ((subsCoeff * (pivotEnteringRow.constant)) + entryVal.constant) + ) + Nothing -> (entryVar, entryVal) + Nothing -> error "pivot: non basic variable not found in basic row" + where + -- \| The entering row, i.e., the row in the dict which is the value of + -- leavingVariable. + dictEntertingRow = + fromMaybe + (error "pivot: Basic variable not found in Dict") + $ M.lookup leavingVariable dict - filterOutEnteringVarTerm = M.filterWithKey (\vName _ -> vName /= enteringVariable) + filterOutEnteringVarTerm = M.filterWithKey (\vName _ -> vName /= enteringVariable) diff --git a/src/Linear/Simplex/Solver/Types.hs b/src/Linear/Simplex/Solver/Types.hs new file mode 100644 index 0000000..39aca4f --- /dev/null +++ b/src/Linear/Simplex/Solver/Types.hs @@ -0,0 +1,25 @@ +module Linear.Simplex.Solver.Types where + +import qualified Data.Map as Map +import GHC.Generics (Generic) +import Linear.Expr.Types (Expr) +import Linear.System.Linear.Types (CanBeLinearSystem) +import Linear.Var.Types (SimplexNum, Var) + +data OptimisationDirection = Minimize | Maximize + deriving (Show, Eq, GHC.Generics.Generic) + +data Objective = Objective + { expr :: Linear.Expr.Types.Expr -- TODO: this should be ExprVarsOnly + , direction :: OptimisationDirection + } + deriving (Show, Eq, GHC.Generics.Generic) + +data Result = Result + { varMap :: Map.Map Var SimplexNum + , objVal :: SimplexNum + } + deriving (Show, Read, Eq, GHC.Generics.Generic) + +class (CanBeLinearSystem s) => Solver s where + solve :: s -> Objective -> Result diff --git a/src/Linear/Simplex/Standardize.hs b/src/Linear/Simplex/Standardize.hs index e39d461..d8ca09c 100644 --- a/src/Linear/Simplex/Standardize.hs +++ b/src/Linear/Simplex/Standardize.hs @@ -1,13 +1,9 @@ module Linear.Simplex.Standardize where -import Control.Lens -import Data.Generics.Labels () import Data.List (sort) import qualified Data.Map as M import GHC.Generics (Generic) -import Linear.Simplex.Types - -- Add slack vars, need type of system with only equalities -- Add artificial vars, can we type check this somehow? Maybe with a phantom type? Is Tableau enough? diff --git a/src/Linear/Simplex/Types.hs b/src/Linear/Simplex/Types.hs index d2310e2..36f2163 100644 --- a/src/Linear/Simplex/Types.hs +++ b/src/Linear/Simplex/Types.hs @@ -7,350 +7,19 @@ -- Stability : experimental module Linear.Simplex.Types where -import Control.Lens hiding (Const) +import Control.Applicative ((<|>)) import Data.Generics.Labels () -import qualified Data.Set as Set import qualified Data.List as L import qualified Data.List.NonEmpty as NE import qualified Data.Map as M -import GHC.Generics (Generic) -import Control.Applicative ((<|>)) -import GHC.Base (liftA2) - -import Test.QuickCheck (Arbitrary(..), genericShrink, oneof) - +import qualified Data.Maybe as Maybe +import qualified Data.Set as Set import qualified Debug.Trace as T - --- Inputs: --- linear expressions (>=,<=,==) linear expressions --- Transformed into: --- linear expressions (>=,<=,==) rational - -data Term = ConstTerm SimplexNum | CoeffTerm SimplexNum Var | VarTerm Var -- Consider VarTerm Var - note, we must consider normalizing this: Considered. It makes going to standard form easier due to type safety - deriving (Show, Read, Eq, Ord, Generic) - -instance Arbitrary Term where - arbitrary = oneof [ ConstTerm <$> arbitrary - , CoeffTerm <$> arbitrary <*> arbitrary - , VarTerm <$> arbitrary - ] - - shrink = genericShrink - --- TODO: Test each function when reasonable -simplifyTerm :: Term -> Term -simplifyTerm (CoeffTerm 0 _) = ConstTerm 0 -simplifyTerm (CoeffTerm 1 v) = VarTerm v -simplifyTerm t = t - -negateTerm :: Term -> Term -negateTerm (ConstTerm c) = ConstTerm (-c) -negateTerm (CoeffTerm (-1) v) = VarTerm v -negateTerm (CoeffTerm c v) = CoeffTerm (-c) v -negateTerm (VarTerm v) = CoeffTerm (-1) v - --- Consider [Term] -data Expr = Expr Term | Expr :+ Term -- | Expr :+ Expr - deriving (Show, Read, Eq, Generic) - -instance Arbitrary Expr where - arbitrary = oneof [ Expr <$> arbitrary - , liftA2 (:+) arbitrary arbitrary - ] - - shrink = genericShrink - --- | Convert an 'Expr' to a list of 'Term's. -exprToList :: Expr -> [Term] -exprToList (Expr t) = [t] -exprToList (e :+ t) = exprToList e ++ [t] - --- | Convert a list of 'Term's to an 'Expr'. -listToExpr :: [Term] -> Expr -listToExpr [] = Expr $ ConstTerm 0 -listToExpr (t : ts) = foldl (:+) (Expr t) ts - --- expr: (Expr (CoeffTerm (1 % 1) 0) :+ CoeffTerm (1 % 2) (-1)) :+ CoeffTerm (2 % 1) (-1) --- 1 = x --- -1 = y --- 1x + 0.5y + 2y --- simplifiedExpr: (Expr (CoeffTerm (1 % 2) (-1)) :+ CoeffTerm (2 % 1) (-1)) :+ VarTerm 0 --- 0.5y + 2y + x --- simplifiedTwiceExpr: Expr (CoeffTerm (5 % 2) (-1)) :+ VarTerm 0 --- 2.5y + x - --- | Normalize a list of 'Term's where each term is added together. -normalizeTerms :: [Term] -> [Term] -normalizeTerms = L.sort . map simplifyTerm . combineTerms . L.sortBy orderForCombineTerms . map (varToCoeff . simplifyTerm) - where - orderForCombineTerms :: Term -> Term -> Ordering - orderForCombineTerms _ (VarTerm _) = error "Unexpected VarTerm in orderForCombineTerms" - orderForCombineTerms (VarTerm _) _ = error "Unexpected VarTerm in orderForCombineTerms" - orderForCombineTerms (ConstTerm c1) (ConstTerm c2) = compare c1 c2 - orderForCombineTerms (CoeffTerm c1 v1) (CoeffTerm c2 v2) = - case compare v1 v2 of - EQ -> compare c1 c2 - x -> x - orderForCombineTerms (ConstTerm _) (CoeffTerm _ _) = LT - orderForCombineTerms (CoeffTerm _ _) (ConstTerm _) = GT - - varToCoeff :: Term -> Term - varToCoeff (VarTerm v) = CoeffTerm 1 v - varToCoeff t = t - - combineTerms :: [Term] -> [Term] - combineTerms [] = [] - combineTerms [ConstTerm 0] = [] - combineTerms [CoeffTerm 0 _] = [] - combineTerms [x] = [x] - combineTerms allXs@(x1 : x2 : xs) = - -- T.trace (show allXs) $ - case (x1, x2) of - (ConstTerm 0, _) -> combineTerms (x2 : xs) - (_, ConstTerm 0) -> combineTerms (x1 : xs) - (CoeffTerm 0 _, _) -> combineTerms (x2 : xs) - (_, CoeffTerm 0 _) -> combineTerms (x1 : xs) - (ConstTerm c1, ConstTerm c2) -> if c1 + c2 == 0 then combineTerms xs else combineTerms (ConstTerm (c1 + c2) : xs) - (CoeffTerm c1 v1, CoeffTerm c2 v2) -> - if v1 == v2 - then combineTerms (CoeffTerm (c1 + c2) v1 : xs) - else x1 : combineTerms (x2 : xs) - _ -> x1 : combineTerms (x2 : xs) - -simplifyExpr :: Expr -> Expr -simplifyExpr = listToExpr . normalizeTerms . exprToList - -sumExprConstTerms :: Expr -> SimplexNum -sumExprConstTerms (Expr (ConstTerm c)) = c -sumExprConstTerms (Expr (CoeffTerm _ _)) = 0 -sumExprConstTerms (Expr (VarTerm _)) = 0 -sumExprConstTerms (e :+ t) = sumExprConstTerms e + sumExprConstTerms (Expr t) - -zeroConstTerm :: Term -> Term -zeroConstTerm (ConstTerm _) = ConstTerm 0 -zeroConstTerm t = t - -zeroConstExpr :: Expr -> Expr -zeroConstExpr (Expr t) = Expr (zeroConstTerm t) -zeroConstExpr (e :+ t) = zeroConstExpr e :+ zeroConstTerm t - -negateExpr :: Expr -> Expr -negateExpr = listToExpr . map negateTerm . exprToList - -addExpr :: Expr -> Expr -> Expr -addExpr e1 e2 = - -- Safe as Expr :+ Term is the only constructor - simplifyExpr . listToExpr $ (exprToList e1 <> exprToList e2) - -subtractExpr :: Expr -> Expr -> Expr -subtractExpr e1 e2 = addExpr e1 (negateExpr e2) - -substVarExpr :: Var -> Expr -> Expr -> Expr -substVarExpr var varReplacement = simplifyExpr . listToExpr . aux . exprToList - where - replacementTerms = exprToList varReplacement - - aux :: [Term] -> [Term] - aux [] = [] - aux (t : ts) = case t of - (VarTerm tV) -> if tV == var then aux ts ++ replacementTerms else t : aux ts - (CoeffTerm tC tV) -> - if tV == var - then - let newReplacementTerms = - map - ( - simplifyTerm - . - \case - (CoeffTerm rC rV) -> CoeffTerm (tC * rC) rV - (VarTerm rV) -> CoeffTerm tC rV - (ConstTerm rC) -> ConstTerm (tC * rC) - ) - replacementTerms - in aux ts ++ newReplacementTerms - else t : aux ts - (ConstTerm _) -> t : aux ts - --- substVarExpr :: Var -> Expr -> Expr -> Expr --- substVarExpr var varReplacement = simplifyExpr . listToExpr . aux . exprToList --- where --- replacementTerms = exprToList varReplacement - --- aux :: [Term] -> [Term] --- aux [] = [] --- aux (t : ts) = case t of --- (VarTerm tV) -> if tV == var then replacementTerms ++ aux ts else t : aux ts --- (CoeffTerm tC tV) -> --- if tV == var --- then --- let newReplacementTerms = --- map --- ( --- simplifyTerm --- . --- \case --- (CoeffTerm rC rV) -> CoeffTerm (tC * rC) rV --- (VarTerm rV) -> CoeffTerm tC rV --- (ConstTerm rC) -> ConstTerm (tC * rC) --- ) --- replacementTerms --- in newReplacementTerms ++ aux ts --- else t : aux ts --- (ConstTerm _) -> t : aux ts - --- 3x + 5y - 2z as a Expr --- tmpVarTerm = Expr (CoeffTerm 1 3) :+ CoeffTerm 1 5 :+ CoeffTerm 1 (-2) - --- data Expr = Var Var | Const SimplexNum | Expr :+ Expr | Expr :-: Expr | Expr :*: Expr | Expr :/: Expr --- deriving (Show, Read, Eq, Generic) - --- consider moving to a new file if we want people to be able to change this -type SimplexNum = Rational - -data GenericConstraint a b = a :<= b | a :>= b | a :== b - deriving (Show, Read, Eq, Generic) - -instance (Arbitrary a, Arbitrary b) => Arbitrary (GenericConstraint a b) where - arbitrary = oneof [ liftA2 (:<=) arbitrary arbitrary - , liftA2 (:>=) arbitrary arbitrary - , liftA2 (:==) arbitrary arbitrary - ] - shrink = genericShrink - -getGenericConstraintLHS :: GenericConstraint a b -> a -getGenericConstraintLHS (a :<= _) = a -getGenericConstraintLHS (a :>= _) = a -getGenericConstraintLHS (a :== _) = a - -getGenericConstraintRHS :: GenericConstraint a b -> b -getGenericConstraintRHS (_ :<= b) = b -getGenericConstraintRHS (_ :>= b) = b -getGenericConstraintRHS (_ :== b) = b - --- Input -type Constraint = GenericConstraint Expr Expr - --- data TermsOnlyVars = VarTerm' Var | CoeffTerm' SimplexNum Var --- deriving (Show, Read, Eq, Generic) --- data ExprVarsOnly = ExprVarsOnly [TermsOnlyVars] - --- Internal TODO: change to Terms :: [Term] or [Term] --- consider a term type with only variables --- then have another type SimpleConstraint = GenericConstraint TermsOnlyVars SimplexNum -type SimpleConstraint = GenericConstraint Expr SimplexNum - -substVarSimpleConstraint :: Var -> Expr -> SimpleConstraint -> SimpleConstraint -substVarSimpleConstraint var varReplacement (a :<= b) = substVarExpr var varReplacement a :<= b -substVarSimpleConstraint var varReplacement (a :>= b) = substVarExpr var varReplacement a :>= b -substVarSimpleConstraint var varReplacement (a :== b) = substVarExpr var varReplacement a :== b - -constraintToSimpleConstraint :: Constraint -> SimpleConstraint -constraintToSimpleConstraint constraint = - case constraint of - (a :<= b) -> uncurry (:<=) (calcLhsRhs a b) - (a :>= b) -> uncurry (:>=) (calcLhsRhs a b) - (a :== b) -> uncurry (:==) (calcLhsRhs a b) - where - calcLhsRhs a b = (lhs, rhs) - where - aConsts = sumExprConstTerms a - bConsts = sumExprConstTerms b - rhs = bConsts - aConsts - - aWithoutConst = simplifyExpr . zeroConstExpr $ a - bWithoutConst = simplifyExpr . zeroConstExpr $ b - - lhs = subtractExpr aWithoutConst bWithoutConst - calcRhs a b = rhs - where - aConsts = sumExprConstTerms a - bConsts = sumExprConstTerms b - rhs = bConsts - aConsts - - aWithoutConst = simplifyExpr . zeroConstExpr $ a - bWithoutConst = simplifyExpr . zeroConstExpr $ b - - lhs = subtractExpr aWithoutConst bWithoutConst - --- normalize simple constraints by moving all constants to the right -normalizeSimpleConstraint :: SimpleConstraint -> SimpleConstraint -normalizeSimpleConstraint (expr :<= num) = - let - exprList = exprToList expr - - isConstTerm (ConstTerm _) = True - isConstTerm _ = False - - (sumExprConstTerms, nonConstTerms) = L.partition isConstTerm exprList - - constTermsVal = sum . map (\case (ConstTerm c) -> c; _ -> 0) $ sumExprConstTerms - - newExpr = listToExpr nonConstTerms - newNum = num - constTermsVal - in newExpr :<= newNum -normalizeSimpleConstraint (expr :>= num) = - let - exprList = exprToList expr - - isConstTerm (ConstTerm _) = True - isConstTerm _ = False - - (sumExprConstTerms, nonConstTerms) = L.partition isConstTerm exprList - - constTermsVal = sum . map (\case (ConstTerm c) -> c; _ -> 0) $ sumExprConstTerms - - newExpr = listToExpr nonConstTerms - newNum = num - constTermsVal - in newExpr :>= newNum -normalizeSimpleConstraint (expr :== num) = - let - exprList = exprToList expr - - isConstTerm (ConstTerm _) = True - isConstTerm _ = False - - (sumExprConstTerms, nonConstTerms) = L.partition isConstTerm exprList - - constTermsVal = sum . map (\case (ConstTerm c) -> c; _ -> 0) $ sumExprConstTerms - - newExpr = listToExpr nonConstTerms - newNum = num - constTermsVal - in newExpr :== newNum - --- | Simplify coeff constraints by dividing the coefficient from both sides -simplifyCoeff :: SimpleConstraint -> SimpleConstraint -simplifyCoeff expr@(Expr (CoeffTerm coeff var) :<= num) - | coeff == 0 = expr - | coeff > 0 = Expr (VarTerm var) :<= (num / coeff) - | coeff < 0 = Expr (VarTerm var) :>= (num / coeff) -simplifyCoeff expr@(Expr (CoeffTerm coeff var) :>= num) - | coeff == 0 = expr - | coeff > 0 = Expr (VarTerm var) :>= (num / coeff) - | coeff < 0 = Expr (VarTerm var) :<= (num / coeff) -simplifyCoeff expr@(Expr (CoeffTerm coeff var) :== num) = if coeff == 0 then expr else Expr (VarTerm var) :== (num / coeff) -simplifyCoeff expr = expr - -simplifySimpleConstraint :: SimpleConstraint -> SimpleConstraint -simplifySimpleConstraint (expr :<= num) = simplifyCoeff . normalizeSimpleConstraint $ simplifyExpr expr :<= num -simplifySimpleConstraint (expr :>= num) = simplifyCoeff . normalizeSimpleConstraint $ simplifyExpr expr :>= num -simplifySimpleConstraint (expr :== num) = simplifyCoeff . normalizeSimpleConstraint $ simplifyExpr expr :== num - -type SimpleSystem = [SimpleConstraint] - -simplifySimpleSystem :: SimpleSystem -> SimpleSystem -simplifySimpleSystem = map simplifySimpleConstraint - -findHighestVar :: SimpleSystem -> Var -findHighestVar simpleSystem = - let - vars = [v | gc <- simpleSystem, - term <- exprToList $ getGenericConstraintLHS gc, - v <- case term of - VarTerm v -> [v] - CoeffTerm _ v -> [v] - _ -> []] - in maximum vars +import GHC.Base (liftA2) +import GHC.Generics (Generic) +import Linear.Expr.Types (Expr) +import Linear.Var.Types (SimplexNum, Var) +import Test.QuickCheck (Arbitrary (..), genericShrink, oneof) data StandardFormRow = StandardFormRow { lhs :: Expr @@ -361,142 +30,6 @@ data StandardFormRow = StandardFormRow -- | the system with slack variables type StandardForm = [StandardFormRow] -data Bounds = Bounds - { lowerBound :: Maybe SimplexNum - , upperBound :: Maybe SimplexNum - } - deriving (Show, Read, Eq, Generic) - -type Var = Int - -type VarBounds = M.Map Var Bounds - --- | Merge two bounds, very simple -deriveBounds :: SimpleSystem -> VarBounds -deriveBounds = foldr updateBounds M.empty - where - updateBounds :: SimpleConstraint -> VarBounds -> VarBounds - updateBounds (Expr (VarTerm var) :<= num) = M.insertWith mergeBounds var (Bounds Nothing (Just num)) - updateBounds (Expr (VarTerm var) :>= num) = M.insertWith mergeBounds var (Bounds (Just num) Nothing) - updateBounds (Expr (VarTerm var) :== num) = M.insertWith mergeBounds var (Bounds (Just num) (Just num)) - updateBounds _ = id - - mergeBounds :: Bounds -> Bounds -> Bounds - mergeBounds (Bounds l1 u1) (Bounds l2 u2) = Bounds (mergeLower l1 l2) (mergeUpper u1 u2) - where - mergeLower Nothing b = b - mergeLower a Nothing = a - mergeLower (Just a) (Just b) = Just (max a b) - - mergeUpper Nothing b = b - mergeUpper a Nothing = a - mergeUpper (Just a) (Just b) = Just (min a b) - -validateBounds :: VarBounds -> Bool -validateBounds boundsMap = all soundBounds $ M.toList boundsMap - where - soundBounds (_, Bounds lowerBound upperBound) = - case (lowerBound, upperBound) of - (Just l, Just u) -> l <= u - (_, _) -> True - --- Eliminate inequalities which are outside the bounds --- precondition: no zero coefficients --- TODO: better name -removeUselessSystemBounds :: SimpleSystem -> VarBounds -> SimpleSystem -removeUselessSystemBounds constraints bounds = - filter - ( \case - (Expr (VarTerm var) :<= num) -> case M.lookup var bounds of - Just (Bounds _ (Just upper)) -> num <= upper - _ -> True - (Expr (VarTerm var) :>= num) -> case M.lookup var bounds of - Just (Bounds (Just lower) _) -> num >= lower - _ -> True - _ -> True - ) - constraints - --- | Eliminate negative lower bounds via substitution --- Return the system with the eliminated variables and a map of the eliminated variables to their equivalent expressions --- First step here https://en.wikipedia.org/wiki/Simplex_algorithm#Standard_form -eliminateNonZeroLowerBounds :: SimpleSystem -> M.Map Var Expr -> (M.Map Var Expr, SimpleSystem) -eliminateNonZeroLowerBounds constraints eliminatedVarsMap = aux constraints - where - removeConstraint :: SimpleConstraint -> SimpleSystem -> SimpleSystem - removeConstraint c = filter (/= c) - - aux :: SimpleSystem -> (M.Map Var Expr, SimpleSystem) - aux [] = (eliminatedVarsMap, constraints) - aux (c : cs) = case c of - -- x >= 5 - (Expr (VarTerm var) :>= lowerBound) -> - if lowerBound == 0 - then aux cs - else - let newVar = findHighestVar constraints + 1 - -- y >= 0 - newVarLowerBound = Expr (VarTerm newVar) :>= 0 - - -- x = y + 5 - substOldVarWith = Expr (VarTerm newVar) :+ ConstTerm lowerBound - - newConstraints = simplifySimpleSystem $ newVarLowerBound : map (substVarSimpleConstraint var substOldVarWith) constraints - updatedEliminatedVarsMap = M.insert var substOldVarWith eliminatedVarsMap - in eliminateNonZeroLowerBounds newConstraints updatedEliminatedVarsMap -- TODO: Make more efficient if needed - _ -> aux cs - --- Add slack variables... --- Second step here https://en.wikipedia.org/wiki/Simplex_algorithm#Standard_form --- Return system of equalities and the slack variables -addSlackVariables :: SimpleSystem -> ([Var], SimpleSystem) -addSlackVariables constraints = aux constraints newVar [] - where - newVar = findHighestVar constraints + 1 - - aux :: SimpleSystem -> Var -> [Var] -> ([Var], SimpleSystem) - aux [] _ slackVars = (slackVars, []) - aux (c : cs) nextVar slackVars = case c of - (expr :<= num) -> - let slackVar = newVar - newNextVar = nextVar + 1 - newExpr = expr :+ VarTerm slackVar - slackVarLowerBound = Expr (VarTerm slackVar) :>= 0 - (newSlackVars, newConstraints) = aux cs newNextVar slackVars - in (newVar : newSlackVars, newExpr :== num : slackVarLowerBound : newConstraints) - (expr :>= num) -> - let slackVar = newVar - newNextVar = nextVar + 1 - newExpr = expr :+ CoeffTerm (-1) slackVar - slackVarLowerBound = Expr (VarTerm slackVar) :>= 0 - (newSlackVars, newConstraints) = aux cs newNextVar slackVars - in (newVar : newSlackVars, newExpr :== num : slackVarLowerBound : newConstraints) - (expr :== num) -> - let (newSlackVars, newConstraints) = aux cs nextVar slackVars - in (newSlackVars, c : newConstraints) - --- Eliminate unrestricted variables (lower bound unknown) --- Third step here https://en.wikipedia.org/wiki/Simplex_algorithm#Standard_form --- precondition: VarBounds accurate for SimpleSystem -eliminateUnrestrictedLowerBounds :: SimpleSystem -> VarBounds -> M.Map Var Expr -> (M.Map Var Expr, SimpleSystem) -eliminateUnrestrictedLowerBounds constraints varBoundMap eliminatedVarsMap = aux constraints (M.toList varBoundMap) - where - aux :: SimpleSystem -> [(Var, Bounds)] -> (M.Map Var Expr, SimpleSystem) - aux _ [] = (eliminatedVarsMap, constraints) - aux cs ((var, Bounds Nothing _): bounds) = - let newVarPlus = findHighestVar constraints + 1 - newVarMinus = newVarPlus + 1 - newVarPlusLowerBound = Expr (VarTerm newVarPlus) :>= 0 - newVarMinusLowerBound = Expr (VarTerm newVarMinus) :>= 0 - - -- oldVar = newVarPlus - newVarMinus - substOldVarWith = Expr (VarTerm newVarPlus) :+ CoeffTerm (-1) newVarMinus - - newConstraints = simplifySimpleSystem $ newVarPlusLowerBound : newVarMinusLowerBound : map (substVarSimpleConstraint var substOldVarWith) constraints - -- TODO: Update this name - updatedEliminatedVarsMap = M.insert var substOldVarWith eliminatedVarsMap - in eliminateUnrestrictedLowerBounds newConstraints (M.fromList bounds) updatedEliminatedVarsMap - -- data Term = ConstTerm SimplexNum | CoeffTerm SimplexNum Var -- Consider VarTermnewVar data StandardTerm = StandardTerm SimplexNum Var deriving (Show, Read, Eq, Generic) @@ -569,7 +102,9 @@ type VarLitMapSum = VarLitMap -- | Create an objective function. -- We can either 'Max'imize or 'Min'imize a 'VarTermSum'. -data ObjectiveFunction = Max {objective :: VarLitMapSum} | Min {objective :: VarLitMapSum} +data ObjectiveFunction + = Max {objective :: VarLitMapSum} + | Min {objective :: VarLitMapSum} deriving (Show, Read, Eq, Generic) -- | TODO: Maybe we want this type diff --git a/src/Linear/Simplex/Util.hs b/src/Linear/Simplex/Util.hs index 86b8a4d..8ec5005 100644 --- a/src/Linear/Simplex/Util.hs +++ b/src/Linear/Simplex/Util.hs @@ -9,13 +9,18 @@ -- Helper functions for performing the two-phase simplex method. module Linear.Simplex.Util where -import Control.Lens import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Logger (LogLevel (..), LogLine, MonadLogger, logDebug, logError, logInfo, logWarn) -import Data.Bifunctor -import Data.Generics.Labels () +import Control.Monad.Logger + ( LogLevel (..) + , LogLine + , MonadLogger + , logDebug + , logError + , logInfo + , logWarn + ) import Data.Generics.Product (field) -import Data.List +import Data.List (map, nub) import qualified Data.Map as Map import qualified Data.Map.Merge.Lazy as MapMerge import Data.Maybe (fromMaybe) @@ -23,6 +28,17 @@ import qualified Data.Text as T import Data.Time (getCurrentTime) import Data.Time.Format.ISO8601 (iso8601Show) import Linear.Simplex.Types + ( Dict + , DictValue (..) + , ObjectiveFunction (Max, Min) + , PivotObjective (constant, function, variable) + , Result (objectiveVar, varValMap) + , Tableau + , TableauRow (TableauRow, lhs, rhs) + , VarLitMap + , VarLitMapSum + ) +import Linear.Var.Types (SimplexNum, Var) import Prelude hiding (EQ) -- | Is the given 'ObjectiveFunction' to be 'Max'imized? @@ -129,13 +145,17 @@ combineVarLitMapSums = foldDictValue :: [DictValue] -> DictValue foldDictValue [] = error "Empty list of DictValues given to foldDictValue" foldDictValue [x] = x -foldDictValue (DictValue {varMapSum = vm1, constant = c1} : DictValue {varMapSum = vm2, constant = c2} : dvs) = - let combinedDictValue = - DictValue - { varMapSum = foldVarLitMap [vm1, vm2] - , constant = c1 + c2 - } - in foldDictValue $ combinedDictValue : dvs +foldDictValue + ( DictValue {varMapSum = vm1, constant = c1} + : DictValue {varMapSum = vm2, constant = c2} + : dvs + ) = + let combinedDictValue = + DictValue + { varMapSum = foldVarLitMap [vm1, vm2] + , constant = c1 + c2 + } + in foldDictValue $ combinedDictValue : dvs foldVarLitMap :: [VarLitMap] -> VarLitMap foldVarLitMap [] = error "Empty list of VarLitMaps given to foldVarLitMap" @@ -161,7 +181,10 @@ foldVarLitMap (vm1 : vm2 : vms) = in foldVarLitMap $ combinedVarMap : vms insertPivotObjectiveToDict :: PivotObjective -> Dict -> Dict -insertPivotObjectiveToDict objective = Map.insert objective.variable (DictValue {varMapSum = objective.function, constant = objective.constant}) +insertPivotObjectiveToDict objective = + Map.insert + objective.variable + (DictValue {varMapSum = objective.function, constant = objective.constant}) showT :: (Show a) => a -> T.Text showT = T.pack . show diff --git a/src/Linear/SlackForm/Types.hs b/src/Linear/SlackForm/Types.hs new file mode 100644 index 0000000..33d5097 --- /dev/null +++ b/src/Linear/SlackForm/Types.hs @@ -0,0 +1,24 @@ +-- | +-- Module: Linear.Simplex.SlackForm.Types +-- Description: Types for augmented (slack) form of linear programming problems +-- Copyright: (c) Junaid Rasheed, 2024 +-- License: BSD-3 +-- Maintainer: Junaid Rasheed +-- Stability: experimental +module Linear.SlackForm.Types where + +import GHC.Generics (Generic) +import Linear.Expr.Types (Expr) +import Linear.System.Linear.Types (LinearSystem) +import Linear.Var.Types (SimplexNum, Var) + +-- Expr == SimplexNum +data SlackForm = SlackForm + { maxObjective :: Expr -- TODO: should be ExprVarsOnly + , constraints :: LinearSystem + , vars :: [Var] -- all vars are non-negative + } + deriving (Show, Eq, Read, Generic) + +class CanBeSlackForm a where + toSlackForm :: a -> SlackForm diff --git a/src/Linear/SlackForm/Util.hs b/src/Linear/SlackForm/Util.hs new file mode 100644 index 0000000..1c0b50f --- /dev/null +++ b/src/Linear/SlackForm/Util.hs @@ -0,0 +1,123 @@ +-- | +-- Module: Linear.Simplex.StandardForm +-- Description: Standard form of the linear program +-- Copyright: (c) Junaid Rasheed, 2020-2024 +-- License: BSD-3 +-- Maintainer: Junaid Rasheed +-- Stability: experimental +module Linear.SlackForm.Util where + +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as Map +import Linear.Constraint.Generic.Types + ( GenericConstraint ((:<=), (:==), (:>=)) + ) +import Linear.Constraint.Simple.Util + ( substVarSimpleConstraint + ) +import Linear.Expr.Types (Expr (..)) +import Linear.System.Simple.Types + ( SimpleSystem + , findHighestVar + , simplifySimpleSystem + ) +import Linear.Term.Types + ( Term (..) + ) +import Linear.Var.Types (Bounds (..), Var, VarBounds) + +-- | Eliminate non-zero lower bounds via substitution +-- Return the system with the eliminated variables and a map of the eliminated variables to their equivalent expressions +-- First step here https://en.wikipedia.org/wiki/Simplex_algorithm#Standard_form +eliminateNonZeroLowerBounds :: + SimpleSystem -> Map.Map Var Expr -> (Map.Map Var Expr, SimpleSystem) +eliminateNonZeroLowerBounds constraints eliminatedVarsMap = aux [] constraints + where + -- Eliminate non-zero lower bounds + aux _ [] = (eliminatedVarsMap, constraints) + aux checked (c : cs) = case c of + -- x >= 5 + (Expr (VarTerm var :| []) :>= lowerBound) -> + if lowerBound == 0 + then aux (checked ++ [c]) cs + else + let newVar = findHighestVar constraints + 1 + -- y >= 0 + newVarLowerBound = Expr (VarTerm newVar :| []) :>= 0 + + -- x = y + 5 + substOldVarWith = Expr (VarTerm newVar :| [ConstTerm lowerBound]) + substFn = substVarSimpleConstraint var substOldVarWith + + newConstraints = + simplifySimpleSystem $ map substFn checked ++ newVarLowerBound : map substFn cs + updatedEliminatedVarsMap = Map.insert var substOldVarWith eliminatedVarsMap + in eliminateNonZeroLowerBounds newConstraints updatedEliminatedVarsMap -- TODO: Make more efficient if needed + -- TODO: (do) Deal with == ? + -- (dont) Or remove == from the type + -- and convert to <= and >=? + _ -> aux (checked ++ [c]) cs + +-- Add slack variables... +-- Second step here https://en.wikipedia.org/wiki/Simplex_algorithm#Standard_form +-- Return system of equalities and the slack variables +addSlackVariables :: SimpleSystem -> ([Var], SimpleSystem) +addSlackVariables constraints = + let nextAvailableVar = findHighestVar constraints + 1 + in aux constraints nextAvailableVar [] + where + aux :: SimpleSystem -> Var -> [Var] -> ([Var], SimpleSystem) + aux [] _ slackVars = (slackVars, []) + aux (c : cs) nextVar slackVars = case c of + (expr@(Expr exprTs) :<= num) -> + let slackVar = nextVar + newNextVar = nextVar + 1 + newExpr = Expr $ NE.appendList exprTs [VarTerm slackVar] + slackVarLowerBound = Expr (VarTerm slackVar :| []) :>= 0 + (newSlackVars, newConstraints) = aux cs newNextVar slackVars + in (nextVar : newSlackVars, newExpr :== num : slackVarLowerBound : newConstraints) + (expr@(Expr exprTs) :>= num) -> + let slackVar = nextVar + newNextVar = nextVar + 1 + newExpr = Expr $ NE.appendList exprTs [CoeffTerm (-1) slackVar] + slackVarLowerBound = Expr (VarTerm slackVar :| []) :>= 0 + (newSlackVars, newConstraints) = aux cs newNextVar slackVars + in (nextVar : newSlackVars, newExpr :== num : slackVarLowerBound : newConstraints) + (expr :== num) -> + let (newSlackVars, newConstraints) = aux cs nextVar slackVars + in (newSlackVars, c : newConstraints) + +-- Eliminate unrestricted variables (lower bound unknown) +-- Third step here https://en.wikipedia.org/wiki/Simplex_algorithm#Standard_form +-- precondition: VarBounds accurate for SimpleSystem +eliminateUnrestrictedLowerBounds :: + SimpleSystem -> + VarBounds -> + Map.Map Var Expr -> + (Map.Map Var Expr, SimpleSystem) +eliminateUnrestrictedLowerBounds constraints varBoundMap eliminatedVarsMap = aux constraints (Map.toList varBoundMap) + where + aux :: SimpleSystem -> [(Var, Bounds)] -> (Map.Map Var Expr, SimpleSystem) + aux _ [] = (eliminatedVarsMap, constraints) + aux cs ((var, Bounds Nothing _) : bounds) = + let newVarPlus = findHighestVar constraints + 1 + newVarMinus = newVarPlus + 1 + newVarPlusLowerBound = Expr (VarTerm newVarPlus :| []) :>= 0 + newVarMinusLowerBound = Expr (VarTerm newVarMinus :| []) :>= 0 + + -- oldVar = newVarPlus - newVarMinus + substOldVarWith = Expr (VarTerm newVarPlus :| [CoeffTerm (-1) newVarMinus]) + + newConstraints = + simplifySimpleSystem $ + newVarPlusLowerBound + : newVarMinusLowerBound + : map (substVarSimpleConstraint var substOldVarWith) constraints + -- TODO: Update this name + updatedEliminatedVarsMap = Map.insert var substOldVarWith eliminatedVarsMap + in eliminateUnrestrictedLowerBounds + newConstraints + (Map.fromList bounds) + updatedEliminatedVarsMap + aux cs (_ : bounds) = aux cs bounds diff --git a/src/Linear/System/Linear/Types.hs b/src/Linear/System/Linear/Types.hs new file mode 100644 index 0000000..cffe109 --- /dev/null +++ b/src/Linear/System/Linear/Types.hs @@ -0,0 +1,24 @@ +-- | +-- Module: Linear.System.Linear.Types +-- Description: Types for linear programming problems +-- Copyright: (c) Junaid Rasheed, 2024 +-- License: BSD-3 +-- Maintainer: Junaid Rasheed +-- Stability: experimental +module Linear.System.Linear.Types where + +import GHC.Generics (Generic) +import Linear.Constraint.Linear.Types (LinearEquation) +import Linear.Expr.Types (Expr) + +newtype LinearSystem = LinearSystem {unLinearSystem :: [LinearEquation]} + deriving (Show, Eq, Read, Generic) + +class CanBeLinearSystem a where + toLinearSystem :: a -> LinearSystem + +instance CanBeLinearSystem LinearSystem where + toLinearSystem = id + +instance CanBeLinearSystem LinearEquation where + toLinearSystem id = LinearSystem [id] diff --git a/src/Linear/System/Simple/Types.hs b/src/Linear/System/Simple/Types.hs new file mode 100644 index 0000000..270ee7f --- /dev/null +++ b/src/Linear/System/Simple/Types.hs @@ -0,0 +1,38 @@ +-- | +-- Module: Linear.System.Simple.Types +-- Description: Types for the Simplex system +-- Copyright: (c) Junaid Rasheed, 2020-2024 +-- License: BSD-3 +-- Maintainer: jrasheed178@gmail.com +-- Stability: experimental +module Linear.System.Simple.Types where + +import qualified Data.Set as Set +import GHC.Generics (Generic) +import Linear.Constraint.Generic.Types (getGenericConstraintLHS) +import Linear.Constraint.Simple.Types (SimpleConstraint) +import Linear.Constraint.Simple.Util + ( simpleConstraintVars + , simplifySimpleConstraint + ) +import Linear.Expr.Util (exprToList) +import Linear.Term.Types (Term (..)) +import Linear.Var.Types (Var) + +type SimpleSystem = [SimpleConstraint] + +simplifySimpleSystem :: SimpleSystem -> SimpleSystem +simplifySimpleSystem = map simplifySimpleConstraint + +simpleSystemVars :: SimpleSystem -> Set.Set Var +simpleSystemVars = Set.unions . map simpleConstraintVars + +findHighestVar :: SimpleSystem -> Var +findHighestVar simpleSystem = + let vars = + [ v | gc <- simpleSystem, term <- exprToList $ getGenericConstraintLHS gc, v <- case term of + VarTerm v -> [v] + CoeffTerm _ v -> [v] + _ -> [] + ] + in maximum vars diff --git a/src/Linear/System/Simple/Util.hs b/src/Linear/System/Simple/Util.hs new file mode 100644 index 0000000..cb9ca48 --- /dev/null +++ b/src/Linear/System/Simple/Util.hs @@ -0,0 +1,66 @@ +-- | +-- Module: Linear.System.Simple.Util +-- Description: Utility functions for the Simplex method +-- Copyright: (c) Junaid Rasheed, 2020-2024 +-- License: BSD3 +-- Maintainer: jrasheed178@gmail.com +-- Stability: experimental +module Linear.System.Simple.Util where + +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as M +import qualified Data.Set as Set +import Linear.Constraint.Generic.Types + ( GenericConstraint ((:<=), (:==), (:>=)) + ) +import Linear.Constraint.Simple.Types (SimpleConstraint) +import Linear.Expr.Types (Expr (..)) +import Linear.System.Simple.Types + ( SimpleSystem + , simpleSystemVars + ) +import Linear.Term.Types (Term (..)) +import Linear.Var.Types (Bounds (..), VarBounds) + +-- | Derive bounds for all variables in a system +deriveBounds :: SimpleSystem -> VarBounds +deriveBounds simpleSystem = foldr updateBounds initialVarBounds simpleSystem + where + systemVars = simpleSystemVars simpleSystem + initialVarBounds = M.fromList [(v, Bounds Nothing Nothing) | v <- Set.toList systemVars] + + updateBounds :: SimpleConstraint -> VarBounds -> VarBounds + updateBounds (Expr ((VarTerm var) :| []) :<= num) = M.insertWith mergeBounds var (Bounds Nothing (Just num)) + updateBounds (Expr ((VarTerm var) :| []) :>= num) = M.insertWith mergeBounds var (Bounds (Just num) Nothing) + updateBounds (Expr ((VarTerm var) :| []) :== num) = M.insertWith mergeBounds var (Bounds (Just num) (Just num)) + updateBounds _ = id + + -- \| Merge two bounds, very simple + mergeBounds :: Bounds -> Bounds -> Bounds + mergeBounds (Bounds l1 u1) (Bounds l2 u2) = Bounds (mergeLower l1 l2) (mergeUpper u1 u2) + where + mergeLower Nothing b = b + mergeLower a Nothing = a + mergeLower (Just a) (Just b) = Just (max a b) + + mergeUpper Nothing b = b + mergeUpper a Nothing = a + mergeUpper (Just a) (Just b) = Just (min a b) + +-- Eliminate inequalities which are outside the bounds +-- precondition: no zero coefficients +-- TODO: better name +removeUselessSystemBounds :: SimpleSystem -> VarBounds -> SimpleSystem +removeUselessSystemBounds constraints bounds = + filter + ( \case + (Expr ((VarTerm var) :| []) :<= num) -> case M.lookup var bounds of + Just (Bounds _ (Just upper)) -> num <= upper + _ -> True + (Expr ((VarTerm var) :| []) :>= num) -> case M.lookup var bounds of + Just (Bounds (Just lower) _) -> num >= lower + _ -> True + _ -> True + ) + constraints diff --git a/src/Linear/System/Types.hs b/src/Linear/System/Types.hs new file mode 100644 index 0000000..5a0c432 --- /dev/null +++ b/src/Linear/System/Types.hs @@ -0,0 +1,6 @@ +module Linear.System.Types where + +-- class System s where +-- isFeasible :: s -> Bool + +-- TODO: create Sytem type, list of Constraints diff --git a/src/Linear/Term/Types.hs b/src/Linear/Term/Types.hs new file mode 100644 index 0000000..e22a364 --- /dev/null +++ b/src/Linear/Term/Types.hs @@ -0,0 +1,31 @@ +-- | +-- Module : Linear.Term.Types +-- Description : Types for linear terms +-- Copright : (c) Junaid Rasheed, 2020-2024 +-- License : BSD-3 +-- Maintainer : jrasheed178@gmail.com +-- Stability : experimental +module Linear.Term.Types where + +import GHC.Generics (Generic) +import Linear.Var.Types (SimplexNum, Var) +import Test.QuickCheck (Arbitrary (..), genericShrink, oneof) + +data Term + = ConstTerm {constant :: SimplexNum} + | CoeffTerm {coeff :: SimplexNum, var :: Var} + | VarTerm {var :: Var} + deriving (Show, Read, Eq, Ord, Generic) + +data TermVarsOnly + = VarTermVO {var :: Var} + | CoeffTermVO {coeff :: SimplexNum, var :: Var} + deriving (Show, Read, Eq, Generic) + +instance Arbitrary Term where + arbitrary = + oneof + [ ConstTerm <$> arbitrary + , CoeffTerm <$> arbitrary <*> arbitrary + , VarTerm <$> arbitrary + ] diff --git a/src/Linear/Term/Util.hs b/src/Linear/Term/Util.hs new file mode 100644 index 0000000..8b2bd1c --- /dev/null +++ b/src/Linear/Term/Util.hs @@ -0,0 +1,101 @@ +-- | +-- Module : Linear.Expr.Types +-- Description : Util functions for terms +-- Copyright : (c) Junaid Rasheed, 2020-2024 +-- License : BSD-3 +-- Maintainer : jrasheed178@gmail.com +-- Stability : experimental +module Linear.Term.Util where + +import qualified Data.List as L +import Linear.Term.Types + ( Term (..) + , TermVarsOnly (..) + ) +import Linear.Var.Types (Var) + +-- TODO: Test each function when reasonable +simplifyTerm :: Term -> Term +simplifyTerm (CoeffTerm 0 _) = ConstTerm 0 +simplifyTerm (CoeffTerm 1 v) = VarTerm v +simplifyTerm t = t + +negateTerm :: Term -> Term +negateTerm (ConstTerm c) = ConstTerm (-c) +negateTerm (CoeffTerm (-1) v) = VarTerm v +negateTerm (CoeffTerm c v) = CoeffTerm (-c) v +negateTerm (VarTerm v) = CoeffTerm (-1) v + +-- Function to get all vars from a Term +termVar :: Term -> Maybe Var +termVar (VarTerm v) = Just v +termVar (CoeffTerm _ v) = Just v +termVar _ = Nothing + +zeroConstTerm :: Term -> Term +zeroConstTerm (ConstTerm _) = ConstTerm 0 +zeroConstTerm t = t + +isConstTerm :: Term -> Bool +isConstTerm (ConstTerm _) = True +isConstTerm _ = False + +-- | Normalize a list of 'Term's where each term is added together. +normalizeTerms :: [Term] -> [Term] +normalizeTerms = + L.sort + . map simplifyTerm + . combineTerms + . L.sortBy orderForCombineTerms + . map (varToCoeff . simplifyTerm) + where + orderForCombineTerms :: Term -> Term -> Ordering + orderForCombineTerms _ (VarTerm _) = error "Unexpected VarTerm in orderForCombineTerms" + orderForCombineTerms (VarTerm _) _ = error "Unexpected VarTerm in orderForCombineTerms" + orderForCombineTerms (ConstTerm c1) (ConstTerm c2) = compare c1 c2 + orderForCombineTerms (CoeffTerm c1 v1) (CoeffTerm c2 v2) = + case compare v1 v2 of + EQ -> compare c1 c2 + x -> x + orderForCombineTerms (ConstTerm _) (CoeffTerm _ _) = LT + orderForCombineTerms (CoeffTerm _ _) (ConstTerm _) = GT + + varToCoeff :: Term -> Term + varToCoeff (VarTerm v) = CoeffTerm 1 v + varToCoeff t = t + + combineTerms :: [Term] -> [Term] + combineTerms [] = [] + combineTerms [ConstTerm 0] = [] + combineTerms [CoeffTerm 0 _] = [] + combineTerms [x] = [x] + combineTerms allXs@(x1 : x2 : xs) = + case (x1, x2) of + (ConstTerm 0, _) -> combineTerms (x2 : xs) + (_, ConstTerm 0) -> combineTerms (x1 : xs) + (CoeffTerm 0 _, _) -> combineTerms (x2 : xs) + (_, CoeffTerm 0 _) -> combineTerms (x1 : xs) + (ConstTerm c1, ConstTerm c2) -> + if c1 + c2 == 0 + then combineTerms xs + else combineTerms (ConstTerm (c1 + c2) : xs) + (CoeffTerm c1 v1, CoeffTerm c2 v2) -> + if v1 == v2 + then combineTerms (CoeffTerm (c1 + c2) v1 : xs) + else x1 : combineTerms (x2 : xs) + _otherwise -> x1 : combineTerms (x2 : xs) + +termToTermVarsOnly :: Term -> Either String TermVarsOnly +termToTermVarsOnly (VarTerm v) = Right $ VarTermVO v +termToTermVarsOnly (CoeffTerm c v) = Right $ CoeffTermVO c v +termToTermVarsOnly (ConstTerm _) = Left "termToTermVarsOnly: ConstTerm not allowed" + +unsafeTermToTermVarsOnly :: Term -> TermVarsOnly +unsafeTermToTermVarsOnly t = + case termToTermVarsOnly t of + Right x -> x + Left e -> error e + +termsVarOnlyToTerm :: TermVarsOnly -> Term +termsVarOnlyToTerm (VarTermVO v) = VarTerm v +termsVarOnlyToTerm (CoeffTermVO c v) = CoeffTerm c v diff --git a/src/Linear/Var/Types.hs b/src/Linear/Var/Types.hs new file mode 100644 index 0000000..38706a2 --- /dev/null +++ b/src/Linear/Var/Types.hs @@ -0,0 +1,16 @@ +module Linear.Var.Types where + +import qualified Data.Map as M +import GHC.Generics (Generic) + +type SimplexNum = Rational + +type Var = Int + +data Bounds = Bounds + { lowerBound :: Maybe SimplexNum + , upperBound :: Maybe SimplexNum + } + deriving (Show, Read, Eq, Generic) + +type VarBounds = M.Map Var Bounds diff --git a/src/Linear/Var/Util.hs b/src/Linear/Var/Util.hs new file mode 100644 index 0000000..bd813dd --- /dev/null +++ b/src/Linear/Var/Util.hs @@ -0,0 +1,12 @@ +module Linear.Var.Util where + +import qualified Data.Map as M +import Linear.Var.Types (Bounds (..), VarBounds) + +validateBounds :: VarBounds -> Bool +validateBounds boundsMap = all soundBounds $ M.toList boundsMap + where + soundBounds (_, Bounds lowerBound upperBound) = + case (lowerBound, upperBound) of + (Just l, Just u) -> l <= u + (_, _) -> True diff --git a/test/Linear/Constraint/Simple/UtilSpec.hs b/test/Linear/Constraint/Simple/UtilSpec.hs new file mode 100644 index 0000000..16cf06b --- /dev/null +++ b/test/Linear/Constraint/Simple/UtilSpec.hs @@ -0,0 +1,183 @@ +-- | +-- Module: Linear.Constraint.Simple.TypesSpec +-- Description: Tests for Linear.Constraint.Simple.Types +-- Copyright: (c) Junaid Rasheed, 2020-2024 +-- License: BSD-3 +-- Maintainer: Junaid Rasheed +-- Stability: experimental +module Linear.Constraint.Simple.UtilSpec where + +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Linear.Constraint.Simple.Util + ( constraintToSimpleConstraint + , normalizeSimpleConstraint + , simpleConstraintVars + , simplifyCoeff + , simplifySimpleConstraint + , substVarSimpleConstraint + ) +import Linear.Constraint.Util (constraintVars) +import Linear.Expr.Types (Expr (..)) +import Linear.Expr.Util (exprVars) +import Linear.Term.Types (Term (..)) +import Test.Hspec (Spec, describe) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (counterexample, elements) +import TestUtil + ( evalConstraint + , evalExpr + , evalSimpleConstraint + , genVarMap + ) +import Prelude + +spec :: Spec +spec = do + describe "SimpleConstraint" $ do + prop + "substVarSimpleConstraint with a constant is the same as evaluating with the variable mapped to the constant" + $ \simpleConstraint c -> do + let vars = Set.toList $ simpleConstraintVars simpleConstraint + var <- elements vars + let varReplacement = Expr (ConstTerm c :| []) + initialVarMap <- genVarMap vars + let varMap = Map.insert var c initialVarMap + substitutedSimpleConstraint = substVarSimpleConstraint var varReplacement simpleConstraint + substitutedSimpleConstraintEval = evalSimpleConstraint varMap substitutedSimpleConstraint + simpleConstraintEval = evalSimpleConstraint varMap simpleConstraint + pure + $ counterexample + ( "simpleConstraint: " + <> show simpleConstraint + <> "\nvar: " + <> show var + <> "\nconst: " + <> show c + <> "\nvarMap: " + <> show varMap + <> "\nvarReplacement: " + <> show varReplacement + <> "\nsubstitutedSimpleConstraint: " + <> show substitutedSimpleConstraint + <> "\nsubstitutedSimpleConstraintEval: " + <> show substitutedSimpleConstraintEval + <> "\nsimpleConstraintEval: " + <> show simpleConstraintEval + ) + $ substitutedSimpleConstraintEval == simpleConstraintEval + prop + "substVarSimpleConstraint with an expr is the same as evaluating with the variable mapped to the expr" + $ \simpleConstraint exprReplacement -> do + let vars = + Set.toList $ simpleConstraintVars simpleConstraint <> exprVars exprReplacement + var <- elements vars + initialVarMap <- genVarMap vars + let exprReplacementEval = evalExpr initialVarMap exprReplacement + varMap = Map.insert var exprReplacementEval initialVarMap + substitutedSimpleConstraint = substVarSimpleConstraint var exprReplacement simpleConstraint + simpleConstraintEval = evalSimpleConstraint varMap simpleConstraint + substitutedSimpleConstraintEval = evalSimpleConstraint initialVarMap substitutedSimpleConstraint + pure + $ counterexample + ( "simpleConstraint: " + <> show simpleConstraint + <> "\nvar: " + <> show var + <> "\nexprReplacement: " + <> show exprReplacement + <> "\ninitialVarMap: " + <> show initialVarMap + <> "\nexprReplacementEval: " + <> show exprReplacementEval + <> "\nvarMap: " + <> show varMap + <> "\nsubstitutedSimpleConstraint: " + <> show substitutedSimpleConstraint + <> "\nsimpleConstraintEval: " + <> show simpleConstraintEval + <> "\nsubstitutedSimpleConstraintEval: " + <> show substitutedSimpleConstraintEval + ) + $ substitutedSimpleConstraintEval == simpleConstraintEval + prop "constraintToSimpleConstraint leads to the same evaluation" $ \constraint -> do + let vars = Set.toList $ constraintVars constraint + varMap <- genVarMap vars + let simpleConstraint = constraintToSimpleConstraint constraint + constraintEval = evalConstraint varMap constraint + simpleConstraintEval = evalSimpleConstraint varMap simpleConstraint + pure + $ counterexample + ( "constraint: " + <> show constraint + <> "\nsimpleConstraint: " + <> show simpleConstraint + <> "\ninitialVarMap: " + <> show varMap + <> "\nconstraintEval: " + <> show constraintEval + <> "\nsimpleConstraintEval" + <> show simpleConstraintEval + ) + $ constraintEval == simpleConstraintEval + prop "normalizeSimpleConstraint leads to the same evaluation" $ \simpleConstraint -> do + let vars = Set.toList $ simpleConstraintVars simpleConstraint + varMap <- genVarMap vars + let normalizedSimpleConstraint = normalizeSimpleConstraint simpleConstraint + simpleConstraintEval = evalSimpleConstraint varMap simpleConstraint + normalizedSimpleConstraintEval = evalSimpleConstraint varMap normalizedSimpleConstraint + pure + $ counterexample + ( "simpleConstraint: " + <> show simpleConstraint + <> "\nnormalizedSimpleConstraint: " + <> show normalizedSimpleConstraint + <> "\ninitialVarMap: " + <> show varMap + <> "\nsimpleConstraintEval: " + <> show simpleConstraintEval + <> "\nnormalizedSimpleConstraintEval" + <> show normalizedSimpleConstraintEval + ) + $ simpleConstraintEval == normalizedSimpleConstraintEval + prop "simplifyCoeff leads to the same evaluation" $ \simpleConstraint -> do + let vars = Set.toList $ simpleConstraintVars simpleConstraint + varMap <- genVarMap vars + let simplifiedSimpleConstraint = simplifyCoeff simpleConstraint + simpleConstraintEval = evalSimpleConstraint varMap simpleConstraint + simplifiedSimpleConstraintEval = evalSimpleConstraint varMap simplifiedSimpleConstraint + pure + $ counterexample + ( "simpleConstraint: " + <> show simpleConstraint + <> "\nsimplifiedSimpleConstraint: " + <> show simplifiedSimpleConstraint + <> "\ninitialVarMap: " + <> show varMap + <> "\nsimpleConstraintEval: " + <> show simpleConstraintEval + <> "\nsimplifiedSimpleConstraintEval: " + <> show simplifiedSimpleConstraintEval + ) + $ simpleConstraintEval == simplifiedSimpleConstraintEval + prop "simplifySimpleConstraint leads to the same evaluation" $ \simpleConstraint -> do + let vars = Set.toList $ simpleConstraintVars simpleConstraint + varMap <- genVarMap vars + let simplifiedSimpleConstraint = simplifySimpleConstraint simpleConstraint + simpleConstraintEval = evalSimpleConstraint varMap simpleConstraint + simplifiedSimpleConstraintEval = evalSimpleConstraint varMap simplifiedSimpleConstraint + pure + $ counterexample + ( "simpleConstraint: " + <> show simpleConstraint + <> "\nsimplifiedSimpleConstraint: " + <> show simplifiedSimpleConstraint + <> "\ninitialVarMap: " + <> show varMap + <> "\nsimpleConstraintEval: " + <> show simpleConstraintEval + <> "\nsimplifiedSimpleConstraintEval: " + <> show simplifiedSimpleConstraintEval + ) + $ simpleConstraintEval == simplifiedSimpleConstraintEval diff --git a/test/Linear/Expr/UtilSpec.hs b/test/Linear/Expr/UtilSpec.hs new file mode 100644 index 0000000..b155827 --- /dev/null +++ b/test/Linear/Expr/UtilSpec.hs @@ -0,0 +1,269 @@ +-- | +-- Module: Linear.Expr.TypesSpec +-- Description: Tests for Linear.Expr.Types +-- Copyright: (c) Junaid Rasheed, 2020-2024 +-- License: BSD-3 +-- Maintainer: Junaid Rasheed +-- Stability: experimental +module Linear.Expr.UtilSpec where + +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as Map +import qualified Data.Set as Set +import Linear.Expr.Types (Expr (..)) +import Linear.Expr.Util + ( addExpr + , exprToList + , exprVars + , listToExpr + , negateExpr + , simplifyExpr + , substVarExpr + , subtractExpr + , sumExprConstTerms + , zeroConstExpr + ) +import Linear.Term.Types (Term (..)) +import Test.Hspec (Spec, describe) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (counterexample, elements) +import TestUtil (evalExpr, genVarMap) + +spec :: Spec +spec = do + describe "Expr" $ do + prop "simplifying leads to same evaluation" $ \expr -> do + let vars = Set.toList $ exprVars expr + varMap <- genVarMap vars + pure $ evalExpr varMap (simplifyExpr expr) == evalExpr varMap expr + prop "simplifying twice is the same as simplifying once" $ \expr -> do + -- expr: (Expr (CoeffTerm (1 % 1) 0) :+ CoeffTerm (1 % 2) (-1)) :+ CoeffTerm (2 % 1) (-1) + -- 1 = x + -- -1 = y + -- 1x + 0.5y + 2y + -- simplifiedExpr: (Expr (CoeffTerm (1 % 2) (-1)) :+ CoeffTerm (2 % 1) (-1)) :+ VarTerm 0 + -- 0.5y + 2y + x + -- simplifiedTwiceExpr: Expr (CoeffTerm (5 % 2) (-1)) :+ VarTerm 0 + -- 2.5y + x + let simplifiedExpr = simplifyExpr expr + let simplifiedTwiceExpr = simplifyExpr simplifiedExpr + counterexample + ( "expr: " + <> show expr + <> "\nsimplifiedExpr: " + <> show simplifiedExpr + <> "\nsimplifiedTwiceExpr: " + <> show simplifiedTwiceExpr + ) + $ simplifiedTwiceExpr == simplifiedExpr + prop "composing listToExpr and exprToList is the same as id" $ \expr -> do + let exprConvertedTwice = listToExpr (exprToList expr) + counterexample + ( "expr: " + <> show expr + <> "\nexprConvertedTwice: " + <> show exprConvertedTwice + ) + $ exprConvertedTwice == expr + prop "summing c terms is the same as evaluating the expr with zero coefficients" $ \expr -> do + let vars = Set.toList $ exprVars expr + varMap = Map.fromList $ map (,0) vars + constSum = sumExprConstTerms expr + exprEval = evalExpr varMap expr + counterexample + ( "expr: " + <> show expr + <> "\nvarMap: " + <> show varMap + <> "\nconstSum: " + <> show constSum + <> "\nexprEval: " + <> show exprEval + ) + $ constSum == exprEval + prop "negating and evaluating is the same as negating the evaluation" $ \expr -> do + let vars = Set.toList $ exprVars expr + varMap <- genVarMap vars + let negatedExpr = negateExpr expr + exprEval = evalExpr varMap expr + exprEvalNegated = negate exprEval + negatedExprEval = evalExpr varMap negatedExpr + pure + $ counterexample + ( "expr: " + <> show expr + <> "\nnegatedExpr: " + <> show negatedExpr + <> "\nvarMap: " + <> show varMap + <> "\nexprEval: " + <> show exprEval + <> "\nexprEvalNegated: " + <> show exprEvalNegated + <> "\nnegatedExprEval: " + <> show negatedExprEval + ) + $ exprEvalNegated == negatedExprEval + prop "negating a simplified expression twice is the same as not negating" $ \expr -> do + let simplifiedExpr = simplifyExpr expr + negatedTwiceSimpleExpr = negateExpr (negateExpr simplifiedExpr) + counterexample + ( "expr: " + <> show expr + <> "\nsimplifiedExpr: " + <> show simplifiedExpr + <> "\nnegatedTwiceSimpleExpr: " + <> show negatedTwiceSimpleExpr + ) + $ negatedTwiceSimpleExpr == simplifiedExpr + prop "addExpr is the same as evaluating the sum of the exprs" $ \expr1 expr2 -> do + let vars = Set.toList $ exprVars expr1 <> exprVars expr2 + varMap <- genVarMap vars + let addExpr1Expr2 = addExpr expr1 expr2 + addExpr1Expr2Eval = evalExpr varMap addExpr1Expr2 + expr1Eval = evalExpr varMap expr1 + expr2Eval = evalExpr varMap expr2 + sumExpr1EvalExpr2Eval = expr1Eval + expr2Eval + pure + $ counterexample + ( "expr1: " + <> show expr1 + <> "\nexpr2: " + <> show expr2 + <> "\nvarMap:" + <> show varMap + <> "\naddExpr1Expr2: " + <> show addExpr1Expr2 + <> "\naddExpr1Expr2Eval: " + <> show addExpr1Expr2Eval + <> "\nexpr1Eval: " + <> show expr1Eval + <> "\nexpr2Eval: " + <> show expr2Eval + <> "\nexpr1EvalPlusExpr2Eval: " + <> show sumExpr1EvalExpr2Eval + ) + $ addExpr1Expr2Eval == sumExpr1EvalExpr2Eval + prop "subtractExpr is the same as evaluating the difference of the exprs" $ \expr1 expr2 -> do + let vars = Set.toList $ exprVars expr1 <> exprVars expr2 + varMap <- genVarMap vars + let subtractExpr1Expr2 = subtractExpr expr1 expr2 + subtractExpr1Expr2Eval = evalExpr varMap subtractExpr1Expr2 + expr1Eval = evalExpr varMap expr1 + expr2Eval = evalExpr varMap expr2 + diffExpr1EvalExpr2Eval = expr1Eval - expr2Eval + pure + $ counterexample + ( "expr1: " + <> show expr1 + <> "\nexpr2: " + <> show expr2 + <> "\nvarMap:" + <> show varMap + <> "\nsubtractExpr1Expr2: " + <> show subtractExpr1Expr2 + <> "\nsubtractExpr1Expr2Eval: " + <> show subtractExpr1Expr2Eval + <> "\nexpr1Eval: " + <> show expr1Eval + <> "\nexpr2Eval: " + <> show expr2Eval + <> "\nexpr1EvalMinusExpr2Eval: " + <> show diffExpr1EvalExpr2Eval + ) + $ subtractExpr1Expr2Eval == diffExpr1EvalExpr2Eval + prop "substVarExpr with the same variable is the same as simplfying" $ \expr -> do + let vars = Set.toList $ exprVars expr + var <- elements vars + varMap <- genVarMap vars + let varReplacement = Expr (VarTerm var :| []) + exprSubst = substVarExpr var varReplacement expr + exprSimplified = simplifyExpr expr + exprSubstEval = evalExpr varMap exprSubst + exprSimplifiedEval = evalExpr varMap exprSimplified + pure + $ counterexample + ( "expr: " + <> show expr + <> "\nvar: " + <> show var + <> "\nvarMap: " + <> show varMap + <> "\nvarReplacement: " + <> show varReplacement + <> "\nsubstVarExpr: " + <> show exprSubst + <> "\nsimplifyExpr: " + <> show exprSimplified + <> "\nexprSubstEval: " + <> show exprSubstEval + <> "\nexprSimplifiedEval: " + <> show exprSimplifiedEval + ) + $ exprSubstEval == exprSimplifiedEval + prop + "substVarExpr with a constant is the same as evaluating with the variable mapped to the constant" + $ \expr c -> do + let varReplacement = Expr (ConstTerm c :| []) + let vars = Set.toList $ exprVars expr + var <- elements vars + initialVarMap <- genVarMap vars + let varMap = Map.insert var c initialVarMap + substitutedExpr = substVarExpr var varReplacement expr + substitutedExprEval = evalExpr varMap substitutedExpr + exprEval = evalExpr varMap expr + pure + $ counterexample + ( "expr: " + <> show expr + <> "\nvar: " + <> show var + <> "\nconst: " + <> show c + <> "\nvarMap: " + <> show varMap + <> "\nvarReplacement: " + <> show varReplacement + <> "\nsubstitutedExpr: " + <> show substitutedExpr + <> "\nsubstitutedExprEval: " + <> show substitutedExprEval + <> "\nexprEval: " + <> show exprEval + ) + $ evalExpr varMap (substVarExpr var varReplacement expr) == evalExpr varMap expr + prop + "substVarExpr with an expr is the same as evaluating with the variable mapped to the expr" + $ \expr exprReplacement -> do + let vars = Set.toList $ exprVars expr <> exprVars exprReplacement + var <- elements vars + initialVarMap <- genVarMap vars + let exprReplacementEval = evalExpr initialVarMap exprReplacement + varMap = Map.insert var exprReplacementEval initialVarMap + substitutedExpr = substVarExpr var exprReplacement expr + exprEval = evalExpr varMap expr + substitutedExprEval = evalExpr initialVarMap substitutedExpr + pure + $ counterexample + ( "expr: " + <> show expr + <> "\nvar: " + <> show var + <> "\nexprReplacement: " + <> show exprReplacement + <> "\ninitialVarMap: " + <> show initialVarMap + <> "\nexprReplacementEval: " + <> show exprReplacementEval + <> "\nvarMap: " + <> show varMap + <> "\nsubstExpr: " + <> show substitutedExpr + <> "\nexprEval: " + <> show exprEval + <> "\nsubstExprEval: " + <> show substitutedExprEval + ) + $ substitutedExprEval == exprEval + prop "zeroConstExpr correctly zeroes constant terms in expressions" $ \expr -> sumExprConstTerms (zeroConstExpr expr) == 0 diff --git a/test/Linear/Simplex/TypesSpec.hs b/test/Linear/Simplex/TypesSpec.hs deleted file mode 100644 index 5baccee..0000000 --- a/test/Linear/Simplex/TypesSpec.hs +++ /dev/null @@ -1,719 +0,0 @@ -module Linear.Simplex.TypesSpec (spec) where - -import Prelude - -import Control.Monad (forM) -import Data.Functor ((<&>)) -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Data.Maybe as Maybe -import qualified Data.Set as Set -import Test.Hspec -import Test.Hspec.QuickCheck -import Test.QuickCheck - -import Linear.Simplex.Types - -import qualified Debug.Trace as T - -termVar :: Term -> Maybe Var -termVar (VarTerm v) = Just v -termVar (CoeffTerm _ v) = Just v -termVar _ = Nothing - -exprVars :: Expr -> Set.Set Var -exprVars = Set.fromList . Maybe.catMaybes . map termVar . exprToList - -constraintVars :: Constraint -> Set.Set Var -constraintVars (lhs :<= rhs) = exprVars lhs <> exprVars rhs -constraintVars (lhs :>= rhs) = exprVars lhs <> exprVars rhs -constraintVars (lhs :== rhs) = exprVars lhs <> exprVars rhs - -simpleConstraintVars :: SimpleConstraint -> Set.Set Var -simpleConstraintVars (lhs :<= rhs) = exprVars lhs -simpleConstraintVars (lhs :>= rhs) = exprVars lhs -simpleConstraintVars (lhs :== rhs) = exprVars lhs - -simpleSystemVars :: SimpleSystem -> Set.Set Var -simpleSystemVars = Set.unions . map simpleConstraintVars - --- data Term = ConstTerm SimplexNum | CoeffTerm SimplexNum Var | VarTerm Var -- Consider VarTerm Var - note, we must consider normalizing this: Considered. It makes going to standard form easier due to type safety --- deriving (Show, Read, Eq, Ord, Generic) - --- TODO: consider type NumberConstraint = GenericConstraint SimplexNum SimplexNum - -evalTerm :: VarLitMap -> Term -> SimplexNum -evalTerm _ (ConstTerm c) = c -evalTerm varMap (CoeffTerm c v) = c * (Map.findWithDefault (error $ "evalTerm: " <> show v <> " not found in varMap " <> show varMap) v varMap) -evalTerm varMap (VarTerm v) = Map.findWithDefault (error $ "evalTerm: " <> show v <> " not found in varMap " <> show varMap) v varMap - -evalExpr :: VarLitMap -> Expr -> SimplexNum -evalExpr varMap expr = sum $ map (evalTerm varMap) $ exprToList expr - -evalConstraint :: VarLitMap -> Constraint -> Bool -evalConstraint varMap (lhs :<= rhs) = evalExpr varMap lhs <= evalExpr varMap rhs -evalConstraint varMap (lhs :>= rhs) = evalExpr varMap lhs >= evalExpr varMap rhs -evalConstraint varMap (lhs :== rhs) = evalExpr varMap lhs == evalExpr varMap rhs - -evalSimpleConstraint :: VarLitMap -> SimpleConstraint -> Bool -evalSimpleConstraint varMap (lhs :<= rhs) = evalExpr varMap lhs <= rhs -evalSimpleConstraint varMap (lhs :>= rhs) = evalExpr varMap lhs >= rhs -evalSimpleConstraint varMap (lhs :== rhs) = evalExpr varMap lhs == rhs - -evalSimpleSystem :: VarLitMap -> SimpleSystem -> Bool -evalSimpleSystem varMap = all (evalSimpleConstraint varMap) - -genVarMap :: [Var] -> Gen VarLitMap -genVarMap vars = do - varVals <- forM vars $ const arbitrary - pure $ Map.fromList $ zip vars varVals - -spec :: Spec -spec = do - describe "Term" $ do - prop "simplifying leads to same evaluation" $ \term -> do - varMap <- maybe (pure Map.empty) (genVarMap . List.singleton) $ termVar term - let simplifiedTerm = simplifyTerm term - termEval = evalTerm varMap term - simplifiedTermEval = evalTerm varMap simplifiedTerm - pure $ - counterexample - ( "term: " - <> show term - <> "simplifiedTerm: " - <> show simplifiedTerm - <> "\nvarMap: " - <> show varMap - <> "\ntermEval: " - <> show termEval - <> "\nsimplifiedTermEval: " - <> show simplifiedTermEval - ) $ - evalTerm varMap (simplifyTerm term) == evalTerm varMap term - prop "simplifying twice is the same as simplifying once" $ \term -> do - let simplifiedTerm = simplifyTerm term - simplifiedTwiceTerm = simplifyTerm simplifiedTerm - counterexample - ( "term: " - <> show term - <> "\nsimplifiedTerm: " - <> show simplifiedTerm - <> "\nsimplifiedTwiceTerm: " - <> show simplifiedTwiceTerm - ) $ - simplifiedTwiceTerm == simplifiedTerm - prop "negating and evaluating is the same as negating the evaluation" $ \term -> do - varMap <- maybe (pure $ Map.empty) (genVarMap . List.singleton) $ termVar term - let - negatedTerm = negateTerm term - termEval = evalTerm varMap term - negatedTermEval = evalTerm varMap negatedTerm - pure $ - counterexample - ( "term: " - <> show term - <> "\nnegatedTerm: " - <> show negatedTerm - <> "\nvarMap: " - <> show varMap - <> "\ntermEval: " - <> show termEval - <> "\nnegatedTermEval: " - <> show negatedTermEval - ) $ - negate termEval == negatedTermEval - prop "negating twice is the same as not negating" $ \term -> do - let simplifiedTerm = simplifyTerm term - negatedTwiceSimpleTerm = negateTerm (negateTerm simplifiedTerm) - counterexample - ( "term: " - <> show term - <> "\nsimplifiedTerm: " - <> show simplifiedTerm - <> "\nnegatedTwiceSimpleTerm: " - <> show negatedTwiceSimpleTerm - ) $ - negatedTwiceSimpleTerm == simplifiedTerm - prop "zeroConstTerm correctly zeroes constant terms" $ \term -> do - let termZeroedConsts = zeroConstTerm term - counterexample - ( "term: " - <> show term - <> "\ntermZeroedConsts: " - <> show termZeroedConsts - ) $ - case term of - ConstTerm _ -> termZeroedConsts == ConstTerm 0 - _ -> termZeroedConsts == term - describe "Expr" $ do - prop "simplifying leads to same evaluation" $ \expr -> do - let vars = Set.toList $ exprVars expr - varMap <- genVarMap vars - pure $ evalExpr varMap (simplifyExpr expr) == evalExpr varMap expr - prop "simplifying twice is the same as simplifying once" $ \expr -> do - -- expr: (Expr (CoeffTerm (1 % 1) 0) :+ CoeffTerm (1 % 2) (-1)) :+ CoeffTerm (2 % 1) (-1) - -- 1 = x - -- -1 = y - -- 1x + 0.5y + 2y - -- simplifiedExpr: (Expr (CoeffTerm (1 % 2) (-1)) :+ CoeffTerm (2 % 1) (-1)) :+ VarTerm 0 - -- 0.5y + 2y + x - -- simplifiedTwiceExpr: Expr (CoeffTerm (5 % 2) (-1)) :+ VarTerm 0 - -- 2.5y + x - let simplifiedExpr = simplifyExpr expr - let simplifiedTwiceExpr = simplifyExpr simplifiedExpr - counterexample - ( "expr: " - <> show expr - <> "\nsimplifiedExpr: " - <> show simplifiedExpr - <> "\nsimplifiedTwiceExpr: " - <> show simplifiedTwiceExpr - ) $ - simplifiedTwiceExpr == simplifiedExpr - prop "composing listToExpr and exprToList is the same as id" $ \expr -> do - let exprConvertedTwice = listToExpr (exprToList expr) - counterexample - ( "expr: " - <> show expr - <> "\nexprConvertedTwice: " - <> show exprConvertedTwice - ) $ - exprConvertedTwice == expr - prop "summing c terms is the same as evaluating the expr with zero coefficients" $ \expr -> do - let vars = Set.toList $ exprVars expr - varMap = Map.fromList $ map (, 0) vars - constSum = sumExprConstTerms expr - exprEval = evalExpr varMap expr - counterexample - ( "expr: " - <> show expr - <> "\nvarMap: " - <> show varMap - <> "\nconstSum: " - <> show constSum - <> "\nexprEval: " - <> show exprEval - ) $ - constSum == exprEval - prop "negating and evaluating is the same as negating the evaluation" $ \expr -> do - let vars = Set.toList $ exprVars expr - varMap <- genVarMap vars - let negatedExpr = negateExpr expr - exprEval = evalExpr varMap expr - exprEvalNegated = negate exprEval - negatedExprEval = evalExpr varMap negatedExpr - pure $ counterexample - ( "expr: " - <> show expr - <> "\nnegatedExpr: " - <> show negatedExpr - <> "\nvarMap: " - <> show varMap - <> "\nexprEval: " - <> show exprEval - <> "\nexprEvalNegated: " - <> show exprEvalNegated - <> "\nnegatedExprEval: " - <> show negatedExprEval - ) $ - exprEvalNegated == negatedExprEval - prop "negating a simplified expression twice is the same as not negating" $ \expr -> do - let simplifiedExpr = simplifyExpr expr - negatedTwiceSimpleExpr = negateExpr (negateExpr simplifiedExpr) - counterexample - ( "expr: " - <> show expr - <> "\nsimplifiedExpr: " - <> show simplifiedExpr - <> "\nnegatedTwiceSimpleExpr: " - <> show negatedTwiceSimpleExpr - ) $ - negatedTwiceSimpleExpr == simplifiedExpr - prop "addExpr is the same as evaluating the sum of the exprs" $ \expr1 expr2 -> do - let vars = Set.toList $ exprVars expr1 <> exprVars expr2 - varMap <- genVarMap vars - let addExpr1Expr2 = addExpr expr1 expr2 - addExpr1Expr2Eval = evalExpr varMap addExpr1Expr2 - expr1Eval = evalExpr varMap expr1 - expr2Eval = evalExpr varMap expr2 - sumExpr1EvalExpr2Eval = expr1Eval + expr2Eval - pure $ counterexample - ("expr1: " - <> show expr1 - <> "\nexpr2: " - <> show expr2 - <> "\nvarMap:" - <> show varMap - <> "\naddExpr1Expr2: " - <> show addExpr1Expr2 - <> "\naddExpr1Expr2Eval: " - <> show addExpr1Expr2Eval - <> "\nexpr1Eval: " - <> show expr1Eval - <> "\nexpr2Eval: " - <> show expr2Eval - <> "\nexpr1EvalPlusExpr2Eval: " - <> show sumExpr1EvalExpr2Eval - ) $ addExpr1Expr2Eval == sumExpr1EvalExpr2Eval - prop "subtractExpr is the same as evaluating the difference of the exprs" $ \expr1 expr2 -> do - let vars = Set.toList $ exprVars expr1 <> exprVars expr2 - varMap <- genVarMap vars - let subtractExpr1Expr2 = subtractExpr expr1 expr2 - subtractExpr1Expr2Eval = evalExpr varMap subtractExpr1Expr2 - expr1Eval = evalExpr varMap expr1 - expr2Eval = evalExpr varMap expr2 - diffExpr1EvalExpr2Eval = expr1Eval - expr2Eval - pure $ counterexample - ("expr1: " - <> show expr1 - <> "\nexpr2: " - <> show expr2 - <> "\nvarMap:" - <> show varMap - <> "\nsubtractExpr1Expr2: " - <> show subtractExpr1Expr2 - <> "\nsubtractExpr1Expr2Eval: " - <> show subtractExpr1Expr2Eval - <> "\nexpr1Eval: " - <> show expr1Eval - <> "\nexpr2Eval: " - <> show expr2Eval - <> "\nexpr1EvalMinusExpr2Eval: " - <> show diffExpr1EvalExpr2Eval - ) $ subtractExpr1Expr2Eval == diffExpr1EvalExpr2Eval - prop "substVarExpr with the same variable is the same as simplfying" $ \expr -> do - let vars = Set.toList $ exprVars expr - var <- elements vars - varMap <- genVarMap vars - let varReplacement = Expr (VarTerm var) - exprSubst = substVarExpr var varReplacement expr - exprSimplified = simplifyExpr expr - exprSubstEval = evalExpr varMap exprSubst - exprSimplifiedEval = evalExpr varMap exprSimplified - pure $ - counterexample - ( "expr: " - <> show expr - <> "\nvar: " - <> show var - <> "\nvarMap: " - <> show varMap - <> "\nvarReplacement: " - <> show varReplacement - <> "\nsubstVarExpr: " - <> show exprSubst - <> "\nsimplifyExpr: " - <> show exprSimplified - <> "\nexprSubstEval: " - <> show exprSubstEval - <> "\nexprSimplifiedEval: " - <> show exprSimplifiedEval - ) $ - exprSubstEval == exprSimplifiedEval - prop "substVarExpr with a constant is the same as evaluating with the variable mapped to the constant" $ \expr c -> do - let varReplacement = Expr (ConstTerm c) - let vars = Set.toList $ exprVars expr - var <- elements vars - initialVarMap <- genVarMap vars - let varMap = Map.insert var c initialVarMap - substitutedExpr = substVarExpr var varReplacement expr - substitutedExprEval = evalExpr varMap substitutedExpr - exprEval = evalExpr varMap expr - pure $ - counterexample - ( "expr: " - <> show expr - <> "\nvar: " - <> show var - <> "\nconst: " - <> show c - <> "\nvarMap: " - <> show varMap - <> "\nvarReplacement: " - <> show varReplacement - <> "\nsubstitutedExpr: " - <> show substitutedExpr - <> "\nsubstitutedExprEval: " - <> show substitutedExprEval - <> "\nexprEval: " - <> show exprEval - ) $ - evalExpr varMap (substVarExpr var varReplacement expr) == evalExpr varMap expr - prop "substVarExpr with an expr is the same as evaluating with the variable mapped to the expr" $ \expr exprReplacement -> do - let vars = Set.toList $ exprVars expr <> exprVars exprReplacement - var <- elements vars - initialVarMap <- genVarMap vars - let exprReplacementEval = evalExpr initialVarMap exprReplacement - varMap = Map.insert var exprReplacementEval initialVarMap - substitutedExpr = substVarExpr var exprReplacement expr - exprEval = evalExpr varMap expr - substitutedExprEval = evalExpr initialVarMap substitutedExpr - pure $ - counterexample - ( "expr: " - <> show expr - <> "\nvar: " - <> show var - <> "\nexprReplacement: " - <> show exprReplacement - <> "\ninitialVarMap: " - <> show initialVarMap - <> "\nexprReplacementEval: " - <> show exprReplacementEval - <> "\nvarMap: " - <> show varMap - <> "\nsubstExpr: " - <> show substitutedExpr - <> "\nexprEval: " - <> show exprEval - <> "\nsubstExprEval: " - <> show substitutedExprEval - ) $ substitutedExprEval == exprEval - prop "zeroConstExpr correctly zeroes constant terms in expressions" $ \expr -> sumExprConstTerms (zeroConstExpr expr) == 0 - describe "SimpleConstraint" $ do - it "substVarSimpleConstraint with a constant is the same as evaluating with the variable mapped to the constant" $ do - property $ \simpleConstraint c -> do - let vars = Set.toList $ simpleConstraintVars simpleConstraint - var <- elements vars - let varReplacement = Expr (ConstTerm c) - initialVarMap <- genVarMap vars - let varMap = Map.insert var c initialVarMap - substitutedSimpleConstraint = substVarSimpleConstraint var varReplacement simpleConstraint - substitutedSimpleConstraintEval = evalSimpleConstraint varMap substitutedSimpleConstraint - simpleConstraintEval = evalSimpleConstraint varMap simpleConstraint - pure $ - counterexample - ( "simpleConstraint: " - <> show simpleConstraint - <> "\nvar: " - <> show var - <> "\nconst: " - <> show c - <> "\nvarMap: " - <> show varMap - <> "\nvarReplacement: " - <> show varReplacement - <> "\nsubstitutedSimpleConstraint: " - <> show substitutedSimpleConstraint - <> "\nsubstitutedSimpleConstraintEval: " - <> show substitutedSimpleConstraintEval - <> "\nsimpleConstraintEval: " - <> show simpleConstraintEval - ) $ - substitutedSimpleConstraintEval == simpleConstraintEval - it "substVarSimpleConstraint with an expr is the same as evaluating with the variable mapped to the expr" $ do - property $ \simpleConstraint exprReplacement -> do - let vars = Set.toList $ simpleConstraintVars simpleConstraint <> exprVars exprReplacement - var <- elements vars - initialVarMap <- genVarMap vars - let exprReplacementEval = evalExpr initialVarMap exprReplacement - varMap = Map.insert var exprReplacementEval initialVarMap - substitutedSimpleConstraint = substVarSimpleConstraint var exprReplacement simpleConstraint - simpleConstraintEval = evalSimpleConstraint varMap simpleConstraint - substitutedSimpleConstraintEval = evalSimpleConstraint initialVarMap substitutedSimpleConstraint - pure $ - counterexample - ( "simpleConstraint: " - <> show simpleConstraint - <> "\nvar: " - <> show var - <> "\nexprReplacement: " - <> show exprReplacement - <> "\ninitialVarMap: " - <> show initialVarMap - <> "\nexprReplacementEval: " - <> show exprReplacementEval - <> "\nvarMap: " - <> show varMap - <> "\nsubstitutedSimpleConstraint: " - <> show substitutedSimpleConstraint - <> "\nsimpleConstraintEval: " - <> show simpleConstraintEval - <> "\nsubstitutedSimpleConstraintEval: " - <> show substitutedSimpleConstraintEval - ) $ - substitutedSimpleConstraintEval == simpleConstraintEval - it "constraintToSimpleConstraint leads to the same evaluation" $ do - property $ \constraint -> do - let vars = Set.toList $ constraintVars constraint - varMap <- genVarMap vars - let simpleConstraint = constraintToSimpleConstraint constraint - constraintEval = evalConstraint varMap constraint - simpleConstraintEval = evalSimpleConstraint varMap simpleConstraint - pure $ - counterexample - ( "constraint: " - <> show constraint - <> "\nsimpleConstraint: " - <> show simpleConstraint - <> "\ninitialVarMap: " - <> show varMap - <> "\nconstraintEval: " - <> show constraintEval - <> "\nsimpleConstraintEval" - <> show simpleConstraintEval - ) $ - constraintEval == simpleConstraintEval - it "normalizeSimpleConstraint leads to the same evaluation" $ do - property $ \simpleConstraint -> do - let vars = Set.toList $ simpleConstraintVars simpleConstraint - varMap <- genVarMap vars - let normalizedSimpleConstraint = normalizeSimpleConstraint simpleConstraint - simpleConstraintEval = evalSimpleConstraint varMap simpleConstraint - normalizedSimpleConstraintEval = evalSimpleConstraint varMap normalizedSimpleConstraint - pure $ - counterexample - ( "simpleConstraint: " - <> show simpleConstraint - <> "\nnormalizedSimpleConstraint: " - <> show normalizedSimpleConstraint - <> "\ninitialVarMap: " - <> show varMap - <> "\nsimpleConstraintEval: " - <> show simpleConstraintEval - <> "\nnormalizedSimpleConstraintEval" - <> show normalizedSimpleConstraintEval - ) $ - simpleConstraintEval == normalizedSimpleConstraintEval - it "simplifyCoeff leads to the same evaluation" $ do - property $ \simpleConstraint -> do - let vars = Set.toList $ simpleConstraintVars simpleConstraint - varMap <- genVarMap vars - let simplifiedSimpleConstraint = simplifyCoeff simpleConstraint - simpleConstraintEval = evalSimpleConstraint varMap simpleConstraint - simplifiedSimpleConstraintEval = evalSimpleConstraint varMap simplifiedSimpleConstraint - pure $ - counterexample - ( "simpleConstraint: " - <> show simpleConstraint - <> "\nsimplifiedSimpleConstraint: " - <> show simplifiedSimpleConstraint - <> "\ninitialVarMap: " - <> show varMap - <> "\nsimpleConstraintEval: " - <> show simpleConstraintEval - <> "\nsimplifiedSimpleConstraintEval: " - <> show simplifiedSimpleConstraintEval - ) $ - simpleConstraintEval == simplifiedSimpleConstraintEval - it "simplifySimpleConstraint leads to the same evaluation" $ do - property $ \simpleConstraint -> do - let vars = Set.toList $ simpleConstraintVars simpleConstraint - varMap <- genVarMap vars - let simplifiedSimpleConstraint = simplifySimpleConstraint simpleConstraint - simpleConstraintEval = evalSimpleConstraint varMap simpleConstraint - simplifiedSimpleConstraintEval = evalSimpleConstraint varMap simplifiedSimpleConstraint - pure $ - counterexample - ( "simpleConstraint: " - <> show simpleConstraint - <> "\nsimplifiedSimpleConstraint: " - <> show simplifiedSimpleConstraint - <> "\ninitialVarMap: " - <> show varMap - <> "\nsimpleConstraintEval: " - <> show simpleConstraintEval - <> "\nsimplifiedSimpleConstraintEval: " - <> show simplifiedSimpleConstraintEval - ) $ - simpleConstraintEval == simplifiedSimpleConstraintEval - describe "SimpleSystem" $ do - it "simplifySimpleSystem leads to the same evaluation" $ do - property $ \simpleSystem -> do - let vars = Set.toList $ simpleSystemVars simpleSystem - varMap <- genVarMap vars - let simplifiedSimpleSystem = simplifySimpleSystem simpleSystem - simpleSystemEval = evalSimpleSystem varMap simpleSystem - simplifiedSimpleSystemEval = evalSimpleSystem varMap simplifiedSimpleSystem - pure $ - counterexample - ( "simpleSystem: " - <> show simpleSystem - <> "\nsimplifiedSimpleSystem: " - <> show simplifiedSimpleSystem - <> "\ninitialVarMap: " - <> show varMap - <> "\nsimpleSystemEval: " - <> show simpleSystemEval - <> "\nsimplifiedSimpleSystemEval: " - <> show simplifiedSimpleSystemEval - ) $ - simpleSystemEval == simplifiedSimpleSystemEval - it "findHighestVar finds the highest variable in a simple system" $ do - let simpleSystem1 = - [ Expr (VarTerm 0) :>= 0 - , Expr (VarTerm 0) :<= 1 - , Expr (VarTerm 1) :>= 0 - , Expr (VarTerm 1) :<= 1 - ] - simpleSystem100 = - [ Expr (VarTerm 0) :<= 1 - , Expr (VarTerm 50) :<= 1 - , Expr (VarTerm 100) :<= 1 - ] - simpleSystem10 = - [ Expr (VarTerm (-10)) :<= 1 - , Expr (VarTerm 0) :<= 1 - , Expr (VarTerm 10) :<= 1 - ] - simpleSystemMinus10 = - [ Expr (VarTerm (-10)) :<= 1 - , Expr (VarTerm (-20)) :<= 1 - ] - - findHighestVar simpleSystem1 `shouldBe` 1 - findHighestVar simpleSystem100 `shouldBe` 100 - findHighestVar simpleSystem10 `shouldBe` 10 - findHighestVar simpleSystemMinus10 `shouldBe` (-10) - describe "Bounds" $ do - it "validateBounds finds that deriving bounds for a system where -1 <= x <= 1 has valid bounds" $ do - let simpleSystem = - [ Expr (VarTerm 0) :>= (-1) - , Expr (VarTerm 0) :<= 1 - ] - derivedBounds = deriveBounds simpleSystem - expectedBounds = Map.fromList [(0, Bounds (Just (-1)) (Just 1))] - derivedBounds `shouldBe` expectedBounds - validateBounds derivedBounds `shouldBe` True - it "validateBounds finds that deriving bounds for a system where 0 <= x <= 1 has valid bounds" $ do - let simpleSystem = - [ Expr (VarTerm 0) :>= 0 - , Expr (VarTerm 0) :<= 1 - ] - derivedBounds = deriveBounds simpleSystem - expectedBounds = Map.fromList [(0, Bounds (Just 0) (Just 1))] - derivedBounds `shouldBe` expectedBounds - validateBounds derivedBounds `shouldBe` True - it "validateBounds finds that deriving bounds for a system where 1 <= x <= 1 has valid bounds" $ do - let simpleSystem = - [ Expr (VarTerm 0) :>= 1 - , Expr (VarTerm 0) :<= 1 - ] - derivedBounds = deriveBounds simpleSystem - expectedBounds = Map.fromList [(0, Bounds (Just 1) (Just 1))] - derivedBounds `shouldBe` expectedBounds - validateBounds derivedBounds `shouldBe` True - it "validateBounds finds that deriving bounds for a system where 1 <= x <= 0 has invalid bounds" $ do - let simpleSystem = - [ Expr (VarTerm 0) :>= 1 - , Expr (VarTerm 0) :<= 0 - ] - derivedBounds = deriveBounds simpleSystem - expectedBounds = Map.fromList [(0, Bounds (Just 1) (Just 0))] - derivedBounds `shouldBe` expectedBounds - validateBounds derivedBounds `shouldBe` False - it "validateBounds finds that deriving bounds for a system where 0 <= x <= 1 and 1 <= y <= 3 has valid bounds" $ do - let simpleSystem = - [ Expr (VarTerm 0) :>= 0 - , Expr (VarTerm 0) :<= 1 - , Expr (VarTerm 1) :>= 1 - , Expr (VarTerm 1) :<= 3 - ] - derivedBounds = deriveBounds simpleSystem - expectedBounds = Map.fromList [(0, Bounds (Just 0) (Just 1)), (1, Bounds (Just 1) (Just 3))] - derivedBounds `shouldBe` expectedBounds - validateBounds derivedBounds `shouldBe` True - it "validateBounds finds that deriving bounds for a system where 1 <= x <= 0 and 3 <= y <= 1 has invalid bounds" $ do - let simpleSystem = - [ Expr (VarTerm 0) :>= 1 - , Expr (VarTerm 0) :<= 0 - , Expr (VarTerm 1) :>= 3 - , Expr (VarTerm 1) :<= 1 - ] - derivedBounds = deriveBounds simpleSystem - expectedBounds = Map.fromList [(0, Bounds (Just 1) (Just 0)), (1, Bounds (Just 3) (Just 1))] - derivedBounds `shouldBe` expectedBounds - validateBounds derivedBounds `shouldBe` False - it "validateBounds finds that deriving bounds for a system where 1 <= x <= 0 and 1 <= y <= 3 has invalid bounds" $ do - let simpleSystem = - [ Expr (VarTerm 0) :>= 1 - , Expr (VarTerm 0) :<= 0 - , Expr (VarTerm 1) :>= 1 - , Expr (VarTerm 1) :<= 3 - ] - derivedBounds = deriveBounds simpleSystem - expectedBounds = Map.fromList [(0, Bounds (Just 1) (Just 0)), (1, Bounds (Just 1) (Just 3))] - derivedBounds `shouldBe` expectedBounds - validateBounds derivedBounds `shouldBe` False - it "validateBounds finds that deriving bounds for a system where 0 <= x <= 1 and 3 <= y <= 1 has invalid bounds" $ do - let simpleSystem = - [ Expr (VarTerm 0) :>= 0 - , Expr (VarTerm 0) :<= 1 - , Expr (VarTerm 1) :>= 3 - , Expr (VarTerm 1) :<= 1 - ] - derivedBounds = deriveBounds simpleSystem - expectedBounds = Map.fromList [(0, Bounds (Just 0) (Just 1)), (1, Bounds (Just 3) (Just 1))] - derivedBounds `shouldBe` expectedBounds - validateBounds derivedBounds `shouldBe` False - it "removeUselessSystemBounds removes x <= 3 when bounds say x <= 2" $ do - let simpleSystem = - [ Expr (VarTerm 0) :<= 2 - , Expr (VarTerm 0) :<= 3 - ] - bounds = Map.fromList [(0, Bounds (Just 0) (Just 2))] - simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds - expectedSimpleSystem = [Expr (VarTerm 0) :<= 2] - simplifiedSimpleSystem `shouldBe` expectedSimpleSystem - it "removeUselessSystemBounds does not remove x <= 2 when bounds say x <= 2" $ do - let simpleSystem = - [ Expr (VarTerm 0) :<= 2 - ] - bounds = Map.fromList [(0, Bounds (Just 0) (Just 2))] - simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds - expectedSimpleSystem = [Expr (VarTerm 0) :<= 2] - simplifiedSimpleSystem `shouldBe` expectedSimpleSystem - it "removeUselessSystemBounds removes x >= 3 when bounds say x >= 4" $ do - let simpleSystem = - [ Expr (VarTerm 0) :>= 4 - , Expr (VarTerm 0) :>= 3 - ] - bounds = Map.fromList [(0, Bounds (Just 4) (Just 5))] - simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds - expectedSimpleSystem = [Expr (VarTerm 0) :>= 4] - simplifiedSimpleSystem `shouldBe` expectedSimpleSystem - it "removeUselessSystemBounds does not remove x >= 4 when bounds say x >= 4" $ do - let simpleSystem = - [ Expr (VarTerm 0) :>= 4 - ] - bounds = Map.fromList [(0, Bounds (Just 4) (Just 5))] - simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds - expectedSimpleSystem = [Expr (VarTerm 0) :>= 4] - simplifiedSimpleSystem `shouldBe` expectedSimpleSystem - it "removeUselessSystemBounds does not remove 0 <= x <= 2 when bounds say 0 <= x <= 2" $ do - let simpleSystem = - [ Expr (VarTerm 0) :>= 0 - , Expr (VarTerm 0) :<= 2 - ] - bounds = Map.fromList [(0, Bounds (Just 0) (Just 2))] - simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds - expectedSimpleSystem = [Expr (VarTerm 0) :>= 0, Expr (VarTerm 0) :<= 2] - simplifiedSimpleSystem `shouldBe` expectedSimpleSystem - it "removeUselessSystemBounds removes upper bound of 0 <= x <= 2 when bounds say 0 <= x <= 1" $ do - let simpleSystem = - [ Expr (VarTerm 0) :>= 0 - , Expr (VarTerm 0) :<= 2 - ] - bounds = Map.fromList [(0, Bounds (Just 0) (Just 1))] - simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds - expectedSimpleSystem = [Expr (VarTerm 0) :>= 0] - simplifiedSimpleSystem `shouldBe` expectedSimpleSystem - it "removeUselessSystemBounds removes lower bound of 0 <= x <= 2 when bounds say 1 <= x <= 2" $ do - let simpleSystem = - [ Expr (VarTerm 0) :>= 0 - , Expr (VarTerm 0) :<= 2 - ] - bounds = Map.fromList [(0, Bounds (Just 1) (Just 2))] - simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds - expectedSimpleSystem = [Expr (VarTerm 0) :<= 2] - simplifiedSimpleSystem `shouldBe` expectedSimpleSystem - it "removeUselssSystemBounds only removes constraints of the form x <= c" $ do - let simpleSystem = - [ Expr (VarTerm 0) :<= 2 - , Expr (VarTerm 0) :<= 3 - , Expr (CoeffTerm 2 0) :<= 6 - ] - bounds = Map.fromList [(0, Bounds (Just 0) (Just 2))] - simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds - expectedSimpleSystem = [Expr (VarTerm 0) :<= 2, Expr (CoeffTerm 2 0) :<= 6] - simplifiedSimpleSystem `shouldBe` expectedSimpleSystem diff --git a/test/Linear/SlackForm/UtilSpec.hs b/test/Linear/SlackForm/UtilSpec.hs new file mode 100644 index 0000000..82295d9 --- /dev/null +++ b/test/Linear/SlackForm/UtilSpec.hs @@ -0,0 +1,380 @@ +module Linear.SlackForm.UtilSpec where + +import Control.Monad (forM) +import Data.Functor ((<&>)) +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import qualified Data.Set as Set +import qualified Debug.Trace as T +import Linear.Constraint.Generic.Types + ( GenericConstraint ((:<=), (:==), (:>=)) + , getGenericConstraintLHS + ) +import Linear.Expr.Types (Expr (..)) +import Linear.SlackForm.Util + ( addSlackVariables + , eliminateNonZeroLowerBounds + , eliminateUnrestrictedLowerBounds + ) +import Linear.System.Simple.Util (deriveBounds) +import Linear.Term.Types + ( Term (..) + ) +import Test.Hspec (Spec, describe, it, shouldBe) +import Test.QuickCheck (Testable (property), withMaxSuccess) + +-- data Term = ConstTerm SimplexNum | CoeffTerm SimplexNum Var | VarTerm Var -- Consider VarTerm Var - note, we must consider normalizing this: Considered. It makes going to standard form easier due to type safety +-- deriving (Show, Read, Eq, Ord, Generic) + +-- TODO: consider type NumberConstraint = GenericConstraint SimplexNum SimplexNum +spec :: Spec +spec = do + describe "Slack Form Transformations" $ do + it + "eliminateNonZeroLowerBounds does not do anything when all lower bounds are zero" + $ do + let simpleSystem = + [ Expr (VarTerm 0 :| []) :>= 0 + , Expr (VarTerm 1 :| []) :>= 0 + ] + (updatedBounds, updatedSystem) = eliminateNonZeroLowerBounds simpleSystem Map.empty + expectedSimpleSystem = + [ Expr (VarTerm 0 :| []) :>= 0 + , Expr (VarTerm 1 :| []) :>= 0 + ] + expectedEliminatedVarExprMap = Map.empty + updatedSystem `shouldBe` expectedSimpleSystem + updatedBounds `shouldBe` expectedEliminatedVarExprMap + it "eliminateNonZeroLowerBounds correctly eliminates positive lower bounds" $ do + let simpleSystem = + [ Expr (VarTerm 0 :| []) :>= 1 + , Expr (VarTerm 1 :| []) :>= 0 + ] + (updatedBounds, updatedSystem) = eliminateNonZeroLowerBounds simpleSystem Map.empty + expectedSimpleSystem = + [ Expr (VarTerm 2 :| []) :>= 0 + , Expr (VarTerm 1 :| []) :>= 0 + ] + expectedEliminatedVarExprMap = Map.fromList [(0, Expr (VarTerm 2 :| [ConstTerm 1]))] + updatedSystem `shouldBe` expectedSimpleSystem + updatedBounds `shouldBe` expectedEliminatedVarExprMap + it "eliminateNonZeroLowerBounds correctly eliminates negative lower bounds" $ do + let simpleSystem = + [ Expr (VarTerm 0 :| []) :>= (-1) + , Expr (VarTerm 1 :| []) :>= 0 + ] + (updatedBounds, updatedSystem) = eliminateNonZeroLowerBounds simpleSystem Map.empty + expectedSimpleSystem = + [ Expr (VarTerm 2 :| []) :>= 0 + , Expr (VarTerm 1 :| []) :>= 0 + ] + expectedEliminatedVarExprMap = Map.fromList [(0, Expr (VarTerm 2 :| [ConstTerm (-1)]))] + updatedSystem `shouldBe` expectedSimpleSystem + updatedBounds `shouldBe` expectedEliminatedVarExprMap + it + "eliminateNonZeroLowerBounds correctly eliminates positive and negative lower bounds" + $ do + let simpleSystem = + [ Expr (VarTerm 0 :| []) :>= 1 + , Expr (VarTerm 1 :| []) :>= (-1) + ] + (updatedBounds, updatedSystem) = eliminateNonZeroLowerBounds simpleSystem Map.empty + expectedSimpleSystem = + [ Expr (VarTerm 2 :| []) :>= 0 + , Expr (VarTerm 3 :| []) :>= 0 + ] + expectedEliminatedVarExprMap = + Map.fromList + [ (0, Expr (VarTerm 2 :| [ConstTerm 1])) + , (1, Expr (VarTerm 3 :| [ConstTerm (-1)])) + ] + updatedSystem `shouldBe` expectedSimpleSystem + updatedBounds `shouldBe` expectedEliminatedVarExprMap + it + "eliminateNonZeroLowerBounds correctly substitutes vars with non-zero lower bounds" + $ do + let simpleSystem = + [ Expr (VarTerm 0 :| []) :>= 1 + , Expr (VarTerm 1 :| []) :>= 0 + , Expr (VarTerm 0 :| [VarTerm 1]) :>= 1 + ] + (updatedBounds, updatedSystem) = eliminateNonZeroLowerBounds simpleSystem Map.empty + expectedSimpleSystem = + [ Expr (VarTerm 2 :| []) :>= 0 + , Expr (VarTerm 1 :| []) :>= 0 + , Expr (VarTerm 1 :| [VarTerm 2]) :>= 0 + ] + expectedEliminatedVarExprMap = Map.fromList [(0, Expr (VarTerm 2 :| [ConstTerm 1]))] + updatedSystem `shouldBe` expectedSimpleSystem + updatedBounds `shouldBe` expectedEliminatedVarExprMap + it "eliminateNonZeroLowerBounds property based test lower bounds" $ do + withMaxSuccess 5 $ property $ \simpleSystem -> do + let (updatedBounds, updatedSystem) = eliminateNonZeroLowerBounds simpleSystem Map.empty + all + ( \case + Expr (VarTerm _ :| []) :>= num -> num == 0 + _ -> True + ) + updatedSystem + it "eliminateNonZeroLowerBounds property based test map" $ do + withMaxSuccess 5 $ property $ \simpleSystem -> do + let (updatedBounds, updatedSystem) = eliminateNonZeroLowerBounds simpleSystem Map.empty + all + ( \(var, _) -> + any + ( \constraint -> + let getVars _a = [] + lhs = getGenericConstraintLHS constraint + allVars = getVars lhs + in var `notElem` allVars + ) + updatedSystem + ) + (Map.toList updatedBounds) + it + "addSlackVariables correctly transforms inequalities to equalities (wikipedia case)" + $ do + let simpleSystem = + [ Expr (VarTerm 2 :| [CoeffTerm 2 3]) :<= 3 -- x_2 + 2x_3 <= 3 + , Expr (CoeffTerm (-1) 4 :| [CoeffTerm 3 5]) :>= 2 -- -x_4 + 3x_5 >= 2 + ] + expectedSystem = + [ Expr (VarTerm 2 :| [CoeffTerm 2 3, VarTerm 6]) :== 3 -- x_2 + 2x_3 + x_6 = 3 + , Expr (VarTerm 6 :| []) :>= 0 -- x_6 >= 0 + , Expr (CoeffTerm (-1) 4 :| [CoeffTerm 3 5, CoeffTerm (-1) 7]) :== 2 -- -x_4 + 3x_5 + x_7 = 2 + , Expr (VarTerm 7 :| []) :>= 0 -- x_7 >= 0 + ] + expectedSlackVars = [6, 7] + (slackVars, updatedSystem) = addSlackVariables simpleSystem + updatedSystem `shouldBe` expectedSystem + slackVars `shouldBe` expectedSlackVars + it + "addSlackVariables correctly transforms inequalities to equalities (test case 1)" + $ do + let simpleSystem = + [ Expr (VarTerm 1 :| [CoeffTerm 2 2]) :<= 4 -- x_1 + 2x_2 <= 4 + , Expr (CoeffTerm (-1) 3 :| [CoeffTerm 2 4]) :>= 3 -- -x_3 + 2x_4 >= 3 + ] + expectedSystem = + [ Expr (VarTerm 1 :| [CoeffTerm 2 2, VarTerm 5]) :== 4 -- x_1 + 2x_2 + x_5 = 4 + , Expr (VarTerm 5 :| []) :>= 0 -- x_5 >= 0 + , Expr (CoeffTerm (-1) 3 :| [CoeffTerm 2 4, CoeffTerm (-1) 6]) :== 3 -- -x_3 + 2x_4 - x_6 = 3 + , Expr (VarTerm 6 :| []) :>= 0 -- x_6 >= 0 + ] + expectedSlackVars = [5, 6] + (slackVars, updatedSystem) = addSlackVariables simpleSystem + updatedSystem `shouldBe` expectedSystem + slackVars `shouldBe` expectedSlackVars + it + "addSlackVariables correctly transforms inequalities to equalities (test case 2)" + $ do + let simpleSystem = + [ Expr (VarTerm 1 :| [CoeffTerm 2 2]) :<= 5 -- x_1 + 2x_2 <= 5 + , Expr (CoeffTerm (-1) 3 :| [CoeffTerm 2 4]) :>= 4 -- -x_3 + 2x_4 >= 4 + ] + expectedSystem = + [ Expr (VarTerm 1 :| [CoeffTerm 2 2, VarTerm 5]) :== 5 -- x_1 + 2x_2 + x_5 = 5 + , Expr (VarTerm 5 :| []) :>= 0 -- x_5 >= 0 + , Expr (CoeffTerm (-1) 3 :| [CoeffTerm 2 4, CoeffTerm (-1) 6]) :== 4 -- -x_3 + 2x_4 - x_6 = 4 + , Expr (VarTerm 6 :| []) :>= 0 -- x_6 >= 0 + ] + expectedSlackVars = [5, 6] + (slackVars, updatedSystem) = addSlackVariables simpleSystem + updatedSystem `shouldBe` expectedSystem + slackVars `shouldBe` expectedSlackVars + it + "addSlackVariables correctly transforms inequalities to equalities (test case 3)" + $ do + let simpleSystem = + [ Expr (VarTerm 1 :| [CoeffTerm 2 2]) :<= 5 -- x_1 + 2x_2 <= 5 + , Expr (CoeffTerm (-1) 3 :| [CoeffTerm 2 4]) :== 4 -- -x_3 + 2x_4 = 4 + ] + expectedSystem = + [ Expr (VarTerm 1 :| [CoeffTerm 2 2, VarTerm 5]) :== 5 -- x_1 + 2x_2 + x_5 = 5 + , Expr (VarTerm 5 :| []) :>= 0 -- x_5 >= 0 + , Expr (CoeffTerm (-1) 3 :| [CoeffTerm 2 4]) :== 4 -- -x_3 + 2x_4 = 4 + ] + expectedSlackVars = [5] + (slackVars, updatedSystem) = addSlackVariables simpleSystem + updatedSystem `shouldBe` expectedSystem + slackVars `shouldBe` expectedSlackVars + it + "addSlackVariables correctly transforms inequalities to equalities (test case 4)" + $ do + let simpleSystem = + [ Expr (VarTerm 1 :| [CoeffTerm 2 2]) :== 5 -- x_1 + 2x_2 = 5 + , Expr (CoeffTerm (-1) 3 :| [CoeffTerm 2 4]) :== 4 -- -x_3 + 2x_4 = 4 + ] + expectedSystem = + [ Expr (VarTerm 1 :| [CoeffTerm 2 2]) :== 5 -- x_1 + 2x_2 = 5 + , Expr (CoeffTerm (-1) 3 :| [CoeffTerm 2 4]) :== 4 -- -x_3 + 2x_4 = 4 + ] + expectedSlackVars = [] + (slackVars, updatedSystem) = addSlackVariables simpleSystem + updatedSystem `shouldBe` expectedSystem + slackVars `shouldBe` expectedSlackVars + it + "eliminateUnrestrictedLowerBounds correctly eliminates unrestricted lower bounds (wikipedia case)" + $ do + let simpleSystem = + [ Expr (VarTerm 1 :| []) :>= 0 -- x_1 >= 0 + , Expr (VarTerm 1 :| [VarTerm 2]) :>= 0 -- x_1 + x_2 >= 0 + ] + systemBounds = deriveBounds simpleSystem + (eliminatedNonZeroLowerBounds, systemWithoutNonZeroLowerBounds) = eliminateNonZeroLowerBounds simpleSystem Map.empty + (slackVars, systemWithSlackVars) = addSlackVariables systemWithoutNonZeroLowerBounds + (updatedEliminatedVarsMap, updatedSystem) = + eliminateUnrestrictedLowerBounds + systemWithSlackVars + systemBounds + eliminatedNonZeroLowerBounds + expectedSystem = + [ Expr (VarTerm 5 :| []) :>= 0 -- x_5 >= 0 + , Expr (VarTerm 6 :| []) :>= 0 -- x_6 >= 0 + , Expr (CoeffTerm (-1) 3 :| [VarTerm 1]) :== 0 -- -x_3 + x_1 = 0 + , Expr (VarTerm 3 :| []) :>= 0 -- x_3 >= 0 + , Expr (CoeffTerm (-1) 4 :| [CoeffTerm (-1) 6, VarTerm 1, VarTerm 5]) :== 0 -- -x_4 - x_6 + x_1 + x_5 = 0 + , Expr (VarTerm 4 :| []) :>= 0 -- x_4 >= 0 + ] + expectedEliminatedVarExprMap = Map.fromList [(2, Expr (VarTerm 5 :| [CoeffTerm (-1) 6]))] + + updatedSystem `shouldBe` expectedSystem + updatedEliminatedVarsMap `shouldBe` expectedEliminatedVarExprMap + it + "eliminateUnrestrictedLowerBounds correctly eliminates unrestricted lower bounds (test case 2)" + $ do + let simpleSystem = + [ Expr (VarTerm 1 :| []) :>= 0 -- x_1 >= 0 + , Expr (VarTerm 1 :| [VarTerm 2, VarTerm 3]) :>= 0 -- x_1 + x_2 + x_3 >= 0 + ] + systemBounds = deriveBounds simpleSystem + (eliminatedNonZeroLowerBounds, systemWithoutNonZeroLowerBounds) = eliminateNonZeroLowerBounds simpleSystem Map.empty + (slackVars, systemWithSlackVars) = addSlackVariables systemWithoutNonZeroLowerBounds + (updatedEliminatedVarsMap, updatedSystem) = + eliminateUnrestrictedLowerBounds + systemWithSlackVars + systemBounds + eliminatedNonZeroLowerBounds + expectedSystem = + [ Expr (VarTerm 8 :| []) :>= 0 -- x_8 >= 0 + , Expr (VarTerm 9 :| []) :>= 0 -- x_9 >= 0 + , Expr (VarTerm 6 :| []) :>= 0 -- x_6 >= 0 + , Expr (VarTerm 7 :| []) :>= 0 -- x_7 >= 0 + , Expr (CoeffTerm (-1) 4 :| [VarTerm 1]) :== 0 -- -x_4 + x_1 = 0 + , Expr (VarTerm 4 :| []) :>= 0 -- x_4 >= 0 + , Expr + ( CoeffTerm (-1) 5 + :| [CoeffTerm (-1) 7, CoeffTerm (-1) 9, VarTerm 1, VarTerm 6, VarTerm 8] + ) + :== 0 -- -x_5 - x_7 - x_9 + x_1 + x_6 + x_8 = 0 + , Expr (VarTerm 5 :| []) :>= 0 -- x_5 >= 0 + ] + expectedEliminatedVarExprMap = + Map.fromList + [ (2, Expr (VarTerm 6 :| [CoeffTerm (-1) 7])) + , (3, Expr (VarTerm 8 :| [CoeffTerm (-1) 9])) + ] + updatedSystem `shouldBe` expectedSystem + updatedEliminatedVarsMap `shouldBe` expectedEliminatedVarExprMap + + it + "eliminateUnrestrictedLowerBounds correctly eliminates unrestricted lower bounds (test case 3)" + $ do + let simpleSystem = + [ Expr (VarTerm 1 :| []) :>= 0 -- x_1 >= 0 + , Expr (VarTerm 1 :| [VarTerm 2]) :>= 0 -- x_1 + x_2 >= 0 + , Expr (VarTerm 2 :| [VarTerm 3]) :>= 0 -- x_2 + x_3 >= 0 + ] + systemBounds = deriveBounds simpleSystem + (eliminatedNonZeroLowerBounds, systemWithoutNonZeroLowerBounds) = eliminateNonZeroLowerBounds simpleSystem Map.empty + (slackVars, systemWithSlackVars) = addSlackVariables systemWithoutNonZeroLowerBounds + (updatedEliminatedVarsMap, updatedSystem) = + eliminateUnrestrictedLowerBounds + systemWithSlackVars + systemBounds + eliminatedNonZeroLowerBounds + expectedSystem = + [ Expr (VarTerm 9 :| []) :>= 0 -- x_9 >= 0 + , Expr (VarTerm 10 :| []) :>= 0 -- x_10 >= 0 + , Expr (VarTerm 7 :| []) :>= 0 -- x_7 >= 0 + , Expr (VarTerm 8 :| []) :>= 0 -- x_8 >= 0 + , Expr (CoeffTerm (-1) 4 :| [VarTerm 1]) :== 0 -- -x_4 + x_1 = 0 + , Expr (VarTerm 4 :| []) :>= 0 -- x_4 >= 0 + , Expr (CoeffTerm (-1) 5 :| [CoeffTerm (-1) 8, VarTerm 1, VarTerm 7]) :== 0 -- -x_5 - x_8 + x_1 + x_7 = 0 + , Expr (VarTerm 5 :| []) :>= 0 -- x_5 >= 0 + , Expr + ( CoeffTerm (-1) 6 :| [CoeffTerm (-1) 8, CoeffTerm (-1) 10, VarTerm 7, VarTerm 9] + ) + :== 0 -- -x_6 - x_8 - x_10 + x_7 + x_9 = 0 + , Expr (VarTerm 6 :| []) :>= 0 -- x_6 >= 0 + ] + expectedEliminatedVarExprMap = + Map.fromList + [ (2, Expr (VarTerm 7 :| [CoeffTerm (-1) 8])) + , (3, Expr (VarTerm 9 :| [CoeffTerm (-1) 10])) + ] + updatedSystem `shouldBe` expectedSystem + updatedEliminatedVarsMap `shouldBe` expectedEliminatedVarExprMap + it + "eliminateUnrestrictedLowerBounds correctly eliminates non-zero lower bounds for all variables" + $ do + let simpleSystem = + [ Expr (VarTerm 1 :| [CoeffTerm 2 1]) :>= 0 -- x_1 + 2 >= 0 + , Expr (VarTerm 2 :| [CoeffTerm 3 1]) :>= 0 -- x_2 + 3 >= 0 + ] + systemBounds = deriveBounds simpleSystem + (eliminatedNonZeroLowerBounds, systemWithoutNonZeroLowerBounds) = eliminateNonZeroLowerBounds simpleSystem Map.empty + (slackVars, systemWithSlackVars) = addSlackVariables systemWithoutNonZeroLowerBounds + (updatedEliminatedVarsMap, updatedSystem) = + eliminateUnrestrictedLowerBounds + systemWithSlackVars + systemBounds + eliminatedNonZeroLowerBounds + expectedSystem = + [ Expr (VarTerm 7 :| []) :>= 0 -- x_7 >= 0 + , Expr (VarTerm 8 :| []) :>= 0 -- x_8 >= 0 + , Expr (VarTerm 5 :| []) :>= 0 -- x_5 >= 0 + , Expr (VarTerm 6 :| []) :>= 0 -- x_6 >= 0 + , Expr (CoeffTerm (-3) 6 :| [CoeffTerm (-1) 3, CoeffTerm 3 5]) :== 0 -- -3x_6 - x_3 + 3x_5 = 0 + , Expr (VarTerm 3 :| []) :>= 0 -- x_3 >= 0 + , Expr + ( CoeffTerm (-3) 6 + :| [CoeffTerm (-1) 4, CoeffTerm (-1) 8, CoeffTerm 3 5, VarTerm 7] + ) + :== 0 -- -3x_6 - x_4 - x_8 + 3x_5 + x_7 = 0 + , Expr (VarTerm 4 :| []) :>= 0 -- x_4 >= 0 + ] + expectedEliminatedVarExprMap = + Map.fromList + [ (1, Expr (VarTerm 5 :| [CoeffTerm (-1) 6])) + , (2, Expr (VarTerm 7 :| [CoeffTerm (-1) 8])) + ] + updatedSystem `shouldBe` expectedSystem + updatedEliminatedVarsMap `shouldBe` expectedEliminatedVarExprMap + + it + "eliminateUnrestrictedLowerBounds correctly handles all variables with zero lower bounds" + $ do + let simpleSystem = + [ Expr (VarTerm 1 :| []) :>= 0 -- x_1 >= 0 + , Expr (VarTerm 2 :| []) :>= 0 -- x_2 >= 0 + ] + systemBounds = deriveBounds simpleSystem + (eliminatedNonZeroLowerBounds, systemWithoutNonZeroLowerBounds) = eliminateNonZeroLowerBounds simpleSystem Map.empty + (slackVars, systemWithSlackVars) = addSlackVariables systemWithoutNonZeroLowerBounds + (updatedEliminatedVarsMap, updatedSystem) = + eliminateUnrestrictedLowerBounds + systemWithSlackVars + systemBounds + eliminatedNonZeroLowerBounds + expectedSystem = + [ (Expr (VarTerm 1 :| [CoeffTerm (-1) 3])) :== 0 -- x_1 - x_3 = 0 + , Expr (VarTerm 3 :| []) :>= 0 -- x_3 >= 0 + , (Expr (VarTerm 2 :| [CoeffTerm (-1) 4])) :== 0 -- x_2 - x_4 = 0 + , Expr (VarTerm 4 :| []) :>= 0 -- x_4 >= 0 + ] + expectedEliminatedVarExprMap = Map.empty + updatedSystem `shouldBe` expectedSystem + updatedEliminatedVarsMap `shouldBe` expectedEliminatedVarExprMap diff --git a/test/Linear/System/Simple/UtilSpec.hs b/test/Linear/System/Simple/UtilSpec.hs new file mode 100644 index 0000000..62ba132 --- /dev/null +++ b/test/Linear/System/Simple/UtilSpec.hs @@ -0,0 +1,256 @@ +-- | +-- Module: Linear.System.Simple.TypesSpec +-- Description: Tests for Linear.System.Simple.Types +-- Copyright: (c) Junaid Rasheed, 2020-2024 +-- License: BSD-3 +-- Maintainer: Junaid Rasheed =)) + ) +import Linear.Expr.Types (Expr (Expr)) +import Linear.System.Simple.Types + ( findHighestVar + , simpleSystemVars + , simplifySimpleSystem + ) +import Linear.System.Simple.Util + ( deriveBounds + , removeUselessSystemBounds + ) +import Linear.Term.Types (Term (..)) +import Linear.Var.Types (Bounds (..)) +import Linear.Var.Util (validateBounds) +import Test.Hspec (Spec, describe, it, shouldBe) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (counterexample) +import TestUtil (evalSimpleSystem, genVarMap) + +spec :: Spec +spec = do + describe "SimpleSystem" $ do + prop "simplifySimpleSystem leads to the same evaluation" $ \simpleSystem -> do + let vars = Set.toList $ simpleSystemVars simpleSystem + varMap <- genVarMap vars + let simplifiedSimpleSystem = simplifySimpleSystem simpleSystem + simpleSystemEval = evalSimpleSystem varMap simpleSystem + simplifiedSimpleSystemEval = evalSimpleSystem varMap simplifiedSimpleSystem + pure + $ counterexample + ( "simpleSystem: " + <> show simpleSystem + <> "\nsimplifiedSimpleSystem: " + <> show simplifiedSimpleSystem + <> "\ninitialVarMap: " + <> show varMap + <> "\nsimpleSystemEval: " + <> show simpleSystemEval + <> "\nsimplifiedSimpleSystemEval: " + <> show simplifiedSimpleSystemEval + ) + $ simpleSystemEval == simplifiedSimpleSystemEval + it "findHighestVar finds the highest variable in a simple system" $ do + let simpleSystem1 = + [ Expr (VarTerm 0 :| []) :>= 0 + , Expr (VarTerm 0 :| []) :<= 1 + , Expr (VarTerm 1 :| []) :>= 0 + , Expr (VarTerm 1 :| []) :<= 1 + ] + simpleSystem100 = + [ Expr (VarTerm 0 :| []) :<= 1 + , Expr (VarTerm 50 :| []) :<= 1 + , Expr (VarTerm 100 :| []) :<= 1 + ] + simpleSystem10 = + [ Expr (VarTerm (-10) :| []) :<= 1 + , Expr (VarTerm 0 :| []) :<= 1 + , Expr (VarTerm 10 :| []) :<= 1 + ] + simpleSystemMinus10 = + [ Expr (VarTerm (-10) :| []) :<= 1 + , Expr (VarTerm (-20) :| []) :<= 1 + ] + + findHighestVar simpleSystem1 `shouldBe` 1 + findHighestVar simpleSystem100 `shouldBe` 100 + findHighestVar simpleSystem10 `shouldBe` 10 + findHighestVar simpleSystemMinus10 `shouldBe` (-10) + describe "Bounds" $ do + it + "validateBounds finds that deriving bounds for a system where -1 <= x <= 1 has valid bounds" + $ do + let simpleSystem = + [ Expr (VarTerm 0 :| []) :>= (-1) + , Expr (VarTerm 0 :| []) :<= 1 + ] + derivedBounds = deriveBounds simpleSystem + expectedBounds = Map.fromList [(0, Bounds (Just (-1)) (Just 1))] + derivedBounds `shouldBe` expectedBounds + validateBounds derivedBounds `shouldBe` True + it + "validateBounds finds that deriving bounds for a system where 0 <= x <= 1 has valid bounds" + $ do + let simpleSystem = + [ Expr (VarTerm 0 :| []) :>= 0 + , Expr (VarTerm 0 :| []) :<= 1 + ] + derivedBounds = deriveBounds simpleSystem + expectedBounds = Map.fromList [(0, Bounds (Just 0) (Just 1))] + derivedBounds `shouldBe` expectedBounds + validateBounds derivedBounds `shouldBe` True + it + "validateBounds finds that deriving bounds for a system where 1 <= x <= 1 has valid bounds" + $ do + let simpleSystem = + [ Expr (VarTerm 0 :| []) :>= 1 + , Expr (VarTerm 0 :| []) :<= 1 + ] + derivedBounds = deriveBounds simpleSystem + expectedBounds = Map.fromList [(0, Bounds (Just 1) (Just 1))] + derivedBounds `shouldBe` expectedBounds + validateBounds derivedBounds `shouldBe` True + it + "validateBounds finds that deriving bounds for a system where 1 <= x <= 0 has invalid bounds" + $ do + let simpleSystem = + [ Expr (VarTerm 0 :| []) :>= 1 + , Expr (VarTerm 0 :| []) :<= 0 + ] + derivedBounds = deriveBounds simpleSystem + expectedBounds = Map.fromList [(0, Bounds (Just 1) (Just 0))] + derivedBounds `shouldBe` expectedBounds + validateBounds derivedBounds `shouldBe` False + it + "validateBounds finds that deriving bounds for a system where 0 <= x <= 1 and 1 <= y <= 3 has valid bounds" + $ do + let simpleSystem = + [ Expr (VarTerm 0 :| []) :>= 0 + , Expr (VarTerm 0 :| []) :<= 1 + , Expr (VarTerm 1 :| []) :>= 1 + , Expr (VarTerm 1 :| []) :<= 3 + ] + derivedBounds = deriveBounds simpleSystem + expectedBounds = Map.fromList [(0, Bounds (Just 0) (Just 1)), (1, Bounds (Just 1) (Just 3))] + derivedBounds `shouldBe` expectedBounds + validateBounds derivedBounds `shouldBe` True + it + "validateBounds finds that deriving bounds for a system where 1 <= x <= 0 and 3 <= y <= 1 has invalid bounds" + $ do + let simpleSystem = + [ Expr (VarTerm 0 :| []) :>= 1 + , Expr (VarTerm 0 :| []) :<= 0 + , Expr (VarTerm 1 :| []) :>= 3 + , Expr (VarTerm 1 :| []) :<= 1 + ] + derivedBounds = deriveBounds simpleSystem + expectedBounds = Map.fromList [(0, Bounds (Just 1) (Just 0)), (1, Bounds (Just 3) (Just 1))] + derivedBounds `shouldBe` expectedBounds + validateBounds derivedBounds `shouldBe` False + it + "validateBounds finds that deriving bounds for a system where 1 <= x <= 0 and 1 <= y <= 3 has invalid bounds" + $ do + let simpleSystem = + [ Expr (VarTerm 0 :| []) :>= 1 + , Expr (VarTerm 0 :| []) :<= 0 + , Expr (VarTerm 1 :| []) :>= 1 + , Expr (VarTerm 1 :| []) :<= 3 + ] + derivedBounds = deriveBounds simpleSystem + expectedBounds = Map.fromList [(0, Bounds (Just 1) (Just 0)), (1, Bounds (Just 1) (Just 3))] + derivedBounds `shouldBe` expectedBounds + validateBounds derivedBounds `shouldBe` False + it + "validateBounds finds that deriving bounds for a system where 0 <= x <= 1 and 3 <= y <= 1 has invalid bounds" + $ do + let simpleSystem = + [ Expr (VarTerm 0 :| []) :>= 0 + , Expr (VarTerm 0 :| []) :<= 1 + , Expr (VarTerm 1 :| []) :>= 3 + , Expr (VarTerm 1 :| []) :<= 1 + ] + derivedBounds = deriveBounds simpleSystem + expectedBounds = Map.fromList [(0, Bounds (Just 0) (Just 1)), (1, Bounds (Just 3) (Just 1))] + derivedBounds `shouldBe` expectedBounds + validateBounds derivedBounds `shouldBe` False + it "removeUselessSystemBounds removes x <= 3 when bounds say x <= 2" $ do + let simpleSystem = + [ Expr (VarTerm 0 :| []) :<= 2 + , Expr (VarTerm 0 :| []) :<= 3 + ] + bounds = Map.fromList [(0, Bounds (Just 0) (Just 2))] + simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds + expectedSimpleSystem = [Expr (VarTerm 0 :| []) :<= 2] + simplifiedSimpleSystem `shouldBe` expectedSimpleSystem + it "removeUselessSystemBounds does not remove x <= 2 when bounds say x <= 2" $ do + let simpleSystem = + [ Expr (VarTerm 0 :| []) :<= 2 + ] + bounds = Map.fromList [(0, Bounds (Just 0) (Just 2))] + simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds + expectedSimpleSystem = [Expr (VarTerm 0 :| []) :<= 2] + simplifiedSimpleSystem `shouldBe` expectedSimpleSystem + it "removeUselessSystemBounds removes x >= 3 when bounds say x >= 4" $ do + let simpleSystem = + [ Expr (VarTerm 0 :| []) :>= 4 + , Expr (VarTerm 0 :| []) :>= 3 + ] + bounds = Map.fromList [(0, Bounds (Just 4) (Just 5))] + simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds + expectedSimpleSystem = [Expr (VarTerm 0 :| []) :>= 4] + simplifiedSimpleSystem `shouldBe` expectedSimpleSystem + it "removeUselessSystemBounds does not remove x >= 4 when bounds say x >= 4" $ do + let simpleSystem = + [ Expr (VarTerm 0 :| []) :>= 4 + ] + bounds = Map.fromList [(0, Bounds (Just 4) (Just 5))] + simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds + expectedSimpleSystem = [Expr (VarTerm 0 :| []) :>= 4] + simplifiedSimpleSystem `shouldBe` expectedSimpleSystem + it + "removeUselessSystemBounds does not remove 0 <= x <= 2 when bounds say 0 <= x <= 2" + $ do + let simpleSystem = + [ Expr (VarTerm 0 :| []) :>= 0 + , Expr (VarTerm 0 :| []) :<= 2 + ] + bounds = Map.fromList [(0, Bounds (Just 0) (Just 2))] + simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds + expectedSimpleSystem = [Expr (VarTerm 0 :| []) :>= 0, Expr (VarTerm 0 :| []) :<= 2] + simplifiedSimpleSystem `shouldBe` expectedSimpleSystem + it + "removeUselessSystemBounds removes upper bound of 0 <= x <= 2 when bounds say 0 <= x <= 1" + $ do + let simpleSystem = + [ Expr (VarTerm 0 :| []) :>= 0 + , Expr (VarTerm 0 :| []) :<= 2 + ] + bounds = Map.fromList [(0, Bounds (Just 0) (Just 1))] + simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds + expectedSimpleSystem = [Expr (VarTerm 0 :| []) :>= 0] + simplifiedSimpleSystem `shouldBe` expectedSimpleSystem + it + "removeUselessSystemBounds removes lower bound of 0 <= x <= 2 when bounds say 1 <= x <= 2" + $ do + let simpleSystem = + [ Expr (VarTerm 0 :| []) :>= 0 + , Expr (VarTerm 0 :| []) :<= 2 + ] + bounds = Map.fromList [(0, Bounds (Just 1) (Just 2))] + simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds + expectedSimpleSystem = [Expr (VarTerm 0 :| []) :<= 2] + simplifiedSimpleSystem `shouldBe` expectedSimpleSystem + it "removeUselssSystemBounds only removes constraints of the form x <= c" $ do + let simpleSystem = + [ Expr (VarTerm 0 :| []) :<= 2 + , Expr (VarTerm 0 :| []) :<= 3 + , Expr (CoeffTerm 2 0 :| []) :<= 6 + ] + bounds = Map.fromList [(0, Bounds (Just 0) (Just 2))] + simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds + expectedSimpleSystem = [Expr (VarTerm 0 :| []) :<= 2, Expr (CoeffTerm 2 0 :| []) :<= 6] + simplifiedSimpleSystem `shouldBe` expectedSimpleSystem diff --git a/test/Linear/Term/UtilSpec.hs b/test/Linear/Term/UtilSpec.hs new file mode 100644 index 0000000..c92f6b5 --- /dev/null +++ b/test/Linear/Term/UtilSpec.hs @@ -0,0 +1,133 @@ +-- | +-- Module: Linear.Term.TypesSpec +-- Description: Tests for Linear.Term.Types +-- Copyright: (c) Junaid Rasheed, 2020-2024 +-- License: BSD-3 +-- Maintainer: Junaid Rasheed +-- Stability: experimental +module Linear.Term.UtilSpec where + +import qualified Data.Either as Either +import qualified Data.List as List +import qualified Data.Map as Map +import Linear.Term.Types + ( Term (..) + , TermVarsOnly (..) + ) +import Linear.Term.Util + ( isConstTerm + , negateTerm + , normalizeTerms + , simplifyTerm + , termToTermVarsOnly + , termVar + , unsafeTermToTermVarsOnly + , zeroConstTerm + ) +import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (counterexample) +import TestUtil (evalTerm, genVarMap) +import Prelude + +spec :: Spec +spec = do + describe "Term" $ do + prop "simplifying leads to same evaluation" $ \term -> do + varMap <- maybe (pure Map.empty) (genVarMap . List.singleton) $ termVar term + let simplifiedTerm = simplifyTerm term + termEval = evalTerm varMap term + simplifiedTermEval = evalTerm varMap simplifiedTerm + pure + $ counterexample + ( "term: " + <> show term + <> "simplifiedTerm: " + <> show simplifiedTerm + <> "\nvarMap: " + <> show varMap + <> "\ntermEval: " + <> show termEval + <> "\nsimplifiedTermEval: " + <> show simplifiedTermEval + ) + $ evalTerm varMap (simplifyTerm term) == evalTerm varMap term + prop "simplifyTerm is idempotent" $ \term -> do + let simplifiedTerm = simplifyTerm term + simplifiedTwiceTerm = simplifyTerm simplifiedTerm + counterexample + ( "term: " + <> show term + <> "\nsimplifiedTerm: " + <> show simplifiedTerm + <> "\nsimplifiedTwiceTerm: " + <> show simplifiedTwiceTerm + ) + $ simplifiedTwiceTerm == simplifiedTerm + prop "negating and evaluating is the same as negating the evaluation" $ \term -> do + varMap <- maybe (pure $ Map.empty) (genVarMap . List.singleton) $ termVar term + let negatedTerm = negateTerm term + termEval = evalTerm varMap term + negatedTermEval = evalTerm varMap negatedTerm + pure + $ counterexample + ( "term: " + <> show term + <> "\nnegatedTerm: " + <> show negatedTerm + <> "\nvarMap: " + <> show varMap + <> "\ntermEval: " + <> show termEval + <> "\nnegatedTermEval: " + <> show negatedTermEval + ) + $ negate termEval == negatedTermEval + prop "negating twice is the same as not negating" $ \term -> do + let simplifiedTerm = simplifyTerm term + negatedTwiceSimpleTerm = negateTerm (negateTerm simplifiedTerm) + counterexample + ( "term: " + <> show term + <> "\nsimplifiedTerm: " + <> show simplifiedTerm + <> "\nnegatedTwiceSimpleTerm: " + <> show negatedTwiceSimpleTerm + ) + $ negatedTwiceSimpleTerm == simplifiedTerm + prop "zeroConstTerm correctly zeroes constant terms" $ \term -> do + let termZeroedConsts = zeroConstTerm term + counterexample + ( "term: " + <> show term + <> "\ntermZeroedConsts: " + <> show termZeroedConsts + ) + $ case term of + ConstTerm _ -> termZeroedConsts == ConstTerm 0 + _ -> termZeroedConsts == term + it "isConstTerm correctly identifies constant terms" $ do + isConstTerm (ConstTerm 0) `shouldBe` True + isConstTerm (ConstTerm 1) `shouldBe` True + isConstTerm (CoeffTerm 1 1) `shouldBe` False + isConstTerm (VarTerm 1) `shouldBe` False + it "termToTermVarsOnly correctly converts terms to vars only" $ do + termToTermVarsOnly (ConstTerm 0) `shouldSatisfy` Either.isLeft + termToTermVarsOnly (ConstTerm 1) `shouldSatisfy` Either.isLeft + termToTermVarsOnly (CoeffTerm 1 1) `shouldBe` Right (CoeffTermVO 1 1) + termToTermVarsOnly (VarTerm 1) `shouldBe` Right (VarTermVO 1) + it "unsafeTermToTermVarsOnly correctly converts terms without vars" $ do + unsafeTermToTermVarsOnly (CoeffTerm 1 1) `shouldBe` (CoeffTermVO 1 1) + unsafeTermToTermVarsOnly (VarTerm 1) `shouldBe` (VarTermVO 1) + prop "normalizeTerms is idempotent" $ \terms -> do + let normalizedTerms = normalizeTerms terms + normalizedTwiceTerms = normalizeTerms normalizedTerms + counterexample + ( "terms: " + <> show terms + <> "\nnormalizedTerms: " + <> show normalizedTerms + <> "\nnormalizedTwiceTerms: " + <> show normalizedTwiceTerms + ) + $ normalizedTwiceTerms == normalizedTerms diff --git a/test/Linear/Var/UtilSpec.hs b/test/Linear/Var/UtilSpec.hs new file mode 100644 index 0000000..1f21f36 --- /dev/null +++ b/test/Linear/Var/UtilSpec.hs @@ -0,0 +1,21 @@ +module Linear.Var.UtilSpec where + +import qualified Data.Map as Map +import Linear.Var.Types (Bounds (..)) +import Linear.Var.Util (validateBounds) +import Test.Hspec (Spec, describe, it, shouldBe) + +spec :: Spec +spec = do + describe "Bounds" $ do + it "validateBounds returns true for valid bounds" $ do + validateBounds (Map.fromList [(1, Bounds (Just 1) (Just 2))]) `shouldBe` True + validateBounds (Map.fromList [(1, Bounds (Just 1.1) (Just 1.2))]) + `shouldBe` True + validateBounds (Map.fromList [(1, Bounds (Just 1) Nothing)]) `shouldBe` True + validateBounds (Map.fromList [(1, Bounds Nothing (Just 2))]) `shouldBe` True + validateBounds (Map.fromList [(1, Bounds Nothing Nothing)]) `shouldBe` True + it "validateBounds returns false for invalid bounds" $ do + validateBounds (Map.fromList [(1, Bounds (Just 2) (Just 1))]) `shouldBe` False + validateBounds (Map.fromList [(1, Bounds (Just 1.2) (Just 1.1))]) + `shouldBe` False diff --git a/test/Spec.hs b/test/Spec.hs index 52ef578..a824f8c 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1 +1 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} \ No newline at end of file +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/TestUtil.hs b/test/TestUtil.hs new file mode 100644 index 0000000..b2e5ddb --- /dev/null +++ b/test/TestUtil.hs @@ -0,0 +1,73 @@ +-- | +-- Module: TestUtil +-- Description: Utility functions for testing +-- Copyright: (c) Junaid Rasheed, 2020-2024 +-- License: BSD-3 +-- Maintainer: Junaid Rasheed +-- Stability: experimental +module TestUtil where + +import Control.Monad (forM) +import qualified Data.Map as Map +import Linear.Constraint.Generic.Types + ( GenericConstraint ((:<=), (:==), (:>=)) + ) +import Linear.Constraint.Simple.Types (SimpleConstraint) +import Linear.Constraint.Types + ( Constraint (..) + ) +import Linear.Expr.Types (Expr) +import Linear.Expr.Util (exprToList) +import Linear.Simplex.Types (VarLitMap) +import Linear.System.Simple.Types (SimpleSystem) +import Linear.Term.Types + ( Term (..) + ) +import Linear.Var.Types (SimplexNum, Var) +import Test.QuickCheck (Arbitrary (..), Gen) +import Prelude + +evalTerm :: VarLitMap -> Linear.Term.Types.Term -> SimplexNum +evalTerm _ (Linear.Term.Types.ConstTerm c) = c +evalTerm varMap (Linear.Term.Types.CoeffTerm c v) = + c + * Map.findWithDefault + (error $ "evalTerm: " <> show v <> " not found in varMap " <> show varMap) + v + varMap +evalTerm varMap (Linear.Term.Types.VarTerm v) = + Map.findWithDefault + (error $ "evalTerm: " <> show v <> " not found in varMap " <> show varMap) + v + varMap + +evalExpr :: VarLitMap -> Expr -> SimplexNum +evalExpr varMap expr = sum $ map (evalTerm varMap) $ exprToList expr + +evalConstraint :: VarLitMap -> Constraint -> Bool +evalConstraint varMap (lhs :<= rhs) = evalExpr varMap lhs <= evalExpr varMap rhs +evalConstraint varMap (lhs :>= rhs) = evalExpr varMap lhs >= evalExpr varMap rhs +evalConstraint varMap (lhs :== rhs) = evalExpr varMap lhs == evalExpr varMap rhs + +evalSimpleConstraint :: VarLitMap -> SimpleConstraint -> Bool +evalSimpleConstraint varMap (lhs :<= rhs) = evalExpr varMap lhs <= rhs +evalSimpleConstraint varMap (lhs :>= rhs) = evalExpr varMap lhs >= rhs +evalSimpleConstraint varMap (lhs :== rhs) = evalExpr varMap lhs == rhs + +evalSimpleSystem :: VarLitMap -> SimpleSystem -> Bool +evalSimpleSystem varMap = all (evalSimpleConstraint varMap) + +genVarMap :: [Var] -> Gen VarLitMap +genVarMap vars = do + varVals <- forM vars $ const arbitrary + pure $ Map.fromList $ zip vars varVals + +isConstExpr :: Expr -> Bool +isConstExpr expr = + let listExpr = exprToList expr + in all + ( \case + ConstTerm _ -> True + _ -> False + ) + listExpr From 73050bb799b5f68e6f58560569920e88c282f024 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 31 Aug 2024 17:15:16 +0100 Subject: [PATCH 41/47] use ExprVarsOnly for LinearSystem --- src/Linear/Constraint/Linear/Types.hs | 13 ++----------- 1 file changed, 2 insertions(+), 11 deletions(-) diff --git a/src/Linear/Constraint/Linear/Types.hs b/src/Linear/Constraint/Linear/Types.hs index afa4b9f..657153c 100644 --- a/src/Linear/Constraint/Linear/Types.hs +++ b/src/Linear/Constraint/Linear/Types.hs @@ -7,21 +7,12 @@ module Linear.Constraint.Linear.Types where import GHC.Generics (Generic) -import Linear.Expr.Types (Expr) +import Linear.Expr.Types (ExprVarsOnly) import Linear.Var.Types (SimplexNum) --- TODO: Expr -> ExprVarsOnly -- lhs == rhs data LinearEquation = LinearEquation - { lhs :: Expr + { lhs :: ExprVarsOnly , rhs :: SimplexNum } deriving (Show, Eq, Read, Generic) - --- class CanBeLinearEquation a where --- toLinearEquation :: a -> LinearEquation --- fromLinearEquation :: LinearEquation -> a - --- instance CanBeLinearEquation LinearEquation where --- toLinearEquation = id --- fromLinearEquation = id From dd7fe5a12c1fadffba11419b41dc500dec778033 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 31 Aug 2024 20:01:10 +0100 Subject: [PATCH 42/47] 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 --- simplex-method.cabal | 2 + src/Linear/Constraint/Linear/Util.hs | 29 +++ src/Linear/Constraint/Simple/Types.hs | 4 +- src/Linear/Constraint/Simple/Util.hs | 140 ++++++----- src/Linear/Expr/Types.hs | 14 +- src/Linear/Expr/Util.hs | 54 ++++- src/Linear/SlackForm/Util.hs | 88 ++++--- src/Linear/System/Simple/Types.hs | 11 +- src/Linear/System/Simple/Util.hs | 16 +- src/Linear/Term/Types.hs | 7 + src/Linear/Term/Util.hs | 9 +- test/Linear/Constraint/Simple/UtilSpec.hs | 40 +--- test/Linear/Expr/UtilSpec.hs | 5 +- test/Linear/SlackForm/UtilSpec.hs | 277 +++++++++++----------- test/Linear/System/Simple/UtilSpec.hs | 126 +++++----- test/TestUtil.hs | 18 +- 16 files changed, 472 insertions(+), 368 deletions(-) create mode 100644 src/Linear/Constraint/Linear/Util.hs diff --git a/simplex-method.cabal b/simplex-method.cabal index ad954f4..c82498e 100644 --- a/simplex-method.cabal +++ b/simplex-method.cabal @@ -29,6 +29,7 @@ library exposed-modules: Linear.Constraint.Generic.Types Linear.Constraint.Linear.Types + Linear.Constraint.Linear.Util Linear.Constraint.Simple.Types Linear.Constraint.Simple.Util Linear.Constraint.Types @@ -44,6 +45,7 @@ library Linear.SlackForm.Types Linear.SlackForm.Util Linear.System.Linear.Types + Linear.System.Linear.Util Linear.System.Simple.Types Linear.System.Simple.Util Linear.System.Types diff --git a/src/Linear/Constraint/Linear/Util.hs b/src/Linear/Constraint/Linear/Util.hs new file mode 100644 index 0000000..ed86f2d --- /dev/null +++ b/src/Linear/Constraint/Linear/Util.hs @@ -0,0 +1,29 @@ +-- | +-- Module: Linear.Constraint.Linear.Util +-- Description: Utility functions for linear constraints +-- Copyright: (c) Junaid Rasheed, 2024 +-- License: BSD-3 +-- Maintainer: Junaid Rasheed +-- Stability: experimental +module Linear.Constraint.Linear.Util where + +import qualified Data.Set as Set +import Linear.Constraint.Linear.Types (LinearEquation (..)) +import Linear.Expr.Types (ExprVarsOnly) +import Linear.Expr.Util + ( exprVarsOnlyMaxVar + , exprVarsOnlyVars + , substVarExprVarsOnly + ) +import Linear.Var.Types (Var) + +-- | Get the variables in a linear equation +linearEquationVars :: LinearEquation -> Set.Set Var +linearEquationVars (LinearEquation lhs _) = exprVarsOnlyVars lhs + +findHighestVar :: LinearEquation -> Var +findHighestVar (LinearEquation lhs _) = exprVarsOnlyMaxVar lhs + +substVarWith :: + Var -> ExprVarsOnly -> LinearEquation -> LinearEquation +substVarWith var expr (LinearEquation lhs rhs) = LinearEquation (substVarExprVarsOnly var expr lhs) rhs diff --git a/src/Linear/Constraint/Simple/Types.hs b/src/Linear/Constraint/Simple/Types.hs index aad774f..6ff8020 100644 --- a/src/Linear/Constraint/Simple/Types.hs +++ b/src/Linear/Constraint/Simple/Types.hs @@ -8,7 +8,7 @@ module Linear.Constraint.Simple.Types where import Linear.Constraint.Generic.Types (GenericConstraint) -import Linear.Expr.Types (Expr) +import Linear.Expr.Types (ExprVarsOnly) import Linear.Var.Types (SimplexNum) -type SimpleConstraint = GenericConstraint Expr SimplexNum +type SimpleConstraint = GenericConstraint ExprVarsOnly SimplexNum diff --git a/src/Linear/Constraint/Simple/Util.hs b/src/Linear/Constraint/Simple/Util.hs index 4670947..06699b1 100644 --- a/src/Linear/Constraint/Simple/Util.hs +++ b/src/Linear/Constraint/Simple/Util.hs @@ -8,32 +8,50 @@ module Linear.Constraint.Simple.Util where import qualified Data.List as L -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.List.NonEmpty as NE import qualified Data.Set as Set import Linear.Constraint.Generic.Types - ( GenericConstraint ((:<=), (:==), (:>=)) + ( GenericConstraint (..) ) import Linear.Constraint.Simple.Types (SimpleConstraint) import Linear.Constraint.Types (Constraint) -import Linear.Expr.Types (Expr (Expr)) +import Linear.Expr.Types (Expr (..), ExprVarsOnly (..)) import Linear.Expr.Util - ( exprToList + ( exprToExprVarsOnly + , exprToList , exprVars + , exprVarsOnlyToExpr , listToExpr , simplifyExpr + , simplifyExprVarsOnly , substVarExpr + , substVarExprVarsOnly , subtractExpr , sumExprConstTerms , zeroConstExpr ) -import Linear.Term.Types (Term (CoeffTerm, ConstTerm, VarTerm)) +import Linear.Term.Types (Term (..), TermVarsOnly (..)) import Linear.Var.Types (Var) -substVarSimpleConstraint :: Var -> Expr -> SimpleConstraint -> SimpleConstraint -substVarSimpleConstraint var varReplacement (a :<= b) = substVarExpr var varReplacement a :<= b -substVarSimpleConstraint var varReplacement (a :>= b) = substVarExpr var varReplacement a :>= b -substVarSimpleConstraint var varReplacement (a :== b) = substVarExpr var varReplacement a :== b +substVarSimpleConstraintExpr :: + Var -> Expr -> SimpleConstraint -> SimpleConstraint +substVarSimpleConstraintExpr var varReplacement (a :<= b) = + let newExpr = substVarExpr var varReplacement (exprVarsOnlyToExpr a) + newConstraint = newExpr :<= Expr [ConstTerm b] + in constraintToSimpleConstraint newConstraint +substVarSimpleConstraintExpr var varReplacement (a :>= b) = + let newExpr = substVarExpr var varReplacement (exprVarsOnlyToExpr a) + newConstraint = newExpr :>= Expr [ConstTerm b] + in constraintToSimpleConstraint newConstraint +substVarSimpleConstraintExpr var varReplacement (a :== b) = + let newExpr = substVarExpr var varReplacement (exprVarsOnlyToExpr a) + newConstraint = newExpr :== Expr [ConstTerm b] + in constraintToSimpleConstraint newConstraint + +substVarSimpleConstraint :: + Var -> ExprVarsOnly -> SimpleConstraint -> SimpleConstraint +substVarSimpleConstraint var varReplacement (a :<= b) = substVarExprVarsOnly var varReplacement a :<= b +substVarSimpleConstraint var varReplacement (a :>= b) = substVarExprVarsOnly var varReplacement a :>= b +substVarSimpleConstraint var varReplacement (a :== b) = substVarExprVarsOnly var varReplacement a :== b constraintToSimpleConstraint :: Constraint -> SimpleConstraint constraintToSimpleConstraint constraint = @@ -51,79 +69,77 @@ constraintToSimpleConstraint constraint = aWithoutConst = simplifyExpr . zeroConstExpr $ a bWithoutConst = simplifyExpr . zeroConstExpr $ b - lhs = subtractExpr aWithoutConst bWithoutConst - calcRhs a b = rhs - where - aConsts = sumExprConstTerms a - bConsts = sumExprConstTerms b - rhs = bConsts - aConsts - - aWithoutConst = simplifyExpr . zeroConstExpr $ a - bWithoutConst = simplifyExpr . zeroConstExpr $ b - - lhs = subtractExpr aWithoutConst bWithoutConst + lhs' = subtractExpr aWithoutConst bWithoutConst + lhs = case exprToExprVarsOnly lhs' of + Right exprVarsOnly -> exprVarsOnly + Left err -> + error $ + "constraintToSimpleConstraint: lhs is not ExprVarsOnly. Details: " <> err -- normalize simple constraints by moving all constants to the right -normalizeSimpleConstraint :: SimpleConstraint -> SimpleConstraint -normalizeSimpleConstraint (expr :<= num) = - let exprList = exprToList expr +-- normalizeSimpleConstraint :: SimpleConstraint -> SimpleConstraint +-- normalizeSimpleConstraint (expr :<= num) = +-- let exprList = exprToList expr - isConstTerm (ConstTerm _) = True - isConstTerm _ = False +-- isConstTerm (ConstTerm _) = True +-- isConstTerm _ = False - (sumExprConstTerms, nonConstTerms) = L.partition isConstTerm exprList +-- (sumExprConstTerms, nonConstTerms) = L.partition isConstTerm exprList - constTermsVal = sum . map (\case (ConstTerm c) -> c; _ -> 0) $ sumExprConstTerms +-- constTermsVal = sum . map (\case (ConstTerm c) -> c; _ -> 0) $ sumExprConstTerms - newExpr = listToExpr nonConstTerms - newNum = num - constTermsVal - in newExpr :<= newNum -normalizeSimpleConstraint (expr :>= num) = - let exprList = exprToList expr +-- newExpr = listToExpr nonConstTerms +-- newNum = num - constTermsVal +-- in newExpr :<= newNum +-- normalizeSimpleConstraint (expr :>= num) = +-- let exprList = exprToList expr - isConstTerm (ConstTerm _) = True - isConstTerm _ = False +-- isConstTerm (ConstTerm _) = True +-- isConstTerm _ = False - (sumExprConstTerms, nonConstTerms) = L.partition isConstTerm exprList +-- (sumExprConstTerms, nonConstTerms) = L.partition isConstTerm exprList - constTermsVal = sum . map (\case (ConstTerm c) -> c; _ -> 0) $ sumExprConstTerms +-- constTermsVal = sum . map (\case (ConstTerm c) -> c; _ -> 0) $ sumExprConstTerms - newExpr = listToExpr nonConstTerms - newNum = num - constTermsVal - in newExpr :>= newNum -normalizeSimpleConstraint (expr :== num) = - let exprList = exprToList expr +-- newExpr = listToExpr nonConstTerms +-- newNum = num - constTermsVal +-- in newExpr :>= newNum +-- normalizeSimpleConstraint (expr :== num) = +-- let exprList = exprToList expr - isConstTerm (ConstTerm _) = True - isConstTerm _ = False +-- isConstTerm (ConstTerm _) = True +-- isConstTerm _ = False - (sumExprConstTerms, nonConstTerms) = L.partition isConstTerm exprList +-- (sumExprConstTerms, nonConstTerms) = L.partition isConstTerm exprList - constTermsVal = sum . map (\case (ConstTerm c) -> c; _ -> 0) $ sumExprConstTerms +-- constTermsVal = sum . map (\case (ConstTerm c) -> c; _ -> 0) $ sumExprConstTerms - newExpr = listToExpr nonConstTerms - newNum = num - constTermsVal - in newExpr :== newNum +-- newExpr = listToExpr nonConstTerms +-- newNum = num - constTermsVal +-- in newExpr :== newNum -- | Simplify coeff constraints by dividing the coefficient from both sides simplifyCoeff :: SimpleConstraint -> SimpleConstraint -simplifyCoeff expr@(Expr (CoeffTerm coeff var :| []) :<= num) +simplifyCoeff expr@(ExprVarsOnly [CoeffTermVO coeff var] :<= num) | coeff == 0 = expr - | coeff > 0 = Expr (VarTerm var :| []) :<= (num / coeff) - | coeff < 0 = Expr (VarTerm var :| []) :>= (num / coeff) -simplifyCoeff expr@(Expr (CoeffTerm coeff var :| []) :>= num) + | coeff > 0 = ExprVarsOnly [VarTermVO var] :<= (num / coeff) + | coeff < 0 = ExprVarsOnly [VarTermVO var] :>= (num / coeff) +simplifyCoeff expr@(ExprVarsOnly [CoeffTermVO coeff var] :>= num) | coeff == 0 = expr - | coeff > 0 = Expr (VarTerm var :| []) :>= (num / coeff) - | coeff < 0 = Expr (VarTerm var :| []) :<= (num / coeff) -simplifyCoeff expr@(Expr (CoeffTerm coeff var :| []) :== num) = if coeff == 0 then expr else Expr (VarTerm var :| []) :== (num / coeff) + | coeff > 0 = ExprVarsOnly [VarTermVO var] :>= (num / coeff) + | coeff < 0 = ExprVarsOnly [VarTermVO var] :<= (num / coeff) +simplifyCoeff expr@(ExprVarsOnly [CoeffTermVO coeff var] :== num) = + if coeff == 0 + then expr + else ExprVarsOnly [VarTermVO var] :== (num / coeff) simplifyCoeff expr = expr simplifySimpleConstraint :: SimpleConstraint -> SimpleConstraint -simplifySimpleConstraint (expr :<= num) = simplifyCoeff . normalizeSimpleConstraint $ simplifyExpr expr :<= num -simplifySimpleConstraint (expr :>= num) = simplifyCoeff . normalizeSimpleConstraint $ simplifyExpr expr :>= num -simplifySimpleConstraint (expr :== num) = simplifyCoeff . normalizeSimpleConstraint $ simplifyExpr expr :== num +simplifySimpleConstraint (expr :<= num) = simplifyCoeff $ simplifyExprVarsOnly expr :<= num +simplifySimpleConstraint (expr :>= num) = simplifyCoeff $ simplifyExprVarsOnly expr :>= num +simplifySimpleConstraint (expr :== num) = simplifyCoeff $ simplifyExprVarsOnly expr :== num simpleConstraintVars :: SimpleConstraint -> Set.Set Var -simpleConstraintVars (expr :<= _) = exprVars expr -simpleConstraintVars (expr :>= _) = exprVars expr -simpleConstraintVars (expr :== _) = exprVars expr +simpleConstraintVars (expr :<= _) = exprVars . exprVarsOnlyToExpr $ expr +simpleConstraintVars (expr :>= _) = exprVars . exprVarsOnlyToExpr $ expr +simpleConstraintVars (expr :== _) = exprVars . exprVarsOnlyToExpr $ expr diff --git a/src/Linear/Expr/Types.hs b/src/Linear/Expr/Types.hs index b78a3c0..702593e 100644 --- a/src/Linear/Expr/Types.hs +++ b/src/Linear/Expr/Types.hs @@ -7,14 +7,13 @@ -- Stability: experimental module Linear.Expr.Types where -import qualified Data.List.NonEmpty as NE -import GHC.Base (liftA2) import GHC.Generics (Generic) import Linear.Term.Types (Term, TermVarsOnly) import Test.QuickCheck (Arbitrary (..)) -import Test.QuickCheck.Gen (suchThat) -newtype Expr = Expr {unExpr :: NE.NonEmpty Term} +-- TODO: Use normal lists +-- treat empty expr as 0 +newtype Expr = Expr {unExpr :: [Term]} deriving ( Show , Read @@ -22,7 +21,7 @@ newtype Expr = Expr {unExpr :: NE.NonEmpty Term} , Generic ) -newtype ExprVarsOnly = ExprVarsOnly {unExprVarsOnly :: NE.NonEmpty TermVarsOnly} +newtype ExprVarsOnly = ExprVarsOnly {unExprVarsOnly :: [TermVarsOnly]} deriving ( Show , Read @@ -31,4 +30,7 @@ newtype ExprVarsOnly = ExprVarsOnly {unExprVarsOnly :: NE.NonEmpty TermVarsOnly} ) instance Arbitrary Expr where - arbitrary = Expr . NE.fromList <$> arbitrary `suchThat` (not . null) + arbitrary = Expr <$> arbitrary + +instance Arbitrary ExprVarsOnly where + arbitrary = ExprVarsOnly <$> arbitrary diff --git a/src/Linear/Expr/Util.hs b/src/Linear/Expr/Util.hs index 91c25f7..05abb09 100644 --- a/src/Linear/Expr/Util.hs +++ b/src/Linear/Expr/Util.hs @@ -8,15 +8,16 @@ module Linear.Expr.Util where import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.List.NonEmpty as NE import qualified Data.Maybe as Maybe import qualified Data.Set as Set import Linear.Expr.Types (Expr (..), ExprVarsOnly (..)) -import Linear.Term.Types (Term (..)) +import Linear.Term.Types (Term (..), TermVarsOnly (..)) import Linear.Term.Util ( negateTerm , normalizeTerms + , normalizeTermsVarsOnly , simplifyTerm + , termVarsOnlyToTerm , unsafeTermToTermVarsOnly , zeroConstTerm ) @@ -24,12 +25,17 @@ import Linear.Var.Types (SimplexNum, Var) -- | Convert an 'Expr' to a list of 'Term's. exprToList :: Expr -> [Term] -exprToList (Expr t) = NE.toList t +exprToList = unExpr + +exprVarsOnlyToList :: ExprVarsOnly -> [TermVarsOnly] +exprVarsOnlyToList = unExprVarsOnly -- | Convert a list of 'Term's to an 'Expr'. listToExpr :: [Term] -> Expr -listToExpr [] = Expr $ ConstTerm 0 :| [] -- TODO: Maybe throw an error? -listToExpr ts = Expr $ NE.fromList ts +listToExpr = Expr + +listToExprVarsOnly :: [TermVarsOnly] -> ExprVarsOnly +listToExprVarsOnly = ExprVarsOnly exprVars :: Expr -> Set.Set Var exprVars = Set.fromList . Maybe.mapMaybe termVars . exprToList @@ -39,23 +45,32 @@ exprVars = Set.fromList . Maybe.mapMaybe termVars . exprToList termVars (CoeffTerm _ v) = Just v termVars (VarTerm v) = Just v +exprVarsOnlyVars :: ExprVarsOnly -> Set.Set Var +exprVarsOnlyVars = exprVars . exprVarsOnlyToExpr + +exprVarsOnlyMaxVar :: ExprVarsOnly -> Var +exprVarsOnlyMaxVar = maximum . exprVarsOnlyVars + simplifyExpr :: Expr -> Expr simplifyExpr = listToExpr . normalizeTerms . exprToList +simplifyExprVarsOnly :: ExprVarsOnly -> ExprVarsOnly +simplifyExprVarsOnly = listToExprVarsOnly . normalizeTermsVarsOnly . exprVarsOnlyToList + sumExprConstTerms :: Expr -> SimplexNum sumExprConstTerms (Expr ts) = sumExprConstTerms ts where - sumExprConstTerms = sum . Maybe.mapMaybe termConst . NE.toList + sumExprConstTerms = sum . Maybe.mapMaybe termConst termConst :: Term -> Maybe SimplexNum termConst (ConstTerm c) = Just c termConst _ = Nothing zeroConstExpr :: Expr -> Expr -zeroConstExpr (Expr ts) = Expr $ NE.map zeroConstTerm ts +zeroConstExpr (Expr ts) = Expr $ map zeroConstTerm ts negateExpr :: Expr -> Expr -negateExpr (Expr ts) = Expr $ NE.map negateTerm ts +negateExpr (Expr ts) = Expr $ map negateTerm ts addExpr :: Expr -> Expr -> Expr addExpr e1 e2 = @@ -90,12 +105,29 @@ substVarExpr var varReplacement = simplifyExpr . listToExpr . aux . exprToList else t : aux ts (ConstTerm _) -> t : aux ts +substVarExprVarsOnly :: Var -> ExprVarsOnly -> ExprVarsOnly -> ExprVarsOnly +substVarExprVarsOnly var varReplacement expr = + let varReplacement' = exprVarsOnlyToExpr varReplacement + expr' = exprVarsOnlyToExpr expr + result' = substVarExpr var varReplacement' expr' + in unsafeExprToExprVarsOnly result' + +unsafeExprToExprVarsOnly :: Expr -> ExprVarsOnly +unsafeExprToExprVarsOnly (Expr ts) = ExprVarsOnly (map unsafeTermToTermVarsOnly ts) + exprToExprVarsOnly :: Expr -> Either String ExprVarsOnly -exprToExprVarsOnly (Expr ts) = do +exprToExprVarsOnly expr@(Expr ts) = do if any isConstTerm ts - then Left "safeExprToExprVarsOnly: Expr contains ConstTerm" - else Right $ ExprVarsOnly (NE.map unsafeTermToTermVarsOnly ts) + then + if sumExprConstTerms expr == 0 + then Right $ ExprVarsOnly [] + else + Left $ "safeExprToExprVarsOnly: Expr contains ConstTerm. Expr: " <> show expr + else Right $ unsafeExprToExprVarsOnly expr where isConstTerm :: Term -> Bool isConstTerm (ConstTerm _) = True isConstTerm _ = False + +exprVarsOnlyToExpr :: ExprVarsOnly -> Expr +exprVarsOnlyToExpr (ExprVarsOnly ts) = Expr $ map termVarsOnlyToTerm ts diff --git a/src/Linear/SlackForm/Util.hs b/src/Linear/SlackForm/Util.hs index 1c0b50f..95e5875 100644 --- a/src/Linear/SlackForm/Util.hs +++ b/src/Linear/SlackForm/Util.hs @@ -7,23 +7,28 @@ -- Stability: experimental module Linear.SlackForm.Util where -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map +import qualified Data.Maybe as Maybe import Linear.Constraint.Generic.Types ( GenericConstraint ((:<=), (:==), (:>=)) ) +import Linear.Constraint.Linear.Types (LinearEquation (..)) +import qualified Linear.Constraint.Linear.Util as CLU import Linear.Constraint.Simple.Util - ( substVarSimpleConstraint + ( substVarSimpleConstraintExpr ) -import Linear.Expr.Types (Expr (..)) +import Linear.Expr.Types (Expr (..), ExprVarsOnly (..)) +import Linear.Expr.Util (exprVarsOnlyToExpr) +import Linear.System.Linear.Types (LinearSystem (..)) +import qualified Linear.System.Linear.Util as SLU import Linear.System.Simple.Types ( SimpleSystem - , findHighestVar , simplifySimpleSystem ) +import qualified Linear.System.Simple.Types as SST import Linear.Term.Types ( Term (..) + , TermVarsOnly (..) ) import Linear.Var.Types (Bounds (..), Var, VarBounds) @@ -35,20 +40,22 @@ eliminateNonZeroLowerBounds :: eliminateNonZeroLowerBounds constraints eliminatedVarsMap = aux [] constraints where -- Eliminate non-zero lower bounds + + aux :: SimpleSystem -> SimpleSystem -> (Map.Map Var Expr, SimpleSystem) aux _ [] = (eliminatedVarsMap, constraints) aux checked (c : cs) = case c of -- x >= 5 - (Expr (VarTerm var :| []) :>= lowerBound) -> + (ExprVarsOnly (VarTermVO var : []) :>= lowerBound) -> if lowerBound == 0 then aux (checked ++ [c]) cs else - let newVar = findHighestVar constraints + 1 + let newVar = SST.findHighestVar constraints + 1 -- y >= 0 - newVarLowerBound = Expr (VarTerm newVar :| []) :>= 0 + newVarLowerBound = ExprVarsOnly (VarTermVO newVar : []) :>= 0 -- x = y + 5 - substOldVarWith = Expr (VarTerm newVar :| [ConstTerm lowerBound]) - substFn = substVarSimpleConstraint var substOldVarWith + substOldVarWith = Expr (VarTerm newVar : [ConstTerm lowerBound]) + substFn = substVarSimpleConstraintExpr var substOldVarWith newConstraints = simplifySimpleSystem $ map substFn checked ++ newVarLowerBound : map substFn cs @@ -62,60 +69,65 @@ eliminateNonZeroLowerBounds constraints eliminatedVarsMap = aux [] constraints -- Add slack variables... -- Second step here https://en.wikipedia.org/wiki/Simplex_algorithm#Standard_form -- Return system of equalities and the slack variables -addSlackVariables :: SimpleSystem -> ([Var], SimpleSystem) +addSlackVariables :: SimpleSystem -> ([Var], LinearSystem) addSlackVariables constraints = - let nextAvailableVar = findHighestVar constraints + 1 + let nextAvailableVar = SST.findHighestVar constraints + 1 in aux constraints nextAvailableVar [] where - aux :: SimpleSystem -> Var -> [Var] -> ([Var], SimpleSystem) - aux [] _ slackVars = (slackVars, []) + aux :: SimpleSystem -> Var -> [Var] -> ([Var], LinearSystem) + aux [] _ slackVars = (slackVars, LinearSystem []) aux (c : cs) nextVar slackVars = case c of - (expr@(Expr exprTs) :<= num) -> + (expr@(ExprVarsOnly exprTs) :<= num) -> let slackVar = nextVar newNextVar = nextVar + 1 - newExpr = Expr $ NE.appendList exprTs [VarTerm slackVar] - slackVarLowerBound = Expr (VarTerm slackVar :| []) :>= 0 + newExpr = ExprVarsOnly $ exprTs ++ [VarTermVO slackVar] + -- slackVarLowerBound = Expr (VarTerm slackVar : []) :>= 0 (newSlackVars, newConstraints) = aux cs newNextVar slackVars - in (nextVar : newSlackVars, newExpr :== num : slackVarLowerBound : newConstraints) - (expr@(Expr exprTs) :>= num) -> + in ( nextVar : newSlackVars + , SLU.prependLinearEquation (LinearEquation newExpr num) newConstraints + ) + (expr@(ExprVarsOnly exprTs) :>= num) -> let slackVar = nextVar newNextVar = nextVar + 1 - newExpr = Expr $ NE.appendList exprTs [CoeffTerm (-1) slackVar] - slackVarLowerBound = Expr (VarTerm slackVar :| []) :>= 0 + newExpr = ExprVarsOnly $ exprTs ++ [CoeffTermVO (-1) slackVar] + -- slackVarLowerBound = Expr (VarTerm slackVar : []) :>= 0 (newSlackVars, newConstraints) = aux cs newNextVar slackVars - in (nextVar : newSlackVars, newExpr :== num : slackVarLowerBound : newConstraints) + in ( nextVar : newSlackVars + , SLU.prependLinearEquation (LinearEquation newExpr num) newConstraints + ) (expr :== num) -> let (newSlackVars, newConstraints) = aux cs nextVar slackVars - in (newSlackVars, c : newConstraints) + in ( newSlackVars + , SLU.prependLinearEquation (LinearEquation expr num) newConstraints + ) --- Eliminate unrestricted variables (lower bound unknown) +-- Eliminate unrestricted variables (lower bound unknown) given some bounds -- Third step here https://en.wikipedia.org/wiki/Simplex_algorithm#Standard_form --- precondition: VarBounds accurate for SimpleSystem eliminateUnrestrictedLowerBounds :: - SimpleSystem -> + LinearSystem -> VarBounds -> Map.Map Var Expr -> - (Map.Map Var Expr, SimpleSystem) + (Map.Map Var Expr, LinearSystem) eliminateUnrestrictedLowerBounds constraints varBoundMap eliminatedVarsMap = aux constraints (Map.toList varBoundMap) where - aux :: SimpleSystem -> [(Var, Bounds)] -> (Map.Map Var Expr, SimpleSystem) + aux :: + LinearSystem -> [(Var, Bounds)] -> (Map.Map Var Expr, LinearSystem) aux _ [] = (eliminatedVarsMap, constraints) aux cs ((var, Bounds Nothing _) : bounds) = - let newVarPlus = findHighestVar constraints + 1 + let highestVar = Maybe.fromMaybe (-1) $ SLU.findHighestVar constraints + newVarPlus = highestVar + 1 newVarMinus = newVarPlus + 1 - newVarPlusLowerBound = Expr (VarTerm newVarPlus :| []) :>= 0 - newVarMinusLowerBound = Expr (VarTerm newVarMinus :| []) :>= 0 + -- newVarPlusLowerBound = Expr (VarTerm newVarPlus : []) :>= 0 + -- newVarMinusLowerBound = Expr (VarTerm newVarMinus : []) :>= 0 -- oldVar = newVarPlus - newVarMinus - substOldVarWith = Expr (VarTerm newVarPlus :| [CoeffTerm (-1) newVarMinus]) + substOldVarWith = ExprVarsOnly (VarTermVO newVarPlus : [CoeffTermVO (-1) newVarMinus]) newConstraints = - simplifySimpleSystem $ - newVarPlusLowerBound - : newVarMinusLowerBound - : map (substVarSimpleConstraint var substOldVarWith) constraints - -- TODO: Update this name - updatedEliminatedVarsMap = Map.insert var substOldVarWith eliminatedVarsMap + LinearSystem $ + map (CLU.substVarWith var substOldVarWith) (unLinearSystem constraints) -- TODO: simplify? + -- TODO: Update this name + updatedEliminatedVarsMap = Map.insert var (exprVarsOnlyToExpr substOldVarWith) eliminatedVarsMap in eliminateUnrestrictedLowerBounds newConstraints (Map.fromList bounds) diff --git a/src/Linear/System/Simple/Types.hs b/src/Linear/System/Simple/Types.hs index 270ee7f..3b2d944 100644 --- a/src/Linear/System/Simple/Types.hs +++ b/src/Linear/System/Simple/Types.hs @@ -15,8 +15,8 @@ import Linear.Constraint.Simple.Util ( simpleConstraintVars , simplifySimpleConstraint ) -import Linear.Expr.Util (exprToList) -import Linear.Term.Types (Term (..)) +import Linear.Expr.Util (exprVarsOnlyToList) +import Linear.Term.Types (TermVarsOnly (..)) import Linear.Var.Types (Var) type SimpleSystem = [SimpleConstraint] @@ -30,9 +30,8 @@ simpleSystemVars = Set.unions . map simpleConstraintVars findHighestVar :: SimpleSystem -> Var findHighestVar simpleSystem = let vars = - [ v | gc <- simpleSystem, term <- exprToList $ getGenericConstraintLHS gc, v <- case term of - VarTerm v -> [v] - CoeffTerm _ v -> [v] - _ -> [] + [ v | gc <- simpleSystem, term <- exprVarsOnlyToList $ getGenericConstraintLHS gc, v <- case term of + VarTermVO v -> [v] + CoeffTermVO _ v -> [v] ] in maximum vars diff --git a/src/Linear/System/Simple/Util.hs b/src/Linear/System/Simple/Util.hs index cb9ca48..f514063 100644 --- a/src/Linear/System/Simple/Util.hs +++ b/src/Linear/System/Simple/Util.hs @@ -7,20 +7,18 @@ -- Stability: experimental module Linear.System.Simple.Util where -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.List.NonEmpty as NE import qualified Data.Map as M import qualified Data.Set as Set import Linear.Constraint.Generic.Types ( GenericConstraint ((:<=), (:==), (:>=)) ) import Linear.Constraint.Simple.Types (SimpleConstraint) -import Linear.Expr.Types (Expr (..)) +import Linear.Expr.Types (Expr (..), ExprVarsOnly (..)) import Linear.System.Simple.Types ( SimpleSystem , simpleSystemVars ) -import Linear.Term.Types (Term (..)) +import Linear.Term.Types (Term (..), TermVarsOnly (..)) import Linear.Var.Types (Bounds (..), VarBounds) -- | Derive bounds for all variables in a system @@ -31,9 +29,9 @@ deriveBounds simpleSystem = foldr updateBounds initialVarBounds simpleSystem initialVarBounds = M.fromList [(v, Bounds Nothing Nothing) | v <- Set.toList systemVars] updateBounds :: SimpleConstraint -> VarBounds -> VarBounds - updateBounds (Expr ((VarTerm var) :| []) :<= num) = M.insertWith mergeBounds var (Bounds Nothing (Just num)) - updateBounds (Expr ((VarTerm var) :| []) :>= num) = M.insertWith mergeBounds var (Bounds (Just num) Nothing) - updateBounds (Expr ((VarTerm var) :| []) :== num) = M.insertWith mergeBounds var (Bounds (Just num) (Just num)) + updateBounds (ExprVarsOnly [VarTermVO var] :<= num) = M.insertWith mergeBounds var (Bounds Nothing (Just num)) + updateBounds (ExprVarsOnly [VarTermVO var] :>= num) = M.insertWith mergeBounds var (Bounds (Just num) Nothing) + updateBounds (ExprVarsOnly [VarTermVO var] :== num) = M.insertWith mergeBounds var (Bounds (Just num) (Just num)) updateBounds _ = id -- \| Merge two bounds, very simple @@ -55,10 +53,10 @@ removeUselessSystemBounds :: SimpleSystem -> VarBounds -> SimpleSystem removeUselessSystemBounds constraints bounds = filter ( \case - (Expr ((VarTerm var) :| []) :<= num) -> case M.lookup var bounds of + (ExprVarsOnly [VarTermVO var] :<= num) -> case M.lookup var bounds of Just (Bounds _ (Just upper)) -> num <= upper _ -> True - (Expr ((VarTerm var) :| []) :>= num) -> case M.lookup var bounds of + (ExprVarsOnly [VarTermVO var] :>= num) -> case M.lookup var bounds of Just (Bounds (Just lower) _) -> num >= lower _ -> True _ -> True diff --git a/src/Linear/Term/Types.hs b/src/Linear/Term/Types.hs index e22a364..a8f2236 100644 --- a/src/Linear/Term/Types.hs +++ b/src/Linear/Term/Types.hs @@ -29,3 +29,10 @@ instance Arbitrary Term where , CoeffTerm <$> arbitrary <*> arbitrary , VarTerm <$> arbitrary ] + +instance Arbitrary TermVarsOnly where + arbitrary = + oneof + [ VarTermVO <$> arbitrary + , CoeffTermVO <$> arbitrary <*> arbitrary + ] diff --git a/src/Linear/Term/Util.hs b/src/Linear/Term/Util.hs index 8b2bd1c..1966421 100644 --- a/src/Linear/Term/Util.hs +++ b/src/Linear/Term/Util.hs @@ -85,6 +85,9 @@ normalizeTerms = else x1 : combineTerms (x2 : xs) _otherwise -> x1 : combineTerms (x2 : xs) +normalizeTermsVarsOnly :: [TermVarsOnly] -> [TermVarsOnly] +normalizeTermsVarsOnly = map unsafeTermToTermVarsOnly . normalizeTerms . map termVarsOnlyToTerm + termToTermVarsOnly :: Term -> Either String TermVarsOnly termToTermVarsOnly (VarTerm v) = Right $ VarTermVO v termToTermVarsOnly (CoeffTerm c v) = Right $ CoeffTermVO c v @@ -96,6 +99,6 @@ unsafeTermToTermVarsOnly t = Right x -> x Left e -> error e -termsVarOnlyToTerm :: TermVarsOnly -> Term -termsVarOnlyToTerm (VarTermVO v) = VarTerm v -termsVarOnlyToTerm (CoeffTermVO c v) = CoeffTerm c v +termVarsOnlyToTerm :: TermVarsOnly -> Term +termVarsOnlyToTerm (VarTermVO v) = VarTerm v +termVarsOnlyToTerm (CoeffTermVO c v) = CoeffTerm c v diff --git a/test/Linear/Constraint/Simple/UtilSpec.hs b/test/Linear/Constraint/Simple/UtilSpec.hs index 16cf06b..bb1d78c 100644 --- a/test/Linear/Constraint/Simple/UtilSpec.hs +++ b/test/Linear/Constraint/Simple/UtilSpec.hs @@ -7,27 +7,27 @@ -- Stability: experimental module Linear.Constraint.Simple.UtilSpec where -import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map as Map import qualified Data.Set as Set import Linear.Constraint.Simple.Util ( constraintToSimpleConstraint - , normalizeSimpleConstraint , simpleConstraintVars , simplifyCoeff , simplifySimpleConstraint , substVarSimpleConstraint + , substVarSimpleConstraintExpr ) import Linear.Constraint.Util (constraintVars) -import Linear.Expr.Types (Expr (..)) -import Linear.Expr.Util (exprVars) -import Linear.Term.Types (Term (..)) +import Linear.Expr.Types (Expr (..), ExprVarsOnly (..)) +import Linear.Expr.Util (exprVars, exprVarsOnlyVars) +import Linear.Term.Types (Term (..), TermVarsOnly (..)) import Test.Hspec (Spec, describe) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (counterexample, elements) import TestUtil ( evalConstraint , evalExpr + , evalExprVarsOnly , evalSimpleConstraint , genVarMap ) @@ -37,14 +37,14 @@ spec :: Spec spec = do describe "SimpleConstraint" $ do prop - "substVarSimpleConstraint with a constant is the same as evaluating with the variable mapped to the constant" + "substVarSimpleConstraintExpr with a constant is the same as evaluating with the variable mapped to the constant" $ \simpleConstraint c -> do let vars = Set.toList $ simpleConstraintVars simpleConstraint var <- elements vars - let varReplacement = Expr (ConstTerm c :| []) + let varReplacement = Expr (ConstTerm c : []) initialVarMap <- genVarMap vars let varMap = Map.insert var c initialVarMap - substitutedSimpleConstraint = substVarSimpleConstraint var varReplacement simpleConstraint + substitutedSimpleConstraint = substVarSimpleConstraintExpr var varReplacement simpleConstraint substitutedSimpleConstraintEval = evalSimpleConstraint varMap substitutedSimpleConstraint simpleConstraintEval = evalSimpleConstraint varMap simpleConstraint pure @@ -68,7 +68,7 @@ spec = do ) $ substitutedSimpleConstraintEval == simpleConstraintEval prop - "substVarSimpleConstraint with an expr is the same as evaluating with the variable mapped to the expr" + "substVarSimpleConstraintExpr with an expr is the same as evaluating with the variable mapped to the expr" $ \simpleConstraint exprReplacement -> do let vars = Set.toList $ simpleConstraintVars simpleConstraint <> exprVars exprReplacement @@ -76,7 +76,7 @@ spec = do initialVarMap <- genVarMap vars let exprReplacementEval = evalExpr initialVarMap exprReplacement varMap = Map.insert var exprReplacementEval initialVarMap - substitutedSimpleConstraint = substVarSimpleConstraint var exprReplacement simpleConstraint + substitutedSimpleConstraint = substVarSimpleConstraintExpr var exprReplacement simpleConstraint simpleConstraintEval = evalSimpleConstraint varMap simpleConstraint substitutedSimpleConstraintEval = evalSimpleConstraint initialVarMap substitutedSimpleConstraint pure @@ -121,26 +121,6 @@ spec = do <> show simpleConstraintEval ) $ constraintEval == simpleConstraintEval - prop "normalizeSimpleConstraint leads to the same evaluation" $ \simpleConstraint -> do - let vars = Set.toList $ simpleConstraintVars simpleConstraint - varMap <- genVarMap vars - let normalizedSimpleConstraint = normalizeSimpleConstraint simpleConstraint - simpleConstraintEval = evalSimpleConstraint varMap simpleConstraint - normalizedSimpleConstraintEval = evalSimpleConstraint varMap normalizedSimpleConstraint - pure - $ counterexample - ( "simpleConstraint: " - <> show simpleConstraint - <> "\nnormalizedSimpleConstraint: " - <> show normalizedSimpleConstraint - <> "\ninitialVarMap: " - <> show varMap - <> "\nsimpleConstraintEval: " - <> show simpleConstraintEval - <> "\nnormalizedSimpleConstraintEval" - <> show normalizedSimpleConstraintEval - ) - $ simpleConstraintEval == normalizedSimpleConstraintEval prop "simplifyCoeff leads to the same evaluation" $ \simpleConstraint -> do let vars = Set.toList $ simpleConstraintVars simpleConstraint varMap <- genVarMap vars diff --git a/test/Linear/Expr/UtilSpec.hs b/test/Linear/Expr/UtilSpec.hs index b155827..5cc925a 100644 --- a/test/Linear/Expr/UtilSpec.hs +++ b/test/Linear/Expr/UtilSpec.hs @@ -7,7 +7,6 @@ -- Stability: experimental module Linear.Expr.UtilSpec where -import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import qualified Data.Set as Set @@ -177,7 +176,7 @@ spec = do let vars = Set.toList $ exprVars expr var <- elements vars varMap <- genVarMap vars - let varReplacement = Expr (VarTerm var :| []) + let varReplacement = Expr (VarTerm var : []) exprSubst = substVarExpr var varReplacement expr exprSimplified = simplifyExpr expr exprSubstEval = evalExpr varMap exprSubst @@ -205,7 +204,7 @@ spec = do prop "substVarExpr with a constant is the same as evaluating with the variable mapped to the constant" $ \expr c -> do - let varReplacement = Expr (ConstTerm c :| []) + let varReplacement = Expr (ConstTerm c : []) let vars = Set.toList $ exprVars expr var <- elements vars initialVarMap <- genVarMap vars diff --git a/test/Linear/SlackForm/UtilSpec.hs b/test/Linear/SlackForm/UtilSpec.hs index 82295d9..927b66c 100644 --- a/test/Linear/SlackForm/UtilSpec.hs +++ b/test/Linear/SlackForm/UtilSpec.hs @@ -3,7 +3,6 @@ module Linear.SlackForm.UtilSpec where import Control.Monad (forM) import Data.Functor ((<&>)) import qualified Data.List as List -import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map as Map import qualified Data.Maybe as Maybe import qualified Data.Set as Set @@ -12,15 +11,18 @@ import Linear.Constraint.Generic.Types ( GenericConstraint ((:<=), (:==), (:>=)) , getGenericConstraintLHS ) -import Linear.Expr.Types (Expr (..)) +import Linear.Constraint.Linear.Types (LinearEquation (..)) +import Linear.Expr.Types (Expr (..), ExprVarsOnly (..)) import Linear.SlackForm.Util ( addSlackVariables , eliminateNonZeroLowerBounds , eliminateUnrestrictedLowerBounds ) +import Linear.System.Linear.Types (LinearSystem (..)) import Linear.System.Simple.Util (deriveBounds) import Linear.Term.Types ( Term (..) + , TermVarsOnly (..) ) import Test.Hspec (Spec, describe, it, shouldBe) import Test.QuickCheck (Testable (property), withMaxSuccess) @@ -36,59 +38,59 @@ spec = do "eliminateNonZeroLowerBounds does not do anything when all lower bounds are zero" $ do let simpleSystem = - [ Expr (VarTerm 0 :| []) :>= 0 - , Expr (VarTerm 1 :| []) :>= 0 + [ ExprVarsOnly (VarTermVO 0 : []) :>= 0 + , ExprVarsOnly (VarTermVO 1 : []) :>= 0 ] (updatedBounds, updatedSystem) = eliminateNonZeroLowerBounds simpleSystem Map.empty expectedSimpleSystem = - [ Expr (VarTerm 0 :| []) :>= 0 - , Expr (VarTerm 1 :| []) :>= 0 + [ ExprVarsOnly (VarTermVO 0 : []) :>= 0 + , ExprVarsOnly (VarTermVO 1 : []) :>= 0 ] expectedEliminatedVarExprMap = Map.empty updatedSystem `shouldBe` expectedSimpleSystem updatedBounds `shouldBe` expectedEliminatedVarExprMap it "eliminateNonZeroLowerBounds correctly eliminates positive lower bounds" $ do let simpleSystem = - [ Expr (VarTerm 0 :| []) :>= 1 - , Expr (VarTerm 1 :| []) :>= 0 + [ ExprVarsOnly (VarTermVO 0 : []) :>= 1 + , ExprVarsOnly (VarTermVO 1 : []) :>= 0 ] (updatedBounds, updatedSystem) = eliminateNonZeroLowerBounds simpleSystem Map.empty expectedSimpleSystem = - [ Expr (VarTerm 2 :| []) :>= 0 - , Expr (VarTerm 1 :| []) :>= 0 + [ ExprVarsOnly (VarTermVO 2 : []) :>= 0 + , ExprVarsOnly (VarTermVO 1 : []) :>= 0 ] - expectedEliminatedVarExprMap = Map.fromList [(0, Expr (VarTerm 2 :| [ConstTerm 1]))] + expectedEliminatedVarExprMap = Map.fromList [(0, Expr (VarTerm 2 : [ConstTerm 1]))] updatedSystem `shouldBe` expectedSimpleSystem updatedBounds `shouldBe` expectedEliminatedVarExprMap it "eliminateNonZeroLowerBounds correctly eliminates negative lower bounds" $ do let simpleSystem = - [ Expr (VarTerm 0 :| []) :>= (-1) - , Expr (VarTerm 1 :| []) :>= 0 + [ ExprVarsOnly (VarTermVO 0 : []) :>= (-1) + , ExprVarsOnly (VarTermVO 1 : []) :>= 0 ] (updatedBounds, updatedSystem) = eliminateNonZeroLowerBounds simpleSystem Map.empty expectedSimpleSystem = - [ Expr (VarTerm 2 :| []) :>= 0 - , Expr (VarTerm 1 :| []) :>= 0 + [ ExprVarsOnly (VarTermVO 2 : []) :>= 0 + , ExprVarsOnly (VarTermVO 1 : []) :>= 0 ] - expectedEliminatedVarExprMap = Map.fromList [(0, Expr (VarTerm 2 :| [ConstTerm (-1)]))] + expectedEliminatedVarExprMap = Map.fromList [(0, Expr (VarTerm 2 : [ConstTerm (-1)]))] updatedSystem `shouldBe` expectedSimpleSystem updatedBounds `shouldBe` expectedEliminatedVarExprMap it "eliminateNonZeroLowerBounds correctly eliminates positive and negative lower bounds" $ do let simpleSystem = - [ Expr (VarTerm 0 :| []) :>= 1 - , Expr (VarTerm 1 :| []) :>= (-1) + [ ExprVarsOnly (VarTermVO 0 : []) :>= 1 + , ExprVarsOnly (VarTermVO 1 : []) :>= (-1) ] (updatedBounds, updatedSystem) = eliminateNonZeroLowerBounds simpleSystem Map.empty expectedSimpleSystem = - [ Expr (VarTerm 2 :| []) :>= 0 - , Expr (VarTerm 3 :| []) :>= 0 + [ ExprVarsOnly (VarTermVO 2 : []) :>= 0 + , ExprVarsOnly (VarTermVO 3 : []) :>= 0 ] expectedEliminatedVarExprMap = Map.fromList - [ (0, Expr (VarTerm 2 :| [ConstTerm 1])) - , (1, Expr (VarTerm 3 :| [ConstTerm (-1)])) + [ (0, Expr (VarTerm 2 : [ConstTerm 1])) + , (1, Expr (VarTerm 3 : [ConstTerm (-1)])) ] updatedSystem `shouldBe` expectedSimpleSystem updatedBounds `shouldBe` expectedEliminatedVarExprMap @@ -96,17 +98,17 @@ spec = do "eliminateNonZeroLowerBounds correctly substitutes vars with non-zero lower bounds" $ do let simpleSystem = - [ Expr (VarTerm 0 :| []) :>= 1 - , Expr (VarTerm 1 :| []) :>= 0 - , Expr (VarTerm 0 :| [VarTerm 1]) :>= 1 + [ ExprVarsOnly (VarTermVO 0 : []) :>= 1 + , ExprVarsOnly (VarTermVO 1 : []) :>= 0 + , ExprVarsOnly (VarTermVO 0 : [VarTermVO 1]) :>= 1 ] (updatedBounds, updatedSystem) = eliminateNonZeroLowerBounds simpleSystem Map.empty expectedSimpleSystem = - [ Expr (VarTerm 2 :| []) :>= 0 - , Expr (VarTerm 1 :| []) :>= 0 - , Expr (VarTerm 1 :| [VarTerm 2]) :>= 0 + [ ExprVarsOnly (VarTermVO 2 : []) :>= 0 + , ExprVarsOnly (VarTermVO 1 : []) :>= 0 + , ExprVarsOnly (VarTermVO 1 : [VarTermVO 2]) :>= 0 ] - expectedEliminatedVarExprMap = Map.fromList [(0, Expr (VarTerm 2 :| [ConstTerm 1]))] + expectedEliminatedVarExprMap = Map.fromList [(0, Expr (VarTerm 2 : [ConstTerm 1]))] updatedSystem `shouldBe` expectedSimpleSystem updatedBounds `shouldBe` expectedEliminatedVarExprMap it "eliminateNonZeroLowerBounds property based test lower bounds" $ do @@ -114,7 +116,7 @@ spec = do let (updatedBounds, updatedSystem) = eliminateNonZeroLowerBounds simpleSystem Map.empty all ( \case - Expr (VarTerm _ :| []) :>= num -> num == 0 + ExprVarsOnly (VarTermVO _ : []) :>= num -> num == 0 _ -> True ) updatedSystem @@ -137,15 +139,16 @@ spec = do "addSlackVariables correctly transforms inequalities to equalities (wikipedia case)" $ do let simpleSystem = - [ Expr (VarTerm 2 :| [CoeffTerm 2 3]) :<= 3 -- x_2 + 2x_3 <= 3 - , Expr (CoeffTerm (-1) 4 :| [CoeffTerm 3 5]) :>= 2 -- -x_4 + 3x_5 >= 2 + [ ExprVarsOnly (VarTermVO 2 : [CoeffTermVO 2 3]) :<= 3 -- x_2 + 2x_3 <= 3 + , ExprVarsOnly (CoeffTermVO (-1) 4 : [CoeffTermVO 3 5]) :>= 2 -- -x_4 + 3x_5 >= 2 ] expectedSystem = - [ Expr (VarTerm 2 :| [CoeffTerm 2 3, VarTerm 6]) :== 3 -- x_2 + 2x_3 + x_6 = 3 - , Expr (VarTerm 6 :| []) :>= 0 -- x_6 >= 0 - , Expr (CoeffTerm (-1) 4 :| [CoeffTerm 3 5, CoeffTerm (-1) 7]) :== 2 -- -x_4 + 3x_5 + x_7 = 2 - , Expr (VarTerm 7 :| []) :>= 0 -- x_7 >= 0 - ] + LinearSystem + [ LinearEquation (ExprVarsOnly (VarTermVO 2 : [CoeffTermVO 2 3, VarTermVO 6])) 3 -- x_2 + 2x_3 + x_6 = 3 + , LinearEquation + (ExprVarsOnly (CoeffTermVO (-1) 4 : [CoeffTermVO 3 5, CoeffTermVO (-1) 7])) + 2 -- -x_4 + 3x_5 + x_7 = 2 + ] expectedSlackVars = [6, 7] (slackVars, updatedSystem) = addSlackVariables simpleSystem updatedSystem `shouldBe` expectedSystem @@ -154,15 +157,16 @@ spec = do "addSlackVariables correctly transforms inequalities to equalities (test case 1)" $ do let simpleSystem = - [ Expr (VarTerm 1 :| [CoeffTerm 2 2]) :<= 4 -- x_1 + 2x_2 <= 4 - , Expr (CoeffTerm (-1) 3 :| [CoeffTerm 2 4]) :>= 3 -- -x_3 + 2x_4 >= 3 + [ ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 2]) :<= 4 -- x_1 + 2x_2 <= 4 + , ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4]) :>= 3 -- -x_3 + 2x_4 >= 3 ] expectedSystem = - [ Expr (VarTerm 1 :| [CoeffTerm 2 2, VarTerm 5]) :== 4 -- x_1 + 2x_2 + x_5 = 4 - , Expr (VarTerm 5 :| []) :>= 0 -- x_5 >= 0 - , Expr (CoeffTerm (-1) 3 :| [CoeffTerm 2 4, CoeffTerm (-1) 6]) :== 3 -- -x_3 + 2x_4 - x_6 = 3 - , Expr (VarTerm 6 :| []) :>= 0 -- x_6 >= 0 - ] + LinearSystem + [ LinearEquation (ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 2, VarTermVO 5])) 4 -- x_1 + 2x_2 + x_5 = 4 + , LinearEquation + (ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4, CoeffTermVO (-1) 6])) + 3 -- -x_3 + 2x_4 - x_6 = 3 + ] expectedSlackVars = [5, 6] (slackVars, updatedSystem) = addSlackVariables simpleSystem updatedSystem `shouldBe` expectedSystem @@ -171,15 +175,16 @@ spec = do "addSlackVariables correctly transforms inequalities to equalities (test case 2)" $ do let simpleSystem = - [ Expr (VarTerm 1 :| [CoeffTerm 2 2]) :<= 5 -- x_1 + 2x_2 <= 5 - , Expr (CoeffTerm (-1) 3 :| [CoeffTerm 2 4]) :>= 4 -- -x_3 + 2x_4 >= 4 + [ ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 2]) :<= 5 -- x_1 + 2x_2 <= 5 + , ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4]) :>= 4 -- -x_3 + 2x_4 >= 4 ] expectedSystem = - [ Expr (VarTerm 1 :| [CoeffTerm 2 2, VarTerm 5]) :== 5 -- x_1 + 2x_2 + x_5 = 5 - , Expr (VarTerm 5 :| []) :>= 0 -- x_5 >= 0 - , Expr (CoeffTerm (-1) 3 :| [CoeffTerm 2 4, CoeffTerm (-1) 6]) :== 4 -- -x_3 + 2x_4 - x_6 = 4 - , Expr (VarTerm 6 :| []) :>= 0 -- x_6 >= 0 - ] + LinearSystem + [ LinearEquation (ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 2, VarTermVO 5])) 5 -- x_1 + 2x_2 + x_5 = 5 + , LinearEquation + (ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4, CoeffTermVO (-1) 6])) + 4 -- -x_3 + 2x_4 - x_6 = 4 + ] expectedSlackVars = [5, 6] (slackVars, updatedSystem) = addSlackVariables simpleSystem updatedSystem `shouldBe` expectedSystem @@ -188,14 +193,14 @@ spec = do "addSlackVariables correctly transforms inequalities to equalities (test case 3)" $ do let simpleSystem = - [ Expr (VarTerm 1 :| [CoeffTerm 2 2]) :<= 5 -- x_1 + 2x_2 <= 5 - , Expr (CoeffTerm (-1) 3 :| [CoeffTerm 2 4]) :== 4 -- -x_3 + 2x_4 = 4 + [ ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 2]) :<= 5 -- x_1 + 2x_2 <= 5 + , ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4]) :== 4 -- -x_3 + 2x_4 = 4 ] expectedSystem = - [ Expr (VarTerm 1 :| [CoeffTerm 2 2, VarTerm 5]) :== 5 -- x_1 + 2x_2 + x_5 = 5 - , Expr (VarTerm 5 :| []) :>= 0 -- x_5 >= 0 - , Expr (CoeffTerm (-1) 3 :| [CoeffTerm 2 4]) :== 4 -- -x_3 + 2x_4 = 4 - ] + LinearSystem + [ LinearEquation (ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 2, VarTermVO 5])) 5 -- x_1 + 2x_2 + x_5 = 5 + , LinearEquation (ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4])) 4 -- -x_3 + 2x_4 = 4 + ] expectedSlackVars = [5] (slackVars, updatedSystem) = addSlackVariables simpleSystem updatedSystem `shouldBe` expectedSystem @@ -204,13 +209,14 @@ spec = do "addSlackVariables correctly transforms inequalities to equalities (test case 4)" $ do let simpleSystem = - [ Expr (VarTerm 1 :| [CoeffTerm 2 2]) :== 5 -- x_1 + 2x_2 = 5 - , Expr (CoeffTerm (-1) 3 :| [CoeffTerm 2 4]) :== 4 -- -x_3 + 2x_4 = 4 + [ ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 2]) :== 5 -- x_1 + 2x_2 = 5 + , ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4]) :== 4 -- -x_3 + 2x_4 = 4 ] expectedSystem = - [ Expr (VarTerm 1 :| [CoeffTerm 2 2]) :== 5 -- x_1 + 2x_2 = 5 - , Expr (CoeffTerm (-1) 3 :| [CoeffTerm 2 4]) :== 4 -- -x_3 + 2x_4 = 4 - ] + LinearSystem + [ LinearEquation (ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 2])) 5 -- x_1 + 2x_2 = 5 + , LinearEquation (ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4])) 4 -- -x_3 + 2x_4 = 4 + ] expectedSlackVars = [] (slackVars, updatedSystem) = addSlackVariables simpleSystem updatedSystem `shouldBe` expectedSystem @@ -219,8 +225,8 @@ spec = do "eliminateUnrestrictedLowerBounds correctly eliminates unrestricted lower bounds (wikipedia case)" $ do let simpleSystem = - [ Expr (VarTerm 1 :| []) :>= 0 -- x_1 >= 0 - , Expr (VarTerm 1 :| [VarTerm 2]) :>= 0 -- x_1 + x_2 >= 0 + [ ExprVarsOnly (VarTermVO 1 : []) :>= 0 -- x_1 >= 0 + , ExprVarsOnly (VarTermVO 1 : [VarTermVO 2]) :>= 0 -- x_1 + x_2 >= 0 ] systemBounds = deriveBounds simpleSystem (eliminatedNonZeroLowerBounds, systemWithoutNonZeroLowerBounds) = eliminateNonZeroLowerBounds simpleSystem Map.empty @@ -230,24 +236,27 @@ spec = do systemWithSlackVars systemBounds eliminatedNonZeroLowerBounds + expectedSlackVars = [3, 4] expectedSystem = - [ Expr (VarTerm 5 :| []) :>= 0 -- x_5 >= 0 - , Expr (VarTerm 6 :| []) :>= 0 -- x_6 >= 0 - , Expr (CoeffTerm (-1) 3 :| [VarTerm 1]) :== 0 -- -x_3 + x_1 = 0 - , Expr (VarTerm 3 :| []) :>= 0 -- x_3 >= 0 - , Expr (CoeffTerm (-1) 4 :| [CoeffTerm (-1) 6, VarTerm 1, VarTerm 5]) :== 0 -- -x_4 - x_6 + x_1 + x_5 = 0 - , Expr (VarTerm 4 :| []) :>= 0 -- x_4 >= 0 - ] - expectedEliminatedVarExprMap = Map.fromList [(2, Expr (VarTerm 5 :| [CoeffTerm (-1) 6]))] + LinearSystem + [ LinearEquation (ExprVarsOnly (CoeffTermVO (-1) 3 : [VarTermVO 1])) 0 -- -x_3 + x_1 = 0 + , LinearEquation + ( ExprVarsOnly + (CoeffTermVO (-1) 4 : [CoeffTermVO (-1) 6, VarTermVO 1, VarTermVO 5]) + ) + 0 -- -x_4 - x_6 + x_1 + x_5 = 0 + ] + expectedEliminatedVarExprMap = Map.fromList [(2, Expr (VarTerm 5 : [CoeffTerm (-1) 6]))] + slackVars `shouldBe` expectedSlackVars updatedSystem `shouldBe` expectedSystem updatedEliminatedVarsMap `shouldBe` expectedEliminatedVarExprMap it "eliminateUnrestrictedLowerBounds correctly eliminates unrestricted lower bounds (test case 2)" $ do let simpleSystem = - [ Expr (VarTerm 1 :| []) :>= 0 -- x_1 >= 0 - , Expr (VarTerm 1 :| [VarTerm 2, VarTerm 3]) :>= 0 -- x_1 + x_2 + x_3 >= 0 + [ ExprVarsOnly (VarTermVO 1 : []) :>= 0 -- x_1 >= 0 + , ExprVarsOnly (VarTermVO 1 : [VarTermVO 2, VarTermVO 3]) :>= 0 -- x_1 + x_2 + x_3 >= 0 ] systemBounds = deriveBounds simpleSystem (eliminatedNonZeroLowerBounds, systemWithoutNonZeroLowerBounds) = eliminateNonZeroLowerBounds simpleSystem Map.empty @@ -257,25 +266,24 @@ spec = do systemWithSlackVars systemBounds eliminatedNonZeroLowerBounds + expectedSlackVars = [4, 5] expectedSystem = - [ Expr (VarTerm 8 :| []) :>= 0 -- x_8 >= 0 - , Expr (VarTerm 9 :| []) :>= 0 -- x_9 >= 0 - , Expr (VarTerm 6 :| []) :>= 0 -- x_6 >= 0 - , Expr (VarTerm 7 :| []) :>= 0 -- x_7 >= 0 - , Expr (CoeffTerm (-1) 4 :| [VarTerm 1]) :== 0 -- -x_4 + x_1 = 0 - , Expr (VarTerm 4 :| []) :>= 0 -- x_4 >= 0 - , Expr - ( CoeffTerm (-1) 5 - :| [CoeffTerm (-1) 7, CoeffTerm (-1) 9, VarTerm 1, VarTerm 6, VarTerm 8] - ) - :== 0 -- -x_5 - x_7 - x_9 + x_1 + x_6 + x_8 = 0 - , Expr (VarTerm 5 :| []) :>= 0 -- x_5 >= 0 - ] + LinearSystem + [ LinearEquation (ExprVarsOnly (CoeffTermVO (-1) 4 : [VarTermVO 1])) 0 -- -x_4 + x_1 = 0 + , LinearEquation + ( ExprVarsOnly + ( CoeffTermVO (-1) 5 + : [CoeffTermVO (-1) 7, CoeffTermVO (-1) 9, VarTermVO 1, VarTermVO 6, VarTermVO 8] + ) + ) + 0 -- -x_5 - x_7 - x_9 + x_1 + x_6 + x_8 = 0 + ] expectedEliminatedVarExprMap = Map.fromList - [ (2, Expr (VarTerm 6 :| [CoeffTerm (-1) 7])) - , (3, Expr (VarTerm 8 :| [CoeffTerm (-1) 9])) + [ (2, Expr (VarTerm 6 : [CoeffTerm (-1) 7])) + , (3, Expr (VarTerm 8 : [CoeffTerm (-1) 9])) ] + slackVars `shouldBe` expectedSlackVars updatedSystem `shouldBe` expectedSystem updatedEliminatedVarsMap `shouldBe` expectedEliminatedVarExprMap @@ -283,74 +291,78 @@ spec = do "eliminateUnrestrictedLowerBounds correctly eliminates unrestricted lower bounds (test case 3)" $ do let simpleSystem = - [ Expr (VarTerm 1 :| []) :>= 0 -- x_1 >= 0 - , Expr (VarTerm 1 :| [VarTerm 2]) :>= 0 -- x_1 + x_2 >= 0 - , Expr (VarTerm 2 :| [VarTerm 3]) :>= 0 -- x_2 + x_3 >= 0 + [ ExprVarsOnly (VarTermVO 1 : []) :>= 0 -- x_1 >= 0 + , ExprVarsOnly (VarTermVO 1 : [VarTermVO 2]) :>= 0 -- x_1 + x_2 >= 0 + , ExprVarsOnly (VarTermVO 2 : [VarTermVO 3]) :>= 0 -- x_2 + x_3 >= 0 ] systemBounds = deriveBounds simpleSystem (eliminatedNonZeroLowerBounds, systemWithoutNonZeroLowerBounds) = eliminateNonZeroLowerBounds simpleSystem Map.empty (slackVars, systemWithSlackVars) = addSlackVariables systemWithoutNonZeroLowerBounds + expectedSlackVars = [4, 5, 6] (updatedEliminatedVarsMap, updatedSystem) = eliminateUnrestrictedLowerBounds systemWithSlackVars systemBounds eliminatedNonZeroLowerBounds expectedSystem = - [ Expr (VarTerm 9 :| []) :>= 0 -- x_9 >= 0 - , Expr (VarTerm 10 :| []) :>= 0 -- x_10 >= 0 - , Expr (VarTerm 7 :| []) :>= 0 -- x_7 >= 0 - , Expr (VarTerm 8 :| []) :>= 0 -- x_8 >= 0 - , Expr (CoeffTerm (-1) 4 :| [VarTerm 1]) :== 0 -- -x_4 + x_1 = 0 - , Expr (VarTerm 4 :| []) :>= 0 -- x_4 >= 0 - , Expr (CoeffTerm (-1) 5 :| [CoeffTerm (-1) 8, VarTerm 1, VarTerm 7]) :== 0 -- -x_5 - x_8 + x_1 + x_7 = 0 - , Expr (VarTerm 5 :| []) :>= 0 -- x_5 >= 0 - , Expr - ( CoeffTerm (-1) 6 :| [CoeffTerm (-1) 8, CoeffTerm (-1) 10, VarTerm 7, VarTerm 9] - ) - :== 0 -- -x_6 - x_8 - x_10 + x_7 + x_9 = 0 - , Expr (VarTerm 6 :| []) :>= 0 -- x_6 >= 0 - ] + LinearSystem + [ LinearEquation (ExprVarsOnly (CoeffTermVO (-1) 4 : [VarTermVO 1])) 0 -- -x_4 + x_1 = 0 + , LinearEquation + ( ExprVarsOnly + (CoeffTermVO (-1) 5 : [CoeffTermVO (-1) 8, VarTermVO 1, VarTermVO 7]) + ) + 0 -- -x_5 - x_8 + x_1 + x_7 = 0 + , LinearEquation + ( ExprVarsOnly + ( CoeffTermVO (-1) 6 + : [CoeffTermVO (-1) 8, CoeffTermVO (-1) 10, VarTermVO 7, VarTermVO 9] + ) + ) + 0 -- -x_6 - x_8 - x_10 + x_7 + x_9 = 0 + ] expectedEliminatedVarExprMap = Map.fromList - [ (2, Expr (VarTerm 7 :| [CoeffTerm (-1) 8])) - , (3, Expr (VarTerm 9 :| [CoeffTerm (-1) 10])) + [ (2, Expr (VarTerm 7 : [CoeffTerm (-1) 8])) + , (3, Expr (VarTerm 9 : [CoeffTerm (-1) 10])) ] + slackVars `shouldBe` expectedSlackVars updatedSystem `shouldBe` expectedSystem updatedEliminatedVarsMap `shouldBe` expectedEliminatedVarExprMap it "eliminateUnrestrictedLowerBounds correctly eliminates non-zero lower bounds for all variables" $ do let simpleSystem = - [ Expr (VarTerm 1 :| [CoeffTerm 2 1]) :>= 0 -- x_1 + 2 >= 0 - , Expr (VarTerm 2 :| [CoeffTerm 3 1]) :>= 0 -- x_2 + 3 >= 0 + [ ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 1]) :>= 0 -- x_1 + 2x_1 >= 0 + , ExprVarsOnly (VarTermVO 2 : [CoeffTermVO 3 1]) :>= 0 -- x_2 + 3x_1 >= 0 ] systemBounds = deriveBounds simpleSystem (eliminatedNonZeroLowerBounds, systemWithoutNonZeroLowerBounds) = eliminateNonZeroLowerBounds simpleSystem Map.empty (slackVars, systemWithSlackVars) = addSlackVariables systemWithoutNonZeroLowerBounds + expectedSlackVars = [3, 4] (updatedEliminatedVarsMap, updatedSystem) = eliminateUnrestrictedLowerBounds systemWithSlackVars systemBounds eliminatedNonZeroLowerBounds expectedSystem = - [ Expr (VarTerm 7 :| []) :>= 0 -- x_7 >= 0 - , Expr (VarTerm 8 :| []) :>= 0 -- x_8 >= 0 - , Expr (VarTerm 5 :| []) :>= 0 -- x_5 >= 0 - , Expr (VarTerm 6 :| []) :>= 0 -- x_6 >= 0 - , Expr (CoeffTerm (-3) 6 :| [CoeffTerm (-1) 3, CoeffTerm 3 5]) :== 0 -- -3x_6 - x_3 + 3x_5 = 0 - , Expr (VarTerm 3 :| []) :>= 0 -- x_3 >= 0 - , Expr - ( CoeffTerm (-3) 6 - :| [CoeffTerm (-1) 4, CoeffTerm (-1) 8, CoeffTerm 3 5, VarTerm 7] - ) - :== 0 -- -3x_6 - x_4 - x_8 + 3x_5 + x_7 = 0 - , Expr (VarTerm 4 :| []) :>= 0 -- x_4 >= 0 - ] + LinearSystem + [ LinearEquation + (ExprVarsOnly (CoeffTermVO (-3) 6 : [CoeffTermVO (-1) 3, CoeffTermVO 3 5])) + 0 -- -3x_6 - x_3 + 3x_5 = 0 + , LinearEquation + ( ExprVarsOnly + ( CoeffTermVO (-3) 6 + : [CoeffTermVO (-1) 4, CoeffTermVO (-1) 8, CoeffTermVO 3 5, VarTermVO 7] + ) + ) + 0 -- -3x_6 - x_4 - x_8 + 3x_5 + x_7 = 0 + ] expectedEliminatedVarExprMap = Map.fromList - [ (1, Expr (VarTerm 5 :| [CoeffTerm (-1) 6])) - , (2, Expr (VarTerm 7 :| [CoeffTerm (-1) 8])) + [ (1, Expr (VarTerm 5 : [CoeffTerm (-1) 6])) + , (2, Expr (VarTerm 7 : [CoeffTerm (-1) 8])) ] + slackVars `shouldBe` expectedSlackVars updatedSystem `shouldBe` expectedSystem updatedEliminatedVarsMap `shouldBe` expectedEliminatedVarExprMap @@ -358,23 +370,24 @@ spec = do "eliminateUnrestrictedLowerBounds correctly handles all variables with zero lower bounds" $ do let simpleSystem = - [ Expr (VarTerm 1 :| []) :>= 0 -- x_1 >= 0 - , Expr (VarTerm 2 :| []) :>= 0 -- x_2 >= 0 + [ ExprVarsOnly (VarTermVO 1 : []) :>= 0 -- x_1 >= 0 + , ExprVarsOnly (VarTermVO 2 : []) :>= 0 -- x_2 >= 0 ] systemBounds = deriveBounds simpleSystem (eliminatedNonZeroLowerBounds, systemWithoutNonZeroLowerBounds) = eliminateNonZeroLowerBounds simpleSystem Map.empty (slackVars, systemWithSlackVars) = addSlackVariables systemWithoutNonZeroLowerBounds + expectedSlackVars = [3, 4] (updatedEliminatedVarsMap, updatedSystem) = eliminateUnrestrictedLowerBounds systemWithSlackVars systemBounds eliminatedNonZeroLowerBounds expectedSystem = - [ (Expr (VarTerm 1 :| [CoeffTerm (-1) 3])) :== 0 -- x_1 - x_3 = 0 - , Expr (VarTerm 3 :| []) :>= 0 -- x_3 >= 0 - , (Expr (VarTerm 2 :| [CoeffTerm (-1) 4])) :== 0 -- x_2 - x_4 = 0 - , Expr (VarTerm 4 :| []) :>= 0 -- x_4 >= 0 - ] + LinearSystem + [ LinearEquation (ExprVarsOnly (VarTermVO 1 : [CoeffTermVO (-1) 3])) 0 -- x_1 - x_3 = 0 + , LinearEquation (ExprVarsOnly (VarTermVO 2 : [CoeffTermVO (-1) 4])) 0 -- x_2 - x_4 = 0 + ] expectedEliminatedVarExprMap = Map.empty + slackVars `shouldBe` expectedSlackVars updatedSystem `shouldBe` expectedSystem updatedEliminatedVarsMap `shouldBe` expectedEliminatedVarExprMap diff --git a/test/Linear/System/Simple/UtilSpec.hs b/test/Linear/System/Simple/UtilSpec.hs index 62ba132..7e881a0 100644 --- a/test/Linear/System/Simple/UtilSpec.hs +++ b/test/Linear/System/Simple/UtilSpec.hs @@ -13,7 +13,7 @@ import qualified Data.Set as Set import Linear.Constraint.Generic.Types ( GenericConstraint ((:<=), (:>=)) ) -import Linear.Expr.Types (Expr (Expr)) +import Linear.Expr.Types (ExprVarsOnly (..)) import Linear.System.Simple.Types ( findHighestVar , simpleSystemVars @@ -23,7 +23,7 @@ import Linear.System.Simple.Util ( deriveBounds , removeUselessSystemBounds ) -import Linear.Term.Types (Term (..)) +import Linear.Term.Types (TermVarsOnly (..)) import Linear.Var.Types (Bounds (..)) import Linear.Var.Util (validateBounds) import Test.Hspec (Spec, describe, it, shouldBe) @@ -56,24 +56,24 @@ spec = do $ simpleSystemEval == simplifiedSimpleSystemEval it "findHighestVar finds the highest variable in a simple system" $ do let simpleSystem1 = - [ Expr (VarTerm 0 :| []) :>= 0 - , Expr (VarTerm 0 :| []) :<= 1 - , Expr (VarTerm 1 :| []) :>= 0 - , Expr (VarTerm 1 :| []) :<= 1 + [ ExprVarsOnly (VarTermVO 0 : []) :>= 0 + , ExprVarsOnly (VarTermVO 0 : []) :<= 1 + , ExprVarsOnly (VarTermVO 1 : []) :>= 0 + , ExprVarsOnly (VarTermVO 1 : []) :<= 1 ] simpleSystem100 = - [ Expr (VarTerm 0 :| []) :<= 1 - , Expr (VarTerm 50 :| []) :<= 1 - , Expr (VarTerm 100 :| []) :<= 1 + [ ExprVarsOnly (VarTermVO 0 : []) :<= 1 + , ExprVarsOnly (VarTermVO 50 : []) :<= 1 + , ExprVarsOnly (VarTermVO 100 : []) :<= 1 ] simpleSystem10 = - [ Expr (VarTerm (-10) :| []) :<= 1 - , Expr (VarTerm 0 :| []) :<= 1 - , Expr (VarTerm 10 :| []) :<= 1 + [ ExprVarsOnly (VarTermVO (-10) : []) :<= 1 + , ExprVarsOnly (VarTermVO 0 : []) :<= 1 + , ExprVarsOnly (VarTermVO 10 : []) :<= 1 ] simpleSystemMinus10 = - [ Expr (VarTerm (-10) :| []) :<= 1 - , Expr (VarTerm (-20) :| []) :<= 1 + [ ExprVarsOnly (VarTermVO (-10) : []) :<= 1 + , ExprVarsOnly (VarTermVO (-20) : []) :<= 1 ] findHighestVar simpleSystem1 `shouldBe` 1 @@ -85,8 +85,8 @@ spec = do "validateBounds finds that deriving bounds for a system where -1 <= x <= 1 has valid bounds" $ do let simpleSystem = - [ Expr (VarTerm 0 :| []) :>= (-1) - , Expr (VarTerm 0 :| []) :<= 1 + [ ExprVarsOnly (VarTermVO 0 : []) :>= (-1) + , ExprVarsOnly (VarTermVO 0 : []) :<= 1 ] derivedBounds = deriveBounds simpleSystem expectedBounds = Map.fromList [(0, Bounds (Just (-1)) (Just 1))] @@ -96,8 +96,8 @@ spec = do "validateBounds finds that deriving bounds for a system where 0 <= x <= 1 has valid bounds" $ do let simpleSystem = - [ Expr (VarTerm 0 :| []) :>= 0 - , Expr (VarTerm 0 :| []) :<= 1 + [ ExprVarsOnly (VarTermVO 0 : []) :>= 0 + , ExprVarsOnly (VarTermVO 0 : []) :<= 1 ] derivedBounds = deriveBounds simpleSystem expectedBounds = Map.fromList [(0, Bounds (Just 0) (Just 1))] @@ -107,8 +107,8 @@ spec = do "validateBounds finds that deriving bounds for a system where 1 <= x <= 1 has valid bounds" $ do let simpleSystem = - [ Expr (VarTerm 0 :| []) :>= 1 - , Expr (VarTerm 0 :| []) :<= 1 + [ ExprVarsOnly (VarTermVO 0 : []) :>= 1 + , ExprVarsOnly (VarTermVO 0 : []) :<= 1 ] derivedBounds = deriveBounds simpleSystem expectedBounds = Map.fromList [(0, Bounds (Just 1) (Just 1))] @@ -118,8 +118,8 @@ spec = do "validateBounds finds that deriving bounds for a system where 1 <= x <= 0 has invalid bounds" $ do let simpleSystem = - [ Expr (VarTerm 0 :| []) :>= 1 - , Expr (VarTerm 0 :| []) :<= 0 + [ ExprVarsOnly (VarTermVO 0 : []) :>= 1 + , ExprVarsOnly (VarTermVO 0 : []) :<= 0 ] derivedBounds = deriveBounds simpleSystem expectedBounds = Map.fromList [(0, Bounds (Just 1) (Just 0))] @@ -129,10 +129,10 @@ spec = do "validateBounds finds that deriving bounds for a system where 0 <= x <= 1 and 1 <= y <= 3 has valid bounds" $ do let simpleSystem = - [ Expr (VarTerm 0 :| []) :>= 0 - , Expr (VarTerm 0 :| []) :<= 1 - , Expr (VarTerm 1 :| []) :>= 1 - , Expr (VarTerm 1 :| []) :<= 3 + [ ExprVarsOnly (VarTermVO 0 : []) :>= 0 + , ExprVarsOnly (VarTermVO 0 : []) :<= 1 + , ExprVarsOnly (VarTermVO 1 : []) :>= 1 + , ExprVarsOnly (VarTermVO 1 : []) :<= 3 ] derivedBounds = deriveBounds simpleSystem expectedBounds = Map.fromList [(0, Bounds (Just 0) (Just 1)), (1, Bounds (Just 1) (Just 3))] @@ -142,10 +142,10 @@ spec = do "validateBounds finds that deriving bounds for a system where 1 <= x <= 0 and 3 <= y <= 1 has invalid bounds" $ do let simpleSystem = - [ Expr (VarTerm 0 :| []) :>= 1 - , Expr (VarTerm 0 :| []) :<= 0 - , Expr (VarTerm 1 :| []) :>= 3 - , Expr (VarTerm 1 :| []) :<= 1 + [ ExprVarsOnly (VarTermVO 0 : []) :>= 1 + , ExprVarsOnly (VarTermVO 0 : []) :<= 0 + , ExprVarsOnly (VarTermVO 1 : []) :>= 3 + , ExprVarsOnly (VarTermVO 1 : []) :<= 1 ] derivedBounds = deriveBounds simpleSystem expectedBounds = Map.fromList [(0, Bounds (Just 1) (Just 0)), (1, Bounds (Just 3) (Just 1))] @@ -155,10 +155,10 @@ spec = do "validateBounds finds that deriving bounds for a system where 1 <= x <= 0 and 1 <= y <= 3 has invalid bounds" $ do let simpleSystem = - [ Expr (VarTerm 0 :| []) :>= 1 - , Expr (VarTerm 0 :| []) :<= 0 - , Expr (VarTerm 1 :| []) :>= 1 - , Expr (VarTerm 1 :| []) :<= 3 + [ ExprVarsOnly (VarTermVO 0 : []) :>= 1 + , ExprVarsOnly (VarTermVO 0 : []) :<= 0 + , ExprVarsOnly (VarTermVO 1 : []) :>= 1 + , ExprVarsOnly (VarTermVO 1 : []) :<= 3 ] derivedBounds = deriveBounds simpleSystem expectedBounds = Map.fromList [(0, Bounds (Just 1) (Just 0)), (1, Bounds (Just 1) (Just 3))] @@ -168,10 +168,10 @@ spec = do "validateBounds finds that deriving bounds for a system where 0 <= x <= 1 and 3 <= y <= 1 has invalid bounds" $ do let simpleSystem = - [ Expr (VarTerm 0 :| []) :>= 0 - , Expr (VarTerm 0 :| []) :<= 1 - , Expr (VarTerm 1 :| []) :>= 3 - , Expr (VarTerm 1 :| []) :<= 1 + [ ExprVarsOnly (VarTermVO 0 : []) :>= 0 + , ExprVarsOnly (VarTermVO 0 : []) :<= 1 + , ExprVarsOnly (VarTermVO 1 : []) :>= 3 + , ExprVarsOnly (VarTermVO 1 : []) :<= 1 ] derivedBounds = deriveBounds simpleSystem expectedBounds = Map.fromList [(0, Bounds (Just 0) (Just 1)), (1, Bounds (Just 3) (Just 1))] @@ -179,78 +179,82 @@ spec = do validateBounds derivedBounds `shouldBe` False it "removeUselessSystemBounds removes x <= 3 when bounds say x <= 2" $ do let simpleSystem = - [ Expr (VarTerm 0 :| []) :<= 2 - , Expr (VarTerm 0 :| []) :<= 3 + [ ExprVarsOnly (VarTermVO 0 : []) :<= 2 + , ExprVarsOnly (VarTermVO 0 : []) :<= 3 ] bounds = Map.fromList [(0, Bounds (Just 0) (Just 2))] simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds - expectedSimpleSystem = [Expr (VarTerm 0 :| []) :<= 2] + expectedSimpleSystem = [ExprVarsOnly (VarTermVO 0 : []) :<= 2] simplifiedSimpleSystem `shouldBe` expectedSimpleSystem it "removeUselessSystemBounds does not remove x <= 2 when bounds say x <= 2" $ do let simpleSystem = - [ Expr (VarTerm 0 :| []) :<= 2 + [ ExprVarsOnly (VarTermVO 0 : []) :<= 2 ] bounds = Map.fromList [(0, Bounds (Just 0) (Just 2))] simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds - expectedSimpleSystem = [Expr (VarTerm 0 :| []) :<= 2] + expectedSimpleSystem = [ExprVarsOnly (VarTermVO 0 : []) :<= 2] simplifiedSimpleSystem `shouldBe` expectedSimpleSystem it "removeUselessSystemBounds removes x >= 3 when bounds say x >= 4" $ do let simpleSystem = - [ Expr (VarTerm 0 :| []) :>= 4 - , Expr (VarTerm 0 :| []) :>= 3 + [ ExprVarsOnly (VarTermVO 0 : []) :>= 4 + , ExprVarsOnly (VarTermVO 0 : []) :>= 3 ] bounds = Map.fromList [(0, Bounds (Just 4) (Just 5))] simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds - expectedSimpleSystem = [Expr (VarTerm 0 :| []) :>= 4] + expectedSimpleSystem = [ExprVarsOnly (VarTermVO 0 : []) :>= 4] simplifiedSimpleSystem `shouldBe` expectedSimpleSystem it "removeUselessSystemBounds does not remove x >= 4 when bounds say x >= 4" $ do let simpleSystem = - [ Expr (VarTerm 0 :| []) :>= 4 + [ ExprVarsOnly (VarTermVO 0 : []) :>= 4 ] bounds = Map.fromList [(0, Bounds (Just 4) (Just 5))] simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds - expectedSimpleSystem = [Expr (VarTerm 0 :| []) :>= 4] + expectedSimpleSystem = [ExprVarsOnly (VarTermVO 0 : []) :>= 4] simplifiedSimpleSystem `shouldBe` expectedSimpleSystem it "removeUselessSystemBounds does not remove 0 <= x <= 2 when bounds say 0 <= x <= 2" $ do let simpleSystem = - [ Expr (VarTerm 0 :| []) :>= 0 - , Expr (VarTerm 0 :| []) :<= 2 + [ ExprVarsOnly (VarTermVO 0 : []) :>= 0 + , ExprVarsOnly (VarTermVO 0 : []) :<= 2 ] bounds = Map.fromList [(0, Bounds (Just 0) (Just 2))] simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds - expectedSimpleSystem = [Expr (VarTerm 0 :| []) :>= 0, Expr (VarTerm 0 :| []) :<= 2] + expectedSimpleSystem = + [ExprVarsOnly (VarTermVO 0 : []) :>= 0, ExprVarsOnly (VarTermVO 0 : []) :<= 2] simplifiedSimpleSystem `shouldBe` expectedSimpleSystem it "removeUselessSystemBounds removes upper bound of 0 <= x <= 2 when bounds say 0 <= x <= 1" $ do let simpleSystem = - [ Expr (VarTerm 0 :| []) :>= 0 - , Expr (VarTerm 0 :| []) :<= 2 + [ ExprVarsOnly (VarTermVO 0 : []) :>= 0 + , ExprVarsOnly (VarTermVO 0 : []) :<= 2 ] bounds = Map.fromList [(0, Bounds (Just 0) (Just 1))] simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds - expectedSimpleSystem = [Expr (VarTerm 0 :| []) :>= 0] + expectedSimpleSystem = [ExprVarsOnly (VarTermVO 0 : []) :>= 0] simplifiedSimpleSystem `shouldBe` expectedSimpleSystem it "removeUselessSystemBounds removes lower bound of 0 <= x <= 2 when bounds say 1 <= x <= 2" $ do let simpleSystem = - [ Expr (VarTerm 0 :| []) :>= 0 - , Expr (VarTerm 0 :| []) :<= 2 + [ ExprVarsOnly (VarTermVO 0 : []) :>= 0 + , ExprVarsOnly (VarTermVO 0 : []) :<= 2 ] bounds = Map.fromList [(0, Bounds (Just 1) (Just 2))] simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds - expectedSimpleSystem = [Expr (VarTerm 0 :| []) :<= 2] + expectedSimpleSystem = [ExprVarsOnly (VarTermVO 0 : []) :<= 2] simplifiedSimpleSystem `shouldBe` expectedSimpleSystem it "removeUselssSystemBounds only removes constraints of the form x <= c" $ do let simpleSystem = - [ Expr (VarTerm 0 :| []) :<= 2 - , Expr (VarTerm 0 :| []) :<= 3 - , Expr (CoeffTerm 2 0 :| []) :<= 6 + [ ExprVarsOnly (VarTermVO 0 : []) :<= 2 + , ExprVarsOnly (VarTermVO 0 : []) :<= 3 + , ExprVarsOnly (CoeffTermVO 2 0 : []) :<= 6 ] bounds = Map.fromList [(0, Bounds (Just 0) (Just 2))] simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds - expectedSimpleSystem = [Expr (VarTerm 0 :| []) :<= 2, Expr (CoeffTerm 2 0 :| []) :<= 6] + expectedSimpleSystem = + [ ExprVarsOnly (VarTermVO 0 : []) :<= 2 + , ExprVarsOnly (CoeffTermVO 2 0 : []) :<= 6 + ] simplifiedSimpleSystem `shouldBe` expectedSimpleSystem diff --git a/test/TestUtil.hs b/test/TestUtil.hs index b2e5ddb..1432abe 100644 --- a/test/TestUtil.hs +++ b/test/TestUtil.hs @@ -16,13 +16,15 @@ import Linear.Constraint.Simple.Types (SimpleConstraint) import Linear.Constraint.Types ( Constraint (..) ) -import Linear.Expr.Types (Expr) -import Linear.Expr.Util (exprToList) +import Linear.Expr.Types (Expr, ExprVarsOnly) +import Linear.Expr.Util (exprToList, exprVarsOnlyToExpr) import Linear.Simplex.Types (VarLitMap) import Linear.System.Simple.Types (SimpleSystem) import Linear.Term.Types ( Term (..) + , TermVarsOnly ) +import Linear.Term.Util (termVarsOnlyToTerm) import Linear.Var.Types (SimplexNum, Var) import Test.QuickCheck (Arbitrary (..), Gen) import Prelude @@ -41,18 +43,24 @@ evalTerm varMap (Linear.Term.Types.VarTerm v) = v varMap +evalTermVarsOnly :: VarLitMap -> TermVarsOnly -> SimplexNum +evalTermVarsOnly varMap terms = evalTerm varMap $ termVarsOnlyToTerm terms + evalExpr :: VarLitMap -> Expr -> SimplexNum evalExpr varMap expr = sum $ map (evalTerm varMap) $ exprToList expr +evalExprVarsOnly :: VarLitMap -> ExprVarsOnly -> SimplexNum +evalExprVarsOnly varMap = evalExpr varMap . exprVarsOnlyToExpr + evalConstraint :: VarLitMap -> Constraint -> Bool evalConstraint varMap (lhs :<= rhs) = evalExpr varMap lhs <= evalExpr varMap rhs evalConstraint varMap (lhs :>= rhs) = evalExpr varMap lhs >= evalExpr varMap rhs evalConstraint varMap (lhs :== rhs) = evalExpr varMap lhs == evalExpr varMap rhs evalSimpleConstraint :: VarLitMap -> SimpleConstraint -> Bool -evalSimpleConstraint varMap (lhs :<= rhs) = evalExpr varMap lhs <= rhs -evalSimpleConstraint varMap (lhs :>= rhs) = evalExpr varMap lhs >= rhs -evalSimpleConstraint varMap (lhs :== rhs) = evalExpr varMap lhs == rhs +evalSimpleConstraint varMap (lhs :<= rhs) = evalExprVarsOnly varMap lhs <= rhs +evalSimpleConstraint varMap (lhs :>= rhs) = evalExprVarsOnly varMap lhs >= rhs +evalSimpleConstraint varMap (lhs :== rhs) = evalExprVarsOnly varMap lhs == rhs evalSimpleSystem :: VarLitMap -> SimpleSystem -> Bool evalSimpleSystem varMap = all (evalSimpleConstraint varMap) From f9571d76e1d3ce966217ff846b797607aee67e52 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 19 Oct 2024 18:40:27 +0100 Subject: [PATCH 43/47] wip --- src/Linear/Constraint/Linear/Types.hs | 2 + src/Linear/Constraint/Simple/Types.hs | 11 +- src/Linear/Constraint/Simple/Util.hs | 106 ++-- src/Linear/Constraint/Types.hs | 8 +- src/Linear/Constraint/Util.hs | 8 +- src/Linear/Expr/Types.hs | 2 +- src/Linear/Expr/Util.hs | 3 +- src/Linear/Simplex/Solver/Types.hs | 4 +- src/Linear/SlackForm/Types.hs | 22 +- src/Linear/SlackForm/Util.hs | 31 +- src/Linear/System/Linear/Types.hs | 1 + src/Linear/System/Linear/Util.hs | 25 + src/Linear/System/Simple/Types.hs | 40 +- src/Linear/System/Simple/Util.hs | 33 +- src/Linear/System/Types.hs | 4 + src/Linear/Term/Util.hs | 1 - src/Linear/Var/Types.hs | 5 + test/Linear/SlackForm/UtilSpec.hs | 679 +++++++++++++------------- test/Linear/System/Simple/UtilSpec.hs | 212 ++++---- test/TestUtil.hs | 18 +- 20 files changed, 650 insertions(+), 565 deletions(-) create mode 100644 src/Linear/System/Linear/Util.hs diff --git a/src/Linear/Constraint/Linear/Types.hs b/src/Linear/Constraint/Linear/Types.hs index 657153c..e42e2a4 100644 --- a/src/Linear/Constraint/Linear/Types.hs +++ b/src/Linear/Constraint/Linear/Types.hs @@ -11,6 +11,8 @@ import Linear.Expr.Types (ExprVarsOnly) import Linear.Var.Types (SimplexNum) -- lhs == rhs +-- TODO: Should I move this? Typicially, this would for a 'LinearConstraint', but I'm renaming 'Constraint' to 'LinearConstraint'. +-- TODO: Maybe I should move 'Constraint' here? data LinearEquation = LinearEquation { lhs :: ExprVarsOnly , rhs :: SimplexNum diff --git a/src/Linear/Constraint/Simple/Types.hs b/src/Linear/Constraint/Simple/Types.hs index 6ff8020..05640f9 100644 --- a/src/Linear/Constraint/Simple/Types.hs +++ b/src/Linear/Constraint/Simple/Types.hs @@ -10,5 +10,14 @@ module Linear.Constraint.Simple.Types where import Linear.Constraint.Generic.Types (GenericConstraint) import Linear.Expr.Types (ExprVarsOnly) import Linear.Var.Types (SimplexNum) +import GHC.Generics (Generic) +import Test.QuickCheck (Arbitrary (..)) -type SimpleConstraint = GenericConstraint ExprVarsOnly SimplexNum +newtype SimpleConstraint = SimpleConstraint { unSimpleConstraint :: GenericConstraint ExprVarsOnly SimplexNum } + deriving (Show, Eq, Read, Generic) + +instance Arbitrary SimpleConstraint where + arbitrary = SimpleConstraint <$> arbitrary + +class CanBeSimpleConstraint a where + toSimpleConstraint :: a -> SimpleConstraint diff --git a/src/Linear/Constraint/Simple/Util.hs b/src/Linear/Constraint/Simple/Util.hs index 06699b1..2583296 100644 --- a/src/Linear/Constraint/Simple/Util.hs +++ b/src/Linear/Constraint/Simple/Util.hs @@ -12,8 +12,8 @@ import qualified Data.Set as Set import Linear.Constraint.Generic.Types ( GenericConstraint (..) ) -import Linear.Constraint.Simple.Types (SimpleConstraint) -import Linear.Constraint.Types (Constraint) +import Linear.Constraint.Simple.Types (SimpleConstraint (..)) +import Linear.Constraint.Types (Constraint (..)) import Linear.Expr.Types (Expr (..), ExprVarsOnly (..)) import Linear.Expr.Util ( exprToExprVarsOnly @@ -34,31 +34,31 @@ import Linear.Var.Types (Var) substVarSimpleConstraintExpr :: Var -> Expr -> SimpleConstraint -> SimpleConstraint -substVarSimpleConstraintExpr var varReplacement (a :<= b) = +substVarSimpleConstraintExpr var varReplacement (SimpleConstraint (a :<= b)) = let newExpr = substVarExpr var varReplacement (exprVarsOnlyToExpr a) newConstraint = newExpr :<= Expr [ConstTerm b] - in constraintToSimpleConstraint newConstraint -substVarSimpleConstraintExpr var varReplacement (a :>= b) = + in constraintToSimpleConstraint $ Constraint newConstraint +substVarSimpleConstraintExpr var varReplacement (SimpleConstraint (a :>= b)) = let newExpr = substVarExpr var varReplacement (exprVarsOnlyToExpr a) newConstraint = newExpr :>= Expr [ConstTerm b] - in constraintToSimpleConstraint newConstraint -substVarSimpleConstraintExpr var varReplacement (a :== b) = + in constraintToSimpleConstraint $ Constraint newConstraint +substVarSimpleConstraintExpr var varReplacement (SimpleConstraint (a :== b)) = let newExpr = substVarExpr var varReplacement (exprVarsOnlyToExpr a) newConstraint = newExpr :== Expr [ConstTerm b] - in constraintToSimpleConstraint newConstraint + in constraintToSimpleConstraint $ Constraint newConstraint substVarSimpleConstraint :: Var -> ExprVarsOnly -> SimpleConstraint -> SimpleConstraint -substVarSimpleConstraint var varReplacement (a :<= b) = substVarExprVarsOnly var varReplacement a :<= b -substVarSimpleConstraint var varReplacement (a :>= b) = substVarExprVarsOnly var varReplacement a :>= b -substVarSimpleConstraint var varReplacement (a :== b) = substVarExprVarsOnly var varReplacement a :== b +substVarSimpleConstraint var varReplacement (SimpleConstraint (a :<= b)) = SimpleConstraint $ substVarExprVarsOnly var varReplacement a :<= b +substVarSimpleConstraint var varReplacement (SimpleConstraint (a :>= b)) = SimpleConstraint $ substVarExprVarsOnly var varReplacement a :>= b +substVarSimpleConstraint var varReplacement (SimpleConstraint (a :== b)) = SimpleConstraint $ substVarExprVarsOnly var varReplacement a :== b constraintToSimpleConstraint :: Constraint -> SimpleConstraint constraintToSimpleConstraint constraint = case constraint of - (a :<= b) -> uncurry (:<=) (calcLhsRhs a b) - (a :>= b) -> uncurry (:>=) (calcLhsRhs a b) - (a :== b) -> uncurry (:==) (calcLhsRhs a b) + Constraint (a :<= b) -> SimpleConstraint $ uncurry (:<=) (calcLhsRhs a b) + Constraint (a :>= b) -> SimpleConstraint $ uncurry (:>=) (calcLhsRhs a b) + Constraint (a :== b) -> SimpleConstraint $ uncurry (:==) (calcLhsRhs a b) where calcLhsRhs a b = (lhs, rhs) where @@ -76,70 +76,28 @@ constraintToSimpleConstraint constraint = error $ "constraintToSimpleConstraint: lhs is not ExprVarsOnly. Details: " <> err --- normalize simple constraints by moving all constants to the right --- normalizeSimpleConstraint :: SimpleConstraint -> SimpleConstraint --- normalizeSimpleConstraint (expr :<= num) = --- let exprList = exprToList expr - --- isConstTerm (ConstTerm _) = True --- isConstTerm _ = False - --- (sumExprConstTerms, nonConstTerms) = L.partition isConstTerm exprList - --- constTermsVal = sum . map (\case (ConstTerm c) -> c; _ -> 0) $ sumExprConstTerms - --- newExpr = listToExpr nonConstTerms --- newNum = num - constTermsVal --- in newExpr :<= newNum --- normalizeSimpleConstraint (expr :>= num) = --- let exprList = exprToList expr - --- isConstTerm (ConstTerm _) = True --- isConstTerm _ = False - --- (sumExprConstTerms, nonConstTerms) = L.partition isConstTerm exprList - --- constTermsVal = sum . map (\case (ConstTerm c) -> c; _ -> 0) $ sumExprConstTerms - --- newExpr = listToExpr nonConstTerms --- newNum = num - constTermsVal --- in newExpr :>= newNum --- normalizeSimpleConstraint (expr :== num) = --- let exprList = exprToList expr - --- isConstTerm (ConstTerm _) = True --- isConstTerm _ = False - --- (sumExprConstTerms, nonConstTerms) = L.partition isConstTerm exprList - --- constTermsVal = sum . map (\case (ConstTerm c) -> c; _ -> 0) $ sumExprConstTerms - --- newExpr = listToExpr nonConstTerms --- newNum = num - constTermsVal --- in newExpr :== newNum - -- | Simplify coeff constraints by dividing the coefficient from both sides simplifyCoeff :: SimpleConstraint -> SimpleConstraint -simplifyCoeff expr@(ExprVarsOnly [CoeffTermVO coeff var] :<= num) - | coeff == 0 = expr - | coeff > 0 = ExprVarsOnly [VarTermVO var] :<= (num / coeff) - | coeff < 0 = ExprVarsOnly [VarTermVO var] :>= (num / coeff) -simplifyCoeff expr@(ExprVarsOnly [CoeffTermVO coeff var] :>= num) - | coeff == 0 = expr - | coeff > 0 = ExprVarsOnly [VarTermVO var] :>= (num / coeff) - | coeff < 0 = ExprVarsOnly [VarTermVO var] :<= (num / coeff) -simplifyCoeff expr@(ExprVarsOnly [CoeffTermVO coeff var] :== num) = +simplifyCoeff simpleConstraint@(SimpleConstraint (ExprVarsOnly [CoeffTermVO coeff var] :<= num)) + | coeff == 0 = simpleConstraint + | coeff > 0 = SimpleConstraint $ ExprVarsOnly [VarTermVO var] :<= (num / coeff) + | coeff < 0 = SimpleConstraint $ ExprVarsOnly [VarTermVO var] :>= (num / coeff) +simplifyCoeff simpleConstraint@(SimpleConstraint (ExprVarsOnly [CoeffTermVO coeff var] :>= num)) + | coeff == 0 = simpleConstraint + | coeff > 0 = SimpleConstraint $ ExprVarsOnly [VarTermVO var] :>= (num / coeff) + | coeff < 0 = SimpleConstraint $ ExprVarsOnly [VarTermVO var] :<= (num / coeff) +simplifyCoeff simpleConstraint@(SimpleConstraint (ExprVarsOnly [CoeffTermVO coeff var] :== num)) = if coeff == 0 - then expr - else ExprVarsOnly [VarTermVO var] :== (num / coeff) -simplifyCoeff expr = expr + then simpleConstraint + else SimpleConstraint $ ExprVarsOnly [VarTermVO var] :== (num / coeff) +simplifyCoeff simpleConstraint = simpleConstraint simplifySimpleConstraint :: SimpleConstraint -> SimpleConstraint -simplifySimpleConstraint (expr :<= num) = simplifyCoeff $ simplifyExprVarsOnly expr :<= num -simplifySimpleConstraint (expr :>= num) = simplifyCoeff $ simplifyExprVarsOnly expr :>= num -simplifySimpleConstraint (expr :== num) = simplifyCoeff $ simplifyExprVarsOnly expr :== num +simplifySimpleConstraint (SimpleConstraint (expr :<= num)) = simplifyCoeff . SimpleConstraint $ simplifyExprVarsOnly expr :<= num +simplifySimpleConstraint (SimpleConstraint (expr :>= num)) = simplifyCoeff . SimpleConstraint $ simplifyExprVarsOnly expr :>= num +simplifySimpleConstraint (SimpleConstraint (expr :== num)) = simplifyCoeff . SimpleConstraint $ simplifyExprVarsOnly expr :== num simpleConstraintVars :: SimpleConstraint -> Set.Set Var -simpleConstraintVars (expr :<= _) = exprVars . exprVarsOnlyToExpr $ expr -simpleConstraintVars (expr :>= _) = exprVars . exprVarsOnlyToExpr $ expr -simpleConstraintVars (expr :== _) = exprVars . exprVarsOnlyToExpr $ expr +simpleConstraintVars (SimpleConstraint (expr :<= _)) = exprVars . exprVarsOnlyToExpr $ expr +simpleConstraintVars (SimpleConstraint (expr :>= _)) = exprVars . exprVarsOnlyToExpr $ expr +simpleConstraintVars (SimpleConstraint (expr :== _)) = exprVars . exprVarsOnlyToExpr $ expr diff --git a/src/Linear/Constraint/Types.hs b/src/Linear/Constraint/Types.hs index 0c74884..216d60a 100644 --- a/src/Linear/Constraint/Types.hs +++ b/src/Linear/Constraint/Types.hs @@ -11,6 +11,12 @@ import qualified Data.Set as Set import GHC.Generics (Generic) import Linear.Constraint.Generic.Types (GenericConstraint) import Linear.Expr.Types (Expr) +import Test.QuickCheck (Arbitrary (..)) -- Input -type Constraint = GenericConstraint Expr Expr +-- TODO: Consider LinearConstraint +newtype Constraint = Constraint {unConstraint :: GenericConstraint Expr Expr} + deriving (Show, Eq, Read, Generic) + +instance Arbitrary Constraint where + arbitrary = Constraint <$> arbitrary diff --git a/src/Linear/Constraint/Util.hs b/src/Linear/Constraint/Util.hs index 334790f..097ed29 100644 --- a/src/Linear/Constraint/Util.hs +++ b/src/Linear/Constraint/Util.hs @@ -11,11 +11,11 @@ import qualified Data.Set as Set import Linear.Constraint.Generic.Types ( GenericConstraint ((:<=), (:==), (:>=)) ) -import Linear.Constraint.Types (Constraint) +import Linear.Constraint.Types (Constraint (..)) import Linear.Expr.Util (exprVars) import Linear.Var.Types (Var) constraintVars :: Constraint -> Set.Set Var -constraintVars (lhs :<= rhs) = exprVars lhs <> exprVars rhs -constraintVars (lhs :>= rhs) = exprVars lhs <> exprVars rhs -constraintVars (lhs :== rhs) = exprVars lhs <> exprVars rhs +constraintVars (Constraint (lhs :<= rhs)) = exprVars lhs <> exprVars rhs +constraintVars (Constraint (lhs :>= rhs)) = exprVars lhs <> exprVars rhs +constraintVars (Constraint (lhs :== rhs)) = exprVars lhs <> exprVars rhs diff --git a/src/Linear/Expr/Types.hs b/src/Linear/Expr/Types.hs index 702593e..ac25fa5 100644 --- a/src/Linear/Expr/Types.hs +++ b/src/Linear/Expr/Types.hs @@ -11,8 +11,8 @@ import GHC.Generics (Generic) import Linear.Term.Types (Term, TermVarsOnly) import Test.QuickCheck (Arbitrary (..)) --- TODO: Use normal lists -- treat empty expr as 0 +-- Consider a version with a num instance, use + and * operators for the input newtype Expr = Expr {unExpr :: [Term]} deriving ( Show diff --git a/src/Linear/Expr/Util.hs b/src/Linear/Expr/Util.hs index 05abb09..76df7cb 100644 --- a/src/Linear/Expr/Util.hs +++ b/src/Linear/Expr/Util.hs @@ -121,8 +121,7 @@ exprToExprVarsOnly expr@(Expr ts) = do then if sumExprConstTerms expr == 0 then Right $ ExprVarsOnly [] - else - Left $ "safeExprToExprVarsOnly: Expr contains ConstTerm. Expr: " <> show expr + else Left $ "safeExprToExprVarsOnly: Expr contains ConstTerm. Expr: " <> show expr else Right $ unsafeExprToExprVarsOnly expr where isConstTerm :: Term -> Bool diff --git a/src/Linear/Simplex/Solver/Types.hs b/src/Linear/Simplex/Solver/Types.hs index 39aca4f..904635b 100644 --- a/src/Linear/Simplex/Solver/Types.hs +++ b/src/Linear/Simplex/Solver/Types.hs @@ -2,7 +2,7 @@ module Linear.Simplex.Solver.Types where import qualified Data.Map as Map import GHC.Generics (Generic) -import Linear.Expr.Types (Expr) +import Linear.Expr.Types (ExprVarsOnly) import Linear.System.Linear.Types (CanBeLinearSystem) import Linear.Var.Types (SimplexNum, Var) @@ -10,7 +10,7 @@ data OptimisationDirection = Minimize | Maximize deriving (Show, Eq, GHC.Generics.Generic) data Objective = Objective - { expr :: Linear.Expr.Types.Expr -- TODO: this should be ExprVarsOnly + { expr :: Linear.Expr.Types.ExprVarsOnly , direction :: OptimisationDirection } deriving (Show, Eq, GHC.Generics.Generic) diff --git a/src/Linear/SlackForm/Types.hs b/src/Linear/SlackForm/Types.hs index 33d5097..b737f53 100644 --- a/src/Linear/SlackForm/Types.hs +++ b/src/Linear/SlackForm/Types.hs @@ -7,18 +7,30 @@ -- Stability: experimental module Linear.SlackForm.Types where +import qualified Data.Set as Set import GHC.Generics (Generic) -import Linear.Expr.Types (Expr) -import Linear.System.Linear.Types (LinearSystem) +import Linear.Constraint.Linear.Types (LinearEquation (..)) +import Linear.Expr.Types (ExprVarsOnly) +import Linear.Expr.Util (exprVarsOnlyVars) +import Linear.System.Linear.Types (LinearSystem (..)) +import Linear.System.Simple.Types import Linear.Var.Types (SimplexNum, Var) -- Expr == SimplexNum +-- TODO: think about a better name for this type, CanonicalForm? data SlackForm = SlackForm - { maxObjective :: Expr -- TODO: should be ExprVarsOnly + { maxObjective :: ExprVarsOnly , constraints :: LinearSystem - , vars :: [Var] -- all vars are non-negative + , vars :: Set.Set Var -- all vars are non-negative } deriving (Show, Eq, Read, Generic) class CanBeSlackForm a where - toSlackForm :: a -> SlackForm + toSlackForm :: a -> ExprVarsOnly -> SlackForm + +instance CanBeSlackForm LinearSystem where + toSlackForm ls obj = + SlackForm + obj + ls + (Set.unions $ map (exprVarsOnlyVars . lhs) ls.unLinearSystem) diff --git a/src/Linear/SlackForm/Util.hs b/src/Linear/SlackForm/Util.hs index 95e5875..463e35b 100644 --- a/src/Linear/SlackForm/Util.hs +++ b/src/Linear/SlackForm/Util.hs @@ -7,6 +7,7 @@ -- Stability: experimental module Linear.SlackForm.Util where +import qualified Data.Bifunctor as Bifunctor import qualified Data.Map as Map import qualified Data.Maybe as Maybe import Linear.Constraint.Generic.Types @@ -14,6 +15,7 @@ import Linear.Constraint.Generic.Types ) import Linear.Constraint.Linear.Types (LinearEquation (..)) import qualified Linear.Constraint.Linear.Util as CLU +import Linear.Constraint.Simple.Types (SimpleConstraint (..)) import Linear.Constraint.Simple.Util ( substVarSimpleConstraintExpr ) @@ -22,7 +24,7 @@ import Linear.Expr.Util (exprVarsOnlyToExpr) import Linear.System.Linear.Types (LinearSystem (..)) import qualified Linear.System.Linear.Util as SLU import Linear.System.Simple.Types - ( SimpleSystem + ( SimpleSystem (..) , simplifySimpleSystem ) import qualified Linear.System.Simple.Types as SST @@ -37,28 +39,29 @@ import Linear.Var.Types (Bounds (..), Var, VarBounds) -- First step here https://en.wikipedia.org/wiki/Simplex_algorithm#Standard_form eliminateNonZeroLowerBounds :: SimpleSystem -> Map.Map Var Expr -> (Map.Map Var Expr, SimpleSystem) -eliminateNonZeroLowerBounds constraints eliminatedVarsMap = aux [] constraints +eliminateNonZeroLowerBounds constraints eliminatedVarsMap = aux [] constraints.unSimpleSystem where -- Eliminate non-zero lower bounds - - aux :: SimpleSystem -> SimpleSystem -> (Map.Map Var Expr, SimpleSystem) + aux :: + [SimpleConstraint] -> [SimpleConstraint] -> (Map.Map Var Expr, SimpleSystem) aux _ [] = (eliminatedVarsMap, constraints) aux checked (c : cs) = case c of -- x >= 5 - (ExprVarsOnly (VarTermVO var : []) :>= lowerBound) -> + (SimpleConstraint (ExprVarsOnly [VarTermVO var] :>= lowerBound)) -> if lowerBound == 0 then aux (checked ++ [c]) cs else - let newVar = SST.findHighestVar constraints + 1 + let newVar = SST.nextAvailableVar constraints -- y >= 0 - newVarLowerBound = ExprVarsOnly (VarTermVO newVar : []) :>= 0 + newVarLowerBound = SimpleConstraint $ ExprVarsOnly [VarTermVO newVar] :>= 0 -- x = y + 5 substOldVarWith = Expr (VarTerm newVar : [ConstTerm lowerBound]) substFn = substVarSimpleConstraintExpr var substOldVarWith newConstraints = - simplifySimpleSystem $ map substFn checked ++ newVarLowerBound : map substFn cs + simplifySimpleSystem . SimpleSystem $ + map substFn checked ++ newVarLowerBound : map substFn cs updatedEliminatedVarsMap = Map.insert var substOldVarWith eliminatedVarsMap in eliminateNonZeroLowerBounds newConstraints updatedEliminatedVarsMap -- TODO: Make more efficient if needed -- TODO: (do) Deal with == ? @@ -71,13 +74,12 @@ eliminateNonZeroLowerBounds constraints eliminatedVarsMap = aux [] constraints -- Return system of equalities and the slack variables addSlackVariables :: SimpleSystem -> ([Var], LinearSystem) addSlackVariables constraints = - let nextAvailableVar = SST.findHighestVar constraints + 1 - in aux constraints nextAvailableVar [] + let nextAvailableVar = SST.nextAvailableVar constraints + in aux constraints.unSimpleSystem nextAvailableVar [] where - aux :: SimpleSystem -> Var -> [Var] -> ([Var], LinearSystem) aux [] _ slackVars = (slackVars, LinearSystem []) aux (c : cs) nextVar slackVars = case c of - (expr@(ExprVarsOnly exprTs) :<= num) -> + (SimpleConstraint (ExprVarsOnly exprTs :<= num)) -> let slackVar = nextVar newNextVar = nextVar + 1 newExpr = ExprVarsOnly $ exprTs ++ [VarTermVO slackVar] @@ -86,7 +88,7 @@ addSlackVariables constraints = in ( nextVar : newSlackVars , SLU.prependLinearEquation (LinearEquation newExpr num) newConstraints ) - (expr@(ExprVarsOnly exprTs) :>= num) -> + (SimpleConstraint (ExprVarsOnly exprTs :>= num)) -> let slackVar = nextVar newNextVar = nextVar + 1 newExpr = ExprVarsOnly $ exprTs ++ [CoeffTermVO (-1) slackVar] @@ -95,7 +97,7 @@ addSlackVariables constraints = in ( nextVar : newSlackVars , SLU.prependLinearEquation (LinearEquation newExpr num) newConstraints ) - (expr :== num) -> + (SimpleConstraint (expr :== num)) -> let (newSlackVars, newConstraints) = aux cs nextVar slackVars in ( newSlackVars , SLU.prependLinearEquation (LinearEquation expr num) newConstraints @@ -126,7 +128,6 @@ eliminateUnrestrictedLowerBounds constraints varBoundMap eliminatedVarsMap = aux newConstraints = LinearSystem $ map (CLU.substVarWith var substOldVarWith) (unLinearSystem constraints) -- TODO: simplify? - -- TODO: Update this name updatedEliminatedVarsMap = Map.insert var (exprVarsOnlyToExpr substOldVarWith) eliminatedVarsMap in eliminateUnrestrictedLowerBounds newConstraints diff --git a/src/Linear/System/Linear/Types.hs b/src/Linear/System/Linear/Types.hs index cffe109..133bc3a 100644 --- a/src/Linear/System/Linear/Types.hs +++ b/src/Linear/System/Linear/Types.hs @@ -11,6 +11,7 @@ import GHC.Generics (Generic) import Linear.Constraint.Linear.Types (LinearEquation) import Linear.Expr.Types (Expr) +-- TODO: name this system of equations or something newtype LinearSystem = LinearSystem {unLinearSystem :: [LinearEquation]} deriving (Show, Eq, Read, Generic) diff --git a/src/Linear/System/Linear/Util.hs b/src/Linear/System/Linear/Util.hs new file mode 100644 index 0000000..dd6781a --- /dev/null +++ b/src/Linear/System/Linear/Util.hs @@ -0,0 +1,25 @@ +-- | +-- Module: Linear.System.Linear.Util +-- Description: Utility functions for linear programming systems +-- Copyright: (c) Junaid Rasheed, 2024 +-- License: BSD-3 +-- Maintainer: Junaid Rasheed +-- Stability: experimental +module Linear.System.Linear.Util where + +import Linear.Constraint.Linear.Types (LinearEquation (..)) +import qualified Linear.Constraint.Linear.Util as CLU +import Linear.System.Linear.Types (LinearSystem (..)) +import Linear.Var.Types (Var) + +-- | Prepend a linear equation to a linear system +prependLinearEquation :: LinearEquation -> LinearSystem -> LinearSystem +prependLinearEquation eq (LinearSystem eqs) = LinearSystem (eq : eqs) + +-- | Append a linear equation to a linear system +appendLinearEquation :: LinearEquation -> LinearSystem -> LinearSystem +appendLinearEquation eq (LinearSystem eqs) = LinearSystem (eqs ++ [eq]) + +findHighestVar :: LinearSystem -> Maybe Var +findHighestVar (LinearSystem []) = Nothing +findHighestVar (LinearSystem eqs) = Just $ maximum $ map CLU.findHighestVar eqs diff --git a/src/Linear/System/Simple/Types.hs b/src/Linear/System/Simple/Types.hs index 3b2d944..f671e22 100644 --- a/src/Linear/System/Simple/Types.hs +++ b/src/Linear/System/Simple/Types.hs @@ -16,22 +16,42 @@ import Linear.Constraint.Simple.Util , simplifySimpleConstraint ) import Linear.Expr.Util (exprVarsOnlyToList) +import Linear.System.Types (System) import Linear.Term.Types (TermVarsOnly (..)) import Linear.Var.Types (Var) +import Test.QuickCheck (Arbitrary (..)) -type SimpleSystem = [SimpleConstraint] +-- TODO: Use a more descriptive name +newtype SimpleSystem = SimpleSystem {unSimpleSystem :: [SimpleConstraint]} + deriving (Show, Eq, Read, Generic) + +instance Arbitrary SimpleSystem where + arbitrary = SimpleSystem <$> arbitrary simplifySimpleSystem :: SimpleSystem -> SimpleSystem -simplifySimpleSystem = map simplifySimpleConstraint +simplifySimpleSystem = SimpleSystem . map simplifySimpleConstraint . unSimpleSystem simpleSystemVars :: SimpleSystem -> Set.Set Var -simpleSystemVars = Set.unions . map simpleConstraintVars +simpleSystemVars = Set.unions . map simpleConstraintVars . unSimpleSystem -findHighestVar :: SimpleSystem -> Var +findHighestVar :: SimpleSystem -> Maybe Var findHighestVar simpleSystem = - let vars = - [ v | gc <- simpleSystem, term <- exprVarsOnlyToList $ getGenericConstraintLHS gc, v <- case term of - VarTermVO v -> [v] - CoeffTermVO _ v -> [v] - ] - in maximum vars + let vars = simpleSystemVars simpleSystem + in if Set.null vars + then Nothing + else Just $ Set.findMax vars + +nextAvailableVar :: SimpleSystem -> Var +nextAvailableVar simpleSystem = + case findHighestVar simpleSystem of + Just v -> v + 1 + Nothing -> 0 + +class CanBeSimpleSystem a where + toSimpleSystem :: a -> SimpleSystem + +instance CanBeSimpleSystem SimpleSystem where + toSimpleSystem = id + +instance CanBeSimpleSystem System where + toSimpleSystem = undefined diff --git a/src/Linear/System/Simple/Util.hs b/src/Linear/System/Simple/Util.hs index f514063..bdcd239 100644 --- a/src/Linear/System/Simple/Util.hs +++ b/src/Linear/System/Simple/Util.hs @@ -12,10 +12,10 @@ import qualified Data.Set as Set import Linear.Constraint.Generic.Types ( GenericConstraint ((:<=), (:==), (:>=)) ) -import Linear.Constraint.Simple.Types (SimpleConstraint) +import Linear.Constraint.Simple.Types (SimpleConstraint (..)) import Linear.Expr.Types (Expr (..), ExprVarsOnly (..)) import Linear.System.Simple.Types - ( SimpleSystem + ( SimpleSystem (..) , simpleSystemVars ) import Linear.Term.Types (Term (..), TermVarsOnly (..)) @@ -23,15 +23,15 @@ import Linear.Var.Types (Bounds (..), VarBounds) -- | Derive bounds for all variables in a system deriveBounds :: SimpleSystem -> VarBounds -deriveBounds simpleSystem = foldr updateBounds initialVarBounds simpleSystem +deriveBounds simpleSystem = foldr updateBounds initialVarBounds simpleSystem.unSimpleSystem where systemVars = simpleSystemVars simpleSystem initialVarBounds = M.fromList [(v, Bounds Nothing Nothing) | v <- Set.toList systemVars] updateBounds :: SimpleConstraint -> VarBounds -> VarBounds - updateBounds (ExprVarsOnly [VarTermVO var] :<= num) = M.insertWith mergeBounds var (Bounds Nothing (Just num)) - updateBounds (ExprVarsOnly [VarTermVO var] :>= num) = M.insertWith mergeBounds var (Bounds (Just num) Nothing) - updateBounds (ExprVarsOnly [VarTermVO var] :== num) = M.insertWith mergeBounds var (Bounds (Just num) (Just num)) + updateBounds (SimpleConstraint (ExprVarsOnly [VarTermVO var] :<= num)) = M.insertWith mergeBounds var (Bounds Nothing (Just num)) + updateBounds (SimpleConstraint (ExprVarsOnly [VarTermVO var] :>= num)) = M.insertWith mergeBounds var (Bounds (Just num) Nothing) + updateBounds (SimpleConstraint (ExprVarsOnly [VarTermVO var] :== num)) = M.insertWith mergeBounds var (Bounds (Just num) (Just num)) updateBounds _ = id -- \| Merge two bounds, very simple @@ -51,14 +51,15 @@ deriveBounds simpleSystem = foldr updateBounds initialVarBounds simpleSystem -- TODO: better name removeUselessSystemBounds :: SimpleSystem -> VarBounds -> SimpleSystem removeUselessSystemBounds constraints bounds = - filter - ( \case - (ExprVarsOnly [VarTermVO var] :<= num) -> case M.lookup var bounds of - Just (Bounds _ (Just upper)) -> num <= upper + SimpleSystem $ + filter + ( \case + (SimpleConstraint (ExprVarsOnly [VarTermVO var] :<= num)) -> case M.lookup var bounds of + Just (Bounds _ (Just upper)) -> num <= upper + _ -> True + (SimpleConstraint (ExprVarsOnly [VarTermVO var] :>= num)) -> case M.lookup var bounds of + Just (Bounds (Just lower) _) -> num >= lower + _ -> True _ -> True - (ExprVarsOnly [VarTermVO var] :>= num) -> case M.lookup var bounds of - Just (Bounds (Just lower) _) -> num >= lower - _ -> True - _ -> True - ) - constraints + ) + constraints.unSimpleSystem diff --git a/src/Linear/System/Types.hs b/src/Linear/System/Types.hs index 5a0c432..84a7a41 100644 --- a/src/Linear/System/Types.hs +++ b/src/Linear/System/Types.hs @@ -1,6 +1,10 @@ module Linear.System.Types where +import Linear.Constraint.Types (Constraint) + -- class System s where -- isFeasible :: s -> Bool -- TODO: create Sytem type, list of Constraints +newtype System = System {unSystem :: [Constraint]} + deriving (Show, Eq, Read) diff --git a/src/Linear/Term/Util.hs b/src/Linear/Term/Util.hs index 1966421..406293b 100644 --- a/src/Linear/Term/Util.hs +++ b/src/Linear/Term/Util.hs @@ -14,7 +14,6 @@ import Linear.Term.Types ) import Linear.Var.Types (Var) --- TODO: Test each function when reasonable simplifyTerm :: Term -> Term simplifyTerm (CoeffTerm 0 _) = ConstTerm 0 simplifyTerm (CoeffTerm 1 v) = VarTerm v diff --git a/src/Linear/Var/Types.hs b/src/Linear/Var/Types.hs index 38706a2..5100b10 100644 --- a/src/Linear/Var/Types.hs +++ b/src/Linear/Var/Types.hs @@ -3,8 +3,10 @@ module Linear.Var.Types where import qualified Data.Map as M import GHC.Generics (Generic) +-- TODO: Consider other names: SimplexCoeff, CoeffType type SimplexNum = Rational +-- TODO: newtype type Var = Int data Bounds = Bounds @@ -13,4 +15,7 @@ data Bounds = Bounds } deriving (Show, Read, Eq, Generic) +-- newtype VarBounds = VarBounds { unVarBounds :: M.Map Var Bounds } +-- deriving (Show, Read, Eq, Generic) + type VarBounds = M.Map Var Bounds diff --git a/test/Linear/SlackForm/UtilSpec.hs b/test/Linear/SlackForm/UtilSpec.hs index 927b66c..5f55cc4 100644 --- a/test/Linear/SlackForm/UtilSpec.hs +++ b/test/Linear/SlackForm/UtilSpec.hs @@ -19,6 +19,7 @@ import Linear.SlackForm.Util , eliminateUnrestrictedLowerBounds ) import Linear.System.Linear.Types (LinearSystem (..)) +import Linear.System.Simple.Types (SimpleSystem (..)) import Linear.System.Simple.Util (deriveBounds) import Linear.Term.Types ( Term (..) @@ -26,368 +27,386 @@ import Linear.Term.Types ) import Test.Hspec (Spec, describe, it, shouldBe) import Test.QuickCheck (Testable (property), withMaxSuccess) +import Linear.Constraint.Simple.Types (SimpleConstraint(..)) -- data Term = ConstTerm SimplexNum | CoeffTerm SimplexNum Var | VarTerm Var -- Consider VarTerm Var - note, we must consider normalizing this: Considered. It makes going to standard form easier due to type safety -- deriving (Show, Read, Eq, Ord, Generic) -- TODO: consider type NumberConstraint = GenericConstraint SimplexNum SimplexNum spec :: Spec -spec = do - describe "Slack Form Transformations" $ do - it - "eliminateNonZeroLowerBounds does not do anything when all lower bounds are zero" - $ do - let simpleSystem = - [ ExprVarsOnly (VarTermVO 0 : []) :>= 0 - , ExprVarsOnly (VarTermVO 1 : []) :>= 0 +spec = describe "Slack Form Transformations" $ do + it + "eliminateNonZeroLowerBounds does not do anything when all lower bounds are zero" + $ do + let simpleSystem = + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 0 ] - (updatedBounds, updatedSystem) = eliminateNonZeroLowerBounds simpleSystem Map.empty - expectedSimpleSystem = - [ ExprVarsOnly (VarTermVO 0 : []) :>= 0 - , ExprVarsOnly (VarTermVO 1 : []) :>= 0 + (updatedBounds, updatedSystem) = eliminateNonZeroLowerBounds simpleSystem Map.empty + expectedSimpleSystem = + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 0 ] - expectedEliminatedVarExprMap = Map.empty - updatedSystem `shouldBe` expectedSimpleSystem - updatedBounds `shouldBe` expectedEliminatedVarExprMap - it "eliminateNonZeroLowerBounds correctly eliminates positive lower bounds" $ do - let simpleSystem = - [ ExprVarsOnly (VarTermVO 0 : []) :>= 1 - , ExprVarsOnly (VarTermVO 1 : []) :>= 0 + expectedEliminatedVarExprMap = Map.empty + updatedSystem `shouldBe` expectedSimpleSystem + updatedBounds `shouldBe` expectedEliminatedVarExprMap + it "eliminateNonZeroLowerBounds correctly eliminates positive lower bounds" $ do + let simpleSystem = + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 0 + ] + (updatedBounds, updatedSystem) = eliminateNonZeroLowerBounds simpleSystem Map.empty + expectedSimpleSystem = + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 2] :>= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 0 + ] + expectedEliminatedVarExprMap = Map.fromList [(0, Expr (VarTerm 2 : [ConstTerm 1]))] + updatedSystem `shouldBe` expectedSimpleSystem + updatedBounds `shouldBe` expectedEliminatedVarExprMap + it "eliminateNonZeroLowerBounds correctly eliminates negative lower bounds" $ do + let simpleSystem = + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= (-1) + , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 0 ] + (updatedBounds, updatedSystem) = eliminateNonZeroLowerBounds simpleSystem Map.empty + expectedSimpleSystem = + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 2] :>= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 0 + ] + expectedEliminatedVarExprMap = Map.fromList [(0, Expr (VarTerm 2 : [ConstTerm (-1)]))] + updatedSystem `shouldBe` expectedSimpleSystem + updatedBounds `shouldBe` expectedEliminatedVarExprMap + it + "eliminateNonZeroLowerBounds correctly eliminates positive and negative lower bounds" + $ do + let simpleSystem = + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= (-1) + ] (updatedBounds, updatedSystem) = eliminateNonZeroLowerBounds simpleSystem Map.empty expectedSimpleSystem = - [ ExprVarsOnly (VarTermVO 2 : []) :>= 0 - , ExprVarsOnly (VarTermVO 1 : []) :>= 0 - ] - expectedEliminatedVarExprMap = Map.fromList [(0, Expr (VarTerm 2 : [ConstTerm 1]))] + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 2] :>= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 3] :>= 0 + ] + expectedEliminatedVarExprMap = + Map.fromList + [ (0, Expr (VarTerm 2 : [ConstTerm 1])) + , (1, Expr (VarTerm 3 : [ConstTerm (-1)])) + ] updatedSystem `shouldBe` expectedSimpleSystem updatedBounds `shouldBe` expectedEliminatedVarExprMap - it "eliminateNonZeroLowerBounds correctly eliminates negative lower bounds" $ do + it + "eliminateNonZeroLowerBounds correctly substitutes vars with non-zero lower bounds" + $ do let simpleSystem = - [ ExprVarsOnly (VarTermVO 0 : []) :>= (-1) - , ExprVarsOnly (VarTermVO 1 : []) :>= 0 - ] + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 0 + , SimpleConstraint $ ExprVarsOnly (VarTermVO 0 : [VarTermVO 1]) :>= 1 + ] (updatedBounds, updatedSystem) = eliminateNonZeroLowerBounds simpleSystem Map.empty expectedSimpleSystem = - [ ExprVarsOnly (VarTermVO 2 : []) :>= 0 - , ExprVarsOnly (VarTermVO 1 : []) :>= 0 - ] - expectedEliminatedVarExprMap = Map.fromList [(0, Expr (VarTerm 2 : [ConstTerm (-1)]))] + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 2] :>= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 0 + , SimpleConstraint $ ExprVarsOnly (VarTermVO 1 : [VarTermVO 2]) :>= 0 + ] + expectedEliminatedVarExprMap = Map.fromList [(0, Expr (VarTerm 2 : [ConstTerm 1]))] updatedSystem `shouldBe` expectedSimpleSystem updatedBounds `shouldBe` expectedEliminatedVarExprMap - it - "eliminateNonZeroLowerBounds correctly eliminates positive and negative lower bounds" - $ do - let simpleSystem = - [ ExprVarsOnly (VarTermVO 0 : []) :>= 1 - , ExprVarsOnly (VarTermVO 1 : []) :>= (-1) + it "eliminateNonZeroLowerBounds property based test lower bounds" $ withMaxSuccess 5 $ property $ \simpleSystem -> do + let (updatedBounds, updatedSystem) = eliminateNonZeroLowerBounds simpleSystem Map.empty + all + ( \case + SimpleConstraint (ExprVarsOnly [VarTermVO _] :>= num) -> num == 0 + _ -> True + ) + updatedSystem.unSimpleSystem + it "eliminateNonZeroLowerBounds property based test map" $ withMaxSuccess 5 $ property $ \simpleSystem -> do + let (updatedBounds, updatedSystem) = eliminateNonZeroLowerBounds simpleSystem Map.empty + all + ( \(var, _) -> + any + ( \(SimpleConstraint constraint) -> + let getVars _a = [] + lhs = getGenericConstraintLHS constraint + allVars = getVars lhs + in var `notElem` allVars + ) + updatedSystem.unSimpleSystem + ) + (Map.toList updatedBounds) + it + "addSlackVariables correctly transforms inequalities to equalities (wikipedia case)" + $ do + let simpleSystem = + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly (VarTermVO 2 : [CoeffTermVO 2 3]) :<= 3 -- x_2 + 2x_3 <= 3 + , SimpleConstraint $ ExprVarsOnly (CoeffTermVO (-1) 4 : [CoeffTermVO 3 5]) :>= 2 -- -x_4 + 3x_5 >= 2 + ] + expectedSystem = + LinearSystem + [ LinearEquation (ExprVarsOnly (VarTermVO 2 : [CoeffTermVO 2 3, VarTermVO 6])) 3 -- x_2 + 2x_3 + x_6 = 3 + , LinearEquation + (ExprVarsOnly (CoeffTermVO (-1) 4 : [CoeffTermVO 3 5, CoeffTermVO (-1) 7])) + 2 -- -x_4 + 3x_5 + x_7 = 2 ] - (updatedBounds, updatedSystem) = eliminateNonZeroLowerBounds simpleSystem Map.empty - expectedSimpleSystem = - [ ExprVarsOnly (VarTermVO 2 : []) :>= 0 - , ExprVarsOnly (VarTermVO 3 : []) :>= 0 + expectedSlackVars = [6, 7] + (slackVars, updatedSystem) = addSlackVariables simpleSystem + updatedSystem `shouldBe` expectedSystem + slackVars `shouldBe` expectedSlackVars + it + "addSlackVariables correctly transforms inequalities to equalities (test case 1)" + $ do + let simpleSystem = + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 2]) :<= 4 -- x_1 + 2x_2 <= 4 + , SimpleConstraint $ ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4]) :>= 3 -- -x_3 + 2x_4 >= 3 ] - expectedEliminatedVarExprMap = - Map.fromList - [ (0, Expr (VarTerm 2 : [ConstTerm 1])) - , (1, Expr (VarTerm 3 : [ConstTerm (-1)])) - ] - updatedSystem `shouldBe` expectedSimpleSystem - updatedBounds `shouldBe` expectedEliminatedVarExprMap - it - "eliminateNonZeroLowerBounds correctly substitutes vars with non-zero lower bounds" - $ do - let simpleSystem = - [ ExprVarsOnly (VarTermVO 0 : []) :>= 1 - , ExprVarsOnly (VarTermVO 1 : []) :>= 0 - , ExprVarsOnly (VarTermVO 0 : [VarTermVO 1]) :>= 1 + expectedSystem = + LinearSystem + [ LinearEquation (ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 2, VarTermVO 5])) 4 -- x_1 + 2x_2 + x_5 = 4 + , LinearEquation + (ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4, CoeffTermVO (-1) 6])) + 3 -- -x_3 + 2x_4 - x_6 = 3 + ] + expectedSlackVars = [5, 6] + (slackVars, updatedSystem) = addSlackVariables simpleSystem + updatedSystem `shouldBe` expectedSystem + slackVars `shouldBe` expectedSlackVars + it + "addSlackVariables correctly transforms inequalities to equalities (test case 2)" + $ do + let simpleSystem = + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 2]) :<= 5 -- x_1 + 2x_2 <= 5 + , SimpleConstraint $ ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4]) :>= 4 -- -x_3 + 2x_4 >= 4 ] - (updatedBounds, updatedSystem) = eliminateNonZeroLowerBounds simpleSystem Map.empty - expectedSimpleSystem = - [ ExprVarsOnly (VarTermVO 2 : []) :>= 0 - , ExprVarsOnly (VarTermVO 1 : []) :>= 0 - , ExprVarsOnly (VarTermVO 1 : [VarTermVO 2]) :>= 0 + expectedSystem = + LinearSystem + [ LinearEquation (ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 2, VarTermVO 5])) 5 -- x_1 + 2x_2 + x_5 = 5 + , LinearEquation + (ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4, CoeffTermVO (-1) 6])) + 4 -- -x_3 + 2x_4 - x_6 = 4 ] - expectedEliminatedVarExprMap = Map.fromList [(0, Expr (VarTerm 2 : [ConstTerm 1]))] - updatedSystem `shouldBe` expectedSimpleSystem - updatedBounds `shouldBe` expectedEliminatedVarExprMap - it "eliminateNonZeroLowerBounds property based test lower bounds" $ do - withMaxSuccess 5 $ property $ \simpleSystem -> do - let (updatedBounds, updatedSystem) = eliminateNonZeroLowerBounds simpleSystem Map.empty - all - ( \case - ExprVarsOnly (VarTermVO _ : []) :>= num -> num == 0 - _ -> True - ) - updatedSystem - it "eliminateNonZeroLowerBounds property based test map" $ do - withMaxSuccess 5 $ property $ \simpleSystem -> do - let (updatedBounds, updatedSystem) = eliminateNonZeroLowerBounds simpleSystem Map.empty - all - ( \(var, _) -> - any - ( \constraint -> - let getVars _a = [] - lhs = getGenericConstraintLHS constraint - allVars = getVars lhs - in var `notElem` allVars - ) - updatedSystem - ) - (Map.toList updatedBounds) - it - "addSlackVariables correctly transforms inequalities to equalities (wikipedia case)" - $ do - let simpleSystem = - [ ExprVarsOnly (VarTermVO 2 : [CoeffTermVO 2 3]) :<= 3 -- x_2 + 2x_3 <= 3 - , ExprVarsOnly (CoeffTermVO (-1) 4 : [CoeffTermVO 3 5]) :>= 2 -- -x_4 + 3x_5 >= 2 + expectedSlackVars = [5, 6] + (slackVars, updatedSystem) = addSlackVariables simpleSystem + updatedSystem `shouldBe` expectedSystem + slackVars `shouldBe` expectedSlackVars + it + "addSlackVariables correctly transforms inequalities to equalities (test case 3)" + $ do + let simpleSystem = + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 2]) :<= 5 -- x_1 + 2x_2 <= 5 + , SimpleConstraint $ ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4]) :== 4 -- -x_3 + 2x_4 = 4 ] - expectedSystem = - LinearSystem - [ LinearEquation (ExprVarsOnly (VarTermVO 2 : [CoeffTermVO 2 3, VarTermVO 6])) 3 -- x_2 + 2x_3 + x_6 = 3 - , LinearEquation - (ExprVarsOnly (CoeffTermVO (-1) 4 : [CoeffTermVO 3 5, CoeffTermVO (-1) 7])) - 2 -- -x_4 + 3x_5 + x_7 = 2 - ] - expectedSlackVars = [6, 7] - (slackVars, updatedSystem) = addSlackVariables simpleSystem - updatedSystem `shouldBe` expectedSystem - slackVars `shouldBe` expectedSlackVars - it - "addSlackVariables correctly transforms inequalities to equalities (test case 1)" - $ do - let simpleSystem = - [ ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 2]) :<= 4 -- x_1 + 2x_2 <= 4 - , ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4]) :>= 3 -- -x_3 + 2x_4 >= 3 + expectedSystem = + LinearSystem + [ LinearEquation (ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 2, VarTermVO 5])) 5 -- x_1 + 2x_2 + x_5 = 5 + , LinearEquation (ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4])) 4 -- -x_3 + 2x_4 = 4 ] - expectedSystem = - LinearSystem - [ LinearEquation (ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 2, VarTermVO 5])) 4 -- x_1 + 2x_2 + x_5 = 4 - , LinearEquation - (ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4, CoeffTermVO (-1) 6])) - 3 -- -x_3 + 2x_4 - x_6 = 3 - ] - expectedSlackVars = [5, 6] - (slackVars, updatedSystem) = addSlackVariables simpleSystem - updatedSystem `shouldBe` expectedSystem - slackVars `shouldBe` expectedSlackVars - it - "addSlackVariables correctly transforms inequalities to equalities (test case 2)" - $ do - let simpleSystem = - [ ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 2]) :<= 5 -- x_1 + 2x_2 <= 5 - , ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4]) :>= 4 -- -x_3 + 2x_4 >= 4 + expectedSlackVars = [5] + (slackVars, updatedSystem) = addSlackVariables simpleSystem + updatedSystem `shouldBe` expectedSystem + slackVars `shouldBe` expectedSlackVars + it + "addSlackVariables correctly transforms inequalities to equalities (test case 4)" + $ do + let simpleSystem = + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 2]) :== 5 -- x_1 + 2x_2 = 5 + , SimpleConstraint $ ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4]) :== 4 -- -x_3 + 2x_4 = 4 ] - expectedSystem = - LinearSystem - [ LinearEquation (ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 2, VarTermVO 5])) 5 -- x_1 + 2x_2 + x_5 = 5 - , LinearEquation - (ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4, CoeffTermVO (-1) 6])) - 4 -- -x_3 + 2x_4 - x_6 = 4 - ] - expectedSlackVars = [5, 6] - (slackVars, updatedSystem) = addSlackVariables simpleSystem - updatedSystem `shouldBe` expectedSystem - slackVars `shouldBe` expectedSlackVars - it - "addSlackVariables correctly transforms inequalities to equalities (test case 3)" - $ do - let simpleSystem = - [ ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 2]) :<= 5 -- x_1 + 2x_2 <= 5 - , ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4]) :== 4 -- -x_3 + 2x_4 = 4 + expectedSystem = + LinearSystem + [ LinearEquation (ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 2])) 5 -- x_1 + 2x_2 = 5 + , LinearEquation (ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4])) 4 -- -x_3 + 2x_4 = 4 ] - expectedSystem = - LinearSystem - [ LinearEquation (ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 2, VarTermVO 5])) 5 -- x_1 + 2x_2 + x_5 = 5 - , LinearEquation (ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4])) 4 -- -x_3 + 2x_4 = 4 - ] - expectedSlackVars = [5] - (slackVars, updatedSystem) = addSlackVariables simpleSystem - updatedSystem `shouldBe` expectedSystem - slackVars `shouldBe` expectedSlackVars - it - "addSlackVariables correctly transforms inequalities to equalities (test case 4)" - $ do - let simpleSystem = - [ ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 2]) :== 5 -- x_1 + 2x_2 = 5 - , ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4]) :== 4 -- -x_3 + 2x_4 = 4 + expectedSlackVars = [] + (slackVars, updatedSystem) = addSlackVariables simpleSystem + updatedSystem `shouldBe` expectedSystem + slackVars `shouldBe` expectedSlackVars + it + "eliminateUnrestrictedLowerBounds correctly eliminates unrestricted lower bounds (wikipedia case)" + $ do + let simpleSystem = + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 0 -- x_1 >= 0 + , SimpleConstraint $ ExprVarsOnly (VarTermVO 1 : [VarTermVO 2]) :>= 0 -- x_1 + x_2 >= 0 ] - expectedSystem = - LinearSystem - [ LinearEquation (ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 2])) 5 -- x_1 + 2x_2 = 5 - , LinearEquation (ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4])) 4 -- -x_3 + 2x_4 = 4 - ] - expectedSlackVars = [] - (slackVars, updatedSystem) = addSlackVariables simpleSystem - updatedSystem `shouldBe` expectedSystem - slackVars `shouldBe` expectedSlackVars - it - "eliminateUnrestrictedLowerBounds correctly eliminates unrestricted lower bounds (wikipedia case)" - $ do - let simpleSystem = - [ ExprVarsOnly (VarTermVO 1 : []) :>= 0 -- x_1 >= 0 - , ExprVarsOnly (VarTermVO 1 : [VarTermVO 2]) :>= 0 -- x_1 + x_2 >= 0 + systemBounds = deriveBounds simpleSystem + (eliminatedNonZeroLowerBounds, systemWithoutNonZeroLowerBounds) = eliminateNonZeroLowerBounds simpleSystem Map.empty + (slackVars, systemWithSlackVars) = addSlackVariables systemWithoutNonZeroLowerBounds + (updatedEliminatedVarsMap, updatedSystem) = + eliminateUnrestrictedLowerBounds + systemWithSlackVars + systemBounds + eliminatedNonZeroLowerBounds + expectedSlackVars = [3, 4] + expectedSystem = + LinearSystem + [ LinearEquation (ExprVarsOnly (CoeffTermVO (-1) 3 : [VarTermVO 1])) 0 -- -x_3 + x_1 = 0 + , LinearEquation + ( ExprVarsOnly + (CoeffTermVO (-1) 4 : [CoeffTermVO (-1) 6, VarTermVO 1, VarTermVO 5]) + ) + 0 -- -x_4 - x_6 + x_1 + x_5 = 0 ] - systemBounds = deriveBounds simpleSystem - (eliminatedNonZeroLowerBounds, systemWithoutNonZeroLowerBounds) = eliminateNonZeroLowerBounds simpleSystem Map.empty - (slackVars, systemWithSlackVars) = addSlackVariables systemWithoutNonZeroLowerBounds - (updatedEliminatedVarsMap, updatedSystem) = - eliminateUnrestrictedLowerBounds - systemWithSlackVars - systemBounds - eliminatedNonZeroLowerBounds - expectedSlackVars = [3, 4] - expectedSystem = - LinearSystem - [ LinearEquation (ExprVarsOnly (CoeffTermVO (-1) 3 : [VarTermVO 1])) 0 -- -x_3 + x_1 = 0 - , LinearEquation - ( ExprVarsOnly - (CoeffTermVO (-1) 4 : [CoeffTermVO (-1) 6, VarTermVO 1, VarTermVO 5]) - ) - 0 -- -x_4 - x_6 + x_1 + x_5 = 0 - ] - expectedEliminatedVarExprMap = Map.fromList [(2, Expr (VarTerm 5 : [CoeffTerm (-1) 6]))] + expectedEliminatedVarExprMap = Map.fromList [(2, Expr (VarTerm 5 : [CoeffTerm (-1) 6]))] - slackVars `shouldBe` expectedSlackVars - updatedSystem `shouldBe` expectedSystem - updatedEliminatedVarsMap `shouldBe` expectedEliminatedVarExprMap - it - "eliminateUnrestrictedLowerBounds correctly eliminates unrestricted lower bounds (test case 2)" - $ do - let simpleSystem = - [ ExprVarsOnly (VarTermVO 1 : []) :>= 0 -- x_1 >= 0 - , ExprVarsOnly (VarTermVO 1 : [VarTermVO 2, VarTermVO 3]) :>= 0 -- x_1 + x_2 + x_3 >= 0 + slackVars `shouldBe` expectedSlackVars + updatedSystem `shouldBe` expectedSystem + updatedEliminatedVarsMap `shouldBe` expectedEliminatedVarExprMap + it + "eliminateUnrestrictedLowerBounds correctly eliminates unrestricted lower bounds (test case 2)" + $ do + let simpleSystem = + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 0 -- x_1 >= 0 + , SimpleConstraint $ ExprVarsOnly (VarTermVO 1 : [VarTermVO 2, VarTermVO 3]) :>= 0 -- x_1 + x_2 + x_3 >= 0 + ] + systemBounds = deriveBounds simpleSystem + (eliminatedNonZeroLowerBounds, systemWithoutNonZeroLowerBounds) = eliminateNonZeroLowerBounds simpleSystem Map.empty + (slackVars, systemWithSlackVars) = addSlackVariables systemWithoutNonZeroLowerBounds + (updatedEliminatedVarsMap, updatedSystem) = + eliminateUnrestrictedLowerBounds + systemWithSlackVars + systemBounds + eliminatedNonZeroLowerBounds + expectedSlackVars = [4, 5] + expectedSystem = + LinearSystem + [ LinearEquation (ExprVarsOnly (CoeffTermVO (-1) 4 : [VarTermVO 1])) 0 -- -x_4 + x_1 = 0 + , LinearEquation + ( ExprVarsOnly + ( CoeffTermVO (-1) 5 + : [CoeffTermVO (-1) 7, CoeffTermVO (-1) 9, VarTermVO 1, VarTermVO 6, VarTermVO 8] + ) + ) + 0 -- -x_5 - x_7 - x_9 + x_1 + x_6 + x_8 = 0 ] - systemBounds = deriveBounds simpleSystem - (eliminatedNonZeroLowerBounds, systemWithoutNonZeroLowerBounds) = eliminateNonZeroLowerBounds simpleSystem Map.empty - (slackVars, systemWithSlackVars) = addSlackVariables systemWithoutNonZeroLowerBounds - (updatedEliminatedVarsMap, updatedSystem) = - eliminateUnrestrictedLowerBounds - systemWithSlackVars - systemBounds - eliminatedNonZeroLowerBounds - expectedSlackVars = [4, 5] - expectedSystem = - LinearSystem - [ LinearEquation (ExprVarsOnly (CoeffTermVO (-1) 4 : [VarTermVO 1])) 0 -- -x_4 + x_1 = 0 - , LinearEquation - ( ExprVarsOnly - ( CoeffTermVO (-1) 5 - : [CoeffTermVO (-1) 7, CoeffTermVO (-1) 9, VarTermVO 1, VarTermVO 6, VarTermVO 8] - ) - ) - 0 -- -x_5 - x_7 - x_9 + x_1 + x_6 + x_8 = 0 - ] - expectedEliminatedVarExprMap = - Map.fromList - [ (2, Expr (VarTerm 6 : [CoeffTerm (-1) 7])) - , (3, Expr (VarTerm 8 : [CoeffTerm (-1) 9])) - ] - slackVars `shouldBe` expectedSlackVars - updatedSystem `shouldBe` expectedSystem - updatedEliminatedVarsMap `shouldBe` expectedEliminatedVarExprMap + expectedEliminatedVarExprMap = + Map.fromList + [ (2, Expr (VarTerm 6 : [CoeffTerm (-1) 7])) + , (3, Expr (VarTerm 8 : [CoeffTerm (-1) 9])) + ] + slackVars `shouldBe` expectedSlackVars + updatedSystem `shouldBe` expectedSystem + updatedEliminatedVarsMap `shouldBe` expectedEliminatedVarExprMap - it - "eliminateUnrestrictedLowerBounds correctly eliminates unrestricted lower bounds (test case 3)" - $ do - let simpleSystem = - [ ExprVarsOnly (VarTermVO 1 : []) :>= 0 -- x_1 >= 0 - , ExprVarsOnly (VarTermVO 1 : [VarTermVO 2]) :>= 0 -- x_1 + x_2 >= 0 - , ExprVarsOnly (VarTermVO 2 : [VarTermVO 3]) :>= 0 -- x_2 + x_3 >= 0 + it + "eliminateUnrestrictedLowerBounds correctly eliminates unrestricted lower bounds (test case 3)" + $ do + let simpleSystem = + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 0 -- x_1 >= 0 + , SimpleConstraint $ ExprVarsOnly (VarTermVO 1 : [VarTermVO 2]) :>= 0 -- x_1 + x_2 >= 0 + , SimpleConstraint $ ExprVarsOnly (VarTermVO 2 : [VarTermVO 3]) :>= 0 -- x_2 + x_3 >= 0 + ] + systemBounds = deriveBounds simpleSystem + (eliminatedNonZeroLowerBounds, systemWithoutNonZeroLowerBounds) = eliminateNonZeroLowerBounds simpleSystem Map.empty + (slackVars, systemWithSlackVars) = addSlackVariables systemWithoutNonZeroLowerBounds + expectedSlackVars = [4, 5, 6] + (updatedEliminatedVarsMap, updatedSystem) = + eliminateUnrestrictedLowerBounds + systemWithSlackVars + systemBounds + eliminatedNonZeroLowerBounds + expectedSystem = + LinearSystem + [ LinearEquation (ExprVarsOnly (CoeffTermVO (-1) 4 : [VarTermVO 1])) 0 -- -x_4 + x_1 = 0 + , LinearEquation + ( ExprVarsOnly + (CoeffTermVO (-1) 5 : [CoeffTermVO (-1) 8, VarTermVO 1, VarTermVO 7]) + ) + 0 -- -x_5 - x_8 + x_1 + x_7 = 0 + , LinearEquation + ( ExprVarsOnly + ( CoeffTermVO (-1) 6 + : [CoeffTermVO (-1) 8, CoeffTermVO (-1) 10, VarTermVO 7, VarTermVO 9] + ) + ) + 0 -- -x_6 - x_8 - x_10 + x_7 + x_9 = 0 ] - systemBounds = deriveBounds simpleSystem - (eliminatedNonZeroLowerBounds, systemWithoutNonZeroLowerBounds) = eliminateNonZeroLowerBounds simpleSystem Map.empty - (slackVars, systemWithSlackVars) = addSlackVariables systemWithoutNonZeroLowerBounds - expectedSlackVars = [4, 5, 6] - (updatedEliminatedVarsMap, updatedSystem) = - eliminateUnrestrictedLowerBounds - systemWithSlackVars - systemBounds - eliminatedNonZeroLowerBounds - expectedSystem = - LinearSystem - [ LinearEquation (ExprVarsOnly (CoeffTermVO (-1) 4 : [VarTermVO 1])) 0 -- -x_4 + x_1 = 0 - , LinearEquation - ( ExprVarsOnly - (CoeffTermVO (-1) 5 : [CoeffTermVO (-1) 8, VarTermVO 1, VarTermVO 7]) - ) - 0 -- -x_5 - x_8 + x_1 + x_7 = 0 - , LinearEquation - ( ExprVarsOnly - ( CoeffTermVO (-1) 6 - : [CoeffTermVO (-1) 8, CoeffTermVO (-1) 10, VarTermVO 7, VarTermVO 9] - ) - ) - 0 -- -x_6 - x_8 - x_10 + x_7 + x_9 = 0 - ] - expectedEliminatedVarExprMap = - Map.fromList - [ (2, Expr (VarTerm 7 : [CoeffTerm (-1) 8])) - , (3, Expr (VarTerm 9 : [CoeffTerm (-1) 10])) - ] - slackVars `shouldBe` expectedSlackVars - updatedSystem `shouldBe` expectedSystem - updatedEliminatedVarsMap `shouldBe` expectedEliminatedVarExprMap - it - "eliminateUnrestrictedLowerBounds correctly eliminates non-zero lower bounds for all variables" - $ do - let simpleSystem = - [ ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 1]) :>= 0 -- x_1 + 2x_1 >= 0 - , ExprVarsOnly (VarTermVO 2 : [CoeffTermVO 3 1]) :>= 0 -- x_2 + 3x_1 >= 0 + expectedEliminatedVarExprMap = + Map.fromList + [ (2, Expr (VarTerm 7 : [CoeffTerm (-1) 8])) + , (3, Expr (VarTerm 9 : [CoeffTerm (-1) 10])) + ] + slackVars `shouldBe` expectedSlackVars + updatedSystem `shouldBe` expectedSystem + updatedEliminatedVarsMap `shouldBe` expectedEliminatedVarExprMap + it + "eliminateUnrestrictedLowerBounds correctly eliminates non-zero lower bounds for all variables" + $ do + let simpleSystem = + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 1]) :>= 0 -- x_1 + 2x_1 >= 0 + , SimpleConstraint $ ExprVarsOnly (VarTermVO 2 : [CoeffTermVO 3 1]) :>= 0 -- x_2 + 3x_1 >= 0 ] - systemBounds = deriveBounds simpleSystem - (eliminatedNonZeroLowerBounds, systemWithoutNonZeroLowerBounds) = eliminateNonZeroLowerBounds simpleSystem Map.empty - (slackVars, systemWithSlackVars) = addSlackVariables systemWithoutNonZeroLowerBounds - expectedSlackVars = [3, 4] - (updatedEliminatedVarsMap, updatedSystem) = - eliminateUnrestrictedLowerBounds - systemWithSlackVars - systemBounds - eliminatedNonZeroLowerBounds - expectedSystem = - LinearSystem - [ LinearEquation - (ExprVarsOnly (CoeffTermVO (-3) 6 : [CoeffTermVO (-1) 3, CoeffTermVO 3 5])) - 0 -- -3x_6 - x_3 + 3x_5 = 0 - , LinearEquation - ( ExprVarsOnly - ( CoeffTermVO (-3) 6 - : [CoeffTermVO (-1) 4, CoeffTermVO (-1) 8, CoeffTermVO 3 5, VarTermVO 7] - ) - ) - 0 -- -3x_6 - x_4 - x_8 + 3x_5 + x_7 = 0 - ] - expectedEliminatedVarExprMap = - Map.fromList - [ (1, Expr (VarTerm 5 : [CoeffTerm (-1) 6])) - , (2, Expr (VarTerm 7 : [CoeffTerm (-1) 8])) - ] - slackVars `shouldBe` expectedSlackVars - updatedSystem `shouldBe` expectedSystem - updatedEliminatedVarsMap `shouldBe` expectedEliminatedVarExprMap + systemBounds = deriveBounds simpleSystem + (eliminatedNonZeroLowerBounds, systemWithoutNonZeroLowerBounds) = eliminateNonZeroLowerBounds simpleSystem Map.empty + (slackVars, systemWithSlackVars) = addSlackVariables systemWithoutNonZeroLowerBounds + expectedSlackVars = [3, 4] + (updatedEliminatedVarsMap, updatedSystem) = + eliminateUnrestrictedLowerBounds + systemWithSlackVars + systemBounds + eliminatedNonZeroLowerBounds + expectedSystem = + LinearSystem + [ LinearEquation + (ExprVarsOnly (CoeffTermVO (-3) 6 : [CoeffTermVO (-1) 3, CoeffTermVO 3 5])) + 0 -- -3x_6 - x_3 + 3x_5 = 0 + , LinearEquation + ( ExprVarsOnly + ( CoeffTermVO (-3) 6 + : [CoeffTermVO (-1) 4, CoeffTermVO (-1) 8, CoeffTermVO 3 5, VarTermVO 7] + ) + ) + 0 -- -3x_6 - x_4 - x_8 + 3x_5 + x_7 = 0 + ] + expectedEliminatedVarExprMap = + Map.fromList + [ (1, Expr (VarTerm 5 : [CoeffTerm (-1) 6])) + , (2, Expr (VarTerm 7 : [CoeffTerm (-1) 8])) + ] + slackVars `shouldBe` expectedSlackVars + updatedSystem `shouldBe` expectedSystem + updatedEliminatedVarsMap `shouldBe` expectedEliminatedVarExprMap - it - "eliminateUnrestrictedLowerBounds correctly handles all variables with zero lower bounds" - $ do - let simpleSystem = - [ ExprVarsOnly (VarTermVO 1 : []) :>= 0 -- x_1 >= 0 - , ExprVarsOnly (VarTermVO 2 : []) :>= 0 -- x_2 >= 0 + it + "eliminateUnrestrictedLowerBounds correctly handles all variables with zero lower bounds" + $ do + let simpleSystem = + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 0 -- x_1 >= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 2] :>= 0 -- x_2 >= 0 + ] + systemBounds = deriveBounds simpleSystem + (eliminatedNonZeroLowerBounds, systemWithoutNonZeroLowerBounds) = eliminateNonZeroLowerBounds simpleSystem Map.empty + (slackVars, systemWithSlackVars) = addSlackVariables systemWithoutNonZeroLowerBounds + expectedSlackVars = [3, 4] + (updatedEliminatedVarsMap, updatedSystem) = + eliminateUnrestrictedLowerBounds + systemWithSlackVars + systemBounds + eliminatedNonZeroLowerBounds + expectedSystem = + LinearSystem + [ LinearEquation (ExprVarsOnly (VarTermVO 1 : [CoeffTermVO (-1) 3])) 0 -- x_1 - x_3 = 0 + , LinearEquation (ExprVarsOnly (VarTermVO 2 : [CoeffTermVO (-1) 4])) 0 -- x_2 - x_4 = 0 ] - systemBounds = deriveBounds simpleSystem - (eliminatedNonZeroLowerBounds, systemWithoutNonZeroLowerBounds) = eliminateNonZeroLowerBounds simpleSystem Map.empty - (slackVars, systemWithSlackVars) = addSlackVariables systemWithoutNonZeroLowerBounds - expectedSlackVars = [3, 4] - (updatedEliminatedVarsMap, updatedSystem) = - eliminateUnrestrictedLowerBounds - systemWithSlackVars - systemBounds - eliminatedNonZeroLowerBounds - expectedSystem = - LinearSystem - [ LinearEquation (ExprVarsOnly (VarTermVO 1 : [CoeffTermVO (-1) 3])) 0 -- x_1 - x_3 = 0 - , LinearEquation (ExprVarsOnly (VarTermVO 2 : [CoeffTermVO (-1) 4])) 0 -- x_2 - x_4 = 0 - ] - expectedEliminatedVarExprMap = Map.empty - slackVars `shouldBe` expectedSlackVars - updatedSystem `shouldBe` expectedSystem - updatedEliminatedVarsMap `shouldBe` expectedEliminatedVarExprMap + expectedEliminatedVarExprMap = Map.empty + slackVars `shouldBe` expectedSlackVars + updatedSystem `shouldBe` expectedSystem + updatedEliminatedVarsMap `shouldBe` expectedEliminatedVarExprMap diff --git a/test/Linear/System/Simple/UtilSpec.hs b/test/Linear/System/Simple/UtilSpec.hs index 7e881a0..6633867 100644 --- a/test/Linear/System/Simple/UtilSpec.hs +++ b/test/Linear/System/Simple/UtilSpec.hs @@ -15,7 +15,8 @@ import Linear.Constraint.Generic.Types ) import Linear.Expr.Types (ExprVarsOnly (..)) import Linear.System.Simple.Types - ( findHighestVar + ( SimpleSystem (SimpleSystem) + , findHighestVar , simpleSystemVars , simplifySimpleSystem ) @@ -30,6 +31,7 @@ import Test.Hspec (Spec, describe, it, shouldBe) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (counterexample) import TestUtil (evalSimpleSystem, genVarMap) +import Linear.Constraint.Simple.Types (SimpleConstraint(..)) spec :: Spec spec = do @@ -56,49 +58,55 @@ spec = do $ simpleSystemEval == simplifiedSimpleSystemEval it "findHighestVar finds the highest variable in a simple system" $ do let simpleSystem1 = - [ ExprVarsOnly (VarTermVO 0 : []) :>= 0 - , ExprVarsOnly (VarTermVO 0 : []) :<= 1 - , ExprVarsOnly (VarTermVO 1 : []) :>= 0 - , ExprVarsOnly (VarTermVO 1 : []) :<= 1 - ] + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :<= 1 + ] simpleSystem100 = - [ ExprVarsOnly (VarTermVO 0 : []) :<= 1 - , ExprVarsOnly (VarTermVO 50 : []) :<= 1 - , ExprVarsOnly (VarTermVO 100 : []) :<= 1 - ] + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 50] :<= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 100] :<= 1 + ] simpleSystem10 = - [ ExprVarsOnly (VarTermVO (-10) : []) :<= 1 - , ExprVarsOnly (VarTermVO 0 : []) :<= 1 - , ExprVarsOnly (VarTermVO 10 : []) :<= 1 - ] + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (-10)] :<= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 10] :<= 1 + ] simpleSystemMinus10 = - [ ExprVarsOnly (VarTermVO (-10) : []) :<= 1 - , ExprVarsOnly (VarTermVO (-20) : []) :<= 1 - ] + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (-10)] :<= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (-20)] :<= 1 + ] - findHighestVar simpleSystem1 `shouldBe` 1 - findHighestVar simpleSystem100 `shouldBe` 100 - findHighestVar simpleSystem10 `shouldBe` 10 - findHighestVar simpleSystemMinus10 `shouldBe` (-10) - describe "Bounds" $ do - it - "validateBounds finds that deriving bounds for a system where -1 <= x <= 1 has valid bounds" - $ do - let simpleSystem = - [ ExprVarsOnly (VarTermVO 0 : []) :>= (-1) - , ExprVarsOnly (VarTermVO 0 : []) :<= 1 + findHighestVar (SimpleSystem []) `shouldBe` Nothing + findHighestVar simpleSystem1 `shouldBe` Just 1 + findHighestVar simpleSystem100 `shouldBe` Just 100 + findHighestVar simpleSystem10 `shouldBe` Just 10 + findHighestVar simpleSystemMinus10 `shouldBe` Just (-10) + describe "Bounds" $ it + "validateBounds finds that deriving bounds for a system where -1 <= x <= 1 has valid bounds" + $ do + let simpleSystem = + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= (-1) + , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 1 ] - derivedBounds = deriveBounds simpleSystem - expectedBounds = Map.fromList [(0, Bounds (Just (-1)) (Just 1))] - derivedBounds `shouldBe` expectedBounds - validateBounds derivedBounds `shouldBe` True + derivedBounds = deriveBounds simpleSystem + expectedBounds = Map.fromList [(0, Bounds (Just (-1)) (Just 1))] + derivedBounds `shouldBe` expectedBounds + validateBounds derivedBounds `shouldBe` True it "validateBounds finds that deriving bounds for a system where 0 <= x <= 1 has valid bounds" $ do let simpleSystem = - [ ExprVarsOnly (VarTermVO 0 : []) :>= 0 - , ExprVarsOnly (VarTermVO 0 : []) :<= 1 - ] + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 1 + ] derivedBounds = deriveBounds simpleSystem expectedBounds = Map.fromList [(0, Bounds (Just 0) (Just 1))] derivedBounds `shouldBe` expectedBounds @@ -107,9 +115,10 @@ spec = do "validateBounds finds that deriving bounds for a system where 1 <= x <= 1 has valid bounds" $ do let simpleSystem = - [ ExprVarsOnly (VarTermVO 0 : []) :>= 1 - , ExprVarsOnly (VarTermVO 0 : []) :<= 1 - ] + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 1 + ] derivedBounds = deriveBounds simpleSystem expectedBounds = Map.fromList [(0, Bounds (Just 1) (Just 1))] derivedBounds `shouldBe` expectedBounds @@ -118,9 +127,10 @@ spec = do "validateBounds finds that deriving bounds for a system where 1 <= x <= 0 has invalid bounds" $ do let simpleSystem = - [ ExprVarsOnly (VarTermVO 0 : []) :>= 1 - , ExprVarsOnly (VarTermVO 0 : []) :<= 0 - ] + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 0 + ] derivedBounds = deriveBounds simpleSystem expectedBounds = Map.fromList [(0, Bounds (Just 1) (Just 0))] derivedBounds `shouldBe` expectedBounds @@ -129,11 +139,12 @@ spec = do "validateBounds finds that deriving bounds for a system where 0 <= x <= 1 and 1 <= y <= 3 has valid bounds" $ do let simpleSystem = - [ ExprVarsOnly (VarTermVO 0 : []) :>= 0 - , ExprVarsOnly (VarTermVO 0 : []) :<= 1 - , ExprVarsOnly (VarTermVO 1 : []) :>= 1 - , ExprVarsOnly (VarTermVO 1 : []) :<= 3 - ] + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :<= 3 + ] derivedBounds = deriveBounds simpleSystem expectedBounds = Map.fromList [(0, Bounds (Just 0) (Just 1)), (1, Bounds (Just 1) (Just 3))] derivedBounds `shouldBe` expectedBounds @@ -142,11 +153,12 @@ spec = do "validateBounds finds that deriving bounds for a system where 1 <= x <= 0 and 3 <= y <= 1 has invalid bounds" $ do let simpleSystem = - [ ExprVarsOnly (VarTermVO 0 : []) :>= 1 - , ExprVarsOnly (VarTermVO 0 : []) :<= 0 - , ExprVarsOnly (VarTermVO 1 : []) :>= 3 - , ExprVarsOnly (VarTermVO 1 : []) :<= 1 - ] + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 3 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :<= 1 + ] derivedBounds = deriveBounds simpleSystem expectedBounds = Map.fromList [(0, Bounds (Just 1) (Just 0)), (1, Bounds (Just 3) (Just 1))] derivedBounds `shouldBe` expectedBounds @@ -155,11 +167,12 @@ spec = do "validateBounds finds that deriving bounds for a system where 1 <= x <= 0 and 1 <= y <= 3 has invalid bounds" $ do let simpleSystem = - [ ExprVarsOnly (VarTermVO 0 : []) :>= 1 - , ExprVarsOnly (VarTermVO 0 : []) :<= 0 - , ExprVarsOnly (VarTermVO 1 : []) :>= 1 - , ExprVarsOnly (VarTermVO 1 : []) :<= 3 - ] + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :<= 3 + ] derivedBounds = deriveBounds simpleSystem expectedBounds = Map.fromList [(0, Bounds (Just 1) (Just 0)), (1, Bounds (Just 1) (Just 3))] derivedBounds `shouldBe` expectedBounds @@ -168,93 +181,104 @@ spec = do "validateBounds finds that deriving bounds for a system where 0 <= x <= 1 and 3 <= y <= 1 has invalid bounds" $ do let simpleSystem = - [ ExprVarsOnly (VarTermVO 0 : []) :>= 0 - , ExprVarsOnly (VarTermVO 0 : []) :<= 1 - , ExprVarsOnly (VarTermVO 1 : []) :>= 3 - , ExprVarsOnly (VarTermVO 1 : []) :<= 1 - ] + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 3 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :<= 1 + ] derivedBounds = deriveBounds simpleSystem expectedBounds = Map.fromList [(0, Bounds (Just 0) (Just 1)), (1, Bounds (Just 3) (Just 1))] derivedBounds `shouldBe` expectedBounds validateBounds derivedBounds `shouldBe` False it "removeUselessSystemBounds removes x <= 3 when bounds say x <= 2" $ do let simpleSystem = - [ ExprVarsOnly (VarTermVO 0 : []) :<= 2 - , ExprVarsOnly (VarTermVO 0 : []) :<= 3 - ] + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 2 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 3 + ] bounds = Map.fromList [(0, Bounds (Just 0) (Just 2))] simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds - expectedSimpleSystem = [ExprVarsOnly (VarTermVO 0 : []) :<= 2] + expectedSimpleSystem = SimpleSystem [SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 2] simplifiedSimpleSystem `shouldBe` expectedSimpleSystem it "removeUselessSystemBounds does not remove x <= 2 when bounds say x <= 2" $ do let simpleSystem = - [ ExprVarsOnly (VarTermVO 0 : []) :<= 2 - ] + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 2 + ] bounds = Map.fromList [(0, Bounds (Just 0) (Just 2))] simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds - expectedSimpleSystem = [ExprVarsOnly (VarTermVO 0 : []) :<= 2] + expectedSimpleSystem = SimpleSystem [SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 2] simplifiedSimpleSystem `shouldBe` expectedSimpleSystem it "removeUselessSystemBounds removes x >= 3 when bounds say x >= 4" $ do let simpleSystem = - [ ExprVarsOnly (VarTermVO 0 : []) :>= 4 - , ExprVarsOnly (VarTermVO 0 : []) :>= 3 - ] + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 4 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 3 + ] bounds = Map.fromList [(0, Bounds (Just 4) (Just 5))] simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds - expectedSimpleSystem = [ExprVarsOnly (VarTermVO 0 : []) :>= 4] + expectedSimpleSystem = SimpleSystem [SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 4] simplifiedSimpleSystem `shouldBe` expectedSimpleSystem it "removeUselessSystemBounds does not remove x >= 4 when bounds say x >= 4" $ do let simpleSystem = - [ ExprVarsOnly (VarTermVO 0 : []) :>= 4 - ] + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 4 + ] bounds = Map.fromList [(0, Bounds (Just 4) (Just 5))] simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds - expectedSimpleSystem = [ExprVarsOnly (VarTermVO 0 : []) :>= 4] + expectedSimpleSystem = SimpleSystem [SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 4] simplifiedSimpleSystem `shouldBe` expectedSimpleSystem it "removeUselessSystemBounds does not remove 0 <= x <= 2 when bounds say 0 <= x <= 2" $ do let simpleSystem = - [ ExprVarsOnly (VarTermVO 0 : []) :>= 0 - , ExprVarsOnly (VarTermVO 0 : []) :<= 2 - ] + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 2 + ] bounds = Map.fromList [(0, Bounds (Just 0) (Just 2))] simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds expectedSimpleSystem = - [ExprVarsOnly (VarTermVO 0 : []) :>= 0, ExprVarsOnly (VarTermVO 0 : []) :<= 2] + SimpleSystem + [SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 0, SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 2] simplifiedSimpleSystem `shouldBe` expectedSimpleSystem it "removeUselessSystemBounds removes upper bound of 0 <= x <= 2 when bounds say 0 <= x <= 1" $ do let simpleSystem = - [ ExprVarsOnly (VarTermVO 0 : []) :>= 0 - , ExprVarsOnly (VarTermVO 0 : []) :<= 2 - ] + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 2 + ] bounds = Map.fromList [(0, Bounds (Just 0) (Just 1))] simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds - expectedSimpleSystem = [ExprVarsOnly (VarTermVO 0 : []) :>= 0] + expectedSimpleSystem = SimpleSystem [SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 0] simplifiedSimpleSystem `shouldBe` expectedSimpleSystem it "removeUselessSystemBounds removes lower bound of 0 <= x <= 2 when bounds say 1 <= x <= 2" $ do let simpleSystem = - [ ExprVarsOnly (VarTermVO 0 : []) :>= 0 - , ExprVarsOnly (VarTermVO 0 : []) :<= 2 - ] + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 2 + ] bounds = Map.fromList [(0, Bounds (Just 1) (Just 2))] simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds - expectedSimpleSystem = [ExprVarsOnly (VarTermVO 0 : []) :<= 2] + expectedSimpleSystem = SimpleSystem [SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 2] simplifiedSimpleSystem `shouldBe` expectedSimpleSystem it "removeUselssSystemBounds only removes constraints of the form x <= c" $ do let simpleSystem = - [ ExprVarsOnly (VarTermVO 0 : []) :<= 2 - , ExprVarsOnly (VarTermVO 0 : []) :<= 3 - , ExprVarsOnly (CoeffTermVO 2 0 : []) :<= 6 - ] + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 2 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 3 + , SimpleConstraint $ ExprVarsOnly [CoeffTermVO 2 0] :<= 6 + ] bounds = Map.fromList [(0, Bounds (Just 0) (Just 2))] simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds expectedSimpleSystem = - [ ExprVarsOnly (VarTermVO 0 : []) :<= 2 - , ExprVarsOnly (CoeffTermVO 2 0 : []) :<= 6 - ] + SimpleSystem + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 2 + , SimpleConstraint $ ExprVarsOnly [CoeffTermVO 2 0] :<= 6 + ] simplifiedSimpleSystem `shouldBe` expectedSimpleSystem diff --git a/test/TestUtil.hs b/test/TestUtil.hs index 1432abe..88d4476 100644 --- a/test/TestUtil.hs +++ b/test/TestUtil.hs @@ -12,14 +12,14 @@ import qualified Data.Map as Map import Linear.Constraint.Generic.Types ( GenericConstraint ((:<=), (:==), (:>=)) ) -import Linear.Constraint.Simple.Types (SimpleConstraint) +import Linear.Constraint.Simple.Types (SimpleConstraint (..)) import Linear.Constraint.Types ( Constraint (..) ) import Linear.Expr.Types (Expr, ExprVarsOnly) import Linear.Expr.Util (exprToList, exprVarsOnlyToExpr) import Linear.Simplex.Types (VarLitMap) -import Linear.System.Simple.Types (SimpleSystem) +import Linear.System.Simple.Types (SimpleSystem (..)) import Linear.Term.Types ( Term (..) , TermVarsOnly @@ -53,17 +53,17 @@ evalExprVarsOnly :: VarLitMap -> ExprVarsOnly -> SimplexNum evalExprVarsOnly varMap = evalExpr varMap . exprVarsOnlyToExpr evalConstraint :: VarLitMap -> Constraint -> Bool -evalConstraint varMap (lhs :<= rhs) = evalExpr varMap lhs <= evalExpr varMap rhs -evalConstraint varMap (lhs :>= rhs) = evalExpr varMap lhs >= evalExpr varMap rhs -evalConstraint varMap (lhs :== rhs) = evalExpr varMap lhs == evalExpr varMap rhs +evalConstraint varMap (Constraint (lhs :<= rhs)) = evalExpr varMap lhs <= evalExpr varMap rhs +evalConstraint varMap (Constraint (lhs :>= rhs)) = evalExpr varMap lhs >= evalExpr varMap rhs +evalConstraint varMap (Constraint (lhs :== rhs)) = evalExpr varMap lhs == evalExpr varMap rhs evalSimpleConstraint :: VarLitMap -> SimpleConstraint -> Bool -evalSimpleConstraint varMap (lhs :<= rhs) = evalExprVarsOnly varMap lhs <= rhs -evalSimpleConstraint varMap (lhs :>= rhs) = evalExprVarsOnly varMap lhs >= rhs -evalSimpleConstraint varMap (lhs :== rhs) = evalExprVarsOnly varMap lhs == rhs +evalSimpleConstraint varMap (SimpleConstraint (lhs :<= rhs)) = evalExprVarsOnly varMap lhs <= rhs +evalSimpleConstraint varMap (SimpleConstraint (lhs :>= rhs)) = evalExprVarsOnly varMap lhs >= rhs +evalSimpleConstraint varMap (SimpleConstraint (lhs :== rhs)) = evalExprVarsOnly varMap lhs == rhs evalSimpleSystem :: VarLitMap -> SimpleSystem -> Bool -evalSimpleSystem varMap = all (evalSimpleConstraint varMap) +evalSimpleSystem varMap = all (evalSimpleConstraint varMap) . unSimpleSystem genVarMap :: [Var] -> Gen VarLitMap genVarMap vars = do From be080cc4c5d06e9ac68109ea0778e37ef2563aad Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 9 Nov 2024 23:34:56 +0000 Subject: [PATCH 44/47] Rename GenericConstraint to MixedComparison --- simplex-method.cabal | 2 +- src/Comparison/Types.hs | 34 ++++++++++++++++++++++++++ src/Linear/Constraint/Generic/Types.hs | 33 ------------------------- src/Linear/Constraint/Simple/Types.hs | 7 +++--- src/Linear/Constraint/Simple/Util.hs | 6 ++--- src/Linear/Constraint/Types.hs | 4 +-- src/Linear/Constraint/Util.hs | 6 ++--- src/Linear/SlackForm/Util.hs | 6 ++--- src/Linear/System/Simple/Types.hs | 2 +- src/Linear/System/Simple/Util.hs | 8 +++--- test/Linear/SlackForm/UtilSpec.hs | 14 +++++------ test/Linear/System/Simple/UtilSpec.hs | 17 +++++++------ test/TestUtil.hs | 6 ++--- 13 files changed, 75 insertions(+), 70 deletions(-) create mode 100644 src/Comparison/Types.hs delete mode 100644 src/Linear/Constraint/Generic/Types.hs diff --git a/simplex-method.cabal b/simplex-method.cabal index c82498e..1591c71 100644 --- a/simplex-method.cabal +++ b/simplex-method.cabal @@ -27,7 +27,7 @@ source-repository head library exposed-modules: - Linear.Constraint.Generic.Types + Comparison.Types Linear.Constraint.Linear.Types Linear.Constraint.Linear.Util Linear.Constraint.Simple.Types diff --git a/src/Comparison/Types.hs b/src/Comparison/Types.hs new file mode 100644 index 0000000..f37625c --- /dev/null +++ b/src/Comparison/Types.hs @@ -0,0 +1,34 @@ +-- | +-- Module : Comparison.Types +-- Description : Types for constraints in linear programming problems +-- Copyright : (c) Junaid Rasheed, 2020-2024 +-- License : BSD-3 +-- Maintainer : jrasheed178@gmail.com +-- Stability : experimental +module Comparison.Types where + +import Control.Applicative (liftA2) +import Foreign.C.Types (CBool) +import GHC.Generics (Generic) +import Test.QuickCheck (Arbitrary, arbitrary, genericShrink, oneof) + +data MixedComparison a b = a :<= b | a :>= b | a :== b + deriving (Show, Read, Eq, Generic) + +instance (Arbitrary a, Arbitrary b) => Arbitrary (MixedComparison a b) where + arbitrary = + oneof + [ liftA2 (:<=) arbitrary arbitrary + , liftA2 (:>=) arbitrary arbitrary + , liftA2 (:==) arbitrary arbitrary + ] + +getMixedComparisonLHS :: MixedComparison a b -> a +getMixedComparisonLHS (a :<= _) = a +getMixedComparisonLHS (a :>= _) = a +getMixedComparisonLHS (a :== _) = a + +getMixedComparisonRHS :: MixedComparison a b -> b +getMixedComparisonRHS (_ :<= b) = b +getMixedComparisonRHS (_ :>= b) = b +getMixedComparisonRHS (_ :== b) = b diff --git a/src/Linear/Constraint/Generic/Types.hs b/src/Linear/Constraint/Generic/Types.hs deleted file mode 100644 index 2f26a17..0000000 --- a/src/Linear/Constraint/Generic/Types.hs +++ /dev/null @@ -1,33 +0,0 @@ --- | --- Module : Linear.Constraint.Generic.Types --- Description : Types for constraints in linear programming problems --- Copyright : (c) Junaid Rasheed, 2020-2024 --- License : BSD-3 --- Maintainer : jrasheed178@gmail.com --- Stability : experimental -module Linear.Constraint.Generic.Types where - -import Control.Applicative (liftA2) -import GHC.Generics (Generic) -import Test.QuickCheck (Arbitrary, arbitrary, genericShrink, oneof) - -data GenericConstraint a b = a :<= b | a :>= b | a :== b - deriving (Show, Read, Eq, Generic) - -instance (Arbitrary a, Arbitrary b) => Arbitrary (GenericConstraint a b) where - arbitrary = - oneof - [ liftA2 (:<=) arbitrary arbitrary - , liftA2 (:>=) arbitrary arbitrary - , liftA2 (:==) arbitrary arbitrary - ] - -getGenericConstraintLHS :: GenericConstraint a b -> a -getGenericConstraintLHS (a :<= _) = a -getGenericConstraintLHS (a :>= _) = a -getGenericConstraintLHS (a :== _) = a - -getGenericConstraintRHS :: GenericConstraint a b -> b -getGenericConstraintRHS (_ :<= b) = b -getGenericConstraintRHS (_ :>= b) = b -getGenericConstraintRHS (_ :== b) = b diff --git a/src/Linear/Constraint/Simple/Types.hs b/src/Linear/Constraint/Simple/Types.hs index 05640f9..7d975fb 100644 --- a/src/Linear/Constraint/Simple/Types.hs +++ b/src/Linear/Constraint/Simple/Types.hs @@ -7,13 +7,14 @@ -- Stability: experimental module Linear.Constraint.Simple.Types where -import Linear.Constraint.Generic.Types (GenericConstraint) +import Comparison.Types (MixedComparison) +import GHC.Generics (Generic) import Linear.Expr.Types (ExprVarsOnly) import Linear.Var.Types (SimplexNum) -import GHC.Generics (Generic) import Test.QuickCheck (Arbitrary (..)) -newtype SimpleConstraint = SimpleConstraint { unSimpleConstraint :: GenericConstraint ExprVarsOnly SimplexNum } +newtype SimpleConstraint = SimpleConstraint + {unSimpleConstraint :: MixedComparison ExprVarsOnly SimplexNum} deriving (Show, Eq, Read, Generic) instance Arbitrary SimpleConstraint where diff --git a/src/Linear/Constraint/Simple/Util.hs b/src/Linear/Constraint/Simple/Util.hs index 2583296..223b462 100644 --- a/src/Linear/Constraint/Simple/Util.hs +++ b/src/Linear/Constraint/Simple/Util.hs @@ -7,11 +7,11 @@ -- Stability: experimental module Linear.Constraint.Simple.Util where +import Comparison.Types + ( MixedComparison (..) + ) import qualified Data.List as L import qualified Data.Set as Set -import Linear.Constraint.Generic.Types - ( GenericConstraint (..) - ) import Linear.Constraint.Simple.Types (SimpleConstraint (..)) import Linear.Constraint.Types (Constraint (..)) import Linear.Expr.Types (Expr (..), ExprVarsOnly (..)) diff --git a/src/Linear/Constraint/Types.hs b/src/Linear/Constraint/Types.hs index 216d60a..70c523d 100644 --- a/src/Linear/Constraint/Types.hs +++ b/src/Linear/Constraint/Types.hs @@ -7,15 +7,15 @@ -- Stability: experimental module Linear.Constraint.Types where +import Comparison.Types (MixedComparison) import qualified Data.Set as Set import GHC.Generics (Generic) -import Linear.Constraint.Generic.Types (GenericConstraint) import Linear.Expr.Types (Expr) import Test.QuickCheck (Arbitrary (..)) -- Input -- TODO: Consider LinearConstraint -newtype Constraint = Constraint {unConstraint :: GenericConstraint Expr Expr} +newtype Constraint = Constraint {unConstraint :: MixedComparison Expr Expr} deriving (Show, Eq, Read, Generic) instance Arbitrary Constraint where diff --git a/src/Linear/Constraint/Util.hs b/src/Linear/Constraint/Util.hs index 097ed29..1d50e1e 100644 --- a/src/Linear/Constraint/Util.hs +++ b/src/Linear/Constraint/Util.hs @@ -7,10 +7,10 @@ -- Stability: experimental module Linear.Constraint.Util where -import qualified Data.Set as Set -import Linear.Constraint.Generic.Types - ( GenericConstraint ((:<=), (:==), (:>=)) +import Comparison.Types + ( MixedComparison ((:<=), (:==), (:>=)) ) +import qualified Data.Set as Set import Linear.Constraint.Types (Constraint (..)) import Linear.Expr.Util (exprVars) import Linear.Var.Types (Var) diff --git a/src/Linear/SlackForm/Util.hs b/src/Linear/SlackForm/Util.hs index 463e35b..f135e4c 100644 --- a/src/Linear/SlackForm/Util.hs +++ b/src/Linear/SlackForm/Util.hs @@ -7,12 +7,12 @@ -- Stability: experimental module Linear.SlackForm.Util where +import Comparison.Types + ( MixedComparison ((:<=), (:==), (:>=)) + ) import qualified Data.Bifunctor as Bifunctor import qualified Data.Map as Map import qualified Data.Maybe as Maybe -import Linear.Constraint.Generic.Types - ( GenericConstraint ((:<=), (:==), (:>=)) - ) import Linear.Constraint.Linear.Types (LinearEquation (..)) import qualified Linear.Constraint.Linear.Util as CLU import Linear.Constraint.Simple.Types (SimpleConstraint (..)) diff --git a/src/Linear/System/Simple/Types.hs b/src/Linear/System/Simple/Types.hs index f671e22..647277c 100644 --- a/src/Linear/System/Simple/Types.hs +++ b/src/Linear/System/Simple/Types.hs @@ -7,9 +7,9 @@ -- Stability: experimental module Linear.System.Simple.Types where +import Comparison.Types (getMixedComparisonLHS) import qualified Data.Set as Set import GHC.Generics (Generic) -import Linear.Constraint.Generic.Types (getGenericConstraintLHS) import Linear.Constraint.Simple.Types (SimpleConstraint) import Linear.Constraint.Simple.Util ( simpleConstraintVars diff --git a/src/Linear/System/Simple/Util.hs b/src/Linear/System/Simple/Util.hs index bdcd239..6c40fe5 100644 --- a/src/Linear/System/Simple/Util.hs +++ b/src/Linear/System/Simple/Util.hs @@ -7,11 +7,11 @@ -- Stability: experimental module Linear.System.Simple.Util where +import Comparison.Types + ( MixedComparison ((:<=), (:==), (:>=)) + ) import qualified Data.Map as M import qualified Data.Set as Set -import Linear.Constraint.Generic.Types - ( GenericConstraint ((:<=), (:==), (:>=)) - ) import Linear.Constraint.Simple.Types (SimpleConstraint (..)) import Linear.Expr.Types (Expr (..), ExprVarsOnly (..)) import Linear.System.Simple.Types @@ -57,7 +57,7 @@ removeUselessSystemBounds constraints bounds = (SimpleConstraint (ExprVarsOnly [VarTermVO var] :<= num)) -> case M.lookup var bounds of Just (Bounds _ (Just upper)) -> num <= upper _ -> True - (SimpleConstraint (ExprVarsOnly [VarTermVO var] :>= num)) -> case M.lookup var bounds of + (SimpleConstraint (ExprVarsOnly [VarTermVO var] :>= num)) -> case M.lookup var bounds of Just (Bounds (Just lower) _) -> num >= lower _ -> True _ -> True diff --git a/test/Linear/SlackForm/UtilSpec.hs b/test/Linear/SlackForm/UtilSpec.hs index 5f55cc4..944ed80 100644 --- a/test/Linear/SlackForm/UtilSpec.hs +++ b/test/Linear/SlackForm/UtilSpec.hs @@ -1,5 +1,9 @@ module Linear.SlackForm.UtilSpec where +import Comparison.Types + ( MixedComparison ((:<=), (:==), (:>=)) + , getMixedComparisonLHS + ) import Control.Monad (forM) import Data.Functor ((<&>)) import qualified Data.List as List @@ -7,11 +11,8 @@ import qualified Data.Map as Map import qualified Data.Maybe as Maybe import qualified Data.Set as Set import qualified Debug.Trace as T -import Linear.Constraint.Generic.Types - ( GenericConstraint ((:<=), (:==), (:>=)) - , getGenericConstraintLHS - ) import Linear.Constraint.Linear.Types (LinearEquation (..)) +import Linear.Constraint.Simple.Types (SimpleConstraint (..)) import Linear.Expr.Types (Expr (..), ExprVarsOnly (..)) import Linear.SlackForm.Util ( addSlackVariables @@ -27,12 +28,11 @@ import Linear.Term.Types ) import Test.Hspec (Spec, describe, it, shouldBe) import Test.QuickCheck (Testable (property), withMaxSuccess) -import Linear.Constraint.Simple.Types (SimpleConstraint(..)) -- data Term = ConstTerm SimplexNum | CoeffTerm SimplexNum Var | VarTerm Var -- Consider VarTerm Var - note, we must consider normalizing this: Considered. It makes going to standard form easier due to type safety -- deriving (Show, Read, Eq, Ord, Generic) --- TODO: consider type NumberConstraint = GenericConstraint SimplexNum SimplexNum +-- TODO: consider type NumberConstraint = MixedComparison SimplexNum SimplexNum spec :: Spec spec = describe "Slack Form Transformations" $ do it @@ -137,7 +137,7 @@ spec = describe "Slack Form Transformations" $ do any ( \(SimpleConstraint constraint) -> let getVars _a = [] - lhs = getGenericConstraintLHS constraint + lhs = getMixedComparisonLHS constraint allVars = getVars lhs in var `notElem` allVars ) diff --git a/test/Linear/System/Simple/UtilSpec.hs b/test/Linear/System/Simple/UtilSpec.hs index 6633867..c328828 100644 --- a/test/Linear/System/Simple/UtilSpec.hs +++ b/test/Linear/System/Simple/UtilSpec.hs @@ -7,12 +7,13 @@ -- Stability: experimental module Linear.System.Simple.UtilSpec where +import Comparison.Types + ( MixedComparison ((:<=), (:>=)) + ) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map as Map import qualified Data.Set as Set -import Linear.Constraint.Generic.Types - ( GenericConstraint ((:<=), (:>=)) - ) +import Linear.Constraint.Simple.Types (SimpleConstraint (..)) import Linear.Expr.Types (ExprVarsOnly (..)) import Linear.System.Simple.Types ( SimpleSystem (SimpleSystem) @@ -31,7 +32,6 @@ import Test.Hspec (Spec, describe, it, shouldBe) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (counterexample) import TestUtil (evalSimpleSystem, genVarMap) -import Linear.Constraint.Simple.Types (SimpleConstraint(..)) spec :: Spec spec = do @@ -87,8 +87,9 @@ spec = do findHighestVar simpleSystem100 `shouldBe` Just 100 findHighestVar simpleSystem10 `shouldBe` Just 10 findHighestVar simpleSystemMinus10 `shouldBe` Just (-10) - describe "Bounds" $ it - "validateBounds finds that deriving bounds for a system where -1 <= x <= 1 has valid bounds" + describe "Bounds" + $ it + "validateBounds finds that deriving bounds for a system where -1 <= x <= 1 has valid bounds" $ do let simpleSystem = SimpleSystem @@ -241,7 +242,9 @@ spec = do simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds expectedSimpleSystem = SimpleSystem - [SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 0, SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 2] + [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 2 + ] simplifiedSimpleSystem `shouldBe` expectedSimpleSystem it "removeUselessSystemBounds removes upper bound of 0 <= x <= 2 when bounds say 0 <= x <= 1" diff --git a/test/TestUtil.hs b/test/TestUtil.hs index 88d4476..628f0ec 100644 --- a/test/TestUtil.hs +++ b/test/TestUtil.hs @@ -7,11 +7,11 @@ -- Stability: experimental module TestUtil where +import Comparison.Types + ( MixedComparison ((:<=), (:==), (:>=)) + ) import Control.Monad (forM) import qualified Data.Map as Map -import Linear.Constraint.Generic.Types - ( GenericConstraint ((:<=), (:==), (:>=)) - ) import Linear.Constraint.Simple.Types (SimpleConstraint (..)) import Linear.Constraint.Types ( Constraint (..) From 834d2eddea24bb2eb77451c7472eef9416f739b2 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Fri, 29 Nov 2024 12:42:38 +0000 Subject: [PATCH 45/47] mixedcomparison class idea --- package.yaml | 1 + simplex-method.cabal | 4 ++-- src/Comparison/Types.hs | 27 +++++++++++++++++++++++++++ 3 files changed, 30 insertions(+), 2 deletions(-) diff --git a/package.yaml b/package.yaml index 044dca5..7be037d 100644 --- a/package.yaml +++ b/package.yaml @@ -46,6 +46,7 @@ default-extensions: TemplateHaskell TupleSections TypeApplications + TypeFamilies NamedFieldPuns library: diff --git a/simplex-method.cabal b/simplex-method.cabal index 1591c71..671f3cb 100644 --- a/simplex-method.cabal +++ b/simplex-method.cabal @@ -58,7 +58,7 @@ library hs-source-dirs: src default-extensions: - DataKinds DeriveFunctor DeriveGeneric DerivingStrategies DisambiguateRecordFields DuplicateRecordFields FlexibleContexts LambdaCase OverloadedLabels OverloadedRecordDot OverloadedStrings RecordWildCards TemplateHaskell TupleSections TypeApplications NamedFieldPuns + DataKinds DeriveFunctor DeriveGeneric DerivingStrategies DisambiguateRecordFields DuplicateRecordFields FlexibleContexts LambdaCase OverloadedLabels OverloadedRecordDot OverloadedStrings RecordWildCards TemplateHaskell TupleSections TypeApplications TypeFamilies NamedFieldPuns build-depends: QuickCheck , base >=4.14 && <5 @@ -86,7 +86,7 @@ test-suite simplex-method-test hs-source-dirs: test default-extensions: - DataKinds DeriveFunctor DeriveGeneric DerivingStrategies DisambiguateRecordFields DuplicateRecordFields FlexibleContexts LambdaCase OverloadedLabels OverloadedRecordDot OverloadedStrings RecordWildCards TemplateHaskell TupleSections TypeApplications NamedFieldPuns + DataKinds DeriveFunctor DeriveGeneric DerivingStrategies DisambiguateRecordFields DuplicateRecordFields FlexibleContexts LambdaCase OverloadedLabels OverloadedRecordDot OverloadedStrings RecordWildCards TemplateHaskell TupleSections TypeApplications TypeFamilies NamedFieldPuns build-depends: QuickCheck , base >=4.14 && <5 diff --git a/src/Comparison/Types.hs b/src/Comparison/Types.hs index f37625c..15728df 100644 --- a/src/Comparison/Types.hs +++ b/src/Comparison/Types.hs @@ -32,3 +32,30 @@ getMixedComparisonRHS :: MixedComparison a b -> b getMixedComparisonRHS (_ :<= b) = b getMixedComparisonRHS (_ :>= b) = b getMixedComparisonRHS (_ :== b) = b + +class MixedComparison2 c where + type LhsType c :: * + type RhsType c :: * + + lhs :: c -> LhsType c + rhs :: c -> RhsType c + + (.<=) :: c -> Bool + (.>=) :: c -> Bool + + (.==) :: c -> Bool + (.==) c = (.>=) c && (.<=) c + +data IntComparison = IntComparison Int Int + +instance MixedComparison2 IntComparison where + type LhsType IntComparison = Int + type RhsType IntComparison = Int + + lhs (IntComparison l _) = l + rhs (IntComparison _ r) = r + + (.<=) (IntComparison l r) = l <= r + (.>=) (IntComparison l r) = l >= r + + (.==) (IntComparison l r) = l == r From 7c44b1de04234f98be3a24cb07193f4f96676178 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 11 Jan 2025 14:34:09 +0000 Subject: [PATCH 46/47] rename some types, add some strict fields, add todos --- simplex-method.cabal | 6 +- src/Comparison/Types.hs | 29 ++++++--- src/Linear/CanonicalForm/Types.hs | 28 +++++++++ .../{SlackForm => CanonicalForm}/Util.hs | 29 ++++++++- src/Linear/Constraint/Types.hs | 6 +- src/Linear/Simplex/Solver/Types.hs | 62 ++++++++++++++++++- src/Linear/SlackForm/Types.hs | 36 ----------- src/Linear/System/Linear/Types.hs | 18 ++++-- src/Linear/System/Linear/Util.hs | 6 +- src/Linear/System/Simple/Types.hs | 2 +- src/Linear/System/Simple/Util.hs | 5 +- src/Linear/System/Types.hs | 3 - src/Linear/Var/Types.hs | 9 +-- .../{SlackForm => CanonicalForm}/UtilSpec.hs | 40 ++++++------ test/Linear/System/Simple/UtilSpec.hs | 32 +++++----- 15 files changed, 199 insertions(+), 112 deletions(-) create mode 100644 src/Linear/CanonicalForm/Types.hs rename src/Linear/{SlackForm => CanonicalForm}/Util.hs (85%) delete mode 100644 src/Linear/SlackForm/Types.hs rename test/Linear/{SlackForm => CanonicalForm}/UtilSpec.hs (92%) diff --git a/simplex-method.cabal b/simplex-method.cabal index 671f3cb..5cbdd65 100644 --- a/simplex-method.cabal +++ b/simplex-method.cabal @@ -28,6 +28,8 @@ source-repository head library exposed-modules: Comparison.Types + Linear.CanonicalForm.Types + Linear.CanonicalForm.Util Linear.Constraint.Linear.Types Linear.Constraint.Linear.Util Linear.Constraint.Simple.Types @@ -42,8 +44,6 @@ library Linear.Simplex.Standardize Linear.Simplex.Types Linear.Simplex.Util - Linear.SlackForm.Types - Linear.SlackForm.Util Linear.System.Linear.Types Linear.System.Linear.Util Linear.System.Simple.Types @@ -75,9 +75,9 @@ test-suite simplex-method-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: + Linear.CanonicalForm.UtilSpec Linear.Constraint.Simple.UtilSpec Linear.Expr.UtilSpec - Linear.SlackForm.UtilSpec Linear.System.Simple.UtilSpec Linear.Term.UtilSpec Linear.Var.UtilSpec diff --git a/src/Comparison/Types.hs b/src/Comparison/Types.hs index 15728df..1d860c5 100644 --- a/src/Comparison/Types.hs +++ b/src/Comparison/Types.hs @@ -5,7 +5,12 @@ -- License : BSD-3 -- Maintainer : jrasheed178@gmail.com -- Stability : experimental -module Comparison.Types where +module Comparison.Types + ( MixedComparison (..) + , getLHS + , getRHS + ) +where import Control.Applicative (liftA2) import Foreign.C.Types (CBool) @@ -23,16 +28,22 @@ instance (Arbitrary a, Arbitrary b) => Arbitrary (MixedComparison a b) where , liftA2 (:==) arbitrary arbitrary ] -getMixedComparisonLHS :: MixedComparison a b -> a -getMixedComparisonLHS (a :<= _) = a -getMixedComparisonLHS (a :>= _) = a -getMixedComparisonLHS (a :== _) = a +getLHS :: MixedComparison a b -> a +getLHS (a :<= _) = a +getLHS (a :>= _) = a +getLHS (a :== _) = a -getMixedComparisonRHS :: MixedComparison a b -> b -getMixedComparisonRHS (_ :<= b) = b -getMixedComparisonRHS (_ :>= b) = b -getMixedComparisonRHS (_ :== b) = b +getRHS :: MixedComparison a b -> b +getRHS (_ :<= b) = b +getRHS (_ :>= b) = b +getRHS (_ :== b) = b +{- Using a class here and staying 'generic' (as in, be permissive on allowed +types) is awkward. I think it's simpler to just stick with the data type. +If we want a class, how do we best define the comparison ops? We'd need a way +for LhsType and RhsType to be compared. Maybe we can use something like +MixedTypesNum, but that's going to take some work. +-} class MixedComparison2 c where type LhsType c :: * type RhsType c :: * diff --git a/src/Linear/CanonicalForm/Types.hs b/src/Linear/CanonicalForm/Types.hs new file mode 100644 index 0000000..3ac47df --- /dev/null +++ b/src/Linear/CanonicalForm/Types.hs @@ -0,0 +1,28 @@ +-- | +-- Module: Linear.Simplex.CanonicalForm.Types +-- Description: Types for augmented (slack) form of linear programming problems +-- Copyright: (c) Junaid Rasheed, 2024 +-- License: BSD-3 +-- Maintainer: Junaid Rasheed +-- Stability: experimental +module Linear.CanonicalForm.Types where + +import qualified Data.Map as Map +import qualified Data.Set as Set +import GHC.Generics (Generic) +import Linear.Constraint.Linear.Types (LinearEquation (..)) +import Linear.Expr.Types (Expr, ExprVarsOnly) +import Linear.Expr.Util (exprVarsOnlyVars) +import Linear.System.Linear.Types (LinearSystem (..)) +import Linear.System.Simple.Types +import Linear.Var.Types (SimplexNum, Var) + +-- https://en.wikipedia.org/wiki/Linear_programming#Augmented_form_(slack_form) +data CanonicalForm = CanonicalForm + { constraints :: !LinearSystem + , originalVars :: !(Set.Set Var) + , systemVars :: !(Set.Set Var) + , systemSlackVars :: !(Set.Set Var) -- all vars are non-negative + , eliminatedVarsMap :: !(Map.Map Var Expr) + } + deriving (Show, Eq, Read, Generic) diff --git a/src/Linear/SlackForm/Util.hs b/src/Linear/CanonicalForm/Util.hs similarity index 85% rename from src/Linear/SlackForm/Util.hs rename to src/Linear/CanonicalForm/Util.hs index f135e4c..5491e8d 100644 --- a/src/Linear/SlackForm/Util.hs +++ b/src/Linear/CanonicalForm/Util.hs @@ -5,7 +5,7 @@ -- License: BSD-3 -- Maintainer: Junaid Rasheed -- Stability: experimental -module Linear.SlackForm.Util where +module Linear.CanonicalForm.Util where import Comparison.Types ( MixedComparison ((:<=), (:==), (:>=)) @@ -13,6 +13,7 @@ import Comparison.Types import qualified Data.Bifunctor as Bifunctor import qualified Data.Map as Map import qualified Data.Maybe as Maybe +import qualified Data.Set as Set import Linear.Constraint.Linear.Types (LinearEquation (..)) import qualified Linear.Constraint.Linear.Util as CLU import Linear.Constraint.Simple.Types (SimpleConstraint (..)) @@ -21,6 +22,7 @@ import Linear.Constraint.Simple.Util ) import Linear.Expr.Types (Expr (..), ExprVarsOnly (..)) import Linear.Expr.Util (exprVarsOnlyToExpr) +import Linear.CanonicalForm.Types (CanonicalForm (..)) import Linear.System.Linear.Types (LinearSystem (..)) import qualified Linear.System.Linear.Util as SLU import Linear.System.Simple.Types @@ -28,6 +30,7 @@ import Linear.System.Simple.Types , simplifySimpleSystem ) import qualified Linear.System.Simple.Types as SST +import Linear.System.Simple.Util (deriveBounds) import Linear.Term.Types ( Term (..) , TermVarsOnly (..) @@ -72,8 +75,9 @@ eliminateNonZeroLowerBounds constraints eliminatedVarsMap = aux [] constraints.u -- Add slack variables... -- Second step here https://en.wikipedia.org/wiki/Simplex_algorithm#Standard_form -- Return system of equalities and the slack variables -addSlackVariables :: SimpleSystem -> ([Var], LinearSystem) -addSlackVariables constraints = +-- TODO: [Var] should be a set +addSlackVars :: SimpleSystem -> ([Var], LinearSystem) +addSlackVars constraints = let nextAvailableVar = SST.nextAvailableVar constraints in aux constraints.unSimpleSystem nextAvailableVar [] where @@ -134,3 +138,22 @@ eliminateUnrestrictedLowerBounds constraints varBoundMap eliminatedVarsMap = aux (Map.fromList bounds) updatedEliminatedVarsMap aux cs (_ : bounds) = aux cs bounds + +simpleSystemToCanonicalForm :: SimpleSystem -> CanonicalForm +simpleSystemToCanonicalForm system = + CanonicalForm + { constraints = finalSystem + , originalVars = SST.simpleSystemVars system + , systemVars = SLU.linearSystemVars finalSystem + , systemSlackVars = Set.fromList slackVars + , eliminatedVarsMap = eliminatedVarsMap + } + where + (eliminatedNonZeroLowerBoundVarsMap, system1) = eliminateNonZeroLowerBounds system Map.empty + system1Bounds = deriveBounds system1 + (slackVars, linearSystem) = addSlackVars system1 + (eliminatedVarsMap, finalSystem) = + eliminateUnrestrictedLowerBounds + linearSystem + system1Bounds + eliminatedNonZeroLowerBoundVarsMap diff --git a/src/Linear/Constraint/Types.hs b/src/Linear/Constraint/Types.hs index 70c523d..e41e14d 100644 --- a/src/Linear/Constraint/Types.hs +++ b/src/Linear/Constraint/Types.hs @@ -7,7 +7,11 @@ -- Stability: experimental module Linear.Constraint.Types where -import Comparison.Types (MixedComparison) +import Comparison.Types + ( MixedComparison + , getLHS + , getRHS + ) import qualified Data.Set as Set import GHC.Generics (Generic) import Linear.Expr.Types (Expr) diff --git a/src/Linear/Simplex/Solver/Types.hs b/src/Linear/Simplex/Solver/Types.hs index 904635b..80d77c6 100644 --- a/src/Linear/Simplex/Solver/Types.hs +++ b/src/Linear/Simplex/Solver/Types.hs @@ -3,8 +3,10 @@ module Linear.Simplex.Solver.Types where import qualified Data.Map as Map import GHC.Generics (Generic) import Linear.Expr.Types (ExprVarsOnly) -import Linear.System.Linear.Types (CanBeLinearSystem) +import Linear.CanonicalForm.Types (CanonicalForm) +import Linear.System.Linear.Types (LinearSystem) import Linear.Var.Types (SimplexNum, Var) +import System.Posix.Types (CMode) data OptimisationDirection = Minimize | Maximize deriving (Show, Eq, GHC.Generics.Generic) @@ -15,11 +17,65 @@ data Objective = Objective } deriving (Show, Eq, GHC.Generics.Generic) +-- TODO: Is it useful to include the system in the result? data Result = Result + +-- TODO: Include the canonical form? +data OptimisationResult = OptimisationResult { varMap :: Map.Map Var SimplexNum , objVal :: SimplexNum } deriving (Show, Read, Eq, GHC.Generics.Generic) -class (CanBeLinearSystem s) => Solver s where - solve :: s -> Objective -> Result +-- class (CanBeLinearSystem s) => Solver s where +-- solve :: s -> Objective -> Result +class TwoPhaseSolver inputSystem where + firstPhase :: inputSystem -> Maybe CanonicalForm + + twoPhaseSolve :: inputSystem -> Objective -> Maybe OptimisationResult + twoPhaseSolve inputSystem obj = + let mSf = firstPhase inputSystem + in case mSf of + Nothing -> Nothing + Just sf -> Just $ systemResult $ secondPhase obj sf + where + secondPhase :: Objective -> CanonicalForm -> CanonicalForm + secondPhase = undefined + + -- This will probably be a proper function + systemResult :: CanonicalForm -> OptimisationResult + systemResult = undefined + +class CanBeStandardForm problem where + findSolution :: problem -> Maybe CanonicalForm + +-- solveStandardForm :: StandardForm -> Objective -> Maybe Result + +class LinearSystemProcessor s where + type System s :: * + +data FeasibleSystem = FeasibleSystem + { varVals :: Map.Map Var SimplexNum + , system :: LinearSystem + } + +data Model = Model {model :: Map.Map Var SimplexNum} + +data SatResult model = Unsat | Sat model + +-- s is a system +class (Monad (SatSolverMonad s)) => SatSolver s where + type SatSolverOptions s :: * + type SatSolverMonad s :: * -> * + + solve :: SatSolverOptions s -> s -> (SatSolverMonad s) (SatResult Model) + +class (Monad (OptSolverMonad s)) => OptSolver s where + type OptSolverOptions s :: * + type OptSolverMonad s :: * -> * + + optimise :: + OptSolverOptions s -> s -> Objective -> (OptSolverMonad s) (SatResult Model) + +-- class (CanBeLinearSystem s) => Solver2 s where +-- solve2 :: s -> Objective -> Result diff --git a/src/Linear/SlackForm/Types.hs b/src/Linear/SlackForm/Types.hs deleted file mode 100644 index b737f53..0000000 --- a/src/Linear/SlackForm/Types.hs +++ /dev/null @@ -1,36 +0,0 @@ --- | --- Module: Linear.Simplex.SlackForm.Types --- Description: Types for augmented (slack) form of linear programming problems --- Copyright: (c) Junaid Rasheed, 2024 --- License: BSD-3 --- Maintainer: Junaid Rasheed --- Stability: experimental -module Linear.SlackForm.Types where - -import qualified Data.Set as Set -import GHC.Generics (Generic) -import Linear.Constraint.Linear.Types (LinearEquation (..)) -import Linear.Expr.Types (ExprVarsOnly) -import Linear.Expr.Util (exprVarsOnlyVars) -import Linear.System.Linear.Types (LinearSystem (..)) -import Linear.System.Simple.Types -import Linear.Var.Types (SimplexNum, Var) - --- Expr == SimplexNum --- TODO: think about a better name for this type, CanonicalForm? -data SlackForm = SlackForm - { maxObjective :: ExprVarsOnly - , constraints :: LinearSystem - , vars :: Set.Set Var -- all vars are non-negative - } - deriving (Show, Eq, Read, Generic) - -class CanBeSlackForm a where - toSlackForm :: a -> ExprVarsOnly -> SlackForm - -instance CanBeSlackForm LinearSystem where - toSlackForm ls obj = - SlackForm - obj - ls - (Set.unions $ map (exprVarsOnlyVars . lhs) ls.unLinearSystem) diff --git a/src/Linear/System/Linear/Types.hs b/src/Linear/System/Linear/Types.hs index 133bc3a..30d06a7 100644 --- a/src/Linear/System/Linear/Types.hs +++ b/src/Linear/System/Linear/Types.hs @@ -12,14 +12,20 @@ import Linear.Constraint.Linear.Types (LinearEquation) import Linear.Expr.Types (Expr) -- TODO: name this system of equations or something +-- TODO: OR, should I just get rid of this? newtype LinearSystem = LinearSystem {unLinearSystem :: [LinearEquation]} deriving (Show, Eq, Read, Generic) -class CanBeLinearSystem a where - toLinearSystem :: a -> LinearSystem +{- When would I ever want this? Do I need things to be able to be +able to turn into linear systems? Yes. But do I want other people +to be able to do that? It would be nice, but I think we do that in +the future if people actually want it. +-} +-- class CanBeLinearSystem a where +-- toLinearSystem :: a -> LinearSystem -instance CanBeLinearSystem LinearSystem where - toLinearSystem = id +-- instance CanBeLinearSystem LinearSystem where +-- toLinearSystem = id -instance CanBeLinearSystem LinearEquation where - toLinearSystem id = LinearSystem [id] +-- instance CanBeLinearSystem LinearEquation where +-- toLinearSystem id = LinearSystem [id] diff --git a/src/Linear/System/Linear/Util.hs b/src/Linear/System/Linear/Util.hs index dd6781a..4f3cc8d 100644 --- a/src/Linear/System/Linear/Util.hs +++ b/src/Linear/System/Linear/Util.hs @@ -7,10 +7,11 @@ -- Stability: experimental module Linear.System.Linear.Util where +import qualified Data.Set as Set import Linear.Constraint.Linear.Types (LinearEquation (..)) import qualified Linear.Constraint.Linear.Util as CLU import Linear.System.Linear.Types (LinearSystem (..)) -import Linear.Var.Types (Var) +import Linear.Var.Types (Var, VarBounds) -- | Prepend a linear equation to a linear system prependLinearEquation :: LinearEquation -> LinearSystem -> LinearSystem @@ -23,3 +24,6 @@ appendLinearEquation eq (LinearSystem eqs) = LinearSystem (eqs ++ [eq]) findHighestVar :: LinearSystem -> Maybe Var findHighestVar (LinearSystem []) = Nothing findHighestVar (LinearSystem eqs) = Just $ maximum $ map CLU.findHighestVar eqs + +linearSystemVars :: LinearSystem -> Set.Set Var +linearSystemVars = Set.unions . map CLU.linearEquationVars . unLinearSystem diff --git a/src/Linear/System/Simple/Types.hs b/src/Linear/System/Simple/Types.hs index 647277c..c77a598 100644 --- a/src/Linear/System/Simple/Types.hs +++ b/src/Linear/System/Simple/Types.hs @@ -7,7 +7,7 @@ -- Stability: experimental module Linear.System.Simple.Types where -import Comparison.Types (getMixedComparisonLHS) +import Comparison.Types (getLHS) import qualified Data.Set as Set import GHC.Generics (Generic) import Linear.Constraint.Simple.Types (SimpleConstraint) diff --git a/src/Linear/System/Simple/Util.hs b/src/Linear/System/Simple/Util.hs index 6c40fe5..cfe5b2c 100644 --- a/src/Linear/System/Simple/Util.hs +++ b/src/Linear/System/Simple/Util.hs @@ -48,9 +48,8 @@ deriveBounds simpleSystem = foldr updateBounds initialVarBounds simpleSystem.unS -- Eliminate inequalities which are outside the bounds -- precondition: no zero coefficients --- TODO: better name -removeUselessSystemBounds :: SimpleSystem -> VarBounds -> SimpleSystem -removeUselessSystemBounds constraints bounds = +removeObviousInequalities :: SimpleSystem -> VarBounds -> SimpleSystem +removeObviousInequalities constraints bounds = SimpleSystem $ filter ( \case diff --git a/src/Linear/System/Types.hs b/src/Linear/System/Types.hs index 84a7a41..c279f49 100644 --- a/src/Linear/System/Types.hs +++ b/src/Linear/System/Types.hs @@ -2,9 +2,6 @@ module Linear.System.Types where import Linear.Constraint.Types (Constraint) --- class System s where --- isFeasible :: s -> Bool - -- TODO: create Sytem type, list of Constraints newtype System = System {unSystem :: [Constraint]} deriving (Show, Eq, Read) diff --git a/src/Linear/Var/Types.hs b/src/Linear/Var/Types.hs index 5100b10..3a32172 100644 --- a/src/Linear/Var/Types.hs +++ b/src/Linear/Var/Types.hs @@ -3,19 +3,14 @@ module Linear.Var.Types where import qualified Data.Map as M import GHC.Generics (Generic) --- TODO: Consider other names: SimplexCoeff, CoeffType type SimplexNum = Rational --- TODO: newtype type Var = Int data Bounds = Bounds - { lowerBound :: Maybe SimplexNum - , upperBound :: Maybe SimplexNum + { lowerBound :: !(Maybe SimplexNum) + , upperBound :: !(Maybe SimplexNum) } deriving (Show, Read, Eq, Generic) --- newtype VarBounds = VarBounds { unVarBounds :: M.Map Var Bounds } --- deriving (Show, Read, Eq, Generic) - type VarBounds = M.Map Var Bounds diff --git a/test/Linear/SlackForm/UtilSpec.hs b/test/Linear/CanonicalForm/UtilSpec.hs similarity index 92% rename from test/Linear/SlackForm/UtilSpec.hs rename to test/Linear/CanonicalForm/UtilSpec.hs index 944ed80..1e57cfe 100644 --- a/test/Linear/SlackForm/UtilSpec.hs +++ b/test/Linear/CanonicalForm/UtilSpec.hs @@ -1,8 +1,8 @@ -module Linear.SlackForm.UtilSpec where +module Linear.CanonicalForm.UtilSpec where import Comparison.Types ( MixedComparison ((:<=), (:==), (:>=)) - , getMixedComparisonLHS + , getLHS ) import Control.Monad (forM) import Data.Functor ((<&>)) @@ -14,8 +14,8 @@ import qualified Debug.Trace as T import Linear.Constraint.Linear.Types (LinearEquation (..)) import Linear.Constraint.Simple.Types (SimpleConstraint (..)) import Linear.Expr.Types (Expr (..), ExprVarsOnly (..)) -import Linear.SlackForm.Util - ( addSlackVariables +import Linear.CanonicalForm.Util + ( addSlackVars , eliminateNonZeroLowerBounds , eliminateUnrestrictedLowerBounds ) @@ -137,7 +137,7 @@ spec = describe "Slack Form Transformations" $ do any ( \(SimpleConstraint constraint) -> let getVars _a = [] - lhs = getMixedComparisonLHS constraint + lhs = getLHS constraint allVars = getVars lhs in var `notElem` allVars ) @@ -145,7 +145,7 @@ spec = describe "Slack Form Transformations" $ do ) (Map.toList updatedBounds) it - "addSlackVariables correctly transforms inequalities to equalities (wikipedia case)" + "addSlackVars correctly transforms inequalities to equalities (wikipedia case)" $ do let simpleSystem = SimpleSystem @@ -160,11 +160,11 @@ spec = describe "Slack Form Transformations" $ do 2 -- -x_4 + 3x_5 + x_7 = 2 ] expectedSlackVars = [6, 7] - (slackVars, updatedSystem) = addSlackVariables simpleSystem + (slackVars, updatedSystem) = addSlackVars simpleSystem updatedSystem `shouldBe` expectedSystem slackVars `shouldBe` expectedSlackVars it - "addSlackVariables correctly transforms inequalities to equalities (test case 1)" + "addSlackVars correctly transforms inequalities to equalities (test case 1)" $ do let simpleSystem = SimpleSystem @@ -179,11 +179,11 @@ spec = describe "Slack Form Transformations" $ do 3 -- -x_3 + 2x_4 - x_6 = 3 ] expectedSlackVars = [5, 6] - (slackVars, updatedSystem) = addSlackVariables simpleSystem + (slackVars, updatedSystem) = addSlackVars simpleSystem updatedSystem `shouldBe` expectedSystem slackVars `shouldBe` expectedSlackVars it - "addSlackVariables correctly transforms inequalities to equalities (test case 2)" + "addSlackVars correctly transforms inequalities to equalities (test case 2)" $ do let simpleSystem = SimpleSystem @@ -198,11 +198,11 @@ spec = describe "Slack Form Transformations" $ do 4 -- -x_3 + 2x_4 - x_6 = 4 ] expectedSlackVars = [5, 6] - (slackVars, updatedSystem) = addSlackVariables simpleSystem + (slackVars, updatedSystem) = addSlackVars simpleSystem updatedSystem `shouldBe` expectedSystem slackVars `shouldBe` expectedSlackVars it - "addSlackVariables correctly transforms inequalities to equalities (test case 3)" + "addSlackVars correctly transforms inequalities to equalities (test case 3)" $ do let simpleSystem = SimpleSystem @@ -215,11 +215,11 @@ spec = describe "Slack Form Transformations" $ do , LinearEquation (ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4])) 4 -- -x_3 + 2x_4 = 4 ] expectedSlackVars = [5] - (slackVars, updatedSystem) = addSlackVariables simpleSystem + (slackVars, updatedSystem) = addSlackVars simpleSystem updatedSystem `shouldBe` expectedSystem slackVars `shouldBe` expectedSlackVars it - "addSlackVariables correctly transforms inequalities to equalities (test case 4)" + "addSlackVars correctly transforms inequalities to equalities (test case 4)" $ do let simpleSystem = SimpleSystem @@ -232,7 +232,7 @@ spec = describe "Slack Form Transformations" $ do , LinearEquation (ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4])) 4 -- -x_3 + 2x_4 = 4 ] expectedSlackVars = [] - (slackVars, updatedSystem) = addSlackVariables simpleSystem + (slackVars, updatedSystem) = addSlackVars simpleSystem updatedSystem `shouldBe` expectedSystem slackVars `shouldBe` expectedSlackVars it @@ -245,7 +245,7 @@ spec = describe "Slack Form Transformations" $ do ] systemBounds = deriveBounds simpleSystem (eliminatedNonZeroLowerBounds, systemWithoutNonZeroLowerBounds) = eliminateNonZeroLowerBounds simpleSystem Map.empty - (slackVars, systemWithSlackVars) = addSlackVariables systemWithoutNonZeroLowerBounds + (slackVars, systemWithSlackVars) = addSlackVars systemWithoutNonZeroLowerBounds (updatedEliminatedVarsMap, updatedSystem) = eliminateUnrestrictedLowerBounds systemWithSlackVars @@ -276,7 +276,7 @@ spec = describe "Slack Form Transformations" $ do ] systemBounds = deriveBounds simpleSystem (eliminatedNonZeroLowerBounds, systemWithoutNonZeroLowerBounds) = eliminateNonZeroLowerBounds simpleSystem Map.empty - (slackVars, systemWithSlackVars) = addSlackVariables systemWithoutNonZeroLowerBounds + (slackVars, systemWithSlackVars) = addSlackVars systemWithoutNonZeroLowerBounds (updatedEliminatedVarsMap, updatedSystem) = eliminateUnrestrictedLowerBounds systemWithSlackVars @@ -314,7 +314,7 @@ spec = describe "Slack Form Transformations" $ do ] systemBounds = deriveBounds simpleSystem (eliminatedNonZeroLowerBounds, systemWithoutNonZeroLowerBounds) = eliminateNonZeroLowerBounds simpleSystem Map.empty - (slackVars, systemWithSlackVars) = addSlackVariables systemWithoutNonZeroLowerBounds + (slackVars, systemWithSlackVars) = addSlackVars systemWithoutNonZeroLowerBounds expectedSlackVars = [4, 5, 6] (updatedEliminatedVarsMap, updatedSystem) = eliminateUnrestrictedLowerBounds @@ -355,7 +355,7 @@ spec = describe "Slack Form Transformations" $ do ] systemBounds = deriveBounds simpleSystem (eliminatedNonZeroLowerBounds, systemWithoutNonZeroLowerBounds) = eliminateNonZeroLowerBounds simpleSystem Map.empty - (slackVars, systemWithSlackVars) = addSlackVariables systemWithoutNonZeroLowerBounds + (slackVars, systemWithSlackVars) = addSlackVars systemWithoutNonZeroLowerBounds expectedSlackVars = [3, 4] (updatedEliminatedVarsMap, updatedSystem) = eliminateUnrestrictedLowerBounds @@ -394,7 +394,7 @@ spec = describe "Slack Form Transformations" $ do ] systemBounds = deriveBounds simpleSystem (eliminatedNonZeroLowerBounds, systemWithoutNonZeroLowerBounds) = eliminateNonZeroLowerBounds simpleSystem Map.empty - (slackVars, systemWithSlackVars) = addSlackVariables systemWithoutNonZeroLowerBounds + (slackVars, systemWithSlackVars) = addSlackVars systemWithoutNonZeroLowerBounds expectedSlackVars = [3, 4] (updatedEliminatedVarsMap, updatedSystem) = eliminateUnrestrictedLowerBounds diff --git a/test/Linear/System/Simple/UtilSpec.hs b/test/Linear/System/Simple/UtilSpec.hs index c328828..f872807 100644 --- a/test/Linear/System/Simple/UtilSpec.hs +++ b/test/Linear/System/Simple/UtilSpec.hs @@ -23,7 +23,7 @@ import Linear.System.Simple.Types ) import Linear.System.Simple.Util ( deriveBounds - , removeUselessSystemBounds + , removeObviousInequalities ) import Linear.Term.Types (TermVarsOnly (..)) import Linear.Var.Types (Bounds (..)) @@ -192,46 +192,46 @@ spec = do expectedBounds = Map.fromList [(0, Bounds (Just 0) (Just 1)), (1, Bounds (Just 3) (Just 1))] derivedBounds `shouldBe` expectedBounds validateBounds derivedBounds `shouldBe` False - it "removeUselessSystemBounds removes x <= 3 when bounds say x <= 2" $ do + it "removeObviousInequalities removes x <= 3 when bounds say x <= 2" $ do let simpleSystem = SimpleSystem [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 2 , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 3 ] bounds = Map.fromList [(0, Bounds (Just 0) (Just 2))] - simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds + simplifiedSimpleSystem = removeObviousInequalities simpleSystem bounds expectedSimpleSystem = SimpleSystem [SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 2] simplifiedSimpleSystem `shouldBe` expectedSimpleSystem - it "removeUselessSystemBounds does not remove x <= 2 when bounds say x <= 2" $ do + it "removeObviousInequalities does not remove x <= 2 when bounds say x <= 2" $ do let simpleSystem = SimpleSystem [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 2 ] bounds = Map.fromList [(0, Bounds (Just 0) (Just 2))] - simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds + simplifiedSimpleSystem = removeObviousInequalities simpleSystem bounds expectedSimpleSystem = SimpleSystem [SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 2] simplifiedSimpleSystem `shouldBe` expectedSimpleSystem - it "removeUselessSystemBounds removes x >= 3 when bounds say x >= 4" $ do + it "removeObviousInequalities removes x >= 3 when bounds say x >= 4" $ do let simpleSystem = SimpleSystem [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 4 , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 3 ] bounds = Map.fromList [(0, Bounds (Just 4) (Just 5))] - simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds + simplifiedSimpleSystem = removeObviousInequalities simpleSystem bounds expectedSimpleSystem = SimpleSystem [SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 4] simplifiedSimpleSystem `shouldBe` expectedSimpleSystem - it "removeUselessSystemBounds does not remove x >= 4 when bounds say x >= 4" $ do + it "removeObviousInequalities does not remove x >= 4 when bounds say x >= 4" $ do let simpleSystem = SimpleSystem [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 4 ] bounds = Map.fromList [(0, Bounds (Just 4) (Just 5))] - simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds + simplifiedSimpleSystem = removeObviousInequalities simpleSystem bounds expectedSimpleSystem = SimpleSystem [SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 4] simplifiedSimpleSystem `shouldBe` expectedSimpleSystem it - "removeUselessSystemBounds does not remove 0 <= x <= 2 when bounds say 0 <= x <= 2" + "removeObviousInequalities does not remove 0 <= x <= 2 when bounds say 0 <= x <= 2" $ do let simpleSystem = SimpleSystem @@ -239,7 +239,7 @@ spec = do , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 2 ] bounds = Map.fromList [(0, Bounds (Just 0) (Just 2))] - simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds + simplifiedSimpleSystem = removeObviousInequalities simpleSystem bounds expectedSimpleSystem = SimpleSystem [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 0 @@ -247,7 +247,7 @@ spec = do ] simplifiedSimpleSystem `shouldBe` expectedSimpleSystem it - "removeUselessSystemBounds removes upper bound of 0 <= x <= 2 when bounds say 0 <= x <= 1" + "removeObviousInequalities removes upper bound of 0 <= x <= 2 when bounds say 0 <= x <= 1" $ do let simpleSystem = SimpleSystem @@ -255,11 +255,11 @@ spec = do , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 2 ] bounds = Map.fromList [(0, Bounds (Just 0) (Just 1))] - simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds + simplifiedSimpleSystem = removeObviousInequalities simpleSystem bounds expectedSimpleSystem = SimpleSystem [SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 0] simplifiedSimpleSystem `shouldBe` expectedSimpleSystem it - "removeUselessSystemBounds removes lower bound of 0 <= x <= 2 when bounds say 1 <= x <= 2" + "removeObviousInequalities removes lower bound of 0 <= x <= 2 when bounds say 1 <= x <= 2" $ do let simpleSystem = SimpleSystem @@ -267,7 +267,7 @@ spec = do , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 2 ] bounds = Map.fromList [(0, Bounds (Just 1) (Just 2))] - simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds + simplifiedSimpleSystem = removeObviousInequalities simpleSystem bounds expectedSimpleSystem = SimpleSystem [SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 2] simplifiedSimpleSystem `shouldBe` expectedSimpleSystem it "removeUselssSystemBounds only removes constraints of the form x <= c" $ do @@ -278,7 +278,7 @@ spec = do , SimpleConstraint $ ExprVarsOnly [CoeffTermVO 2 0] :<= 6 ] bounds = Map.fromList [(0, Bounds (Just 0) (Just 2))] - simplifiedSimpleSystem = removeUselessSystemBounds simpleSystem bounds + simplifiedSimpleSystem = removeObviousInequalities simpleSystem bounds expectedSimpleSystem = SimpleSystem [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 2 From 6a69fdb5f062a02a47a07e6f1afa949c7a35832b Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 1 Mar 2025 13:09:19 +0000 Subject: [PATCH 47/47] implement pivoting in new type system --- package.yaml | 1 + simplex-method.cabal | 9 +- src/Linear/CanonicalForm/Solver.hs | 9 ++ src/Linear/CanonicalForm/Util.hs | 13 +- src/Linear/Simplex/Solver/TwoPhase.hs | 3 +- src/Linear/Simplex/Types.hs | 4 +- src/Linear/Simplex/Util.hs | 3 +- src/Linear/System/Simple/Types.hs | 6 +- src/Linear/Tableau/Types.hs | 89 ++++++++++++ src/Linear/Var/Types.hs | 5 +- src/Linear/Var/Util.hs | 8 +- test/Linear/CanonicalForm/UtilSpec.hs | 181 +++++++++++++------------ test/Linear/System/Simple/UtilSpec.hs | 164 +++++++++++------------ test/Linear/Tableau/TypesSpec.hs | 78 +++++++++++ test/Linear/Term/UtilSpec.hs | 186 +++++++++++++------------- test/Linear/Var/UtilSpec.hs | 27 ++-- test/TestUtil.hs | 17 ++- 17 files changed, 499 insertions(+), 304 deletions(-) create mode 100644 src/Linear/CanonicalForm/Solver.hs create mode 100644 src/Linear/Tableau/Types.hs create mode 100644 test/Linear/Tableau/TypesSpec.hs diff --git a/package.yaml b/package.yaml index 7be037d..80225a5 100644 --- a/package.yaml +++ b/package.yaml @@ -38,6 +38,7 @@ default-extensions: DisambiguateRecordFields DuplicateRecordFields FlexibleContexts + GeneralizedNewtypeDeriving LambdaCase OverloadedLabels OverloadedRecordDot diff --git a/simplex-method.cabal b/simplex-method.cabal index 5cbdd65..48b78e1 100644 --- a/simplex-method.cabal +++ b/simplex-method.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack @@ -28,6 +28,7 @@ source-repository head library exposed-modules: Comparison.Types + Linear.CanonicalForm.Solver Linear.CanonicalForm.Types Linear.CanonicalForm.Util Linear.Constraint.Linear.Types @@ -49,6 +50,7 @@ library Linear.System.Simple.Types Linear.System.Simple.Util Linear.System.Types + Linear.Tableau.Types Linear.Term.Types Linear.Term.Util Linear.Var.Types @@ -58,7 +60,7 @@ library hs-source-dirs: src default-extensions: - DataKinds DeriveFunctor DeriveGeneric DerivingStrategies DisambiguateRecordFields DuplicateRecordFields FlexibleContexts LambdaCase OverloadedLabels OverloadedRecordDot OverloadedStrings RecordWildCards TemplateHaskell TupleSections TypeApplications TypeFamilies NamedFieldPuns + DataKinds DeriveFunctor DeriveGeneric DerivingStrategies DisambiguateRecordFields DuplicateRecordFields FlexibleContexts GeneralizedNewtypeDeriving LambdaCase OverloadedLabels OverloadedRecordDot OverloadedStrings RecordWildCards TemplateHaskell TupleSections TypeApplications TypeFamilies NamedFieldPuns build-depends: QuickCheck , base >=4.14 && <5 @@ -79,6 +81,7 @@ test-suite simplex-method-test Linear.Constraint.Simple.UtilSpec Linear.Expr.UtilSpec Linear.System.Simple.UtilSpec + Linear.Tableau.TypesSpec Linear.Term.UtilSpec Linear.Var.UtilSpec TestUtil @@ -86,7 +89,7 @@ test-suite simplex-method-test hs-source-dirs: test default-extensions: - DataKinds DeriveFunctor DeriveGeneric DerivingStrategies DisambiguateRecordFields DuplicateRecordFields FlexibleContexts LambdaCase OverloadedLabels OverloadedRecordDot OverloadedStrings RecordWildCards TemplateHaskell TupleSections TypeApplications TypeFamilies NamedFieldPuns + DataKinds DeriveFunctor DeriveGeneric DerivingStrategies DisambiguateRecordFields DuplicateRecordFields FlexibleContexts GeneralizedNewtypeDeriving LambdaCase OverloadedLabels OverloadedRecordDot OverloadedStrings RecordWildCards TemplateHaskell TupleSections TypeApplications TypeFamilies NamedFieldPuns build-depends: QuickCheck , base >=4.14 && <5 diff --git a/src/Linear/CanonicalForm/Solver.hs b/src/Linear/CanonicalForm/Solver.hs new file mode 100644 index 0000000..17bb703 --- /dev/null +++ b/src/Linear/CanonicalForm/Solver.hs @@ -0,0 +1,9 @@ +module Linear.CanonicalForm.Solver where + +import Prelude + +import Linear.CanonicalForm.Types (CanonicalForm(..)) + +-- TwoPhase + +-- Revised diff --git a/src/Linear/CanonicalForm/Util.hs b/src/Linear/CanonicalForm/Util.hs index 5491e8d..f74fd96 100644 --- a/src/Linear/CanonicalForm/Util.hs +++ b/src/Linear/CanonicalForm/Util.hs @@ -35,7 +35,8 @@ import Linear.Term.Types ( Term (..) , TermVarsOnly (..) ) -import Linear.Var.Types (Bounds (..), Var, VarBounds) +import Linear.Var.Types (Bounds (..), Var(..), VarBounds) +import qualified Linear.Var.Util as LVU -- | Eliminate non-zero lower bounds via substitution -- Return the system with the eliminated variables and a map of the eliminated variables to their equivalent expressions @@ -85,7 +86,7 @@ addSlackVars constraints = aux (c : cs) nextVar slackVars = case c of (SimpleConstraint (ExprVarsOnly exprTs :<= num)) -> let slackVar = nextVar - newNextVar = nextVar + 1 + newNextVar = LVU.nextVar nextVar newExpr = ExprVarsOnly $ exprTs ++ [VarTermVO slackVar] -- slackVarLowerBound = Expr (VarTerm slackVar : []) :>= 0 (newSlackVars, newConstraints) = aux cs newNextVar slackVars @@ -94,7 +95,7 @@ addSlackVars constraints = ) (SimpleConstraint (ExprVarsOnly exprTs :>= num)) -> let slackVar = nextVar - newNextVar = nextVar + 1 + newNextVar = LVU.nextVar nextVar newExpr = ExprVarsOnly $ exprTs ++ [CoeffTermVO (-1) slackVar] -- slackVarLowerBound = Expr (VarTerm slackVar : []) :>= 0 (newSlackVars, newConstraints) = aux cs newNextVar slackVars @@ -120,9 +121,9 @@ eliminateUnrestrictedLowerBounds constraints varBoundMap eliminatedVarsMap = aux LinearSystem -> [(Var, Bounds)] -> (Map.Map Var Expr, LinearSystem) aux _ [] = (eliminatedVarsMap, constraints) aux cs ((var, Bounds Nothing _) : bounds) = - let highestVar = Maybe.fromMaybe (-1) $ SLU.findHighestVar constraints - newVarPlus = highestVar + 1 - newVarMinus = newVarPlus + 1 + let highestVar = Maybe.fromMaybe (Var (-1)) $ SLU.findHighestVar constraints + newVarPlus = LVU.nextVar highestVar + newVarMinus = LVU.nextVar newVarPlus -- newVarPlusLowerBound = Expr (VarTerm newVarPlus : []) :>= 0 -- newVarMinusLowerBound = Expr (VarTerm newVarMinus : []) :>= 0 diff --git a/src/Linear/Simplex/Solver/TwoPhase.hs b/src/Linear/Simplex/Solver/TwoPhase.hs index ce07010..14b1ca9 100644 --- a/src/Linear/Simplex/Solver/TwoPhase.hs +++ b/src/Linear/Simplex/Solver/TwoPhase.hs @@ -43,6 +43,7 @@ import Linear.Simplex.Types , Tableau , TableauRow (rhs) , VarLitMapSum + , Var ) import Linear.Simplex.Util ( combineVarLitMapSums @@ -54,7 +55,7 @@ import Linear.Simplex.Util , showT , tableauInDictionaryForm ) -import Linear.Var.Types (SimplexNum, Var) +import Linear.Var.Types (SimplexNum) import Prelude hiding (EQ) -- | Find a feasible solution for the given system of 'StandardConstraint's by performing the first phase of the two-phase simplex method diff --git a/src/Linear/Simplex/Types.hs b/src/Linear/Simplex/Types.hs index 36f2163..2a3c952 100644 --- a/src/Linear/Simplex/Types.hs +++ b/src/Linear/Simplex/Types.hs @@ -18,9 +18,11 @@ import qualified Debug.Trace as T import GHC.Base (liftA2) import GHC.Generics (Generic) import Linear.Expr.Types (Expr) -import Linear.Var.Types (SimplexNum, Var) +import Linear.Var.Types (SimplexNum) import Test.QuickCheck (Arbitrary (..), genericShrink, oneof) +type Var = Int + data StandardFormRow = StandardFormRow { lhs :: Expr , rhs :: SimplexNum diff --git a/src/Linear/Simplex/Util.hs b/src/Linear/Simplex/Util.hs index 8ec5005..e5a45b8 100644 --- a/src/Linear/Simplex/Util.hs +++ b/src/Linear/Simplex/Util.hs @@ -37,8 +37,9 @@ import Linear.Simplex.Types , TableauRow (TableauRow, lhs, rhs) , VarLitMap , VarLitMapSum + , Var ) -import Linear.Var.Types (SimplexNum, Var) +import Linear.Var.Types (SimplexNum) import Prelude hiding (EQ) -- | Is the given 'ObjectiveFunction' to be 'Max'imized? diff --git a/src/Linear/System/Simple/Types.hs b/src/Linear/System/Simple/Types.hs index c77a598..f2e2540 100644 --- a/src/Linear/System/Simple/Types.hs +++ b/src/Linear/System/Simple/Types.hs @@ -18,7 +18,7 @@ import Linear.Constraint.Simple.Util import Linear.Expr.Util (exprVarsOnlyToList) import Linear.System.Types (System) import Linear.Term.Types (TermVarsOnly (..)) -import Linear.Var.Types (Var) +import Linear.Var.Types (Var(..)) import Test.QuickCheck (Arbitrary (..)) -- TODO: Use a more descriptive name @@ -44,8 +44,8 @@ findHighestVar simpleSystem = nextAvailableVar :: SimpleSystem -> Var nextAvailableVar simpleSystem = case findHighestVar simpleSystem of - Just v -> v + 1 - Nothing -> 0 + Just v -> Var $ v.unVar + 1 + Nothing -> Var 0 class CanBeSimpleSystem a where toSimpleSystem :: a -> SimpleSystem diff --git a/src/Linear/Tableau/Types.hs b/src/Linear/Tableau/Types.hs new file mode 100644 index 0000000..b2d5b8f --- /dev/null +++ b/src/Linear/Tableau/Types.hs @@ -0,0 +1,89 @@ +module Linear.Tableau.Types where + +import qualified Data.Set as Set +import Test.QuickCheck (Arbitrary(..)) +import qualified Test.QuickCheck as QC + +import Linear.Var.Types (SimplexNum) +import Linear.Simplex.Solver.Types (Objective) +import Linear.CanonicalForm.Types (CanonicalForm) + +-- TODO: Consider a type where the size of the list is specified +-- | A row for a @Tableau@ +data TableauRow = TableauRow { coeffs :: ![SimplexNum] + -- ^ Variable coefficients + , rhs :: !SimplexNum + -- ^ Right-hand side constants + } + deriving stock (Show, Read, Eq) + +instance Arbitrary TableauRow where + arbitrary = + TableauRow <$> QC.listOf1 arbitrary <*> arbitrary + +-- | Type representing a Simplex Tableau +data Tableau = Tableau { rows :: ![TableauRow] + , basicVars :: !(Set.Set Int) -- TODO: document the sizes are the same + -- ^ Column index of the basic vars for each row + } + deriving stock (Show, Read, Eq) + +instance Arbitrary Tableau where + arbitrary = do + n <- QC.choose (1, 5) + rows <- QC.vectorOf n arbitrary + basicVars <- Set.fromList <$> QC.vectorOf n (QC.choose (0, 10)) + pure $ Tableau rows basicVars + +rowCoeffsLength :: TableauRow -> Int +rowCoeffsLength row = length row.coeffs + +rowLength :: TableauRow -> Int +rowLength row = 1 + rowCoeffsLength row + +-- | Perform a pivot operation on a @Tableau@ +pivot :: Int -- ^ Entering column index (0-based) + -> Int -- ^ Leaving row index (0-based) + -> Tableau + -> Tableau +pivot enteringCol leavingRowIdx tableau = + let + -- Split tableau into leaving row and others + (beforeRows, pivotRow:afterRows) = splitAt leavingRowIdx tableau.rows + pivotElemCoeff = getCoeff enteringCol pivotRow + + -- Normalize pivot row + normalizedRow = TableauRow + { coeffs = map (/ pivotElemCoeff) pivotRow.coeffs + , rhs = pivotRow.rhs / pivotElemCoeff + } + + -- Update all other rows + adjustedRows = map (adjustRow normalizedRow enteringCol) (beforeRows ++ afterRows) + (adjustedBefore, adjustedAfter) = splitAt leavingRowIdx adjustedRows + newRows = adjustedBefore ++ [normalizedRow] ++ adjustedAfter + + -- Update basic variables + newBasicVars = updateBasicVar leavingRowIdx enteringCol tableau.basicVars + in + Tableau + { rows = newRows + , basicVars = newBasicVars + } + where + getCoeff col (TableauRow cs _) = cs !! col + + -- Eliminate entering col using gaussian elimination + adjustRow normalizedRow enterCol' row = + let multiplier = getCoeff enterCol' row + adjustedCoeffs = zipWith (-) (coeffs row) (map (* multiplier) (coeffs normalizedRow)) + adjustedRHS = rhs row - multiplier * rhs normalizedRow + in TableauRow adjustedCoeffs adjustedRHS + + updateBasicVar idx newVar vars = + let (before, after) = (Set.take idx vars, Set.drop (idx + 1) vars) + in before <> Set.fromList [newVar] <> after + +mkTableau :: Objective -> CanonicalForm -> Tableau +mkTableau = undefined + diff --git a/src/Linear/Var/Types.hs b/src/Linear/Var/Types.hs index 3a32172..37d9df2 100644 --- a/src/Linear/Var/Types.hs +++ b/src/Linear/Var/Types.hs @@ -2,10 +2,13 @@ module Linear.Var.Types where import qualified Data.Map as M import GHC.Generics (Generic) +import Test.QuickCheck (Arbitrary) type SimplexNum = Rational -type Var = Int +newtype Var = Var { unVar :: Int } + deriving (Show, Read, Eq, Ord, Generic) + deriving newtype (Arbitrary) data Bounds = Bounds { lowerBound :: !(Maybe SimplexNum) diff --git a/src/Linear/Var/Util.hs b/src/Linear/Var/Util.hs index bd813dd..ff95de9 100644 --- a/src/Linear/Var/Util.hs +++ b/src/Linear/Var/Util.hs @@ -1,7 +1,7 @@ module Linear.Var.Util where import qualified Data.Map as M -import Linear.Var.Types (Bounds (..), VarBounds) +import Linear.Var.Types (Var(..), Bounds (..), VarBounds) validateBounds :: VarBounds -> Bool validateBounds boundsMap = all soundBounds $ M.toList boundsMap @@ -10,3 +10,9 @@ validateBounds boundsMap = all soundBounds $ M.toList boundsMap case (lowerBound, upperBound) of (Just l, Just u) -> l <= u (_, _) -> True + +nextVar :: Var -> Var +nextVar = Var . succ . unVar + +prevVar :: Var -> Var +prevVar = Var . pred . unVar diff --git a/test/Linear/CanonicalForm/UtilSpec.hs b/test/Linear/CanonicalForm/UtilSpec.hs index 1e57cfe..13d20fb 100644 --- a/test/Linear/CanonicalForm/UtilSpec.hs +++ b/test/Linear/CanonicalForm/UtilSpec.hs @@ -26,6 +26,9 @@ import Linear.Term.Types ( Term (..) , TermVarsOnly (..) ) +import Linear.Var.Types + ( Var (..) + ) import Test.Hspec (Spec, describe, it, shouldBe) import Test.QuickCheck (Testable (property), withMaxSuccess) @@ -40,14 +43,14 @@ spec = describe "Slack Form Transformations" $ do $ do let simpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 0 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 0 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :>= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 1)] :>= 0 ] (updatedBounds, updatedSystem) = eliminateNonZeroLowerBounds simpleSystem Map.empty expectedSimpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 0 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 0 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :>= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 1)] :>= 0 ] expectedEliminatedVarExprMap = Map.empty updatedSystem `shouldBe` expectedSimpleSystem @@ -55,31 +58,31 @@ spec = describe "Slack Form Transformations" $ do it "eliminateNonZeroLowerBounds correctly eliminates positive lower bounds" $ do let simpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 1 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 0 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :>= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 1)] :>= 0 ] (updatedBounds, updatedSystem) = eliminateNonZeroLowerBounds simpleSystem Map.empty expectedSimpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 2] :>= 0 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 0 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 2)] :>= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 1)] :>= 0 ] - expectedEliminatedVarExprMap = Map.fromList [(0, Expr (VarTerm 2 : [ConstTerm 1]))] + expectedEliminatedVarExprMap = Map.fromList [(Var 0, Expr (VarTerm (Var 2) : [ConstTerm 1]))] updatedSystem `shouldBe` expectedSimpleSystem updatedBounds `shouldBe` expectedEliminatedVarExprMap it "eliminateNonZeroLowerBounds correctly eliminates negative lower bounds" $ do let simpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= (-1) - , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 0 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :>= (-1) + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 1)] :>= 0 ] (updatedBounds, updatedSystem) = eliminateNonZeroLowerBounds simpleSystem Map.empty expectedSimpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 2] :>= 0 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 0 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 2)] :>= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 1)] :>= 0 ] - expectedEliminatedVarExprMap = Map.fromList [(0, Expr (VarTerm 2 : [ConstTerm (-1)]))] + expectedEliminatedVarExprMap = Map.fromList [(Var 0, Expr (VarTerm (Var 2) : [ConstTerm (-1)]))] updatedSystem `shouldBe` expectedSimpleSystem updatedBounds `shouldBe` expectedEliminatedVarExprMap it @@ -87,19 +90,19 @@ spec = describe "Slack Form Transformations" $ do $ do let simpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 1 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= (-1) + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :>= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 1)] :>= (-1) ] (updatedBounds, updatedSystem) = eliminateNonZeroLowerBounds simpleSystem Map.empty expectedSimpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 2] :>= 0 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 3] :>= 0 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 2)] :>= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 3)] :>= 0 ] expectedEliminatedVarExprMap = Map.fromList - [ (0, Expr (VarTerm 2 : [ConstTerm 1])) - , (1, Expr (VarTerm 3 : [ConstTerm (-1)])) + [ (Var 0, Expr (VarTerm (Var 2) : [ConstTerm 1])) + , (Var 1, Expr (VarTerm (Var 3) : [ConstTerm (-1)])) ] updatedSystem `shouldBe` expectedSimpleSystem updatedBounds `shouldBe` expectedEliminatedVarExprMap @@ -108,25 +111,25 @@ spec = describe "Slack Form Transformations" $ do $ do let simpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 1 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 0 - , SimpleConstraint $ ExprVarsOnly (VarTermVO 0 : [VarTermVO 1]) :>= 1 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :>= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 1)] :>= 0 + , SimpleConstraint $ ExprVarsOnly (VarTermVO (Var 0) : [VarTermVO (Var 1)]) :>= 1 ] (updatedBounds, updatedSystem) = eliminateNonZeroLowerBounds simpleSystem Map.empty expectedSimpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 2] :>= 0 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 0 - , SimpleConstraint $ ExprVarsOnly (VarTermVO 1 : [VarTermVO 2]) :>= 0 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 2)] :>= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 1)] :>= 0 + , SimpleConstraint $ ExprVarsOnly (VarTermVO (Var 1) : [VarTermVO (Var 2)]) :>= 0 ] - expectedEliminatedVarExprMap = Map.fromList [(0, Expr (VarTerm 2 : [ConstTerm 1]))] + expectedEliminatedVarExprMap = Map.fromList [(Var 0, Expr (VarTerm (Var 2) : [ConstTerm 1]))] updatedSystem `shouldBe` expectedSimpleSystem updatedBounds `shouldBe` expectedEliminatedVarExprMap it "eliminateNonZeroLowerBounds property based test lower bounds" $ withMaxSuccess 5 $ property $ \simpleSystem -> do let (updatedBounds, updatedSystem) = eliminateNonZeroLowerBounds simpleSystem Map.empty all ( \case - SimpleConstraint (ExprVarsOnly [VarTermVO _] :>= num) -> num == 0 + SimpleConstraint (ExprVarsOnly [VarTermVO (Var _)] :>= num) -> num == 0 _ -> True ) updatedSystem.unSimpleSystem @@ -149,17 +152,17 @@ spec = describe "Slack Form Transformations" $ do $ do let simpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly (VarTermVO 2 : [CoeffTermVO 2 3]) :<= 3 -- x_2 + 2x_3 <= 3 - , SimpleConstraint $ ExprVarsOnly (CoeffTermVO (-1) 4 : [CoeffTermVO 3 5]) :>= 2 -- -x_4 + 3x_5 >= 2 + [ SimpleConstraint $ ExprVarsOnly (VarTermVO (Var 2) : [CoeffTermVO 2 (Var 3)]) :<= 3 -- x_2 + 2x_3 <= 3 + , SimpleConstraint $ ExprVarsOnly (CoeffTermVO (-1) (Var 4) : [CoeffTermVO 3 (Var 5)]) :>= 2 -- -x_4 + 3x_5 >= 2 ] expectedSystem = LinearSystem - [ LinearEquation (ExprVarsOnly (VarTermVO 2 : [CoeffTermVO 2 3, VarTermVO 6])) 3 -- x_2 + 2x_3 + x_6 = 3 + [ LinearEquation (ExprVarsOnly (VarTermVO (Var 2) : [CoeffTermVO 2 (Var 3), VarTermVO (Var 6)])) 3 -- x_2 + 2x_3 + x_6 = 3 , LinearEquation - (ExprVarsOnly (CoeffTermVO (-1) 4 : [CoeffTermVO 3 5, CoeffTermVO (-1) 7])) + (ExprVarsOnly (CoeffTermVO (-1) (Var 4) : [CoeffTermVO 3 (Var 5), CoeffTermVO (-1) (Var 7)])) 2 -- -x_4 + 3x_5 + x_7 = 2 ] - expectedSlackVars = [6, 7] + expectedSlackVars = [Var 6, Var 7] (slackVars, updatedSystem) = addSlackVars simpleSystem updatedSystem `shouldBe` expectedSystem slackVars `shouldBe` expectedSlackVars @@ -168,17 +171,17 @@ spec = describe "Slack Form Transformations" $ do $ do let simpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 2]) :<= 4 -- x_1 + 2x_2 <= 4 - , SimpleConstraint $ ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4]) :>= 3 -- -x_3 + 2x_4 >= 3 + [ SimpleConstraint $ ExprVarsOnly (VarTermVO (Var 1) : [CoeffTermVO 2 (Var 2)]) :<= 4 -- x_1 + 2x_2 <= 4 + , SimpleConstraint $ ExprVarsOnly (CoeffTermVO (-1) (Var 3) : [CoeffTermVO 2 (Var 4)]) :>= 3 -- -x_3 + 2x_4 >= 3 ] expectedSystem = LinearSystem - [ LinearEquation (ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 2, VarTermVO 5])) 4 -- x_1 + 2x_2 + x_5 = 4 + [ LinearEquation (ExprVarsOnly (VarTermVO (Var 1) : [CoeffTermVO 2 (Var 2), VarTermVO (Var 5)])) 4 -- x_1 + 2x_2 + x_5 = 4 , LinearEquation - (ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4, CoeffTermVO (-1) 6])) + (ExprVarsOnly (CoeffTermVO (-1) (Var 3) : [CoeffTermVO 2 (Var 4), CoeffTermVO (-1) (Var 6)])) 3 -- -x_3 + 2x_4 - x_6 = 3 ] - expectedSlackVars = [5, 6] + expectedSlackVars = [Var 5, Var 6] (slackVars, updatedSystem) = addSlackVars simpleSystem updatedSystem `shouldBe` expectedSystem slackVars `shouldBe` expectedSlackVars @@ -187,17 +190,17 @@ spec = describe "Slack Form Transformations" $ do $ do let simpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 2]) :<= 5 -- x_1 + 2x_2 <= 5 - , SimpleConstraint $ ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4]) :>= 4 -- -x_3 + 2x_4 >= 4 + [ SimpleConstraint $ ExprVarsOnly (VarTermVO (Var 1) : [CoeffTermVO 2 (Var 2)]) :<= 5 -- x_1 + 2x_2 <= 5 + , SimpleConstraint $ ExprVarsOnly (CoeffTermVO (-1) (Var 3) : [CoeffTermVO 2 (Var 4)]) :>= 4 -- -x_3 + 2x_4 >= 4 ] expectedSystem = LinearSystem - [ LinearEquation (ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 2, VarTermVO 5])) 5 -- x_1 + 2x_2 + x_5 = 5 + [ LinearEquation (ExprVarsOnly (VarTermVO (Var 1) : [CoeffTermVO 2 (Var 2), VarTermVO (Var 5)])) 5 -- x_1 + 2x_2 + x_5 = 5 , LinearEquation - (ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4, CoeffTermVO (-1) 6])) + (ExprVarsOnly (CoeffTermVO (-1) (Var 3) : [CoeffTermVO 2 (Var 4), CoeffTermVO (-1) (Var 6)])) 4 -- -x_3 + 2x_4 - x_6 = 4 ] - expectedSlackVars = [5, 6] + expectedSlackVars = [Var 5, Var 6] (slackVars, updatedSystem) = addSlackVars simpleSystem updatedSystem `shouldBe` expectedSystem slackVars `shouldBe` expectedSlackVars @@ -206,15 +209,15 @@ spec = describe "Slack Form Transformations" $ do $ do let simpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 2]) :<= 5 -- x_1 + 2x_2 <= 5 - , SimpleConstraint $ ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4]) :== 4 -- -x_3 + 2x_4 = 4 + [ SimpleConstraint $ ExprVarsOnly (VarTermVO (Var 1) : [CoeffTermVO 2 (Var 2)]) :<= 5 -- x_1 + 2x_2 <= 5 + , SimpleConstraint $ ExprVarsOnly (CoeffTermVO (-1) (Var 3) : [CoeffTermVO 2 (Var 4)]) :== 4 -- -x_3 + 2x_4 = 4 ] expectedSystem = LinearSystem - [ LinearEquation (ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 2, VarTermVO 5])) 5 -- x_1 + 2x_2 + x_5 = 5 - , LinearEquation (ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4])) 4 -- -x_3 + 2x_4 = 4 + [ LinearEquation (ExprVarsOnly (VarTermVO (Var 1) : [CoeffTermVO 2 (Var 2), VarTermVO (Var 5)])) 5 -- x_1 + 2x_2 + x_5 = 5 + , LinearEquation (ExprVarsOnly (CoeffTermVO (-1) (Var 3) : [CoeffTermVO 2 (Var 4)])) 4 -- -x_3 + 2x_4 = 4 ] - expectedSlackVars = [5] + expectedSlackVars = [Var 5] (slackVars, updatedSystem) = addSlackVars simpleSystem updatedSystem `shouldBe` expectedSystem slackVars `shouldBe` expectedSlackVars @@ -223,13 +226,13 @@ spec = describe "Slack Form Transformations" $ do $ do let simpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 2]) :== 5 -- x_1 + 2x_2 = 5 - , SimpleConstraint $ ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4]) :== 4 -- -x_3 + 2x_4 = 4 + [ SimpleConstraint $ ExprVarsOnly (VarTermVO (Var 1) : [CoeffTermVO 2 (Var 2)]) :== 5 -- x_1 + 2x_2 = 5 + , SimpleConstraint $ ExprVarsOnly (CoeffTermVO (-1) (Var 3) : [CoeffTermVO 2 (Var 4)]) :== 4 -- -x_3 + 2x_4 = 4 ] expectedSystem = LinearSystem - [ LinearEquation (ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 2])) 5 -- x_1 + 2x_2 = 5 - , LinearEquation (ExprVarsOnly (CoeffTermVO (-1) 3 : [CoeffTermVO 2 4])) 4 -- -x_3 + 2x_4 = 4 + [ LinearEquation (ExprVarsOnly (VarTermVO (Var 1) : [CoeffTermVO 2 (Var 2)])) 5 -- x_1 + 2x_2 = 5 + , LinearEquation (ExprVarsOnly (CoeffTermVO (-1) (Var 3) : [CoeffTermVO 2 (Var 4)])) 4 -- -x_3 + 2x_4 = 4 ] expectedSlackVars = [] (slackVars, updatedSystem) = addSlackVars simpleSystem @@ -240,8 +243,8 @@ spec = describe "Slack Form Transformations" $ do $ do let simpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 0 -- x_1 >= 0 - , SimpleConstraint $ ExprVarsOnly (VarTermVO 1 : [VarTermVO 2]) :>= 0 -- x_1 + x_2 >= 0 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 1)] :>= 0 -- x_1 >= 0 + , SimpleConstraint $ ExprVarsOnly (VarTermVO (Var 1) : [VarTermVO (Var 2)]) :>= 0 -- x_1 + x_2 >= 0 ] systemBounds = deriveBounds simpleSystem (eliminatedNonZeroLowerBounds, systemWithoutNonZeroLowerBounds) = eliminateNonZeroLowerBounds simpleSystem Map.empty @@ -251,17 +254,17 @@ spec = describe "Slack Form Transformations" $ do systemWithSlackVars systemBounds eliminatedNonZeroLowerBounds - expectedSlackVars = [3, 4] + expectedSlackVars = [Var 3, Var 4] expectedSystem = LinearSystem - [ LinearEquation (ExprVarsOnly (CoeffTermVO (-1) 3 : [VarTermVO 1])) 0 -- -x_3 + x_1 = 0 + [ LinearEquation (ExprVarsOnly (CoeffTermVO (-1) (Var 3) : [VarTermVO (Var 1)])) 0 -- -x_3 + x_1 = 0 , LinearEquation ( ExprVarsOnly - (CoeffTermVO (-1) 4 : [CoeffTermVO (-1) 6, VarTermVO 1, VarTermVO 5]) + (CoeffTermVO (-1) (Var 4) : [CoeffTermVO (-1) (Var 6), VarTermVO (Var 1), VarTermVO (Var 5)]) ) 0 -- -x_4 - x_6 + x_1 + x_5 = 0 ] - expectedEliminatedVarExprMap = Map.fromList [(2, Expr (VarTerm 5 : [CoeffTerm (-1) 6]))] + expectedEliminatedVarExprMap = Map.fromList [(Var 2, Expr (VarTerm (Var 5) : [CoeffTerm (-1) (Var 6)]))] slackVars `shouldBe` expectedSlackVars updatedSystem `shouldBe` expectedSystem @@ -271,8 +274,8 @@ spec = describe "Slack Form Transformations" $ do $ do let simpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 0 -- x_1 >= 0 - , SimpleConstraint $ ExprVarsOnly (VarTermVO 1 : [VarTermVO 2, VarTermVO 3]) :>= 0 -- x_1 + x_2 + x_3 >= 0 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 1)] :>= 0 -- x_1 >= 0 + , SimpleConstraint $ ExprVarsOnly (VarTermVO (Var 1) : [VarTermVO (Var 2), VarTermVO (Var 3)]) :>= 0 -- x_1 + x_2 + x_3 >= 0 ] systemBounds = deriveBounds simpleSystem (eliminatedNonZeroLowerBounds, systemWithoutNonZeroLowerBounds) = eliminateNonZeroLowerBounds simpleSystem Map.empty @@ -282,22 +285,22 @@ spec = describe "Slack Form Transformations" $ do systemWithSlackVars systemBounds eliminatedNonZeroLowerBounds - expectedSlackVars = [4, 5] + expectedSlackVars = [Var 4, Var 5] expectedSystem = LinearSystem - [ LinearEquation (ExprVarsOnly (CoeffTermVO (-1) 4 : [VarTermVO 1])) 0 -- -x_4 + x_1 = 0 + [ LinearEquation (ExprVarsOnly (CoeffTermVO (-1) (Var 4) : [VarTermVO (Var 1)])) 0 -- -x_4 + x_1 = 0 , LinearEquation ( ExprVarsOnly - ( CoeffTermVO (-1) 5 - : [CoeffTermVO (-1) 7, CoeffTermVO (-1) 9, VarTermVO 1, VarTermVO 6, VarTermVO 8] + ( CoeffTermVO (-1) (Var 5) + : [CoeffTermVO (-1) (Var 7), CoeffTermVO (-1) (Var 9), VarTermVO (Var 1), VarTermVO (Var 6), VarTermVO (Var 8)] ) ) 0 -- -x_5 - x_7 - x_9 + x_1 + x_6 + x_8 = 0 ] expectedEliminatedVarExprMap = Map.fromList - [ (2, Expr (VarTerm 6 : [CoeffTerm (-1) 7])) - , (3, Expr (VarTerm 8 : [CoeffTerm (-1) 9])) + [ (Var 2, Expr (VarTerm (Var 6) : [CoeffTerm (-1) (Var 7)])) + , (Var 3, Expr (VarTerm (Var 8) : [CoeffTerm (-1) (Var 9)])) ] slackVars `shouldBe` expectedSlackVars updatedSystem `shouldBe` expectedSystem @@ -308,14 +311,14 @@ spec = describe "Slack Form Transformations" $ do $ do let simpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 0 -- x_1 >= 0 - , SimpleConstraint $ ExprVarsOnly (VarTermVO 1 : [VarTermVO 2]) :>= 0 -- x_1 + x_2 >= 0 - , SimpleConstraint $ ExprVarsOnly (VarTermVO 2 : [VarTermVO 3]) :>= 0 -- x_2 + x_3 >= 0 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 1)] :>= 0 -- x_1 >= 0 + , SimpleConstraint $ ExprVarsOnly (VarTermVO (Var 1) : [VarTermVO (Var 2)]) :>= 0 -- x_1 + x_2 >= 0 + , SimpleConstraint $ ExprVarsOnly (VarTermVO (Var 2) : [VarTermVO (Var 3)]) :>= 0 -- x_2 + x_3 >= 0 ] systemBounds = deriveBounds simpleSystem (eliminatedNonZeroLowerBounds, systemWithoutNonZeroLowerBounds) = eliminateNonZeroLowerBounds simpleSystem Map.empty (slackVars, systemWithSlackVars) = addSlackVars systemWithoutNonZeroLowerBounds - expectedSlackVars = [4, 5, 6] + expectedSlackVars = [Var 4, Var 5, Var 6] (updatedEliminatedVarsMap, updatedSystem) = eliminateUnrestrictedLowerBounds systemWithSlackVars @@ -323,24 +326,24 @@ spec = describe "Slack Form Transformations" $ do eliminatedNonZeroLowerBounds expectedSystem = LinearSystem - [ LinearEquation (ExprVarsOnly (CoeffTermVO (-1) 4 : [VarTermVO 1])) 0 -- -x_4 + x_1 = 0 + [ LinearEquation (ExprVarsOnly (CoeffTermVO (-1) (Var 4) : [VarTermVO (Var 1)])) 0 -- -x_4 + x_1 = 0 , LinearEquation ( ExprVarsOnly - (CoeffTermVO (-1) 5 : [CoeffTermVO (-1) 8, VarTermVO 1, VarTermVO 7]) + (CoeffTermVO (-1) (Var 5) : [CoeffTermVO (-1) (Var 8), VarTermVO (Var 1), VarTermVO (Var 7)]) ) 0 -- -x_5 - x_8 + x_1 + x_7 = 0 , LinearEquation ( ExprVarsOnly - ( CoeffTermVO (-1) 6 - : [CoeffTermVO (-1) 8, CoeffTermVO (-1) 10, VarTermVO 7, VarTermVO 9] + ( CoeffTermVO (-1) (Var 6) + : [CoeffTermVO (-1) (Var 8), CoeffTermVO (-1) (Var 10), VarTermVO (Var 7), VarTermVO (Var 9)] ) ) 0 -- -x_6 - x_8 - x_10 + x_7 + x_9 = 0 ] expectedEliminatedVarExprMap = Map.fromList - [ (2, Expr (VarTerm 7 : [CoeffTerm (-1) 8])) - , (3, Expr (VarTerm 9 : [CoeffTerm (-1) 10])) + [ (Var 2, Expr (VarTerm (Var 7) : [CoeffTerm (-1) (Var 8)])) + , (Var 3, Expr (VarTerm (Var 9) : [CoeffTerm (-1) (Var 10)])) ] slackVars `shouldBe` expectedSlackVars updatedSystem `shouldBe` expectedSystem @@ -350,13 +353,13 @@ spec = describe "Slack Form Transformations" $ do $ do let simpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly (VarTermVO 1 : [CoeffTermVO 2 1]) :>= 0 -- x_1 + 2x_1 >= 0 - , SimpleConstraint $ ExprVarsOnly (VarTermVO 2 : [CoeffTermVO 3 1]) :>= 0 -- x_2 + 3x_1 >= 0 + [ SimpleConstraint $ ExprVarsOnly (VarTermVO (Var 1) : [CoeffTermVO 2 (Var 1)]) :>= 0 -- x_1 + 2x_1 >= 0 + , SimpleConstraint $ ExprVarsOnly (VarTermVO (Var 2) : [CoeffTermVO 3 (Var 1)]) :>= 0 -- x_2 + 3x_1 >= 0 ] systemBounds = deriveBounds simpleSystem (eliminatedNonZeroLowerBounds, systemWithoutNonZeroLowerBounds) = eliminateNonZeroLowerBounds simpleSystem Map.empty (slackVars, systemWithSlackVars) = addSlackVars systemWithoutNonZeroLowerBounds - expectedSlackVars = [3, 4] + expectedSlackVars = [Var 3, Var 4] (updatedEliminatedVarsMap, updatedSystem) = eliminateUnrestrictedLowerBounds systemWithSlackVars @@ -365,20 +368,20 @@ spec = describe "Slack Form Transformations" $ do expectedSystem = LinearSystem [ LinearEquation - (ExprVarsOnly (CoeffTermVO (-3) 6 : [CoeffTermVO (-1) 3, CoeffTermVO 3 5])) + (ExprVarsOnly (CoeffTermVO (-3) (Var 6) : [CoeffTermVO (-1) (Var 3), CoeffTermVO 3 (Var 5)])) 0 -- -3x_6 - x_3 + 3x_5 = 0 , LinearEquation ( ExprVarsOnly - ( CoeffTermVO (-3) 6 - : [CoeffTermVO (-1) 4, CoeffTermVO (-1) 8, CoeffTermVO 3 5, VarTermVO 7] + ( CoeffTermVO (-3) (Var 6) + : [CoeffTermVO (-1) (Var 4), CoeffTermVO (-1) (Var 8), CoeffTermVO 3 (Var 5), VarTermVO (Var 7)] ) ) 0 -- -3x_6 - x_4 - x_8 + 3x_5 + x_7 = 0 ] expectedEliminatedVarExprMap = Map.fromList - [ (1, Expr (VarTerm 5 : [CoeffTerm (-1) 6])) - , (2, Expr (VarTerm 7 : [CoeffTerm (-1) 8])) + [ (Var 1, Expr (VarTerm (Var 5) : [CoeffTerm (-1) (Var 6)])) + , (Var 2, Expr (VarTerm (Var 7) : [CoeffTerm (-1) (Var 8)])) ] slackVars `shouldBe` expectedSlackVars updatedSystem `shouldBe` expectedSystem @@ -389,13 +392,13 @@ spec = describe "Slack Form Transformations" $ do $ do let simpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 0 -- x_1 >= 0 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 2] :>= 0 -- x_2 >= 0 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 1)] :>= 0 -- x_1 >= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 2)] :>= 0 -- x_2 >= 0 ] systemBounds = deriveBounds simpleSystem (eliminatedNonZeroLowerBounds, systemWithoutNonZeroLowerBounds) = eliminateNonZeroLowerBounds simpleSystem Map.empty (slackVars, systemWithSlackVars) = addSlackVars systemWithoutNonZeroLowerBounds - expectedSlackVars = [3, 4] + expectedSlackVars = [Var 3, Var 4] (updatedEliminatedVarsMap, updatedSystem) = eliminateUnrestrictedLowerBounds systemWithSlackVars @@ -403,8 +406,8 @@ spec = describe "Slack Form Transformations" $ do eliminatedNonZeroLowerBounds expectedSystem = LinearSystem - [ LinearEquation (ExprVarsOnly (VarTermVO 1 : [CoeffTermVO (-1) 3])) 0 -- x_1 - x_3 = 0 - , LinearEquation (ExprVarsOnly (VarTermVO 2 : [CoeffTermVO (-1) 4])) 0 -- x_2 - x_4 = 0 + [ LinearEquation (ExprVarsOnly (VarTermVO (Var 1) : [CoeffTermVO (-1) (Var 3)])) 0 -- x_1 - x_3 = 0 + , LinearEquation (ExprVarsOnly (VarTermVO (Var 2) : [CoeffTermVO (-1) (Var 4)])) 0 -- x_2 - x_4 = 0 ] expectedEliminatedVarExprMap = Map.empty slackVars `shouldBe` expectedSlackVars diff --git a/test/Linear/System/Simple/UtilSpec.hs b/test/Linear/System/Simple/UtilSpec.hs index f872807..bfde917 100644 --- a/test/Linear/System/Simple/UtilSpec.hs +++ b/test/Linear/System/Simple/UtilSpec.hs @@ -26,7 +26,7 @@ import Linear.System.Simple.Util , removeObviousInequalities ) import Linear.Term.Types (TermVarsOnly (..)) -import Linear.Var.Types (Bounds (..)) +import Linear.Var.Types (Bounds (..), Var(..)) import Linear.Var.Util (validateBounds) import Test.Hspec (Spec, describe, it, shouldBe) import Test.Hspec.QuickCheck (prop) @@ -59,45 +59,45 @@ spec = do it "findHighestVar finds the highest variable in a simple system" $ do let simpleSystem1 = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 0 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 1 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 0 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :<= 1 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :>= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :<= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 1)] :>= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 1)] :<= 1 ] simpleSystem100 = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 1 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 50] :<= 1 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 100] :<= 1 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :<= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 50)] :<= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 100)] :<= 1 ] simpleSystem10 = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO (-10)] :<= 1 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 1 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 10] :<= 1 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var (-10))] :<= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :<= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 10)] :<= 1 ] simpleSystemMinus10 = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO (-10)] :<= 1 - , SimpleConstraint $ ExprVarsOnly [VarTermVO (-20)] :<= 1 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var (-10))] :<= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var (-20))] :<= 1 ] findHighestVar (SimpleSystem []) `shouldBe` Nothing - findHighestVar simpleSystem1 `shouldBe` Just 1 - findHighestVar simpleSystem100 `shouldBe` Just 100 - findHighestVar simpleSystem10 `shouldBe` Just 10 - findHighestVar simpleSystemMinus10 `shouldBe` Just (-10) + findHighestVar simpleSystem1 `shouldBe` Just (Var 1) + findHighestVar simpleSystem100 `shouldBe` Just (Var 100) + findHighestVar simpleSystem10 `shouldBe` Just (Var 10) + findHighestVar simpleSystemMinus10 `shouldBe` Just (Var (-10)) describe "Bounds" $ it "validateBounds finds that deriving bounds for a system where -1 <= x <= 1 has valid bounds" $ do let simpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= (-1) - , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 1 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :>= (-1) + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :<= 1 ] derivedBounds = deriveBounds simpleSystem - expectedBounds = Map.fromList [(0, Bounds (Just (-1)) (Just 1))] + expectedBounds = Map.fromList [(Var 0, Bounds (Just (-1)) (Just 1))] derivedBounds `shouldBe` expectedBounds validateBounds derivedBounds `shouldBe` True it @@ -105,11 +105,11 @@ spec = do $ do let simpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 0 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 1 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :>= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :<= 1 ] derivedBounds = deriveBounds simpleSystem - expectedBounds = Map.fromList [(0, Bounds (Just 0) (Just 1))] + expectedBounds = Map.fromList [(Var 0, Bounds (Just 0) (Just 1))] derivedBounds `shouldBe` expectedBounds validateBounds derivedBounds `shouldBe` True it @@ -117,11 +117,11 @@ spec = do $ do let simpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 1 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 1 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :>= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :<= 1 ] derivedBounds = deriveBounds simpleSystem - expectedBounds = Map.fromList [(0, Bounds (Just 1) (Just 1))] + expectedBounds = Map.fromList [(Var 0, Bounds (Just 1) (Just 1))] derivedBounds `shouldBe` expectedBounds validateBounds derivedBounds `shouldBe` True it @@ -129,11 +129,11 @@ spec = do $ do let simpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 1 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 0 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :>= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :<= 0 ] derivedBounds = deriveBounds simpleSystem - expectedBounds = Map.fromList [(0, Bounds (Just 1) (Just 0))] + expectedBounds = Map.fromList [(Var 0, Bounds (Just 1) (Just 0))] derivedBounds `shouldBe` expectedBounds validateBounds derivedBounds `shouldBe` False it @@ -141,13 +141,13 @@ spec = do $ do let simpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 0 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 1 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 1 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :<= 3 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :>= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :<= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 1)] :>= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 1)] :<= 3 ] derivedBounds = deriveBounds simpleSystem - expectedBounds = Map.fromList [(0, Bounds (Just 0) (Just 1)), (1, Bounds (Just 1) (Just 3))] + expectedBounds = Map.fromList [(Var 0, Bounds (Just 0) (Just 1)), (Var 1, Bounds (Just 1) (Just 3))] derivedBounds `shouldBe` expectedBounds validateBounds derivedBounds `shouldBe` True it @@ -155,13 +155,13 @@ spec = do $ do let simpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 1 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 0 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 3 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :<= 1 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :>= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :<= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 1)] :>= 3 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 1)] :<= 1 ] derivedBounds = deriveBounds simpleSystem - expectedBounds = Map.fromList [(0, Bounds (Just 1) (Just 0)), (1, Bounds (Just 3) (Just 1))] + expectedBounds = Map.fromList [(Var 0, Bounds (Just 1) (Just 0)), (Var 1, Bounds (Just 3) (Just 1))] derivedBounds `shouldBe` expectedBounds validateBounds derivedBounds `shouldBe` False it @@ -169,13 +169,13 @@ spec = do $ do let simpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 1 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 0 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 1 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :<= 3 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :>= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :<= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 1)] :>= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 1)] :<= 3 ] derivedBounds = deriveBounds simpleSystem - expectedBounds = Map.fromList [(0, Bounds (Just 1) (Just 0)), (1, Bounds (Just 1) (Just 3))] + expectedBounds = Map.fromList [(Var 0, Bounds (Just 1) (Just 0)), (Var 1, Bounds (Just 1) (Just 3))] derivedBounds `shouldBe` expectedBounds validateBounds derivedBounds `shouldBe` False it @@ -183,67 +183,67 @@ spec = do $ do let simpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 0 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 1 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :>= 3 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 1] :<= 1 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :>= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :<= 1 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 1)] :>= 3 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 1)] :<= 1 ] derivedBounds = deriveBounds simpleSystem - expectedBounds = Map.fromList [(0, Bounds (Just 0) (Just 1)), (1, Bounds (Just 3) (Just 1))] + expectedBounds = Map.fromList [(Var 0, Bounds (Just 0) (Just 1)), (Var 1, Bounds (Just 3) (Just 1))] derivedBounds `shouldBe` expectedBounds validateBounds derivedBounds `shouldBe` False it "removeObviousInequalities removes x <= 3 when bounds say x <= 2" $ do let simpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 2 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 3 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :<= 2 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :<= 3 ] - bounds = Map.fromList [(0, Bounds (Just 0) (Just 2))] + bounds = Map.fromList [(Var 0, Bounds (Just 0) (Just 2))] simplifiedSimpleSystem = removeObviousInequalities simpleSystem bounds - expectedSimpleSystem = SimpleSystem [SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 2] + expectedSimpleSystem = SimpleSystem [SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :<= 2] simplifiedSimpleSystem `shouldBe` expectedSimpleSystem it "removeObviousInequalities does not remove x <= 2 when bounds say x <= 2" $ do let simpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 2 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :<= 2 ] - bounds = Map.fromList [(0, Bounds (Just 0) (Just 2))] + bounds = Map.fromList [(Var 0, Bounds (Just 0) (Just 2))] simplifiedSimpleSystem = removeObviousInequalities simpleSystem bounds - expectedSimpleSystem = SimpleSystem [SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 2] + expectedSimpleSystem = SimpleSystem [SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :<= 2] simplifiedSimpleSystem `shouldBe` expectedSimpleSystem it "removeObviousInequalities removes x >= 3 when bounds say x >= 4" $ do let simpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 4 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 3 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :>= 4 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :>= 3 ] - bounds = Map.fromList [(0, Bounds (Just 4) (Just 5))] + bounds = Map.fromList [(Var 0, Bounds (Just 4) (Just 5))] simplifiedSimpleSystem = removeObviousInequalities simpleSystem bounds - expectedSimpleSystem = SimpleSystem [SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 4] + expectedSimpleSystem = SimpleSystem [SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :>= 4] simplifiedSimpleSystem `shouldBe` expectedSimpleSystem it "removeObviousInequalities does not remove x >= 4 when bounds say x >= 4" $ do let simpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 4 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :>= 4 ] - bounds = Map.fromList [(0, Bounds (Just 4) (Just 5))] + bounds = Map.fromList [(Var 0, Bounds (Just 4) (Just 5))] simplifiedSimpleSystem = removeObviousInequalities simpleSystem bounds - expectedSimpleSystem = SimpleSystem [SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 4] + expectedSimpleSystem = SimpleSystem [SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :>= 4] simplifiedSimpleSystem `shouldBe` expectedSimpleSystem it "removeObviousInequalities does not remove 0 <= x <= 2 when bounds say 0 <= x <= 2" $ do let simpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 0 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 2 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :>= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :<= 2 ] - bounds = Map.fromList [(0, Bounds (Just 0) (Just 2))] + bounds = Map.fromList [(Var 0, Bounds (Just 0) (Just 2))] simplifiedSimpleSystem = removeObviousInequalities simpleSystem bounds expectedSimpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 0 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 2 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :>= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :<= 2 ] simplifiedSimpleSystem `shouldBe` expectedSimpleSystem it @@ -251,37 +251,37 @@ spec = do $ do let simpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 0 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 2 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :>= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :<= 2 ] - bounds = Map.fromList [(0, Bounds (Just 0) (Just 1))] + bounds = Map.fromList [(Var 0, Bounds (Just 0) (Just 1))] simplifiedSimpleSystem = removeObviousInequalities simpleSystem bounds - expectedSimpleSystem = SimpleSystem [SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 0] + expectedSimpleSystem = SimpleSystem [SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :>= 0] simplifiedSimpleSystem `shouldBe` expectedSimpleSystem it "removeObviousInequalities removes lower bound of 0 <= x <= 2 when bounds say 1 <= x <= 2" $ do let simpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :>= 0 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 2 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :>= 0 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :<= 2 ] - bounds = Map.fromList [(0, Bounds (Just 1) (Just 2))] + bounds = Map.fromList [(Var 0, Bounds (Just 1) (Just 2))] simplifiedSimpleSystem = removeObviousInequalities simpleSystem bounds - expectedSimpleSystem = SimpleSystem [SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 2] + expectedSimpleSystem = SimpleSystem [SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :<= 2] simplifiedSimpleSystem `shouldBe` expectedSimpleSystem it "removeUselssSystemBounds only removes constraints of the form x <= c" $ do let simpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 2 - , SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 3 - , SimpleConstraint $ ExprVarsOnly [CoeffTermVO 2 0] :<= 6 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :<= 2 + , SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :<= 3 + , SimpleConstraint $ ExprVarsOnly [CoeffTermVO 2 (Var 0)] :<= 6 ] - bounds = Map.fromList [(0, Bounds (Just 0) (Just 2))] + bounds = Map.fromList [(Var 0, Bounds (Just 0) (Just 2))] simplifiedSimpleSystem = removeObviousInequalities simpleSystem bounds expectedSimpleSystem = SimpleSystem - [ SimpleConstraint $ ExprVarsOnly [VarTermVO 0] :<= 2 - , SimpleConstraint $ ExprVarsOnly [CoeffTermVO 2 0] :<= 6 + [ SimpleConstraint $ ExprVarsOnly [VarTermVO (Var 0)] :<= 2 + , SimpleConstraint $ ExprVarsOnly [CoeffTermVO 2 (Var 0)] :<= 6 ] simplifiedSimpleSystem `shouldBe` expectedSimpleSystem diff --git a/test/Linear/Tableau/TypesSpec.hs b/test/Linear/Tableau/TypesSpec.hs new file mode 100644 index 0000000..2600bbc --- /dev/null +++ b/test/Linear/Tableau/TypesSpec.hs @@ -0,0 +1,78 @@ +module Linear.Tableau.TypesSpec where + +import Data.List (nub) +import qualified Data.Set as Set +import Linear.Tableau.Types + +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck + +spec :: Spec +spec = + describe "Tableau Pivoting" $ do + let -- Sample initial tableau + initialTableau = Tableau + { rows = + [ TableauRow { coeffs = [1, 2], rhs = 3 } -- x₁ + 2x₂ = 3 + , TableauRow { coeffs = [4, 5], rhs = 6 } -- 4x₁ +5x₂ = 6 + ] + , basicVars = Set.fromList [2, 3] -- x₃ basic in row 0, x₄ in row 1 + } + + it "handles basic pivot operation" $ do + let result = pivot 0 0 initialTableau + result.rows `shouldBe` + [ TableauRow { coeffs = [1, 2], rhs = 3 } -- x₁ remains same + , TableauRow { coeffs = [0, -3], rhs = -6 } -- 0x₁ -3x₂ = -6 + ] + result.basicVars `shouldBe` Set.fromList [0, 3] -- x₁ now basic in row 0 + + it "handles pivot with negative coefficients" $ do + let tab = Tableau + { rows = [ TableauRow { coeffs = [-2, 4], rhs = 6 } + , TableauRow { coeffs = [3, -1], rhs = 2 } + ] + , basicVars = Set.fromList [1, 2] + } + result = pivot 0 0 tab + + result.rows `shouldBe` + [ TableauRow { coeffs = [1, -2], rhs = -3 } -- Normalized row + , TableauRow { coeffs = [0, 5], rhs = 11 } -- Eliminated row: 3 - (3 * -3) = 0, -1 - (3 * -2) = 5 + ] + result.basicVars `shouldBe` Set.fromList [0, 2] + + it "maintains row count" $ -- TODO: Why am I testing this? + property $ \(Positive n) -> + let tab = Tableau { rows = (replicate n (TableauRow { coeffs = [], rhs = 0 })), basicVars = Set.fromList (replicate n 0) } + in length (rows (pivot 0 0 tab)) `shouldBe` n + + it "handles fractional results" $ do + let tab = Tableau + { rows = [ TableauRow { coeffs = [2, 4], rhs = 6 } ] + , basicVars = Set.fromList [0] + } + result = pivot 0 0 tab + + coeffs (head (rows result)) `shouldBe` [1, 2] + rhs (head (rows result)) `shouldBe` 3 + + it "pivots the wikipeda worked example correctly" $ do + let tab = Tableau + { rows = [ TableauRow { coeffs = [1, 2, 3, 4, 0, 0], rhs = 0 } + , TableauRow { coeffs = [0, 3, 2, 1, 1, 0], rhs = 10 } + , TableauRow { coeffs = [0, 2, 5, 3, 0, 1], rhs = 15 } + ] + , basicVars = Set.fromList [0, 4, 5] + } + let step1 = pivot 3 2 tab + let step1Expected = Tableau + { rows = [ TableauRow { coeffs = [1, -(2 / 3), -(11 / 3), 0, 0, -(4 / 3)], rhs = -20 } + , TableauRow { coeffs = [0, 7/3, 1/3, 0, 1,- (1 / 3)], rhs = 5 } + , TableauRow { coeffs = [0, 2/3, 5/3, 1, 0, 1/3], rhs = 5 } + ] + , basicVars = Set.fromList [0, 4, 3] + } + step1 `shouldBe` step1Expected + diff --git a/test/Linear/Term/UtilSpec.hs b/test/Linear/Term/UtilSpec.hs index c92f6b5..b276c29 100644 --- a/test/Linear/Term/UtilSpec.hs +++ b/test/Linear/Term/UtilSpec.hs @@ -29,105 +29,105 @@ import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (counterexample) import TestUtil (evalTerm, genVarMap) import Prelude +import Linear.Var.Types (Var(..)) spec :: Spec -spec = do - describe "Term" $ do - prop "simplifying leads to same evaluation" $ \term -> do - varMap <- maybe (pure Map.empty) (genVarMap . List.singleton) $ termVar term - let simplifiedTerm = simplifyTerm term - termEval = evalTerm varMap term - simplifiedTermEval = evalTerm varMap simplifiedTerm - pure - $ counterexample - ( "term: " - <> show term - <> "simplifiedTerm: " - <> show simplifiedTerm - <> "\nvarMap: " - <> show varMap - <> "\ntermEval: " - <> show termEval - <> "\nsimplifiedTermEval: " - <> show simplifiedTermEval - ) - $ evalTerm varMap (simplifyTerm term) == evalTerm varMap term - prop "simplifyTerm is idempotent" $ \term -> do - let simplifiedTerm = simplifyTerm term - simplifiedTwiceTerm = simplifyTerm simplifiedTerm - counterexample +spec = describe "Term" $ do + prop "simplifying leads to same evaluation" $ \term -> do + varMap <- maybe (pure Map.empty) (genVarMap . List.singleton) $ termVar term + let simplifiedTerm = simplifyTerm term + termEval = evalTerm varMap term + simplifiedTermEval = evalTerm varMap simplifiedTerm + pure + $ counterexample ( "term: " <> show term - <> "\nsimplifiedTerm: " + <> "simplifiedTerm: " <> show simplifiedTerm - <> "\nsimplifiedTwiceTerm: " - <> show simplifiedTwiceTerm + <> "\nvarMap: " + <> show varMap + <> "\ntermEval: " + <> show termEval + <> "\nsimplifiedTermEval: " + <> show simplifiedTermEval ) - $ simplifiedTwiceTerm == simplifiedTerm - prop "negating and evaluating is the same as negating the evaluation" $ \term -> do - varMap <- maybe (pure $ Map.empty) (genVarMap . List.singleton) $ termVar term - let negatedTerm = negateTerm term - termEval = evalTerm varMap term - negatedTermEval = evalTerm varMap negatedTerm - pure - $ counterexample - ( "term: " - <> show term - <> "\nnegatedTerm: " - <> show negatedTerm - <> "\nvarMap: " - <> show varMap - <> "\ntermEval: " - <> show termEval - <> "\nnegatedTermEval: " - <> show negatedTermEval - ) - $ negate termEval == negatedTermEval - prop "negating twice is the same as not negating" $ \term -> do - let simplifiedTerm = simplifyTerm term - negatedTwiceSimpleTerm = negateTerm (negateTerm simplifiedTerm) - counterexample + $ evalTerm varMap (simplifyTerm term) == evalTerm varMap term + prop "simplifyTerm is idempotent" $ \term -> do + let simplifiedTerm = simplifyTerm term + simplifiedTwiceTerm = simplifyTerm simplifiedTerm + counterexample + ( "term: " + <> show term + <> "\nsimplifiedTerm: " + <> show simplifiedTerm + <> "\nsimplifiedTwiceTerm: " + <> show simplifiedTwiceTerm + ) + $ simplifiedTwiceTerm == simplifiedTerm + prop "negating and evaluating is the same as negating the evaluation" $ \term -> do + varMap <- maybe (pure $ Map.empty) (genVarMap . List.singleton) $ termVar term + let negatedTerm = negateTerm term + termEval = evalTerm varMap term + negatedTermEval = evalTerm varMap negatedTerm + pure + $ counterexample ( "term: " <> show term - <> "\nsimplifiedTerm: " - <> show simplifiedTerm - <> "\nnegatedTwiceSimpleTerm: " - <> show negatedTwiceSimpleTerm - ) - $ negatedTwiceSimpleTerm == simplifiedTerm - prop "zeroConstTerm correctly zeroes constant terms" $ \term -> do - let termZeroedConsts = zeroConstTerm term - counterexample - ( "term: " - <> show term - <> "\ntermZeroedConsts: " - <> show termZeroedConsts - ) - $ case term of - ConstTerm _ -> termZeroedConsts == ConstTerm 0 - _ -> termZeroedConsts == term - it "isConstTerm correctly identifies constant terms" $ do - isConstTerm (ConstTerm 0) `shouldBe` True - isConstTerm (ConstTerm 1) `shouldBe` True - isConstTerm (CoeffTerm 1 1) `shouldBe` False - isConstTerm (VarTerm 1) `shouldBe` False - it "termToTermVarsOnly correctly converts terms to vars only" $ do - termToTermVarsOnly (ConstTerm 0) `shouldSatisfy` Either.isLeft - termToTermVarsOnly (ConstTerm 1) `shouldSatisfy` Either.isLeft - termToTermVarsOnly (CoeffTerm 1 1) `shouldBe` Right (CoeffTermVO 1 1) - termToTermVarsOnly (VarTerm 1) `shouldBe` Right (VarTermVO 1) - it "unsafeTermToTermVarsOnly correctly converts terms without vars" $ do - unsafeTermToTermVarsOnly (CoeffTerm 1 1) `shouldBe` (CoeffTermVO 1 1) - unsafeTermToTermVarsOnly (VarTerm 1) `shouldBe` (VarTermVO 1) - prop "normalizeTerms is idempotent" $ \terms -> do - let normalizedTerms = normalizeTerms terms - normalizedTwiceTerms = normalizeTerms normalizedTerms - counterexample - ( "terms: " - <> show terms - <> "\nnormalizedTerms: " - <> show normalizedTerms - <> "\nnormalizedTwiceTerms: " - <> show normalizedTwiceTerms + <> "\nnegatedTerm: " + <> show negatedTerm + <> "\nvarMap: " + <> show varMap + <> "\ntermEval: " + <> show termEval + <> "\nnegatedTermEval: " + <> show negatedTermEval ) - $ normalizedTwiceTerms == normalizedTerms + $ negate termEval == negatedTermEval + prop "negating twice is the same as not negating" $ \term -> do + let simplifiedTerm = simplifyTerm term + negatedTwiceSimpleTerm = negateTerm (negateTerm simplifiedTerm) + counterexample + ( "term: " + <> show term + <> "\nsimplifiedTerm: " + <> show simplifiedTerm + <> "\nnegatedTwiceSimpleTerm: " + <> show negatedTwiceSimpleTerm + ) + $ negatedTwiceSimpleTerm == simplifiedTerm + prop "zeroConstTerm correctly zeroes constant terms" $ \term -> do + let termZeroedConsts = zeroConstTerm term + counterexample + ( "term: " + <> show term + <> "\ntermZeroedConsts: " + <> show termZeroedConsts + ) + $ case term of + ConstTerm _ -> termZeroedConsts == ConstTerm 0 + _ -> termZeroedConsts == term + it "isConstTerm correctly identifies constant terms" $ do + isConstTerm (ConstTerm 0) `shouldBe` True + isConstTerm (ConstTerm 1) `shouldBe` True + isConstTerm (CoeffTerm 1 (Var 1)) `shouldBe` False + isConstTerm (VarTerm (Var 1)) `shouldBe` False + it "termToTermVarsOnly correctly converts terms to vars only" $ do + termToTermVarsOnly (ConstTerm 0) `shouldSatisfy` Either.isLeft + termToTermVarsOnly (ConstTerm 1) `shouldSatisfy` Either.isLeft + termToTermVarsOnly (CoeffTerm 1 (Var 1)) `shouldBe` Right (CoeffTermVO 1 (Var 1)) + termToTermVarsOnly (VarTerm (Var 1)) `shouldBe` Right (VarTermVO (Var 1)) + it "unsafeTermToTermVarsOnly correctly converts terms without vars" $ do + unsafeTermToTermVarsOnly (CoeffTerm 1 (Var 1)) `shouldBe` (CoeffTermVO 1 (Var 1)) + unsafeTermToTermVarsOnly (VarTerm (Var 1)) `shouldBe` (VarTermVO (Var 1)) + prop "normalizeTerms is idempotent" $ \terms -> do + let normalizedTerms = normalizeTerms terms + normalizedTwiceTerms = normalizeTerms normalizedTerms + counterexample + ( "terms: " + <> show terms + <> "\nnormalizedTerms: " + <> show normalizedTerms + <> "\nnormalizedTwiceTerms: " + <> show normalizedTwiceTerms + ) + $ normalizedTwiceTerms == normalizedTerms diff --git a/test/Linear/Var/UtilSpec.hs b/test/Linear/Var/UtilSpec.hs index 1f21f36..58c76cf 100644 --- a/test/Linear/Var/UtilSpec.hs +++ b/test/Linear/Var/UtilSpec.hs @@ -1,21 +1,20 @@ module Linear.Var.UtilSpec where import qualified Data.Map as Map -import Linear.Var.Types (Bounds (..)) +import Linear.Var.Types ( Bounds(..), Var(..) ) import Linear.Var.Util (validateBounds) import Test.Hspec (Spec, describe, it, shouldBe) spec :: Spec -spec = do - describe "Bounds" $ do - it "validateBounds returns true for valid bounds" $ do - validateBounds (Map.fromList [(1, Bounds (Just 1) (Just 2))]) `shouldBe` True - validateBounds (Map.fromList [(1, Bounds (Just 1.1) (Just 1.2))]) - `shouldBe` True - validateBounds (Map.fromList [(1, Bounds (Just 1) Nothing)]) `shouldBe` True - validateBounds (Map.fromList [(1, Bounds Nothing (Just 2))]) `shouldBe` True - validateBounds (Map.fromList [(1, Bounds Nothing Nothing)]) `shouldBe` True - it "validateBounds returns false for invalid bounds" $ do - validateBounds (Map.fromList [(1, Bounds (Just 2) (Just 1))]) `shouldBe` False - validateBounds (Map.fromList [(1, Bounds (Just 1.2) (Just 1.1))]) - `shouldBe` False +spec = describe "Bounds" $ do + it "validateBounds returns true for valid bounds" $ do + validateBounds (Map.fromList [(Var 1, Bounds (Just 1) (Just 2))]) `shouldBe` True + validateBounds (Map.fromList [(Var 1, Bounds (Just 1.1) (Just 1.2))]) + `shouldBe` True + validateBounds (Map.fromList [(Var 1, Bounds (Just 1) Nothing)]) `shouldBe` True + validateBounds (Map.fromList [(Var 1, Bounds Nothing (Just 2))]) `shouldBe` True + validateBounds (Map.fromList [(Var 1, Bounds Nothing Nothing)]) `shouldBe` True + it "validateBounds returns false for invalid bounds" $ do + validateBounds (Map.fromList [(Var 1, Bounds (Just 2) (Just 1))]) `shouldBe` False + validateBounds (Map.fromList [(Var 1, Bounds (Just 1.2) (Just 1.1))]) + `shouldBe` False diff --git a/test/TestUtil.hs b/test/TestUtil.hs index 628f0ec..bf753d0 100644 --- a/test/TestUtil.hs +++ b/test/TestUtil.hs @@ -18,7 +18,6 @@ import Linear.Constraint.Types ) import Linear.Expr.Types (Expr, ExprVarsOnly) import Linear.Expr.Util (exprToList, exprVarsOnlyToExpr) -import Linear.Simplex.Types (VarLitMap) import Linear.System.Simple.Types (SimpleSystem (..)) import Linear.Term.Types ( Term (..) @@ -29,7 +28,7 @@ import Linear.Var.Types (SimplexNum, Var) import Test.QuickCheck (Arbitrary (..), Gen) import Prelude -evalTerm :: VarLitMap -> Linear.Term.Types.Term -> SimplexNum +evalTerm :: Map.Map Var SimplexNum -> Linear.Term.Types.Term -> SimplexNum evalTerm _ (Linear.Term.Types.ConstTerm c) = c evalTerm varMap (Linear.Term.Types.CoeffTerm c v) = c @@ -43,29 +42,29 @@ evalTerm varMap (Linear.Term.Types.VarTerm v) = v varMap -evalTermVarsOnly :: VarLitMap -> TermVarsOnly -> SimplexNum +evalTermVarsOnly :: Map.Map Var SimplexNum -> TermVarsOnly -> SimplexNum evalTermVarsOnly varMap terms = evalTerm varMap $ termVarsOnlyToTerm terms -evalExpr :: VarLitMap -> Expr -> SimplexNum +evalExpr :: Map.Map Var SimplexNum -> Expr -> SimplexNum evalExpr varMap expr = sum $ map (evalTerm varMap) $ exprToList expr -evalExprVarsOnly :: VarLitMap -> ExprVarsOnly -> SimplexNum +evalExprVarsOnly :: Map.Map Var SimplexNum -> ExprVarsOnly -> SimplexNum evalExprVarsOnly varMap = evalExpr varMap . exprVarsOnlyToExpr -evalConstraint :: VarLitMap -> Constraint -> Bool +evalConstraint :: Map.Map Var SimplexNum -> Constraint -> Bool evalConstraint varMap (Constraint (lhs :<= rhs)) = evalExpr varMap lhs <= evalExpr varMap rhs evalConstraint varMap (Constraint (lhs :>= rhs)) = evalExpr varMap lhs >= evalExpr varMap rhs evalConstraint varMap (Constraint (lhs :== rhs)) = evalExpr varMap lhs == evalExpr varMap rhs -evalSimpleConstraint :: VarLitMap -> SimpleConstraint -> Bool +evalSimpleConstraint :: Map.Map Var SimplexNum -> SimpleConstraint -> Bool evalSimpleConstraint varMap (SimpleConstraint (lhs :<= rhs)) = evalExprVarsOnly varMap lhs <= rhs evalSimpleConstraint varMap (SimpleConstraint (lhs :>= rhs)) = evalExprVarsOnly varMap lhs >= rhs evalSimpleConstraint varMap (SimpleConstraint (lhs :== rhs)) = evalExprVarsOnly varMap lhs == rhs -evalSimpleSystem :: VarLitMap -> SimpleSystem -> Bool +evalSimpleSystem :: Map.Map Var SimplexNum -> SimpleSystem -> Bool evalSimpleSystem varMap = all (evalSimpleConstraint varMap) . unSimpleSystem -genVarMap :: [Var] -> Gen VarLitMap +genVarMap :: [Var] -> Gen (Map.Map Var SimplexNum) genVarMap vars = do varVals <- forM vars $ const arbitrary pure $ Map.fromList $ zip vars varVals