Scheduler.hs

{-# LANGUAGE DerivingStrategies #-}

-- | A card scheduler built on top of the FSRS-7 memory model.
--
-- The memory model in "FSRS.Algorithm" is fully specified by upstream; the
-- scheduling policy around it is not, so this module follows the widely used
-- reference scheduler from
-- <https://github.com/open-spaced-repetition/py-fsrs py-fsrs>: a card walks
-- through a list of learning steps, graduates into the review queue, and drops
-- into relearning steps when it lapses.
--
-- Two things differ from py-fsrs, both because FSRS-7 is built for continuous
-- intervals where FSRS-6 was built for whole days:
--
-- * Elapsed time is measured in fractional days rather than truncated to whole
--   days, and it is fed to the model directly. There is no same-day special
--   case, because 'FSRS.Algorithm.transitionCoefficient' already is one.
-- * Scheduled intervals are not rounded to whole days. Set
--   'schedulerMinimumInterval' to @1@ (the default) to keep review-queue
--   intervals at a day or more anyway, or lower it to let FSRS-7 schedule
--   sub-day reviews.
--
-- Fuzzing is explicit rather than ambient: 'reviewCard' is deterministic, and
-- 'reviewCardFuzzed' takes the random sample as an argument, so scheduling
-- stays a pure function of its inputs.
module FSRS.Scheduler
  ( -- * Cards
    CardState (..)
  , Card (..)
  , newCard
  , cardRetrievability

    -- * Scheduler
  , Scheduler (..)
  , defaultScheduler
  , nextReviewInterval

    -- * Reviewing
  , ReviewLog (..)
  , reviewCard
  , reviewCardFuzzed
  , previewIntervals

    -- * Fuzz
  , fuzzRanges
  , fuzzBounds
  , fuzzInterval
  ) where

import Data.Maybe (fromMaybe)
import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime)

import FSRS.Algorithm
  ( nextIntervalDays
  , nextMemoryState
  , retrievability
  )
import FSRS.Parameters (Parameters, defaultParameters)
import FSRS.Types
  ( Days
  , MemoryState (..)
  , Rating (..)
  , Retrievability
  , Stability
  , allRatings
  )

-- | Where a card sits in the learn \/ review \/ relearn cycle.
data CardState
  = -- | Working through 'schedulerLearningSteps'.
    Learning
  | -- | Graduated; intervals come from the memory model.
    Review
  | -- | Lapsed, working through 'schedulerRelearningSteps'.
    Relearning
  deriving stock (Eq, Ord, Show, Read, Enum, Bounded)

-- | A card's scheduling state.
data Card = Card
  { cardState :: !CardState
  , cardStep :: !(Maybe Int)
  -- ^ Index into the current step list; 'Nothing' in the 'Review' state.
  , cardMemory :: !(Maybe MemoryState)
  -- ^ 'Nothing' until the card has been reviewed once.
  , cardDue :: !UTCTime
  , cardLastReview :: !(Maybe UTCTime)
  }
  deriving stock (Eq, Show)

-- | A card that has never been reviewed, due at the given time.
newCard :: UTCTime -> Card
newCard due =
  Card
    { cardState = Learning
    , cardStep = Just 0
    , cardMemory = Nothing
    , cardDue = due
    , cardLastReview = Nothing
    }

-- | Scheduling policy.
--
-- 'schedulerMinimumInterval' must not exceed 'schedulerMaximumInterval'.
data Scheduler = Scheduler
  { schedulerParameters :: !Parameters
  , schedulerDesiredRetention :: !Retrievability
  -- ^ The recall probability a scheduled review aims for.
  , schedulerLearningSteps :: ![NominalDiffTime]
  , schedulerRelearningSteps :: ![NominalDiffTime]
  , schedulerMinimumInterval :: !Days
  -- ^ Floor for review-queue intervals.
  , schedulerMaximumInterval :: !Days
  -- ^ Ceiling for review-queue intervals.
  }
  deriving stock (Eq, Show)

-- | The FSRS-7 defaults: 90% desired retention, one-minute and ten-minute
-- learning steps, a ten-minute relearning step, and intervals between one day
-- and a century.
defaultScheduler :: Scheduler
defaultScheduler =
  Scheduler
    { schedulerParameters = defaultParameters
    , schedulerDesiredRetention = 0.9
    , schedulerLearningSteps = [minutes 1, minutes 10]
    , schedulerRelearningSteps = [minutes 10]
    , schedulerMinimumInterval = 1
    , schedulerMaximumInterval = 36500
    }
  where
    minutes :: Integer -> NominalDiffTime
    minutes n = fromInteger (n * 60)

-- | The interval a graduated card of the given stability earns, clamped to the
-- scheduler's interval bounds.
nextReviewInterval :: Scheduler -> Stability -> Days
nextReviewInterval sched stability =
  clampTo (schedulerMinimumInterval sched) (schedulerMaximumInterval sched) $
    nextIntervalDays
      (schedulerParameters sched)
      (schedulerDesiredRetention sched)
      stability

-- | What happened in a single review.
data ReviewLog = ReviewLog
  { logRating :: !Rating
  , logReviewTime :: !UTCTime
  , logElapsedDays :: !Days
  -- ^ Days since the previous review; @0@ for a card's first review.
  , logStateBefore :: !CardState
  , logMemoryBefore :: !(Maybe MemoryState)
  , logMemoryAfter :: !MemoryState
  , logInterval :: !NominalDiffTime
  -- ^ The interval that was scheduled, after any fuzz.
  }
  deriving stock (Eq, Show)

-- | Review a card. Deterministic: no fuzz is applied.
reviewCard :: Scheduler -> Card -> Rating -> UTCTime -> (Card, ReviewLog)
reviewCard = reviewCardWith Nothing

-- | Review a card, fuzzing the scheduled interval.
--
-- The first argument is a uniform sample from @[0, 1]@, which the caller draws
-- however it likes; values outside that range are clamped. Fuzz only ever
-- applies to a card that ends up in the 'Review' state with an interval of at
-- least 2.5 days — see 'fuzzInterval'.
reviewCardFuzzed :: Double -> Scheduler -> Card -> Rating -> UTCTime -> (Card, ReviewLog)
reviewCardFuzzed = reviewCardWith . Just

reviewCardWith
  :: Maybe Double -> Scheduler -> Card -> Rating -> UTCTime -> (Card, ReviewLog)
reviewCardWith sample sched card rating now = (card', logEntry)
  where
    elapsed = case cardLastReview card of
      Nothing -> 0
      Just previous -> max 0 (realToFrac (diffUTCTime now previous) / 86400)

    memoryAfter = nextMemoryState (schedulerParameters sched) (cardMemory card) elapsed rating
    (state', step', interval) = schedule sample sched card rating memoryAfter

    card' =
      card
        { cardState = state'
        , cardStep = step'
        , cardMemory = Just memoryAfter
        , cardDue = addUTCTime interval now
        , cardLastReview = Just now
        }

    logEntry =
      ReviewLog
        { logRating = rating
        , logReviewTime = now
        , logElapsedDays = elapsed
        , logStateBefore = cardState card
        , logMemoryBefore = cardMemory card
        , logMemoryAfter = memoryAfter
        , logInterval = interval
        }

-- | The state machine: which state the card moves to, where it lands in the
-- step list, and how long until it is due again.
schedule
  :: Maybe Double
  -> Scheduler
  -> Card
  -> Rating
  -> MemoryState
  -> (CardState, Maybe Int, NominalDiffTime)
schedule sample sched card rating memory = case cardState card of
  Learning -> stepped Learning (schedulerLearningSteps sched)
  Relearning -> stepped Relearning (schedulerRelearningSteps sched)
  Review -> case rating of
    Again -> case schedulerRelearningSteps sched of
      [] -> graduate
      (firstStep : _) -> (Relearning, Just 0, firstStep)
    _ -> graduate
  where
    graduate = (Review, Nothing, daysToDiffTime fuzzed)
      where
        plain = nextReviewInterval sched (memoryStability memory)
        fuzzed = maybe plain (\u -> fuzzInterval sched u plain) sample

    current = max 0 (fromMaybe 0 (cardStep card))

    stepped _ [] = graduate
    stepped state steps@(firstStep : rest)
      -- The card was scheduled by a scheduler with more steps than this one.
      | current >= length steps && rating /= Again = graduate
      | otherwise = case rating of
          Again -> (state, Just 0, firstStep)
          Hard -> (state, Just current, hardInterval)
          Good -> case stepAt (current + 1) of
            Nothing -> graduate
            Just interval -> (state, Just (current + 1), interval)
          Easy -> graduate
      where
        stepAt i = case drop i steps of
          (interval : _) -> Just interval
          [] -> Nothing

        -- Hard repeats the current step. On the very first step there is
        -- nothing to repeat yet, so py-fsrs splits the difference with the
        -- next step, or stretches the only step by half.
        hardInterval = case (current, rest) of
          (0, []) -> firstStep * 1.5
          (0, second : _) -> (firstStep + second) / 2
          -- `current` is in range here: the guard above sent the rest to
          -- `graduate`, so the fallback is unreachable.
          _ -> fromMaybe firstStep (stepAt current)

-- | A card's retrievability at the given time, or 'Nothing' if it has never
-- been reviewed.
cardRetrievability :: Scheduler -> Card -> UTCTime -> Maybe Retrievability
cardRetrievability sched card now = do
  memory <- cardMemory card
  previous <- cardLastReview card
  let elapsed = max 0 (realToFrac (diffUTCTime now previous) / 86400)
  pure (retrievability (schedulerParameters sched) elapsed (memoryStability memory))

-- | The interval each of the four ratings would earn, without reviewing.
-- Handy for showing the four buttons' answers in a UI.
previewIntervals :: Scheduler -> Card -> UTCTime -> [(Rating, NominalDiffTime)]
previewIntervals sched card now =
  [ (rating, logInterval (snd (reviewCard sched card rating now)))
  | rating <- allRatings
  ]

-- ---------------------------------------------------------------------------
-- Fuzz
-- ---------------------------------------------------------------------------

-- | @(start, end, factor)@ triples describing how much an interval may be
-- nudged: every day of the interval that falls inside a range contributes
-- @factor@ days of slack. Taken from py-fsrs.
fuzzRanges :: [(Days, Days, Double)]
fuzzRanges =
  [ (2.5, 7.0, 0.15)
  , (7.0, 20.0, 0.1)
  , (20.0, 1 / 0, 0.05)
  ]

-- | The window an interval may be fuzzed into, or 'Nothing' for intervals
-- shorter than 2.5 days, which are left alone.
fuzzBounds :: Scheduler -> Days -> Maybe (Days, Days)
fuzzBounds sched interval
  | not (interval >= 2.5) = Nothing
  | otherwise = Just (min low high, high)
  where
    delta =
      1
        + sum
          [ factor * max 0 (min interval end - start)
          | (start, end, factor) <- fuzzRanges
          ]
    low = max 2 (interval - delta)
    high = min (schedulerMaximumInterval sched) (interval + delta)

-- | Nudge an interval by a random amount within 'fuzzBounds'.
--
-- The first argument is a uniform sample from @[0, 1]@; it is clamped, so any
-- finite value is safe. Intervals below 2.5 days are returned unchanged.
fuzzInterval :: Scheduler -> Double -> Days -> Days
fuzzInterval sched sample interval = case fuzzBounds sched interval of
  Nothing -> interval
  Just (low, high) -> low + clampTo 0 1 sample * (high - low)

-- ---------------------------------------------------------------------------
-- Helpers
-- ---------------------------------------------------------------------------

clampTo :: Double -> Double -> Double -> Double
clampTo lo hi x = min hi (max lo x)

daysToDiffTime :: Days -> NominalDiffTime
daysToDiffTime d = realToFrac (d * 86400)