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

Finish new stats.

Browse source
This commit is contained in:
Dominik Pantůček 2025-01-02 16:58:41 +01:00
parent 227787597d
commit 6cfdf705c8
3 changed files with 471 additions and 445 deletions
Download patch file Download diff file Expand all files Collapse all files

14
src/brmember.scm
View file

@ -87,6 +87,8 @@
brmember-spec-fee brmember-spec-fee
brmember-age
brmember-tests! brmember-tests!
) )
@ -492,6 +494,18 @@
#f)) #f))
#f))) #f)))
(define (brmember-age mr)
(let ((born (brmember-info mr 'born #f)))
(if born
(let ((lst (string-split born "-")))
(if (null? lst)
#f
(let ((y (string->number (car lst))))
(if y
(- (current-year) y)
#f))))
#f)))
;; Self-tests ;; Self-tests
(define (brmember-tests!) (define (brmember-tests!)
(run-tests (run-tests

888
src/cal-period.scm
View file

@ -26,460 +26,464 @@
(declare (unit cal-period)) (declare (unit cal-period))
(module (module
cal-period
(
*current-month*
*current-day*
set-current-month!
set-current-day!
with-current-month
with-current-day
make-cal-period
cal-period-since
cal-period-before
cal-period-scomment
cal-period-bcomment
set-cal-period-scomment
period-markers->cal-periods
cal-periods-duration
cal-month-in-period?
cal-month-in-periods?
cal-month-find-period
cal-day-in-period?
cal-day-in-periods?
cal-periods->string
cal-periods-match
make-cal-period-lookup-table
lookup-by-cal-period
cal-ensure-month
cal-ensure-day
cal-period-tests!
)
(import scheme
(chicken base)
(chicken sort)
(chicken time)
(chicken time posix)
(chicken format)
(chicken string)
cal-month
testing
util-tag
cal-day)
;; Type tag
(define TAG-CAL-PERIOD (make-tag CAL-PERIOD))
;; Current month - if changed, we get the actual state for given month.
(define *current-month*
(make-parameter
(let ((d (seconds->local-time (current-seconds))))
(make-cal-month (+ 1900 (vector-ref d 5))
(+ (vector-ref d 4) 1)))))
;; Current month - if changed, we get the actual state for given month.
(define *current-day*
(make-parameter
(let ((d (seconds->local-time (current-seconds))))
(make-cal-day (+ 1900 (vector-ref d 5))
(+ (vector-ref d 4) 1)
(vector-ref d 3)))))
;; Changes both current-month and current-day based on given month
(define (set-current-month! m)
(*current-month* m)
(*current-day* (cal-ensure-day m)))
;; Changes both current-day and current-month based on given day
(define (set-current-day! d)
(*current-day* d)
(*current-month* (cal-ensure-month d)))
;; Parameterizes both current-month and current-day based on given
;; month
(define-syntax with-current-month
(syntax-rules ()
((_ ms body ...)
(let ((m ms))
(parameterize ((*current-month* m)
(*current-day* (cal-ensure-day m)))
body ...)))))
;; Parameterizes both current-day and current-month based on given
;; day
(define-syntax with-current-day
(syntax-rules ()
((_ ds body ...)
(let ((d ds))
(parameterize ((*current-day* d)
(*current-month* (cal-ensure-month d)))
body ...)))))
;; Creates a new period value with optional since and before
;; comments.
(define (make-cal-period since before . args)
(let ((scomment (if (not (null? args)) (car args) #f))
(bcomment (if (and (not (null? args))
(not (null? (cdr args))))
(cadr args)
#f)))
(list TAG-CAL-PERIOD since before scomment bcomment)))
;; Simple accessors
(define cal-period-since cadr)
(define cal-period-before caddr)
(define cal-period-scomment cadddr)
(define cal-period-bcomment (compose cadddr cdr))
;; Direct updater
(define (set-cal-period-scomment p c)
(list TAG-CAL-PERIOD
(cal-period-since p)
(cal-period-before p)
c
(cal-period-bcomment p)))
;; Type predicate
(define (cal-period? p)
(and (pair? p)
(eq? (car p)
TAG-CAL-PERIOD)))
;; Month subtype predicate
(define (cal-period-month? p)
(and (cal-period? p)
(cal-month? (cal-period-since p))
(cal-month? (cal-period-before p))))
;; Day subtype predicate
(define (cal-period-day? p)
(and (cal-period? p)
(cal-day? (cal-period-since p))
(cal-day? (cal-period-before p))))
;; Validation
(define (cal-period-valid? p)
(and (pair? p)
(eq? (car p)
TAG-CAL-PERIOD)
(let ((since (cal-period-since p))
(before (cal-period-before p)))
(or (and (cal-month? since)
(cal-month? before)
(cal-month<=? since before))
(and (cal-day? since)
(cal-day? before)
(cal-day<=? since before))))))
;; Sorts period markers (be it start or end) chronologically and
;; returns the sorted list.
(define (sort-period-markers l)
(sort l
(lambda (a b)
(cal-day/month<? (cadr a) (cadr b)))))
;; Converts list of start/stop markers to list of pairs of months -
;; periods. The markers are lists in the form (start/stop cal-month).
(define (period-markers->cal-periods l)
(let loop ((l (sort-period-markers l))
(ps '())
(cb #f))
(if (null? l)
(list #t
(if cb
(reverse (cons (make-cal-period (car cb) #f (cadr cb)) ps))
(reverse ps))
""
-1)
(let* ((marker (car l))
(rmt (if cb 'stop 'start))
(mtype (car marker))
(month (cadr marker))
(line-number (if (null? (cddr marker))
#f
(caddr marker)))
(comment (if (and line-number
(not (null? (cdddr marker))))
(cadddr marker)
#f)))
(if (eq? mtype rmt)
(if cb
(loop (cdr l)
(cons (make-cal-period (car cb) month (cadr cb) comment) ps)
#f)
(loop (cdr l)
ps
(list month comment)))
(list #f
(reverse ps)
(sprintf "Invalid start/stop sequence marker ~A" marker)
line-number))))))
;; Returns duration of period in months. Start is included, end is
;; not. The period contains the month just before the specified end.
(define (cal-period->duration p)
(let* ((b (cal-period-since p))
(e (cal-period-before p))
(e- (if e e (*current-month*))))
(cal-month-diff b e-)))
;; Returns sum of periods lengths.
(define (cal-periods-duration l)
(apply + (map cal-period->duration l)))
;; True if month belongs to given month period - start inclusive, end
;; exclusive.
(define (cal-month-in-period? p . ml)
(let ((m (if (null? ml)
(*current-month*)
(cal-ensure-month (car ml))))
(before (cal-ensure-month (cal-period-before p) #t))
(since (cal-ensure-month (cal-period-since p))))
(and (or (not before)
(cal-month<? m before))
(not (cal-month<? m since)))))
;; Returns true if given month is in at least one of the periods
;; given. Defaults to current month.
(define (cal-month-in-periods? ps . ml)
(let ((m (if (null? ml)
(*current-month*)
(car ml))))
(let loop ((ps ps))
(if (null? ps)
#f
(if (cal-month-in-period? (car ps) m)
#t
(loop (cdr ps)))))))
;; Returns true if given month is in at least one of the periods
;; given. Defaults to current month.
(define (cal-month-find-period ps . ml)
(let ((m (if (null? ml)
(*current-month*)
(car ml))))
(let loop ((ps ps))
(if (null? ps)
#f
(if (cal-month-in-period? (car ps) m)
(car ps)
(loop (cdr ps)))))))
;; Checks whether given day belongs to day or month period
(define (cal-day-in-period? p . dl)
(let ((d (if (null? dl)
(*current-day*)
(cal-ensure-day (car dl))))
(before (cal-ensure-day (cal-period-before p)))
(since (cal-ensure-day (cal-period-since p))))
(and (or (not before)
(cal-day<? d before))
(not (cal-day<? d since)))))
;; Returns true if the day belongs to at least one period
(define (cal-day-in-periods? ps . dl)
(let ((d (if (null? dl)
(*current-day*)
(cal-ensure-day (car dl)))))
(let loop ((ps ps))
(if (null? ps)
#f
(if (cal-day-in-period? (car ps) d)
#t
(loop (cdr ps)))))))
;; Returns string representing a month period with possibly open end.
(define (cal-period->string p)
(sprintf "~A..~A"
(cal-day/month->string (cal-period-since p))
(cal-day/month->string (cal-period-before p))))
;; Returns a string representing a list of periods.
(define (cal-periods->string ps)
(string-intersperse
(map cal-period->string ps)
", "))
;; Finds a period the month matches and returns it. If no period
;; matches, it returns #f.
(define (cal-periods-match ps . ml)
(let ((m (if (null? ml) (*current-month*) (car ml))))
(let loop ((ps ps))
(if (null? ps)
#f
(if (cal-month-in-period? (car ps) m)
(car ps)
(loop (cdr ps)))))))
;; Creates lookup table from definition source
(define (make-cal-period-lookup-table source)
(let loop ((lst source)
(res '())
(prev #f))
(if (null? lst)
(reverse
(cons (cons (make-cal-period (apply make-cal-month (car prev)) #f)
(cdr prev))
res))
(loop (cdr lst)
(if prev
(cons (cons (make-cal-period (apply make-cal-month (car prev))
(apply make-cal-month (caar lst)))
(cdr prev))
res)
res)
(car lst)))))
;; Looks up current month and returns associated definitions
(define (lookup-by-cal-period table)
(let loop ((lst table))
(if (null? lst)
#f
(if (cal-month-in-period? (caar lst))
(cdar lst)
(loop (cdr lst))))))
;; Wrapper that accepts either day or month and returns testable month
(define (cal-ensure-month v . stop?s)
(if v
(if (cal-month? v)
v
(if (cal-day? v)
(apply cal-day->month v stop?s)
#f))
#f))
;; Ensures day for checking the periods
(define (cal-ensure-day v)
(if v
(if (cal-day? v)
v
(if (cal-month? v)
(make-cal-day (cal-month-year v)
(cal-month-month v)
1)
#f))
#f))
;; Performs self-tests of the period module.
(define (cal-period-tests!)
(run-tests
cal-period cal-period
(test-equal? sort-period-markers (
(sort-period-markers current-year
`((start ,(make-cal-month 2023 1)) *current-month*
(stop ,(make-cal-month 2022 10)) *current-day*
(start ,(make-cal-month 2022 3))))
`((start ,(make-cal-month 2022 3)) set-current-month!
(stop ,(make-cal-month 2022 10)) set-current-day!
(start ,(make-cal-month 2023 1))))
(test-equal? period-markers->cal-periods with-current-month
(period-markers->cal-periods with-current-day
make-cal-period
cal-period-since
cal-period-before
cal-period-scomment
cal-period-bcomment
set-cal-period-scomment
period-markers->cal-periods
cal-periods-duration
cal-month-in-period?
cal-month-in-periods?
cal-month-find-period
cal-day-in-period?
cal-day-in-periods?
cal-periods->string
cal-periods-match
make-cal-period-lookup-table
lookup-by-cal-period
cal-ensure-month
cal-ensure-day
cal-period-tests!
)
(import scheme
(chicken base)
(chicken sort)
(chicken time)
(chicken time posix)
(chicken format)
(chicken string)
cal-month
testing
util-tag
cal-day)
;; Type tag
(define TAG-CAL-PERIOD (make-tag CAL-PERIOD))
(define (current-year)
(cal-month-year (*current-month*)))
;; Current month - if changed, we get the actual state for given month.
(define *current-month*
(make-parameter
(let ((d (seconds->local-time (current-seconds))))
(make-cal-month (+ 1900 (vector-ref d 5))
(+ (vector-ref d 4) 1)))))
;; Current month - if changed, we get the actual state for given month.
(define *current-day*
(make-parameter
(let ((d (seconds->local-time (current-seconds))))
(make-cal-day (+ 1900 (vector-ref d 5))
(+ (vector-ref d 4) 1)
(vector-ref d 3)))))
;; Changes both current-month and current-day based on given month
(define (set-current-month! m)
(*current-month* m)
(*current-day* (cal-ensure-day m)))
;; Changes both current-day and current-month based on given day
(define (set-current-day! d)
(*current-day* d)
(*current-month* (cal-ensure-month d)))
;; Parameterizes both current-month and current-day based on given
;; month
(define-syntax with-current-month
(syntax-rules ()
((_ ms body ...)
(let ((m ms))
(parameterize ((*current-month* m)
(*current-day* (cal-ensure-day m)))
body ...)))))
;; Parameterizes both current-day and current-month based on given
;; day
(define-syntax with-current-day
(syntax-rules ()
((_ ds body ...)
(let ((d ds))
(parameterize ((*current-day* d)
(*current-month* (cal-ensure-month d)))
body ...)))))
;; Creates a new period value with optional since and before
;; comments.
(define (make-cal-period since before . args)
(let ((scomment (if (not (null? args)) (car args) #f))
(bcomment (if (and (not (null? args))
(not (null? (cdr args))))
(cadr args)
#f)))
(list TAG-CAL-PERIOD since before scomment bcomment)))
;; Simple accessors
(define cal-period-since cadr)
(define cal-period-before caddr)
(define cal-period-scomment cadddr)
(define cal-period-bcomment (compose cadddr cdr))
;; Direct updater
(define (set-cal-period-scomment p c)
(list TAG-CAL-PERIOD
(cal-period-since p)
(cal-period-before p)
c
(cal-period-bcomment p)))
;; Type predicate
(define (cal-period? p)
(and (pair? p)
(eq? (car p)
TAG-CAL-PERIOD)))
;; Month subtype predicate
(define (cal-period-month? p)
(and (cal-period? p)
(cal-month? (cal-period-since p))
(cal-month? (cal-period-before p))))
;; Day subtype predicate
(define (cal-period-day? p)
(and (cal-period? p)
(cal-day? (cal-period-since p))
(cal-day? (cal-period-before p))))
;; Validation
(define (cal-period-valid? p)
(and (pair? p)
(eq? (car p)
TAG-CAL-PERIOD)
(let ((since (cal-period-since p))
(before (cal-period-before p)))
(or (and (cal-month? since)
(cal-month? before)
(cal-month<=? since before))
(and (cal-day? since)
(cal-day? before)
(cal-day<=? since before))))))
;; Sorts period markers (be it start or end) chronologically and
;; returns the sorted list.
(define (sort-period-markers l)
(sort l
(lambda (a b)
(cal-day/month<? (cadr a) (cadr b)))))
;; Converts list of start/stop markers to list of pairs of months -
;; periods. The markers are lists in the form (start/stop cal-month).
(define (period-markers->cal-periods l)
(let loop ((l (sort-period-markers l))
(ps '())
(cb #f))
(if (null? l)
(list #t
(if cb
(reverse (cons (make-cal-period (car cb) #f (cadr cb)) ps))
(reverse ps))
""
-1)
(let* ((marker (car l))
(rmt (if cb 'stop 'start))
(mtype (car marker))
(month (cadr marker))
(line-number (if (null? (cddr marker))
#f
(caddr marker)))
(comment (if (and line-number
(not (null? (cdddr marker))))
(cadddr marker)
#f)))
(if (eq? mtype rmt)
(if cb
(loop (cdr l)
(cons (make-cal-period (car cb) month (cadr cb) comment) ps)
#f)
(loop (cdr l)
ps
(list month comment)))
(list #f
(reverse ps)
(sprintf "Invalid start/stop sequence marker ~A" marker)
line-number))))))
;; Returns duration of period in months. Start is included, end is
;; not. The period contains the month just before the specified end.
(define (cal-period->duration p)
(let* ((b (cal-period-since p))
(e (cal-period-before p))
(e- (if e e (*current-month*))))
(cal-month-diff b e-)))
;; Returns sum of periods lengths.
(define (cal-periods-duration l)
(apply + (map cal-period->duration l)))
;; True if month belongs to given month period - start inclusive, end
;; exclusive.
(define (cal-month-in-period? p . ml)
(let ((m (if (null? ml)
(*current-month*)
(cal-ensure-month (car ml))))
(before (cal-ensure-month (cal-period-before p) #t))
(since (cal-ensure-month (cal-period-since p))))
(and (or (not before)
(cal-month<? m before))
(not (cal-month<? m since)))))
;; Returns true if given month is in at least one of the periods
;; given. Defaults to current month.
(define (cal-month-in-periods? ps . ml)
(let ((m (if (null? ml)
(*current-month*)
(car ml))))
(let loop ((ps ps))
(if (null? ps)
#f
(if (cal-month-in-period? (car ps) m)
#t
(loop (cdr ps)))))))
;; Returns true if given month is in at least one of the periods
;; given. Defaults to current month.
(define (cal-month-find-period ps . ml)
(let ((m (if (null? ml)
(*current-month*)
(car ml))))
(let loop ((ps ps))
(if (null? ps)
#f
(if (cal-month-in-period? (car ps) m)
(car ps)
(loop (cdr ps)))))))
;; Checks whether given day belongs to day or month period
(define (cal-day-in-period? p . dl)
(let ((d (if (null? dl)
(*current-day*)
(cal-ensure-day (car dl))))
(before (cal-ensure-day (cal-period-before p)))
(since (cal-ensure-day (cal-period-since p))))
(and (or (not before)
(cal-day<? d before))
(not (cal-day<? d since)))))
;; Returns true if the day belongs to at least one period
(define (cal-day-in-periods? ps . dl)
(let ((d (if (null? dl)
(*current-day*)
(cal-ensure-day (car dl)))))
(let loop ((ps ps))
(if (null? ps)
#f
(if (cal-day-in-period? (car ps) d)
#t
(loop (cdr ps)))))))
;; Returns string representing a month period with possibly open end.
(define (cal-period->string p)
(sprintf "~A..~A"
(cal-day/month->string (cal-period-since p))
(cal-day/month->string (cal-period-before p))))
;; Returns a string representing a list of periods.
(define (cal-periods->string ps)
(string-intersperse
(map cal-period->string ps)
", "))
;; Finds a period the month matches and returns it. If no period
;; matches, it returns #f.
(define (cal-periods-match ps . ml)
(let ((m (if (null? ml) (*current-month*) (car ml))))
(let loop ((ps ps))
(if (null? ps)
#f
(if (cal-month-in-period? (car ps) m)
(car ps)
(loop (cdr ps)))))))
;; Creates lookup table from definition source
(define (make-cal-period-lookup-table source)
(let loop ((lst source)
(res '())
(prev #f))
(if (null? lst)
(reverse
(cons (cons (make-cal-period (apply make-cal-month (car prev)) #f)
(cdr prev))
res))
(loop (cdr lst)
(if prev
(cons (cons (make-cal-period (apply make-cal-month (car prev))
(apply make-cal-month (caar lst)))
(cdr prev))
res)
res)
(car lst)))))
;; Looks up current month and returns associated definitions
(define (lookup-by-cal-period table)
(let loop ((lst table))
(if (null? lst)
#f
(if (cal-month-in-period? (caar lst))
(cdar lst)
(loop (cdr lst))))))
;; Wrapper that accepts either day or month and returns testable month
(define (cal-ensure-month v . stop?s)
(if v
(if (cal-month? v)
v
(if (cal-day? v)
(apply cal-day->month v stop?s)
#f))
#f))
;; Ensures day for checking the periods
(define (cal-ensure-day v)
(if v
(if (cal-day? v)
v
(if (cal-month? v)
(make-cal-day (cal-month-year v)
(cal-month-month v)
1)
#f))
#f))
;; Performs self-tests of the period module.
(define (cal-period-tests!)
(run-tests
cal-period
(test-equal? sort-period-markers
(sort-period-markers
`((start ,(make-cal-month 2023 1))
(stop ,(make-cal-month 2022 10))
(start ,(make-cal-month 2022 3))))
`((start ,(make-cal-month 2022 3)) `((start ,(make-cal-month 2022 3))
(stop ,(make-cal-month 2022 10)) (stop ,(make-cal-month 2022 10))
(start ,(make-cal-month 2023 1)) (start ,(make-cal-month 2023 1))))
(stop ,(make-cal-month 2023 4)))) (test-equal? period-markers->cal-periods
`(#t (period-markers->cal-periods
(,(make-cal-period (make-cal-month 2022 3) `((start ,(make-cal-month 2022 3))
(make-cal-month 2022 10) #f #f) (stop ,(make-cal-month 2022 10))
,(make-cal-period (make-cal-month 2023 1) (start ,(make-cal-month 2023 1))
(make-cal-month 2023 4) #f #f)) (stop ,(make-cal-month 2023 4))))
"" `(#t
-1)) (,(make-cal-period (make-cal-month 2022 3)
(test-equal? period-markers->cal-periods-open (make-cal-month 2022 10) #f #f)
(period-markers->cal-periods ,(make-cal-period (make-cal-month 2023 1)
`((start ,(make-cal-month 2022 3)) (make-cal-month 2023 4) #f #f))
(stop ,(make-cal-month 2022 10)) ""
(start ,(make-cal-month 2023 1)) -1))
(stop ,(make-cal-month 2023 4)) (test-equal? period-markers->cal-periods-open
(start ,(make-cal-month 2023 5)))) (period-markers->cal-periods
`(#t `((start ,(make-cal-month 2022 3))
(,(make-cal-period (make-cal-month 2022 3) (stop ,(make-cal-month 2022 10))
(make-cal-month 2022 10) #f #f) (start ,(make-cal-month 2023 1))
,(make-cal-period (make-cal-month 2023 1) (stop ,(make-cal-month 2023 4))
(make-cal-month 2023 4) #f #f) (start ,(make-cal-month 2023 5))))
,(make-cal-period (make-cal-month 2023 5) #f #f #f)) `(#t
"" (,(make-cal-period (make-cal-month 2022 3)
-1)) (make-cal-month 2022 10) #f #f)
(test-eq? cal-period->duration ,(make-cal-period (make-cal-month 2023 1)
(cal-period->duration (make-cal-period (make-cal-month 2023 1) (make-cal-month 2023 4) #f #f)
(make-cal-month 2023 4) #f #f)) ,(make-cal-period (make-cal-month 2023 5) #f #f #f))
3) ""
(parameterize ((*current-month* (make-cal-month 2023 4))) -1))
(test-eq? cal-period->duration (test-eq? cal-period->duration
(cal-period->duration (make-cal-period (make-cal-month 2023 1) #f #f #f)) (cal-period->duration (make-cal-period (make-cal-month 2023 1)
3)) (make-cal-month 2023 4) #f #f))
(test-eq? cal-periods-duration 3)
(cal-periods-duration `(,(make-cal-period (make-cal-month 2022 3) (parameterize ((*current-month* (make-cal-month 2023 4)))
(make-cal-month 2022 10) #f #f) (test-eq? cal-period->duration
,(make-cal-period (make-cal-month 2023 1) (cal-period->duration (make-cal-period (make-cal-month 2023 1) #f #f #f))
(make-cal-month 2023 4) #f #f))) 3))
10) (test-eq? cal-periods-duration
(test-true cal-month-in-period? (cal-periods-duration `(,(make-cal-period (make-cal-month 2022 3)
(cal-month-in-period? (make-cal-period (make-cal-month 2022 1) (make-cal-month 2022 10) #f #f)
(make-cal-month 2022 4) #f #f) ,(make-cal-period (make-cal-month 2023 1)
(make-cal-month 2022 3))) (make-cal-month 2023 4) #f #f)))
(test-false cal-month-in-period? 10)
(test-true cal-month-in-period?
(cal-month-in-period? (make-cal-period (make-cal-month 2022 1) (cal-month-in-period? (make-cal-period (make-cal-month 2022 1)
(make-cal-month 2022 4) #f #f) (make-cal-month 2022 4) #f #f)
(make-cal-month 2022 5)))
(test-true cal-month-in-periods?
(cal-month-in-periods? `(,(make-cal-period (make-cal-month 2022 1)
(make-cal-month 2022 4) #f #f)
,(make-cal-period (make-cal-month 2023 5)
(make-cal-month 2023 10) #f #f))
(make-cal-month 2022 3))) (make-cal-month 2022 3)))
(test-true cal-month-in-periods? (test-false cal-month-in-period?
(cal-month-in-periods? `(,(make-cal-period (make-cal-month 2022 1) (cal-month-in-period? (make-cal-period (make-cal-month 2022 1)
(make-cal-month 2022 4) #f #f) (make-cal-month 2022 4) #f #f)
,(make-cal-period (make-cal-month 2023 5) (make-cal-month 2022 5)))
(make-cal-month 2023 10) #f #f)) (test-true cal-month-in-periods?
(make-cal-month 2023 7)))
(test-false cal-month-in-periods?
(cal-month-in-periods? `(,(make-cal-period (make-cal-month 2022 1) (cal-month-in-periods? `(,(make-cal-period (make-cal-month 2022 1)
(make-cal-month 2022 4) #f #f) (make-cal-month 2022 4) #f #f)
,(make-cal-period (make-cal-month 2023 5) ,(make-cal-period (make-cal-month 2023 5)
(make-cal-month 2023 10) #f #f)) (make-cal-month 2023 10) #f #f))
(make-cal-month 2022 10))) (make-cal-month 2022 3)))
(test-equal? cal-period->string (test-true cal-month-in-periods?
(cal-period->string (make-cal-period (make-cal-month 2022 1) (cal-month-in-periods? `(,(make-cal-period (make-cal-month 2022 1)
(make-cal-month 2022 4) #f #f)) (make-cal-month 2022 4) #f #f)
"2022-01..2022-04") ,(make-cal-period (make-cal-month 2023 5)
(test-equal? cal-periods->string (make-cal-month 2023 10) #f #f))
(cal-periods->string `(,(make-cal-period (make-cal-month 2022 1) (make-cal-month 2023 7)))
(make-cal-month 2022 4) #f #f) (test-false cal-month-in-periods?
,(make-cal-period (make-cal-month 2022 12) (cal-month-in-periods? `(,(make-cal-period (make-cal-month 2022 1)
(make-cal-month 2023 2) #f #f))) (make-cal-month 2022 4) #f #f)
"2022-01..2022-04, 2022-12..2023-02") ,(make-cal-period (make-cal-month 2023 5)
(test-false cal-periods-match (make-cal-month 2023 10) #f #f))
(cal-periods-match `(,(make-cal-period (make-cal-month 2022 1) (make-cal-month 2022 10)))
(make-cal-month 2022 4) #f #f) (test-equal? cal-period->string
,(make-cal-period (make-cal-month 2022 12) (cal-period->string (make-cal-period (make-cal-month 2022 1)
(make-cal-month 2023 2) #f #f)) (make-cal-month 2022 4) #f #f))
(make-cal-month 2022 5))) "2022-01..2022-04")
(test-equal? cal-periods-match (test-equal? cal-periods->string
(cal-periods->string `(,(make-cal-period (make-cal-month 2022 1)
(make-cal-month 2022 4) #f #f)
,(make-cal-period (make-cal-month 2022 12)
(make-cal-month 2023 2) #f #f)))
"2022-01..2022-04, 2022-12..2023-02")
(test-false cal-periods-match
(cal-periods-match `(,(make-cal-period (make-cal-month 2022 1) (cal-periods-match `(,(make-cal-period (make-cal-month 2022 1)
(make-cal-month 2022 4) #f #f) (make-cal-month 2022 4) #f #f)
,(make-cal-period (make-cal-month 2022 12) ,(make-cal-period (make-cal-month 2022 12)
(make-cal-month 2023 2) #f #f)) (make-cal-month 2023 2) #f #f))
(make-cal-month 2022 2)) (make-cal-month 2022 5)))
(make-cal-period (make-cal-month 2022 1) (test-equal? cal-periods-match
(make-cal-month 2022 4) #f #f)) (cal-periods-match `(,(make-cal-period (make-cal-month 2022 1)
)) (make-cal-month 2022 4) #f #f)
,(make-cal-period (make-cal-month 2022 12)
(make-cal-month 2023 2) #f #f))
(make-cal-month 2022 2))
(make-cal-period (make-cal-month 2022 1)
(make-cal-month 2022 4) #f #f))
))
) )

14
src/mbase-query.scm
View file

@ -47,6 +47,13 @@
(define (members-base-oldest-month mb) (define (members-base-oldest-month mb)
(make-cal-month 2015 1)) (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. ;; Returns dictionary with statistics about the members base.
(define (mbase-info mb-arg) (define (mbase-info mb-arg)
(let* ((members (find-members-by-predicate mb-arg brmember-usable?)) (let* ((members (find-members-by-predicate mb-arg brmember-usable?))
@ -81,10 +88,10 @@
(map (lambda (v) (map (lambda (v)
(min 0 v)) (min 0 v))
mbals)))) mbals))))
;; debts of fees (di13 (ldict-set di12 'age
;; add average age of active members (members-average-age active-members)))
) )
di12)) di13))
;; Returns a list two lists: keys, data. ;; Returns a list two lists: keys, data.
;; Each data record contains values for all keys. ;; Each data record contains values for all keys.
@ -93,6 +100,7 @@
'(month '(month
total active suspended students destroyed invalid total active suspended students destroyed invalid
expected balance advance debt expected balance advance debt
age
))) )))
(let mloop ((data '()) (let mloop ((data '())
(month (members-base-oldest-month mb))) (month (members-base-oldest-month mb)))