-- Do not edit! Automatically created with doctest-extract from src/Numeric/HiGHS/LP/Monad.hs {-# LINE 52 "src/Numeric/HiGHS/LP/Monad.hs" #-} {-# OPTIONS_GHC -XTypeFamilies #-} {-# OPTIONS_GHC -XTypeOperators #-} module Test.Numeric.HiGHS.LP.Monad where import Test.DocTest.Base import qualified Test.DocTest.Driver as DocTest {-# LINE 55 "src/Numeric/HiGHS/LP/Monad.hs" #-} import qualified Numeric.HiGHS.LP.Monad as LP import qualified Numeric.HiGHS.LP as CLP import Test.Numeric.HiGHS.LP.Utility (traverse_Lag, traverseLag) import Test.Numeric.HiGHS.LP (TripletShape, tripletShape, forAllMethod) import Numeric.HiGHS.LP (Direction, (.*), (<=.)) import qualified Numeric.LinearProgramming.Monad as LPMonad import qualified Numeric.LinearProgramming.Test as TestLP import Numeric.LinearProgramming.Common (Bounds, Objective) import qualified Data.Array.Comfort.Storable as Array import qualified Data.Array.Comfort.Shape as Shape import qualified Data.NonEmpty as NonEmpty import Data.Array.Comfort.Storable (Array) import Data.Traversable (Traversable) import Data.Foldable (Foldable) import qualified Control.Monad.Trans.Except as ME import qualified Data.List.HT as ListHT import Data.Tuple.HT (mapSnd) import Foreign.Storable (Storable) import qualified Test.QuickCheck as QC type Constraints ix = CLP.Constraints Double ix approxSuccession :: (Shape.C sh, Show sh, Show a, Ord a, Num a, Storable a) => a -> Either CLP.ModelStatus (NonEmpty.T [] (a, Array sh a)) -> Either CLP.ModelStatus (NonEmpty.T [] (a, Array sh a)) -> QC.Property approxSuccession tol x y = QC.counterexample (show x) $ QC.counterexample (show y) $ case (x,y) of (Left sx, Left sy) -> sx==sy (Right (NonEmpty.Cons xh xs), Right (NonEmpty.Cons yh ys)) -> let equalSol (optX, _) (optY, _) = TestLP.approxReal tol optX optY in equalSol xh yh && ListHT.equalWith equalSol xs ys _ -> False runSuccessive :: (Eq sh, Shape.Indexed sh, Shape.Index sh ~ ix, Foldable t) => CLP.Method -> sh -> Bounds ix -> (Constraints ix, (Direction, Objective sh)) -> t (Double -> Constraints ix, (Direction, Objective sh)) -> Either CLP.ModelStatus () runSuccessive method shape bounds (constrs,dirObj) objs = let solve constrs_ dirObj_ = do (status,result) <- LP.solve method constrs_ dirObj_ return $ maybe (Left status) Right result in LP.run shape bounds $ ME.runExceptT $ do (opt, _xs) <- ME.ExceptT $ solve constrs dirObj traverse_Lag opt (\prevResult (newConstr, dirObjI) -> do (optI, _xs) <- ME.ExceptT $ solve (newConstr prevResult) dirObjI return optI) objs solveSuccessiveWarm :: (Eq sh, Shape.Indexed sh, Shape.Index sh ~ ix, Traversable t) => CLP.Method -> sh -> Bounds ix -> (Constraints ix, (Direction, Objective sh)) -> t (Double -> Constraints ix, (Direction, Objective sh)) -> Either CLP.ModelStatus (NonEmpty.T t (Double, Array sh Double)) solveSuccessiveWarm method shape bounds (constrs,dirObj) objs = let solve constrs_ dirObj_ = do (status,result) <- LP.solve method constrs_ dirObj_ return $ maybe (Left status) Right result in LP.run shape bounds $ ME.runExceptT $ do result <- ME.ExceptT $ solve constrs dirObj NonEmpty.Cons result <$> traverseLag result (\(prevOpt, _xs) (newConstr, dirObjI) -> ME.ExceptT $ solve (newConstr prevOpt) dirObjI) objs solveSuccessiveGen :: (Eq sh, Shape.Indexed sh, Shape.Index sh ~ ix, Traversable t) => CLP.Method -> sh -> Bounds ix -> (Constraints ix, (Direction, Objective sh)) -> t (Double -> Constraints ix, (Direction, Objective sh)) -> Either CLP.ModelStatus (NonEmpty.T t (Double, Array sh Double)) solveSuccessiveGen method shape bounds (constrs,dirObj) objs = let solve bounds_ constrs_ dirObj_ = case CLP.solve method bounds_ constrs_ dirObj_ of (status,result) -> maybe (Left status) Right result in LPMonad.run shape bounds $ ME.runExceptT $ do result <- ME.ExceptT $ LPMonad.lift solve constrs dirObj NonEmpty.Cons result <$> traverseLag result (\(prevOpt, _xs) (newConstr, dirObjI) -> ME.ExceptT $ LPMonad.lift solve (newConstr prevOpt) dirObjI) objs test :: DocTest.T () test = do DocTest.printPrefix "Numeric.HiGHS.LP.Monad:198: " {-# LINE 198 "src/Numeric/HiGHS/LP/Monad.hs" #-} DocTest.example( {-# LINE 198 "src/Numeric/HiGHS/LP/Monad.hs" #-} case Shape.indexTupleFromShape tripletShape of (x,y,z) -> fmap (mapSnd Array.toTuple) $ snd $ LP.run tripletShape [] (LP.solve LP.simplex [[2.*x, 1.*y] <=. 10, [1.*y, (5::Double).*z] <=. 20] (LP.Maximize, Array.fromTuple (4,-3,2) :: Array.Array TripletShape Double)) ) [ExpectedLine [LineChunk "Just (28.0,(5.0,0.0,4.0))"]] DocTest.printPrefix "Numeric.HiGHS.LP.Monad:210: " {-# LINE 210 "src/Numeric/HiGHS/LP/Monad.hs" #-} DocTest.property( {-# LINE 210 "src/Numeric/HiGHS/LP/Monad.hs" #-} forAllMethod $ \method -> TestLP.forAllOrigin $ \origin -> TestLP.forAllProblem origin $ \bounds constrs -> QC.forAll (TestLP.genObjective origin) $ \(dir,obj) -> case (CLP.solve method bounds constrs (dir,obj), LP.run (Array.shape origin) bounds $ LP.solve method constrs (dir,obj)) of ((_, Just (optA,_)), (_, Just (optB,_))) -> TestLP.approxReal 0.1 optA optB; _ -> False ) DocTest.printPrefix "Numeric.HiGHS.LP.Monad:222: " {-# LINE 222 "src/Numeric/HiGHS/LP/Monad.hs" #-} DocTest.property( {-# LINE 222 "src/Numeric/HiGHS/LP/Monad.hs" #-} forAllMethod $ \method -> TestLP.forAllOrigin $ \origin -> TestLP.forAllProblem origin $ \bounds constrs -> TestLP.forAllObjectives origin $ \objs_ -> case TestLP.successiveObjectives origin 0.01 objs_ of (dirObj, objs) -> either (\msg -> QC.counterexample (show msg) False) (const $ QC.property True) $ runSuccessive method (Array.shape origin) bounds (constrs,dirObj) objs ) DocTest.printPrefix "Numeric.HiGHS.LP.Monad:235: " {-# LINE 235 "src/Numeric/HiGHS/LP/Monad.hs" #-} DocTest.property( {-# LINE 235 "src/Numeric/HiGHS/LP/Monad.hs" #-} forAllMethod $ \method -> TestLP.forAllOrigin $ \origin -> TestLP.forAllProblem origin $ \bounds constrs -> TestLP.forAllObjectives origin $ \objs_ -> let shape = Array.shape origin in case TestLP.successiveObjectives origin 0.01 objs_ of (dirObj, objs) -> approxSuccession 0.01 (solveSuccessiveWarm method shape bounds (constrs,dirObj) objs) (solveSuccessiveGen method shape bounds (constrs,dirObj) objs) )