1 module Effort = Evidence.Stimulus.Effort 2 3 let beats ~previous ~current = 4 let load = Float.compare (Effort.load current) (Effort.load previous) in 5 let reps = Int.compare (Effort.reps current) (Effort.reps previous) in 6 load > 0 || (load = 0 && reps > 0) 7 8 (* The mirror of [beats]: [current] is strictly worse than [previous] — less 9 load, or equal load and fewer reps. The mark of decompensation. *) 10 let declines ~previous ~current = 11 let load = Float.compare (Effort.load current) (Effort.load previous) in 12 let reps = Int.compare (Effort.reps current) (Effort.reps previous) in 13 load < 0 || (load = 0 && reps < 0) 14 15 type assessment = Progressing | Stalled | Decompensating 16 type error = Insufficient_data 17 18 let pp_assessment ppf = function 19 | Progressing -> Format.pp_print_string ppf "progressing" 20 | Stalled -> Format.pp_print_string ppf "stalled" 21 | Decompensating -> Format.pp_print_string ppf "decompensating" 22 23 let pp_error ppf Insufficient_data = 24 Format.pp_print_string ppf "not enough record to judge" 25 26 let stall_window = Recovery.days 14 27 let rec last = function [] -> None | [ x ] -> Some x | _ :: rest -> last rest 28 29 (* The most recent observation that improved on the one before it. *) 30 let last_advance observations = 31 let rec scan found = function 32 | (previous : Evidence.Observation.t) :: (current :: _ as rest) -> 33 let found = 34 if 35 beats 36 ~previous:(Evidence.Observation.effort previous) 37 ~current:(Evidence.Observation.effort current) 38 then Some current 39 else found 40 in 41 scan found rest 42 | _ -> found 43 in 44 scan None observations 45 46 let elapsed_between (a : Evidence.Observation.t) (b : Evidence.Observation.t) = 47 Recovery.duration_to_seconds 48 (Recovery.elapsed 49 ~since:(Evidence.Observation.performed_at a) 50 ~now:(Evidence.Observation.performed_at b)) 51 52 let assess observations = 53 let window = Recovery.duration_to_seconds stall_window in 54 match (observations, last observations) with 55 | ([] | [ _ ]), _ | _, None -> Error Insufficient_data 56 | first :: _, Some latest -> ( 57 (* After the window passes without progress, separate a halt from a loss. 58 Strength below the reference is decompensation. Strength that holds at 59 the reference is a stall. The reference is the peak reached (the last 60 advance), or the first observation when the record never advanced. *) 61 let effort = Evidence.Observation.effort in 62 let verdict ~reference = 63 if declines ~previous:(effort reference) ~current:(effort latest) then 64 Decompensating 65 else Stalled 66 in 67 match last_advance observations with 68 | Some advance -> 69 if elapsed_between advance latest >= window then 70 Ok (verdict ~reference:advance) 71 else Ok Progressing 72 | None -> 73 (* Never advanced. Only a stall once the record is long enough to say 74 so. Otherwise two sessions a day apart would condemn the routine. *) 75 if elapsed_between first latest >= window then 76 Ok (verdict ~reference:first) 77 else Error Insufficient_data) 78 79 type remedy = 80 | Lay_off_then_reduce of { 81 lay_off : Recovery.duration; 82 drop_stimuli_per_workout : int; 83 extra_rest : Recovery.duration; 84 } 85 86 let remedy = function 87 | Progressing -> None 88 | Stalled | Decompensating -> 89 Some 90 (Lay_off_then_reduce 91 { 92 lay_off = Recovery.days 7; 93 drop_stimuli_per_workout = 1; 94 extra_rest = Recovery.days 1; 95 }) 96 97 let pp_remedy ppf 98 (Lay_off_then_reduce { lay_off; drop_stimuli_per_workout; extra_rest }) = 99 Format.fprintf ppf 100 "take %a off, then drop %d stimulus per workout and add %a between workouts" 101 Recovery.pp_duration lay_off drop_stimuli_per_workout Recovery.pp_duration 102 extra_rest 103 104 let load_increase_trigger = 12 105 let load_increase ~current = (current *. 1.10, current *. 1.20) 106 107 type load_verdict = Hold | Increase of float * float | Too_heavy 108 109 (* The trigger is absolute. The window ceiling never gates the verdict. Only 110 the window floor does. *) 111 let judge_load ~rep_range effort = 112 let reps = Effort.reps effort in 113 let min_reps, _ = Prescription.Rep_range.bounds rep_range in 114 if reps >= load_increase_trigger then 115 let low, high = load_increase ~current:(Effort.load effort) in 116 Increase (low, high) 117 else if reps < min_reps then Too_heavy 118 else Hold 119 120 let pp_load_verdict ppf = function 121 | Hold -> Format.pp_print_string ppf "hold the load" 122 | Increase (low, high) -> 123 Format.fprintf ppf "raise the load to %g-%g kg" low high 124 | Too_heavy -> Format.pp_print_string ppf "load is too heavy for the window" 125 126 type diagnostic = 127 | Excess_volume of int 128 | Extensions_on_every_stimulus of int 129 | Trained_under_recovered of int 130 131 let excess_volume workout = 132 List.length (Evidence.Workout.stimuli workout) 133 > Evidence.Workout.filled_slots workout 134 135 let all_extended workout = 136 match Evidence.Workout.stimuli workout with 137 | [] -> false 138 | stimuli -> List.for_all Evidence.Stimulus.is_extended stimuli 139 140 let under_recovered workout = 141 match Recovery.basis (Evidence.Workout.clearance workout) with 142 | Recovery.Recovered -> false 143 | Recovery.Overridden _ -> true 144 145 let diagnose log = 146 let workouts = Evidence.Log.workouts log in 147 let count predicate = List.length (List.filter predicate workouts) in 148 let excessive = count excess_volume in 149 let extended = count all_extended in 150 let overridden = count under_recovered in 151 let when_present n d = if n > 0 then [ d n ] else [] in 152 when_present excessive (fun n -> Excess_volume n) 153 @ when_present extended (fun n -> Extensions_on_every_stimulus n) 154 @ when_present overridden (fun n -> Trained_under_recovered n) 155 156 let pp_diagnostic ppf = function 157 | Excess_volume n -> 158 Format.fprintf ppf "%d workout(s) recorded more stimuli than prescribed" n 159 | Extensions_on_every_stimulus n -> 160 Format.fprintf ppf "%d workout(s) extended every stimulus beyond failure" 161 n 162 | Trained_under_recovered n -> 163 Format.fprintf ppf "%d workout(s) begun before recovery was complete" n 164 165 type workout_comparison = { 166 exercise : Exercise.t; 167 previous : Evidence.Stimulus.Effort.t; 168 current : Evidence.Stimulus.Effort.t; 169 } 170 171 (* The latest observation strictly before [at]. This prevents a correction from 172 comparing an exercise against itself when the recorded observation shares its 173 workout's start time. Callers scope the observation series by exercise before 174 they call this helper. *) 175 let latest_before ~at observations = 176 observations 177 |> List.filter (fun (observation : Evidence.Observation.t) -> 178 Recovery.duration_to_seconds 179 (Recovery.elapsed 180 ~since:(Evidence.Observation.performed_at observation) 181 ~now:at) 182 > 0) 183 |> List.sort (fun a b -> 184 Int.compare 185 (Recovery.timestamp_to_unix_seconds 186 (Evidence.Observation.performed_at a)) 187 (Recovery.timestamp_to_unix_seconds 188 (Evidence.Observation.performed_at b))) 189 |> last 190 191 (* The latest observation strictly before the workout started. This prevents a 192 correction of the saved workout from comparing an exercise against itself. *) 193 let previous_effort log ~started exercise = 194 Evidence.Log.observations log exercise 195 |> latest_before ~at:started 196 |> Option.map Evidence.Observation.effort 197 198 let workout_comparisons log workout = 199 let started = Evidence.Workout.started_at workout in 200 Evidence.Workout.stimuli workout 201 |> List.concat_map Evidence.Stimulus.efforts 202 |> List.fold_left 203 (fun (seen, comparisons) current -> 204 let exercise = Evidence.Stimulus.Effort.exercise current in 205 if List.exists (Exercise.equal exercise) seen then (seen, comparisons) 206 else 207 let comparison = 208 Option.map 209 (fun previous -> { exercise; previous; current }) 210 (previous_effort log ~started exercise) 211 in 212 (exercise :: seen, Option.to_list comparison @ comparisons)) 213 ([], []) 214 |> snd |> List.rev 215 216 let workout_changes log workout = 217 workout_comparisons log workout 218 |> List.filter (fun comparison -> 219 beats ~previous:comparison.previous ~current:comparison.current) 220 221 (* How many distinct exercises in [workout] beat their most recent earlier 222 observation in [log]. Progress is the Heavy Duty signal: an increase in reps 223 or load. This module judges it, so a caller receives a count and never 224 re-derives the rule. An exercise with no earlier observation does not 225 count. *) 226 let workout_progress log workout = List.length (workout_changes log workout) 227 228 (* The most recent observation of [target]'s exercise strictly before [target] 229 was performed, taken from [observations] (any order). This applies the same 230 baseline rule as [previous_effort], but over a bare observation series rather 231 than a log. Imported evidence is not a native workout. A caller can still 232 compare it against the observations before it. *) 233 let previous_observation observations (target : Evidence.Observation.t) = 234 let exercise = Evidence.Observation.exercise target in 235 let performed = Evidence.Observation.performed_at target in 236 observations 237 |> List.filter (fun (o : Evidence.Observation.t) -> 238 Exercise.equal (Evidence.Observation.exercise o) exercise) 239 |> latest_before ~at:performed 240