diff --git a/src/Makefile b/src/Makefile index 8707242..cd59f87 100644 --- a/src/Makefile +++ b/src/Makefile @@ -43,7 +43,7 @@ HACKERBASE-DEPS=hackerbase.scm cal-month.import.scm \ progress.import.scm cal-period.import.scm \ util-stdout.import.scm export-web-static.import.scm \ dokuwiki.import.scm mailinglist.import.scm \ - export-sheet.import.scm + export-sheet.import.scm mbase-query.import.scm HACKERBASE-OBJS=hackerbase.o testing.o listing.o cal-month.o \ cal-period.o ansi.o util-bst-ldict.o command-line.o mbase.o \ @@ -61,7 +61,7 @@ HACKERBASE-OBJS=hackerbase.o testing.o listing.o cal-month.o \ util-dir.o dokuwiki.o racket-kwargs.o duck.o util-bst.o \ util-bst-bdict.o util-bst-ldict.o util-bst-lset.o mailman2.o \ mailman-common.o mailman3.o mailman3-sql.o tiocgwinsz.o \ - mailinglist.o export-sheet.o + mailinglist.o export-sheet.o mbase-query.o GENDOC-SOURCES=gendoc.scm duck-extract.import.scm \ util-time.import.scm util-csv.import.scm util-git.import.scm \ @@ -569,3 +569,10 @@ EXPORT-SHEET-SOURCES=export-sheet.scm mbase.import.scm \ export-sheet.o: export-sheet.import.scm export-sheet.import.scm: $(EXPORT-SHEET-SOURCES) + +MBASE-QUERY-SOURCES=mbase-query.scm mbase.import.scm \ + brmember.import.scm util-bst-ldict.scm primes.import.scm \ + cal-period.import.scm cal-month.import.scm + +mbase-query.o: mbase-query.import.scm +mbase-query.import.scm: $(MBASE-QUERY-SOURCES) diff --git a/src/hackerbase.scm b/src/hackerbase.scm index 7074d1e..ce6c781 100644 --- a/src/hackerbase.scm +++ b/src/hackerbase.scm @@ -52,7 +52,8 @@ racket-kwargs util-string mailinglist - export-sheet) + export-sheet + mbase-query) ;; Command-line options and configurable parameters (define -needs-bank- (make-parameter #f)) diff --git a/src/mbase-query.scm b/src/mbase-query.scm new file mode 100644 index 0000000..c9e3e4c --- /dev/null +++ b/src/mbase-query.scm @@ -0,0 +1,92 @@ +;; +;; mbase-query.scm +;; +;; Queries of various mbase derived attributes. +;; +;; ISC License +;; +;; Copyright 2023-2025 Brmlab, z.s. +;; Dominik Pantůček +;; +;; 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) + + (define (members-base-oldest-month mb) + (make-cal-month 2015 1)) + + ;; 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))) + (di2 (ldict-set di1 'active + (filter brmember-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?))) + ;; add expected income + ;; add total balance of all members (including destroyed) + ;; add total balance of all active members (-only-active -like) + ;; add average age of active members + + ) + di8)) + + ;; 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))) + (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 (length (ldict-ref bi (car keys))) row) + (cdr keys))))) + (list keys (reverse data)))))) + + ) diff --git a/src/mbase.scm b/src/mbase.scm index 3412306..f2f12bb 100644 --- a/src/mbase.scm +++ b/src/mbase.scm @@ -50,8 +50,6 @@ mbase-update-by-id mbase-update - mbase-stats - mbase-add-unpaired mbase-unpaired @@ -207,47 +205,6 @@ (proc mr) mr))))) - ;; 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))) - (di2 (ldict-set di1 'active - (filter brmember-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?)))) - di8)) - - (define (members-base-oldest-month mb) - (make-cal-month 2015 1)) - - ;; 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))) - (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 (length (ldict-ref bi (car keys))) row) - (cdr keys))))) - (list keys (reverse data)))))) - ;; Adds unpaired transaction to given members-base (define (mbase-add-unpaired mb tr) (ldict-set mb 'unpaired diff --git a/src/members-fees.scm b/src/members-fees.scm index 5a3b0c3..7373497 100644 --- a/src/members-fees.scm +++ b/src/members-fees.scm @@ -41,6 +41,7 @@ member-calendar->table members-summary member-calendar-entry->fee + get-expected-income get-expected-income-string ) @@ -208,6 +209,19 @@ (cons 0 0) members))) + (define (get-expected-income mb) + (let* ((flst + (map (compose member-calendar-entry->fee make-member-calendar-entry) + (find-members-by-predicate mb brmember-active?))) + (amts (sort (delete-duplicates flst) <)) + (sums + (map + (lambda (amt) + (cons amt + (length (filter (lambda (v) (= v amt)) flst)))) + amts))) + (number->string (foldl + 0 (map (lambda (p) (* (car p) (cdr p))) sums))))) + (define (get-expected-income-string mb) (let* ((flst (map (compose member-calendar-entry->fee make-member-calendar-entry)