Golden.hs

-- | Every function of the model, checked against vectors produced by the
-- pure-Python transcription of the upstream reference implementation.
--
-- The two implementations perform the same floating-point operations in the
-- same order on the same libm, so agreement is expected to the last few bits;
-- the tolerances below are deliberately much tighter than "close enough".
module Test.FSRS.Golden (tests) where

import Control.Monad (unless)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (Assertion, assertFailure, testCase, (@?=))

import FSRS
import Test.FSRS.Gen (approxEqual, relativeError)
import Test.FSRS.GoldenData

-- | Tolerance for everything but the root-finder: bit-for-bit agreement with a
-- little slack for the last ulp.
tol :: Double
tol = 1.0e-12

-- | The interval solver converges by a different route than the Python
-- bisection used to produce the vectors, so it only agrees to about a
-- nanosecond in relative terms.
intervalTol :: Double
intervalTol = 1.0e-9

tests :: TestTree
tests =
  testGroup
    "golden vectors"
    [ testCase "the golden parameter sets are all valid" $
        mapM_
          (\ws -> validateParameters ws @?= [])
          goldenParameterSets
    , testCase "the first golden parameter set is the default one" $
        take 1 goldenParameterSets @?= [parametersToList defaultParameters]
    , labelled "forgetting curve" goldenCurveVectors checkCurve
    , labelled "difficulty" goldenDifficultyVectors checkDifficulty
    , labelled "stability blocks" goldenHalfStabilityVectors checkHalfStability
    , labelled "transition function" goldenTransitionVectors checkTransition
    , labelled "memory-state transition" goldenStepVectors checkStep
    , labelled "interval inversion" goldenIntervalVectors checkInterval
    , labelled "replayed review histories" goldenReplayVectors checkReplay
    ]

labelled :: String -> [a] -> (a -> Assertion) -> TestTree
labelled name vectors check =
  testCase (name <> " (" <> show (length vectors) <> " vectors)") $
    mapM_ check vectors

paramsAt :: Int -> Parameters
paramsAt i = case mkParameters (goldenParameterSets !! i) of
  Right p -> p
  Left errs -> error ("golden parameter set " <> show i <> " is invalid: " <> show errs)

ratingAt :: Int -> Rating
ratingAt n = case ratingFromInt n of
  Just r -> r
  Nothing -> error ("golden vector has a bad rating: " <> show n)

close :: Double -> String -> Double -> Double -> Assertion
close t label expected actual =
  unless (approxEqual t t actual expected) $
    assertFailure $
      label
        <> "\n  expected: "
        <> show expected
        <> "\n  actual:   "
        <> show actual
        <> "\n  relative error: "
        <> show (relativeError actual expected)

checkCurve :: CurveVector -> Assertion
checkCurve v =
  close tol (show v) (cvRetrievability v) $
    retrievability (paramsAt (cvParams v)) (cvElapsedDays v) (cvStability v)

checkDifficulty :: DifficultyVector -> Assertion
checkDifficulty v =
  close tol (show v) (dvNextDifficulty v) $
    case dvDifficulty v of
      Nothing -> initialDifficulty params rating
      Just d -> nextDifficulty params d rating
  where
    params = paramsAt (dvParams v)
    rating = ratingAt (dvRating v)

checkHalfStability :: HalfStabilityVector -> Assertion
checkHalfStability v =
  close tol (show v) (hsNextStability v) $
    stabilityAfterReview
      block
      (MemoryState (hsStability v) (hsDifficulty v))
      (hsRetrievability v)
      (ratingAt (hsRating v))
  where
    params = paramsAt (hsParams v)
    block = (if hsLongTerm v then longTermWeights else shortTermWeights) params

checkTransition :: TransitionVector -> Assertion
checkTransition v =
  close tol (show v) (tvCoefficient v) $
    transitionCoefficient (paramsAt (tvParams v)) (tvElapsedDays v)

checkStep :: StepVector -> Assertion
checkStep v = do
  close tol (show v <> " [stability]") expectedS (memoryStability actual)
  close tol (show v <> " [difficulty]") expectedD (memoryDifficulty actual)
  where
    (expectedS, expectedD) = svNextState v
    actual =
      nextMemoryState
        (paramsAt (svParams v))
        (uncurry MemoryState <$> svState v)
        (svElapsedDays v)
        (ratingAt (svRating v))

checkInterval :: IntervalVector -> Assertion
checkInterval v =
  close intervalTol (show v) (ivInterval v) $
    nextIntervalDays (paramsAt (ivParams v)) (ivDesiredRetention v) (ivStability v)

checkReplay :: ReplayVector -> Assertion
checkReplay v = case replayReviews params reviews of
  Nothing -> assertFailure (show v <> ": replayReviews returned Nothing")
  Just actual -> do
    close tol (show v <> " [stability]") expectedS (memoryStability actual)
    close tol (show v <> " [difficulty]") expectedD (memoryDifficulty actual)
  where
    params = paramsAt (rvParams v)
    reviews = [(dt, ratingAt g) | (dt, g) <- rvReviews v]
    (expectedS, expectedD) = rvFinalState v