summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/app.lisp43
-rw-r--r--src/models.lisp186
-rw-r--r--src/package.lisp53
-rw-r--r--src/program.lisp232
-rw-r--r--src/progression.lisp157
-rw-r--r--src/recovery.lisp180
-rw-r--r--src/routes.lisp411
7 files changed, 1262 insertions, 0 deletions
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)))))))
Copyright 2019--2026 Marius PETER