pollen-tfl/pricing-table.rkt

#lang racket/base
(require racket/dict "sku.rkt")
(provide (all-defined-out) (all-from-out "sku.rkt"))


(define (round-cents float)
  (/ (floor (* float 100)) 100))

(define (round-up inc x)
  (* (ceiling (/ x inc)) inc))


(define (calc-multi-price base-price people)
  (round-cents 
   (sub1 (round-up 10 (case people
                        [(1) base-price]
                        [(2) (/ (* base-price 4) 3)]
                        [(5) (* base-price 2)]
                        [(10) (* base-price 3)]
                        [(20) (* base-price 4)]
                        [(40) (* base-price 5)]
                        [(60) (* base-price 6)]
                        [(80) (* base-price 7)]
                        [else (error "Too many people")])))))



(define (calc-multi-license sku people)
  (define base-price (sku-base-price sku))
  (calc-multi-price base-price people))

(define license-increments '(1 2 5 10 20 40 60 80))

(define (make-price-list base-price)
  (map (λ(n) (cons n (calc-multi-license base-price n))) license-increments))

(define (get-price sku [people 1])
  (with-handlers ([exn:fail? (λ(e) (get-price sku (add1 people)))])
    (calc-multi-license sku people)))

(define (get-variant-id sku which)
  (dict-ref (sku-variant-ids sku) which))


(define (grid->table grid)
  (define (table-row row [cell-tag 'td])
    `(tr (th ((style "width:40%")) ,(car row)) ,@(map (λ(c) `(,cell-tag ,c)) (cdr row))))
  (define (table-header row)
    (table-row row 'th))
  
  `(table ((class "buy-table"))
          ,(table-header (car grid))
          ,@(map table-row (cdr grid))))

(define (people->string p)
  (define p-string (format "~a"
                           (if (< p 10)
                               (list-ref '(zero one two three four five six seven eight nine) p)
                               p)))
  (string-append p-string " " (if (= p 1) "person" "people")))

(require txexpr racket/string)
(define (textify x)
  (cond
    ;; convert nbsp to string
    [(string? x) (string-replace x #px"[\\s#\u00A0]+" " ")]
    [(eq? 'nbsp x) " "]
    [(list? x) (string-append* (map textify (if (txexpr? x)
                                                (get-elements x)
                                                x)))]))

(module+ test
  (require rackunit)
  (check-equal?
   (textify
    '(span (a ((href "equity.html")) "Equity") " + " (a ((href "concourse.html")) "Concourse Standard") " + " (a ((href "triplicate.html")) "Triplicate")))
   "Equity + Concourse Standard + Triplicate"))

(define (buy-link sku people)
  (define price (get-price sku people))
  (define item (textify (sku-name sku)))
  `(a ((class "checkout_clicker")
       (href "#")
       (item ,item)
       (label ,(format "~a (~a-person license)" item people))
       (quantity ,(number->string people))
       (amount ,(number->string price))
       (success "/order-success.html")
       (failure "/order-failure.html"))
      ,(format "$~a" price)))

(define (make-buy-grid #:people people-list #:skus sku-list)
  (cons 
   (cons "" (map people->string people-list)) 
   (map (λ(sku) (cons (sku-name sku) 
                      (map (λ(p) (buy-link sku p)) people-list))) sku-list)))


(define (make-buy-table #:people people-list #:skus sku-list)
  (grid->table (make-buy-grid #:people people-list #:skus sku-list)))