rose-ash/lib/commerce/promo.sx

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