wip

Author: rasheedja

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
 

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

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,20 +27,24 @@ 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:
       Paths_simplex_method
   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.*

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?

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