diff --git a/lib/commerce/attribution.sx b/lib/commerce/attribution.sx new file mode 100644 index 00000000..3e666231 --- /dev/null +++ b/lib/commerce/attribution.sx @@ -0,0 +1,100 @@ +;; lib/commerce/attribution.sx — line-level discount attribution. +;; +;; The briefing's marquee backward query: "which line item triggered this +;; discount?". promo.sx computes discount amounts at the class/order level; +;; this layer answers the *scope* question relationally and in both directions: +;; forward — which lines does code C touch? (lines-for-code) +;; backward — which codes touch this line? (codes-for-line) +;; Both are the same relation promo-toucheso run with different vars bound. +;; +;; A :fixed promo is order-level (touches no single line); query those with +;; order-level-codes. Only promos that actually apply (amount > 0) touch lines. + +;; Lines whose sku is in product-class `cls`. +(define + class-lines + (fn + (ctx cart cls) + (filter + (fn (l) (= (catalog-class (ctx-catalog ctx) (line-sku l)) cls)) + cart))) + +;; The lines a promo applies to (its scope). :fixed is order-level → no lines. +(define + promo-lines + (fn + (ctx cart p) + (let + ((k (promo-kind p))) + (cond + ((= k :percent) (class-lines ctx cart (nth p 2))) + ((= k :member) + (if + (= (get ctx :customer) :member) + (class-lines ctx cart (nth p 2)) + (list))) + ((= k :bundle) + (filter (fn (l) (= (line-sku l) (nth p 2))) cart)) + (:else (list)))))) + +;; Relation: promo `code` touches `line`. Only applying promos (amount > 0) +;; touch anything, so an inapplicable promo contributes no pairs. +(define + promo-toucheso + (fn + (ctx cart ruleset code line) + (fresh + (p) + (membero p ruleset) + (project + (p) + (if + (> (promo-amount ctx cart p) 0) + (mk-conj + (== code (promo-code p)) + (membero line (promo-lines ctx cart p))) + fail))))) + +;; --- query helpers --- + +(define + lines-for-code + (fn + (ctx cart ruleset code) + (run* line (promo-toucheso ctx cart ruleset code line)))) + +(define + codes-for-line + (fn + (ctx cart ruleset line) + (run* code (promo-toucheso ctx cart ruleset code line)))) + +(define + line-touched-by? + (fn + (ctx cart ruleset code line) + (not + (empty? + (run + 1 + c + (mk-conj (promo-toucheso ctx cart ruleset code line) (== c true))))))) + +;; Applying order-level (:fixed) promos — discounts with no single line. +(define + order-level-codes + (fn + (ctx cart ruleset) + (run* + code + (fresh + (p) + (membero p ruleset) + (project + (p) + (if + (and + (> (promo-amount ctx cart p) 0) + (= (promo-kind p) :fixed)) + (== code (promo-code p)) + fail)))))) diff --git a/lib/commerce/conformance.sh b/lib/commerce/conformance.sh index 2a1b022d..c457b3ea 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 promo stack quote ledger order recon federation) +SUITES=(catalog cart price api promo stack quote ledger order recon federation attribution) OUT_JSON="lib/commerce/scoreboard.json" OUT_MD="lib/commerce/scoreboard.md" @@ -70,6 +70,7 @@ run_suite() { (load "lib/commerce/order.sx") (load "lib/commerce/recon.sx") (load "lib/commerce/federation.sx") +(load "lib/commerce/attribution.sx") (epoch 2) (eval "(define ct-pass 0)") (eval "(define ct-fail 0)") diff --git a/lib/commerce/scoreboard.json b/lib/commerce/scoreboard.json index ace44643..6f635a12 100644 --- a/lib/commerce/scoreboard.json +++ b/lib/commerce/scoreboard.json @@ -10,9 +10,10 @@ "ledger": {"pass": 20, "fail": 0}, "order": {"pass": 21, "fail": 0}, "recon": {"pass": 20, "fail": 0}, - "federation": {"pass": 12, "fail": 0} + "federation": {"pass": 12, "fail": 0}, + "attribution": {"pass": 16, "fail": 0} }, - "total_pass": 185, + "total_pass": 201, "total_fail": 0, - "total": 185 + "total": 201 } diff --git a/lib/commerce/scoreboard.md b/lib/commerce/scoreboard.md index 2fe4b738..965df57f 100644 --- a/lib/commerce/scoreboard.md +++ b/lib/commerce/scoreboard.md @@ -15,4 +15,5 @@ _Generated by `lib/commerce/conformance.sh`_ | order | 21 | 0 | 21 | | recon | 20 | 0 | 20 | | federation | 12 | 0 | 12 | -| **Total** | **185** | **0** | **185** | +| attribution | 16 | 0 | 16 | +| **Total** | **201** | **0** | **201** | diff --git a/lib/commerce/tests/attribution.sx b/lib/commerce/tests/attribution.sx new file mode 100644 index 00000000..2c203698 --- /dev/null +++ b/lib/commerce/tests/attribution.sx @@ -0,0 +1,124 @@ +;; lib/commerce/tests/attribution.sx — line-level discount attribution. +;; Uses (commerce-test name got expected) provided by conformance.sh. + +(define + pcat + (make-catalog + (list + (list "widget" 1000 :standard) + (list "gizmo" 2000 :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 2) + (list "gizmo" :none 1) + (list "book" :none 1) + (list "tea" :none 6))) + +(define + ruleset + (list + (list :percent "TEN" :standard 1000) + (list :percent "TWENTY" :standard 2000) + (list :bundle "B3T" "tea" 3) + (list :fixed "FIVE" 0 500) + (list :member "MEM" :standard 1500))) + +(define w-line (list "widget" :none 2)) +(define t-line (list "tea" :none 6)) +(define bk-line (list "book" :none 1)) + +;; --- scope helpers --- + +(commerce-test + "class-lines-standard" + (class-lines gctx cart :standard) + (list (list "widget" :none 2) (list "gizmo" :none 1))) + +(commerce-test + "promo-lines-bundle" + (promo-lines gctx cart (list :bundle "B3T" "tea" 3)) + (list (list "tea" :none 6))) + +(commerce-test + "promo-lines-fixed-none" + (promo-lines gctx cart (list :fixed "FIVE" 0 500)) + (list)) + +;; --- forward: which lines does a code touch? --- + +(commerce-test + "lines-for-ten" + (lines-for-code gctx cart ruleset "TEN") + (list (list "widget" :none 2) (list "gizmo" :none 1))) + +(commerce-test + "lines-for-bundle" + (lines-for-code gctx cart ruleset "B3T") + (list (list "tea" :none 6))) + +(commerce-test + "lines-for-fixed-empty" + (lines-for-code gctx cart ruleset "FIVE") + (list)) +(commerce-test + "lines-for-mem-guest-empty" + (lines-for-code gctx cart ruleset "MEM") + (list)) + +;; --- backward: which codes touch this line? (the showcase) --- + +(commerce-test + "codes-for-widget-guest" + (codes-for-line gctx cart ruleset w-line) + (list "TEN" "TWENTY")) + +(commerce-test + "codes-for-tea" + (codes-for-line gctx cart ruleset t-line) + (list "B3T")) +(commerce-test + "codes-for-book-none" + (codes-for-line gctx cart ruleset bk-line) + (list)) + +;; member sees the member rate too +(commerce-test + "codes-for-widget-member" + (codes-for-line mctx cart ruleset w-line) + (list "TEN" "TWENTY" "MEM")) + +(commerce-test + "lines-for-mem-member" + (lines-for-code mctx cart ruleset "MEM") + (list (list "widget" :none 2) (list "gizmo" :none 1))) + +;; --- predicate --- + +(commerce-test + "touched-yes" + (line-touched-by? gctx cart ruleset "TEN" w-line) + true) +(commerce-test + "touched-no-wrong-class" + (line-touched-by? gctx cart ruleset "B3T" w-line) + false) +(commerce-test + "touched-no-guest-mem" + (line-touched-by? gctx cart ruleset "MEM" w-line) + false) + +;; --- order-level (fixed) codes --- + +(commerce-test + "order-level" + (order-level-codes gctx cart ruleset) + (list "FIVE")) diff --git a/plans/commerce-on-sx.md b/plans/commerce-on-sx.md index 798a40c7..a9ea0089 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` → **185/185** (11 suites: catalog, cart, price, api, promo, stack, quote, ledger, order, recon, federation) — **Phases 1-4 done (roadmap complete)** +`bash lib/commerce/conformance.sh` → **201/201** (12 suites; + attribution) — **roadmap complete; Phase 5 extensions in progress** ## Ground rules @@ -78,9 +78,9 @@ lib/commerce/api.sx ── (commerce/add) (commerce/total) (commerce/checkout) ## Phase 5 — Extensions (backlog; base roadmap complete) Thesis-aligned deepenings of the relational/composition showcase. Pick the one that unlocks the most tests per effort each iteration. -- [ ] line-level discount attribution — "which line item triggered this discount?" - as a backward miniKanren query (briefing gotcha; promos currently apply at - class level). Refactor promo amounts to also yield per-line attribution. +- [x] line-level discount attribution — "which line item triggered this discount?" + as a backward miniKanren query (`attribution.sx`: `promo-toucheso` relation, + `lines-for-code`/`codes-for-line` both directions, `order-level-codes` for fixed). - [ ] time-windowed promotions — promos gated by a validity window; quote takes a datetime, determinism preserved. (quote.sx already documents datetime intent.) - [ ] discount-aware tax policy — alternative `cart-quote` computing tax on the @@ -97,6 +97,14 @@ that unlocks the most tests per effort each iteration. Keeps lib/commerce provider-agnostic; enables multi-provider support in the core. ## Progress log +- 2026-06-07 — `attribution.sx` (Phase 5 ext): line-level discount attribution — + the briefing's marquee "which line item triggered this discount?" query. + `promo-lines` is the pure per-promo scope (percent/member → class lines, bundle + → sku lines, fixed → order-level/none); `promo-toucheso` relates (code, line) + for applying promos, run forward (`lines-for-code`) and backward + (`codes-for-line`). `order-level-codes` lists applying fixed promos; predicate + `line-touched-by?`. Additive — promo.sx amounts unchanged. attribution suite + 16/16; total 201/201 (12 suites). - 2026-06-07 — `recon.sx` + `federation.sx` (**Phase 4 complete — roadmap done**). `recon.sx`: reconciliation as relational queries over the ledger. Per-order summary tuples (id total paid refunded net status); `recon-statuso`/`neto`/