brmlab/hackerbase
4
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Fix computing expected income based on actual fees and discounts.

Browse source
This commit is contained in:
Dominik Pantůček 2024-02-09 14:28:17 +01:00
parent dc3044026c
commit 15888b7e3e
2 changed files with 40 additions and 29 deletions
Download patch file Download diff file Expand all files Collapse all files

15
src/members-fees.scm
View file

@ -30,6 +30,7 @@
(
lookup-member-fee
member-calendar
make-member-calendar-entry
member-calendar-first-month
member-calendar-last-month
member-calendar-query
@ -82,15 +83,17 @@
(if (cal-month>? cm last-month)
(reverse cal)
(loop (cal-month-add cm)
(cons (list cm
(with-current-month
(cons (with-current-month
cm
(brmember-flags mr))
(with-current-month
cm
(brmember-spec-fee mr)))
(make-member-calendar-entry mr))
cal))))))
;; Assumes current-month is specified correctly
(define (make-member-calendar-entry mr)
(list (*current-month*)
(brmember-flags mr)
(brmember-spec-fee mr)))
;; Returns the first month of the calendar
(define (member-calendar-first-month mc)
(caar mc))

52
src/members-print.scm
View file

@ -500,7 +500,17 @@
(null? (cdr dsa)))
#f
(cadr dsa))))
(let* ((members ;; Pass 1
(let* ((raw-members
(sort
(if destroyed?
(find-members-by-predicate MB (lambda x #t))
(if only-active?
(find-members-by-predicate MB (lambda (mr)
(brmember-active? mr)))
(find-members-by-predicate MB (lambda (mr)
(not (brmember-destroyed? mr))))))
brmember<?))
(members ;; Pass 1
(map
(lambda (mr)
(let* ((balance (member-balance mr))
@ -522,15 +532,7 @@
total
balance
)))
(sort
(if destroyed?
(find-members-by-predicate MB (lambda x #t))
(if only-active?
(find-members-by-predicate MB (lambda (mr)
(brmember-active? mr)))
(find-members-by-predicate MB (lambda (mr)
(not (brmember-destroyed? mr))))))
brmember<?)))
raw-members))
(balances (map (lambda (m)
(list-ref m 6))
members)))
@ -598,19 +600,25 @@
(map (lambda (member)
(min 0 (list-ref member 5)))
members)))
(let* ((ns (foldl (lambda (acc member)
(cons (+ (car acc) (if (eq? 'student (cadr member)) 1 0))
(+ (cdr acc) (if (eq? 'active (cadr member)) 1 0))))
(cons 0 0)
members))
(students (car ns))
(full (cdr ns)))
(print "Expected income: "
(+ (* (lookup-member-fee 'normal) full)
(* (lookup-member-fee 'student) students))
" (" full " full members + " students " students)"))
(let* ((flst
(map (compose member-calendar-entry->fee make-member-calendar-entry)
(filter brmember-active? raw-members)))
(amts (sort (delete-duplicates flst) <))
(sums
(map
(lambda (amt)
(cons amt
(length (filter (lambda (v) (= v amt)) flst))))
amts))
)
))
(print "Expected income: "
(string-intersperse (map
(lambda (p)
(format "~A*~A" (cdr p) (car p)))
sums)
" + ")
" = "
(foldl + 0 (map (lambda (p) (* (car p) (cdr p))) sums)))))))
(define (unpaired-table mb . args)
(apply