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

Porting to new calendar modules.

Browse source
This commit is contained in:
Dominik Pantůček 2023-05-09 22:56:50 +02:00
parent 21a58e9536
commit cc463991c1
10 changed files with 57 additions and 545 deletions
Download patch file Download diff file Expand all files Collapse all files

57
src/Makefile
View file

@ -31,20 +31,20 @@ static: ../hackerbase
CSC=csc
HACKERBASE-DEPS=hackerbase.scm month.import.scm \
HACKERBASE-DEPS=hackerbase.scm cal-month.import.scm \
command-line.import.scm mbase.import.scm brmember.import.scm \
configuration.import.scm cards.import.scm \
members-print.import.scm members-payments.import.scm \
web-static.import.scm environment.import.scm \
mailman.import.scm texts.import.scm tests.import.scm \
notifications.import.scm logging.import.scm \
progress.import.scm period.import.scm
progress.import.scm cal-period.import.scm
HACKERBASE-OBJS=hackerbase.o testing.o listing.o month.o period.o \
ansi.o util-dict-list.o command-line.o mbase.o primes.o \
brmember.o configuration.o progress.o table.o cards.o \
members-print.o members-fees.o mbase-dir.o util-csv.o \
bank-account.o bank-fio.o members-payments.o \
HACKERBASE-OBJS=hackerbase.o testing.o listing.o cal-month.o \
cal-period.o ansi.o util-dict-list.o command-line.o mbase.o \
primes.o brmember.o configuration.o progress.o table.o \
cards.o members-print.o members-fees.o mbase-dir.o \
util-csv.o bank-account.o bank-fio.o members-payments.o \
brmember-parser.o web-static.o environment.o mailman.o \
util-set-list.o util-time.o util-tag.o util-io.o \
util-string.o util-io.o util-list.o util-parser.o texts.o \
@ -106,17 +106,6 @@ UTIL-DICT-LIST-SOURCES=util-dict-list.scm testing.import.scm \
util-dict-list.o: util-dict-list.import.scm
util-dict-list.import.scm: $(UTIL-DICT-LIST-SOURCES)
MONTH-SOURCES=month.scm testing.import.scm
month.o: month.import.scm
month.import.scm: $(MONTH-SOURCES)
PERIOD-SOURCES=period.scm testing.import.scm month.import.scm \
configuration.import.scm
period.o: period.import.scm
period.import.scm: $(PERIOD-SOURCES)
ANSI-SOURCES=ansi.scm testing.import.scm util-list.import.scm
ansi.o: ansi.import.scm
@ -130,9 +119,10 @@ command-line.import.scm: $(COMMAND-LINE-SOURCES)
MBASE-SOURCES=mbase.scm testing.import.scm util-dict-list.import.scm \
primes.import.scm brmember.import.scm ansi.import.scm \
period.import.scm month.import.scm configuration.import.scm \
progress.import.scm table.import.scm mbase-dir.import.scm \
util-list.import.scm util-tag.import.scm
cal-period.import.scm cal-month.import.scm \
configuration.import.scm progress.import.scm \
table.import.scm mbase-dir.import.scm util-list.import.scm \
util-tag.import.scm
mbase.o: mbase.import.scm
mbase.import.scm: $(MBASE-SOURCES)
@ -147,17 +137,16 @@ PRIMES-SOURCES=primes.scm testing.import.scm util-list.import.scm
primes.o: primes.import.scm
primes.import.scm: $(PRIMES-SOURCES)
BRMEMBER-SOURCES=brmember.scm util-dict-list.import.scm \
period.import.scm testing.import.scm month.import.scm \
configuration.import.scm primes.import.scm \
bank-account.import.scm util-list.import.scm \
BRMEMBER-SOURCES=brmember.scm util-dict-list.import.scm \
cal-period.import.scm testing.import.scm cal-month.import.scm \
configuration.import.scm primes.import.scm \
bank-account.import.scm util-list.import.scm \
util-tag.import.scm
brmember.o: brmember.import.scm
brmember.import.scm: $(BRMEMBER-SOURCES)
CONFIGURATION-SOURCES=configuration.scm month.import.scm \
util-parser.import.scm
CONFIGURATION-SOURCES=configuration.scm util-parser.import.scm
configuration.o: configuration.import.scm
configuration.import.scm: $(CONFIGURATION-SOURCES)
@ -180,8 +169,8 @@ cards.o: cards.import.scm
cards.import.scm: $(CARDS-SOURCES)
BRMEMBER-PARSER-SOURCES=brmember-parser.scm brmember.import.scm \
testing.import.scm util-dict-list.import.scm month.import.scm \
period.import.scm configuration.import.scm \
testing.import.scm util-dict-list.import.scm cal-month.import.scm \
cal-period.import.scm configuration.import.scm \
util-string.import.scm util-list.import.scm \
util-parser.import.scm
@ -189,8 +178,8 @@ brmember-parser.o: brmember-parser.import.scm
brmember-parser.import.scm: $(BRMEMBER-PARSER-SOURCES)
MEMBERS-PRINT-SOURCES=members-print.scm util-dict-list.import.scm \
brmember.import.scm month.import.scm table.import.scm \
listing.import.scm ansi.import.scm period.import.scm \
brmember.import.scm cal-month.import.scm table.import.scm \
listing.import.scm ansi.import.scm cal-period.import.scm \
primes.import.scm mbase.import.scm configuration.import.scm \
bank-account.import.scm members-fees.import.scm \
members-payments.import.scm util-list.import.scm \
@ -200,7 +189,7 @@ members-print.o: members-print.import.scm
members-print.import.scm: $(MEMBERS-PRINT-SOURCES)
MEMBERS-FEES-SOURCES=members-fees.scm configuration.import.scm \
brmember.import.scm month.import.scm table.import.scm \
brmember.import.scm cal-month.import.scm table.import.scm \
mbase.import.scm specification.import.scm \
util-list.import.scm
@ -233,7 +222,7 @@ bank-fio.import.scm: $(BANK-FIO-SOURCES)
MEMBERS-PAYMENTS-SOURCES=members-payments.scm bank-account.import.scm \
util-dict-list.import.scm members-fees.import.scm \
period.import.scm configuration.import.scm \
cal-period.import.scm configuration.import.scm \
progress.import.scm bank-fio.import.scm util-list.import.scm \
specification.import.scm
@ -354,7 +343,7 @@ LOGGING-SOURCES=logging.scm util-string.import.scm
logging.o: logging.import.scm
logging.import.scm: $(LOGGING-SOURCES)
SPECIFICATION-SOURCES=specification.scm period.import.scm
SPECIFICATION-SOURCES=specification.scm cal-period.import.scm
specification.o: specification.import.scm
specification.import.scm: $(SPECIFICATION-SOURCES)

8
src/brmember-parser.scm
View file

@ -38,8 +38,8 @@
brmember
testing
util-dict-list
month
period
cal-month
cal-period
util-list
configuration
util-string
@ -81,7 +81,7 @@
(kind (cadr mk)))
(foldl (lambda (mr value)
(let* ((mspec (string-first+rest (car value)))
(month (string->month (car mspec)))
(month (string->cal-month (car mspec)))
(comment (cdr mspec)))
(if month
(brmember-sub-prepend
@ -95,7 +95,7 @@
,(lambda (mr output key value)
(case key
((student suspend member)
(let* ((res (period-markers->periods value))
(let* ((res (period-markers->cal-periods value))
(ok? (car res))
(periods (cadr res))
(msg (caddr res))

22
src/brmember.scm
View file

@ -84,8 +84,8 @@
(chicken format)
util-dict-list
testing
month
period
cal-month
cal-period
configuration
primes
util-list
@ -273,14 +273,14 @@
(let ((member (brmember-info mr 'member)))
(if (null? member)
#f
(month>=? (*current-month*)
(period-since (car member)))))))
(cal-month>=? (*current-month*)
(cal-period-since (car member)))))))
;; Generic period-based predicate
(define ((member-period-predicate? key) mr)
(let ((periods (brmember-info mr key #f)))
(and periods
(month-in-periods? periods))))
(cal-month-in-periods? periods))))
;; Returns true if the member is now suspended
(define member-is-suspended?
@ -302,12 +302,12 @@
;; Returns true if the member is active (not suspended or destroyed).
(define (brmember-active? mr)
(and (month-in-periods? (brmember-info mr 'member))
(and (cal-month-in-periods? (brmember-info mr 'member))
(not (brmember-suspended? mr))))
;; Returns true if the member is currently a member
(define (brmember-existing? mr)
(month-in-periods?
(cal-month-in-periods?
(brmember-info mr 'member)))
;; Returns a list of flags of given member record.
@ -331,9 +331,9 @@
;; suspended.
(define (brmember-suspended-months mr)
(if (brmember-suspended? mr)
(let ((period (periods-match (brmember-info mr 'suspend))))
(let ((period (cal-periods-match (brmember-info mr 'suspend))))
(if period
(month-diff (car period) (*current-month*))
(cal-month-diff (cal-period-since period) (*current-month*))
0))
0))
@ -352,8 +352,8 @@
(define (brmember-payments mr)
(filter (lambda (tr)
(let* ((isodate (bank-transaction-date tr))
(month (iso-date->month isodate)))
(month<=? month (*current-month*))))
(month (iso-date->cal-month isodate)))
(cal-month<=? month (*current-month*))))
(ldict-ref mr 'payments '())))
;; Returns a list of MLs this member is subscribed to

1
src/configuration.scm
View file

@ -46,7 +46,6 @@
(chicken time posix)
(chicken file)
(chicken io)
month
util-parser)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

10
src/mbase.scm
View file

@ -73,8 +73,8 @@
primes
brmember
ansi
period
month
cal-period
cal-month
configuration
progress
mbase-dir
@ -224,7 +224,7 @@
di7))
(define (members-base-oldest-month mb)
(make-month 2015 1))
(make-cal-month 2015 1))
;; Returns a list two lists: keys, data.
;; Each data record contains values for all keys.
@ -232,14 +232,14 @@
(let ((keys '(month total active suspended students destroyed invalid)))
(let mloop ((data '())
(month (members-base-oldest-month mb)))
(if (month<? month (*current-month*))
(if (cal-month<? month (*current-month*))
(let ((bi (parameterize ((*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)
(month-add month 1))
(cal-month-add month 1))
(kloop (cons (length (ldict-ref bi (car keys))) row)
(cdr keys)))))
(list keys (reverse data))))))

18
src/members-fees.scm
View file

@ -47,17 +47,17 @@
(chicken sort)
configuration
brmember
month
cal-month
ansi
table
mbase
period
cal-period
specification
util-list)
;; Returns a matching list of (list regular student)
(define (lookup-member-fees)
(lookup-by-period member-fees-lookup-table))
(lookup-by-cal-period member-fees-lookup-table))
;; Returns time-based fee for given type
(define (lookup-member-fee type)
@ -74,12 +74,12 @@
(let ((last-month (if (null? args)
(*current-month*)
(car args)))
(first-month (period-since (car (brmember-info mr 'member)))))
(first-month (cal-period-since (car (brmember-info mr 'member)))))
(let loop ((cm first-month)
(cal '()))
(if (month>? cm last-month)
(if (cal-month>? cm last-month)
(reverse cal)
(loop (month-add cm)
(loop (cal-month-add cm)
(cons (list cm
(parameterize ((*current-month* cm))
(brmember-flags mr)))
@ -134,8 +134,8 @@
'()
(let* ((fm (member-calendar-first-month mc))
(lm (member-calendar-last-month mc))
(fy (month-year fm))
(ly (month-year lm)))
(fy (cal-month-year fm))
(ly (cal-month-year lm)))
(let loop ((y fy)
(rows '()))
(if (> y ly)
@ -147,7 +147,7 @@
(reverse row)
(mloop (add1 m)
(cons (member-calendar-entry->string
(member-calendar-query mc (make-month y m)))
(member-calendar-query mc (make-cal-month y m)))
row))))
rows)))))))

4
src/members-payments.scm
View file

@ -52,7 +52,7 @@
bank-fio
util-dict-list
members-fees
period
cal-period
configuration
util-list
progress
@ -64,7 +64,7 @@
;; Lookup CZK/EUR
(define (lookup-eur-rate)
(car (lookup-by-period exchange-rates-lookup-table)))
(car (lookup-by-cal-period exchange-rates-lookup-table)))
;; Extract probable member-id from transaction
(define (transaction-extract-member-id transaction)

192
src/month.scm
View file

@ -1,192 +0,0 @@
;;
;; month.scm
;;
;; Month processing 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 month))
(module
month
(
make-month
month-year
month-month
month-valid?
string->month
month->string
month=?
month<?
month<=?
month>=?
month>?
month-diff
month-add
iso-date->month
month-tests!
)
(import scheme
(chicken base)
(chicken string)
(chicken format)
testing)
;; Simple wrapper for creating month representation as a list.
(define (make-month y m)
(list y m))
;; Accessors
(define month-year car)
(define month-month cadr)
;; Returns true if this is a valid month representation - a list with
;; two integer elements within the allowed range.
(define (month-valid? m)
(and (list? m)
(car m)
(cdr m)
(cadr m)
(null? (cddr m))
(integer? (car m))
(integer? (cadr m))
(>= (car m) 1000)
(<= (car m) 9999)
(>= (cadr m) 1)
(<= (cadr m) 12)))
;; Converts string in a format YYYY-MM to valid month. Returns #f if
;; the conversion fails.
(define (string->month s)
(let ((l (string-split s "-")))
(if (or (not l)
(null? l)
(null? (cdr l))
(not (null? (cddr l))))
#f
(let ((y (string->number (car l)))
(m (string->number (cadr l))))
(if (and y m)
(let ((M (list y m)))
(if (month-valid? M)
M
#f))
#f)))))
;; Formats (valid) month as YYYY-MM string
(define (month->string M)
(if M
(if (month-valid? M)
(let ((y (car M))
(m (cadr M)))
(sprintf "~A-~A~A"
y
(if (< m 10) "0" "")
m))
(error 'string->month "Invalid month" M))
"____-__"))
;; Returns true if both arguments are a valid month and are equal
(define (month=? m n)
(and (month-valid? m)
(month-valid? n)
(equal? m n)))
;; Returns true if the first argument is a month in the past of the
;; second argument month
(define (month<? m n)
(and (month-valid? m)
(month-valid? n)
(or (< (car m) (car n))
(and (= (car m) (car n))
(< (cadr m) (cadr n))))))
;; Returns true if m is less than or equal n
(define (month<=? m n)
(or (month<? m n)
(month=? m n)))
;; Returns true if m is greater than or equal to n
(define (month>=? m n)
(not (month<? m n)))
;; Returns true if m is greater than n
(define (month>? m n)
(not (month<=? m n)))
;; Returns the number of months between from f and to t. The first
;; month is included in the count, the last month is not.
(define (month-diff f t)
(if (month-valid? f)
(if (month-valid? t)
(let ((F (+ (* (car f) 12) (cadr f) -1))
(T (+ (* (car t) 12) (cadr t) -1)))
(- T F))
(error 'month-diff "Second argument is not a valid month" t))
(error 'month-diff "First argument is not a valid month" f)))
;; Returns a month n months after the month m. The number n defaults
;; to 1.
(define (month-add m . ns)
(let* ((n (if (null? ns)
1
(car ns)))
(mi (+ (* 12 (car m)) (cadr m) n -1)))
(list (quotient mi 12)
(+ (remainder mi 12) 1))))
;; Converts ISO date to single month
(define (iso-date->month str)
(let* ((lst (string-split str "-"))
(year (car lst))
(mon (cadr lst)))
(make-month (string->number year)
(string->number mon))))
;; Performs self-tests of the month module.
(define (month-tests!)
(run-tests
month
(test-true month-valid? (month-valid? '(2023 5)))
(test-false month-valid? (month-valid? '(999 8)))
(test-false month-valid? (month-valid? '(2023 -5)))
(test-equal? string->month (string->month "2023-01") '(2023 1))
(test-false string->month (string->month "2023-13"))
(test-false string->month (string->month "YYYY-01"))
(test-false string->month (string->month "2023-MMM"))
(test-equal? month->string (month->string '(2023 1)) "2023-01")
(test-exn month->string (month->string '(999 12)))
(test-exn month->string (month->string '(2023 13)))
(test-true month<? (month<? '(2023 5) '(2023 6)))
(test-true month<? (month<? '(2022 12) '(2023 1)))
(test-false month<? (month<? '(2023 1) '(2023 1)))
(test-false month<? (month<? '(2023 1) '(2023 1)))
(test-true month=? (month=? '(2023 4) '(2023 4)))
(test-false month=? (month=? '(2023 4) '(2023 5)))
(test-eq? month-diff (month-diff '(2023 1) '(2023 2)) 1)
(test-eq? month-diff (month-diff '(2023 1) '(2023 12)) 11)
(test-eq? month-diff (month-diff '(2023 1) '(2022 2)) -11)
(test-eq? month-add (month-add '(2023 1) 2) '(2023 3))
(test-equal? iso-date->month (iso-date->month "2023-04-03") '(2023 4))
))
)

284
src/period.scm
View file

@ -1,284 +0,0 @@
;;
;; period.scm
;;
;; Month periods.
;;
;; 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 period))
(module
period
(
*current-month*
make-period
period-since
period-before
period-scomment
period-bcomment
period-markers->periods
periods-duration
month-in-period?
month-in-periods?
periods->string
periods-match
make-period-lookup-table
lookup-by-period
period-tests!
)
(import scheme
(chicken base)
(chicken sort)
(chicken time)
(chicken time posix)
(chicken format)
(chicken string)
month
testing
configuration)
;; Current month - if changed, we get the actual state for given month.
(define *current-month*
(make-parameter
(let ((d (seconds->local-time (current-seconds))))
(list (+ 1900 (vector-ref d 5))
(+ (vector-ref d 4) 1)))))
;; Creates a new period value with optional since and before
;; comments.
(define (make-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 since before scomment bcomment)))
;; Simple accessors
(define period-since car)
(define period-before cadr)
(define period-scomment caddr)
(define period-bcomment cadddr)
;; Sorts period markers (be it start or end) chronologically and
;; returns the sorted list.
(define (sort-period-markers l)
(sort l
(lambda (a b)
(month<? (cadr a) (cadr b)))))
;; Converts list of start/stop markers to list of pairs of months -
;; periods.
(define (period-markers->periods l)
(let loop ((l (sort-period-markers l))
(ps '())
(cb #f))
(if (null? l)
(list #t
(if cb
(reverse (cons (make-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-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 (period->duration p)
(let* ((b (period-since p))
(e (period-before p))
(e- (if e e (*current-month*))))
(month-diff b e-)))
;; Returns sum of periods lengths.
(define (periods-duration l)
(apply + (map period->duration l)))
;; True if month belongs to given month period - start inclusive, end
;; exclusive.
(define (month-in-period? p . ml)
(let ((m (if (null? ml)
(*current-month*)
(car ml))))
(and (or (not (period-before p))
(month<? m (period-before p)))
(not (month<? m (period-since p))))))
;; Returns true if given month is in at least one of the periods
;; given. Defaults to current month.
(define (month-in-periods? ps . ml)
(let ((m (if (null? ml)
(*current-month*)
(car ml))))
(let loop ((ps ps))
(if (null? ps)
#f
(if (month-in-period? (car ps) m)
#t
(loop (cdr ps)))))))
;; Returns string representing a month period with possibly open end.
(define (period->string p)
(sprintf "~A..~A"
(month->string (period-since p))
(month->string (period-before p))))
;; Returns a string representing a list of periods.
(define (periods->string ps)
(string-intersperse
(map period->string ps)
", "))
;; Finds a period the month matches and returns it. If no period
;; matches, it returns #f.
(define (periods-match ps . ml)
(let ((m (if (null? ml) (*current-month*) (car ml))))
(let loop ((ps ps))
(if (null? ps)
#f
(if (month-in-period? (car ps) m)
(car ps)
(loop (cdr ps)))))))
;; Creates lookup table from definition source
(define (make-period-lookup-table source)
(let loop ((lst source)
(res '())
(prev #f))
(if (null? lst)
(reverse
(cons (cons (make-period (car prev) #f)
(cdr prev))
res))
(loop (cdr lst)
(if prev
(cons (cons (make-period (car prev) (caar lst))
(cdr prev))
res)
res)
(car lst)))))
;; Looks up current month and returns associated definitions
(define (lookup-by-period table)
(let loop ((lst table))
(if (null? lst)
#f
(if (month-in-period? (caar lst))
(cdar lst)
(loop (cdr lst))))))
;; Performs self-tests of the period module.
(define (period-tests!)
(run-tests
period
(test-equal? sort-period-markers
(sort-period-markers '((start (2023 1)) (stop (2022 10)) (start (2022 3))))
'((start (2022 3)) (stop (2022 10)) (start (2023 1))))
(test-equal? period-markers->periods
(period-markers->periods
'((start (2022 3)) (stop (2022 10)) (start (2023 1)) (stop (2023 4))))
'(#t
(((2022 3) (2022 10) #f #f)
((2023 1) (2023 4) #f #f))
""
-1))
(test-equal? period-markers->periods-open
(period-markers->periods
'((start (2022 3)) (stop (2022 10)) (start (2023 1)) (stop (2023 4)) (start (2023 5))))
'(#t
(((2022 3) (2022 10) #f #f)
((2023 1) (2023 4) #f #f)
((2023 5) #f #f #f))
""
-1))
(test-eq? period-duration
(period->duration '((2023 1) (2023 4) #f #f)) 3)
(parameterize ((*current-month* (list 2023 4)))
(test-eq? period-duration
(period->duration '((2023 1) #f #f #f)) 3))
(test-eq? periods-duration
(periods-duration '(((2022 3) (2022 10) #f #f)
((2023 1) (2023 4) #f #f)))
10)
(test-true month-in-period?
(month-in-period? '((2022 1) (2022 4) #f #f) '(2022 3)))
(test-false month-in-period?
(month-in-period? '((2022 1) (2022 4) #f #f) '(2022 5)))
(test-true month-in-periods?
(month-in-periods? '(((2022 1) (2022 4) #f #f)
((2023 5) (2023 10) #f #f))
'(2022 3)))
(test-true month-in-periods?
(month-in-periods? '(((2022 1) (2022 4) #f #f)
((2023 5) (2023 10) #f #f))
'(2023 7)))
(test-false month-in-periods?
(month-in-periods? '(((2022 1) (2022 4) #f #f)
((2023 5) (2023 10) #f #f))
'(2022 10)))
(test-equal? period->string
(period->string '((2022 1) (2022 4) #f #f))
"2022-01..2022-04")
(test-equal? periods->string
(periods->string '(((2022 1) (2022 4) #f #f)
((2022 12) (2023 2) #f #f)))
"2022-01..2022-04, 2022-12..2023-02")
(test-false periods-match (periods-match '(((2022 1) (2022 4) #f #f)
((2022 12) (2023 2) #f #f))
'(2022 5)))
(test-equal? periods-match (periods-match '(((2022 1) (2022 4) #f #f)
((2022 12) (2023 2) #f #f))
'(2022 2))
'((2022 1) (2022 4) #f #f))
))
)

6
src/specification.scm
View file

@ -34,16 +34,16 @@
)
(import scheme
period)
cal-period)
;; Convert into lookups - a list of (list period regular student)
(define member-fees-lookup-table
(make-period-lookup-table
(make-cal-period-lookup-table
'(((2010 1) 500 250))))
;; Exchange rates
(define exchange-rates-lookup-table
(make-period-lookup-table
(make-cal-period-lookup-table
'(((2010 1) 25))))
;; How long the member can be suspended without any action required?