Initial commit, ACM PEARC25 and PEARC26 chosen restaurants work.

Committer: hpcdisrespecter <noreply@git.asperger.pro>

	modified:   .gitignore
	modified:   README.md
	new file:   menus/peoples-organic.sexp
	new file:   menus/townhall-shortnorth.sexp
	new file:   organic-cafe.asd
	new file:   run.lisp
	new file:   src/package.lisp
	new file:   src/planner.lisp
	new file:   test/tests.lisp

.gitignore

@@ -1,25 +1 @@
-# ---> Haskell
-dist
-dist-*
-cabal-dev
-*.o
-*.hi
-*.hie
-*.chi
-*.chs.h
-*.dyn_o
-*.dyn_hi
-.hpc
-.hsenv
-.cabal-sandbox/
-cabal.sandbox.config
-*.prof
-*.aux
-*.hp
-*.eventlog
-.stack-work/
-cabal.project.local
-cabal.project.local~
-.HTF/
-.ghc.environment.*
 

README.md

@@ -1,3 +1,120 @@
 # organicCafe
 
-MC sampling a downtown cafe's menu under the Federal per diem
+~~Practical joke~~ ~~vent art~~ SERIOUS DISCUSSION code for generating multi-day, 
+budget-constrained meal plans from a menu using MC sampling.
+
+- Never make a decision about food at a technical conference again! 
+- Make wait staff feel awkward by ordering as soon as you arrive! 
+- Avoid the temptation to eat the same thing every day!
+
+The menu and meal templates are a small, data-only S-expression DSL.
+
+Shoutout to People's Organic in MSP (Federal per diem: $92, FY2026) and
+TownHall Short North in Columbus ($80, FY2025), the respective off-site ordering adventures
+for ACM PEARC26 and PEARC25.
+
+People's Organic has a small menu and fewer options, whereas TownHall produces 
+a Cartesian product of garnishes. Both are supported in this framework. 
+
+## General Ideas 
+
+Prices are converted to integer cents when loaded, so budget comparisons do
+not rely on floating-point arithmetic. 
+
+For normal generation, the planner computes the weighted number of completions 
+at each remaining budget and samples only branches that can finish beneath the
+cap. This avoids both rejection loops and materializing large Cartesian products.
+
+Any given day, a small pool of feasible days is drawn, and least-repetitive 
+candidates are favored. 
+
+`feasible-candidates` still eagerly enumerates combinations for tests,
+diagnostics, and suitably small menus such as People's Organic.
+
+## Variables
+
+- `--budget DOLLARS` sets the daily per diem. 
+- `--days N` sets the number of days to plan.
+- `--menu FILE` selects a menu file from `menus/`.
+- `--plan PLAN` selects a plan from the menu. If omitted, the first plan is used.
+- `--add-lazy-day DOLLARS` appends a breakfast-only day with its own budget. For outbound flight days. 
+- `--seed N` sets the random seed for reproducibility (don't use this you orthorexic nerd). 
+
+## Usage 
+
+SBCL and ASDF are the only requirements.
+
+```sh
+# PEARC26 default  
+sbcl --script run.lisp
+# the same thing explicitly with seed
+sbcl --script run.lisp -- --budget 92 --days 3 --seed 1337 --add-lazy-day 30
+# PEARC25 default 
+sbcl --script run.lisp -- \
+  --menu menus/townhall-shortnorth.sexp \
+  --budget 80 --add-lazy-day 30 --seed 1337
+```
+
+Use `--help` for all options. 
+
+Ask for help if you need it. Someone will probably answer. 
+
+## Tests 
+
+Run the tests: 
+
+```sh
+sbcl --non-interactive \
+  --eval '(require "asdf")' \
+  --eval '(asdf:load-asd (truename "organic-cafe.asd"))' \
+  --eval '(asdf:test-system "organic-cafe/tests")'
+```
+
+## The DSL
+
+The complete menus live in `menus/` and defaults to `menus/peoples-organic.sexp`. The DSL is a small S-expression language for describing menus and meal plans.
+ 
+`:lazy-day` is a special plan item, for the day you leave town. 
+
+### Basic example
+
+```lisp
+(:menu "A Cafe"
+  (:group :mains
+    (:item "Soup and sandwich" 12.50)
+    (:item "Grain bowl" 14))
+  (:group :drinks
+    (:item "Coffee" 3.25))
+
+  (:plan :lunch
+    (:meal :lunch
+      (:one :main :mains)
+      (:maybe :drink :drinks :chance 1/2))))
+```
+
+`(:one LABEL GROUP)` always chooses one item. `(:maybe LABEL GROUP :chance P)`
+chooses no item with probability `1-P`; if present, each item in the group has
+an equal share of `P`.
+
+### Composable forms 
+
+TownHall's menu has options, so it demonstrates compositional forms:
+
+```lisp
+(:choose :side :bowl-side :count 2)
+
+(:either :meal
+  (:branch 1/2
+    (:one :shared-plate :pour-la-table))
+  (:branch 1/2
+    (:one :protein :bowl-protein)
+    (:one :base :bowl-base)))
+```
+
+`:choose` samples the requested number of distinct items. `:either` selects one
+weighted branch, whose body may contain any number of other plan forms. Branch
+weights must sum to one. `:one` and `:maybe` are also valid. You are also valid.
+
+### License and Sharing
+
+Do what the fuck you want.

menus/peoples-organic.sexp

@@ -0,0 +1,62 @@
+(:menu "People's Organic Cafe"
+  (:group :breakfast-main
+    (:item "Steak and eggs" 21)
+    (:item "Breakfast bowl" 16)
+    (:item "Avocado toast" 17)
+    (:item "Breakfast quesadilla" 17)
+    (:item "Breakfast croissant" 16)
+    (:item "Classic quiche Lorraine" 14)
+    (:item "Seasonal quiche" 11)
+    (:item "Breakfast burrito" 16))
+
+  (:group :lunch-main
+    (:item "Bison burger" 19)
+    (:item "Cheeseburger" 17)
+    (:item "Northern California wrap" 16)
+    (:item "Roasted turkey pesto sandwich" 15)
+    (:item "MN grilled cheese" 12)
+    (:item "Rosemary flatbread" 15))
+
+  (:group :soup
+    (:item "Soup du jour" 6)
+    (:item "Tomato basil soup" 6))
+
+  (:group :dinner-main
+    (:item "Chicken pot pie" 18)
+    (:item "Sesame glazed salmon" 22)
+    (:item "Ahi tuna" 19)
+    (:item "Chicken fried rice (ask for no hemp seeds)" 20)
+    (:item "Street tacos (chicken)" 16)
+    (:item "Street tacos (mahi mahi)" 16))
+
+  (:group :hot-drink
+    (:item "16 oz cafe au lait" 5)
+    (:item "16 oz chai tea" 6.25)
+    (:item "12 oz sweet matcha latte" 6.60)
+    (:item "London fog" 5.10)
+    (:item "Hot cocoa" 5))
+
+  (:group :cold-drink
+    (:item "Ginger green matcha shake" 9.50)
+    (:item "Co-co antioxidant shake" 9.50)
+    (:item "Garden elixir" 6.70)
+    (:item "Green elixir" 6.70)
+    (:item "16 oz cold press" 5.10))
+
+  (:plan :full-day
+    (:meal :breakfast
+      (:one :main :breakfast-main)
+      (:one :hot-drink :hot-drink))
+    (:meal :lunch
+      (:one :main :lunch-main)
+      (:maybe :soup :soup :chance 1/2)
+      (:one :cold-drink :cold-drink))
+    (:meal :dinner
+      (:one :main :dinner-main)
+      (:one :hot-drink :hot-drink)))
+
+  (:plan :lazy-day
+    (:meal :breakfast
+      (:one :main :breakfast-main)
+      (:one :hot-drink :hot-drink)
+      (:one :cold-drink :cold-drink))))

menus/townhall-shortnorth.sexp

@@ -0,0 +1,122 @@
+(:menu "TownHall Short North"
+  ;; Bowl construction
+  (:group :bowl-protein
+    (:item "Organic chicken" 14)
+    (:item "Grass-fed steak" 17)
+    (:item "Braised beef" 16)
+    (:item "Wild salmon" 16)
+    (:item "Wild shrimp" 17))
+
+  (:group :bowl-base
+    (:item "White rice" 0)
+    (:item "Rice noodle" 0)
+    (:item "Bone broth" 0))
+
+  (:group :bowl-addon
+    (:item "Konjac noodle" 1)
+    (:item "Mushrooms" 1)
+    (:item "Shaved Parmesan" 1)
+    (:item "Extra sauce" 0.50)
+    (:item "Extra side" 3))
+
+  (:group :bowl-side
+    (:item "Garlic broccoli" 0)
+    (:item "Charred pineapple" 0)
+    (:item "Grilled vegetables" 0)
+    (:item "Roasted Brussels sprouts" 0)
+    (:item "Smashed avocado" 0)
+    (:item "Kimchi slaw" 0)
+    (:item "Scrambled eggs" 0))
+
+  (:group :bowl-sauce
+    (:item "Bang bang" 0)
+    (:item "Rosemary aioli" 0)
+    (:item "Korean BBQ" 0)
+    (:item "Togarashi aioli" 0))
+
+  (:group :bowl-garnish
+    (:item "Scallions" 0)
+    (:item "Red onion" 0))
+
+  ;; Broth construction
+  (:group :broth-size
+    (:item "12 oz" 3.75))
+
+  (:group :broth-type
+    (:item "Chicken bone broth" 0)
+    (:item "Beef bone broth" 0))
+
+  (:group :broth-addon
+    (:item "Garlic" 0.50)
+    (:item "Onions" 0.50)
+    (:item "Scallions" 0.50)
+    (:item "Konjac noodles" 1)
+    (:item "Mushrooms" 1)
+    (:item "Chicken" 2))
+
+  (:group :pour-la-table
+    (:item "Truffle fries" 9)
+    (:item "Steak bites" 18)
+    (:item "Roasted Brussels sprouts" 6)
+    (:item "Garlic broccoli" 5)
+    (:item "Red sauce flatbread" 13))
+
+  (:group :dessert
+    (:item "Acai bowl" 8)
+    (:item "Energy bites" 8))
+
+  (:group :juice
+    (:item "Citrus" 5)
+    (:item "Pineapple" 5)
+    (:item "Wheatgrass" 5))
+
+  (:group :smoothie
+    (:item "Keto power" 10)
+    (:item "Leg day (no flax)" 8)
+    (:item "Keto cacao" 8))
+
+  (:group :hot-drink
+    (:item "Original" 5)
+    (:item "Honey latte" 5)
+    (:item "Keto nootropic" 6))
+
+  (:group :iced-drink
+    (:item "Kombucha" 5)
+    (:item "Coconut water" 6))
+
+  (:plan :full-day
+    (:meal :breakfast
+      (:one :smoothie :smoothie)
+      (:one :hot-drink :hot-drink)
+      (:one :dessert :dessert))
+
+    (:meal :lunch
+      (:one :protein :bowl-protein)
+      (:one :base :bowl-base)
+      (:choose :side :bowl-side :count 2)
+      (:one :sauce :bowl-sauce)
+      (:choose :garnish :bowl-garnish :count 2)
+      (:one :hot-drink :hot-drink)
+      (:one :cold-drink :iced-drink))
+
+    (:meal :dinner
+      (:either :meal
+        (:branch 1/2
+          (:one :shared-plate :pour-la-table))
+        (:branch 1/2
+          (:one :protein :bowl-protein)
+          (:one :base :bowl-base)
+          (:choose :side :bowl-side :count 2)
+          (:one :sauce :bowl-sauce)
+          (:choose :garnish :bowl-garnish :count 2)))
+      (:one :broth-size :broth-size)
+      (:one :broth-type :broth-type)
+      (:one :cold-drink :iced-drink)
+      (:one :dessert :dessert)))
+
+  (:plan :lazy-day
+    (:meal :breakfast
+      (:one :smoothie :smoothie)
+      (:one :hot-drink :hot-drink)
+      (:one :cold-drink :iced-drink)
+      (:one :dessert :dessert))))

organic-cafe.asd

@@ -0,0 +1,15 @@
+(asdf:defsystem "organic-cafe"
+  :description "A small S-expression DSL and budget-aware cafe meal planner."
+  :version "0.1.0"
+  :license "WTFPL-2.0"
+  :serial t
+  :components ((:file "src/package")
+               (:file "src/planner")))
+
+(asdf:defsystem "organic-cafe/tests"
+  :depends-on ("organic-cafe")
+  :serial t
+  :components ((:file "test/tests"))
+  :perform (asdf:test-op (operation component)
+             (declare (ignore operation component))
+             (uiop:symbol-call :organic-cafe/tests :run-tests)))

run.lisp

@@ -0,0 +1,17 @@
+(require "asdf")
+
+(let* ((script (or *load-truename* *compile-file-truename*))
+       (root (uiop:pathname-directory-pathname script))
+       (default-menu (merge-pathnames "menus/peoples-organic.sexp" root)))
+  ;; Loading source here keeps the CLI read-only.  The ASDF system remains
+  ;; available for compiled development and test workflows.
+  (load (merge-pathnames "src/package.lisp" root))
+  (load (merge-pathnames "src/planner.lisp" root))
+  (handler-case
+      (uiop:quit
+       (uiop:symbol-call :organic-cafe :run-cli
+                         (rest sb-ext:*posix-argv*)
+                         :default-menu default-menu))
+    (error (condition)
+      (format *error-output* "Error: ~A~%" condition)
+      (uiop:quit 1))))

src/package.lisp

@@ -0,0 +1,7 @@
+(defpackage #:organic-cafe
+  (:use #:cl)
+  (:export #:load-menu
+           #:feasible-candidates
+           #:generate-plans
+           #:print-candidate
+           #:run-cli))

src/planner.lisp

@@ -0,0 +1,569 @@
+(in-package #:organic-cafe)
+
+(defstruct item
+  name
+  price
+  group)
+
+(defstruct plan-slot
+  label
+  group
+  (count 1)
+  (chance 1))
+
+(defstruct plan-branch
+  weight
+  nodes)
+
+(defstruct plan-either
+  label
+  branches)
+
+(defstruct meal
+  name
+  slots)
+
+(defstruct cafe-plan
+  name
+  meals)
+
+(defstruct cafe-menu
+  name
+  groups
+  plans)
+
+(defstruct selection
+  meal
+  label
+  item)
+
+(defstruct candidate
+  selections
+  total
+  weight)
+
+(defstruct choice-option
+  selections
+  cost
+  weight)
+
+(defun dollars-to-cents (value)
+  (unless (and (realp value) (not (minusp value)))
+    (error "Price must be a non-negative number, got ~S." value))
+  (round (* value 100)))
+
+(defun ensure-keyword (value description)
+  (unless (keywordp value)
+    (error "~A must be a keyword, got ~S." description value))
+  value)
+
+(defun parse-item (form group)
+  (destructuring-bind (operator name price) form
+    (unless (eql operator :item)
+      (error "Expected (:item name price), got ~S." form))
+    (unless (stringp name)
+      (error "Item name must be a string, got ~S." name))
+    (make-item :name name
+               :price (dollars-to-cents price)
+               :group group)))
+
+(defun parse-group (form groups)
+  (destructuring-bind (operator name &rest item-forms) form
+    (unless (eql operator :group)
+      (error "Expected a :group form, got ~S." form))
+    (ensure-keyword name "Group name")
+    (when (gethash name groups)
+      (error "Duplicate group ~S." name))
+    (unless item-forms
+      (error "Group ~S has no items." name))
+    (setf (gethash name groups)
+          (mapcar (lambda (item-form)
+                    (parse-item item-form name))
+                  item-forms))))
+
+(defun parse-slot (form)
+  (destructuring-bind (operator label group &rest options) form
+    (unless (member operator '(:one :maybe :choose))
+      (error "Expected :one, :maybe, or :choose, got ~S." operator))
+    (ensure-keyword label "Slot label")
+    (ensure-keyword group "Slot group")
+    (when (oddp (length options))
+      (error "Malformed options in ~S." form))
+    (let ((chance (if (eql operator :maybe)
+                      (getf options :chance 1/2)
+                      1))
+          (count (if (eql operator :choose)
+                     (getf options :count)
+                     1)))
+      (unless (and (realp chance) (<= 0 chance 1))
+        (error "Chance must be between zero and one, got ~S." chance))
+      (unless (and (integerp count) (plusp count))
+        (error ":choose requires a positive integer :count, got ~S." count))
+      (make-plan-slot :label label
+                      :group group
+                      :count count
+                      :chance chance))))
+
+(defun parse-node (form)
+  (case (first form)
+    ((:one :maybe :choose)
+     (parse-slot form))
+    (:either
+     (destructuring-bind (operator label &rest branch-forms) form
+       (declare (ignore operator))
+       (ensure-keyword label "Either label")
+       (unless branch-forms
+         (error "Either ~S has no branches." label))
+       (let ((branches
+               (mapcar
+                (lambda (branch-form)
+                  (destructuring-bind
+                      (branch-operator weight &rest node-forms)
+                      branch-form
+                    (unless (eql branch-operator :branch)
+                      (error "Expected a :branch form, got ~S." branch-form))
+                    (unless (and (realp weight) (plusp weight))
+                      (error "Branch weight must be positive, got ~S." weight))
+                    (unless node-forms
+                      (error "A branch in ~S is empty." label))
+                    (make-plan-branch
+                     :weight weight
+                     :nodes (mapcar #'parse-node node-forms))))
+                branch-forms)))
+         (unless (= (reduce #'+ branches
+                            :key #'plan-branch-weight)
+                    1)
+           (error "Branch weights in ~S must sum to one." label))
+         (make-plan-either :label label :branches branches))))
+    (otherwise
+     (error "Unknown plan node ~S." form))))
+
+(defun parse-meal (form)
+  (destructuring-bind (operator name &rest slot-forms) form
+    (unless (eql operator :meal)
+      (error "Expected a :meal form, got ~S." form))
+    (ensure-keyword name "Meal name")
+    (unless slot-forms
+      (error "Meal ~S has no slots." name))
+    (make-meal :name name :slots (mapcar #'parse-node slot-forms))))
+
+(defun parse-plan (form)
+  (destructuring-bind (operator name &rest meal-forms) form
+    (unless (eql operator :plan)
+      (error "Expected a :plan form, got ~S." form))
+    (ensure-keyword name "Plan name")
+    (unless meal-forms
+      (error "Plan ~S has no meals." name))
+    (make-cafe-plan :name name :meals (mapcar #'parse-meal meal-forms))))
+
+(defun validate-node-groups (node plan groups)
+  (etypecase node
+    (plan-slot
+     (let ((items (gethash (plan-slot-group node) groups)))
+       (unless items
+         (error "Plan ~S refers to unknown group ~S."
+                (cafe-plan-name plan)
+                (plan-slot-group node)))
+       (when (> (plan-slot-count node) (length items))
+         (error "Plan ~S chooses ~D items from group ~S, which has only ~D."
+                (cafe-plan-name plan)
+                (plan-slot-count node)
+                (plan-slot-group node)
+                (length items)))))
+    (plan-either
+     (dolist (branch (plan-either-branches node))
+       (dolist (child (plan-branch-nodes branch))
+         (validate-node-groups child plan groups))))))
+
+(defun validate-plan-groups (plans groups)
+  (maphash
+   (lambda (plan-name plan)
+     (declare (ignore plan-name))
+     (dolist (meal (cafe-plan-meals plan))
+       (dolist (node (meal-slots meal))
+         (validate-node-groups node plan groups))))
+   plans))
+
+(defun load-menu (pathname)
+  "Read and validate one data-only cafe menu DSL file."
+  (let ((*read-eval* nil))
+    (with-open-file (stream pathname :direction :input)
+      (let ((form (read stream nil :eof))
+            (trailing (read stream nil :eof)))
+        (when (eql form :eof)
+          (error "Menu file ~A is empty." pathname))
+        (unless (eql trailing :eof)
+          (error "Menu file must contain exactly one top-level form."))
+        (destructuring-bind (operator name &rest clauses) form
+          (unless (and (eql operator :menu) (stringp name))
+            (error "Menu must start with (:menu \"name\" ...)."))
+          (let ((groups (make-hash-table :test #'eq))
+                (plans (make-hash-table :test #'eq)))
+            (dolist (clause clauses)
+              (case (first clause)
+                (:group (parse-group clause groups))
+                (:plan
+                 (let ((plan (parse-plan clause)))
+                   (when (gethash (cafe-plan-name plan) plans)
+                     (error "Duplicate plan ~S." (cafe-plan-name plan)))
+                   (setf (gethash (cafe-plan-name plan) plans) plan)))
+                (otherwise
+                 (error "Unknown menu clause ~S." clause))))
+            (when (zerop (hash-table-count plans))
+              (error "Menu has no plans."))
+            (validate-plan-groups plans groups)
+            (make-cafe-menu :name name :groups groups :plans plans)))))))
+
+(defun combinations (items count)
+  "Return all distinct COUNT-element combinations of ITEMS."
+  (cond
+    ((zerop count) (list nil))
+    ((endp items) nil)
+    (t
+     (append
+      (mapcar (lambda (tail) (cons (first items) tail))
+              (combinations (rest items) (1- count)))
+      (combinations (rest items) count)))))
+
+(defun slot-options (slot meal-name groups)
+  (let* ((items (gethash (plan-slot-group slot) groups))
+         (choices (combinations items (plan-slot-count slot)))
+         (chance (plan-slot-chance slot))
+         (choice-weight (/ chance (length choices)))
+         (options
+           (mapcar
+            (lambda (chosen)
+              (make-choice-option
+               :selections
+               (mapcar (lambda (item)
+                         (make-selection :meal meal-name
+                                         :label (plan-slot-label slot)
+                                         :item item))
+                       chosen)
+               :cost (reduce #'+ chosen :key #'item-price :initial-value 0)
+               :weight choice-weight))
+            choices)))
+    (if (< chance 1)
+        (cons (make-choice-option :selections nil
+                                  :cost 0
+                                  :weight (- 1 chance))
+              options)
+        options)))
+
+(defun combine-option-lists (left-options right-options)
+  (loop for left in left-options
+        append
+        (loop for right in right-options
+              collect
+              (make-choice-option
+               :selections (append (choice-option-selections left)
+                                   (choice-option-selections right))
+               :cost (+ (choice-option-cost left)
+                        (choice-option-cost right))
+               :weight (* (choice-option-weight left)
+                          (choice-option-weight right))))))
+
+(defun sequence-options (nodes meal-name groups)
+  (reduce (lambda (options node)
+            (combine-option-lists
+             options
+             (node-options node meal-name groups)))
+          nodes
+          :initial-value
+          (list (make-choice-option :selections nil :cost 0 :weight 1))))
+
+(defun node-options (node meal-name groups)
+  (etypecase node
+    (plan-slot
+     (slot-options node meal-name groups))
+    (plan-either
+     (loop for branch in (plan-either-branches node)
+           append
+           (mapcar
+            (lambda (option)
+              (setf (choice-option-weight option)
+                    (* (plan-branch-weight branch)
+                       (choice-option-weight option)))
+              option)
+            (sequence-options (plan-branch-nodes branch)
+                              meal-name
+                              groups))))))
+
+(defun plan-option-lists (plan groups)
+  (loop for meal in (cafe-plan-meals plan)
+        append
+        (loop for node in (meal-slots meal)
+              collect (node-options node (meal-name meal) groups))))
+
+(defun feasible-candidates (menu plan-name budget)
+  "Materialize feasible candidates, intended for diagnostics and small menus."
+  (let* ((budget-cents (dollars-to-cents budget))
+         (plan (gethash plan-name (cafe-menu-plans menu)))
+         (option-lists
+           (and plan
+                (plan-option-lists plan (cafe-menu-groups menu))))
+         (results '()))
+    (unless plan
+      (error "Unknown plan ~S." plan-name))
+    (labels ((walk (remaining selections total weight)
+               (if (endp remaining)
+                   (push (make-candidate
+                          :selections (reverse selections)
+                          :total total
+                          :weight weight)
+                         results)
+                   (dolist (option (first remaining))
+                     (let ((next-total
+                             (+ total (choice-option-cost option))))
+                         (when (<= next-total budget-cents)
+                           (walk (rest remaining)
+                                 (append (reverse
+                                          (choice-option-selections option))
+                                         selections)
+                                 next-total
+                                 (* weight
+                                    (choice-option-weight option)))))))))
+      (walk option-lists '() 0 1)
+      (nreverse results))))
+
+(defun repetition-score (candidate history)
+  (let ((local (make-hash-table :test #'equal))
+        (score 0))
+    (dolist (selection (candidate-selections candidate) score)
+      (let ((name (item-name (selection-item selection))))
+        (incf score (gethash name history 0))
+        (when (gethash name local)
+          (incf score))
+        (setf (gethash name local) t)))))
+
+(defun weighted-choice (candidates state)
+  (let* ((total (loop for candidate in candidates
+                      sum (coerce (candidate-weight candidate)
+                                  'double-float)))
+         (target (random total state)))
+    (dolist (candidate candidates (car (last candidates)))
+      (decf target (coerce (candidate-weight candidate) 'double-float))
+      (when (minusp target)
+        (return candidate)))))
+
+(defun least-repetitive-choice (candidates history state)
+  (let ((best-score nil)
+        (best '()))
+    (dolist (candidate candidates)
+      (let ((score (repetition-score candidate history)))
+        (cond
+          ((or (null best-score) (< score best-score))
+           (setf best-score score
+                 best (list candidate)))
+          ((= score best-score)
+           (push candidate best)))))
+    (weighted-choice best state)))
+
+(defun remember-candidate (candidate history)
+  (dolist (selection (candidate-selections candidate))
+    (incf (gethash (item-name (selection-item selection)) history 0))))
+
+(defun make-conditioned-sampler (option-lists budget-cents state)
+  "Return a sampler weighted by choices that fit within BUDGET-CENTS."
+  (let* ((options (coerce option-lists 'vector))
+         (count (length options))
+         (memo (make-hash-table :test #'equal)))
+    (labels
+        ((partition (index remaining)
+           (if (= index count)
+               1.0d0
+               (let ((key (cons index remaining)))
+                 (multiple-value-bind (cached present-p) (gethash key memo)
+                   (if present-p
+                       cached
+                       (setf
+                        (gethash key memo)
+                        (loop for option in (aref options index)
+                              for cost = (choice-option-cost option)
+                              when (<= cost remaining)
+                                sum (* (coerce (choice-option-weight option)
+                                               'double-float)
+                                       (partition (1+ index)
+                                                  (- remaining cost)))
+                                  into total
+                              finally (return total))))))))
+         (pick-option (index remaining)
+           (let ((total (partition index remaining)))
+             (when (zerop total)
+               (error "No completion fits within the remaining budget."))
+             (let ((target (random total state))
+                   (fallback nil))
+               (dolist (option (aref options index) fallback)
+                 (when (<= (choice-option-cost option) remaining)
+                   (setf fallback option)
+                   (decf target
+                         (* (coerce (choice-option-weight option)
+                                    'double-float)
+                            (partition (1+ index)
+                                       (- remaining
+                                          (choice-option-cost option)))))
+                   (when (minusp target)
+                     (return option))))))))
+      (let ((total-weight (partition 0 budget-cents)))
+        (values
+         (when (plusp total-weight)
+           (lambda ()
+             (let ((remaining budget-cents)
+                   (selections '())
+                   (total 0))
+               (dotimes (index count)
+                 (let ((option (pick-option index remaining)))
+                   (decf remaining (choice-option-cost option))
+                   (incf total (choice-option-cost option))
+                   (setf selections
+                         (append (reverse
+                                  (choice-option-selections option))
+                                 selections))))
+               (make-candidate :selections (reverse selections)
+                               :total total
+                               :weight 1))))
+         total-weight)))))
+
+(defun generate-plans
+    (menu plan-name budget days
+     &key (state *random-state*) (diversity-pool-size 32))
+  "Generate DAYS budget-conditioned plans, preferring varied candidate pools."
+  (unless (and (integerp days) (plusp days))
+    (error "Days must be a positive integer, got ~S." days))
+  (unless (and (integerp diversity-pool-size)
+               (plusp diversity-pool-size))
+    (error "Diversity pool size must be a positive integer."))
+  (let ((plan (gethash plan-name (cafe-menu-plans menu))))
+    (unless plan
+      (error "Unknown plan ~S." plan-name))
+    (multiple-value-bind (sample total-weight)
+        (make-conditioned-sampler
+         (plan-option-lists plan (cafe-menu-groups menu))
+         (dollars-to-cents budget)
+         state)
+      (declare (ignore total-weight))
+      (unless sample
+        (error "No ~S plan fits within a $~,2F budget."
+               plan-name budget))
+      (let ((history (make-hash-table :test #'equal))
+            (chosen '()))
+        (loop repeat days
+              finally (return (nreverse chosen))
+              do
+                 (let* ((pool
+                          (loop repeat diversity-pool-size
+                                collect (funcall sample)))
+                        (candidate
+                          (least-repetitive-choice pool history state)))
+                   (remember-candidate candidate history)
+                   (push candidate chosen)))))))
+
+(defun display-name (keyword)
+  (string-capitalize
+   (substitute #\Space #\- (symbol-name keyword))))
+
+(defun print-candidate (candidate &key (stream *standard-output*) day budget)
+  (when day
+    (format stream "~&Day ~D~%" day))
+  (let ((current-meal nil))
+    (dolist (selection (candidate-selections candidate))
+      (unless (eql current-meal (selection-meal selection))
+        (setf current-meal (selection-meal selection))
+        (format stream "~A:~%" (display-name current-meal)))
+      (format stream "  ~A: ~A — $~,2F~%"
+              (display-name (selection-label selection))
+              (item-name (selection-item selection))
+              (/ (item-price (selection-item selection)) 100.0))))
+  (format stream "Total: $~,2F" (/ (candidate-total candidate) 100.0))
+  (when budget
+    (format stream "  (remaining: $~,2F)"
+            (- budget (/ (candidate-total candidate) 100.0))))
+  (terpri stream))
+
+(defun read-number (string description)
+  (let ((*read-eval* nil))
+    (multiple-value-bind (value position)
+        (read-from-string string nil nil)
+      (unless (and (realp value) (= position (length string)))
+        (error "~A must be a number, got ~S." description string))
+      value)))
+
+(defun keyword-argument (string)
+  (intern (string-upcase string) :keyword))
+
+(defun usage (&optional (stream *standard-output*))
+  (format stream
+          "Usage: sbcl --script run.lisp [--menu FILE] [--plan NAME]~
+           ~%       [--budget DOLLARS] [--days N]~
+           ~%       [--add-lazy-day DOLLARS]~
+           ~%       [--seed N]~
+           ~%Defaults: menus/peoples-organic.sexp, full-day, $92, 3 days.~%"))
+
+(defun run-cli (arguments &key default-menu)
+  (let ((menu-path default-menu)
+        (plan-name :full-day)
+        (budget 92)
+        (days 3)
+        (lazy-budget 30)
+        (seed nil))
+    (labels ((take-value (option)
+               (unless arguments
+                 (error "~A requires a value." option))
+               (pop arguments)))
+      (loop while arguments
+            for argument = (pop arguments)
+            do (cond
+                 ((string= argument "--"))
+                 ((string= argument "--help")
+                  (usage)
+                  (return-from run-cli 0))
+                 ((string= argument "--menu")
+                  (setf menu-path (take-value argument)))
+                 ((string= argument "--plan")
+                  (setf plan-name
+                        (keyword-argument (take-value argument))))
+                 ((string= argument "--budget")
+                  (setf budget
+                        (read-number (take-value argument) "Budget")))
+                 ((string= argument "--days")
+                  (setf days
+                        (parse-integer (take-value argument)
+                                       :junk-allowed nil)))
+                 ((string= argument "--add-lazy-day")
+                  (setf lazy-budget
+                        (read-number (take-value argument)
+                                     "Lazy-day budget")))
+                 ((string= argument "--seed")
+                  (setf seed
+                        (parse-integer (take-value argument)
+                                       :junk-allowed nil)))
+                 (t (error "Unknown argument ~A." argument)))))
+    (unless menu-path
+      (error "No menu path was supplied."))
+    (when (eql plan-name :lazy-day)
+      (error "The lazy-day plan cannot be selected directly; use --add-lazy-day DOLLARS."))
+    (when (and lazy-budget
+               (not (and (realp lazy-budget) (plusp lazy-budget))))
+      (error "--add-lazy-day must be a positive dollar amount."))
+    (let* ((menu (load-menu menu-path))
+           (state (if seed
+                      (sb-ext:seed-random-state seed)
+                      (make-random-state t)))
+           (plans (generate-plans menu plan-name budget days :state state))
+           (lazy-plans
+             (when lazy-budget
+               (generate-plans menu :lazy-day lazy-budget 1
+                               :state state))))
+      (format t "~&~A — ~A plan, $~,2F daily budget~2%"
+              (cafe-menu-name menu)
+              (display-name plan-name)
+              budget)
+      (loop for candidate in plans
+            for day from 1
+            do (print-candidate candidate :day day :budget budget)
+               (terpri))
+      (loop for candidate in lazy-plans
+            do (format t "~&Lazy Day (outbound)~%")
+               (print-candidate candidate :budget lazy-budget)
+               (terpri))
+      0)))

test/tests.lisp

@@ -0,0 +1,150 @@
+(defpackage #:organic-cafe/tests
+  (:use #:cl)
+  (:export #:run-tests))
+
+(in-package #:organic-cafe/tests)
+
+(defun menu-path (filename)
+  (asdf:system-relative-pathname
+   "organic-cafe"
+   (format nil "menus/~A" filename)))
+
+(defmacro check (form)
+  `(unless ,form
+     (error "Check failed: ~S" ',form)))
+
+(defun selections (candidate meal label)
+  (remove-if-not
+   (lambda (selection)
+     (and (eql meal (organic-cafe::selection-meal selection))
+          (eql label (organic-cafe::selection-label selection))))
+   (organic-cafe::candidate-selections candidate)))
+
+(defun check-within-budget (plans budget-cents)
+  (check
+   (every (lambda (candidate)
+            (<= (organic-cafe::candidate-total candidate) budget-cents))
+          plans)))
+
+(defun test-peoples-organic ()
+  (let* ((menu
+           (organic-cafe:load-menu
+            (menu-path "peoples-organic.sexp")))
+         (candidates
+           ;; test a smaller budget to check filter
+           (organic-cafe:feasible-candidates menu :full-day 85))
+         (plans
+           (organic-cafe:generate-plans
+            menu :full-day 85 3
+            :state (sb-ext:seed-random-state 1337))))
+    (check (= 107168 (length candidates)))
+    (check-within-budget candidates 8500)
+    (check (= 3 (length plans)))
+    (check-within-budget plans 8500)
+    (length candidates)))
+
+(defun test-townhall ()
+  (let* ((menu
+           (organic-cafe:load-menu
+            (menu-path "townhall-shortnorth.sexp")))
+         (plans
+           (organic-cafe:generate-plans
+            menu :full-day 70 3
+            :state (sb-ext:seed-random-state 67)))
+         (lazy-plan
+           (first
+            (organic-cafe:generate-plans
+             menu :lazy-day 30 1
+             :state (sb-ext:seed-random-state 69))))
+         (branch-samples
+           (organic-cafe:generate-plans
+            menu :full-day 100 20
+            :state (sb-ext:seed-random-state 69)
+            :diversity-pool-size 1)))
+    (check (= 3 (length plans)))
+    (check-within-budget plans 7000)
+    (dolist (candidate plans)
+      (check (= 2 (length (selections candidate :lunch :side))))
+      (check (= 2 (length (selections candidate :lunch :garnish))))
+      (check
+       (= 2
+          (length
+           (remove-duplicates
+            (mapcar (lambda (selection)
+                      (organic-cafe::item-name
+                       (organic-cafe::selection-item selection)))
+                    (selections candidate :lunch :side))
+            :test #'string=))))
+      (let ((shared (selections candidate :dinner :shared-plate))
+            (bowl (selections candidate :dinner :protein)))
+        (check (not (and shared bowl)))
+        (check (or shared bowl))
+        (check shared)))
+    (check (<= (organic-cafe::candidate-total lazy-plan) 3000))
+    (check (= 4 (length
+                 (organic-cafe::candidate-selections lazy-plan))))
+    (dolist (candidate branch-samples)
+      (let ((shared (selections candidate :dinner :shared-plate))
+            (bowl (selections candidate :dinner :protein)))
+        (check (not (and shared bowl)))
+        (check (or shared bowl))
+        (when bowl
+          (check (= 2 (length (selections candidate :dinner :side))))
+          (check (= 2 (length
+                       (selections candidate :dinner :garnish)))))))
+    ;; At a roomy budget, both weighted dinner branches are reachable.
+    (check
+     (some (lambda (candidate)
+             (selections candidate :dinner :shared-plate))
+           branch-samples))
+    (check
+     (some (lambda (candidate)
+             (selections candidate :dinner :protein))
+           branch-samples))
+    t))
+
+(defun test-cli-lazy-day-budget ()
+  (let* ((peoples-menu (menu-path "peoples-organic.sexp"))
+         (output
+           (with-output-to-string (stream)
+             (let ((*standard-output* stream))
+               (organic-cafe:run-cli
+                (list "--days" "1"
+                      "--add-lazy-day" "30"
+                      "--seed" "1337")
+                :default-menu peoples-menu)))))
+    (check (search "Day 1" output))
+    (check (search "Lazy Day (outbound)" output))
+    (check (not (search "Lazy Day 2" output)))
+    (check
+     (handler-case
+         (let ((*standard-output* (make-broadcast-stream)))
+           (organic-cafe:run-cli
+            (list "--days" "1"
+                  "--add-lazy-day" "1"
+                  "--seed" "1337")
+            :default-menu peoples-menu)
+           nil)
+       (error (condition)
+         (search "LAZY-DAY" (string-upcase
+                             (princ-to-string condition))))))
+    (check
+     (handler-case
+         (progn
+           (organic-cafe:run-cli
+            (list "--plan" "lazy-day")
+            :default-menu peoples-menu)
+           nil)
+       (error (condition)
+         (search "--add-lazy-day"
+                 (princ-to-string condition)))))
+    t))
+
+(defun run-tests ()
+  (let ((peoples-count (test-peoples-organic)))
+    (test-townhall)
+    (test-cli-lazy-day-budget)
+    (format t
+            "~&All organic-cafe tests passed (~:D enumerated People's days; TownHall DP sampling covered).~%"
+            peoples-count)
+    t))