{-# 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 (CardState -> CardState -> Bool
(CardState -> CardState -> Bool)
-> (CardState -> CardState -> Bool) -> Eq CardState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CardState -> CardState -> Bool
== :: CardState -> CardState -> Bool
$c/= :: CardState -> CardState -> Bool
/= :: CardState -> CardState -> Bool
Eq, Eq CardState
Eq CardState =>
(CardState -> CardState -> Ordering)
-> (CardState -> CardState -> Bool)
-> (CardState -> CardState -> Bool)
-> (CardState -> CardState -> Bool)
-> (CardState -> CardState -> Bool)
-> (CardState -> CardState -> CardState)
-> (CardState -> CardState -> CardState)
-> Ord CardState
CardState -> CardState -> Bool
CardState -> CardState -> Ordering
CardState -> CardState -> CardState
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CardState -> CardState -> Ordering
compare :: CardState -> CardState -> Ordering
$c< :: CardState -> CardState -> Bool
< :: CardState -> CardState -> Bool
$c<= :: CardState -> CardState -> Bool
<= :: CardState -> CardState -> Bool
$c> :: CardState -> CardState -> Bool
> :: CardState -> CardState -> Bool
$c>= :: CardState -> CardState -> Bool
>= :: CardState -> CardState -> Bool
$cmax :: CardState -> CardState -> CardState
max :: CardState -> CardState -> CardState
$cmin :: CardState -> CardState -> CardState
min :: CardState -> CardState -> CardState
Ord, Int -> CardState -> ShowS
[CardState] -> ShowS
CardState -> String
(Int -> CardState -> ShowS)
-> (CardState -> String)
-> ([CardState] -> ShowS)
-> Show CardState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CardState -> ShowS
showsPrec :: Int -> CardState -> ShowS
$cshow :: CardState -> String
show :: CardState -> String
$cshowList :: [CardState] -> ShowS
showList :: [CardState] -> ShowS
Show, ReadPrec [CardState]
ReadPrec CardState
Int -> ReadS CardState
ReadS [CardState]
(Int -> ReadS CardState)
-> ReadS [CardState]
-> ReadPrec CardState
-> ReadPrec [CardState]
-> Read CardState
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS CardState
readsPrec :: Int -> ReadS CardState
$creadList :: ReadS [CardState]
readList :: ReadS [CardState]
$creadPrec :: ReadPrec CardState
readPrec :: ReadPrec CardState
$creadListPrec :: ReadPrec [CardState]
readListPrec :: ReadPrec [CardState]
Read, Int -> CardState
CardState -> Int
CardState -> [CardState]
CardState -> CardState
CardState -> CardState -> [CardState]
CardState -> CardState -> CardState -> [CardState]
(CardState -> CardState)
-> (CardState -> CardState)
-> (Int -> CardState)
-> (CardState -> Int)
-> (CardState -> [CardState])
-> (CardState -> CardState -> [CardState])
-> (CardState -> CardState -> [CardState])
-> (CardState -> CardState -> CardState -> [CardState])
-> Enum CardState
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: CardState -> CardState
succ :: CardState -> CardState
$cpred :: CardState -> CardState
pred :: CardState -> CardState
$ctoEnum :: Int -> CardState
toEnum :: Int -> CardState
$cfromEnum :: CardState -> Int
fromEnum :: CardState -> Int
$cenumFrom :: CardState -> [CardState]
enumFrom :: CardState -> [CardState]
$cenumFromThen :: CardState -> CardState -> [CardState]
enumFromThen :: CardState -> CardState -> [CardState]
$cenumFromTo :: CardState -> CardState -> [CardState]
enumFromTo :: CardState -> CardState -> [CardState]
$cenumFromThenTo :: CardState -> CardState -> CardState -> [CardState]
enumFromThenTo :: CardState -> CardState -> CardState -> [CardState]
Enum, CardState
CardState -> CardState -> Bounded CardState
forall a. a -> a -> Bounded a
$cminBound :: CardState
minBound :: CardState
$cmaxBound :: CardState
maxBound :: CardState
Bounded)

-- | A card's scheduling state.
data Card = Card
  { Card -> CardState
cardState :: !CardState
  , Card -> Maybe Int
cardStep :: !(Maybe Int)
  -- ^ Index into the current step list; 'Nothing' in the 'Review' state.
  , Card -> Maybe MemoryState
cardMemory :: !(Maybe MemoryState)
  -- ^ 'Nothing' until the card has been reviewed once.
  , Card -> UTCTime
cardDue :: !UTCTime
  , Card -> Maybe UTCTime
cardLastReview :: !(Maybe UTCTime)
  }
  deriving stock (Card -> Card -> Bool
(Card -> Card -> Bool) -> (Card -> Card -> Bool) -> Eq Card
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Card -> Card -> Bool
== :: Card -> Card -> Bool
$c/= :: Card -> Card -> Bool
/= :: Card -> Card -> Bool
Eq, Int -> Card -> ShowS
[Card] -> ShowS
Card -> String
(Int -> Card -> ShowS)
-> (Card -> String) -> ([Card] -> ShowS) -> Show Card
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Card -> ShowS
showsPrec :: Int -> Card -> ShowS
$cshow :: Card -> String
show :: Card -> String
$cshowList :: [Card] -> ShowS
showList :: [Card] -> ShowS
Show)

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

-- | Scheduling policy.
--
-- 'schedulerMinimumInterval' must not exceed 'schedulerMaximumInterval'.
data Scheduler = Scheduler
  { Scheduler -> Parameters
schedulerParameters :: !Parameters
  , Scheduler -> Days
schedulerDesiredRetention :: !Retrievability
  -- ^ The recall probability a scheduled review aims for.
  , Scheduler -> [NominalDiffTime]
schedulerLearningSteps :: ![NominalDiffTime]
  , Scheduler -> [NominalDiffTime]
schedulerRelearningSteps :: ![NominalDiffTime]
  , Scheduler -> Days
schedulerMinimumInterval :: !Days
  -- ^ Floor for review-queue intervals.
  , Scheduler -> Days
schedulerMaximumInterval :: !Days
  -- ^ Ceiling for review-queue intervals.
  }
  deriving stock (Scheduler -> Scheduler -> Bool
(Scheduler -> Scheduler -> Bool)
-> (Scheduler -> Scheduler -> Bool) -> Eq Scheduler
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Scheduler -> Scheduler -> Bool
== :: Scheduler -> Scheduler -> Bool
$c/= :: Scheduler -> Scheduler -> Bool
/= :: Scheduler -> Scheduler -> Bool
Eq, Int -> Scheduler -> ShowS
[Scheduler] -> ShowS
Scheduler -> String
(Int -> Scheduler -> ShowS)
-> (Scheduler -> String)
-> ([Scheduler] -> ShowS)
-> Show Scheduler
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Scheduler -> ShowS
showsPrec :: Int -> Scheduler -> ShowS
$cshow :: Scheduler -> String
show :: Scheduler -> String
$cshowList :: [Scheduler] -> ShowS
showList :: [Scheduler] -> ShowS
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
defaultScheduler =
  Scheduler
    { schedulerParameters :: Parameters
schedulerParameters = Parameters
defaultParameters
    , schedulerDesiredRetention :: Days
schedulerDesiredRetention = Days
0.9
    , schedulerLearningSteps :: [NominalDiffTime]
schedulerLearningSteps = [Integer -> NominalDiffTime
minutes Integer
1, Integer -> NominalDiffTime
minutes Integer
10]
    , schedulerRelearningSteps :: [NominalDiffTime]
schedulerRelearningSteps = [Integer -> NominalDiffTime
minutes Integer
10]
    , schedulerMinimumInterval :: Days
schedulerMinimumInterval = Days
1
    , schedulerMaximumInterval :: Days
schedulerMaximumInterval = Days
36500
    }
  where
    minutes :: Integer -> NominalDiffTime
    minutes :: Integer -> NominalDiffTime
minutes Integer
n = Integer -> NominalDiffTime
forall a. Num a => Integer -> a
fromInteger (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
60)

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

-- | What happened in a single review.
data ReviewLog = ReviewLog
  { ReviewLog -> Rating
logRating :: !Rating
  , ReviewLog -> UTCTime
logReviewTime :: !UTCTime
  , ReviewLog -> Days
logElapsedDays :: !Days
  -- ^ Days since the previous review; @0@ for a card's first review.
  , ReviewLog -> CardState
logStateBefore :: !CardState
  , ReviewLog -> Maybe MemoryState
logMemoryBefore :: !(Maybe MemoryState)
  , ReviewLog -> MemoryState
logMemoryAfter :: !MemoryState
  , ReviewLog -> NominalDiffTime
logInterval :: !NominalDiffTime
  -- ^ The interval that was scheduled, after any fuzz.
  }
  deriving stock (ReviewLog -> ReviewLog -> Bool
(ReviewLog -> ReviewLog -> Bool)
-> (ReviewLog -> ReviewLog -> Bool) -> Eq ReviewLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ReviewLog -> ReviewLog -> Bool
== :: ReviewLog -> ReviewLog -> Bool
$c/= :: ReviewLog -> ReviewLog -> Bool
/= :: ReviewLog -> ReviewLog -> Bool
Eq, Int -> ReviewLog -> ShowS
[ReviewLog] -> ShowS
ReviewLog -> String
(Int -> ReviewLog -> ShowS)
-> (ReviewLog -> String)
-> ([ReviewLog] -> ShowS)
-> Show ReviewLog
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ReviewLog -> ShowS
showsPrec :: Int -> ReviewLog -> ShowS
$cshow :: ReviewLog -> String
show :: ReviewLog -> String
$cshowList :: [ReviewLog] -> ShowS
showList :: [ReviewLog] -> ShowS
Show)

-- | Review a card. Deterministic: no fuzz is applied.
reviewCard :: Scheduler -> Card -> Rating -> UTCTime -> (Card, ReviewLog)
reviewCard :: Scheduler -> Card -> Rating -> UTCTime -> (Card, ReviewLog)
reviewCard = Maybe Days
-> Scheduler -> Card -> Rating -> UTCTime -> (Card, ReviewLog)
reviewCardWith Maybe Days
forall a. Maybe a
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 :: Days -> Scheduler -> Card -> Rating -> UTCTime -> (Card, ReviewLog)
reviewCardFuzzed = Maybe Days
-> Scheduler -> Card -> Rating -> UTCTime -> (Card, ReviewLog)
reviewCardWith (Maybe Days
 -> Scheduler -> Card -> Rating -> UTCTime -> (Card, ReviewLog))
-> (Days -> Maybe Days)
-> Days
-> Scheduler
-> Card
-> Rating
-> UTCTime
-> (Card, ReviewLog)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Days -> Maybe Days
forall a. a -> Maybe a
Just

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

    memoryAfter :: MemoryState
memoryAfter = Parameters -> Maybe MemoryState -> Days -> Rating -> MemoryState
nextMemoryState (Scheduler -> Parameters
schedulerParameters Scheduler
sched) (Card -> Maybe MemoryState
cardMemory Card
card) Days
elapsed Rating
rating
    (CardState
state', Maybe Int
step', NominalDiffTime
interval) = Maybe Days
-> Scheduler
-> Card
-> Rating
-> MemoryState
-> (CardState, Maybe Int, NominalDiffTime)
schedule Maybe Days
sample Scheduler
sched Card
card Rating
rating MemoryState
memoryAfter

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

    logEntry :: ReviewLog
logEntry =
      ReviewLog
        { logRating :: Rating
logRating = Rating
rating
        , logReviewTime :: UTCTime
logReviewTime = UTCTime
now
        , logElapsedDays :: Days
logElapsedDays = Days
elapsed
        , logStateBefore :: CardState
logStateBefore = Card -> CardState
cardState Card
card
        , logMemoryBefore :: Maybe MemoryState
logMemoryBefore = Card -> Maybe MemoryState
cardMemory Card
card
        , logMemoryAfter :: MemoryState
logMemoryAfter = MemoryState
memoryAfter
        , logInterval :: NominalDiffTime
logInterval = NominalDiffTime
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 :: Maybe Days
-> Scheduler
-> Card
-> Rating
-> MemoryState
-> (CardState, Maybe Int, NominalDiffTime)
schedule Maybe Days
sample Scheduler
sched Card
card Rating
rating MemoryState
memory = case Card -> CardState
cardState Card
card of
  CardState
Learning -> CardState
-> [NominalDiffTime] -> (CardState, Maybe Int, NominalDiffTime)
stepped CardState
Learning (Scheduler -> [NominalDiffTime]
schedulerLearningSteps Scheduler
sched)
  CardState
Relearning -> CardState
-> [NominalDiffTime] -> (CardState, Maybe Int, NominalDiffTime)
stepped CardState
Relearning (Scheduler -> [NominalDiffTime]
schedulerRelearningSteps Scheduler
sched)
  CardState
Review -> case Rating
rating of
    Rating
Again -> case Scheduler -> [NominalDiffTime]
schedulerRelearningSteps Scheduler
sched of
      [] -> (CardState, Maybe Int, NominalDiffTime)
forall {a}. (CardState, Maybe a, NominalDiffTime)
graduate
      (NominalDiffTime
firstStep : [NominalDiffTime]
_) -> (CardState
Relearning, Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0, NominalDiffTime
firstStep)
    Rating
_ -> (CardState, Maybe Int, NominalDiffTime)
forall {a}. (CardState, Maybe a, NominalDiffTime)
graduate
  where
    graduate :: (CardState, Maybe a, NominalDiffTime)
graduate = (CardState
Review, Maybe a
forall a. Maybe a
Nothing, Days -> NominalDiffTime
daysToDiffTime Days
fuzzed)
      where
        plain :: Days
plain = Scheduler -> Days -> Days
nextReviewInterval Scheduler
sched (MemoryState -> Days
memoryStability MemoryState
memory)
        fuzzed :: Days
fuzzed = Days -> (Days -> Days) -> Maybe Days -> Days
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Days
plain (\Days
u -> Scheduler -> Days -> Days -> Days
fuzzInterval Scheduler
sched Days
u Days
plain) Maybe Days
sample

    current :: Int
current = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Card -> Maybe Int
cardStep Card
card))

    stepped :: CardState
-> [NominalDiffTime] -> (CardState, Maybe Int, NominalDiffTime)
stepped CardState
_ [] = (CardState, Maybe Int, NominalDiffTime)
forall {a}. (CardState, Maybe a, NominalDiffTime)
graduate
    stepped CardState
state steps :: [NominalDiffTime]
steps@(NominalDiffTime
firstStep : [NominalDiffTime]
rest)
      -- The card was scheduled by a scheduler with more steps than this one.
      | Int
current Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [NominalDiffTime] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [NominalDiffTime]
steps Bool -> Bool -> Bool
&& Rating
rating Rating -> Rating -> Bool
forall a. Eq a => a -> a -> Bool
/= Rating
Again = (CardState, Maybe Int, NominalDiffTime)
forall {a}. (CardState, Maybe a, NominalDiffTime)
graduate
      | Bool
otherwise = case Rating
rating of
          Rating
Again -> (CardState
state, Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0, NominalDiffTime
firstStep)
          Rating
Hard -> (CardState
state, Int -> Maybe Int
forall a. a -> Maybe a
Just Int
current, NominalDiffTime
hardInterval)
          Rating
Good -> case Int -> Maybe NominalDiffTime
stepAt (Int
current Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) of
            Maybe NominalDiffTime
Nothing -> (CardState, Maybe Int, NominalDiffTime)
forall {a}. (CardState, Maybe a, NominalDiffTime)
graduate
            Just NominalDiffTime
interval -> (CardState
state, Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
current Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1), NominalDiffTime
interval)
          Rating
Easy -> (CardState, Maybe Int, NominalDiffTime)
forall {a}. (CardState, Maybe a, NominalDiffTime)
graduate
      where
        stepAt :: Int -> Maybe NominalDiffTime
stepAt Int
i = case Int -> [NominalDiffTime] -> [NominalDiffTime]
forall a. Int -> [a] -> [a]
drop Int
i [NominalDiffTime]
steps of
          (NominalDiffTime
interval : [NominalDiffTime]
_) -> NominalDiffTime -> Maybe NominalDiffTime
forall a. a -> Maybe a
Just NominalDiffTime
interval
          [] -> Maybe NominalDiffTime
forall a. Maybe a
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 :: NominalDiffTime
hardInterval = case (Int
current, [NominalDiffTime]
rest) of
          (Int
0, []) -> NominalDiffTime
firstStep NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
1.5
          (Int
0, NominalDiffTime
second : [NominalDiffTime]
_) -> (NominalDiffTime
firstStep NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
+ NominalDiffTime
second) NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Fractional a => a -> a -> a
/ NominalDiffTime
2
          -- `current` is in range here: the guard above sent the rest to
          -- `graduate`, so the fallback is unreachable.
          (Int, [NominalDiffTime])
_ -> NominalDiffTime -> Maybe NominalDiffTime -> NominalDiffTime
forall a. a -> Maybe a -> a
fromMaybe NominalDiffTime
firstStep (Int -> Maybe NominalDiffTime
stepAt Int
current)

-- | A card's retrievability at the given time, or 'Nothing' if it has never
-- been reviewed.
cardRetrievability :: Scheduler -> Card -> UTCTime -> Maybe Retrievability
cardRetrievability :: Scheduler -> Card -> UTCTime -> Maybe Days
cardRetrievability Scheduler
sched Card
card UTCTime
now = do
  memory <- Card -> Maybe MemoryState
cardMemory Card
card
  previous <- cardLastReview card
  let elapsed = Days -> Days -> Days
forall a. Ord a => a -> a -> a
max Days
0 (NominalDiffTime -> Days
forall a b. (Real a, Fractional b) => a -> b
realToFrac (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
now UTCTime
previous) Days -> Days -> Days
forall a. Fractional a => a -> a -> a
/ Days
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 :: Scheduler -> Card -> UTCTime -> [(Rating, NominalDiffTime)]
previewIntervals Scheduler
sched Card
card UTCTime
now =
  [ (Rating
rating, ReviewLog -> NominalDiffTime
logInterval ((Card, ReviewLog) -> ReviewLog
forall a b. (a, b) -> b
snd (Scheduler -> Card -> Rating -> UTCTime -> (Card, ReviewLog)
reviewCard Scheduler
sched Card
card Rating
rating UTCTime
now)))
  | Rating
rating <- [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 :: [(Days, Days, Days)]
fuzzRanges =
  [ (Days
2.5, Days
7.0, Days
0.15)
  , (Days
7.0, Days
20.0, Days
0.1)
  , (Days
20.0, Days
1 Days -> Days -> Days
forall a. Fractional a => a -> a -> a
/ Days
0, Days
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 :: Scheduler -> Days -> Maybe (Days, Days)
fuzzBounds Scheduler
sched Days
interval
  | Bool -> Bool
not (Days
interval Days -> Days -> Bool
forall a. Ord a => a -> a -> Bool
>= Days
2.5) = Maybe (Days, Days)
forall a. Maybe a
Nothing
  | Bool
otherwise = (Days, Days) -> Maybe (Days, Days)
forall a. a -> Maybe a
Just (Days -> Days -> Days
forall a. Ord a => a -> a -> a
min Days
low Days
high, Days
high)
  where
    delta :: Days
delta =
      Days
1
        Days -> Days -> Days
forall a. Num a => a -> a -> a
+ [Days] -> Days
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
          [ Days
factor Days -> Days -> Days
forall a. Num a => a -> a -> a
* Days -> Days -> Days
forall a. Ord a => a -> a -> a
max Days
0 (Days -> Days -> Days
forall a. Ord a => a -> a -> a
min Days
interval Days
end Days -> Days -> Days
forall a. Num a => a -> a -> a
- Days
start)
          | (Days
start, Days
end, Days
factor) <- [(Days, Days, Days)]
fuzzRanges
          ]
    low :: Days
low = Days -> Days -> Days
forall a. Ord a => a -> a -> a
max Days
2 (Days
interval Days -> Days -> Days
forall a. Num a => a -> a -> a
- Days
delta)
    high :: Days
high = Days -> Days -> Days
forall a. Ord a => a -> a -> a
min (Scheduler -> Days
schedulerMaximumInterval Scheduler
sched) (Days
interval Days -> Days -> Days
forall a. Num a => a -> a -> a
+ Days
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 :: Scheduler -> Days -> Days -> Days
fuzzInterval Scheduler
sched Days
sample Days
interval = case Scheduler -> Days -> Maybe (Days, Days)
fuzzBounds Scheduler
sched Days
interval of
  Maybe (Days, Days)
Nothing -> Days
interval
  Just (Days
low, Days
high) -> Days
low Days -> Days -> Days
forall a. Num a => a -> a -> a
+ Days -> Days -> Days -> Days
clampTo Days
0 Days
1 Days
sample Days -> Days -> Days
forall a. Num a => a -> a -> a
* (Days
high Days -> Days -> Days
forall a. Num a => a -> a -> a
- Days
low)

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

clampTo :: Double -> Double -> Double -> Double
clampTo :: Days -> Days -> Days -> Days
clampTo Days
lo Days
hi Days
x = Days -> Days -> Days
forall a. Ord a => a -> a -> a
min Days
hi (Days -> Days -> Days
forall a. Ord a => a -> a -> a
max Days
lo Days
x)

daysToDiffTime :: Days -> NominalDiffTime
daysToDiffTime :: Days -> NominalDiffTime
daysToDiffTime Days
d = Days -> NominalDiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Days
d Days -> Days -> Days
forall a. Num a => a -> a -> a
* Days
86400)