Monad.hs

-- 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)
  )