-- Do not edit! Automatically created with doctest-extract from src/Numeric/COINOR/CLP/Monad.hs {-# LINE 42 "src/Numeric/COINOR/CLP/Monad.hs" #-} {-# OPTIONS_GHC -XTypeFamilies #-} {-# OPTIONS_GHC -XTypeOperators #-} module Test.Numeric.COINOR.CLP.Monad where import Test.DocTest.Base import qualified Test.DocTest.Driver as DocTest {-# LINE 45 "src/Numeric/COINOR/CLP/Monad.hs" #-} import qualified Numeric.COINOR.CLP.Monad as LP import qualified Numeric.COINOR.CLP as CLP import Test.Numeric.COINOR.CLP.Utility (traverse_Lag, traverseLag) import Test.Numeric.COINOR.CLP (TripletShape, tripletShape, forAllMethod) import Numeric.COINOR.CLP (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.FailureType (NonEmpty.T [] (a, Array sh a)) -> Either CLP.FailureType (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.FailureType () runSuccessive method shape bounds (constrs,dirObj) objs = LP.run shape bounds $ ME.runExceptT $ do (opt, _xs) <- ME.ExceptT $ LP.simplex method constrs dirObj traverse_Lag opt (\prevResult (newConstr, dirObjI) -> do (optI, _xs) <- ME.ExceptT $ LP.simplex method (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.FailureType (NonEmpty.T t (Double, Array sh Double)) solveSuccessiveWarm method shape bounds (constrs,dirObj) objs = LP.run shape bounds $ ME.runExceptT $ do result <- ME.ExceptT $ LP.simplex method constrs dirObj NonEmpty.Cons result <$> traverseLag result (\(prevOpt, _xs) (newConstr, dirObjI) -> ME.ExceptT $ LP.simplex method (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.FailureType (NonEmpty.T t (Double, Array sh Double)) solveSuccessiveGen method shape bounds (constrs,dirObj) objs = LPMonad.run shape bounds $ ME.runExceptT $ do result <- ME.ExceptT $ LPMonad.lift (CLP.simplex method) constrs dirObj NonEmpty.Cons result <$> traverseLag result (\(prevOpt, _xs) (newConstr, dirObjI) -> ME.ExceptT $ LPMonad.lift (CLP.simplex method) (newConstr prevOpt) dirObjI) objs test :: DocTest.T () test = do DocTest.printPrefix "Numeric.COINOR.CLP.Monad:181: " {-# LINE 181 "src/Numeric/COINOR/CLP/Monad.hs" #-} DocTest.property {-# LINE 181 "src/Numeric/COINOR/CLP/Monad.hs" #-} (forAllMethod $ \method -> TestLP.forAllOrigin $ \origin -> TestLP.forAllProblem origin $ \bounds constrs -> QC.forAll (TestLP.genObjective origin) $ \(dir,obj) -> case (CLP.simplex method bounds constrs (dir,obj), LP.run (Array.shape origin) bounds $ LP.simplex method constrs (dir,obj)) of (Right (optA,_), Right (optB,_)) -> TestLP.approxReal 0.1 optA optB; _ -> False) DocTest.printPrefix "Numeric.COINOR.CLP.Monad:183: " {-# LINE 183 "src/Numeric/COINOR/CLP/Monad.hs" #-} DocTest.property {-# LINE 183 "src/Numeric/COINOR/CLP/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.COINOR.CLP.Monad:185: " {-# LINE 185 "src/Numeric/COINOR/CLP/Monad.hs" #-} DocTest.property {-# LINE 185 "src/Numeric/COINOR/CLP/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) -> approxSuccession 0.01 (solveSuccessiveWarm method (Array.shape origin) bounds (constrs,dirObj) objs) (solveSuccessiveGen method (Array.shape origin) bounds (constrs,dirObj) objs)) DocTest.printPrefix "Numeric.COINOR.CLP.Monad:178: " {-# LINE 178 "src/Numeric/COINOR/CLP/Monad.hs" #-} DocTest.example {-# LINE 178 "src/Numeric/COINOR/CLP/Monad.hs" #-} (case Shape.indexTupleFromShape tripletShape of (x,y,z) -> mapSnd Array.toTuple <$> LP.run tripletShape [] (LP.simplex LP.dual [[2.*x, 1.*y] <=. 10, [1.*y, (5::Double).*z] <=. 20] (LP.Maximize, Array.fromTuple (4,-3,2) :: Array.Array TripletShape Double))) [ExpectedLine [LineChunk "Right (28.0,(5.0,0.0,4.0))"]]