From 79fa28e55d23a6e4163830c6bdce53f1b96dbfa7 Mon Sep 17 00:00:00 2001 From: giles Date: Sun, 7 Jun 2026 00:17:26 +0000 Subject: [PATCH] commerce: promo rules (percent/fixed/bundle/member) as relations (17 tests) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit promo.sx — four promo types as tagged tuples; per-promo discount is pure integer arithmetic, but enumeration is relational: promo-discounto and promo-applieso run forward ("which codes apply, for how much?") and backward ("which code yields this discount?"). project grounds the membero-bound promo. applicable-promos / promo-amount-for deterministic helpers. Total 83/83. Co-Authored-By: Claude Opus 4.8 (1M context) --- lib/commerce/conformance.sh | 3 +- lib/commerce/promo.sx | 153 +++++++++++++++++++++++++++++++++++ lib/commerce/scoreboard.json | 7 +- lib/commerce/scoreboard.md | 3 +- lib/commerce/tests/promo.sx | 142 ++++++++++++++++++++++++++++++++ plans/commerce-on-sx.md | 12 ++- 6 files changed, 313 insertions(+), 7 deletions(-) create mode 100644 lib/commerce/promo.sx create mode 100644 lib/commerce/tests/promo.sx diff --git a/lib/commerce/conformance.sh b/lib/commerce/conformance.sh index d88466dd..abd7cd9c 100755 --- a/lib/commerce/conformance.sh +++ b/lib/commerce/conformance.sh @@ -17,7 +17,7 @@ if [ ! -x "$SX_SERVER" ]; then exit 1 fi -SUITES=(catalog cart price api) +SUITES=(catalog cart price api promo) OUT_JSON="lib/commerce/scoreboard.json" OUT_MD="lib/commerce/scoreboard.md" @@ -47,6 +47,7 @@ run_suite() { (load "lib/commerce/cart.sx") (load "lib/commerce/price.sx") (load "lib/commerce/api.sx") +(load "lib/commerce/promo.sx") (epoch 2) (eval "(define ct-pass 0)") (eval "(define ct-fail 0)") diff --git a/lib/commerce/promo.sx b/lib/commerce/promo.sx new file mode 100644 index 00000000..27a76823 --- /dev/null +++ b/lib/commerce/promo.sx @@ -0,0 +1,153 @@ +;; lib/commerce/promo.sx — promotions as relations over the cart + catalog. +;; +;; A promo is a tagged tuple; the second field is always its code: +;; (:percent code class pct-bps) pct-bps off every line of product-class +;; (:fixed code threshold amount) amount off when subtotal >= threshold +;; (:bundle code sku n) every nth unit of sku is free +;; (:member code class pct-bps) like :percent, members only +;; +;; A ruleset is a list of promo tuples. The discount a promo yields on a +;; given cart is a pure integer computation (minor units); the *enumeration* +;; of which promos apply is relational, so promo-applieso runs forward +;; ("which codes apply and for how much?") and backward ("which code yields +;; this discount?"). Stacking precedence is a separate layer (stack.sx). + +(define promo-kind (fn (p) (nth p 0))) +(define promo-code (fn (p) (nth p 1))) + +;; Extended price of all lines whose sku is in product-class `class`. +(define + class-extended + (fn + (ctx cart class) + (let + ((cat (ctx-catalog ctx))) + (reduce + (fn + (acc l) + (if + (= (catalog-class cat (line-sku l)) class) + (+ acc (line-extended cat l)) + acc)) + 0 + cart)))) + +(define + sku-qty + (fn + (cart sku) + (reduce + (fn (acc l) (if (= (line-sku l) sku) (+ acc (line-qty l)) acc)) + 0 + cart))) + +;; --- per-type discount amounts (pure, integer minor units) --- + +(define + percent-amount + (fn + (ctx cart p) + (apply-bps + (class-extended ctx cart (nth p 2)) + (nth p 3)))) + +(define + fixed-amount + (fn + (ctx cart p) + (let + ((sub (cart-subtotal (ctx-catalog ctx) cart))) + (if + (>= sub (nth p 2)) + (min (nth p 3) sub) + 0)))) + +(define + bundle-amount + (fn + (ctx cart p) + (let + ((sku (nth p 2)) (n (nth p 3))) + (let + ((free (quotient (sku-qty cart sku) n))) + (* free (catalog-price (ctx-catalog ctx) sku)))))) + +(define + member-amount + (fn + (ctx cart p) + (if + (= (get ctx :customer) :member) + (apply-bps + (class-extended ctx cart (nth p 2)) + (nth p 3)) + 0))) + +;; Discount this promo yields on this cart (0 if it does not apply). +(define + promo-amount + (fn + (ctx cart p) + (let + ((k (promo-kind p))) + (cond + ((= k :percent) (percent-amount ctx cart p)) + ((= k :fixed) (fixed-amount ctx cart p)) + ((= k :bundle) (bundle-amount ctx cart p)) + ((= k :member) (member-amount ctx cart p)) + (:else 0))))) + +;; --- relational enumeration --- + +;; (code, amount) for every promo in the ruleset (amount may be 0). +(define + promo-discounto + (fn + (ctx cart ruleset code amount) + (fresh + (p) + (membero p ruleset) + (project + (p) + (== code (promo-code p)) + (== amount (promo-amount ctx cart p)))))) + +;; (code, amount) restricted to promos that actually apply (amount > 0). +(define + promo-applieso + (fn + (ctx cart ruleset code amount) + (fresh + (p) + (membero p ruleset) + (project + (p) + (if + (> (promo-amount ctx cart p) 0) + (mk-conj + (== code (promo-code p)) + (== amount (promo-amount ctx cart p))) + fail))))) + +;; --- deterministic helpers --- + +;; List of (list code amount) for applicable promos, in ruleset order. +(define + applicable-promos + (fn + (ctx cart ruleset) + (run* + pair + (fresh + (code amount) + (promo-applieso ctx cart ruleset code amount) + (== pair (list code amount)))))) + +;; Discount for one code (0 if absent / inapplicable). +(define + promo-amount-for + (fn + (ctx cart ruleset code) + (let + ((rs (run 1 a (promo-applieso ctx cart ruleset code a)))) + (if (empty? rs) 0 (first rs))))) diff --git a/lib/commerce/scoreboard.json b/lib/commerce/scoreboard.json index c30f641e..4fca48d8 100644 --- a/lib/commerce/scoreboard.json +++ b/lib/commerce/scoreboard.json @@ -3,9 +3,10 @@ "catalog": {"pass": 16, "fail": 0}, "cart": {"pass": 18, "fail": 0}, "price": {"pass": 20, "fail": 0}, - "api": {"pass": 12, "fail": 0} + "api": {"pass": 12, "fail": 0}, + "promo": {"pass": 17, "fail": 0} }, - "total_pass": 66, + "total_pass": 83, "total_fail": 0, - "total": 66 + "total": 83 } diff --git a/lib/commerce/scoreboard.md b/lib/commerce/scoreboard.md index bca6e9ae..a631e4c2 100644 --- a/lib/commerce/scoreboard.md +++ b/lib/commerce/scoreboard.md @@ -8,4 +8,5 @@ _Generated by `lib/commerce/conformance.sh`_ | cart | 18 | 0 | 18 | | price | 20 | 0 | 20 | | api | 12 | 0 | 12 | -| **Total** | **66** | **0** | **66** | +| promo | 17 | 0 | 17 | +| **Total** | **83** | **0** | **83** | diff --git a/lib/commerce/tests/promo.sx b/lib/commerce/tests/promo.sx new file mode 100644 index 00000000..a082aa29 --- /dev/null +++ b/lib/commerce/tests/promo.sx @@ -0,0 +1,142 @@ +;; lib/commerce/tests/promo.sx — promo rules + relational enumeration. +;; Uses (commerce-test name got expected) provided by conformance.sh. + +(define + pcat + (make-catalog + (list + (list "widget" 1000 :standard) + (list "book" 800 :zero-rated) + (list "tea" 1000 :reduced)) + (list) + (list))) + +(define gctx (make-pricing-context pcat (list) :uk :guest)) +(define mctx (make-pricing-context pcat (list) :uk :member)) + +(define + cart + (list + (list "widget" :none 3) + (list "book" :none 1) + (list "tea" :none 6))) + +(define + ruleset + (list + (list :percent "TEN" :standard 1000) + (list :fixed "FIVER" 5000 500) + (list :bundle "B3T" "tea" 3) + (list :member "MEM" :standard 1500))) + +;; --- per-type amounts --- + +(commerce-test + "percent-amount" + (promo-amount gctx cart (list :percent "TEN" :standard 1000)) + 300) + +(commerce-test + "fixed-amount-met" + (promo-amount gctx cart (list :fixed "FIVER" 5000 500)) + 500) + +(commerce-test + "fixed-amount-not-met" + (promo-amount + gctx + (list (list "widget" :none 1)) + (list :fixed "FIVER" 5000 500)) + 0) + +(commerce-test + "fixed-amount-capped" + (promo-amount + gctx + (list (list "book" :none 1)) + (list :fixed "BIG" 0 9999)) + 800) + +(commerce-test + "bundle-amount" + (promo-amount gctx cart (list :bundle "B3T" "tea" 3)) + 2000) + +(commerce-test + "member-amount-guest" + (promo-amount gctx cart (list :member "MEM" :standard 1500)) + 0) + +(commerce-test + "member-amount-member" + (promo-amount mctx cart (list :member "MEM" :standard 1500)) + 450) + +;; --- relational enumeration: forward --- + +(commerce-test + "discounto-all-guest" + (run* + pair + (fresh + (code amount) + (promo-discounto gctx cart ruleset code amount) + (== pair (list code amount)))) + (list + (list "TEN" 300) + (list "FIVER" 500) + (list "B3T" 2000) + (list "MEM" 0))) + +(commerce-test + "applicable-guest" + (applicable-promos gctx cart ruleset) + (list + (list "TEN" 300) + (list "FIVER" 500) + (list "B3T" 2000))) + +(commerce-test + "applicable-member" + (applicable-promos mctx cart ruleset) + (list + (list "TEN" 300) + (list "FIVER" 500) + (list "B3T" 2000) + (list "MEM" 450))) + +;; --- relational enumeration: backward (the showcase) --- + +(commerce-test + "code-by-discount-2000" + (run* code (promo-applieso gctx cart ruleset code 2000)) + (list "B3T")) + +(commerce-test + "code-by-discount-500" + (run* code (promo-applieso gctx cart ruleset code 500)) + (list "FIVER")) + +(commerce-test + "code-by-discount-none" + (run* code (promo-applieso gctx cart ruleset code 9999)) + (list)) + +;; --- deterministic helpers --- + +(commerce-test + "amount-for-ten" + (promo-amount-for gctx cart ruleset "TEN") + 300) +(commerce-test + "amount-for-mem-guest" + (promo-amount-for gctx cart ruleset "MEM") + 0) +(commerce-test + "amount-for-mem-member" + (promo-amount-for mctx cart ruleset "MEM") + 450) +(commerce-test + "amount-for-absent" + (promo-amount-for gctx cart ruleset "NOPE") + 0) diff --git a/plans/commerce-on-sx.md b/plans/commerce-on-sx.md index 66d306a7..21b2b701 100644 --- a/plans/commerce-on-sx.md +++ b/plans/commerce-on-sx.md @@ -21,7 +21,7 @@ reconciliation — all auditable via the event log. ## Status (rolling) -`bash lib/commerce/conformance.sh` → **66/66** (4 suites: catalog, cart, price, api) — Phase 1 done +`bash lib/commerce/conformance.sh` → **83/83** (5 suites: catalog, cart, price, api, promo) — Phase 1 done, Phase 2 in progress ## Ground rules @@ -61,7 +61,7 @@ lib/commerce/api.sx ── (commerce/add) (commerce/total) (commerce/checkout) - [x] `api.sx` + tests + scoreboard + conformance.sh ## Phase 2 — Promotions (relational) -- [ ] promo rules: percentage, fixed, bundle, member rate +- [x] promo rules: percentage, fixed, bundle, member rate - [ ] explicit stacking precedence; "best price" backward query - [ ] tests: stacking order, mutually-exclusive promos, member vs guest @@ -76,6 +76,14 @@ lib/commerce/api.sx ── (commerce/add) (commerce/total) (commerce/checkout) - [ ] tests: webhook replay, partial refund, double-charge guard ## Progress log +- 2026-06-07 — `promo.sx` (Phase 2 piece 1): four promo types as tagged tuples + `(:percent code class bps)`/`(:fixed code threshold amount)`/`(:bundle code sku + n)`/`(:member code class bps)`. Per-promo discount is pure integer arithmetic; + `promo-discounto`/`promo-applieso` enumerate (code, amount) relationally — + forward ("which apply?") and backward ("which code yields 2000?" → run* over + applieso). `applicable-promos`/`promo-amount-for` deterministic helpers. promo + amounts via `project` to ground the membero-bound promo. promo suite 17/17; + total 83/83. Next: stacking precedence + best-price (stack.sx). - 2026-06-06 — `api.sx` (**Phase 1 complete**): session facade `{:ctx :cart}` with `commerce-add`/`-remove`/`-set-qty`/`-total`/`-count`/ `-lines`, `commerce-can-add?` catalog validation, `commerce-explain` per-line