From bc14c93a3c4729776f6051b363473b46c60bfcfe Mon Sep 17 00:00:00 2001 From: hpcdisrespecter Date: Thu, 23 Jul 2026 02:58:10 -0500 Subject: [PATCH] Initial commit, ACM PEARC25 and PEARC26 chosen restaurants work. Committer: hpcdisrespecter 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 | 24 -- README.md | 119 ++++++- menus/peoples-organic.sexp | 62 ++++ menus/townhall-shortnorth.sexp | 122 +++++++ organic-cafe.asd | 15 + run.lisp | 17 + src/package.lisp | 7 + src/planner.lisp | 569 +++++++++++++++++++++++++++++++++ test/tests.lisp | 150 +++++++++ 9 files changed, 1060 insertions(+), 25 deletions(-) create mode 100644 menus/peoples-organic.sexp create mode 100644 menus/townhall-shortnorth.sexp create mode 100644 organic-cafe.asd create mode 100644 run.lisp create mode 100644 src/package.lisp create mode 100644 src/planner.lisp create mode 100644 test/tests.lisp diff --git a/.gitignore b/.gitignore index 6a62767..8b13789 100644 --- a/.gitignore +++ b/.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.* diff --git a/README.md b/README.md index 5ddf06a..7038a96 100644 --- a/README.md +++ b/README.md @@ -1,3 +1,120 @@ # organicCafe -MC sampling a downtown cafe's menu under the Federal per diem \ No newline at end of file +~~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. diff --git a/menus/peoples-organic.sexp b/menus/peoples-organic.sexp new file mode 100644 index 0000000..e89a613 --- /dev/null +++ b/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)))) diff --git a/menus/townhall-shortnorth.sexp b/menus/townhall-shortnorth.sexp new file mode 100644 index 0000000..ff46d75 --- /dev/null +++ b/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)))) diff --git a/organic-cafe.asd b/organic-cafe.asd new file mode 100644 index 0000000..d3711fe --- /dev/null +++ b/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))) diff --git a/run.lisp b/run.lisp new file mode 100644 index 0000000..89742fb --- /dev/null +++ b/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)))) diff --git a/src/package.lisp b/src/package.lisp new file mode 100644 index 0000000..fd5abfc --- /dev/null +++ b/src/package.lisp @@ -0,0 +1,7 @@ +(defpackage #:organic-cafe + (:use #:cl) + (:export #:load-menu + #:feasible-candidates + #:generate-plans + #:print-candidate + #:run-cli)) diff --git a/src/planner.lisp b/src/planner.lisp new file mode 100644 index 0000000..5823025 --- /dev/null +++ b/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))) diff --git a/test/tests.lisp b/test/tests.lisp new file mode 100644 index 0000000..006b3fd --- /dev/null +++ b/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))