haskell-fsrs-7.0.0: test/Test/FSRS/SchedulerSpec.hs
-- | Tests for the scheduling layer: the state machine, due dates and fuzz.
module Test.FSRS.SchedulerSpec (tests) where
import Data.Time.Calendar (fromGregorian)
import Data.Time.Clock (NominalDiffTime, UTCTime (..), addUTCTime, diffUTCTime)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (assertBool, testCase, (@?=))
import Test.Tasty.QuickCheck (counterexample, forAll, testProperty, (===))
import qualified Test.Tasty.QuickCheck as QC
import FSRS
import Test.FSRS.Gen
tests :: TestTree
tests = testGroup "scheduler" [unitTests, properties]
t0 :: UTCTime
t0 = UTCTime (fromGregorian 2026 1 1) 0
minutes :: Double -> NominalDiffTime
minutes m = realToFrac (m * 60)
days :: Double -> NominalDiffTime
days d = realToFrac (d * 86400)
-- ---------------------------------------------------------------------------
unitTests :: TestTree
unitTests =
testGroup
"the learn/review/relearn cycle"
[ testCase "a new card starts in Learning on step 0 with no memory" $ do
let card = newCard t0
cardState card @?= Learning
cardStep card @?= Just 0
cardMemory card @?= Nothing
cardLastReview card @?= Nothing
, testCase "Good on a new card takes the first learning step" $ do
let (card, entry) = reviewCard defaultScheduler (newCard t0) Good t0
cardState card @?= Learning
cardStep card @?= Just 1
logInterval entry @?= minutes 10
cardDue card @?= addUTCTime (minutes 10) t0
cardMemory card
@?= Just (nextMemoryState defaultParameters Nothing 0 Good)
, testCase "Again on a new card repeats the first learning step" $ do
let (card, entry) = reviewCard defaultScheduler (newCard t0) Again t0
cardState card @?= Learning
cardStep card @?= Just 0
logInterval entry @?= minutes 1
, testCase "Hard on the first of two learning steps splits the difference" $ do
let (_, entry) = reviewCard defaultScheduler (newCard t0) Hard t0
logInterval entry @?= minutes 5.5
, testCase "Hard on a single learning step stretches it by half" $ do
let sched = defaultScheduler {schedulerLearningSteps = [minutes 10]}
(_, entry) = reviewCard sched (newCard t0) Hard t0
logInterval entry @?= minutes 15
, testCase "Easy graduates a new card immediately" $ do
let (card, entry) = reviewCard defaultScheduler (newCard t0) Easy t0
cardState card @?= Review
cardStep card @?= Nothing
assertBool "at least a day" (logInterval entry >= days 1)
, testCase "Good on the last learning step graduates" $ do
let (card1, _) = reviewCard defaultScheduler (newCard t0) Good t0
t1 = cardDue card1
(card2, _) = reviewCard defaultScheduler card1 Good t1
cardState card2 @?= Review
cardStep card2 @?= Nothing
, testCase "a scheduler with no learning steps graduates at once" $ do
let sched = defaultScheduler {schedulerLearningSteps = []}
(card, _) = reviewCard sched (newCard t0) Good t0
cardState card @?= Review
, testCase "Again on a review card drops it into relearning" $ do
let (graduated, _) = reviewCard defaultScheduler (newCard t0) Easy t0
t1 = cardDue graduated
(card, entry) = reviewCard defaultScheduler graduated Again t1
cardState card @?= Relearning
cardStep card @?= Just 0
logInterval entry @?= minutes 10
, testCase "Again on a review card stays in review when relearning is off" $ do
let sched = defaultScheduler {schedulerRelearningSteps = []}
(graduated, _) = reviewCard sched (newCard t0) Easy t0
(card, _) = reviewCard sched graduated Again (cardDue graduated)
cardState card @?= Review
cardStep card @?= Nothing
, testCase "Good on the only relearning step graduates again" $ do
let (graduated, _) = reviewCard defaultScheduler (newCard t0) Easy t0
(lapsed, _) = reviewCard defaultScheduler graduated Again (cardDue graduated)
(card, _) = reviewCard defaultScheduler lapsed Good (cardDue lapsed)
cardState card @?= Review
cardStep card @?= Nothing
, testCase "a card scheduled by a longer-stepped scheduler still graduates" $ do
let stale = (newCard t0) {cardStep = Just 5, cardMemory = Just (MemoryState 10 5)}
(card, _) = reviewCard defaultScheduler stale Good t0
cardState card @?= Review
, testCase "retrievability is unknown until the first review" $
cardRetrievability defaultScheduler (newCard t0) t0 @?= Nothing
, testCase "a graduated card is at the desired retention when it comes due" $ do
let (card, _) = reviewCard defaultScheduler (newCard t0) Easy t0
due = cardDue card
case cardRetrievability defaultScheduler card due of
Nothing -> assertBool "expected a retrievability" False
Just r ->
assertBool
("expected ~0.9, got " <> show r)
(approxEqual 1.0e-6 1.0e-6 r (schedulerDesiredRetention defaultScheduler))
, testCase "previewIntervals agrees with actually reviewing" $ do
let card = newCard t0
preview = previewIntervals defaultScheduler card t0
actual =
[ (r, logInterval (snd (reviewCard defaultScheduler card r t0)))
| r <- allRatings
]
preview @?= actual
, testCase "fuzz leaves short intervals alone" $ do
fuzzInterval defaultScheduler 0.0 2.4 @?= 2.4
fuzzBounds defaultScheduler 2.4 @?= Nothing
, testCase "the fuzz window for a 10-day interval matches py-fsrs" $
-- delta = 1 + 0.15 * (7 - 2.5) + 0.1 * (10 - 7) = 1.975
case fuzzBounds defaultScheduler 10 of
Nothing -> assertBool "expected a fuzz window" False
Just (low, high) -> do
assertBool (show low) (approxEqual 1.0e-12 1.0e-12 low 8.025)
assertBool (show high) (approxEqual 1.0e-12 1.0e-12 high 11.975)
, testCase "fuzz is centred on the unfuzzed interval" $
assertBool "midpoint" $
approxEqual 1.0e-12 1.0e-12 (fuzzInterval defaultScheduler 0.5 10) 10
]
-- ---------------------------------------------------------------------------
properties :: TestTree
properties =
testGroup
"scheduling properties"
[ testProperty "a reviewed card is always due in the future" $
forAll genScheduler $ \sched ->
forAll genCardAndTime $ \(card, now) ->
forAll genRating $ \rating ->
let (card', _) = reviewCard sched card rating now
in counterexample (show (cardDue card', now)) (cardDue card' > now)
, testProperty "a reviewed card always has a memory state" $
forAll genScheduler $ \sched ->
forAll genCardAndTime $ \(card, now) ->
forAll genRating $ \rating ->
let (card', _) = reviewCard sched card rating now
in counterexample (show card') (cardMemory card' /= Nothing)
, testProperty "the log agrees with the card" $
forAll genScheduler $ \sched ->
forAll genCardAndTime $ \(card, now) ->
forAll genRating $ \rating ->
let (card', entry) = reviewCard sched card rating now
in counterexample (show (card', entry)) $
logRating entry == rating
&& logReviewTime entry == now
&& logStateBefore entry == cardState card
&& logMemoryBefore entry == cardMemory card
&& Just (logMemoryAfter entry) == cardMemory card'
&& addUTCTime (logInterval entry) now == cardDue card'
, testProperty "reviewing is deterministic" $
forAll genScheduler $ \sched ->
forAll genCardAndTime $ \(card, now) ->
forAll genRating $ \rating ->
reviewCard sched card rating now === reviewCard sched card rating now
, testProperty "a card in Review has no step, one in Learning has one" $
forAll genScheduler $ \sched ->
forAll genCardAndTime $ \(card, now) ->
forAll genRating $ \rating ->
let (card', _) = reviewCard sched card rating now
in counterexample (show card') $
case cardState card' of
Review -> cardStep card' == Nothing
_ -> cardStep card' /= Nothing
, testProperty "a graduated interval respects the scheduler's bounds" $
forAll genScheduler $ \sched ->
forAll genStability $ \s ->
let ivl = nextReviewInterval sched s
in counterexample (show ivl) $
ivl >= schedulerMinimumInterval sched
&& ivl <= schedulerMaximumInterval sched
, testProperty "fuzz stays inside its window" $
forAll genScheduler $ \sched ->
forAll (QC.choose (0, 1)) $ \sample ->
forAll (QC.choose (0, 36500)) $ \ivl ->
let fuzzed = fuzzInterval sched sample ivl
in case fuzzBounds sched ivl of
Nothing -> counterexample (show fuzzed) (fuzzed === ivl)
Just (low, high) ->
counterexample (show (low, fuzzed, high)) $
QC.property (fuzzed >= low && fuzzed <= high)
, testProperty "fuzz never exceeds the maximum interval" $
forAll genScheduler $ \sched ->
forAll (QC.choose (-5, 5)) $ \sample ->
forAll (QC.choose (0, 36500)) $ \ivl ->
let fuzzed = fuzzInterval sched sample ivl
in counterexample (show fuzzed) $
fuzzed <= max ivl (schedulerMaximumInterval sched)
, testProperty "an out-of-range fuzz sample is clamped, not extrapolated" $
forAll genScheduler $ \sched ->
forAll (QC.choose (2.5, 36500)) $ \ivl ->
fuzzInterval sched (-100) ivl === fuzzInterval sched 0 ivl
QC..&&. fuzzInterval sched 100 ivl === fuzzInterval sched 1 ivl
, testProperty "a better rating never shortens a review card's interval" $
-- With the default weights: for adversarial weights a longer interval
-- does not always follow from more stability, see Test.FSRS.Properties.
forAll (withDefaultParameters <$> genScheduler) $ \sched ->
forAll genUTCTime $ \now ->
forAll genMemoryState $ \memory ->
let card =
(newCard now)
{ cardState = Review
, cardStep = Nothing
, cardMemory = Just memory
, cardLastReview = Just now
}
ivls =
[ logInterval (snd (reviewCard sched card r now))
| r <- [Hard, Good, Easy]
]
in counterexample (show ivls) (and (zipWith (<=) ivls (drop 1 ivls)))
, testProperty "elapsed time is measured in fractional days" $
forAll genScheduler $ \sched ->
forAll genUTCTime $ \now ->
forAll (QC.choose (0, 10 * 86400)) $ \seconds ->
forAll genMemoryState $ \memory ->
let card =
(newCard now)
{ cardState = Review
, cardStep = Nothing
, cardMemory = Just memory
, cardLastReview = Just now
}
later = addUTCTime (realToFrac (seconds :: Double)) now
(_, entry) = reviewCard sched card Good later
in counterexample (show (seconds, logElapsedDays entry)) $
approxEqual 1.0e-9 1.0e-9 (logElapsedDays entry) (seconds / 86400)
, testProperty "a session of reviews always moves forward in time" $
forAll genScheduler $ \sched ->
forAll genUTCTime $ \start ->
forAll (QC.resize 20 (QC.listOf genRating)) $ \ratings ->
let session = scanl next (newCard start, start) ratings
next (card, now) rating =
let (card', _) = reviewCard sched card rating now
in (card', cardDue card')
times = map snd session
gaps = zipWith diffUTCTime (drop 1 times) times
in counterexample (show gaps) (all (> 0) gaps)
, testProperty "a session never leaves the memory state out of range" $
forAll genScheduler $ \sched ->
forAll genUTCTime $ \start ->
forAll (QC.resize 20 (QC.listOf genRating)) $ \ratings ->
let step (card, now) rating =
let (card', _) = reviewCard sched card rating now
in (card', cardDue card')
states =
[ memory
| (card, _) <- scanl step (newCard start, start) ratings
, Just memory <- [cardMemory card]
]
in counterexample (show states) $
all
( \(MemoryState s d) ->
s >= stabilityMin
&& s <= stabilityMax
&& d >= difficultyMin
&& d <= difficultyMax
)
states
]
-- | Keep a generated scheduler's policy but pin it to the default weights.
withDefaultParameters :: Scheduler -> Scheduler
withDefaultParameters sched = sched {schedulerParameters = defaultParameters}
genCardAndTime :: QC.Gen (Card, UTCTime)
genCardAndTime = do
now <- genUTCTime
state <- QC.elements [Learning, Review, Relearning]
memory <- QC.frequency [(1, pure Nothing), (4, Just <$> genMemoryState)]
step <- case state of
Review -> pure Nothing
_ -> Just <$> QC.choose (0, 4)
elapsed <- QC.choose (0, 400 * 86400)
let lastReview = case memory of
Nothing -> Nothing
Just _ -> Just (addUTCTime (negate (realToFrac (elapsed :: Double))) now)
pure
( Card
{ cardState = state
, cardStep = step
, cardMemory = memory
, cardDue = now
, cardLastReview = lastReview
}
, now
)