123 lines
3.5 KiB
Scheme
123 lines
3.5 KiB
Scheme
;;
|
|
;; mbase-query.scm
|
|
;;
|
|
;; Queries of various mbase derived attributes.
|
|
;;
|
|
;; ISC License
|
|
;;
|
|
;; Copyright 2023-2025 Brmlab, z.s.
|
|
;; Dominik Pantůček <dominik.pantucek@trustica.cz>
|
|
;;
|
|
;; Permission to use, copy, modify, and/or distribute this software
|
|
;; for any purpose with or without fee is hereby granted, provided
|
|
;; that the above copyright notice and this permission notice appear
|
|
;; in all copies.
|
|
;;
|
|
;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
|
|
;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
|
|
;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
|
|
;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
|
|
;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
|
|
;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
|
|
;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
|
|
;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
|
;;
|
|
|
|
(declare (unit mbase-query))
|
|
|
|
(module
|
|
mbase-query
|
|
(
|
|
mbase-info
|
|
mbase-stats
|
|
)
|
|
|
|
(import scheme
|
|
(chicken base)
|
|
srfi-1
|
|
mbase
|
|
brmember
|
|
util-bst-ldict
|
|
primes
|
|
cal-period
|
|
cal-month
|
|
members-fees
|
|
members-payments)
|
|
|
|
(define (members-base-oldest-month mb)
|
|
(make-cal-month 2015 1))
|
|
|
|
(define (members-average-age mrs)
|
|
(let* ((ages (map brmember-age mrs))
|
|
(valid (filter (lambda (x) x) ages))
|
|
(num (length valid))
|
|
(sum (foldl + 0 valid)))
|
|
(exact->inexact (/ sum num))))
|
|
|
|
;; Returns dictionary with statistics about the members base.
|
|
(define (mbase-info mb-arg)
|
|
(let* ((members (find-members-by-predicate mb-arg brmember-usable?))
|
|
(di0 (make-ldict))
|
|
(di1 (ldict-set di0 'invalid
|
|
(filter (compose not is-4digit-prime? brmember-id) members)))
|
|
(active-members (filter brmember-active? members))
|
|
(di2 (ldict-set di1 'active
|
|
active-members))
|
|
(di3 (ldict-set di2 'suspended
|
|
(filter brmember-suspended? members)))
|
|
(di4 (ldict-set di3 'students
|
|
(filter brmember-student? members)))
|
|
(di5 (ldict-set di4 'destroyed
|
|
(filter brmember-destroyed? members)))
|
|
(di6 (ldict-set di5 'month (*current-month*)))
|
|
(di7 (ldict-set di6 'total members))
|
|
(di8 (ldict-set di7 'problems
|
|
(find-members-by-predicate mb-arg brmember-has-problems?)))
|
|
(di9 (ldict-set di8 'expected
|
|
(get-expected-income mb-arg)))
|
|
(mbals (map member-total-balance active-members))
|
|
(di10 (ldict-set di9 'balance
|
|
(foldl + 0 mbals)))
|
|
(di11 (ldict-set di10 'advance
|
|
(foldl + 0
|
|
(map (lambda (v)
|
|
(max 0 v))
|
|
mbals))))
|
|
(di12 (ldict-set di11 'debt
|
|
(foldl + 0
|
|
(map (lambda (v)
|
|
(min 0 v))
|
|
mbals))))
|
|
(di13 (ldict-set di12 'age
|
|
(members-average-age active-members)))
|
|
)
|
|
di13))
|
|
|
|
;; Returns a list two lists: keys, data.
|
|
;; Each data record contains values for all keys.
|
|
(define (mbase-stats mb)
|
|
(let ((keys
|
|
'(month
|
|
total active suspended students destroyed invalid
|
|
expected balance advance debt
|
|
age
|
|
)))
|
|
(let mloop ((data '())
|
|
(month (members-base-oldest-month mb)))
|
|
(if (cal-month<=? month (*current-month*))
|
|
(let ((bi (with-current-month month
|
|
(mbase-info mb))))
|
|
(let kloop ((row (list (ldict-ref bi 'month)))
|
|
(keys (cdr keys)))
|
|
(if (null? keys)
|
|
(mloop (cons (reverse row) data)
|
|
(cal-month-add month 1))
|
|
(kloop (cons (let ((val (ldict-ref bi (car keys))))
|
|
(if (list? val)
|
|
(length val)
|
|
val))
|
|
row)
|
|
(cdr keys)))))
|
|
(list keys (reverse data))))))
|
|
|
|
)
|