From 753e25e99ddf57be78ff27ad89cb7e1bbc99d041 Mon Sep 17 00:00:00 2001 From: Marius Peter Date: Sat, 18 Jul 2026 23:23:35 +0200 Subject: Initial commit: HITO MVP Heavy Duty I prescriptive training system encoding Mentzer's methodology. - 4-day split program (Chest & Back, Legs, Shoulders, Arms) - Prescription engine with pre-exhaust superset structure - Strict progression logic (+5kg large / +2.5kg small muscles) - Recovery gating with stall-based extension and override - Onboarding via experience level (Novice/Intermediate/Advanced) - Session logging with full progression analysis - Exercise substitution (33 alternatives for 17 canonical movements) - Objectivist aesthetic: black/gold, serif, rectilinear Stack: Hunchentoot, Mito/SQLite, Djula, SBCL --- src/app.lisp | 43 ++++++ src/models.lisp | 186 +++++++++++++++++++++++ src/package.lisp | 53 +++++++ src/program.lisp | 232 +++++++++++++++++++++++++++++ src/progression.lisp | 157 ++++++++++++++++++++ src/recovery.lisp | 180 ++++++++++++++++++++++ src/routes.lisp | 411 +++++++++++++++++++++++++++++++++++++++++++++++++++ 7 files changed, 1262 insertions(+) create mode 100644 src/app.lisp create mode 100644 src/models.lisp create mode 100644 src/package.lisp create mode 100644 src/program.lisp create mode 100644 src/progression.lisp create mode 100644 src/recovery.lisp create mode 100644 src/routes.lisp (limited to 'src') diff --git a/src/app.lisp b/src/app.lisp new file mode 100644 index 0000000..6c8b960 --- /dev/null +++ b/src/app.lisp @@ -0,0 +1,43 @@ +(in-package #:hito) + +;;; --- Server Configuration --- + +(defvar *app* nil + "The Hunchentoot acceptor instance.") + +(defvar *port* 8080 + "Port on which HITO listens.") + +(defvar *static-directory* + (asdf:system-relative-pathname "hito" "static/") + "Path to static assets (CSS, images).") + +;;; --- Static File Serving --- + +(push (hunchentoot:create-folder-dispatcher-and-handler + "/static/" *static-directory*) + hunchentoot:*dispatch-table*) + +;;; --- Server Lifecycle --- + +(defun start (&key (port *port*)) + "Start the HITO web server. Initializes the database if needed." + (when *app* + (format t "~&Server already running on port ~D. Stop it first.~%" *port*) + (return-from start nil)) + ;; Ensure DB is ready + (init-db) + (setf *app* (make-instance 'hunchentoot:easy-acceptor + :port port + :document-root *static-directory*)) + (hunchentoot:start *app*) + (format t "~&HITO is running on port ~D.~%" port) + *app*) + +(defun stop () + "Stop the HITO web server." + (when *app* + (hunchentoot:stop *app*) + (setf *app* nil) + (format t "~&HITO stopped.~%") + t)) diff --git a/src/models.lisp b/src/models.lisp new file mode 100644 index 0000000..72a128c --- /dev/null +++ b/src/models.lisp @@ -0,0 +1,186 @@ +(in-package #:hito) + +;;; --- Database Configuration --- + +(defvar *db-path* + (asdf:system-relative-pathname "hito" "hito.db") + "Path to the SQLite database file.") + +;;; --- Table Definitions --- + +(mito:deftable exercise () + ((name :col-type (:varchar 128) + :documentation "Exercise name, e.g. 'Pec Deck'") + (muscle-group :col-type (:varchar 64) + :documentation "Primary muscle group: chest, back, legs, shoulders, arms") + (is-default-p :col-type :boolean + :initform t + :documentation "Whether this is a Mentzer canonical exercise") + (substitution-for :col-type (or :bigint :null) + :initform nil + :documentation "FK to exercise this substitutes for (nil if canonical)")) + (:documentation "An exercise in the HITO system. Mentzer's canonical movements are seeded by default.")) + +(mito:deftable user-profile () + ((name :col-type (:varchar 128) + :initform "Trainee" + :documentation "User's name") + (current-workout-day :col-type :integer + :initform 1 + :documentation "Next workout day in the rotation (1-4)") + (last-session-date :col-type (or :varchar :null) + :initform nil + :documentation "ISO date string of last completed session") + (training-start-date :col-type (or :varchar :null) + :initform nil + :documentation "ISO date string of when training began")) + (:documentation "Single user profile. Architected for multi-user extension.")) + +(mito:deftable training-session () + ((session-date :col-type (:varchar 32) + :documentation "ISO date string of this session") + (workout-day :col-type :integer + :documentation "Which day in the rotation (1-4)") + (completed-p :col-type :boolean + :initform nil + :documentation "Whether the session was completed") + (notes :col-type (or :text :null) + :initform nil + :documentation "Optional session notes") + (override-p :col-type :boolean + :initform nil + :documentation "Whether recovery gate was overridden for this session")) + (:documentation "A single training session, one workout day.")) + +(mito:deftable set-record () + ((session-id :col-type :bigint + :documentation "FK to training-session") + (exercise-id :col-type :bigint + :documentation "FK to exercise") + (set-number :col-type :integer + :documentation "Order within the exercise (1, 2, ...)") + (prescribed-weight :col-type :real + :documentation "Target weight in kg") + (prescribed-rep-low :col-type :integer + :initform 6 + :documentation "Lower bound of rep range") + (prescribed-rep-high :col-type :integer + :initform 10 + :documentation "Upper bound of rep range") + (actual-weight :col-type (or :real :null) + :initform nil + :documentation "Weight actually used (filled after session)") + (actual-reps :col-type (or :integer :null) + :initform nil + :documentation "Reps actually achieved (filled after session)") + (to-failure-p :col-type (or :boolean :null) + :initform nil + :documentation "Whether the set was taken to muscular failure")) + (:documentation "A single set within a session — both prescription and result.")) + +;;; --- Database Initialization --- + +(defun connect-db () + "Connect to the SQLite database." + (mito:connect-toplevel :sqlite3 + :database-name *db-path*)) + +(defun ensure-tables () + "Create or migrate all tables." + (mito:ensure-table-exists 'exercise) + (mito:ensure-table-exists 'user-profile) + (mito:ensure-table-exists 'training-session) + (mito:ensure-table-exists 'set-record)) + +;;; --- Seed Data: Mentzer's HD I Canonical Exercises --- + +(defparameter *hd1-exercises* + '(;; Day 1: Chest & Back + ("Pec Deck" "chest") + ("Incline Barbell Press" "chest") + ("Straight-Arm Pulldowns" "back") + ("Close-Grip Palms-Up Pulldowns" "back") + ("Bent-Over Barbell Rows" "back") + ;; Day 2: Legs + ("Leg Extensions" "legs") + ("Leg Press" "legs") + ("Squats" "legs") + ("Leg Curls" "legs") + ("Standing Calf Raises" "legs") + ("Toe Presses" "legs") + ;; Day 3: Shoulders + ("Lateral Raises" "shoulders") + ("Overhead Press" "shoulders") + ("Bent-Over Lateral Raises" "shoulders") + ;; Day 4: Arms + ("Barbell Curls" "arms") + ("Triceps Pushdowns" "arms") + ("Dips" "arms")) + "Mentzer's canonical Heavy Duty I exercises.") + +(defparameter *substitution-options* + '(;; Each entry: (canonical-exercise-name . list-of-substitute-names) + ("Pec Deck" "Cable Crossovers" "Dumbbell Flyes") + ("Incline Barbell Press" "Incline Dumbbell Press" "Flat Barbell Press") + ("Straight-Arm Pulldowns" "Dumbbell Pullovers" "Straight-Arm Cable Pushdowns") + ("Close-Grip Palms-Up Pulldowns" "Chin-Ups" "Close-Grip Cable Rows") + ("Bent-Over Barbell Rows" "T-Bar Rows" "Seated Cable Rows") + ("Leg Extensions" "Sissy Squats") + ("Leg Press" "Hack Squats" "Front Squats") + ("Squats" "Belt Squats" "Bulgarian Split Squats") + ("Leg Curls" "Romanian Deadlifts" "Glute-Ham Raises") + ("Standing Calf Raises" "Seated Calf Raises" "Donkey Calf Raises") + ("Toe Presses" "Calf Press on Leg Press") + ("Lateral Raises" "Cable Lateral Raises" "Machine Lateral Raises") + ("Overhead Press" "Dumbbell Shoulder Press" "Machine Shoulder Press") + ("Bent-Over Lateral Raises" "Reverse Pec Deck" "Face Pulls") + ("Barbell Curls" "Dumbbell Curls" "EZ-Bar Curls") + ("Triceps Pushdowns" "Overhead Triceps Extension" "Close-Grip Bench Press") + ("Dips" "Weighted Dips" "Decline Close-Grip Press")) + "Available substitutions for each canonical exercise. +The movement pattern is what matters, not brand loyalty to specific equipment.") + +(defun seed-exercises () + "Seed the database with Mentzer's canonical exercises if not already present." + (when (zerop (mito:count-dao 'exercise)) + (dolist (entry *hd1-exercises*) + (mito:create-dao 'exercise + :name (first entry) + :muscle-group (second entry) + :is-default-p t + :substitution-for nil)) + (format t "~&Seeded ~D canonical exercises.~%" (length *hd1-exercises*)))) + +(defun find-exercise-by-name (name) + "Look up an exercise DAO by name. Returns nil if not found." + (first (mito:select-dao 'exercise + (sxql:where (:= :name name))))) + +(defun seed-substitution-options () + "Seed available substitution exercises (not active, just available for selection). +These are stored with is-default-p = nil and substitution-for = nil until activated." + (dolist (entry *substitution-options*) + (let* ((canonical-name (first entry)) + (canonical (find-exercise-by-name canonical-name)) + (subs (rest entry))) + (when canonical + (dolist (sub-name subs) + ;; Only create if not already in DB + (unless (find-exercise-by-name sub-name) + (let ((muscle-group (exercise-muscle-group canonical))) + (mito:create-dao 'exercise + :name sub-name + :muscle-group muscle-group + :is-default-p nil + :substitution-for nil))))))) + (format t "~&Seeded substitution options.~%")) + +;;; --- Top-Level Initialization --- + +(defun init-db () + "Initialize the database: connect, create tables, seed data." + (connect-db) + (ensure-tables) + (seed-exercises) + (seed-substitution-options) + (format t "~&Database initialized at ~A~%" *db-path*)) diff --git a/src/package.lisp b/src/package.lisp new file mode 100644 index 0000000..69589b2 --- /dev/null +++ b/src/package.lisp @@ -0,0 +1,53 @@ +(defpackage #:hito + (:use #:cl) + (:export #:start + #:stop + #:*app* + #:init-db + #:connect-db + #:*db-path* + #:exercise + #:user-profile + #:training-session + #:set-record + #:seed-exercises + ;; Program + #:*hd1-program* + #:get-workout-day + #:get-workout-day-name + #:prescribe-session + #:format-session-prescription + #:exercise-prescription + #:exercise-prescription-exercise-id + #:exercise-prescription-exercise-name + #:exercise-prescription-set-count + #:exercise-prescription-rep-low + #:exercise-prescription-rep-high + #:exercise-prescription-target-weight + #:exercise-prescription-group-type + #:exercise-prescription-group-position + ;; Progression + #:evaluate-set + #:compute-next-weight + #:process-session-progression + #:format-session-progression + #:format-progression-result + #:progression-result + #:progression-result-exercise-id + #:progression-result-exercise-name + #:progression-result-old-weight + #:progression-result-new-weight + #:progression-result-status + #:progression-result-actual-reps + ;; Recovery + #:recovery-status + #:recovery-status-ready-p + #:recovery-status-days-remaining + #:recovery-status-next-date + #:recovery-status-reason + #:recovery-status-last-session-date + #:recovery-status-recovery-days + #:calculate-recovery-days + #:override-recovery + #:*override-warning* + #:format-recovery-status)) diff --git a/src/program.lisp b/src/program.lisp new file mode 100644 index 0000000..3a03a53 --- /dev/null +++ b/src/program.lisp @@ -0,0 +1,232 @@ +(in-package #:hito) + +;;; --- Heavy Duty I Program Definition --- +;;; +;;; The program is encoded as pure data: a list of workout days, each containing +;;; ordered exercise entries with superset groupings, set counts, and rep ranges. +;;; This is the single source of truth for what Mentzer prescribed. + +(defparameter *hd1-program* + '((:day 1 + :name "Chest & Back" + :exercises + ((:superset + ((:name "Pec Deck" :sets 1 :rep-low 6 :rep-high 10) + (:name "Incline Barbell Press" :sets 1 :rep-low 6 :rep-high 10))) + (:superset + ((:name "Straight-Arm Pulldowns" :sets 1 :rep-low 6 :rep-high 10) + (:name "Close-Grip Palms-Up Pulldowns" :sets 1 :rep-low 6 :rep-high 10))) + (:straight + ((:name "Bent-Over Barbell Rows" :sets 2 :rep-low 6 :rep-high 10))))) + + (:day 2 + :name "Legs" + :exercises + ((:superset + ((:name "Leg Extensions" :sets 1 :rep-low 6 :rep-high 10) + (:name "Leg Press" :sets 1 :rep-low 6 :rep-high 10))) + (:straight + ((:name "Squats" :sets 1 :rep-low 6 :rep-high 10))) + (:straight + ((:name "Leg Curls" :sets 2 :rep-low 6 :rep-high 10))) + (:straight + ((:name "Standing Calf Raises" :sets 2 :rep-low 6 :rep-high 10))) + (:straight + ((:name "Toe Presses" :sets 1 :rep-low 6 :rep-high 10))))) + + (:day 3 + :name "Shoulders" + :exercises + ((:superset + ((:name "Lateral Raises" :sets 1 :rep-low 6 :rep-high 10) + (:name "Overhead Press" :sets 1 :rep-low 6 :rep-high 10))) + (:straight + ((:name "Bent-Over Lateral Raises" :sets 2 :rep-low 6 :rep-high 10))))) + + (:day 4 + :name "Arms" + :exercises + ((:straight + ((:name "Barbell Curls" :sets 2 :rep-low 6 :rep-high 10))) + (:superset + ((:name "Triceps Pushdowns" :sets 1 :rep-low 6 :rep-high 10) + (:name "Dips" :sets 1 :rep-low 6 :rep-high 10)))))) + "Heavy Duty I: the complete 4-day split as Mentzer prescribed it. +Each workout day contains exercise groups — either :superset (pre-exhaust) +or :straight (standalone). Each exercise specifies sets and rep range.") + +;;; --- Starting Weight Defaults by Experience Level --- +;;; +;;; Conservative starting points. The progression engine will correct these +;;; within 2-3 sessions. Better to start light and progress than to start +;;; heavy and stall. + +(defparameter *starting-weights* + '(;; (exercise-name beginner intermediate advanced) — all in kg + ("Pec Deck" 20 35 55) + ("Incline Barbell Press" 40 60 85) + ("Straight-Arm Pulldowns" 15 22 32) + ("Close-Grip Palms-Up Pulldowns" 27 45 65) + ("Bent-Over Barbell Rows" 35 60 85) + ("Leg Extensions" 20 32 45) + ("Leg Press" 60 115 180) + ("Squats" 40 70 100) + ("Leg Curls" 20 32 45) + ("Standing Calf Raises" 35 70 100) + ("Toe Presses" 45 90 135) + ("Lateral Raises" 7 11 16) + ("Overhead Press" 25 42 60) + ("Bent-Over Lateral Raises" 5 9 14) + ("Barbell Curls" 18 30 40) + ("Triceps Pushdowns" 14 22 32) + ("Dips" 0 0 10)) + "Starting weights by exercise and experience level. +Dips default to 0 (bodyweight) for beginner/intermediate.") + +(defun get-starting-weight (exercise-name level) + "Return the starting weight for an exercise at the given level. +LEVEL is one of :beginner, :intermediate, :advanced." + (let ((entry (assoc exercise-name *starting-weights* :test #'string=))) + (when entry + (case level + (:beginner (second entry)) + (:intermediate (third entry)) + (:advanced (fourth entry)) + (otherwise (second entry)))))) + +;;; --- Program Query Functions --- + +(defun get-workout-day (day-number) + "Return the program definition for a given day (1-4)." + (find day-number *hd1-program* :key (lambda (d) (getf d :day)))) + +(defun get-workout-day-name (day-number) + "Return the human-readable name for a workout day." + (let ((day (get-workout-day day-number))) + (when day (getf day :name)))) + +(defun get-day-exercises (day-number) + "Return the exercise group list for a given day." + (let ((day (get-workout-day day-number))) + (when day (getf day :exercises)))) + +;;; --- Exercise Resolution --- + +(defun find-active-exercise-for-slot (canonical-name) + "Find the currently active exercise for a program slot. +If the user has substituted the canonical exercise, return the substitute. +Otherwise return the canonical exercise itself." + (let ((canonical (find-exercise-by-name canonical-name))) + (when canonical + ;; Check if there's an active substitution pointing to this exercise + (let ((substitute (first (mito:select-dao 'exercise + (sxql:where (:= :substitution-for + (mito:object-id canonical))))))) + (or substitute canonical))))) + +;;; --- Prescription Generation --- + +(defstruct exercise-prescription + "A single exercise prescription within a session." + exercise-id + exercise-name + set-count + rep-low + rep-high + target-weight + group-type ; :superset or :straight + group-position) ; position within superset (0-indexed), nil for straight + +(defun get-last-weight-for-exercise (exercise-id workout-day) + "Find the most recent actual weight used for this exercise in a completed session +of the same workout day. Returns nil if no history." + (let* ((sessions (mito:select-dao 'training-session + (sxql:where (:and (:= :workout-day workout-day) + (:= :completed-p 1))) + (sxql:order-by (:desc :session-date)) + (sxql:limit 1))) + (last-session (first sessions))) + (when last-session + (let ((records (mito:select-dao 'set-record + (sxql:where (:and (:= :session-id (mito:object-id last-session)) + (:= :exercise-id exercise-id)))))) + ;; Return the actual weight from the last set of this exercise + (when records + (let ((last-record (first (sort (copy-list records) #'> + :key (lambda (r) (set-record-set-number r)))))) + (set-record-actual-weight last-record))))))) + +(defun get-prescribed-weight-for-exercise (exercise-id workout-day) + "Get the next prescribed weight for an exercise. +First checks progression table (computed by progression engine), +then falls back to last actual weight, then to nil (needs user input)." + ;; For now, just use last actual weight. Progression engine (Task 4) + ;; will enhance this. + (get-last-weight-for-exercise exercise-id workout-day)) + +(defun prescribe-session (workout-day) + "Generate a full session prescription for the given workout day. +Returns a list of exercise-prescription structs ordered as the program dictates." + (let ((day-def (get-workout-day workout-day)) + (prescriptions '())) + (unless day-def + (error "Invalid workout day: ~D (must be 1-4)" workout-day)) + (dolist (group (getf day-def :exercises)) + (let* ((group-type (first group)) + (exercises (second group)) + (position 0)) + (dolist (ex-def exercises) + (let* ((canonical-name (getf ex-def :name)) + (active-exercise (find-active-exercise-for-slot canonical-name)) + (exercise-id (when active-exercise (mito:object-id active-exercise))) + (exercise-name (if active-exercise + (exercise-name active-exercise) + canonical-name)) + (target-weight (when exercise-id + (get-prescribed-weight-for-exercise + exercise-id workout-day)))) + (push (make-exercise-prescription + :exercise-id exercise-id + :exercise-name exercise-name + :set-count (getf ex-def :sets) + :rep-low (getf ex-def :rep-low) + :rep-high (getf ex-def :rep-high) + :target-weight target-weight + :group-type group-type + :group-position (when (eq group-type :superset) position)) + prescriptions) + (incf position))))) + (nreverse prescriptions))) + +(defun format-prescription (prescription) + "Format a single exercise-prescription for display." + (let ((weight (exercise-prescription-target-weight prescription))) + (format nil "~A: ~@[~A kg × ~]~D-~D reps × ~D set~:P" + (exercise-prescription-exercise-name prescription) + (when weight (round weight)) + (exercise-prescription-rep-low prescription) + (exercise-prescription-rep-high prescription) + (exercise-prescription-set-count prescription)))) + +(defun format-session-prescription (workout-day) + "Format an entire session prescription as a readable string." + (let ((day-def (get-workout-day workout-day)) + (prescriptions (prescribe-session workout-day)) + (groups (get-day-exercises workout-day))) + (with-output-to-string (out) + (format out "~%=== Day ~D: ~A ===~%~%" + workout-day (getf day-def :name)) + ;; Walk the groups directly and print prescriptions in order + (let ((presc-idx 0)) + (loop for group in groups + for group-idx from 0 + for group-type = (first group) + for group-exercises = (second group) + do (when (> group-idx 0) (format out "~%")) + (if (eq group-type :superset) + (format out "[Pre-Exhaust Superset]~%") + (format out "[Straight Set]~%")) + (loop for i below (length group-exercises) + do (format out " ~A~%" + (format-prescription (nth presc-idx prescriptions))) + (incf presc-idx))))))) diff --git a/src/progression.lisp b/src/progression.lisp new file mode 100644 index 0000000..94e980b --- /dev/null +++ b/src/progression.lisp @@ -0,0 +1,157 @@ +(in-package #:hito) + +;;; --- Progression Engine --- +;;; +;;; Mentzer's progression logic is unambiguous: +;;; - Hit the top of the rep range → increase weight next session. +;;; - Within range → maintain weight, keep pushing. +;;; - Below the range → the weight is too heavy, or recovery is incomplete. +;;; The answer is NOT to reduce weight. The answer is more rest. +;;; +;;; "If you haven't recovered, you haven't grown. And if you haven't grown, +;;; more training is the last thing you need." + +;;; --- Weight Increment Configuration --- + +(defparameter *weight-increments* + '(("chest" . 5) + ("back" . 5) + ("legs" . 5) + ("shoulders" . 2.5) + ("arms" . 2.5)) + "Weight increment in kg per muscle group when progression is triggered. +Larger muscle groups tolerate larger jumps.") + +(defun weight-increment-for (muscle-group) + "Return the weight increment for a given muscle group." + (or (cdr (assoc muscle-group *weight-increments* :test #'string-equal)) + 2.5)) + +;;; --- Set Evaluation --- + +(defun evaluate-set (set-record) + "Evaluate a single set's result against its prescription. +Returns one of: + :increase — top of range reached, weight goes up next time + :maintain — within range, keep current weight + :stall — below range, recovery issue flagged" + (let ((actual-reps (set-record-actual-reps set-record)) + (rep-high (set-record-prescribed-rep-high set-record)) + (rep-low (set-record-prescribed-rep-low set-record))) + (cond + ((null actual-reps) :maintain) ; incomplete data, don't change + ((>= actual-reps rep-high) :increase) + ((>= actual-reps rep-low) :maintain) + (t :stall)))) + +;;; --- Weight Computation --- + +(defun compute-next-weight (current-weight progression-result muscle-group) + "Compute the next session's weight based on progression result. + :increase → add increment for muscle group + :maintain → same weight + :stall → same weight (recovery system handles the response)" + (case progression-result + (:increase (+ current-weight (weight-increment-for muscle-group))) + (:maintain current-weight) + (:stall current-weight) + (otherwise current-weight))) + +;;; --- Session Progression Processing --- + +(defstruct progression-result + "Result of progression evaluation for one exercise." + exercise-id + exercise-name + muscle-group + old-weight + new-weight + status ; :increase, :maintain, or :stall + actual-reps + rep-range-high) + +(defun get-exercise-muscle-group (exercise-id) + "Look up the muscle group for an exercise by ID." + (let ((exercise (mito:find-dao 'exercise :id exercise-id))) + (when exercise + (exercise-muscle-group exercise)))) + +(defun process-session-progression (session) + "Process all set records from a completed session and compute progression. +Returns a list of progression-result structs (one per exercise). +For exercises with multiple sets, uses the LAST set to determine progression +(Mentzer: the final set to failure is what counts)." + (let* ((session-id (mito:object-id session)) + (records (mito:select-dao 'set-record + (sxql:where (:= :session-id session-id)) + (sxql:order-by (:asc :exercise-id) (:asc :set-number)))) + ;; Group records by exercise, keep last set per exercise + (exercise-last-sets (make-hash-table)) + (results '())) + ;; Find the last (highest set-number) record for each exercise + (dolist (rec records) + (let ((eid (set-record-exercise-id rec))) + (let ((existing (gethash eid exercise-last-sets))) + (when (or (null existing) + (> (set-record-set-number rec) + (set-record-set-number existing))) + (setf (gethash eid exercise-last-sets) rec))))) + ;; Evaluate progression for each exercise + (maphash + (lambda (exercise-id last-set) + (let* ((status (evaluate-set last-set)) + (muscle-group (get-exercise-muscle-group exercise-id)) + (current-weight (or (set-record-actual-weight last-set) + (set-record-prescribed-weight last-set))) + (new-weight (compute-next-weight current-weight status muscle-group)) + (exercise (mito:find-dao 'exercise :id exercise-id))) + (push (make-progression-result + :exercise-id exercise-id + :exercise-name (when exercise (exercise-name exercise)) + :muscle-group muscle-group + :old-weight current-weight + :new-weight new-weight + :status status + :actual-reps (set-record-actual-reps last-set) + :rep-range-high (set-record-prescribed-rep-high last-set)) + results))) + exercise-last-sets) + ;; Return sorted by exercise-id for consistency + (sort results #'< :key #'progression-result-exercise-id))) + +;;; --- Progression Formatting --- + +(defun format-progression-result (result) + "Format a single progression result in Mentzer's voice." + (case (progression-result-status result) + (:increase + (format nil "~A: ~A reps achieved. The resistance will increase to ~A kg." + (progression-result-exercise-name result) + (progression-result-actual-reps result) + (round (progression-result-new-weight result)))) + (:maintain + (format nil "~A: ~A reps. Maintain ~A kg. Continue to push for ~A." + (progression-result-exercise-name result) + (progression-result-actual-reps result) + (round (progression-result-old-weight result)) + (progression-result-rep-range-high result))) + (:stall + (format nil "~A: ~A reps — below the prescribed range. This is not a weight problem. This is a recovery problem." + (progression-result-exercise-name result) + (progression-result-actual-reps result))) + (otherwise ""))) + +(defun format-session-progression (results) + "Format all progression results from a session." + (with-output-to-string (out) + (format out "~%=== Progression Analysis ===~%~%") + (dolist (r results) + (format out " ~A~%" (format-progression-result r))) + ;; Summary + (let ((increases (count :increase results :key #'progression-result-status)) + (stalls (count :stall results :key #'progression-result-status))) + (format out "~%") + (when (plusp increases) + (format out " Weight increased on ~D exercise~:P.~%" increases)) + (when (plusp stalls) + (format out " ~D stall~:P detected. Extended recovery is indicated.~%" stalls))))) diff --git a/src/recovery.lisp b/src/recovery.lisp new file mode 100644 index 0000000..c4edabd --- /dev/null +++ b/src/recovery.lisp @@ -0,0 +1,180 @@ +(in-package #:hito) + +;;; --- Recovery Gating System --- +;;; +;;; "The muscles DO NOT grow during training. They grow during REST. +;;; If you are not making progress, you are not overtraining — +;;; you are under-recovering." +;;; +;;; Recovery is not optional. It is where growth occurs. The system enforces +;;; minimum rest periods and extends them when stalls indicate incomplete recovery. + +;;; --- Recovery Configuration --- + +(defparameter *base-recovery-days* 3 + "Minimum rest days between training sessions (Mentzer's HD I starting point).") + +(defparameter *stall-extension-days* 2 + "Additional rest days added when a stall is detected in recent sessions.") + +(defparameter *consecutive-stall-extension-days* 3 + "Additional rest days for consecutive stalls across sessions of the same day.") + +(defparameter *max-recovery-days* 14 + "Maximum recovery period before the system suggests program reassessment.") + +;;; --- Recovery Calculation --- + +(defun count-recent-stalls (workout-day &optional (lookback 2)) + "Count sessions of WORKOUT-DAY in the last LOOKBACK completed sessions +that had at least one stall." + (let* ((sessions (mito:select-dao 'training-session + (sxql:where (:and (:= :workout-day workout-day) + (:= :completed-p 1))) + (sxql:order-by (:desc :session-date)) + (sxql:limit lookback))) + (stall-count 0)) + (dolist (session sessions) + (let ((records (mito:select-dao 'set-record + (sxql:where (:= :session-id (mito:object-id session)))))) + (when (some (lambda (rec) + (let ((actual (set-record-actual-reps rec)) + (low (set-record-prescribed-rep-low rec))) + (and actual (< actual low)))) + records) + (incf stall-count)))) + stall-count)) + +(defun calculate-recovery-days (&optional session) + "Calculate the required recovery days based on recent performance. +If SESSION is provided, uses its workout-day for stall analysis. +Otherwise uses the user's current workout day. + +Returns (values days reason) where reason explains the calculation." + (let* ((workout-day (if session + (training-session-workout-day session) + (let ((profile (first (mito:select-dao 'user-profile)))) + (if profile + (user-profile-current-workout-day profile) + 1)))) + (stalls (count-recent-stalls workout-day)) + (base *base-recovery-days*) + (extension (cond + ((>= stalls 2) + *consecutive-stall-extension-days*) + ((>= stalls 1) + *stall-extension-days*) + (t 0))) + (total (min (+ base extension) *max-recovery-days*)) + (reason (cond + ((>= stalls 2) + (format nil "Consecutive stalls detected across recent sessions of Day ~D. ~ + Extended recovery is not merely suggested — it is required. ~ + Growth occurs during rest." workout-day)) + ((>= stalls 1) + (format nil "A stall was detected in your last Day ~D session. ~ + Additional recovery time has been prescribed." workout-day)) + (t + (format nil "Standard recovery period between sessions."))))) + (values total reason))) + +;;; --- Recovery Status --- + +(defstruct recovery-status + "Current recovery state for the trainee." + ready-p ; t if they can train + days-remaining ; days until ready (0 if ready) + next-date ; recommended next training date (string) + reason ; explanation text + last-session-date ; when they last trained + recovery-days) ; total prescribed recovery + +(defun parse-date-string (date-str) + "Parse an ISO date string (YYYY-MM-DD) to a local-time timestamp." + (when (and date-str (plusp (length date-str))) + (local-time:parse-timestring date-str))) + +(defun format-date (timestamp) + "Format a local-time timestamp as YYYY-MM-DD." + (local-time:format-timestring nil timestamp :format '(:year "-" (:month 2) "-" (:day 2)))) + +(defun days-since (date-string) + "Return the number of days elapsed since DATE-STRING (YYYY-MM-DD format)." + (let ((then (parse-date-string date-string)) + (now (local-time:now))) + (when then + (let ((diff (local-time:timestamp-difference now then))) + (floor diff 86400))))) ; seconds -> days + +(defun add-days-to-date (date-string days) + "Add DAYS to a date string, return new date string." + (let ((timestamp (parse-date-string date-string))) + (when timestamp + (format-date (local-time:timestamp+ timestamp days :day))))) + +(defun recovery-status () + "Compute the current recovery status for the trainee. +Returns a recovery-status struct." + (let* ((last-session (first (mito:select-dao 'training-session + (sxql:where (:= :completed-p 1)) + (sxql:order-by (:desc :session-date)) + (sxql:limit 1))))) + (if (null last-session) + ;; No sessions yet — ready to train + (make-recovery-status + :ready-p t + :days-remaining 0 + :next-date (format-date (local-time:now)) + :reason "No previous sessions recorded. You are ready to begin." + :last-session-date nil + :recovery-days 0) + ;; Calculate based on last session + (let* ((last-date (training-session-session-date last-session)) + (elapsed (days-since last-date))) + (multiple-value-bind (required-days reason) + (calculate-recovery-days last-session) + (let* ((remaining (max 0 (- required-days elapsed))) + (ready (zerop remaining)) + (next-date (if ready + (format-date (local-time:now)) + (add-days-to-date last-date required-days)))) + (make-recovery-status + :ready-p ready + :days-remaining remaining + :next-date next-date + :reason reason + :last-session-date last-date + :recovery-days required-days))))))) + +;;; --- Override Mechanism --- + +(defparameter *override-warning* + "You are overriding the prescribed recovery period. Understand: growth occurs ~ +during rest, not during training. The muscles require time to compensate and ~ +supercompensate. If you train before recovery is complete, you are not merely ~ +wasting effort — you are actively undermining your progress. Proceed only if ~ +you are certain your recovery is complete." + "Warning text displayed when user overrides recovery gate. Mentzer's voice.") + +(defun override-recovery () + "Log that the user has overridden the recovery gate. +Returns the warning text. The session created after this should be marked +with override-p = t." + (format t "~&[OVERRIDE] Recovery gate overridden at ~A~%" + (format-date (local-time:now))) + *override-warning*) + +;;; --- Recovery Formatting --- + +(defun format-recovery-status (status) + "Format recovery status for display." + (with-output-to-string (out) + (if (recovery-status-ready-p status) + (format out "READY. You may train today.") + (format out "RECOVERY IN PROGRESS.~%~ + Days remaining: ~D~%~ + Next session: ~A~%~ + ~A" + (recovery-status-days-remaining status) + (recovery-status-next-date status) + (recovery-status-reason status))))) diff --git a/src/routes.lisp b/src/routes.lisp new file mode 100644 index 0000000..10d1a51 --- /dev/null +++ b/src/routes.lisp @@ -0,0 +1,411 @@ +(in-package #:hito) + +;;; --- Template Setup --- +;;; Must happen before any template compilation in routes.lisp + +(djula:add-template-directory + (asdf:system-relative-pathname "hito" "templates/")) + +;;; --- Template Compilation --- + +(defvar *template-base* (djula:compile-template* "base.html")) +(defvar *template-setup* (djula:compile-template* "setup.html")) +(defvar *template-session* (djula:compile-template* "session.html")) +(defvar *template-session-complete* (djula:compile-template* "session-complete.html")) +(defvar *template-dashboard* (djula:compile-template* "dashboard.html")) +(defvar *template-override* (djula:compile-template* "override.html")) +(defvar *template-exercises* (djula:compile-template* "exercises.html")) + +;;; --- Helper: Check if user has completed setup --- + +(defun user-setup-complete-p () + "Return T if a user profile exists (setup has been completed)." + (plusp (mito:count-dao 'user-profile))) + +;;; --- Helper: Get exercises grouped by workout day --- + +(defun get-exercises-by-day () + "Return exercises grouped by workout day for the setup form. +Each day entry has :number, :name, and :exercises (list of id/name pairs)." + (loop for day-def in *hd1-program* + collect + (let* ((day-num (getf day-def :day)) + (day-name (getf day-def :name)) + (day-exercises '())) + ;; Walk the program structure to get exercise names in order + (dolist (group (getf day-def :exercises)) + (dolist (ex-def (second group)) + (let* ((name (getf ex-def :name)) + (exercise (find-exercise-by-name name))) + (when exercise + (push (list :id (mito:object-id exercise) + :name name) + day-exercises))))) + (list :number day-num + :name day-name + :exercises (nreverse day-exercises))))) + +;;; --- Routes --- + +;;; Root: redirect to setup if no profile, otherwise show dashboard +(hunchentoot:define-easy-handler (index :uri "/") () + (unless (user-setup-complete-p) + (hunchentoot:redirect "/setup") + (return-from index nil)) + (let* ((profile (first (mito:select-dao 'user-profile))) + (workout-day (user-profile-current-workout-day profile)) + (day-name (get-workout-day-name workout-day)) + (status (recovery-status)) + (ready (recovery-status-ready-p status)) + ;; Recent sessions (last 5) + (recent-sessions (mito:select-dao 'training-session + (sxql:where (:= :completed-p 1)) + (sxql:order-by (:desc :session-date)) + (sxql:limit 5))) + (session-entries + (mapcar (lambda (s) + (list :date (training-session-session-date s) + :day (training-session-workout-day s) + :day_name (get-workout-day-name + (training-session-workout-day s)) + :override (training-session-override-p s))) + ;; Filter out baseline sessions + (remove-if (lambda (s) + (let ((notes (training-session-notes s))) + (and notes (search "Baseline" notes)))) + recent-sessions)))) + (setf (hunchentoot:content-type*) "text/html") + (djula:render-template* *template-dashboard* nil + :ready ready + :next_day workout-day + :next_day_name day-name + :days_remaining (recovery-status-days-remaining status) + :days_plural (if (= (recovery-status-days-remaining status) 1) + "" "s") + :next_date (recovery-status-next-date status) + :reason (recovery-status-reason status) + :has_history (not (null session-entries)) + :sessions session-entries))) + +;;; Setup GET: show the experience level selection +(hunchentoot:define-easy-handler (setup-page :uri "/setup") () + (when (user-setup-complete-p) + (hunchentoot:redirect "/") + (return-from setup-page nil)) + (setf (hunchentoot:content-type*) "text/html") + (djula:render-template* *template-setup* nil)) + +;;; Setup POST: process level selection and create user profile with starting weights +(hunchentoot:define-easy-handler (setup-submit :uri "/setup/submit" + :default-request-type :post) () + (let* ((params (hunchentoot:post-parameters*)) + (level-str (or (cdr (assoc "level" params :test #'string=)) "beginner")) + (level (cond ((string= level-str "intermediate") :intermediate) + ((string= level-str "advanced") :advanced) + (t :beginner))) + (today (local-time:format-timestring nil (local-time:now) + :format '(:year "-" (:month 2) "-" (:day 2))))) + ;; Create user profile + (mito:create-dao 'user-profile + :name "Trainee" + :current-workout-day 1 + :last-session-date nil + :training-start-date today) + ;; Store starting weights as baseline sessions (backdated to avoid recovery gate) + (let ((baseline-date (local-time:format-timestring nil + (local-time:timestamp- (local-time:now) 30 :day) + :format '(:year "-" (:month 2) "-" (:day 2))))) + (loop for day from 1 to 4 + do (let ((baseline-session + (mito:create-dao 'training-session + :session-date baseline-date + :workout-day day + :completed-p t + :notes "Baseline weights from setup" + :override-p nil))) + (dolist (group (getf (get-workout-day day) :exercises)) + (dolist (ex-def (second group)) + (let* ((name (getf ex-def :name)) + (exercise (find-exercise-by-name name)) + (exercise-id (when exercise (mito:object-id exercise))) + (weight (get-starting-weight name level))) + (when (and exercise-id weight) + (loop for set-num from 1 to (getf ex-def :sets) + do (mito:create-dao 'set-record + :session-id (mito:object-id baseline-session) + :exercise-id exercise-id + :set-number set-num + :prescribed-weight (coerce weight 'double-float) + :prescribed-rep-low 6 + :prescribed-rep-high 10 + :actual-weight (coerce weight 'double-float) + :actual-reps 8 + :to-failure-p t))))))))) + ;; Redirect to dashboard + (hunchentoot:redirect "/"))) + +;;; --- Utility --- + +(defun parse-float (string) + "Parse a string as a float. Returns nil on failure." + (handler-case + (let ((val (read-from-string string))) + (when (numberp val) (coerce val 'double-float))) + (error () nil))) + +(defun parse-int (string) + "Parse a string as an integer. Returns nil on failure." + (handler-case + (parse-integer string :junk-allowed t) + (error () nil))) + +;;; --- Override Routes --- + +;;; Override GET: show confirmation page with warning +(hunchentoot:define-easy-handler (override-page :uri "/override") () + (unless (user-setup-complete-p) + (hunchentoot:redirect "/setup") + (return-from override-page nil)) + (let ((status (recovery-status))) + (when (recovery-status-ready-p status) + ;; Already ready, no override needed + (hunchentoot:redirect "/") + (return-from override-page nil)) + (setf (hunchentoot:content-type*) "text/html") + (djula:render-template* *template-override* nil + :warning *override-warning* + :days_remaining (recovery-status-days-remaining status) + :next_date (recovery-status-next-date status)))) + +;;; Override POST: confirm override and redirect to session +(hunchentoot:define-easy-handler (override-confirm :uri "/override/confirm" + :default-request-type :post) () + (override-recovery) + (hunchentoot:redirect "/session")) + +;;; --- Exercise Routes --- + +(defun get-substitution-options-for (canonical-id) + "Get available substitution exercises for a canonical exercise. +Returns non-canonical exercises with the same muscle group." + (let ((canonical (mito:find-dao 'exercise :id canonical-id))) + (when canonical + (let ((muscle-group (exercise-muscle-group canonical))) + ;; Find all non-default exercises in the same muscle group + ;; that aren't currently active as substitutions for OTHER exercises + (remove-if + (lambda (ex) + (or (= (mito:object-id ex) canonical-id) + (exercise-is-default-p ex))) + (mito:select-dao 'exercise + (sxql:where (:and (:= :muscle-group muscle-group) + (:= :is-default-p 0))))))))) + +(defun build-exercises-page-data () + "Build the data structure for the exercises template." + (loop for day-def in *hd1-program* + collect + (let* ((day-num (getf day-def :day)) + (day-name (getf day-def :name)) + (slots '())) + (dolist (group (getf day-def :exercises)) + (dolist (ex-def (second group)) + (let* ((canonical-name (getf ex-def :name)) + (canonical (find-exercise-by-name canonical-name)) + (canonical-id (when canonical (mito:object-id canonical))) + (active (when canonical + (find-active-exercise-for-slot canonical-name))) + (active-id (when active (mito:object-id active))) + (active-name (when active (exercise-name active))) + (has-sub (and active canonical + (/= active-id canonical-id))) + (options (when canonical-id + (mapcar (lambda (ex) + (list :id (mito:object-id ex) + :name (exercise-name ex))) + (get-substitution-options-for canonical-id))))) + (push (list :canonical_name canonical-name + :canonical_id canonical-id + :active_name active-name + :active_id active-id + :has_substitute has-sub + :options options) + slots)))) + (list :number day-num + :name day-name + :slots (nreverse slots))))) + +;;; Exercises GET: show exercise configuration page +(hunchentoot:define-easy-handler (exercises-page :uri "/exercises") () + (unless (user-setup-complete-p) + (hunchentoot:redirect "/setup") + (return-from exercises-page nil)) + (setf (hunchentoot:content-type*) "text/html") + (djula:render-template* *template-exercises* nil + :days (build-exercises-page-data))) + +;;; Exercises swap POST: activate a substitution +(hunchentoot:define-easy-handler (exercises-swap :uri "/exercises/swap" + :default-request-type :post) () + (let* ((params (hunchentoot:post-parameters*)) + (canonical-id-str (cdr (assoc "canonical-id" params :test #'string=))) + (substitute-id-str (cdr (assoc "substitute-id" params :test #'string=))) + (canonical-id (parse-int canonical-id-str)) + (substitute-id (parse-int substitute-id-str))) + (when canonical-id + ;; Clear any existing substitution for this canonical exercise + (let ((existing-subs (mito:select-dao 'exercise + (sxql:where (:= :substitution-for canonical-id))))) + (dolist (ex existing-subs) + (setf (exercise-substitution-for ex) nil) + (mito:save-dao ex))) + ;; If substitute-id is non-zero and different from canonical, activate it + (when (and substitute-id (plusp substitute-id) + (/= substitute-id canonical-id)) + (let ((substitute (mito:find-dao 'exercise :id substitute-id))) + (when substitute + (setf (exercise-substitution-for substitute) canonical-id) + (mito:save-dao substitute)))))) + (hunchentoot:redirect "/exercises")) + +;;; --- Session Helpers --- + +(defun build-session-groups (workout-day) + "Build the template data structure for displaying a workout session. +Returns a list of groups, each with :type and :exercises." + (let ((day-def (get-workout-day workout-day)) + (groups '()) + (field-counter 0)) + (dolist (group (getf day-def :exercises)) + (let* ((group-type (first group)) + (group-exercises '())) + (dolist (ex-def (second group)) + (let* ((canonical-name (getf ex-def :name)) + (active-exercise (find-active-exercise-for-slot canonical-name)) + (exercise-id (when active-exercise (mito:object-id active-exercise))) + (exercise-name (if active-exercise + (exercise-name active-exercise) + canonical-name)) + (target-weight (when exercise-id + (get-prescribed-weight-for-exercise + exercise-id workout-day))) + (set-count (getf ex-def :sets)) + (sets '())) + ;; Build set entries + (loop for s from 1 to set-count + do (incf field-counter) + (push (list :number s + :field_key field-counter) + sets)) + (push (list :id exercise-id + :name exercise-name + :target_weight (if target-weight (round target-weight) 0) + :rep_low (getf ex-def :rep-low) + :rep_high (getf ex-def :rep-high) + :sets (nreverse sets)) + group-exercises))) + (push (list :type (if (eq group-type :superset) "superset" "straight") + :exercises (nreverse group-exercises)) + groups))) + (nreverse groups))) + +;;; --- Session Routes --- + +;;; Session GET: display the prescribed workout +(hunchentoot:define-easy-handler (session-page :uri "/session") () + (unless (user-setup-complete-p) + (hunchentoot:redirect "/setup") + (return-from session-page nil)) + (let* ((profile (first (mito:select-dao 'user-profile))) + (workout-day (user-profile-current-workout-day profile)) + (day-name (get-workout-day-name workout-day)) + (groups (build-session-groups workout-day))) + (setf (hunchentoot:content-type*) "text/html") + (djula:render-template* *template-session* nil + :day_number workout-day + :day_name day-name + :groups groups))) + +;;; Session POST: process submitted workout results +(hunchentoot:define-easy-handler (session-submit :uri "/session/submit" + :default-request-type :post) () + (let* ((params (hunchentoot:post-parameters*)) + (profile (first (mito:select-dao 'user-profile))) + (workout-day (user-profile-current-workout-day profile)) + (today (local-time:format-timestring nil (local-time:now) + :format '(:year "-" (:month 2) "-" (:day 2)))) + ;; Check if this was an override + (status (recovery-status)) + (is-override (not (recovery-status-ready-p status)))) + ;; Create the training session + (let ((session (mito:create-dao 'training-session + :session-date today + :workout-day workout-day + :completed-p t + :override-p is-override))) + ;; Parse all set records from form params + (let ((field-counter 0)) + (dolist (group (getf (get-workout-day workout-day) :exercises)) + (dolist (ex-def (second group)) + (loop for s from 1 to (getf ex-def :sets) + do (incf field-counter) + (let* ((key (format nil "~D" field-counter)) + (exercise-id-str (cdr (assoc (format nil "exercise-id-~A" key) + params :test #'string=))) + (actual-weight-str (cdr (assoc (format nil "actual-weight-~A" key) + params :test #'string=))) + (actual-reps-str (cdr (assoc (format nil "actual-reps-~A" key) + params :test #'string=))) + (prescribed-weight-str (cdr (assoc (format nil "prescribed-weight-~A" key) + params :test #'string=))) + (to-failure-str (cdr (assoc (format nil "to-failure-~A" key) + params :test #'string=))) + (exercise-id (parse-int exercise-id-str)) + (actual-weight (parse-float actual-weight-str)) + (actual-reps (parse-int actual-reps-str)) + (prescribed-weight (or (parse-float prescribed-weight-str) 0.0d0)) + (to-failure (not (null to-failure-str)))) + (when (and exercise-id actual-weight actual-reps) + (mito:create-dao 'set-record + :session-id (mito:object-id session) + :exercise-id exercise-id + :set-number s + :prescribed-weight prescribed-weight + :prescribed-rep-low 6 + :prescribed-rep-high 10 + :actual-weight actual-weight + :actual-reps actual-reps + :to-failure-p to-failure))))))) + ;; Run progression engine + (let ((progression-results (process-session-progression session))) + ;; Update user profile: advance workout day, update last session date + (let ((next-day (1+ (mod workout-day 4)))) + (when (zerop next-day) (setf next-day 4)) + (setf (user-profile-current-workout-day profile) next-day) + (setf (user-profile-last-session-date profile) today) + (mito:save-dao profile)) + ;; Calculate recovery for display + (let* ((rec-status (recovery-status)) + (increases (count :increase progression-results + :key #'progression-result-status)) + (stalls (count :stall progression-results + :key #'progression-result-status)) + ;; Build template data for results + (result-entries + (mapcar (lambda (r) + (list :exercise_name (progression-result-exercise-name r) + :status (string-downcase + (symbol-name (progression-result-status r))) + :text (format-progression-result r))) + progression-results))) + (setf (hunchentoot:content-type*) "text/html") + (djula:render-template* *template-session-complete* nil + :results result-entries + :has_increases (plusp increases) + :increase_count increases + :increase_plural (if (= increases 1) "" "s") + :has_stalls (plusp stalls) + :stall_count stalls + :stall_plural (if (= stalls 1) "" "s") + :next_date (recovery-status-next-date rec-status) + :recovery_reason (recovery-status-reason rec-status))))))) -- cgit v1.2.3