hpcdisrespecter/organicCafe
1
0
Fork 0
Code Issues Releases Wiki Activity

Initial commit, ACM PEARC25 and PEARC26 chosen restaurants work.

Browse Source 
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
This commit is contained in:
hpcdisrespecter
2026-07-23 02:58:10 -05:00
parent 164c8c4099
commit bc14c93a3c
9 changed files with 1060 additions and 25 deletions
Download Patch File Download Diff File Expand all files Collapse all files

24
.gitignore vendored
View File

@@ -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.*

119
README.md
View File

@@ -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.

62
menus/peoples-organic.sexp Normal file
View File

@@ -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))))

122
menus/townhall-shortnorth.sexp Normal file
View File

@@ -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))))

15
organic-cafe.asd Normal file
View File

@@ -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)))

17
run.lisp Normal file
View File

@@ -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))))

7
src/package.lisp Normal file
View File

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

569
src/planner.lisp Normal file
View File

@@ -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)))

150
test/tests.lisp Normal file
View File

@@ -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))