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,7 +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 (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)
@@ -16,10 +19,62 @@ data Objective = Objective
 
 -- 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 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

@@ -19,13 +19,24 @@ 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)
 
+-- data CanonicalForm = CanonicalForm
+--   { maxObjective :: ExprVarsOnly
+--   , slackForm :: SlackForm
+--   }
+--   deriving (Show, Eq, Read, Generic)
+
 data CanonicalForm = CanonicalForm
         { constraints :: LinearSystem
         , originalVars :: Set.Set Var
@@ -35,12 +46,12 @@ data CanonicalForm = CanonicalForm
         }
         deriving (Show, Eq, Read, Generic)
 
-class CanBeSlackForm a where
-  toSlackForm :: a -> ExprVarsOnly -> SlackForm
+-- 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)
+-- instance CanBeSlackForm LinearSystem where
+--   toSlackForm ls obj =
+--     SlackForm
+--       obj
+--       ls
+--       (Set.unions $ map (exprVarsOnlyVars . lhs) ls.unLinearSystem)

src/Linear/SlackForm/Util.hs

@@ -34,7 +34,7 @@ import Linear.Term.Types
   )
 import Linear.Var.Types (Bounds (..), Var, VarBounds)
 import Linear.System.Simple.Util (deriveBounds)
-import Linear.SlackForm.Types (CanonicalForm(..))
+import Linear.SlackForm.Types (CanonicalForm(..), SlackForm (..))
 import qualified Data.Set as Set
 
 -- | Eliminate non-zero lower bounds via substitution
@@ -147,7 +147,23 @@ simpleSystemToCanonicalForm 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

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
 

test/Linear/SlackForm/UtilSpec.hs

@@ -2,7 +2,7 @@ module Linear.SlackForm.UtilSpec where
 
 import Comparison.Types
   ( MixedComparison ((:<=), (:==), (:>=))
-  , getMixedComparisonLHS
+  , getLHS
   )
 import Control.Monad (forM)
 import Data.Functor ((<&>))
@@ -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
             )