Finish new stats.
This commit is contained in:
parent
227787597d
commit
6cfdf705c8
3 changed files with 471 additions and 445 deletions
|
|
@ -87,6 +87,8 @@
|
|||
|
||||
brmember-spec-fee
|
||||
|
||||
brmember-age
|
||||
|
||||
brmember-tests!
|
||||
)
|
||||
|
||||
|
|
@ -492,6 +494,18 @@
|
|||
#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
|
||||
(define (brmember-tests!)
|
||||
(run-tests
|
||||
|
|
|
|||
|
|
@ -26,460 +26,464 @@
|
|||
(declare (unit cal-period))
|
||||
|
||||
(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
|
||||
(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))
|
||||
(stop ,(make-cal-month 2022 10))
|
||||
(start ,(make-cal-month 2023 1))))
|
||||
(test-equal? period-markers->cal-periods
|
||||
(period-markers->cal-periods
|
||||
(
|
||||
current-year
|
||||
*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))
|
||||
|
||||
(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))
|
||||
(stop ,(make-cal-month 2022 10))
|
||||
(start ,(make-cal-month 2023 1))
|
||||
(stop ,(make-cal-month 2023 4))))
|
||||
`(#t
|
||||
(,(make-cal-period (make-cal-month 2022 3)
|
||||
(make-cal-month 2022 10) #f #f)
|
||||
,(make-cal-period (make-cal-month 2023 1)
|
||||
(make-cal-month 2023 4) #f #f))
|
||||
""
|
||||
-1))
|
||||
(test-equal? period-markers->cal-periods-open
|
||||
(period-markers->cal-periods
|
||||
`((start ,(make-cal-month 2022 3))
|
||||
(stop ,(make-cal-month 2022 10))
|
||||
(start ,(make-cal-month 2023 1))
|
||||
(stop ,(make-cal-month 2023 4))
|
||||
(start ,(make-cal-month 2023 5))))
|
||||
`(#t
|
||||
(,(make-cal-period (make-cal-month 2022 3)
|
||||
(make-cal-month 2022 10) #f #f)
|
||||
,(make-cal-period (make-cal-month 2023 1)
|
||||
(make-cal-month 2023 4) #f #f)
|
||||
,(make-cal-period (make-cal-month 2023 5) #f #f #f))
|
||||
""
|
||||
-1))
|
||||
(test-eq? cal-period->duration
|
||||
(cal-period->duration (make-cal-period (make-cal-month 2023 1)
|
||||
(make-cal-month 2023 4) #f #f))
|
||||
3)
|
||||
(parameterize ((*current-month* (make-cal-month 2023 4)))
|
||||
(test-eq? cal-period->duration
|
||||
(cal-period->duration (make-cal-period (make-cal-month 2023 1) #f #f #f))
|
||||
3))
|
||||
(test-eq? cal-periods-duration
|
||||
(cal-periods-duration `(,(make-cal-period (make-cal-month 2022 3)
|
||||
(make-cal-month 2022 10) #f #f)
|
||||
,(make-cal-period (make-cal-month 2023 1)
|
||||
(make-cal-month 2023 4) #f #f)))
|
||||
10)
|
||||
(test-true cal-month-in-period?
|
||||
(cal-month-in-period? (make-cal-period (make-cal-month 2022 1)
|
||||
(make-cal-month 2022 4) #f #f)
|
||||
(make-cal-month 2022 3)))
|
||||
(test-false cal-month-in-period?
|
||||
(start ,(make-cal-month 2023 1))))
|
||||
(test-equal? period-markers->cal-periods
|
||||
(period-markers->cal-periods
|
||||
`((start ,(make-cal-month 2022 3))
|
||||
(stop ,(make-cal-month 2022 10))
|
||||
(start ,(make-cal-month 2023 1))
|
||||
(stop ,(make-cal-month 2023 4))))
|
||||
`(#t
|
||||
(,(make-cal-period (make-cal-month 2022 3)
|
||||
(make-cal-month 2022 10) #f #f)
|
||||
,(make-cal-period (make-cal-month 2023 1)
|
||||
(make-cal-month 2023 4) #f #f))
|
||||
""
|
||||
-1))
|
||||
(test-equal? period-markers->cal-periods-open
|
||||
(period-markers->cal-periods
|
||||
`((start ,(make-cal-month 2022 3))
|
||||
(stop ,(make-cal-month 2022 10))
|
||||
(start ,(make-cal-month 2023 1))
|
||||
(stop ,(make-cal-month 2023 4))
|
||||
(start ,(make-cal-month 2023 5))))
|
||||
`(#t
|
||||
(,(make-cal-period (make-cal-month 2022 3)
|
||||
(make-cal-month 2022 10) #f #f)
|
||||
,(make-cal-period (make-cal-month 2023 1)
|
||||
(make-cal-month 2023 4) #f #f)
|
||||
,(make-cal-period (make-cal-month 2023 5) #f #f #f))
|
||||
""
|
||||
-1))
|
||||
(test-eq? cal-period->duration
|
||||
(cal-period->duration (make-cal-period (make-cal-month 2023 1)
|
||||
(make-cal-month 2023 4) #f #f))
|
||||
3)
|
||||
(parameterize ((*current-month* (make-cal-month 2023 4)))
|
||||
(test-eq? cal-period->duration
|
||||
(cal-period->duration (make-cal-period (make-cal-month 2023 1) #f #f #f))
|
||||
3))
|
||||
(test-eq? cal-periods-duration
|
||||
(cal-periods-duration `(,(make-cal-period (make-cal-month 2022 3)
|
||||
(make-cal-month 2022 10) #f #f)
|
||||
,(make-cal-period (make-cal-month 2023 1)
|
||||
(make-cal-month 2023 4) #f #f)))
|
||||
10)
|
||||
(test-true cal-month-in-period?
|
||||
(cal-month-in-period? (make-cal-period (make-cal-month 2022 1)
|
||||
(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)))
|
||||
(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 2023 7)))
|
||||
(test-false cal-month-in-periods?
|
||||
(test-false cal-month-in-period?
|
||||
(cal-month-in-period? (make-cal-period (make-cal-month 2022 1)
|
||||
(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 10)))
|
||||
(test-equal? cal-period->string
|
||||
(cal-period->string (make-cal-period (make-cal-month 2022 1)
|
||||
(make-cal-month 2022 4) #f #f))
|
||||
"2022-01..2022-04")
|
||||
(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)
|
||||
(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 5)))
|
||||
(test-equal? cal-periods-match
|
||||
(make-cal-month 2022 3)))
|
||||
(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 2023 7)))
|
||||
(test-false 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 10)))
|
||||
(test-equal? cal-period->string
|
||||
(cal-period->string (make-cal-period (make-cal-month 2022 1)
|
||||
(make-cal-month 2022 4) #f #f))
|
||||
"2022-01..2022-04")
|
||||
(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)
|
||||
(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))
|
||||
))
|
||||
(make-cal-month 2022 5)))
|
||||
(test-equal? cal-periods-match
|
||||
(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))
|
||||
))
|
||||
|
||||
)
|
||||
)
|
||||
|
|
|
|||
|
|
@ -47,6 +47,13 @@
|
|||
(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?))
|
||||
|
|
@ -81,10 +88,10 @@
|
|||
(map (lambda (v)
|
||||
(min 0 v))
|
||||
mbals))))
|
||||
;; debts of fees
|
||||
;; add average age of active members
|
||||
(di13 (ldict-set di12 'age
|
||||
(members-average-age active-members)))
|
||||
)
|
||||
di12))
|
||||
di13))
|
||||
|
||||
;; Returns a list two lists: keys, data.
|
||||
;; Each data record contains values for all keys.
|
||||
|
|
@ -93,6 +100,7 @@
|
|||
'(month
|
||||
total active suspended students destroyed invalid
|
||||
expected balance advance debt
|
||||
age
|
||||
)))
|
||||
(let mloop ((data '())
|
||||
(month (members-base-oldest-month mb)))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue