wip

Author: rasheedja

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)
@@ -18,21 +23,27 @@ data MixedComparison a b = a :<= b | a :>= b | a :== b
 instance (Arbitrary a, Arbitrary b) => Arbitrary (MixedComparison a b) where
   arbitrary =
     oneof
-      [ liftA2 (:<=) arbitrary arbitrary
-      , liftA2 (:>=) arbitrary arbitrary
-      , liftA2 (:==) arbitrary arbitrary
+      [ liftA2 (:<=) arbitrary arbitrary,
+        liftA2 (:>=) arbitrary arbitrary,
+        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/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.System.Linear.Types (LinearSystem)
 import Linear.Var.Types (SimplexNum, Var)
+import Linear.SlackForm.Types (SlackForm)
+import System.Posix.Types (CMode)
 
 data OptimisationDirection = Minimize | Maximize
   deriving (Show, Eq, GHC.Generics.Generic)
@@ -15,11 +17,64 @@ 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 SlackForm
+  
+  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 -> SlackForm -> SlackForm
+      secondPhase = undefined
+
+      -- This will probably be a proper function
+      systemResult :: SlackForm -> OptimisationResult
+      systemResult = undefined
+
+class CanBeStandardForm problem where
+  findSolution :: problem -> Maybe SlackForm
+
+-- 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

@@ -10,27 +10,48 @@ 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.Types (ExprVarsOnly, Expr)
 import Linear.Expr.Util (exprVarsOnlyVars)
 import Linear.System.Linear.Types (LinearSystem (..))
 import Linear.System.Simple.Types
 import Linear.Var.Types (SimplexNum, Var)
+import qualified Data.Map as Map
 
 -- Expr == SimplexNum
 -- TODO: think about a better name for this type, CanonicalForm?
+-- TODO: Rename decision: StandardForm? Or, AugmentedForm
+-- https://en.wikipedia.org/wiki/Linear_programming#Augmented_form_(slack_form)
 data SlackForm = SlackForm
-  { maxObjective :: ExprVarsOnly
-  , constraints :: LinearSystem
-  , vars :: Set.Set Var -- all vars are non-negative
+  { constraints :: LinearSystem
+  , originalVars :: Set.Set Var -- all vars are non-negative
+  , slackVars :: Set.Set Var -- all vars are non-negative
+  , artificialVarsMap :: Map.Map Var Expr -- all vars are non-negative
+  -- , articialVars :: Set.Set Var -- all vars are non-negative
+  -- , systemVars :: Set.Set Var -- all vars are non-negative
   }
   deriving (Show, Eq, Read, Generic)
 
-class CanBeSlackForm a where
-  toSlackForm :: a -> ExprVarsOnly -> SlackForm
+-- data CanonicalForm = CanonicalForm
+--   { maxObjective :: ExprVarsOnly
+--   , slackForm :: SlackForm
+--   }
+--   deriving (Show, Eq, Read, Generic)
 
-instance CanBeSlackForm LinearSystem where
-  toSlackForm ls obj =
-    SlackForm
-      obj
-      ls
-      (Set.unions $ map (exprVarsOnlyVars . lhs) ls.unLinearSystem)
+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)
+
+-- 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)

src/Linear/SlackForm/Util.hs

@@ -33,6 +33,9 @@ import Linear.Term.Types
   , TermVarsOnly (..)
   )
 import Linear.Var.Types (Bounds (..), Var, VarBounds)
+import Linear.System.Simple.Util (deriveBounds)
+import Linear.SlackForm.Types (CanonicalForm(..), SlackForm (..))
+import qualified Data.Set as Set
 
 -- | 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
@@ -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,35 @@ 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
+    
+                }
+simpleSystemToSlackForm :: SimpleSystem -> SlackForm
+simpleSystemToSlackForm system =
+    SlackForm {
+    constraints = finalSystem,
+    originalVars = SST.simpleSystemVars system,
+    -- systemVars = SLU.linearSystemVars finalSystem,
+    slackVars = Set.fromList slackVars,
+    artificialVarsMap = eliminatedVarsMap 
+    }
+  where
+    (eliminatedNonZeroLowerBoundVarsMap, system1) = eliminateNonZeroLowerBounds system Map.empty
+    system1Bounds = deriveBounds system1
+    (slackVars, linearSystem) = addSlackVars system1
+    (eliminatedVarsMap, finalSystem)= eliminateUnrestrictedLowerBounds linearSystem system1Bounds eliminatedNonZeroLowerBoundVarsMap
+    

src/Linear/System/Linear/Types.hs

@@ -10,16 +10,22 @@ module Linear.System.Linear.Types where
 import GHC.Generics (Generic)
 import Linear.Constraint.Linear.Types (LinearEquation)
 import Linear.Expr.Types (Expr)
+import Text.ParserCombinators.ReadP (between)
 
 -- TODO: name this system of equations or something
 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/Util.hs

@@ -7,10 +7,12 @@
 -- 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 +25,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/Simple/Types.hs

@@ -7,13 +7,13 @@
 -- 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)
 import Linear.Constraint.Simple.Util
-  ( simpleConstraintVars
-  , simplifySimpleConstraint
+  ( simpleConstraintVars,
+    simplifySimpleConstraint,
   )
 import Linear.Expr.Util (exprVarsOnlyToList)
 import Linear.System.Types (System)
@@ -37,7 +37,7 @@ simpleSystemVars = Set.unions . map simpleConstraintVars . unSimpleSystem
 findHighestVar :: SimpleSystem -> Maybe Var
 findHighestVar simpleSystem =
   let vars = simpleSystemVars simpleSystem
-  in  if Set.null vars
+   in if Set.null vars
         then Nothing
         else Just $ Set.findMax vars
 

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

src/Linear/Var/Types.hs

@@ -15,7 +15,4 @@ 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