1 (** See {!module:Workout_import} for the contract and the invariant this module 2 upholds on behalf of the core. *) 3 4 type batch_id = string 5 type workout_id = string 6 7 let batch_id s = s 8 let workout_id s = s 9 let batch_id_to_string s = s 10 let workout_id_to_string s = s 11 12 type source_set_type = Normal | Failure | Dropset 13 14 type source_set = { 15 row : int; 16 exercise_name : string; 17 set_index : int; 18 set_type : source_set_type; 19 weight_kg : float; 20 reps : int; 21 superset_id : int option; 22 } 23 24 type warning_kind = Warmup_dropped | Unsupported_row of string 25 type warning = { row : int; exercise_name : string option; kind : warning_kind } 26 27 type error = 28 | Unknown_workout of workout_id 29 | Empty_acknowledgement 30 | Invalid_time 31 32 (* A mapping is confirmed per source exercise name and applies to every matching 33 set. The acknowledgement is the one workout-level confirmation that promotes 34 the workout's [Normal] sets. The revision advances whenever either changes, 35 so a stored promotion made against an earlier revision is stale. *) 36 type workout = { 37 id : workout_id; 38 title : string; 39 started_at : Recovery.timestamp; 40 ended_at : Recovery.timestamp; 41 sets : source_set list; 42 mappings : (string * Exercise.t) list; 43 acknowledgement : string option; 44 revision : int; 45 } 46 47 type batch = { 48 batch_identity : batch_id; 49 source : string; 50 fingerprint : string; 51 imported_at : Recovery.timestamp; 52 workouts : workout list; 53 warnings : warning list; 54 promotions : (workout_id * promoted) list; 55 } 56 57 and provenance = { 58 batch_id : batch_id; 59 workout_id : workout_id; 60 source_rows : int list; 61 normal_confirmation : string option; 62 revision : int; 63 } 64 65 and promoted = { 66 title : string; 67 started_at : Recovery.timestamp; 68 ended_at : Recovery.timestamp; 69 observations : Evidence.Observation.t list; 70 provenance : provenance; 71 } 72 73 let make_workout ~id ~title ~started_at ~ended_at ~sets = 74 if 75 Recovery.timestamp_to_unix_seconds ended_at 76 < Recovery.timestamp_to_unix_seconds started_at 77 then Error Invalid_time 78 else 79 Ok 80 { 81 id; 82 title; 83 started_at; 84 ended_at; 85 sets; 86 mappings = []; 87 acknowledgement = None; 88 revision = 0; 89 } 90 91 let make_batch ~id ~source ~fingerprint ~imported_at ~workouts ~warnings = 92 { 93 batch_identity = id; 94 source; 95 fingerprint; 96 imported_at; 97 workouts; 98 warnings; 99 promotions = []; 100 } 101 102 (* {1 Accessors} *) 103 104 let batch_identity b = b.batch_identity 105 let batch_source b = b.source 106 let batch_fingerprint b = b.fingerprint 107 let batch_imported_at b = b.imported_at 108 let batch_workouts b = b.workouts 109 let batch_warnings b = b.warnings 110 let find_workout b id = List.find_opt (fun w -> String.equal w.id id) b.workouts 111 let workout_identity (w : workout) = w.id 112 let workout_title (w : workout) = w.title 113 let workout_started_at (w : workout) = w.started_at 114 let workout_ended_at (w : workout) = w.ended_at 115 let workout_sets (w : workout) = w.sets 116 let workout_revision (w : workout) = w.revision 117 let workout_acknowledgement (w : workout) = w.acknowledgement 118 119 let workout_mapping (w : workout) ~source_name = 120 List.assoc_opt source_name w.mappings 121 122 (* Replaces the workout that shares [w]'s id, leaving every other workout and 123 the batch's own fields untouched. *) 124 let replace_workout b w = 125 { 126 b with 127 workouts = 128 List.map (fun x -> if String.equal x.id w.id then w else x) b.workouts; 129 } 130 131 (* {1 Cleaning} *) 132 133 let map_exercise b ~workout ~source_name exercise = 134 match find_workout b workout with 135 | None -> Error (Unknown_workout workout) 136 | Some w -> 137 let changed = 138 match List.assoc_opt source_name w.mappings with 139 | Some current -> not (Exercise.equal current exercise) 140 | None -> true 141 in 142 if not changed then Ok b 143 else 144 let mappings = 145 (source_name, exercise) :: List.remove_assoc source_name w.mappings 146 in 147 let w = { w with mappings; revision = w.revision + 1 } in 148 Ok (replace_workout b w) 149 150 let confirm_normal_sets b ~workout ~acknowledgement = 151 match find_workout b workout with 152 | None -> Error (Unknown_workout workout) 153 | Some w -> 154 if String.equal (String.trim acknowledgement) "" then 155 Error Empty_acknowledgement 156 else 157 let changed = 158 match w.acknowledgement with 159 | Some current -> not (String.equal current acknowledgement) 160 | None -> true 161 in 162 if not changed then Ok b 163 else 164 let w = 165 { 166 w with 167 acknowledgement = Some acknowledgement; 168 revision = w.revision + 1; 169 } 170 in 171 Ok (replace_workout b w) 172 173 (* {1 Blockers} *) 174 175 type blocker = No_sets | Unmapped_exercise of string | Normal_sets_unconfirmed 176 177 (* Distinct source exercise names in first-appearance order. *) 178 let distinct_names (sets : source_set list) = 179 List.fold_left 180 (fun acc (s : source_set) -> 181 if List.mem s.exercise_name acc then acc else acc @ [ s.exercise_name ]) 182 [] sets 183 184 (* The sets that promote to canonical evidence. A drop set is not one clean 185 drive to failure — HD1 knows only forced reps, negatives, and a static hold 186 past failure, never a strip set — so a [Dropset] row is non-evidence, dropped 187 the way a warmup is. What remains is the set taken to failure, which is what 188 the doctrine counts. Every downstream decision — blockers, observations, 189 provenance — reads this, so a drop set neither blocks a workout nor records 190 an observation. *) 191 let promotable_sets w = 192 List.filter (fun (s : source_set) -> s.set_type <> Dropset) w.sets 193 194 let blockers w = 195 let sets = promotable_sets w in 196 if sets = [] then [ No_sets ] 197 else 198 let unmapped = 199 distinct_names sets 200 |> List.filter (fun name -> not (List.mem_assoc name w.mappings)) 201 |> List.map (fun name -> Unmapped_exercise name) 202 in 203 let normal_blocker = 204 if 205 List.exists (fun (s : source_set) -> s.set_type = Normal) sets 206 && w.acknowledgement = None 207 then [ Normal_sets_unconfirmed ] 208 else [] 209 in 210 unmapped @ normal_blocker 211 212 (* {1 Promotion} *) 213 214 type workout_result = 215 | Promoted of promoted 216 | Already_promoted of promoted 217 | Blocked of blocker list 218 219 type batch_result = { 220 promoted : (workout_id * promoted) list; 221 already_promoted : (workout_id * promoted) list; 222 blocked : (workout_id * blocker list) list; 223 } 224 225 (* Every promoted set becomes one canonical observation, taken to failure and 226 performed at the workout's end. The export's set type gated whether the 227 workout could promote; it never colours the recorded outcome. The mapping is 228 present for every set, guaranteed by [blockers] returning empty. *) 229 let observe w (s : source_set) = 230 let exercise = 231 match List.assoc_opt s.exercise_name w.mappings with 232 | Some e -> e 233 | None -> 234 (* Unreachable: promotion only runs with no blockers, so every set is 235 mapped. *) 236 assert false 237 in 238 let effort = 239 match 240 Evidence.Stimulus.Effort.make ~exercise ~load:s.weight_kg ~reps:s.reps 241 ~outcome:Evidence.Stimulus.Positive_failure 242 with 243 | Ok effort -> effort 244 | Error _ -> 245 (* Unreachable: the adapter admits only a finite nonnegative load and at 246 least one rep, the same rule [Effort.make] enforces. *) 247 assert false 248 in 249 Evidence.Observation.make ~exercise ~effort ~performed_at:w.ended_at 250 251 let promote_of_workout b (w : workout) = 252 let sets = promotable_sets w in 253 { 254 title = w.title; 255 started_at = w.started_at; 256 ended_at = w.ended_at; 257 observations = List.map (observe w) sets; 258 provenance = 259 { 260 batch_id = b.batch_identity; 261 workout_id = w.id; 262 source_rows = List.map (fun (s : source_set) -> s.row) sets; 263 normal_confirmation = 264 (if List.exists (fun (s : source_set) -> s.set_type = Normal) sets 265 then w.acknowledgement 266 else None); 267 revision = w.revision; 268 }; 269 } 270 271 let store_promotion b workout_id promoted = 272 { 273 b with 274 promotions = 275 (workout_id, promoted) :: List.remove_assoc workout_id b.promotions; 276 } 277 278 (* Promotes one workout against its current state, returning the result and the 279 batch with any stored promotion refreshed. A blocked workout leaves the batch 280 untouched. *) 281 let promote_workout_internal b w = 282 match blockers w with 283 | _ :: _ as bs -> (b, Blocked bs) 284 | [] -> ( 285 match List.assoc_opt w.id b.promotions with 286 | Some prior when prior.provenance.revision = w.revision -> 287 (b, Already_promoted prior) 288 | _ -> 289 let promoted = promote_of_workout b w in 290 (store_promotion b w.id promoted, Promoted promoted)) 291 292 let promote_workout b workout = 293 match find_workout b workout with 294 | None -> Error (Unknown_workout workout) 295 | Some w -> Ok (promote_workout_internal b w) 296 297 let promote_batch b = 298 let b, promoted_rev, already_rev, blocked_rev = 299 List.fold_left 300 (fun (b, promoted, already, blocked) w -> 301 let b, result = promote_workout_internal b w in 302 match result with 303 | Promoted p -> (b, (w.id, p) :: promoted, already, blocked) 304 | Already_promoted p -> (b, promoted, (w.id, p) :: already, blocked) 305 | Blocked bs -> (b, promoted, already, (w.id, bs) :: blocked)) 306 (b, [], [], []) b.workouts 307 in 308 ( b, 309 { 310 promoted = List.rev promoted_rev; 311 already_promoted = List.rev already_rev; 312 blocked = List.rev blocked_rev; 313 } ) 314 315 (* {1 Snapshot} *) 316 317 type observation_snapshot = { 318 exercise_id : Exercise.id; 319 load : float; 320 reps : int; 321 performed_at : Recovery.timestamp; 322 } 323 324 type promoted_snapshot = { 325 title : string; 326 started_at : Recovery.timestamp; 327 ended_at : Recovery.timestamp; 328 observations : observation_snapshot list; 329 source_rows : int list; 330 normal_confirmation : string option; 331 revision : int; 332 } 333 334 type workout_snapshot = { 335 id : workout_id; 336 title : string; 337 started_at : Recovery.timestamp; 338 ended_at : Recovery.timestamp; 339 sets : source_set list; 340 mappings : (string * Exercise.id) list; 341 acknowledgement : string option; 342 revision : int; 343 promotion : promoted_snapshot option; 344 } 345 346 type snapshot = { 347 batch_id : batch_id; 348 source : string; 349 fingerprint : string; 350 imported_at : Recovery.timestamp; 351 workouts : workout_snapshot list; 352 warnings : warning list; 353 } 354 355 type restore_error = 356 | Unknown_exercise of string 357 | Invalid_time 358 | Invalid_effort of Evidence.Stimulus.Effort.error 359 (** A stored observation the core refuses: a nonsensical load or rep 360 count. The snapshot is corrupt, not merely stale. *) 361 362 (* A promoted observation is always a single failure effort, so its snapshot 363 drops the delivery and the outcome. *) 364 let observation_snapshot obs = 365 let effort = Evidence.Observation.effort obs in 366 { 367 exercise_id = Exercise.id (Evidence.Stimulus.Effort.exercise effort); 368 load = Evidence.Stimulus.Effort.load effort; 369 reps = Evidence.Stimulus.Effort.reps effort; 370 performed_at = Evidence.Observation.performed_at obs; 371 } 372 373 let promoted_snapshot (p : promoted) = 374 { 375 title = p.title; 376 started_at = p.started_at; 377 ended_at = p.ended_at; 378 observations = List.map observation_snapshot p.observations; 379 source_rows = p.provenance.source_rows; 380 normal_confirmation = p.provenance.normal_confirmation; 381 revision = p.provenance.revision; 382 } 383 384 let workout_snapshot b (w : workout) = 385 { 386 id = w.id; 387 title = w.title; 388 started_at = w.started_at; 389 ended_at = w.ended_at; 390 sets = w.sets; 391 mappings = List.map (fun (name, e) -> (name, Exercise.id e)) w.mappings; 392 acknowledgement = w.acknowledgement; 393 revision = w.revision; 394 promotion = Option.map promoted_snapshot (List.assoc_opt w.id b.promotions); 395 } 396 397 let snapshot b = 398 { 399 batch_id = b.batch_identity; 400 source = b.source; 401 fingerprint = b.fingerprint; 402 imported_at = b.imported_at; 403 workouts = List.map (workout_snapshot b) b.workouts; 404 warnings = b.warnings; 405 } 406 407 let ( let* ) = Result.bind 408 409 (* Resolve an exercise id, reporting the raw id string when the catalog no 410 longer names it. *) 411 let resolve find_exercise (id : Exercise.id) = 412 match find_exercise id with 413 | Some e -> Ok e 414 | None -> Error (Unknown_exercise (id :> string)) 415 416 let restore_mappings find_exercise mappings = 417 let rec go acc = function 418 | [] -> Ok (List.rev acc) 419 | (name, id) :: tl -> 420 let* e = resolve find_exercise id in 421 go ((name, e) :: acc) tl 422 in 423 go [] mappings 424 425 (* Rebuild a promotion from its snapshot. Each observation is reconstructed as a 426 single failure effort, exactly as promotion first minted it. *) 427 let restore_promotion find_exercise batch_id workout_id (p : promoted_snapshot) 428 = 429 let restore_observation (o : observation_snapshot) = 430 let* exercise = resolve find_exercise o.exercise_id in 431 let* effort = 432 Result.map_error 433 (fun e -> Invalid_effort e) 434 (Evidence.Stimulus.Effort.make ~exercise ~load:o.load ~reps:o.reps 435 ~outcome:Evidence.Stimulus.Positive_failure) 436 in 437 Ok 438 (Evidence.Observation.make ~exercise ~effort ~performed_at:o.performed_at) 439 in 440 let rec go acc = function 441 | [] -> Ok (List.rev acc) 442 | o :: tl -> 443 let* obs = restore_observation o in 444 go (obs :: acc) tl 445 in 446 let* observations = go [] p.observations in 447 Ok 448 { 449 title = p.title; 450 started_at = p.started_at; 451 ended_at = p.ended_at; 452 observations; 453 provenance = 454 { 455 batch_id; 456 workout_id; 457 source_rows = p.source_rows; 458 normal_confirmation = p.normal_confirmation; 459 revision = p.revision; 460 }; 461 } 462 463 let restore_workout find_exercise batch_id (ws : workout_snapshot) = 464 if 465 Recovery.timestamp_to_unix_seconds ws.ended_at 466 < Recovery.timestamp_to_unix_seconds ws.started_at 467 then Error Invalid_time 468 else 469 let* mappings = restore_mappings find_exercise ws.mappings in 470 let* promotion = 471 match ws.promotion with 472 | None -> Ok None 473 | Some p -> 474 let* p = restore_promotion find_exercise batch_id ws.id p in 475 Ok (Some p) 476 in 477 let w = 478 { 479 id = ws.id; 480 title = ws.title; 481 started_at = ws.started_at; 482 ended_at = ws.ended_at; 483 sets = ws.sets; 484 mappings; 485 acknowledgement = ws.acknowledgement; 486 revision = ws.revision; 487 } 488 in 489 Ok (w, Option.map (fun p -> (ws.id, p)) promotion) 490 491 let restore ~find_exercise (s : snapshot) = 492 let rec go workouts promotions = function 493 | [] -> Ok (List.rev workouts, List.rev promotions) 494 | ws :: tl -> 495 let* w, promo = restore_workout find_exercise s.batch_id ws in 496 let promotions = 497 match promo with Some p -> p :: promotions | None -> promotions 498 in 499 go (w :: workouts) promotions tl 500 in 501 let* workouts, promotions = go [] [] s.workouts in 502 Ok 503 { 504 batch_identity = s.batch_id; 505 source = s.source; 506 fingerprint = s.fingerprint; 507 imported_at = s.imported_at; 508 workouts; 509 warnings = s.warnings; 510 promotions; 511 } 512