1 module Stimulus = struct 2 type extension = Forced_reps | Negatives | Rest_pause | Static_hold 3 4 type outcome = 5 | Positive_failure 6 | Beyond_failure of extension * extension list 7 8 let extensions_of_outcome = function 9 | Positive_failure -> [] 10 | Beyond_failure (first, rest) -> first :: rest 11 12 let pp_extension ppf e = 13 Format.pp_print_string ppf 14 (match e with 15 | Forced_reps -> "forced reps" 16 | Negatives -> "negatives" 17 | Rest_pause -> "rest-pause" 18 | Static_hold -> "static hold") 19 20 module Effort = struct 21 type t = { 22 exercise : Exercise.t; 23 load : float; 24 reps : int; 25 outcome : outcome; 26 } 27 28 let make ~exercise ~load ~reps ~outcome = { exercise; load; reps; outcome } 29 let exercise t = t.exercise 30 let load t = t.load 31 let reps t = t.reps 32 let outcome t = t.outcome 33 let extensions t = extensions_of_outcome t.outcome 34 35 let pp ppf t = 36 Format.fprintf ppf "%a %g kg x %d" Exercise.pp t.exercise t.load t.reps; 37 match extensions t with 38 | [] -> () 39 | es -> 40 Format.fprintf ppf " (%a)" 41 (Format.pp_print_list 42 ~pp_sep:(fun ppf () -> Format.pp_print_string ppf ", ") 43 pp_extension) 44 es 45 end 46 47 type delivery = 48 | Single of Effort.t 49 | Pair of { first : Effort.t; second : Effort.t } 50 51 type t = { delivery : delivery } 52 53 let make delivery = { delivery } 54 let delivery t = t.delivery 55 56 let efforts t = 57 match t.delivery with 58 | Single effort -> [ effort ] 59 | Pair { first; second } -> [ first; second ] 60 61 let exercises t = List.map Effort.exercise (efforts t) 62 let extensions t = List.concat_map Effort.extensions (efforts t) 63 let is_extended t = extensions t <> [] 64 65 let pp ppf t = 66 match t.delivery with 67 | Single effort -> Effort.pp ppf effort 68 | Pair { first; second } -> 69 Format.fprintf ppf "%a then %a" Effort.pp first Effort.pp second 70 end 71 72 module Feedback = struct 73 type level = Very_poor | Poor | Fair | Good | Very_good 74 75 let level_to_score = function 76 | Very_poor -> 1 77 | Poor -> 2 78 | Fair -> 3 79 | Good -> 4 80 | Very_good -> 5 81 82 let level_of_score = function 83 | 1 -> Some Very_poor 84 | 2 -> Some Poor 85 | 3 -> Some Fair 86 | 4 -> Some Good 87 | 5 -> Some Very_good 88 | _ -> None 89 90 type signal = 91 | Sleep of level 92 | Appetite of level 93 | Readiness of level 94 | Motivation of level 95 | Difficulty of level 96 | Pain 97 | Injury 98 | Preparation_insufficient 99 100 type t = { reported_at : Recovery.timestamp; signals : signal list } 101 type error = Duplicate_signal of signal 102 103 exception Invalid of error 104 105 let same_category left right = 106 match (left, right) with 107 | Sleep _, Sleep _ 108 | Appetite _, Appetite _ 109 | Readiness _, Readiness _ 110 | Motivation _, Motivation _ 111 | Difficulty _, Difficulty _ 112 | Pain, Pain 113 | Injury, Injury 114 | Preparation_insufficient, Preparation_insufficient -> 115 true 116 | _ -> false 117 118 let make ~reported_at signals = 119 let rec validate seen = function 120 | [] -> { reported_at; signals } 121 | signal :: rest -> 122 if List.exists (same_category signal) seen then 123 raise (Invalid (Duplicate_signal signal)) 124 else validate (signal :: seen) rest 125 in 126 validate [] signals 127 128 let reported_at t = t.reported_at 129 let signals t = t.signals 130 end 131 132 module Workout = struct 133 type shape = As_single | As_pair 134 type completeness = Complete | Incomplete 135 136 type error = 137 | Not_prescribed of Exercise.id 138 | Delivery_mismatch of { 139 exercise : Exercise.id; 140 prescribed : shape; 141 logged : shape; 142 } 143 | No_such_slot of int 144 145 exception Invalid of error 146 147 type t = { 148 prescription : Prescription.Workout.t; 149 clearance : Recovery.clearance; 150 started_at : Recovery.timestamp; 151 ended_at : Recovery.timestamp option; 152 performed : (int * Stimulus.t) list; 153 } 154 155 let pp_shape ppf = function 156 | As_single -> Format.pp_print_string ppf "a single set" 157 | As_pair -> Format.pp_print_string ppf "a pair" 158 159 let pp_error ppf = function 160 | Not_prescribed id -> 161 Format.fprintf ppf "%s is not prescribed for this workout" 162 (id :> string) 163 | Delivery_mismatch { exercise; prescribed; logged } -> 164 Format.fprintf ppf "%s is prescribed as %a but was logged as %a" 165 (exercise :> string) 166 pp_shape prescribed pp_shape logged 167 | No_such_slot slot -> 168 Format.fprintf ppf "slot %d is not part of this workout" slot 169 170 let start prescription ~clearance ~started_at = 171 { prescription; clearance; started_at; ended_at = None; performed = [] } 172 173 let prescription t = t.prescription 174 let clearance t = t.clearance 175 let started_at t = t.started_at 176 let ended_at t = t.ended_at 177 let is_finished t = Option.is_some t.ended_at 178 let stimuli t = List.map snd (List.rev t.performed) 179 let performed t = List.rev t.performed 180 181 let duration t = 182 Option.map 183 (fun ended -> Recovery.elapsed ~since:t.started_at ~now:ended) 184 t.ended_at 185 186 let prescribed_shape p = 187 match Prescription.Stimulus.delivery p with 188 | Prescription.Stimulus.Single _ -> As_single 189 | Prescription.Stimulus.Pre_exhaust _ -> As_pair 190 191 let logged_shape s = 192 match Stimulus.delivery s with 193 | Stimulus.Single _ -> As_single 194 | Stimulus.Pair _ -> As_pair 195 196 let fills ~prescribed ~logged p = 197 Exercise.equal prescribed logged 198 || List.exists (Exercise.equal logged) 199 (Prescription.Stimulus.allowed_substitutes p) 200 && Exercise.may_substitute ~original:prescribed ~candidate:logged 201 202 let mentions p s = 203 List.for_all 204 (fun e -> Prescription.Stimulus.permits p e) 205 (Stimulus.exercises s) 206 207 let conforms p s = 208 let logged = Stimulus.exercises s in 209 let prescribed = Prescription.Stimulus.exercises p in 210 List.length logged = List.length prescribed 211 && List.for_all2 212 (fun prescribed logged -> fills ~prescribed ~logged p) 213 prescribed logged 214 215 let indexed t = 216 List.mapi (fun i p -> (i, p)) (Prescription.Workout.stimuli t.prescription) 217 218 let answered t = List.map fst t.performed 219 220 let outstanding t = 221 indexed t |> List.filter (fun (i, _) -> not (List.mem i (answered t))) 222 223 let unperformed t = List.map snd (outstanding t) 224 let completeness t = if outstanding t = [] then Complete else Incomplete 225 226 (* Distinct answered slots, so recorded extra volume never inflates the 227 count past the prescription length. *) 228 let filled_slots t = List.length (List.sort_uniq Int.compare (answered t)) 229 230 let add_stimulus t s = 231 let candidates = List.filter (fun (_, p) -> mentions p s) (indexed t) in 232 let matching = List.filter (fun (_, p) -> conforms p s) candidates in 233 let leading = Exercise.id (List.hd (Stimulus.exercises s)) in 234 match (candidates, matching) with 235 | [], _ -> raise (Invalid (Not_prescribed leading)) 236 | (_, p) :: _, [] -> 237 raise 238 (Invalid 239 (Delivery_mismatch 240 { 241 exercise = leading; 242 prescribed = prescribed_shape p; 243 logged = logged_shape s; 244 })) 245 | _, matching -> 246 let unanswered = 247 List.filter (fun (i, _) -> not (List.mem i (answered t))) matching 248 in 249 let i, _ = 250 match unanswered with chosen :: _ -> chosen | [] -> List.hd matching 251 in 252 { t with performed = (i, s) :: t.performed } 253 254 (* Validate a stimulus against one named slot, raising as [add_stimulus] 255 does. Shared by the slot-targeted operations. *) 256 let prescription_at t slot = 257 match List.nth_opt (Prescription.Workout.stimuli t.prescription) slot with 258 | Some p -> p 259 | None -> raise (Invalid (No_such_slot slot)) 260 261 let check_against p s = 262 if not (mentions p s) then 263 raise 264 (Invalid (Not_prescribed (Exercise.id (List.hd (Stimulus.exercises s))))) 265 else if not (conforms p s) then 266 raise 267 (Invalid 268 (Delivery_mismatch 269 { 270 exercise = Exercise.id (List.hd (Stimulus.exercises s)); 271 prescribed = prescribed_shape p; 272 logged = logged_shape s; 273 })) 274 275 let record_at t ~slot s = 276 check_against (prescription_at t slot) s; 277 { t with performed = (slot, s) :: t.performed } 278 279 let replace_stimulus t ~slot s = 280 check_against (prescription_at t slot) s; 281 (* A correction targets the slot; it never adds to the recorded volume. 282 Replace the slot's fill in place, keeping its position in performance 283 order. When the slot was empty, record it as its first fill. *) 284 if List.mem_assoc slot t.performed then 285 let replaced = ref false in 286 let performed = 287 List.map 288 (fun (i, existing) -> 289 if i = slot && not !replaced then begin 290 replaced := true; 291 (i, s) 292 end 293 else (i, existing)) 294 t.performed 295 in 296 { t with performed } 297 else { t with performed = (slot, s) :: t.performed } 298 299 let finish t ~ended_at = 300 match t.ended_at with 301 | None -> { t with ended_at = Some ended_at } 302 | Some _ -> t 303 304 let pp ppf t = 305 Format.fprintf ppf "%a (%d of %d)" Prescription.Workout.pp t.prescription 306 (List.length t.performed) 307 (List.length (Prescription.Workout.stimuli t.prescription)) 308 end 309 310 module Log = struct 311 type t = Workout.t list 312 313 type observation = { 314 exercise : Exercise.t; 315 effort : Stimulus.Effort.t; 316 performed_at : Recovery.timestamp; 317 } 318 319 let empty = [] 320 let add t workout = workout :: t 321 322 let started workout = 323 Recovery.timestamp_to_unix_seconds (Workout.started_at workout) 324 325 (* Sorted on read, so workouts need not be added in order. *) 326 let chronological t = 327 List.sort (fun a b -> Int.compare (started a) (started b)) t 328 329 let workouts t = List.rev (chronological t) 330 331 let last_prescription t = 332 match workouts t with 333 | [] -> None 334 | latest :: _ -> Some (Workout.prescription latest) 335 336 let observations_of workout = 337 Workout.stimuli workout 338 |> List.concat_map Stimulus.efforts 339 |> List.map (fun effort -> 340 { 341 exercise = Stimulus.Effort.exercise effort; 342 effort; 343 performed_at = Workout.started_at workout; 344 }) 345 346 let observations t exercise = 347 chronological t 348 |> List.concat_map observations_of 349 |> List.filter (fun o -> Exercise.equal o.exercise exercise) 350 351 let readiness t ~now ~recommended = 352 let finished = 353 chronological t 354 |> List.filter_map (fun w -> Workout.ended_at w) 355 |> List.rev 356 in 357 match finished with 358 | [] -> Recovery.Ready 359 | last :: _ -> 360 Recovery.evaluate_readiness 361 ~elapsed:(Recovery.elapsed ~since:last ~now) 362 ~recommended 363 364 let pp ppf t = Format.fprintf ppf "%d workouts" (List.length t) 365 end 366