haskell-fsrs-7.0.0: test/Test/FSRS/Properties.hs
-- | Properties of the FSRS-7 model.
--
-- Most of these hold for every parameter vector inside the valid box, and are
-- generated that way. A few — the ones about how retrievability and intervals
-- respond to /stability/ — only hold for well-behaved parameters: the two
-- power laws of the FSRS-7 forgetting curve are re-weighted by stability, and
-- for adversarial weights the second component can pull retrievability
-- /down/ as stability grows. Those properties are therefore stated for
-- 'defaultParameters', and say so.
module Test.FSRS.Properties (tests) where
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck
( counterexample
, forAll
, testProperty
, vectorOf
, (===)
, (==>)
)
import qualified Test.Tasty.QuickCheck as QC
import FSRS
import Test.FSRS.Gen
tests :: TestTree
tests =
testGroup
"properties"
[ parameterProperties
, curveProperties
, intervalProperties
, difficultyProperties
, stabilityProperties
, transitionProperties
, stateProperties
]
-- ---------------------------------------------------------------------------
parameterProperties :: TestTree
parameterProperties =
testGroup
"parameters"
[ testProperty "the defaults are valid" $
validateParameters (parametersToList defaultParameters) === []
, testProperty "there are exactly parameterCount defaults" $
length (parametersToList defaultParameters) === parameterCount
, testProperty "mkParameters . parametersToList is the identity" $
forAll genParameters $ \p ->
mkParameters (parametersToList p) === Right p
, testProperty "parameterAt agrees with parametersToList" $
forAll genParameters $ \p ->
map (parameterAt p) [0 .. parameterCount - 1] === parametersToList p
, testProperty "a wrong number of weights is rejected" $
forAll (QC.choose (0, 60)) $ \n ->
n /= parameterCount ==>
mkParameters (replicate n 0.5) === Left [WrongParameterCount n]
, testProperty "clampParameters always produces something valid" $
forAll (vectorOf parameterCount (QC.choose (-1000, 1000))) $ \ws ->
case clampParameters ws of
Left errs -> counterexample (show errs) False
Right p -> counterexample (show p) (validateParameters (parametersToList p) == [])
, testProperty "clampParameters is idempotent" $
forAll (vectorOf parameterCount (QC.choose (-1000, 1000))) $ \ws ->
let once = clampParameters ws
twice = once >>= clampParameters . parametersToList
in once === twice
, testProperty "clampParameters keeps valid weights untouched" $
forAll genParameters $ \p ->
clampParameters (parametersToList p) === Right p
]
-- ---------------------------------------------------------------------------
curveProperties :: TestTree
curveProperties =
testGroup
"forgetting curve"
[ testProperty "a card just reviewed is certain to be recalled" $
forAll genParameters $ \p ->
forAll genStability $ \s ->
retrievability p 0 s === 1
, testProperty "retrievability is a probability" $
forAll genParameters $ \p ->
forAll genElapsedDays $ \t ->
forAll genStability $ \s ->
let r = retrievability p t s
in counterexample (show r) (r > 0 && r <= 1)
, testProperty "retrievability decreases as time passes" $
forAll genParameters $ \p ->
forAll genElapsedDays $ \t1 ->
forAll (QC.choose (1.0e-6, 5)) $ \gap ->
forAll genStability $ \s ->
let t2 = t1 + gap
r1 = retrievability p t1 s
r2 = retrievability p t2 s
in counterexample (show (t1, t2, r1, r2)) (r2 <= r1 + 1.0e-15)
, testProperty "the derivative is never positive" $
forAll genParameters $ \p ->
forAll genElapsedDays $ \t ->
forAll genStability $ \s ->
let d = retrievabilityDerivative p t s
in counterexample (show d) (d <= 0)
, testProperty "the derivative matches a finite difference" $
forAll genParameters $ \p ->
forAll (QC.choose (0.5, 50)) $ \t ->
forAll (QC.choose (1, 500)) $ \s ->
let h = 1.0e-6 * t
numeric = (retrievability p (t + h) s - retrievability p (t - h) s) / (2 * h)
exact = retrievabilityDerivative p t s
in counterexample (show (numeric, exact)) $
approxEqual 1.0e-7 1.0e-5 numeric exact
, testProperty "with the default weights, more stability means more recall" $
forAll genElapsedDays $ \t ->
forAll genStability $ \s1 ->
forAll (QC.choose (1.0e-6, 5)) $ \growth ->
let s2 = min stabilityMax (s1 * exp growth)
r1 = retrievability defaultParameters t s1
r2 = retrievability defaultParameters t s2
in counterexample (show (s1, s2, r1, r2)) (r2 >= r1)
]
-- ---------------------------------------------------------------------------
intervalProperties :: TestTree
intervalProperties =
testGroup
"interval inversion"
[ testProperty "the answer is always a legal interval" $
forAll genParameters $ \p ->
forAll genDesiredRetention $ \dr ->
forAll genStability $ \s ->
let t = nextIntervalDays p dr s
in counterexample (show t) (t >= minimumIntervalDays && t <= maximumIntervalDays)
, testProperty "waiting that long really does land on the desired retention" $
forAll genParameters $ \p ->
forAll genDesiredRetention $ \dr ->
forAll genStability $ \s ->
let t = nextIntervalDays p dr s
r = retrievability p t s
in -- Saturated answers cannot hit the target and do not claim to.
t > minimumIntervalDays && t < maximumIntervalDays ==>
counterexample (show (t, r, dr)) (approxEqual 1.0e-9 1.0e-9 r dr)
, testProperty "asking for more retention never buys a longer interval" $
forAll genParameters $ \p ->
forAll genStability $ \s ->
forAll genDesiredRetention $ \dr1 ->
forAll (QC.choose (1.0e-6, 0.2)) $ \bump ->
let dr2 = min 0.999 (dr1 + bump)
t1 = nextIntervalDays p dr1 s
t2 = nextIntervalDays p dr2 s
in counterexample (show (dr1, dr2, t1, t2)) (t2 <= t1 * (1 + 1.0e-9))
, testProperty "with the default weights, more stability means a longer interval" $
forAll genDesiredRetention $ \dr ->
forAll genStability $ \s1 ->
forAll (QC.choose (1.0e-6, 5)) $ \growth ->
let s2 = min stabilityMax (s1 * exp growth)
t1 = nextIntervalDays defaultParameters dr s1
t2 = nextIntervalDays defaultParameters dr s2
in counterexample (show (s1, s2, t1, t2)) (t2 >= t1 * (1 - 1.0e-9))
, testProperty "an impossible retention saturates instead of diverging" $
forAll genParameters $ \p ->
forAll genStability $ \s ->
counterexample "retention 1" (nextIntervalDays p 1 s == minimumIntervalDays)
QC..&&. counterexample "retention 0" (nextIntervalDays p 0 s == maximumIntervalDays)
]
-- ---------------------------------------------------------------------------
difficultyProperties :: TestTree
difficultyProperties =
testGroup
"difficulty"
[ testProperty "initial difficulty is in range" $
forAll genParameters $ \p ->
forAll genRating $ \rating ->
let d = initialDifficulty p rating
in counterexample (show d) (d >= difficultyMin && d <= difficultyMax)
, testProperty "difficulty stays in range" $
forAll genParameters $ \p ->
forAll genDifficulty $ \d ->
forAll genRating $ \rating ->
let d' = nextDifficulty p d rating
in counterexample (show d') (d' >= difficultyMin && d' <= difficultyMax)
, testProperty "a better rating never makes a card harder" $
forAll genParameters $ \p ->
forAll genDifficulty $ \d ->
let ds = map (nextDifficulty p d) allRatings
in counterexample (show ds) (nonIncreasing ds)
, testProperty "an easier first answer means an easier card" $
forAll genParameters $ \p ->
counterexample
(show (map (initialDifficulty p) allRatings))
(nonIncreasing (map (initialDifficulty p) allRatings))
, testProperty "difficulty stays in range over a long history" $
forAll genParameters $ \p ->
forAll (vectorOf 200 genRating) $ \ratings ->
let ds = scanl (nextDifficulty p) 5 ratings
in counterexample (show (minimum ds, maximum ds)) $
all (\d -> d >= difficultyMin && d <= difficultyMax) ds
]
-- ---------------------------------------------------------------------------
stabilityProperties :: TestTree
stabilityProperties =
testGroup
"stability"
[ testProperty "stability stays in range" $
forAll genParameters $ \p ->
forAll genMemoryState $ \st ->
forAll genElapsedDays $ \t ->
forAll genRating $ \rating ->
let s = memoryStability (nextMemoryState p (Just st) t rating)
in counterexample (show s) (s >= stabilityMin && s <= stabilityMax)
, testProperty "a better rating never means less stability" $
forAll genParameters $ \p ->
forAll genMemoryState $ \st ->
forAll genElapsedDays $ \t ->
let ss = [memoryStability (nextMemoryState p (Just st) t r) | r <- allRatings]
in counterexample (show ss) (nonDecreasing ss)
, testProperty "remembering a card cannot weaken it" $
forAll genParameters $ \p ->
forAll genMemoryState $ \st ->
forAll genElapsedDays $ \t ->
forAll (QC.elements [Hard, Good, Easy]) $ \rating ->
let before = memoryStability st
after = memoryStability (nextMemoryState p (Just st) t rating)
in counterexample (show (before, after)) (after >= before * (1 - 1.0e-12))
, testProperty "forgetting a card cannot strengthen it" $
forAll genParameters $ \p ->
forAll genMemoryState $ \st ->
forAll genElapsedDays $ \t ->
let before = memoryStability st
after = memoryStability (nextMemoryState p (Just st) t Again)
in counterexample (show (before, after)) (after <= before * (1 + 1.0e-12))
, testProperty "the two blocks bracket the blended result" $
forAll genParameters $ \p ->
forAll genMemoryState $ \st ->
forAll genElapsedDays $ \t ->
forAll genRating $ \rating ->
let r = retrievability p t (memoryStability st)
long = stabilityAfterReview (longTermWeights p) st r rating
short = stabilityAfterReview (shortTermWeights p) st r rating
blended = nextStability p st t rating
in counterexample (show (short, blended, long)) $
blended >= min short long - 1.0e-9
&& blended <= max short long + 1.0e-9
, testProperty "at zero elapsed time the blend is the short-term block" $
-- Only when the transition amplitude is exactly 1 — which is the
-- default, and the upper bound of w26.
forAll (withFullAmplitude <$> genParameters) $ \p ->
forAll genMemoryState $ \st ->
forAll genRating $ \rating ->
let r = retrievability p 0 (memoryStability st)
short = stabilityAfterReview (shortTermWeights p) st r rating
in counterexample (show (short, nextStability p st 0 rating)) $
approxEqual 1.0e-12 1.0e-12 (nextStability p st 0 rating) short
, testProperty "the initial stability is the matching weight" $
forAll genParameters $ \p ->
forAll genRating $ \rating ->
initialStability p rating === parameterAt p (ratingToInt rating - 1)
]
-- ---------------------------------------------------------------------------
transitionProperties :: TestTree
transitionProperties =
testGroup
"long-/short-term transition"
[ testProperty "the coefficient is a weight in [0, 1]" $
forAll genParameters $ \p ->
forAll genElapsedDays $ \t ->
let c = transitionCoefficient p t
in counterexample (show c) (c >= 0 && c <= 1)
, testProperty "the coefficient grows with the gap" $
forAll genParameters $ \p ->
forAll genElapsedDays $ \t1 ->
forAll (QC.choose (1.0e-6, 10)) $ \gap ->
let c1 = transitionCoefficient p t1
c2 = transitionCoefficient p (t1 + gap)
in counterexample (show (c1, c2)) (c2 >= c1 - 1.0e-15)
, testProperty "a same-instant review is purely short-term" $
forAll genParameters $ \p ->
transitionCoefficient p 0 === 1 - transitionAmplitude p
, testProperty "a distant review is purely long-term" $
forAll genParameters $ \p ->
counterexample (show (transitionCoefficient p 3650)) $
approxEqual 1.0e-9 0 (transitionCoefficient p 3650) 1
]
-- ---------------------------------------------------------------------------
stateProperties :: TestTree
stateProperties =
testGroup
"state transitions"
[ testProperty "a first review reads the state off the weights" $
forAll genParameters $ \p ->
forAll genElapsedDays $ \t ->
forAll genRating $ \rating ->
nextMemoryState p Nothing t rating
=== MemoryState (initialStability p rating) (initialDifficulty p rating)
, testProperty "the elapsed time of a first review is ignored" $
forAll genParameters $ \p ->
forAll genElapsedDays $ \t1 ->
forAll genElapsedDays $ \t2 ->
forAll genRating $ \rating ->
nextMemoryState p Nothing t1 rating === nextMemoryState p Nothing t2 rating
, testProperty "an empty history has no memory state" $
forAll genParameters $ \p ->
replayReviews p [] === Nothing
, testProperty "replaying is a left fold" $
forAll genParameters $ \p ->
forAll genReviewHistory $ \xs ->
forAll genReviewHistory $ \ys ->
let viaConcat = replayReviews p (xs <> ys)
viaFold = foldl (\st (t, r) -> Just (nextMemoryState p st t r)) (replayReviews p xs) ys
in viaConcat === viaFold
, testProperty "any history leaves the card in a legal state" $
forAll genParameters $ \p ->
forAll genReviewHistory $ \history ->
case replayReviews p history of
Nothing -> QC.property (null history)
Just (MemoryState s d) ->
counterexample (show (s, d)) $
s >= stabilityMin
&& s <= stabilityMax
&& d >= difficultyMin
&& d <= difficultyMax
, testProperty "the state is finite, however long the history" $
forAll genParameters $ \p ->
forAll (vectorOf 100 ((,) <$> genElapsedDays <*> genRating)) $ \history ->
case replayReviews p history of
Nothing -> counterexample "unexpected Nothing" False
Just (MemoryState s d) ->
counterexample (show (s, d)) $
not (isNaN s) && not (isInfinite s) && not (isNaN d) && not (isInfinite d)
]
-- ---------------------------------------------------------------------------
-- | Pin @w26@ to its upper bound, so a same-instant review is purely
-- short-term.
withFullAmplitude :: Parameters -> Parameters
withFullAmplitude p =
case clampParameters (setAt 26 1 (parametersToList p)) of
Right p' -> p'
Left errs -> error (show errs)
where
setAt i x xs = take i xs <> [x] <> drop (i + 1) xs
nonDecreasing :: [Double] -> Bool
nonDecreasing xs = and (zipWith (<=) xs (drop 1 xs))
nonIncreasing :: [Double] -> Bool
nonIncreasing xs = and (zipWith (>=) xs (drop 1 xs))