DataSpec.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UnicodeSyntax     #-}
module MasterPlan.DataSpec (spec) where

import           Control.Monad.State
import           Data.Bool             (bool)
import qualified Data.List.NonEmpty    as NE
import           MasterPlan.Arbitrary  ()
import           MasterPlan.Data
import           System.Random
import           System.Random.Shuffle (shuffle')
import           Test.Hspec
import           Test.Hspec.QuickCheck (prop)
import           Test.QuickCheck       hiding (sample)

-- |Sample the simulation model of the execution of a project.
-- It's a stateful computation with the random generator, which computes
-- a 2-tuple with a Boolean: whether the execution was successful (A Bernoulli
-- sample from trust), and the total actual cost incurred.
simulate ∷ RandomGen g ⇒ Project a → State g (Bool, Cost)
simulate (Atomic _ (Cost c) (Trust t) (Progress p)) =
   do r <- state $ randomR (0, 1)
      let remainingProgress =  1 - p
          effectiveTrust = p + t * remainingProgress
          effectiveCost = c * remainingProgress
      pure (effectiveTrust > r, Cost effectiveCost)

simulate (Annotated _)     = pure (True, 0)
simulate (Sequence _ ps)   = simulateConjunction $ NE.toList ps
simulate (Product _ ps)    = simulateConjunction $ NE.toList ps
simulate (Sum _ ps)        =
  simulate' $ NE.toList ps
 where
   simulate' ∷ RandomGen g ⇒ [Project a] → State g (Bool, Cost)
   simulate' [] = pure (False, 0)
   simulate' (p:rest) = do (success, c) <- simulate p
                           if success then
                             pure (True, c)
                           else
                             do (success', c') <- simulate' rest
                                pure (success', c + c')

-- |Helper function that samples from a sequence of projects to be executed in
-- order, and which all must be successful for the end result to be succesful.
-- This is the case for sequences, and products (in a particular permutation).
simulateConjunction ∷ RandomGen g ⇒ [Project a] → State g (Bool, Cost)
simulateConjunction []       = pure (True, 0)
simulateConjunction (p:rest) = do (success, c) <- simulate p
                                  if success then do
                                    (success', c') <- simulateConjunction rest
                                    pure (success', c + c')
                                  else
                                    pure (False, c)

-- |Compute a project's trust and cost via a Monte Carlo method of computing
-- the average of a handful of samples.
monteCarloTrustAndCost ∷ RandomGen g ⇒ Int → ProjectExpr → State g (Trust, Cost)
monteCarloTrustAndCost n p = do results <- replicateM n $ simulate p
                                let trusts = map (bool 0 1 . fst) results
                                    costs  = map snd results
                                pure (sum trusts / fromIntegral n,
                                      sum costs / fromIntegral n)

aproximatelyEqual ∷ (Show a, Real a, Fractional a) => a -> a -> a → a -> Property
aproximatelyEqual alpha beta x y =
   counterexample (show x ++ " /= " ++ show y) $ diff <= max relError beta
  where
    relError = alpha * max (abs x) (abs y)
    diff = abs $ x - y

spec ∷ Spec
spec = do
  describe "trust and cost" $ do

    let g = mkStdGen 837183

    let eq :: (Show a, Real a, Fractional a) => a -> a -> Property
        eq = aproximatelyEqual 0.05 0.05

    prop "monte-carlo and analytical implementations should agree" $ do
        let monteCarloAndAnalyticalMustAgree ∷ ProjectExpr -> Property
            monteCarloAndAnalyticalMustAgree p =
                counterexample "disagree on cost"  (cost'  `eq` cost  p) .&&.
                counterexample "disagree on trust" (trust' `eq` trust p)
              where
                (trust', cost') = evalState (monteCarloTrustAndCost 50000 p) g
        monteCarloAndAnalyticalMustAgree

  describe "simplification" $ do

    let eq :: (Show a, Real a, Fractional a) => a -> a -> Property
        eq = aproximatelyEqual 0.005 0.005

    prop "is irreductible" $ do
        let simplificationIsIrreductible :: ProjectExpr -> Property
            simplificationIsIrreductible p =
                let p' = simplify p
                    p'' = simplify p'
                 in p /= p' ==> p' == p''
        simplificationIsIrreductible

    prop "is stable" $ do
      let simplifyIsStable :: ProjectExpr -> Property
          simplifyIsStable p =
            let p' = simplify p
             in cost p `eq` cost p' .&&. trust p `eq` trust p'

      simplifyIsStable

  describe "prioritization" $ do

    let shuffleProjs :: NE.NonEmpty (Project a) -> IO (NE.NonEmpty (Project a))
        shuffleProjs ps = do ps' <- NE.toList <$> mapM shuffleProj ps
                             g <- newStdGen
                             pure $ NE.fromList $ shuffle' ps' (length ps') g

        shuffleProj :: Project a -> IO (Project a)
        shuffleProj (Sum r ps)     = Sum r <$> shuffleProjs ps
        shuffleProj (Product r ps) = Product r <$> shuffleProjs ps
        shuffleProj p              = pure p

    prop "minimize cost and keep trust stable" $ do
      -- This test verifies that for any arbitrary project tree, the
      -- prioritized version of it will have the minimum cost.

      let eq = aproximatelyEqual 0.005 0.005

      let prioritizeMinimizesCost :: ProjectExpr -> Property
          prioritizeMinimizesCost p =
            let op = prioritize p
                ocost = cost op
                otrust = trust op
                costIsLessOrEqual p' =
                  counterexample ("variation has smaller cost: " ++ show p') $ ocost <= cost p'
                trustIsSame p' = otrust `eq` trust p'
            in ioProperty $ do variations <- replicateM 10 (shuffleProj p)
                               return $ conjoin (map costIsLessOrEqual variations) .&.
                                        conjoin (map trustIsSame variations)
      prioritizeMinimizesCost