[OCaml] High Intensity Training Online
feat implement Stimulus, the unit of work
A stimulus is a single drive to muscular failure. It replaces the former Set and Set_group entirely: HD1 prescribes one set per exercise, so there is no set count to record, and how the drive was delivered is a property of the stimulus rather than a container wrapping sets. Reaching failure is an invariant, not data. A movement recorded here went to failure by construction, which is what separates a stimulus from mere exercise; what varies is load, the reps it happened to yield, and whether anything carried the effort past failure. Beyond_failure is `extension * extension list` rather than a list, so "beyond failure by no means at all" cannot be written, and extensions stack in the order applied — HD1 puts negatives after forced reps. A mislabelled Pre_exhaust is refused. This does not compromise the record: two unrelated movements are honestly two Single stimuli, so nothing becomes unrepresentable. That is the opposite case to extension rarity, which stays a diagnostic precisely because there the log has no alternative shape to fall back on. Warm-ups sit alongside a stimulus and carry no outcome, so a warm-up cannot reach failure by type. 72 Alcotests.
Changed files
lib/core/dune
@@ -12,5 +12,6 @@
12
12
recovery
13
13
prescription
14
14
workout_prescription
15
Removed:
routine)
15
Added:
routine
16
Added:
stimulus)
16
17
(wrapped false))
lib/core/stimulus.ml
@@ -0,0 +1,102 @@
1
Added:
type extension = Forced_reps | Negatives | Rest_pause | Static_hold
2
Added:
type outcome = Positive_failure | Beyond_failure of extension * extension list
3
Added:
4
Added:
let extensions_of_outcome = function
5
Added:
| Positive_failure -> []
6
Added:
| Beyond_failure (first, rest) -> first :: rest
7
Added:
8
Added:
let pp_extension ppf e =
9
Added:
Format.pp_print_string ppf
10
Added:
(match e with
11
Added:
| Forced_reps -> "forced reps"
12
Added:
| Negatives -> "negatives"
13
Added:
| Rest_pause -> "rest-pause"
14
Added:
| Static_hold -> "static hold")
15
Added:
16
Added:
module Warm_up = struct
17
Added:
type t = { exercise : Exercise.t; load : Units.Weight.t; reps : Units.Reps.t }
18
Added:
19
Added:
let make ~exercise ~load ~reps = { exercise; load; reps }
20
Added:
let exercise t = t.exercise
21
Added:
let load t = t.load
22
Added:
let reps t = t.reps
23
Added:
24
Added:
let pp ppf t =
25
Added:
Format.fprintf ppf "%a %a x %a" Exercise.pp t.exercise Units.Weight.pp
26
Added:
t.load Units.Reps.pp t.reps
27
Added:
end
28
Added:
29
Added:
module Movement = struct
30
Added:
type t = {
31
Added:
exercise : Exercise.t;
32
Added:
load : Units.Weight.t;
33
Added:
reps : Units.Reps.t;
34
Added:
outcome : outcome;
35
Added:
}
36
Added:
37
Added:
let make ~exercise ~load ~reps ~outcome = { exercise; load; reps; outcome }
38
Added:
let exercise t = t.exercise
39
Added:
let load t = t.load
40
Added:
let reps t = t.reps
41
Added:
let outcome t = t.outcome
42
Added:
let extensions t = extensions_of_outcome t.outcome
43
Added:
44
Added:
let pp ppf t =
45
Added:
Format.fprintf ppf "%a %a x %a" Exercise.pp t.exercise Units.Weight.pp
46
Added:
t.load Units.Reps.pp t.reps;
47
Added:
match extensions t with
48
Added:
| [] -> ()
49
Added:
| es ->
50
Added:
Format.fprintf ppf " (%a)"
51
Added:
(Format.pp_print_list
52
Added:
~pp_sep:(fun ppf () -> Format.pp_print_string ppf ", ")
53
Added:
pp_extension)
54
Added:
es
55
Added:
end
56
Added:
57
Added:
type delivery =
58
Added:
| Single of Movement.t
59
Added:
| Pre_exhaust of { isolation : Movement.t; compound : Movement.t }
60
Added:
61
Added:
type t = { delivery : delivery; warm_ups : Warm_up.t list }
62
Added:
63
Added:
type error =
64
Added:
| Not_a_pre_exhaust of { isolation : Exercise.id; compound : Exercise.id }
65
Added:
66
Added:
let pp_error ppf (Not_a_pre_exhaust { isolation; compound }) =
67
Added:
Format.fprintf ppf "%s cannot pre-exhaust for %s"
68
Added:
(isolation :> string)
69
Added:
(compound :> string)
70
Added:
71
Added:
let make ?(warm_ups = []) delivery =
72
Added:
match delivery with
73
Added:
| Pre_exhaust { isolation; compound }
74
Added:
when not
75
Added:
(Exercise.may_pre_exhaust
76
Added:
~isolation:(Movement.exercise isolation)
77
Added:
~compound:(Movement.exercise compound)) ->
78
Added:
Error
79
Added:
(Not_a_pre_exhaust
80
Added:
{
81
Added:
isolation = Exercise.id (Movement.exercise isolation);
82
Added:
compound = Exercise.id (Movement.exercise compound);
83
Added:
})
84
Added:
| _ -> Ok { delivery; warm_ups }
85
Added:
86
Added:
let delivery t = t.delivery
87
Added:
let warm_ups t = t.warm_ups
88
Added:
89
Added:
let movements t =
90
Added:
match t.delivery with
91
Added:
| Single m -> [ m ]
92
Added:
| Pre_exhaust { isolation; compound } -> [ isolation; compound ]
93
Added:
94
Added:
let exercises t = List.map Movement.exercise (movements t)
95
Added:
let extensions t = List.concat_map Movement.extensions (movements t)
96
Added:
let is_extended t = extensions t <> []
97
Added:
98
Added:
let pp ppf t =
99
Added:
match t.delivery with
100
Added:
| Single m -> Movement.pp ppf m
101
Added:
| Pre_exhaust { isolation; compound } ->
102
Added:
Format.fprintf ppf "%a into %a" Movement.pp isolation Movement.pp compound
lib/core/stimulus.mli
@@ -0,0 +1,92 @@
1
Added:
(** One stimulus: a single drive to muscular failure, and the record of what it
2
Added:
took.
3
Added:
4
Added:
This is the unit of work. HD1 prescribes one set per exercise, so there is
5
Added:
no set count to record and no "set group" wrapping anything — how the drive
6
Added:
was delivered is a property of the stimulus itself.
7
Added:
8
Added:
Reaching failure is not recorded because it is not optional: a movement here
9
Added:
always went to failure, which is what distinguishes a stimulus from mere
10
Added:
exercise. What varies is the load, the reps it happened to yield, and
11
Added:
whether anything carried the effort past failure. *)
12
Added:
13
Added:
(** A means of continuing past positive failure. HD1 treats these as occasional:
14
Added:
used on every exercise they lead straight to overtraining, and forced reps
15
Added:
and negatives both need a spotter. *)
16
Added:
type extension = Forced_reps | Negatives | Rest_pause | Static_hold
17
Added:
18
Added:
(** How the drive ended. *)
19
Added:
type outcome =
20
Added:
| Positive_failure (** Unable to complete another rep unaided. *)
21
Added:
| Beyond_failure of extension * extension list
22
Added:
(** In the order applied — HD1 stacks negatives after forced reps. Split
23
Added:
so that "beyond failure by no means at all" cannot be written. *)
24
Added:
25
Added:
val extensions_of_outcome : outcome -> extension list
26
Added:
val pp_extension : Format.formatter -> extension -> unit
27
Added:
28
Added:
(** Preparation for a stimulus: enough to bring blood to the muscles and joints,
29
Added:
no more. Carries no outcome, so a warm-up cannot reach failure. *)
30
Added:
module Warm_up : sig
31
Added:
type t
32
Added:
33
Added:
val make :
34
Added:
exercise:Exercise.t -> load:Units.Weight.t -> reps:Units.Reps.t -> t
35
Added:
36
Added:
val exercise : t -> Exercise.t
37
Added:
val load : t -> Units.Weight.t
38
Added:
val reps : t -> Units.Reps.t
39
Added:
val pp : Format.formatter -> t -> unit
40
Added:
end
41
Added:
42
Added:
(** One movement driven to failure within a stimulus. *)
43
Added:
module Movement : sig
44
Added:
type t
45
Added:
46
Added:
val make :
47
Added:
exercise:Exercise.t ->
48
Added:
load:Units.Weight.t ->
49
Added:
reps:Units.Reps.t ->
50
Added:
outcome:outcome ->
51
Added:
t
52
Added:
53
Added:
val exercise : t -> Exercise.t
54
Added:
val load : t -> Units.Weight.t
55
Added:
val reps : t -> Units.Reps.t
56
Added:
val outcome : t -> outcome
57
Added:
val extensions : t -> extension list
58
Added:
val pp : Format.formatter -> t -> unit
59
Added:
end
60
Added:
61
Added:
(** How the stimulus was delivered — the performed counterpart of
62
Added:
{!Prescription.delivery}. Deliberately a separate type: the two sides carry
63
Added:
different data and must be free to diverge. *)
64
Added:
type delivery =
65
Added:
| Single of Movement.t
66
Added:
| Pre_exhaust of { isolation : Movement.t; compound : Movement.t }
67
Added:
68
Added:
type t
69
Added:
70
Added:
type error =
71
Added:
| Not_a_pre_exhaust of { isolation : Exercise.id; compound : Exercise.id }
72
Added:
73
Added:
val pp_error : Format.formatter -> error -> unit
74
Added:
75
Added:
val make : ?warm_ups:Warm_up.t list -> delivery -> (t, error) result
76
Added:
(** A [Pre_exhaust] must genuinely pre-exhaust; two unrelated movements are two
77
Added:
stimuli, not one. This refuses a mislabelled pairing, not an honest record.
78
Added:
*)
79
Added:
80
Added:
val delivery : t -> delivery
81
Added:
82
Added:
val movements : t -> Movement.t list
83
Added:
(** In performance order; isolation first for a pre-exhaust. *)
84
Added:
85
Added:
val warm_ups : t -> Warm_up.t list
86
Added:
val exercises : t -> Exercise.t list
87
Added:
88
Added:
val extensions : t -> extension list
89
Added:
(** Everything that carried this stimulus past failure, across its movements. *)
90
Added:
91
Added:
val is_extended : t -> bool
92
Added:
val pp : Format.formatter -> t -> unit
test/dune
@@ -11,5 +11,6 @@
11
11
test_prescription
12
12
test_workout_prescription
13
13
test_routine
14
Added:
test_stimulus
14
15
test_recovery)
15
16
(libraries hito.core alcotest))
test/test_hito.ml
@@ -5,4 +5,4 @@
5
5
Alcotest.run "hito"
6
6
(Test_units.suite @ Test_muscle.suite @ Test_exercise.suite
7
7
@ Test_prescription.suite @ Test_workout_prescription.suite
8
Removed:
@ Test_routine.suite @ Test_recovery.suite)
8
Added:
@ Test_routine.suite @ Test_stimulus.suite @ Test_recovery.suite)
test/test_stimulus.ml
@@ -0,0 +1,140 @@
1
Added:
(** Unit tests for {!Stimulus}. *)
2
Added:
3
Added:
let ok = function Ok v -> v | Error _ -> Alcotest.fail "expected Ok"
4
Added:
5
Added:
let get id =
6
Added:
match Exercise.find id with
7
Added:
| Some e -> e
8
Added:
| None -> Alcotest.failf "catalog is missing %S" id
9
Added:
10
Added:
let kg n = ok (Units.Weight.of_kg n)
11
Added:
let reps n = ok (Units.Reps.of_int n)
12
Added:
13
Added:
let move ?(outcome = Stimulus.Positive_failure) id load r =
14
Added:
Stimulus.Movement.make ~exercise:(get id) ~load:(kg load) ~reps:(reps r)
15
Added:
~outcome
16
Added:
17
Added:
let outcome_tests =
18
Added:
[
19
Added:
( "positive failure used no extension",
20
Added:
`Quick,
21
Added:
fun () ->
22
Added:
Alcotest.(check (list string))
23
Added:
"none" []
24
Added:
(List.map
25
Added:
(Format.asprintf "%a" Stimulus.pp_extension)
26
Added:
(Stimulus.extensions_of_outcome Stimulus.Positive_failure)) );
27
Added:
( "extensions stack in the order applied",
28
Added:
`Quick,
29
Added:
fun () ->
30
Added:
let o =
31
Added:
Stimulus.Beyond_failure (Stimulus.Forced_reps, [ Stimulus.Negatives ])
32
Added:
in
33
Added:
Alcotest.(check (list string))
34
Added:
"forced reps then negatives"
35
Added:
[ "forced reps"; "negatives" ]
36
Added:
(List.map
37
Added:
(Format.asprintf "%a" Stimulus.pp_extension)
38
Added:
(Stimulus.extensions_of_outcome o)) );
39
Added:
]
40
Added:
41
Added:
let delivery_tests =
42
Added:
[
43
Added:
( "a single movement is one stimulus",
44
Added:
`Quick,
45
Added:
fun () ->
46
Added:
let s = ok (Stimulus.make (Stimulus.Single (move "curls" 40. 8))) in
47
Added:
Alcotest.(check int)
48
Added:
"one movement" 1
49
Added:
(List.length (Stimulus.movements s));
50
Added:
Alcotest.(check bool) "not extended" false (Stimulus.is_extended s) );
51
Added:
( "a pre-exhaust pair is one stimulus, isolation first",
52
Added:
`Quick,
53
Added:
fun () ->
54
Added:
let s =
55
Added:
ok
56
Added:
(Stimulus.make
57
Added:
(Stimulus.Pre_exhaust
58
Added:
{
59
Added:
isolation = move "dumbbell-flyes" 20. 9;
60
Added:
compound = move "incline-press" 60. 7;
61
Added:
}))
62
Added:
in
63
Added:
Alcotest.(check int)
64
Added:
"two movements" 2
65
Added:
(List.length (Stimulus.movements s));
66
Added:
Alcotest.(check (list string))
67
Added:
"isolation leads"
68
Added:
[ "Dumbbell Flyes"; "Incline Presses" ]
69
Added:
(List.map Exercise.name (Stimulus.exercises s)) );
70
Added:
( "a mislabelled pairing is refused",
71
Added:
`Quick,
72
Added:
fun () ->
73
Added:
match
74
Added:
Stimulus.make
75
Added:
(Stimulus.Pre_exhaust
76
Added:
{
77
Added:
isolation = move "dumbbell-flyes" 20. 9;
78
Added:
compound = move "squats" 100. 8;
79
Added:
})
80
Added:
with
81
Added:
| Error (Stimulus.Not_a_pre_exhaust { isolation; compound }) ->
82
Added:
Alcotest.(check string)
83
Added:
"isolation" "dumbbell-flyes"
84
Added:
(isolation :> string);
85
Added:
Alcotest.(check string) "compound" "squats" (compound :> string)
86
Added:
| Ok _ -> Alcotest.fail "expected Not_a_pre_exhaust" );
87
Added:
( "extensions are gathered across a pre-exhaust's movements",
88
Added:
`Quick,
89
Added:
fun () ->
90
Added:
let s =
91
Added:
ok
92
Added:
(Stimulus.make
93
Added:
(Stimulus.Pre_exhaust
94
Added:
{
95
Added:
isolation = move "lying-french-press" 30. 9;
96
Added:
compound =
97
Added:
move
98
Added:
~outcome:
99
Added:
(Stimulus.Beyond_failure
100
Added:
(Stimulus.Forced_reps, [ Stimulus.Negatives ]))
101
Added:
"dips" 0. 6;
102
Added:
}))
103
Added:
in
104
Added:
Alcotest.(check bool) "extended" true (Stimulus.is_extended s);
105
Added:
Alcotest.(check int)
106
Added:
"two extensions" 2
107
Added:
(List.length (Stimulus.extensions s)) );
108
Added:
]
109
Added:
110
Added:
let warm_up_tests =
111
Added:
[
112
Added:
( "warm-ups sit alongside the stimulus, not inside it",
113
Added:
`Quick,
114
Added:
fun () ->
115
Added:
let w =
116
Added:
Stimulus.Warm_up.make ~exercise:(get "squats") ~load:(kg 40.)
117
Added:
~reps:(reps 10)
118
Added:
in
119
Added:
let s =
120
Added:
ok
121
Added:
(Stimulus.make ~warm_ups:[ w ]
122
Added:
(Stimulus.Single (move "squats" 100. 8)))
123
Added:
in
124
Added:
Alcotest.(check int) "one warm-up" 1 (List.length (Stimulus.warm_ups s));
125
Added:
Alcotest.(check int)
126
Added:
"still one drive to failure" 1
127
Added:
(List.length (Stimulus.movements s)) );
128
Added:
( "a stimulus needs no warm-up",
129
Added:
`Quick,
130
Added:
fun () ->
131
Added:
let s = ok (Stimulus.make (Stimulus.Single (move "sit-ups" 0. 12))) in
132
Added:
Alcotest.(check int) "none" 0 (List.length (Stimulus.warm_ups s)) );
133
Added:
]
134
Added:
135
Added:
let suite =
136
Added:
[
137
Added:
("stimulus.outcome", outcome_tests);
138
Added:
("stimulus.delivery", delivery_tests);
139
Added:
("stimulus.warm_up", warm_up_tests);
140
Added:
]