Compare commits
No commits in common. "5f4724874eeb4d486ef8dce499f876b785970eeb" and "a86063e7221d998005e2764b01998430cc350922" have entirely different histories.
5f4724874e
...
a86063e722
16 changed files with 626 additions and 1002 deletions
|
|
@ -1,14 +1,6 @@
|
|||
ChangeLog
|
||||
=========
|
||||
|
||||
1.18 - released 2025-01-06
|
||||
--------------------------
|
||||
|
||||
* fix typo in members-print
|
||||
* create LaTeX source of general meeting attendance sheet
|
||||
* add expected income, cash flow and average age to stats
|
||||
* add QR code payment in CZK on members' payments pages'
|
||||
|
||||
1.17 - released 2024-10-01
|
||||
--------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -273,6 +273,10 @@ Specify member by nickname.
|
|||
.B \-destroyed
|
||||
Show destroyed members in \fB-fees\fR action as well.
|
||||
|
||||
.TP
|
||||
.B \-ml-all
|
||||
Load all mailman list memberships to show them in members info.
|
||||
|
||||
.SH "FILES"
|
||||
|
||||
All the information about members is stored in in members file in the
|
||||
|
|
|
|||
47
src/Makefile
47
src/Makefile
|
|
@ -42,9 +42,7 @@ HACKERBASE-DEPS=hackerbase.scm cal-month.import.scm \
|
|||
tests.import.scm notifications.import.scm logging.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 mbase-query.import.scm \
|
||||
qr-payment.import.scm
|
||||
dokuwiki.import.scm mailinglist.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 \
|
||||
|
|
@ -60,9 +58,9 @@ HACKERBASE-OBJS=hackerbase.o testing.o listing.o cal-month.o \
|
|||
table-style.o sgr-state.o util-utf8.o sgr-cell.o \
|
||||
template-list-expander.o box-drawing.o export-web-static.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 \
|
||||
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 mbase-query.o qr-payment.o
|
||||
mailinglist.o
|
||||
|
||||
GENDOC-SOURCES=gendoc.scm duck-extract.import.scm \
|
||||
util-time.import.scm util-csv.import.scm util-git.import.scm \
|
||||
|
|
@ -260,6 +258,13 @@ ENVIRONMENT-SOURCES=environment.scm ansi.import.scm
|
|||
environment.o: environment.import.scm
|
||||
environment.import.scm: $(ENVIRONMENT-SOURCES)
|
||||
|
||||
MAILMAN2-SOURCES=mailman2.scm util-bst-lset.import.scm \
|
||||
util-io.import.scm mailman-common.import.scm \
|
||||
configuration.import.scm
|
||||
|
||||
mailman2.o: mailman2.import.scm
|
||||
mailman2.import.scm: $(MAILMAN2-SOURCES)
|
||||
|
||||
UTIL-TIME-SOURCES=util-time.scm duck.import.scm
|
||||
|
||||
util-time.o: util-time.import.scm
|
||||
|
|
@ -468,8 +473,7 @@ box-drawing.import.scm: $(BOX-DRAWING-SOURCES)
|
|||
EXPORT-WEB-STATIC-SOURCES=export-web-static.scm brmember.import.scm \
|
||||
util-dir.import.scm mbase.import.scm \
|
||||
members-payments.import.scm cal-day.import.scm \
|
||||
util-git.import.scm configuration.import.scm texts.import.scm \
|
||||
members-fees.import.scm qr-payment.import.scm
|
||||
util-git.import.scm configuration.import.scm texts.import.scm
|
||||
|
||||
export-web-static.o: export-web-static.import.scm
|
||||
export-web-static.import.scm: $(EXPORT-WEB-STATIC-SOURCES)
|
||||
|
|
@ -520,9 +524,10 @@ UTIL-BST-LSET-SOURCES=util-bst-lset.scm util-bst.import.scm \
|
|||
util-bst-lset.o: util-bst-lset.import.scm
|
||||
util-bst-lset.import.scm: $(UTIL-BST-LSET-SOURCES)
|
||||
|
||||
MAILMAN-SOURCES=mailman.scm mailman-common.import.scm \
|
||||
util-bst-lset.import.scm configuration.import.scm \
|
||||
mailman3.import.scm progress.import.scm
|
||||
MAILMAN-SOURCES=mailman.scm mailman2.import.scm \
|
||||
mailman-common.import.scm util-bst-lset.import.scm \
|
||||
configuration.import.scm mailman3.import.scm \
|
||||
progress.import.scm
|
||||
|
||||
mailman.o: mailman.import.scm
|
||||
mailman.import.scm: $(MAILMAN-SOURCES)
|
||||
|
|
@ -554,25 +559,3 @@ MAILINGLIST-SOURCES=mailinglist.scm racket-kwargs.import.scm \
|
|||
|
||||
mailinglist.o: mailinglist.import.scm
|
||||
mailinglist.import.scm: $(MAILINGLIST-SOURCES)
|
||||
|
||||
EXPORT-SHEET-SOURCES=export-sheet.scm mbase.import.scm \
|
||||
brmember.import.scm brmember-format.import.scm \
|
||||
util-bst-ldict.import.scm members-payments.import.scm \
|
||||
util-format.import.scm members-fees.import.scm \
|
||||
cal-period.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 \
|
||||
members-fees.import.scm members-payments.import.scm
|
||||
|
||||
mbase-query.o: mbase-query.import.scm
|
||||
mbase-query.import.scm: $(MBASE-QUERY-SOURCES)
|
||||
|
||||
QR-PAYMENT-SOURCES=qr-payment.scm util-io.import.scm
|
||||
|
||||
qr-payment.o: qr-payment.import.scm
|
||||
qr-payment.import.scm: $(QR-PAYMENT-SOURCES)
|
||||
|
|
|
|||
|
|
@ -87,8 +87,6 @@
|
|||
|
||||
brmember-spec-fee
|
||||
|
||||
brmember-age
|
||||
|
||||
brmember-tests!
|
||||
)
|
||||
|
||||
|
|
@ -494,18 +492,6 @@
|
|||
#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,464 +26,460 @@
|
|||
(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
|
||||
(
|
||||
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))))
|
||||
(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
|
||||
`((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
|
||||
`((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?
|
||||
(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?
|
||||
(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-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?
|
||||
(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 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
|
||||
(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
|
||||
(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
|
||||
(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 2))
|
||||
(make-cal-period (make-cal-month 2022 1)
|
||||
(make-cal-month 2022 4) #f #f))
|
||||
))
|
||||
|
||||
)
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,226 +0,0 @@
|
|||
;;
|
||||
;; export-sheet.scm
|
||||
;;
|
||||
;; Export attendance sheet as MarkDown document.
|
||||
;;
|
||||
;; ISC License
|
||||
;;
|
||||
;; Copyright 2024 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 export-sheet))
|
||||
|
||||
(module
|
||||
export-sheet
|
||||
(
|
||||
print-attendance-sheet
|
||||
)
|
||||
|
||||
(import scheme
|
||||
(chicken base)
|
||||
(chicken string)
|
||||
(chicken format)
|
||||
(chicken sort)
|
||||
srfi-1
|
||||
mbase
|
||||
brmember
|
||||
brmember-format
|
||||
util-bst-ldict
|
||||
members-payments
|
||||
util-format
|
||||
members-fees
|
||||
cal-period
|
||||
cal-day)
|
||||
|
||||
(define (print-attendance-sheet MB number)
|
||||
(print "\\documentclass{article}")
|
||||
(print "\\usepackage{fancyhdr}")
|
||||
(print "\\usepackage{longtable}")
|
||||
(print "\\usepackage{lastpage}")
|
||||
(print "\\usepackage[top=3cm,left=1cm,right=2cm,bottom=3cm]{geometry}")
|
||||
(print "\\lhead{}")
|
||||
(print
|
||||
(format
|
||||
"\\chead{Prezenční listina ~A. Valné Hromady brmlab z.s. konané ~A. ~A. ~A v sídle spolku}"
|
||||
number
|
||||
(cal-day-day (*current-day*))
|
||||
(cal-day-month (*current-day*))
|
||||
(cal-day-year (*current-day*))
|
||||
))
|
||||
(print "\\rhead{}")
|
||||
(print "\\renewcommand{\\headrulewidth}{0pt}")
|
||||
(print "\\lfoot{}")
|
||||
(print "\\cfoot{Strana \\thepage{} ze \\pageref*{LastPage}}")
|
||||
(print "\\rfoot{}")
|
||||
(print "\\pagestyle{fancy}")
|
||||
(print "\\begin{document}")
|
||||
(print "\\begin{center}")
|
||||
(newline)
|
||||
(print "\\vskip1em")
|
||||
(newline)
|
||||
(define colnames
|
||||
'((id) Nick "Jméno" "Příjmení" (Fee) (Bilance)
|
||||
("\\raisebox{2pt}{\\begin{minipage}{15mm}\\begin{center}Aktivní\\\\Měsíce\\end{center}\\end{minipage}}")
|
||||
((Hlas?)) Podpis))
|
||||
(print "\\renewcommand\\arraystretch{2.1}")
|
||||
(print
|
||||
(format
|
||||
"\\begin{longtable}{|~A|}"
|
||||
(string-intersperse
|
||||
(map
|
||||
(lambda (x)
|
||||
(if (list? x)
|
||||
(if (list? (car x))
|
||||
"c"
|
||||
"r")
|
||||
"l"))
|
||||
colnames)
|
||||
"|")))
|
||||
(print "\\hline")
|
||||
(print
|
||||
(string-intersperse
|
||||
(map
|
||||
(lambda (x)
|
||||
(format
|
||||
"\\textbf{~A}"
|
||||
(if (symbol? x)
|
||||
(symbol->string x)
|
||||
(if (string? x)
|
||||
x
|
||||
(if (string? (car x))
|
||||
(car x)
|
||||
(if (list? (car x))
|
||||
(symbol->string (caar x))
|
||||
(symbol->string (car x))))))))
|
||||
colnames)
|
||||
"&")
|
||||
"\\\\")
|
||||
(print "\\hline")
|
||||
(print "\\endhead")
|
||||
(define valid-voters 0)
|
||||
(define ok-balances 0)
|
||||
(define ok-actives 0)
|
||||
(let loop ((mrs (sort
|
||||
(find-members-by-predicate
|
||||
MB (lambda (mr)
|
||||
(brmember-active? mr)))
|
||||
(lambda (a b)
|
||||
(string<? (brmember-nick a)
|
||||
(brmember-nick b))))))
|
||||
(when (not (null? mrs))
|
||||
(let* ((mr (car mrs))
|
||||
(info (ldict-ref mr 'info))
|
||||
(name (ldict-ref info 'name "ERROR"))
|
||||
(name* (string-translate*
|
||||
name
|
||||
'(("_" . " "))))
|
||||
(namel (string-split name*))
|
||||
(sname (car (reverse namel)))
|
||||
(fname
|
||||
(string-intersperse
|
||||
(reverse
|
||||
(cdr
|
||||
(reverse namel)))
|
||||
" "))
|
||||
(cal (member-calendar mr))
|
||||
(rcal (reverse cal))
|
||||
(rcal12
|
||||
(if (> (length rcal) 12)
|
||||
(take rcal 12)
|
||||
rcal))
|
||||
(acal12 (map cadr rcal12))
|
||||
(acal12* (map (lambda (f) (if (memq 'active f) 1 0)) acal12))
|
||||
(numactive (foldl + 0 acal12*))
|
||||
(spec-fee (brmember-spec-fee mr))
|
||||
(current-fee (if spec-fee
|
||||
spec-fee
|
||||
(member-calendar-entry->fee
|
||||
(list (*current-month*)
|
||||
(brmember-flags mr)
|
||||
spec-fee))))
|
||||
(balance-ok? (>= (member-total-balance mr)
|
||||
(- current-fee)))
|
||||
(active-ok? (>= numactive 9))
|
||||
(vote-ok? (and balance-ok? active-ok?))
|
||||
)
|
||||
(when balance-ok?
|
||||
(set! ok-balances (+ ok-balances 1)))
|
||||
(when active-ok?
|
||||
(set! ok-actives (+ ok-actives 1)))
|
||||
(when vote-ok?
|
||||
(set! valid-voters (+ valid-voters 1)))
|
||||
(print
|
||||
(brmember-id mr)
|
||||
" & "
|
||||
(string-translate*
|
||||
(brmember-nick mr)
|
||||
'(("_" . "\\_")))
|
||||
" & \\small "
|
||||
fname
|
||||
" & \\small "
|
||||
sname
|
||||
" & "
|
||||
current-fee
|
||||
" & "
|
||||
"\\raisebox{2pt}{\\begin{minipage}{15mm}\\begin{flushright}"
|
||||
(format-amount-tex
|
||||
(member-total-balance mr))
|
||||
"\\\\"
|
||||
(if balance-ok?
|
||||
"Bez~dluhu"
|
||||
"---~~~~~~")
|
||||
"\\end{flushright}\\end{minipage}}"
|
||||
" & "
|
||||
;(if balance-ok?
|
||||
; "Y"
|
||||
; "--")
|
||||
;" & "
|
||||
"\\raisebox{2pt}{\\begin{minipage}{12mm}\\begin{center}"
|
||||
numactive "/" 12
|
||||
"\\\\"
|
||||
(if active-ok?
|
||||
"Splněno"
|
||||
"\\phantom{Sp}---\\phantom{Sp}")
|
||||
"\\end{center}\\end{minipage}}"
|
||||
" & "
|
||||
;(if active-ok?
|
||||
; "Y"
|
||||
; "--")
|
||||
;" & "
|
||||
(if vote-ok?
|
||||
"Ano"
|
||||
"--")
|
||||
" & "
|
||||
"~\\hskip28mm~"
|
||||
" \\\\")
|
||||
(print "\\hline")
|
||||
(loop (cdr mrs)))))
|
||||
(print "\\end{longtable}")
|
||||
(print "\\end{center}")
|
||||
(print "\\end{document}")
|
||||
(print "% valid-voters = " valid-voters)
|
||||
(print "% valid-balances = " ok-balances)
|
||||
(print "% valid-actives = " ok-actives)
|
||||
)
|
||||
|
||||
(define (format-amount-tex amt)
|
||||
(string-translate*
|
||||
(format-amount amt)
|
||||
'(("--" . "--{}--"))))
|
||||
|
||||
)
|
||||
|
|
@ -45,9 +45,7 @@
|
|||
util-git
|
||||
configuration
|
||||
texts
|
||||
logging
|
||||
qr-payment
|
||||
members-fees)
|
||||
logging)
|
||||
|
||||
;; HTML entities
|
||||
(define (sanitize-html str)
|
||||
|
|
@ -90,8 +88,6 @@
|
|||
(print "dd+dt,dd+dt+dd{border-top:1px solid #8cacbb}")
|
||||
(print "dd{grid-column:2/3;font-weight:bold;margin:0px;padding-left:16px}")
|
||||
(print "footer{background:#dee7ec;border-top:1px solid #8cacbb;padding:16px}")
|
||||
(print ".qr svg{width:100%;height:auto;max-width:10cm}")
|
||||
(print ".qr{text-align: center}")
|
||||
(print "</style>")
|
||||
(print "</head>")
|
||||
(print "<body>")
|
||||
|
|
@ -113,13 +109,6 @@
|
|||
(print "<dt>Account for Payments<br>(Účet pro platbu příspěvků)</dt><dd>CZK: 2500079551/2010<br>EUR: CZ93 2010 0000 0021 0007 9552</dd>")
|
||||
(print "</dl>")
|
||||
(print "</div>")
|
||||
(print "<div class=\"bi qr\">")
|
||||
(let ((fee (member-calendar-entry->fee
|
||||
(make-member-calendar-entry mr))))
|
||||
(print "<h2>Payment of membership fee " fee " CZK<br/>(Platba členského příspěvku)</h2>")
|
||||
(print (make-brmlab-qrp-svg-string
|
||||
fee "CZK" (brmember-id mr))))
|
||||
(print "</div>")
|
||||
(print "<div class=\"bi\">")
|
||||
(print "<h2>Payments History</h2>")
|
||||
(print "<table>")
|
||||
|
|
|
|||
|
|
@ -51,9 +51,7 @@
|
|||
dokuwiki
|
||||
racket-kwargs
|
||||
util-string
|
||||
mailinglist
|
||||
export-sheet
|
||||
mbase-query)
|
||||
mailinglist)
|
||||
|
||||
;; Command-line options and configurable parameters
|
||||
(define -needs-bank- (make-parameter #f))
|
||||
|
|
@ -68,7 +66,6 @@
|
|||
(define -show-only-active- (make-parameter #f))
|
||||
(define -notify-months- (make-parameter 1))
|
||||
(define -send-emails- (make-parameter #f))
|
||||
(define -number- (make-parameter #f))
|
||||
|
||||
;; Arguments parsing
|
||||
(command-line
|
||||
|
|
@ -184,14 +181,7 @@
|
|||
(-action- 'genweb))
|
||||
(-stats (file:gnuplot-data) "Get stats for all months"
|
||||
(-action- 'print-stats)
|
||||
(-needs-bank- #t)
|
||||
(-fname- file:gnuplot-data))
|
||||
(-sheet (filename gmnum) "Generate attendance sheet for given GM number"
|
||||
(-needs-bank- #t)
|
||||
(-fname- filename)
|
||||
(-number- gmnum)
|
||||
(-action- 'gen-sheet))
|
||||
|
||||
""
|
||||
"Mailman Actions:"
|
||||
(-mlsync () "Synchronize internal ML"
|
||||
|
|
@ -364,10 +354,6 @@
|
|||
((genweb)
|
||||
(log-info "Generating static web files")
|
||||
(gen-html-members MB (-web-dir-)))
|
||||
((gen-sheet)
|
||||
(log-info "Generating attendance sheet")
|
||||
(parameterize ((current-output-port (open-output-file (-fname-))))
|
||||
(print-attendance-sheet MB (-number-))))
|
||||
((edit)
|
||||
(if mr
|
||||
(let ()
|
||||
|
|
|
|||
|
|
@ -49,6 +49,7 @@
|
|||
(import scheme
|
||||
(chicken base)
|
||||
(chicken module)
|
||||
mailman2
|
||||
mailman-common
|
||||
util-bst-lset
|
||||
configuration
|
||||
|
|
@ -58,17 +59,24 @@
|
|||
;; Syntax for simplifying export of case-version procedures
|
||||
(define-syntax define-mailman-proc
|
||||
(syntax-rules ()
|
||||
((_ name proc3)
|
||||
((_ name proc2)
|
||||
(begin
|
||||
(export name)
|
||||
(define (name . args)
|
||||
(case (*mailman-version*)
|
||||
((2) (apply proc2 args))))))
|
||||
((_ name proc2 proc3)
|
||||
(begin
|
||||
(export name)
|
||||
(define (name . args)
|
||||
(case (*mailman-version*)
|
||||
((2) (apply proc2 args))
|
||||
((3) (apply proc3 args))))))))
|
||||
|
||||
(define-mailman-proc list-mailman-lists
|
||||
list-mailman3-lists)
|
||||
list-mailman2-lists list-mailman3-lists)
|
||||
(define-mailman-proc list-mailman-list-members
|
||||
list-mailman3-list-members)
|
||||
list-mailman2-list-members list-mailman3-list-members)
|
||||
|
||||
;; Loads a single mailman list as mailman structure, if
|
||||
;; unsuccessfull, returns only a list with ML name and no member
|
||||
|
|
@ -104,9 +112,9 @@
|
|||
(assoc name lsts))
|
||||
|
||||
(define-mailman-proc add-email-to-mailman-list
|
||||
add-email-to-mailman3-list)
|
||||
add-email-to-mailman2-list add-email-to-mailman3-list)
|
||||
(define-mailman-proc remove-email-from-mailman-list
|
||||
remove-email-from-mailman3-list)
|
||||
remove-email-from-mailman2-list remove-email-from-mailman3-list)
|
||||
|
||||
;; Ensures given email is in given ML
|
||||
(define (mailman-ensure-member ml email)
|
||||
|
|
|
|||
104
src/mailman2.scm
Normal file
104
src/mailman2.scm
Normal file
|
|
@ -0,0 +1,104 @@
|
|||
;;
|
||||
;; mailman2.scm
|
||||
;;
|
||||
;; Mailman management interface - Mailman version 2.x support
|
||||
;;
|
||||
;; ISC License
|
||||
;;
|
||||
;; Copyright 2023 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 mailman2))
|
||||
|
||||
(module
|
||||
mailman2
|
||||
(
|
||||
list-mailman2-lists
|
||||
list-mailman2-list-members
|
||||
|
||||
add-email-to-mailman2-list
|
||||
remove-email-from-mailman2-list
|
||||
)
|
||||
|
||||
(import scheme
|
||||
(chicken base)
|
||||
(chicken pathname)
|
||||
(chicken string)
|
||||
(chicken sort)
|
||||
(chicken format)
|
||||
srfi-1
|
||||
util-bst-lset
|
||||
util-io
|
||||
mailman-common
|
||||
configuration)
|
||||
|
||||
;; Returns full path to given mailman binary
|
||||
(define (mailman-bin bin)
|
||||
(make-pathname (*mailman2-bin*) bin))
|
||||
|
||||
;; Mailman-specific process output lines capture
|
||||
(define (get-mailman-output-lines bin . args)
|
||||
(apply
|
||||
get-process-output-lines
|
||||
(mailman-bin bin)
|
||||
args))
|
||||
|
||||
;; Sends all lines to the process
|
||||
(define (mailman-send/recv bin args . lines)
|
||||
(apply
|
||||
process-send/recv
|
||||
(mailman-bin bin)
|
||||
args
|
||||
lines))
|
||||
|
||||
;; Returns the list of available lists
|
||||
(define (list-mailman2-lists)
|
||||
(get-mailman-output-lines "list_lists" "-b"))
|
||||
|
||||
;; Returns the list of members of given list
|
||||
(define (list-mailman2-list-members lst)
|
||||
(sort
|
||||
(get-mailman-output-lines "list_members" lst)
|
||||
string-ci<?))
|
||||
|
||||
;; Adds given email to given listname
|
||||
(define (add-email-to-mailman2-list listname email)
|
||||
(print "Add " email " to " listname ".")
|
||||
(let ((result
|
||||
(mailman-send/recv
|
||||
"add_members"
|
||||
(list "-r" "-" listname)
|
||||
email)))
|
||||
(let loop ((lines result))
|
||||
(when (not (null? lines))
|
||||
(print " | " (car lines))
|
||||
(loop (cdr lines))))))
|
||||
|
||||
;; Removes given email from given listname
|
||||
(define (remove-email-from-mailman2-list listname email)
|
||||
(print "Remove " email " from " listname ".")
|
||||
(let ((result
|
||||
(get-mailman-output-lines
|
||||
"remove_members" listname
|
||||
(sprintf "~A" email))))
|
||||
(let loop ((lines result))
|
||||
(when (not (null? lines))
|
||||
(print " | " (car lines))
|
||||
(loop (cdr lines))))))
|
||||
|
||||
)
|
||||
|
|
@ -1,123 +0,0 @@
|
|||
;;
|
||||
;; 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))))))
|
||||
|
||||
)
|
||||
|
|
@ -50,6 +50,8 @@
|
|||
mbase-update-by-id
|
||||
mbase-update
|
||||
|
||||
mbase-stats
|
||||
|
||||
mbase-add-unpaired
|
||||
mbase-unpaired
|
||||
|
||||
|
|
@ -205,6 +207,47 @@
|
|||
(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
|
||||
|
|
|
|||
|
|
@ -41,7 +41,6 @@
|
|||
member-calendar->table
|
||||
members-summary
|
||||
member-calendar-entry->fee
|
||||
get-expected-income
|
||||
get-expected-income-string
|
||||
)
|
||||
|
||||
|
|
@ -209,19 +208,6 @@
|
|||
(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)))
|
||||
(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)
|
||||
|
|
|
|||
|
|
@ -380,7 +380,7 @@
|
|||
(members-table-row (ansi #:magenta #:bold) "Expire Soon:"
|
||||
soon-expire-mrs "~N (~S)"))
|
||||
(members-pred-table-row mb
|
||||
(ansi-string #:red #:bold "Problems:")
|
||||
(ansi-string #:red #:bold "Prolems:")
|
||||
brmember-has-problems?
|
||||
"~N~E ~A")
|
||||
(if (null? debtor-mrs)
|
||||
|
|
|
|||
|
|
@ -1,104 +0,0 @@
|
|||
;;
|
||||
;; qr-payment.scm
|
||||
;;
|
||||
;; QR payment generator.
|
||||
;;
|
||||
;; 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 qr-payment))
|
||||
|
||||
(module
|
||||
qr-payment
|
||||
(
|
||||
make-qrp
|
||||
make-brmlab-qrp
|
||||
make-brmlab-qrp-svg-string
|
||||
)
|
||||
|
||||
(import scheme
|
||||
(chicken format)
|
||||
(chicken string)
|
||||
(chicken base)
|
||||
util-io)
|
||||
|
||||
(define (make-empty-qrp . vs)
|
||||
(let ((v (if (null? vs) "1.0" (car vs))))
|
||||
(list v "SPD")))
|
||||
|
||||
(define (add-field-to-qrp qrp key value)
|
||||
(cons (format "~A:~A" key value)
|
||||
qrp))
|
||||
|
||||
(define (serialize-qrp qrp)
|
||||
(string-intersperse (reverse qrp) "*"))
|
||||
|
||||
(define (ensure-amount-format amt)
|
||||
(let* ((n (if (string? amt)
|
||||
(string->number amt)
|
||||
amt))
|
||||
(s (number->string n))
|
||||
(f (string-split s "."))
|
||||
(i? (null? (cdr f))))
|
||||
(format "~A.~A"
|
||||
(car f)
|
||||
(if i?
|
||||
"00"
|
||||
(substring
|
||||
(string-append (cadr f) "0")
|
||||
0 2)))))
|
||||
|
||||
(define (make-qrp iban amt cc vs msg)
|
||||
(let loop ((keys '(ACC AM CC MSG X-VS))
|
||||
(vals (list iban (ensure-amount-format amt) cc msg vs))
|
||||
(qrp (make-empty-qrp)))
|
||||
(if (null? keys)
|
||||
(serialize-qrp qrp)
|
||||
(loop (cdr keys)
|
||||
(cdr vals)
|
||||
(add-field-to-qrp qrp (car keys) (car vals))))))
|
||||
|
||||
(define (make-brmlab-qrp amt cc vs)
|
||||
(let ((iban (if (equal? cc "CZK")
|
||||
"CZ0520100000002500079551"
|
||||
(if (equal? cc "EUR")
|
||||
"CZ9320100000002100079552"
|
||||
(error "Invalid currency!")))))
|
||||
(make-qrp iban amt cc vs "Brmlab")))
|
||||
|
||||
(define (qrp-create-svg-string qrps)
|
||||
(let-values
|
||||
(((ec ol)
|
||||
(get-process-exit+output-lines
|
||||
"qrencode"
|
||||
"-t" "svg"
|
||||
"--inline"
|
||||
"-o" "-"
|
||||
"-l" "M"
|
||||
qrps)))
|
||||
(if (eq? ec 0)
|
||||
(string-intersperse ol "\n")
|
||||
#f)))
|
||||
|
||||
(define (make-brmlab-qrp-svg-string amt cc vs)
|
||||
(qrp-create-svg-string
|
||||
(make-brmlab-qrp amt cc vs)))
|
||||
|
||||
)
|
||||
|
|
@ -5,7 +5,7 @@
|
|||
;;
|
||||
;; ISC License
|
||||
;;
|
||||
;; Copyright 2023-2025 Brmlab, z.s.
|
||||
;; Copyright 2023 Brmlab, z.s.
|
||||
;; Dominik Pantůček <dominik.pantucek@trustica.cz>
|
||||
;;
|
||||
;; Permission to use, copy, modify, and/or distribute this software
|
||||
|
|
@ -39,7 +39,7 @@
|
|||
(chicken format))
|
||||
|
||||
;; Short banner
|
||||
(define banner-line "HackerBase 1.19-dev (c) 2023-2025 Brmlab, z.s.")
|
||||
(define banner-line "HackerBase 1.17 (c) 2023-2024 Brmlab, z.s.")
|
||||
|
||||
;; Banner source with numbers for ANSI CSI SGR
|
||||
(define banner-source "
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue