1 module Rep_range = struct 2 type t = int * int 3 4 type error = 5 | Invalid_order of { min : int; max : int } 6 | Outside_limits of { min : int; max : int } 7 8 let limits = (6, 12) 9 10 exception Invalid of error 11 12 let make ~min ~max = 13 let lower, upper = limits in 14 if min <= 0 || max < min then raise (Invalid (Invalid_order { min; max })) 15 else if min < lower || max > upper then 16 raise (Invalid (Outside_limits { min; max })) 17 else (min, max) 18 19 let bounds t = t 20 end 21 22 module Stimulus = struct 23 type delivery = 24 | Single of Exercise.t 25 | Pre_exhaust of { isolation : Exercise.t; compound : Exercise.t } 26 27 type t = { 28 delivery : delivery; 29 rep_range : Rep_range.t; 30 allowed_substitutes : Exercise.t list; 31 } 32 33 type error = 34 | Not_a_pre_exhaust of { isolation : Exercise.id; compound : Exercise.id } 35 | Substitute_not_permitted of Exercise.id 36 37 let pp_error ppf = function 38 | Not_a_pre_exhaust { isolation; compound } -> 39 Format.fprintf ppf "%s cannot pre-exhaust for %s" 40 (isolation :> string) 41 (compound :> string) 42 | Substitute_not_permitted id -> 43 Format.fprintf ppf "%s is not a permitted substitute" (id :> string) 44 45 let delivery t = t.delivery 46 47 exception Invalid of error 48 49 let rep_range t = t.rep_range 50 let allowed_substitutes t = t.allowed_substitutes 51 52 let delivery_exercises = function 53 | Single e -> [ e ] 54 | Pre_exhaust { isolation; compound } -> [ isolation; compound ] 55 56 let exercises t = delivery_exercises t.delivery 57 58 let make ~delivery ~rep_range ~allowed_substitutes = 59 let movements = delivery_exercises delivery in 60 let unpermitted = 61 List.find_opt 62 (fun candidate -> 63 not 64 (List.exists 65 (fun original -> Exercise.may_substitute ~original ~candidate) 66 movements)) 67 allowed_substitutes 68 in 69 match (delivery, unpermitted) with 70 | Pre_exhaust { isolation; compound }, _ 71 when not (Exercise.may_pre_exhaust ~isolation ~compound) -> 72 raise 73 (Invalid 74 (Not_a_pre_exhaust 75 { 76 isolation = Exercise.id isolation; 77 compound = Exercise.id compound; 78 })) 79 | _, Some candidate -> 80 raise (Invalid (Substitute_not_permitted (Exercise.id candidate))) 81 | _ -> { delivery; rep_range; allowed_substitutes } 82 83 let permits t movement = 84 List.exists (Exercise.equal movement) (exercises t) 85 || List.exists (Exercise.equal movement) t.allowed_substitutes 86 87 let pp_delivery ppf = function 88 | Single e -> Exercise.pp ppf e 89 | Pre_exhaust { isolation; compound } -> 90 Format.fprintf ppf "%a into %a" Exercise.pp isolation Exercise.pp 91 compound 92 93 let pp ppf t = 94 let min_reps, max_reps = Rep_range.bounds t.rep_range in 95 Format.fprintf ppf "%a for %d-%d reps" pp_delivery t.delivery min_reps 96 max_reps 97 end 98 99 module Workout = struct 100 type error = Empty_workout 101 type t = { name : string; stimuli : Stimulus.t list } 102 103 exception Invalid of error 104 105 let make ~name ~stimuli = 106 match stimuli with 107 | [] -> raise (Invalid Empty_workout) 108 | _ -> { name; stimuli } 109 110 let name t = t.name 111 let stimuli t = t.stimuli 112 let pp ppf t = Format.pp_print_string ppf t.name 113 end 114 115 module Routine = struct 116 type error = Empty_routine 117 type t = { name : string; workouts : Workout.t list } 118 119 exception Invalid of error 120 121 let make ~name ~workouts = 122 match workouts with 123 | [] -> raise (Invalid Empty_routine) 124 | _ -> { name; workouts } 125 126 let name t = t.name 127 let workouts t = t.workouts 128 let pp ppf t = Format.pp_print_string ppf t.name 129 130 let workout_after t performed = 131 let rec next = function 132 | [] | [ _ ] -> List.hd t.workouts 133 | w :: (following :: _ as rest) -> 134 if w == performed then following else next rest 135 in 136 next t.workouts 137 138 let training_interval = Recovery.hours 48 139 let cycle_rest = Recovery.hours 72 140 141 let recovery_after t performed = 142 match List.rev t.workouts with 143 | last :: _ when last == performed -> cycle_rest 144 | _ -> training_interval 145 146 (* {1 The Ideal Routine} *) 147 148 open Exercise 149 150 let exercise key = 151 match Exercise.find key with 152 | Some exercise -> exercise 153 | None -> invalid_arg "Ideal Routine references an absent catalog key" 154 155 let dumbbell_flyes = 156 exercise { equipment = Dumbbell; movement = Fly; variation = Standard } 157 158 let cable_crossovers = 159 exercise { equipment = Cable; movement = Crossover; variation = Standard } 160 161 let pec_deck = 162 exercise { equipment = Machine; movement = Pec_deck; variation = Standard } 163 164 let incline_presses = 165 exercise { equipment = Unspecified; movement = Press; variation = Incline } 166 167 let laterals = 168 exercise 169 { 170 equipment = Unspecified; 171 movement = Lateral_raise; 172 variation = Standard; 173 } 174 175 let bent_over_laterals = 176 exercise 177 { equipment = Dumbbell; movement = Lateral_raise; variation = Bent_over } 178 179 let reverse_pec_deck = 180 exercise { equipment = Machine; movement = Pec_deck; variation = Rear_delt } 181 182 let lying_french_presses = 183 exercise 184 { equipment = Unspecified; movement = French_press; variation = Lying } 185 186 let pressdowns = 187 exercise { equipment = Cable; movement = Pressdown; variation = Standard } 188 189 let triceps_machine = 190 exercise { equipment = Machine; movement = Press; variation = Triceps } 191 192 let dips = 193 exercise { equipment = Bodyweight; movement = Dip; variation = Standard } 194 195 let pullovers = 196 exercise 197 { equipment = Unspecified; movement = Pullover; variation = Standard } 198 199 let straight_arm_pulldowns = 200 exercise 201 { equipment = Cable; movement = Pulldown; variation = Straight_arm } 202 203 let close_grip_pulldowns = 204 exercise 205 { 206 equipment = Cable; 207 movement = Pulldown; 208 variation = Close_grip_palms_up; 209 } 210 211 let bent_over_rows = 212 exercise { equipment = Barbell; movement = Row; variation = Bent_over } 213 214 let shrugs = 215 exercise { equipment = Unspecified; movement = Shrug; variation = Standard } 216 217 let hyperextensions = 218 exercise 219 { 220 equipment = Bodyweight; 221 movement = Hyperextension; 222 variation = Standard; 223 } 224 225 let deadlifts = 226 exercise { equipment = Barbell; movement = Deadlift; variation = Standard } 227 228 let curls = 229 exercise { equipment = Barbell; movement = Curl; variation = Standard } 230 231 let preacher_curls = 232 exercise { equipment = Barbell; movement = Curl; variation = Preacher } 233 234 let leg_extensions = 235 exercise 236 { equipment = Machine; movement = Leg_extension; variation = Standard } 237 238 let leg_presses = 239 exercise { equipment = Machine; movement = Leg_press; variation = Standard } 240 241 let squats = 242 exercise { equipment = Barbell; movement = Squat; variation = Standard } 243 244 let leg_curls = 245 exercise { equipment = Machine; movement = Leg_curl; variation = Standard } 246 247 let calf_raises = 248 exercise 249 { equipment = Unspecified; movement = Calf_raise; variation = Standard } 250 251 let sit_ups = 252 exercise { equipment = Bodyweight; movement = Sit_up; variation = Standard } 253 254 (* HD1's guideline window for every listed exercise. *) 255 let six_to_ten = Rep_range.make ~min:6 ~max:10 256 257 let prescribe ?(substitutes = []) delivery = 258 Stimulus.make ~delivery ~rep_range:six_to_ten 259 ~allowed_substitutes:substitutes 260 261 let single ?substitutes exercise = 262 prescribe ?substitutes (Stimulus.Single exercise) 263 264 let pre_exhaust ?substitutes ~isolation ~compound () = 265 prescribe ?substitutes (Stimulus.Pre_exhaust { isolation; compound }) 266 267 let day ~name stimuli = Workout.make ~name ~stimuli 268 269 let ideal_day_one = 270 day ~name:"Day 1" 271 [ 272 pre_exhaust 273 ~substitutes:[ cable_crossovers; pec_deck ] 274 ~isolation:dumbbell_flyes ~compound:incline_presses (); 275 single laterals; 276 single ~substitutes:[ reverse_pec_deck ] bent_over_laterals; 277 pre_exhaust 278 ~substitutes:[ pressdowns; triceps_machine ] 279 ~isolation:lying_french_presses ~compound:dips (); 280 ] 281 282 let ideal_day_two = 283 day ~name:"Day 2" 284 [ 285 pre_exhaust ~substitutes:[ straight_arm_pulldowns ] ~isolation:pullovers 286 ~compound:close_grip_pulldowns (); 287 single bent_over_rows; 288 single shrugs; 289 single ~substitutes:[ deadlifts ] hyperextensions; 290 single ~substitutes:[ preacher_curls ] curls; 291 ] 292 293 let ideal_day_three = 294 day ~name:"Day 3" 295 [ 296 pre_exhaust ~substitutes:[ squats ] ~isolation:leg_extensions 297 ~compound:leg_presses (); 298 single leg_curls; 299 single calf_raises; 300 single sit_ups; 301 ] 302 303 let[@warning "-32"] ideal = 304 make ~name:"Ideal Routine" 305 ~workouts:[ ideal_day_one; ideal_day_two; ideal_day_three ] 306 end 307