1 module Muscle = struct 2 type t = 3 | Pecs 4 | Delts 5 | Triceps 6 | Biceps 7 | Forearms 8 | Lats 9 | Traps 10 | Erectors 11 | Quadriceps 12 | Hamstrings 13 | Glutes 14 | Calves 15 | Abdominals 16 17 let equal = ( = ) 18 end 19 20 type equipment = 21 | Barbell 22 | Cable 23 | Dumbbell 24 | Machine 25 | Bodyweight 26 | Unspecified 27 28 type movement = 29 | Fly 30 | Crossover 31 | Pec_deck 32 | Press 33 | Lateral_raise 34 | French_press 35 | Pressdown 36 | Dip 37 | Pullover 38 | Pulldown 39 | Row 40 | Chin 41 | Shrug 42 | Hyperextension 43 | Deadlift 44 | Curl 45 | Leg_extension 46 | Leg_press 47 | Squat 48 | Leg_curl 49 | Calf_raise 50 | Sit_up 51 52 type variation = 53 | Standard 54 | Incline 55 | Bent_over 56 | Rear_delt 57 | Lying 58 | Triceps 59 | Close_grip_palms_up 60 | Straight_arm 61 | Preacher 62 63 type key = { equipment : equipment; movement : movement; variation : variation } 64 type id = string 65 type mechanic = Isolation | Compound 66 67 type t = { 68 key : key; 69 id : id; 70 name : string; 71 mechanic : mechanic; 72 muscles : Muscle.t list; 73 } 74 75 let make_key ~equipment ~movement ~variation = 76 { equipment; movement; variation } 77 78 let key_equal = ( = ) 79 let key t = t.key 80 let id t = t.id 81 let name t = t.name 82 let equal a b = key_equal a.key b.key 83 let pp ppf t = Format.pp_print_string ppf t.name 84 85 let iso ~key ~id ~name muscle = 86 { key; id; name; mechanic = Isolation; muscles = [ muscle ] } 87 88 let comp ~key ~id ~name muscles = 89 { key; id; name; mechanic = Compound; muscles } 90 91 (* The movements HD1 names, in the order its Ideal Routine introduces them. 92 The stable [id] preserves external serialization. The structured [key] is the 93 catalog identity. [Unspecified] records where HD1 names no equipment. *) 94 let dumbbell_flyes = 95 make_key ~equipment:Dumbbell ~movement:Fly ~variation:Standard 96 97 let cable_crossovers = 98 make_key ~equipment:Cable ~movement:Crossover ~variation:Standard 99 100 let pec_deck = 101 make_key ~equipment:Machine ~movement:Pec_deck ~variation:Standard 102 103 let incline_presses = 104 make_key ~equipment:Unspecified ~movement:Press ~variation:Incline 105 106 let laterals = 107 make_key ~equipment:Unspecified ~movement:Lateral_raise ~variation:Standard 108 109 let bent_over_laterals = 110 make_key ~equipment:Dumbbell ~movement:Lateral_raise ~variation:Bent_over 111 112 let reverse_pec_deck = 113 make_key ~equipment:Machine ~movement:Pec_deck ~variation:Rear_delt 114 115 let lying_french_presses = 116 make_key ~equipment:Unspecified ~movement:French_press ~variation:Lying 117 118 let pressdowns = 119 make_key ~equipment:Cable ~movement:Pressdown ~variation:Standard 120 121 let triceps_machine = 122 make_key ~equipment:Machine ~movement:Press ~variation:Triceps 123 124 let dips = make_key ~equipment:Bodyweight ~movement:Dip ~variation:Standard 125 126 let pullovers = 127 make_key ~equipment:Unspecified ~movement:Pullover ~variation:Standard 128 129 let straight_arm_pulldowns = 130 make_key ~equipment:Cable ~movement:Pulldown ~variation:Straight_arm 131 132 let close_grip_pulldowns = 133 make_key ~equipment:Cable ~movement:Pulldown ~variation:Close_grip_palms_up 134 135 let bent_over_rows = 136 make_key ~equipment:Barbell ~movement:Row ~variation:Bent_over 137 138 let chins = make_key ~equipment:Bodyweight ~movement:Chin ~variation:Standard 139 let shrugs = make_key ~equipment:Unspecified ~movement:Shrug ~variation:Standard 140 141 let hyperextensions = 142 make_key ~equipment:Bodyweight ~movement:Hyperextension ~variation:Standard 143 144 let deadlifts = 145 make_key ~equipment:Barbell ~movement:Deadlift ~variation:Standard 146 147 let curls = make_key ~equipment:Barbell ~movement:Curl ~variation:Standard 148 149 let preacher_curls = 150 make_key ~equipment:Barbell ~movement:Curl ~variation:Preacher 151 152 let leg_extensions = 153 make_key ~equipment:Machine ~movement:Leg_extension ~variation:Standard 154 155 let leg_presses = 156 make_key ~equipment:Machine ~movement:Leg_press ~variation:Standard 157 158 let squats = make_key ~equipment:Barbell ~movement:Squat ~variation:Standard 159 160 let leg_curls = 161 make_key ~equipment:Machine ~movement:Leg_curl ~variation:Standard 162 163 let calf_raises = 164 make_key ~equipment:Unspecified ~movement:Calf_raise ~variation:Standard 165 166 let sit_ups = 167 make_key ~equipment:Bodyweight ~movement:Sit_up ~variation:Standard 168 169 let catalog = 170 [ 171 iso ~key:dumbbell_flyes ~id:"dumbbell-flyes" ~name:"Dumbbell Flyes" 172 Muscle.Pecs; 173 iso ~key:cable_crossovers ~id:"cable-crossovers" ~name:"Cable Crossovers" 174 Muscle.Pecs; 175 iso ~key:pec_deck ~id:"pec-deck" ~name:"Pec Deck" Muscle.Pecs; 176 comp ~key:incline_presses ~id:"incline-press" ~name:"Incline Presses" 177 [ Muscle.Pecs; Muscle.Delts; Muscle.Triceps ]; 178 iso ~key:laterals ~id:"laterals" ~name:"Laterals" Muscle.Delts; 179 iso ~key:bent_over_laterals ~id:"bent-over-laterals" 180 ~name:"Bent-over Dumbbell Laterals" Muscle.Delts; 181 iso ~key:reverse_pec_deck ~id:"reverse-pec-deck" 182 ~name:"Pec Deck (rear delts)" Muscle.Delts; 183 iso ~key:lying_french_presses ~id:"lying-french-press" 184 ~name:"Lying French Presses" Muscle.Triceps; 185 iso ~key:pressdowns ~id:"pressdowns" ~name:"Pressdowns" Muscle.Triceps; 186 iso ~key:triceps_machine ~id:"triceps-machine" ~name:"Triceps Machine" 187 Muscle.Triceps; 188 comp ~key:dips ~id:"dips" ~name:"Dips" 189 [ Muscle.Triceps; Muscle.Pecs; Muscle.Delts ]; 190 iso ~key:pullovers ~id:"pullovers" ~name:"Pullovers" Muscle.Lats; 191 iso ~key:straight_arm_pulldowns ~id:"straight-arm-pulldowns" 192 ~name:"Straight-Arm Pulldowns" Muscle.Lats; 193 comp ~key:close_grip_pulldowns ~id:"close-grip-pulldowns" 194 ~name:"Close-grip, palms-up Pulldowns" 195 [ Muscle.Lats; Muscle.Biceps; Muscle.Forearms ]; 196 comp ~key:bent_over_rows ~id:"bent-over-rows" ~name:"Bent-over Barbell Rows" 197 [ Muscle.Lats; Muscle.Biceps; Muscle.Forearms; Muscle.Erectors ]; 198 comp ~key:chins ~id:"chins" ~name:"Chins" 199 [ Muscle.Lats; Muscle.Biceps; Muscle.Forearms ]; 200 iso ~key:shrugs ~id:"shrugs" ~name:"Shrugs" Muscle.Traps; 201 iso ~key:hyperextensions ~id:"hyperextensions" ~name:"Hyperextensions" 202 Muscle.Erectors; 203 comp ~key:deadlifts ~id:"deadlifts" ~name:"Deadlifts" 204 [ 205 Muscle.Erectors; 206 Muscle.Glutes; 207 Muscle.Hamstrings; 208 Muscle.Quadriceps; 209 Muscle.Traps; 210 ]; 211 iso ~key:curls ~id:"curls" ~name:"Curls" Muscle.Biceps; 212 iso ~key:preacher_curls ~id:"preacher-curls" ~name:"Preacher Curls" 213 Muscle.Biceps; 214 iso ~key:leg_extensions ~id:"leg-extensions" ~name:"Leg Extensions" 215 Muscle.Quadriceps; 216 comp ~key:leg_presses ~id:"leg-presses" ~name:"Leg Presses" 217 [ Muscle.Quadriceps; Muscle.Glutes; Muscle.Hamstrings ]; 218 comp ~key:squats ~id:"squats" ~name:"Squats" 219 [ Muscle.Quadriceps; Muscle.Glutes; Muscle.Hamstrings; Muscle.Erectors ]; 220 iso ~key:leg_curls ~id:"leg-curls" ~name:"Leg Curls" Muscle.Hamstrings; 221 iso ~key:calf_raises ~id:"calf-raises" ~name:"Calf Raises" Muscle.Calves; 222 iso ~key:sit_ups ~id:"sit-ups" ~name:"Sit-Ups" Muscle.Abdominals; 223 ] 224 225 let find sought = 226 List.find_opt (fun exercise -> key_equal exercise.key sought) catalog 227 228 let find_id sought = 229 List.find_opt (fun exercise -> String.equal exercise.id sought) catalog 230 231 (* Mutually substitutable catalog keys. Grouping guarantees symmetry: every 232 member of a group may stand in for every other. Each group is one of HD1's 233 own "or" lists. *) 234 let substitution_groups = 235 [ 236 [ dumbbell_flyes; cable_crossovers; pec_deck ]; 237 [ lying_french_presses; pressdowns; triceps_machine ]; 238 [ bent_over_laterals; reverse_pec_deck ]; 239 [ pullovers; straight_arm_pulldowns ]; 240 [ close_grip_pulldowns; bent_over_rows; chins ]; 241 [ hyperextensions; deadlifts ]; 242 [ curls; preacher_curls ]; 243 [ leg_presses; squats ]; 244 ] 245 246 let group_of exercise = 247 List.find_opt (List.exists (key_equal exercise.key)) substitution_groups 248 |> Option.value ~default:[] 249 250 let permitted_substitutes exercise = 251 group_of exercise 252 |> List.filter (fun key -> not (key_equal key exercise.key)) 253 |> List.filter_map find 254 255 let may_substitute ~original ~candidate = 256 List.exists (equal candidate) (permitted_substitutes original) 257 258 let may_pre_exhaust ~isolation ~compound = 259 match (isolation.mechanic, compound.mechanic, isolation.muscles) with 260 | Isolation, Compound, [ target ] -> 261 List.exists (Muscle.equal target) compound.muscles 262 && List.length compound.muscles >= 2 263 | _ -> false 264