rename some types, add some strict fields, add todos

Author: rasheedja

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

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 :: *

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 <jrasheed178@gmail.com>
+-- 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)

src/Linear/SlackForm/Util.hs renamed to src/Linear/CanonicalForm/Util.hs

@@ -5,14 +5,15 @@
 -- License: BSD-3
 -- Maintainer: Junaid Rasheed <jrasheed178@gmail.com>
 -- Stability: experimental
-module Linear.SlackForm.Util where
+module Linear.CanonicalForm.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 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,13 +22,15 @@ 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
   ( SimpleSystem (..)
   , 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

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)

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

src/Linear/SlackForm/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]

src/Linear/System/Linear/Types.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

src/Linear/System/Linear/Util.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)