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

Move sources to separate directory.

Browse source
This commit is contained in:
Dominik Pantůček 2023-04-01 09:45:46 +02:00
parent aa7a340d51
commit 69d0b8ee10
25 changed files with 0 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

222
src/Makefile Normal file
View file

@ -0,0 +1,222 @@
#
# Makefile
#
# Building the binary from sources.
#
# 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.
#
.PHONY: default
default: imports
.PHONY: static
static: bbstool
.PHONY: all
all: imports static
CSC=csc
BBSTOOL-DEPS=bbstool.scm testing.import.scm listing.import.scm \
dictionary.import.scm month.import.scm period.import.scm \
ansi.import.scm command-line.import.scm \
members-base.import.scm utils.import.scm primes.import.scm \
member-record.import.scm configuration.import.scm \
progress.import.scm table.import.scm cards.import.scm \
member-parser.import.scm members-print.import.scm \
member-fees.import.scm members-dir.import.scm \
csv-simple.import.scm bank-account.import.scm \
bank-fio.import.scm members-payments.import.scm
BBSTOOL-SOURCES=bbstool.scm testing.scm listing.scm dictionary.scm \
month.scm period.scm ansi.scm command-line.scm \
members-base.scm utils.scm primes.scm member-record.scm \
configuration.scm progress.scm table.scm cards.scm \
members-print.scm member-parser.scm member-fees.scm \
members-dir.scm csv-simple.scm bank-account.scm bank-fio.scm \
members-payments.scm
BBSTOOL-OBJS=bbstool.o testing.o listing.o month.o period.o ansi.o \
dictionary.o command-line.o members-base.o utils.o primes.o \
member-record.o configuration.o progress.o table.o cards.o \
members-print.o member-fees.o members-dir.o csv-simple.o \
bank-account.o bank-fio.o members-payments.o member-parser.o
.PHONY: imports
imports: $(BBSTOOL-DEPS)
bbstool: $(BBSTOOL-OBJS)
$(CSC) -static -o $@ $(BBSTOOL-OBJS)
.PHONY: clean
clean:
rm -f *.c *.link *.o *.import.scm bbstool
################################################################
# Module static and shared object and import source compilation
%.o: %.scm
$(CSC) -c -static $<
%.import.scm: %.scm
rm -f $@
$(CSC) -P -J $<
################################################################
# Modules
TESTING-SOURCES=testing.scm
testing.o: testing.import.scm
testing.import.scm: $(TESTING-SOURCES)
LISTING-SOURCES=listing.scm testing.import.scm ansi.import.scm
listing.o: listing.import.scm
listing.import.scm: $(LISTING-SOURCES)
DICTIONARY-SOURCES=dictionary.scm testing.import.scm
dictionary.o: dictionary.import.scm
dictionary.import.scm: $(DICTIONARY-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 utils.import.scm
ansi.o: ansi.import.scm
ansi.import.scm: $(ANSI-SOURCES)
COMMAND-LINE-SOURCES=command-line.scm testing.import.scm
command-line.o: command-line.import.scm
command-line.import.scm: $(COMMAND-LINE-SOURCES)
MEMBERS-BASE-SOURCES=members-base.scm testing.import.scm \
utils.import.scm dictionary.import.scm primes.import.scm \
member-record.import.scm ansi.import.scm period.import.scm \
month.import.scm configuration.import.scm progress.import.scm \
table.import.scm members-dir.import.scm
members-base.o: members-base.import.scm
members-base.import.scm: $(MEMBERS-BASE-SOURCES)
UTILS-SOURCES=utils.scm testing.import.scm
utils.o: utils.import.scm
utils.import.scm: $(UTILS-SOURCES)
PRIMES-SOURCES=primes.scm testing.import.scm utils.import.scm
primes.o: primes.import.scm
primes.import.scm: $(PRIMES-SOURCES)
MEMBER-RECORD-SOURCES=member-record.scm dictionary.import.scm \
period.import.scm testing.import.scm month.import.scm \
configuration.import.scm primes.import.scm utils.import.scm
member-record.o: member-record.import.scm
member-record.import.scm: $(MEMBER-RECORD-SOURCES)
CONFIGURATION-SOURCES=configuration.scm month.import.scm
configuration.o: configuration.import.scm
configuration.import.scm: $(CONFIGURATION-SOURCES)
PROGRESS-SOURCES=progress.scm
progress.o: progress.import.scm
progress.import.scm: $(PROGRESS-SOURCES)
TABLE-SOURCES=table.scm ansi.import.scm testing.import.scm \
utils.import.scm
table.o: table.import.scm
table.import.scm: $(TABLE-SOURCES)
CARDS-SOURCES=cards.scm dictionary.import.scm members-base.import.scm \
member-record.import.scm
cards.o: cards.import.scm
cards.import.scm: $(CARDS-SOURCES)
MEMBER-PARSER-SOURCES=member-parser.scm member-record.import.scm \
testing.import.scm dictionary.import.scm month.import.scm \
period.import.scm utils.import.scm configuration.import.scm
member-parser.o: member-parser.import.scm
member-parser.import.scm: $(MEMBER-PARSER-SOURCES)
MEMBERS-PRINT-SOURCES=members-print.scm dictionary.import.scm \
member-record.import.scm month.import.scm utils.import.scm \
table.import.scm listing.import.scm ansi.import.scm \
period.import.scm primes.import.scm members-base.import.scm \
configuration.import.scm bank-account.import.scm \
member-fees.import.scm
members-print.o: members-print.import.scm
members-print.import.scm: $(MEMBERS-PRINT-SOURCES)
MEMBER-FEES-SOURCES=member-fees.scm configuration.import.scm \
member-record.import.scm month.import.scm table.import.scm \
members-base.import.scm
member-fees.o: member-fees.import.scm
member-fees.import.scm: $(MEMBER-FEES-SOURCES)
MEMBERS-DIR-SOURCES=members-dir.scm testing.import.scm \
dictionary.import.scm utils.import.scm \
member-record.import.scm member-parser.import.scm
members-dir.o: members-dir.import.scm
members-dir.import.scm: $(MEMBERS-DIR-SOURCES)
CSV-SIMPLE-SOURCES=csv-simple.scm testing.import.scm \
progress.import.scm
csv-simple.o: csv-simple.import.scm
csv-simple.import.scm: $(CSV-SIMPLE-SOURCES)
BANK-ACCOUNT-SOURCES=bank-account.scm
bank-account.o: bank-account.import.scm
bank-account.import.scm: $(BANK-ACCOUNT-SOURCES)
BANK-FIO-SOURCES=bank-fio.scm bank-account.import.scm \
csv-simple.import.scm progress.import.scm
bank-fio.o: bank-fio.import.scm
bank-fio.import.scm: $(BANK-FIO-SOURCES)
MEMBERS-PAYMENTS-SOURCES=members-payments.scm bank-account.import.scm \
dictionary.import.scm member-fees.import.scm \
period.import.scm
members-payments.o: members-payments.import.scm
members-payments.import.scm: $(MEMBERS-PAYMENTS-SOURCES)

241
src/ansi.scm Normal file
View file

@ -0,0 +1,241 @@
;;
;; ansi.scm
;;
;; ANSI terminal 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 ansi))
(module
ansi
(
ansi
a:error
a:warning
a:success
a:neutral
a:default
a:muted
a:highlight
ansi-string-length
ansi-paragraph-format
ansi-string
ansi-tests!
)
(import scheme
(chicken base)
(chicken string)
(chicken irregex)
(chicken keyword)
testing
utils)
;; Only basic ANSI colors and bold attribute support.
(define colors
'((#:black . 30)
(#:red . 31)
(#:green . 32)
(#:yellow . 33)
(#:blue . 34)
(#:magenta . 35)
(#:cyan . 36)
(#:white . 37)
(#:grey . 37)
(#:brightblack . 90)
(#:darkgrey . 90)
(#:brightred . 91)
(#:brightgreen . 92)
(#:brightyellow . 93)
(#:brightblue . 94)
(#:brightmagenta . 95)
(#:pink . 95)
(#:brightcyan . 96)
(#:brightwhite . 97)
(#:bgblack . 40)
(#:bgred . 41)
(#:bggreen . 42)
(#:bgyellow . 43)
(#:bgblue . 44)
(#:bgmagenta . 45)
(#:bgcyan . 46)
(#:bgwhite . 47)
(#:bggrey . 47)
(#:bgbrightblack . 100)
(#:bgdarkgrey . 100)
(#:bgbrightred . 101)
(#:bgbrightgreen . 102)
(#:bgbrightyellow . 103)
(#:bgbrightblue . 104)
(#:bgbrightmagenta . 105)
(#:bgpink . 105)
(#:bgbrightcyan . 106)
(#:bgbrightwhite . 107)
(#:default . 0)
(#:bold . 1)))
;; Returns ANSI sequence changing color and/or bold attribute.
(define (ansi . args)
(let ((argsl
(map
(lambda (key-color)
(number->string (cdr key-color)))
(filter
identity
(map (lambda (arg) (assq arg colors)) args)))))
(if (null? argsl)
""
(string-append "\x1b["
(string-intersperse argsl ";")
"m"))))
;; Nice styles to be used everywhere for consistency
(define a:error (ansi #:red #:bold))
(define a:warning (ansi #:default #:yellow))
(define a:success (ansi #:green #:bold))
(define a:neutral (ansi #:default #:white))
(define a:default (ansi #:default))
(define a:muted (ansi #:black #:bold))
(define a:highlight (ansi #:blue #:bold))
;; Returns visual string length in characters skipping any ANSI CSI
;; SGR sequences.
;;
;; Internal states:
;; 0 - regular string
;; 1 - seen escape
;; 2 - CSI started
(define (ansi-string-length str)
(let loop ((lst (irregex-extract (irregex "." 'u)
(irregex-replace (irregex "\t$" 'u)
(irregex-replace (irregex "^\t" 'u)
str))))
(state 0)
(len 0))
(if (null? lst)
len
(let ((ch (car lst)))
(case state
((0) (if (equal? ch "\x1b")
(loop (cdr lst) 1 len)
(loop (cdr lst) 0 (add1 len))))
((1) (if (equal? ch "[")
(loop (cdr lst) 2 len)
(loop (cdr lst) 0 len)))
((2) (if (equal? ch "m")
(loop (cdr lst) 0 len)
(loop (cdr lst) 2 len))))))))
;; Removes all ANSI CSI SGR sequences from the string.
(define (ansi-remove str)
(irregex-replace/all (irregex "\x1b\\[[0-9;]*[^0-9;]" 'u) str ""))
;; Formats string as paragraph of maximum given width while removing
;; all ANSI CSI SGR from it. If the first character is \t, align
;; right, if both first and last characters are \t, align center. The
;; alignment is not done here, but the \t are added to all lines
;; accordingly.
(define (ansi-paragraph-format str width)
(let* ((strl (string->list str))
(first-char (if (null? strl) #f (car strl)))
(last-char (if (null? strl) #f (car (reverse strl))))
(first-tab (eq? first-char #\tab))
(last-tab (eq? last-char #\tab)))
(let loop ((words (string-split
(ansi-remove str)))
(res '("")))
(if (null? words)
(string-intersperse
(reverse
(map
(lambda (line)
(string-append (if first-tab "\t" "")
line
(if last-tab "\t" "")))
res))
"\n")
(let* ((word (car words))
(wlen (ansi-string-length word))
(llen (ansi-string-length (car res))))
(loop (cdr words)
(if (> (+ llen wlen 1) width)
(cons word res)
(cons (string-append (car res)
(if (eq? (string-length (car res)) 0)
""
" ")
word)
(cdr res)))))))))
;; Returns a concatenation of all ANSI styles specified by this
;; module
(define (ansi-string . args)
(apply string-append
(let loop ((args args)
(kws '())
(res '()))
(if (null? args)
(let ((rres (if (null? kws)
res
(cons (apply ansi kws) res))))
(reverse rres))
(let ((arg (car args)))
(loop (cdr args)
(if (keyword? arg)
(cons arg kws)
'())
(if (keyword? arg)
res
(if (null? kws)
(cons arg res)
(cons arg (cons (apply ansi (reverse kws)) res))))))))))
;; Performs ANSI module self-tests.
(define (ansi-tests!)
(run-tests
ansi
(test-equal? ansi (ansi #:red) "\x1b[31m")
(test-equal? ansi (ansi #:nonsense) "")
(test-equal? ansi (ansi #:default) "\x1b[0m")
(test-eq? ansi-string-length (ansi-string-length "test") 4)
(test-eq? ansi-string-length (ansi-string-length "\x1b[1mtest") 4)
(test-eq? ansi-string-length (ansi-string-length "\x1b[30mtest\x1b[0m") 4)
(test-eq? ansi-string-length (ansi-string-length "\x1b[30mščřž\x1b[0m") 4)
(test-equal? ansi-remove (ansi-remove "\x1b[1mtest") "test")
(test-equal? ansi-remove (ansi-remove "\x1b[30mščřž\x1b[0m") "ščřž")
(test-equal? ansi-paragraph-format
(ansi-paragraph-format "Formats string as paragraph of maximum given width" 80)
"Formats string as paragraph of maximum given width")
(test-equal? ansi-paragraph-format
(ansi-paragraph-format "Formats string as paragraph of maximum given width" 20)
"Formats string as\nparagraph of maximum\ngiven width")
(test-equal? ansi-string
(ansi-string "Hello" #:bold "World")
"Hello\x1b[1mWorld")
(test-equal? ansi-string
(ansi-string "Hello" #:bold #:red "World")
"Hello\x1b[1;31mWorld")
))
)

74
src/bank-account.scm Normal file
View file

@ -0,0 +1,74 @@
;;
;; bank-account.scm
;;
;; Generic bank account records.
;;
;; 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 bank-account))
(module
bank-account
(
make-bank-account
bank-account-transactions
bank-account-number
bank-account-bank
bank-account-insert
make-bank-transaction
bank-transaction-varsym
bank-transaction-amount
bank-transaction-currency
bank-transaction-date
bank-transaction-id
bank-transaction-message
bank-transaction-type
)
(import scheme
(chicken base))
;; Bank account is represented as a list with list with the following
;; elements: list of transactions, account number, bank code. This
;; allows cheap transaction prepending.
(define (make-bank-account number bank . maybe-transactions)
(let ((transactions (if (null? maybe-transactions)
'()
(car maybe-transactions))))
(list transactions number bank)))
;; Trivial accessors
(define bank-account-transactions car)
(define bank-account-number cadr)
(define bank-account-bank caddr)
;; Prepends given transaction to given bank account. It expects the
;; transactions list to be the first element of the bank account
;; list.
(define (bank-account-insert account transaction)
(cons (cons transaction (car account))
(cdr account)))
;; Creates a new bank transaction.
(define-record bank-transaction id date amount currency varsym message type)
)

77
src/bank-fio.scm Normal file
View file

@ -0,0 +1,77 @@
;;
;; bank-fio.scm
;;
;; Fio CSV statements loader to common bank format.
;;
;; 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 bank-fio))
(module
bank-fio
(
bank-fio-parse
)
(import scheme
(chicken base)
(chicken string)
bank-account
csv-simple
progress)
;; Conversion of Fio date to ISO
(define (fio-date->iso str)
(string-intersperse
(reverse
(string-split str "."))
"-"))
;; Converts Fio account statement transaction row into standardized
;; bank transaction structure.
(define (make-fio-transaction row)
(let ((id (string->number (car row)))
(date (fio-date->iso (cadr row)))
(amount (string->number
(string-translate* (caddr row)
'(("," . ".")))))
(currency (string->symbol (cadddr row)))
(varsym (list-ref row 9))
(message (list-ref row 12))
(type (list-ref row 13)))
(make-bank-transaction id date amount currency varsym message type)))
;; Loads Fio bank accound statement.
(define (bank-fio-parse fn)
(with-progress%
#t fn
(let* ((csv (csv-parse fn))
(head+body (csv-split-header csv))
(head (car head+body))
(body (cadr head+body))
(numrow (assoc "accountId" head))
(num (if numrow (cadr numrow) "ERROR"))
(bankrow (assoc "bankId" head))
(bank (if bankrow (cadr bankrow) "ERROR")))
(make-bank-account num bank
(map make-fio-transaction body)))))
)

199
src/bbstool.scm Normal file
View file

@ -0,0 +1,199 @@
;;
;; bbstool.scm
;;
;; Brmburo system - members management tool.
;;
;; The license of this file and of the whole suite.
(define license-text "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.
")
(import testing
listing
dictionary
month
period
command-line
utils
ansi
members-base
primes
member-record
configuration
table
cards
members-print
member-parser
member-fees
members-dir
csv-simple
members-payments)
;; Print banner
(print "bbstool 0.7 (c) 2023 Brmlab, z.s.")
(newline)
;; Command-line options and configurable parameters
(define *members-directory* (make-parameter "members"))
(define *apikeys-file* (make-parameter "apikey.ntlm"))
(define -member-id- (make-parameter #f))
(define -member-nick- (make-parameter #f))
(define -action- (make-parameter #f))
(define -fname- (make-parameter #f))
(define -run-tests?- (make-parameter #f))
;; Arguments parsing
(command-line
print-help
(-h () "This help"
(print "Command-line options:")
(newline)
(print-help)
(newline)
(exit 0))
(-license () "Show licensing terms"
(print license-text)
(exit 0))
(-members (dir) "Members base directory" (*members-directory* dir))
(-context (n) "Member-File parser Error Context (lines)" (*member-file-context* (string->number n)))
(-mi (id) "Specify member by id" (-member-id- (string->number id)))
(-mn (nick) "Specify member by nick" (-member-nick- nick))
(-info () "Print information" (-action- 'print-info))
(-stats (file:gnuplot-data) "Get stats for all months"
(-action- 'print-stats)
(-fname- file:gnuplot-data))
(-month (YYYY-MM) "Specify current month"
(*current-month* (string->month YYYY-MM)))
(-print () "Print given member file"
(-action- 'print-member-file))
(-tests () "Run self-tests upon startup" (-run-tests?- #t))
(-idstats () "Returns information about available member ids" (-action- 'print-idstats))
(-genid () "Generates random member id" (-action- 'genid))
(-tstyle (style) "Use given table style: debug, ascii, unicode"
(*table-border-style* (string->symbol style)))
(-gencards (file:cards file:desfires) "Generates brmdoor-compatible card files"
(-action- 'gencards)
(-fname- (list file:cards file:desfires)))
(-problems () "Prints all files with problems" (-action- 'problems))
(-fees () "Prints fees table" (-action- 'fees))
)
;; Run tests
(when (-run-tests?-)
(listing-tests!)
(dictionary-tests!)
(month-tests!)
(period-tests!)
(utils-tests!)
(ansi-tests!)
(command-line-tests!)
(members-dir-tests!)
(primes-tests!)
(member-record-tests!)
(member-parser-tests!)
(table-tests!)
(csv-simple-tests!)
(newline))
;; Load the members database (required for everything anyway)
(define MB (members-payments-process
(load-members (*members-directory*) #t)
(*apikeys-file*)))
;; If a member is specified by either id or nick, get its record
(define mr
(if (-member-id-)
(let ((mr (find-member-by-id MB (-member-id-))))
(when (not mr)
(print "Member id " (-member-id-) " not found!"))
mr)
(if (-member-nick-)
(let ((mr (find-member-by-nick MB (-member-nick-))))
(when (not mr)
(print "Member nick " (-member-nick-) " not found!"))
mr)
#f)))
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Perform requested action
(case (-action-)
((print-info)
(newline)
(print "Current month: " (month->string (*current-month*)))
(newline)
(if mr
(let ()
(print-member-table mr)
(let* ((fees (member-fees-total mr))
(credit (member-credit-total mr))
(payments (member-payments-total mr))
(balance (- (+ credit payments) fees)))
(print "Total fees: " fees)
(print "Total credit: " credit)
(print "Total payments: " payments)
(print "Balance: " balance)
))
(print-members-base-table MB))
(newline))
((print-stats)
(newline)
(parameterize ((current-output-port (open-output-file (-fname-))))
(print-members-base-stats
(members-base-stats MB))))
((print-member-file)
(cond (mr
(newline)
(print-member-source mr))
(else
(print "No member specified!"))))
((print-idstats)
(newline)
(print-members-ids-stats MB)
(newline))
((genid)
(newline)
(print "New member id: " (gen-member-id MB))
(newline))
((gencards)
(apply cards-export MB (-fname-)))
((problems)
(let ((num (let loop ((mb MB)
(num 0))
(if (null? mb)
num
(loop (cdr mb)
(if (or (member-has-problems? (car mb))
(member-has-highlights? (car mb)))
(let ()
(newline)
(print-member-table (car mb))
(print-member-source (car mb))
(add1 num))
num))))))
(when (= num 0)
(newline)
(print "No problems found."))))
((fees)
(newline)
(print-members-fees-table MB))
)

90
src/cards.scm Normal file
View file

@ -0,0 +1,90 @@
;;
;; cards.scm
;;
;; Cards exporter as required by brmdoor.
;;
;; 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 cards))
(module
cards
(
cards-export
)
(import scheme
(chicken base)
(chicken sort)
(chicken format)
(chicken irregex)
dictionary
members-base
member-record)
;; Prints single card type records.
(define (cards-print/type mb type)
(let* ((rmb (filter-members-by-predicate
mb
(lambda (mr)
(and (member-active? mr)
(dict-has-key? (dict-ref mr 'info) type)
(not (null? (dict-ref (dict-ref mr 'info) type)))))))
(recs (map (lambda (mr)
(let ((mi (dict-ref mr 'info)))
(cons (dict-ref mi 'nick)
(dict-ref mi type))))
rmb))
(srecs (sort recs
(lambda (a b)
(string<? (car a)
(car b))))))
(let uloop ((srecs srecs))
(when (not (null? srecs))
(let* ((srec (car srecs))
(nick (car srec)))
(let cloop ((cards (cdr srec)))
(when (not (null? cards))
(let* ((card (car cards))
(cardid (car card))
(calias (cdr card))
(aliased? (> (string-length calias) 0))
(cardname (sprintf "~A~A~A"
nick
(if aliased? "." "")
(if aliased?
(irregex-replace/all (irregex " " 'u) calias "_")
""))))
(print cardname " " cardid)
(cloop (cdr cards)))))
(uloop (cdr srecs)))))))
;; Exports single card type records for all members to given file.
(define (cards-export/type mb type fname)
(parameterize ((current-output-port (open-output-file fname)))
(cards-print/type mb type)))
;; Exports cards and desfires to the files specified.
(define (cards-export mb cardsfn desfirefn)
(cards-export/type mb 'card cardsfn)
(cards-export/type mb 'desfire desfirefn))
)

152
src/command-line.scm Normal file
View file

@ -0,0 +1,152 @@
;;
;; command-line.scm
;;
;; Argument parsing on command-line with interpreter -- 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 command-line))
(module
command-line
(
command-line
command-line:parse-command-line
command-line:print-options
command-line-tests!
)
(import scheme
(chicken base)
(chicken process-context)
(chicken format)
testing)
;; Consumes given number of arguments from the list and returns the
;; remainder of the list and a list of arguments consumed.
(define (consume-args args num)
(let loop ((args args)
(res '())
(num num))
(if (= num 0)
(list args (reverse res))
(if (null? args)
(error 'consume-args "Not enough arguments" num)
(loop (cdr args)
(cons (car args) res)
(- num 1))))))
;; Gets command-line arguments after the "--" of csi (not useful when
;; compiled)
(define (get-command-line-arguments . explicit-argv)
(let* ((args (if (null? explicit-argv) (argv) explicit-argv))
(rargs (member "--" args)))
(if rargs
(cdr rargs)
(cdr args))))
;; Performs the actual parsing based on specification.
(define (command-line:parse-command-line specs)
(let loop ((args (get-command-line-arguments)))
(when (not (null? args))
(let* ((arg (car args))
(specp (assoc arg specs)))
(when (not specp)
(error 'parse-command-line "Unknown argument" arg))
(let* ((proc (caddr specp))
(info (procedure-information proc))
(nargs (- (length info) 1))
(aargsl (consume-args (cdr args) nargs))
(args (car aargsl))
(aargs (cadr aargsl)))
(apply proc aargs)
(loop args))))))
;; String representation of procedure arguments.
(define (procedure->argstring proc)
(let* ((info (procedure-information proc))
(args (cdr info))
(argss (sprintf "~A" args)))
(substring
(substring argss 0 (- (string-length argss) 1))
1)))
;; Prints options descriptions.
(define (command-line:print-options specs)
(let* ((descrs (map (lambda (spec)
(list (car spec)
(procedure->argstring (caddr spec))
(cadr spec)))
specs))
(owidth (apply max (map (lambda (desc)
(string-length (car desc)))
descrs)))
(awidth (apply max (map (lambda (desc)
(string-length (cadr desc)))
descrs))))
(let loop ((descrs descrs))
(when (not (null? descrs))
(let* ((desc (car descrs))
(opt (car desc))
(args (cadr desc))
(help (caddr desc)))
(print " "
opt
(make-string (- owidth (string-length opt)) #\space)
" "
args
(make-string (- awidth (string-length args)) #\space)
" "
help)
(loop (cdr descrs)))))))
;; Syntax for expanding various types of options.
(define-syntax make-option
(syntax-rules ()
((_ opt (args ...) help body ...)
(list (symbol->string 'opt)
help
(lambda (args ...) body ...)))))
;; Simple syntax wrapper for command-line arguments specification and
;; immediate parsing.
(define-syntax command-line
(syntax-rules ()
((_ print-help (exps ...) ...)
(letrec ((specs (list (make-option exps ...) ...))
(print-help (lambda ()
(command-line:print-options specs))))
(command-line:parse-command-line specs)))))
;; Performs self-tests of the command-line module
(define (command-line-tests!)
(run-tests
command-line
(test-exn consume-args (consume-args '(1 2 3) 4))
(test-equal? consume-args (consume-args '(1 2 3 4) 2) '((3 4) (1 2)))
(test-equal? get-command-line-arguments (get-command-line-arguments 1 2 3) '(2 3))
(test-equal? get-command-line-arguments (get-command-line-arguments 1 "--" 2 3) '(2 3))
(test-equal? procedure->argstring (procedure->argstring (lambda (x . y) 1)) "x . y")
(test-equal? procedure->argstring (procedure->argstring (lambda (x) 1)) "x")
(test-equal? procedure->argstring (procedure->argstring (lambda () 1)) "")
))
)

55
src/configuration.scm Normal file
View file

@ -0,0 +1,55 @@
;;
;; configuraiton.scm
;;
;; Configuration parameters used by various modules.
;;
;; 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 configuration))
(module
configuration
(
*current-month*
*member-file-context*
*member-suspend-max-months*
)
(import scheme
(chicken base)
(chicken time)
(chicken time posix)
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))))
(list (+ 1900 (vector-ref d 5))
(+ (vector-ref d 4) 1)))))
;; Configuration of error reporting
(define *member-file-context* (make-parameter 3))
;; How long the member can be suspended without any action required?
(define *member-suspend-max-months* (make-parameter 24))
)

144
src/csv-simple.scm Normal file
View file

@ -0,0 +1,144 @@
;;
;; csv-simple.scm
;;
;; Simple, incomplete and incorrect but fast CSV loader.
;;
;; 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 csv-simple))
(module
csv-simple
(
csv-parse
csv-split-header
csv-simple-tests!
)
(import scheme
(chicken base)
(chicken keyword)
(chicken io)
(chicken irregex)
testing
progress)
;; Curry version of line parser with configurable cell separator and
;; string delimiter. Returns a list of lists of strings.
(define ((make-csv-line-parser separator string-delimiter) line)
(let loop ((tokens (string->list line))
(res '())
(state 1))
(if (null? tokens)
(reverse
(map
(lambda (cell)
(list->string (reverse cell)))
res))
(let ((token (car tokens)))
(case state
((0) ; Parsing regular unquoted cell data - separator creates new cell
(if (eq? token separator)
(loop (cdr tokens)
res
1) ; Start a new cell
(loop (cdr tokens)
(cons (cons token (car res)) (cdr res))
0)))
((1) ; Starting a new cell - check for string delimiter
(if (eq? token string-delimiter)
(loop (cdr tokens)
(cons '() res) ; If it is quoted, keep even empty strings there
2)
(if (eq? token separator)
(loop (cdr tokens)
(cons '() res) ; This was an empty cell
1) ; Another new cell awaiting
(loop (cdr tokens)
(cons (list token) res) ; first token of regular new cell
0))))
((2) ; Parsing quoted cell data - no support for escaping string delimiter!
(if (eq? token string-delimiter)
(loop (cdr tokens)
res
0) ; There shouldn't be anything more, but it is safe to append the rest as normal unquoted data
(loop (cdr tokens)
(cons (cons token (car res)) (cdr res))
2)))))))) ; Continue inside quoted data
;; Parses given CSV lines list
(define (csv-parse-lines lines . args)
(let* ((separator (get-keyword #:separator args (lambda () #\;)))
(string-delimiter (get-keyword #:string-delimiter args (lambda () #\")))
(csv-parse-line (make-csv-line-parser separator string-delimiter))
(total (max (sub1 (length lines)) 1)))
(let loop ((lines lines)
(idx 0)
(res '()))
(if (null? lines)
(reverse res)
(let ((line (car lines)))
(progress%-advance (/ idx total))
(loop (cdr lines)
(add1 idx)
(cons (csv-parse-line line)
res)))))))
;; Loads given CSV file and parses its lines into lists
(define (csv-parse fn . args)
(let ((lines (read-lines (open-input-file fn))))
(apply csv-parse-lines lines args)))
;; Splits CSV into header and body based on the first empty row.
(define (csv-split-header csv)
(let loop ((body csv)
(rhead '()))
(if (null? body)
(list (reverse rhead) '())
(let ((row (car body)))
(if (null? row)
(list (reverse rhead)
(cdr body))
(loop (cdr body)
(cons row rhead)))))))
;; Module self-tests
(define (csv-simple-tests!)
(run-tests
csv-simple
(test-equal? csv-parse-line
((make-csv-line-parser ";" "\"") "test;2;3")
'("test" "2" "3"))
(test-equal? csv-parse-line
((make-csv-line-parser ";" "\"") "test;\"2;quoted\";3")
'("test" "2;quoted" "3"))
(test-equal? csv-split-header
(csv-split-header '((1 2) () (3 4)))
'(((1 2)) ((3 4))))
(test-equal? csv-split-header
(csv-split-header '((1 2) (5 6) (3 4)))
'(((1 2) (5 6) (3 4)) ()))
(test-equal? csv-parse-lines
(csv-parse-lines '("a;b;c" "1;2"))
'(("a" "b" "c") ("1" "2")))
))
)

180
src/dictionary.scm Normal file
View file

@ -0,0 +1,180 @@
;;
;; dictionary.scm
;;
;; Simple dictionary implementation using assq lists.
;;
;; 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 dictionary))
(module
dictionary
(
make-dict
dict-has-key?
dict-ref
dict-remove
dict-set
dict-keys
dict-map
dict-filter
dict-reduce
dictionary-tests!
)
(import scheme
(chicken base)
testing)
;; Returns an empty dictionary represented as empty list or a list of
;; pre-initialized cons pairs.
(define (make-dict . pairs)
(if (null? pairs)
'()
(car pairs)))
;; Checks whether given dictionary d contains the key k.
(define (dict-has-key? d k)
(if (assq k d) #t #f))
;; Retrieves the value for key k from dictionary d. If third argument
;; is provided it is used as default value in case the key does not
;; exist. If only two arguments are given and the key does not exist,
;; raises an error.
(define (dict-ref d k . r)
(let ((p (assq k d)))
(if p
(cdr p)
(if (null? r)
(error 'dict-ref "Key does not exist" k)
(car r)))))
;; Returns a new dictionary based on d with key k removed. If it
;; doesn't contain the key, an error is raised.
(define (dict-remove d k)
(let loop ((s d)
(r '())
(e #t))
(if (null? s)
(if e
(error 'dict-remove "Key does not exist" k)
r)
(if (eq? (caar s) k)
(loop (cdr s) r #f)
(loop (cdr s) (cons (car s) r) e)))))
;; Adds a new value v under the key k to the dictionary d possibly
;; overwriting any value which has been stored under the key
;; before. Returns the updated dictionary.
(define (dict-set d k v)
(let ((dr (let loop ((s d)
(r '()))
(if (null? s)
r
(if (eq? (caar s) k)
(loop (cdr s) r)
(loop (cdr s) (cons (car s) r)))))))
(cons (cons k v)
dr)))
;; Returns the list of keys stored in given dictionary.
(define (dict-keys d)
(map car d))
;; Maps dictionary values, the procedure gets key-value pairs if it
;; accepts more than one argument. If it accepts a third argument,
;; index gets passed as well.
(define (dict-map proc d)
(let* ((lpi (length (procedure-information proc)))
(both? (> lpi 2))
(index? (> lpi 3)))
(let loop ((d d)
(r '())
(i 0))
(if (null? d)
r ; No reverse needed, order does not matter
(loop (cdr d)
(let ((k (caar d))
(v (cdar d)))
(cons (cons k (if both?
(if index?
(proc k v i)
(proc k v))
(proc v)))
r))
(add1 i))))))
;; Returns a dictionary containing only kv pairs matching the
;; predicate which must accept two arguments. Unlike list filter,
;; does not perform final reverse on the result.
(define (dict-filter pred? d)
(let loop ((d d)
(r '()))
(if (null? d)
r
(loop (cdr d)
(if (pred? (caar d) (cdar d))
(cons (car d) r)
r)))))
;; Reduce over dictinary, the reducing procedure gets accumulator,
;; key and value as its three arguments.
(define (dict-reduce init proc d)
(let loop ((d d)
(acc init))
(if (null? d)
acc
(loop (cdr d)
(proc acc (caar d) (cdar d))))))
;; Performs self-tests of the dictionary module.
(define (dictionary-tests!)
(run-tests
dict
(test-true make-dict (null? (make-dict)))
(test-exn dict-ref (dict-ref (make-dict) 'nonexistent))
(test-true dict-ref (dict-ref (make-dict) 'nonexistent #t))
(test-equal? dict-set (dict-set (make-dict) 'nonexistent 1) '((nonexistent . 1)))
(test-equal? dict-set (dict-set (dict-set (make-dict) 'existent 1) 'existent 2) '((existent . 2)))
(test-exn dict-remove (dict-remove (make-dict) 'nonexistent))
(test-true dict-remove (null? (dict-remove (dict-set (make-dict) 'existing 1) 'existing)))
(test-equal? dict-keys (dict-keys (dict-set (make-dict) 'existing 1)) '(existing))
(test-equal? dict-map (dict-map (lambda (v) (* 2 v))
'((a . 1)
(b . 2)))
'((a . 2)
(b . 4)))
(test-equal? dict-map (dict-map (lambda (k v) (* 2 v))
'((a . 1)
(b . 2)))
'((a . 2)
(b . 4)))
(test-equal? dict-filter (dict-filter (lambda (k v)
(odd? v))
'((a . 1)
(b . 2)))
'((a . 1)))
(test-eq? dict-reduce
(dict-reduce 0 (lambda (a k v) (+ a v)) '((a . 1) (b . 2)))
3)
))
)

203
src/listing.scm Normal file
View file

@ -0,0 +1,203 @@
;;
;; listing.scm
;;
;; Source listing with line highlights.
;;
;; 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 listing))
(module
listing
(
print-source-listing
listing-tests!
)
(import scheme
(chicken base)
(chicken string)
(chicken format)
(chicken keyword)
testing
ansi)
;; Returns the number of digits required to represent a given number
;; in decimal format.
(define (number-digits number)
(let loop ((number (abs number))
(digits 0))
(if (= number 0)
(if (= digits 0)
1
digits)
(loop (quotient number 10)
(+ digits 1)))))
;; Formats line number padding it with spaces from the left for
;; alignment with number of given maximum number of digits and
;; appends ordinal dot and space.
(define (format-line-number number digits)
(let loop ((args (list (sprintf "~A. " number)))
(spaces (- digits (number-digits number))))
(if (<= spaces 0)
(string-intersperse args "")
(loop (cons " " args)
(- spaces 1)))))
;; Returns true if given line is near the target line.
(define (line-near-target? line target context)
(let ((target-line (if (list? target)
(car target)
target)))
(or (< context 0)
(<= (abs (- line target-line)) context))))
;; Returns true if given line is near one of the target lines given.
(define (line-near-targets? line targets context)
(let loop ((targets targets))
(if (null? targets)
(< context 0)
(if (line-near-target? line (car targets) context)
#t
(loop (cdr targets))))))
;; Returns true if given number is in highlights.
(define (in-highlights? number highlights)
(let loop ((highlights highlights))
(if (null? highlights)
#f
(let* ((highlight (car highlights))
(line-number (if (list? highlight)
(car highlight)
highlight)))
(if (= number line-number)
#t
(loop (cdr highlights)))))))
;; Returns hihglight match - each highlight should contain:
;; line-number, message, stage, type (error, warning, info ...)
(define (match-highlight number highlights)
(let loop ((highlights highlights))
(if (null? highlights)
#f
(let* ((highlight (car highlights))
(line-number (if (list? highlight)
(car highlight)
highlight)))
(if (= number line-number)
highlight
(loop (cdr highlights)))))))
;; Returns comment if there is any
(define (highlight-comment number highlights)
(let loop ((highlights highlights))
(if (null? highlights)
#f
(let* ((highlight (car highlights))
(line-number (if (list? highlight)
(car highlight)
highlight)))
(if (= number line-number)
(if (list? highlight)
(cadr highlight)
#f)
(loop (cdr highlights)))))))
;; Prints and highlights a selection of source listing lines and
;; their optional context.
(define (print-source-listing lines highlights . args)
(let ((highlight-rules (get-keyword #:highlight-rules args
(lambda ()
`((error ,(ansi #:bold #:red) ,(ansi #:default))
(warning ,(ansi #:yellow) ,(ansi #:default))
(info ,(ansi #:cyan) ,(ansi #:default))
))))
(ellipsis (get-keyword #:ellipsis args (lambda () "...")))
(ctx-pre (get-keyword #:context-pre args (lambda () "")))
(ctx-post (get-keyword #:context-post args (lambda () "")))
(hl-pre (get-keyword #:highlight-pre args (lambda () a:error)))
(hl-post (get-keyword #:highlight-post args (lambda () a:default)))
(context (get-keyword #:context args (lambda () 3))))
(let ((digits (number-digits (length lines))))
(let loop ((lines lines)
(number 1)
(printed-something #f)
(was-printing #f))
(when (not (null? lines))
(let* ((highlight (match-highlight number highlights))
(hl-type (if highlight (cadddr highlight) #f))
(hl-def (assq hl-type highlight-rules))
(hl-pre-real (if hl-def (cadr hl-def) hl-pre))
(hl-post-real (if hl-def (caddr hl-def) hl-post))
(context? (and (not highlight)
(line-near-targets? number highlights context)))
(print? (or highlight context?)))
(cond (print?
(when (and printed-something
(not was-printing))
(print ellipsis))
(if highlight
(display hl-pre-real)
(when context?
(display ctx-pre)))
(display (sprintf "~A~A~A"
(format-line-number number digits)
(car lines)
(let ((comment (highlight-comment number highlights)))
(if comment
(sprintf " # <<< ~A" comment)
""))))
(if highlight
(display hl-post-real)
(when context?
(display ctx-post)))
(newline)
(loop (cdr lines)
(+ number 1)
#t
#t))
(else
(loop (cdr lines)
(+ number 1)
printed-something
#f)))))))))
;; Performs self-tests of the listing module.
(define (listing-tests!)
(run-tests
listing
(test-eq? number-digits (number-digits 0) 1)
(test-eq? number-digits (number-digits 1) 1)
(test-eq? number-digits (number-digits 9) 1)
(test-eq? number-digits (number-digits 10) 2)
(test-eq? number-digits (number-digits 999) 3)
(test-equal? format-line-number (format-line-number 5 3) " 5. ")
(test-true line-near-target? (line-near-target? 4 5 -1))
(test-true line-near-target? (line-near-target? 4 5 1))
(test-true line-near-target? (line-near-target? 1 5 10))
(test-false line-near-target? (line-near-target? 4 5 0))
(test-true line-near-targets? (line-near-targets? 4 '(1 5 10) 1))
(test-false line-near-targets? (line-near-targets? 3 '(1 5 10) 1))
(test-true line-near-targets? (line-near-targets? 3 '(1 5 10) 2))
))
)

185
src/member-fees.scm Normal file
View file

@ -0,0 +1,185 @@
;;
;; member-fees.scm
;;
;; Member fees manipulation.
;;
;; 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 member-fees))
(module
member-fees
(
member-calendar
member-calendar-first-month
member-calendar-last-month
member-calendar-query
member-calendar->years-table
member-calendar->fees
member-fees-total
member-credit-total
member-calendar->table
)
(import scheme
(chicken base)
(chicken format)
(chicken sort)
configuration
member-record
month
ansi
table
members-base
period)
;; Convert into lookups - a list of (list period regular student)
(define member-fees-lookup-table
(make-period-lookup-table
'(((2010 1) 500 250))))
;; Returns a matching list of (list regular student)
(define (lookup-member-fees)
(lookup-by-period member-fees-lookup-table))
;; Returns time-based fee for given type
(define (lookup-member-fee type)
(let ((fees (lookup-member-fees)))
(if (eq? type 'student)
(cadr fees)
(car fees))))
;; Returns a list of months where each month is a list containing:
;; * month (from month module)
;; * flags - a list of symbols: student, suspended, destroyed
;; The list contains all months from 'joined until (*current-month*).
(define (member-calendar mr . args)
(let ((last-month (if (null? args)
(*current-month*)
(car args)))
(first-month (period-since (car (member-record-info mr 'member)))))
(let loop ((cm first-month)
(cal '()))
(if (month>? cm last-month)
(reverse cal)
(loop (month-add cm)
(cons (list cm
(parameterize ((*current-month* cm))
(member-flags mr)))
cal))))))
;; Returns the first month of the calendar
(define (member-calendar-first-month mc)
(caar mc))
;; Returns the last month of the calendar
(define (member-calendar-last-month mc)
(caar (reverse mc)))
;; Returns the calendar entry which matches given month or #f if none
;; found.
(define (member-calendar-query mc m)
(assoc m mc))
;; Formats the calendar entry for visualization
(define (member-calendar-entry->string e)
(if e
(if (member 'existing (cadr e))
(if (member 'suspended (cadr e))
(ansi-string #:bgdarkgrey " ") ; Suspended
(if (member 'destroyed (cadr e))
(ansi-string #:bgblack "~~") ; Destroyed
(if (member 'student (cadr e))
(ansi-string #:bgyellow " ") ; Student
(ansi-string #:bggreen " ")))) ; Normal
" ") ; Nonexistent - should not happen
" ")) ; Nonexistent
;; Converts the entry into the fee
(define (member-calendar-entry->fee e)
(if e
(if (member 'existing (cadr e))
(if (member 'suspended (cadr e))
0 ; Suspended
(if (member 'destroyed (cadr e))
0 ; Destroyed
(if (member 'student (cadr e))
(lookup-member-fee 'student) ; Student
(lookup-member-fee 'regular)))) ; Normal
0) ; Nonexistent - should not happen
0)) ; Nonexistent
;; Converts the calendar into a table where rows represent years and
;; contain the year in the first cell and 12 cells for months after
;; it.
(define (member-calendar->years-table mc)
(if (null? mc)
'()
(let* ((fm (member-calendar-first-month mc))
(lm (member-calendar-last-month mc))
(fy (month-year fm))
(ly (month-year lm)))
(let loop ((y fy)
(rows '()))
(if (> y ly)
(reverse rows)
(loop (add1 y)
(cons (let mloop ((m 1)
(row (list y)))
(if (> m 12)
(reverse row)
(mloop (add1 m)
(cons (member-calendar-entry->string
(member-calendar-query mc (make-month y m)))
row))))
rows)))))))
;; Converts the whole calendar into a list of amounts (fees)
(define (member-calendar->fees mc)
(map member-calendar-entry->fee mc))
;; Returns the total sum of fees for all months relevant for given
;; member
(define (member-fees-total mr)
(foldl + 0 (member-calendar->fees
(member-calendar mr))))
;; Total credit manually recorded in member record
(define (member-credit-total mr)
(let* ((credit (member-record-info mr 'credit '()))
(amounts (map car credit)))
(foldl + 0 amounts)))
;; Nicely print calendar for given member
(define (member-calendar->table mr)
(let* ((mc (member-calendar mr))
(fees (member-calendar->fees mc)))
(table->string (cons (map (lambda (c)
(sprintf "\t~A\t" c))
(list "" 1 2 3 4 5 6 7 8 9 10 11 12))
(member-calendar->years-table mc))
#:table-border #f
#:row-border #t
#:col-border #t
#:ansi #t
)))
)

292
src/member-parser.scm Normal file
View file

@ -0,0 +1,292 @@
;;
;; member-parser.scm
;;
;; Member file parsing.
;;
;; 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 member-parser))
(module
member-parser
(
load-member-file
member-parser-tests!
)
(import scheme
(chicken base)
(chicken io)
(chicken irregex)
member-record
testing
dictionary
month
period
utils
configuration)
;; Pass 2: known keys
(define mandatory-keys '(nick name mail phone))
(define optional-keys '(born))
(define known-multikeys
'(card desfire
credit
studentstart studentstop
suspendstart suspendstop
joined destroyed))
(define ignored-keys '(mail2))
(define known-keys (append mandatory-keys optional-keys))
;; Dynamic start/stop markers
(define start-stop-markers-lookup
'(
(studentstart student start)
(studentstop student stop)
(suspendstart suspend start)
(suspendstop suspend stop)
(joined member start)
(destroyed member stop)
))
(define start-stop-markers (map car start-stop-markers-lookup))
;; Pass 3: Interpreter passes
(define member-schema-interpreters
`((pass-markers
,(lambda (mr output key value)
(if (member key start-stop-markers)
(let* ((mk (assq key start-stop-markers-lookup))
(marker (caddr mk))
(kind (cadr mk)))
(foldl (lambda (mr value)
(let* ((mspec (string-first+rest (car value)))
(month (string->month (car mspec)))
(comment (cdr mspec)))
(if month
(member-record-sub-prepend
mr output kind
(list marker month (cdr value) comment))
(member-record-add-highlight
mr (cdr value) "Invalid month specification" 3 'error))))
mr value))
(member-record-sub-set mr output key value))))
(info
,(lambda (mr output key value)
(case key
((student suspend member)
(let* ((res (period-markers->periods value))
(ok? (car res))
(periods (cadr res))
(msg (caddr res))
(line-number (cadddr res))
(mr1 (member-record-sub-set mr output key periods)))
(if ok?
mr1
(member-record-add-highlight mr1 line-number msg 3 'error))))
((card desfire)
(member-record-sub-set mr output key
(map
(lambda (rec)
(string-first+rest (car rec)))
value)))
((credit)
(member-record-sub-set mr output key
(map
(lambda (rec)
(let* ((fr (string-first+rest (car rec)))
(amt (string->number (car fr)))
(msg (cdr fr)))
(cons amt msg)))
value)))
((nick)
(let ((mr0 (member-record-sub-set mr output key (car value))))
(if (irregex-search (irregex "[ \\t]" 'u) (car value))
(member-record-add-highlight
mr0 (cdr value) "Whitespace not allowed in nick" 3 'error)
mr0)))
(else
(member-record-sub-set mr output key (car value))))))))
;; Pass 4: Final checks - add defaults
(define (member-schema-finalize mr)
(apply
member-record-sub-ensure
mr 'info
(join (map (lambda (mk) (list mk #f)) mandatory-keys))))
;; Pass 0: Removes any comments and removes any leading and trailing
;; whitespace.
(define (preprocess-member-line line)
(irregex-replace (irregex "[ \\t]*$" 'u)
(irregex-replace (irregex "^[ \\t]*" 'u)
(irregex-replace (irregex "#.*$" 'u) line "")
"")
""))
;; Pass 1: Expects line with comments and surrounding whitespace
;; removed, returns either #f if nothing was parsed, symbol if only
;; one token was there and pair of symbol and string if both key and
;; the value were present.
(define (parse-member-line line)
(if (= (string-length line) 0)
#f
(let ((dm (irregex-search (irregex "[ \\t]" 'u) line)))
(if dm
(let* ((sep-idx (irregex-match-start-index dm))
(key-str (substring line 0 sep-idx))
(key (string->symbol key-str))
(sep+val (substring line sep-idx))
(val (irregex-replace (irregex "^[ \\t]*" 'u) sep+val "")))
(cons key val))
(string->symbol line)))))
;; Passes 0 and 1: Adds parsed lines to member record.
(define (parse-member-lines mr source)
(let loop ((lines source)
(mr (member-record-set mr #:source source))
(result '())
(line-number 1))
(if (null? lines)
(member-record-set mr #:parsed (reverse result))
(let ((parsed-line (parse-member-line
(preprocess-member-line
(car lines)))))
(loop (cdr lines)
(if (symbol? parsed-line)
(member-record-add-highlight mr line-number "Got only key" 1 'error)
mr)
(if (pair? parsed-line)
(cons (list (car parsed-line)
(cdr parsed-line)
line-number)
result)
result)
(add1 line-number))))))
;; Pass 2: Converts parsed key/value/line records into a proper
;; dictionary. Known keys are stored as pairs of value and line
;; number, known multikeys as lists of pairs of value and line
;; number.
(define (process-member-file mr)
(let loop ((parsed (dict-ref mr 'parsed))
(mr mr)
(processed (make-dict)))
(if (null? parsed)
(member-record-set mr #:processed processed)
(let* ((line (car parsed))
(key (car line))
(value (cadr line))
(number (caddr line)))
(if (member key known-keys)
(if (dict-has-key? processed key)
(loop (cdr parsed)
(member-record-add-highlight mr number "Duplicate key" 2 'error)
processed)
(loop (cdr parsed)
mr
(dict-set processed key (cons value number))))
(if (member key known-multikeys)
(loop (cdr parsed)
mr
(dict-set processed key (cons (cons value number)
(dict-ref processed key '()))))
(loop (cdr parsed)
(if (member key ignored-keys)
mr
(member-record-add-highlight mr number "Unknown key" 2 'warning))
processed)))))))
;; Pass 3+: Single interpreter pass - input must be
;; dictionary. Output is top-level key of member record.
(define (interpreter-pass mr output input pass-proc)
(let loop ((keys (dict-keys input))
(mr (dict-set mr output (make-dict))))
(if (null? keys)
mr
(let ((key (car keys)))
(loop (cdr keys)
(pass-proc mr output key
(dict-ref input key)))))))
;; Pass 3+: Interpreter passes
(define (interpret-member-file mr . starts)
(let ((input-name (if (null? starts)
'processed
(car starts))))
(let loop ((passes member-schema-interpreters)
(prev-name input-name)
(mr mr))
(if (null? passes)
mr
(let* ((pass (car passes))
(pass-name (car pass))
(pass-proc (cadr pass)))
(loop (cdr passes)
(caar passes)
(interpreter-pass mr pass-name (dict-ref mr prev-name) pass-proc)))))))
;; Loads member file source. Performs passes 0, 1 and 2.
(define (load-member-file mr)
(let* ((mrif (member-record-input-file mr))
(source (read-lines mrif))
(mrp (parse-member-lines mr source)))
(member-schema-finalize
(interpret-member-file
(process-member-file mrp)))))
;; Performs self-tests of the member-parser module.
(define (member-parser-tests!)
(run-tests
member-parser
(test-equal? preprocess-member-line
(preprocess-member-line "# all comment")
"")
(test-equal? preprocess-member-line
(preprocess-member-line " # all comment after spaces")
"")
(test-equal? preprocess-member-line
(preprocess-member-line " test # spaces and comment after spaces")
"test")
(test-equal? preprocess-member-line
(preprocess-member-line "key value # spaces and comment after spaces")
"key value")
(test-false parse-member-line
(parse-member-line ""))
(test-eq? parse-member-line
(parse-member-line "key")
'key)
(test-equal? parse-member-line
(parse-member-line "key value")
'(key . "value"))
(test-equal? parse-member-line
(parse-member-line "key value")
'(key . "value"))
(test-equal? parse-member-line
(parse-member-line "key value and some")
'(key . "value and some"))
(test-equal? parse-member-line
(parse-member-line "key value lot of spaces")
'(key . "value lot of spaces"))
))
)

402
src/member-record.scm Normal file
View file

@ -0,0 +1,402 @@
;;
;; member-record.scm
;;
;; Procedures working with complete member record (as loaded by the
;; members-base).
;;
;; 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 member-record))
(module
member-record
(
make-member-record
member-file-path
member-record-input-file
member-record-set
member-record-add-highlight
member-record-sub-ref
member-record-sub-set
member-record-sub-prepend
member-record-sub-has-key?
member-record-sub-ensure
member-record-info
member-missing-keys
member-has-highlights?
member-record-usable?
member-has-problems?
member-destroyed?
member-suspended?
member-active?
member-student?
member-existing?
member-flags
member-nick
member-id
member-suspended-months
member-format
member<?
member-record-add-payment
member-payments
member-balance
member-record-tests!
)
(import scheme
(chicken base)
(chicken keyword)
(chicken irregex)
(chicken string)
(chicken format)
dictionary
testing
month
period
configuration
primes
utils)
;; Checks whether given string is a 4-digit decimal number.
(define (is-4digit-string? s)
(if (irregex-search (irregex "^[0-9]{4}$") s)
#t
#f))
;; checks whether given symbol is a 4-digit one.
(define (is-4digit-symbol? s)
(is-4digit-string?
(symbol->string s)))
;; Returns the first 4-digit symbol from the list.
(define (get-4digit-symbol-from-list lst)
(let loop ((lst lst))
(if (null? lst)
#f
(if (is-4digit-symbol? (car lst))
(car lst)
(loop (cdr lst))))))
;; Creates new member record based on the file and symlinks
;; information received from the members directory. Any keyword
;; arguments are converted to respective symbols in the dictionary.
(define (make-member-record file-name file-path symlinks . args)
(let loop ((args args)
(pairs `((file-name . ,file-name)
(file-path . ,file-path)
(symlinks . ,symlinks)
(id . ,(string->number
(symbol->string
(get-4digit-symbol-from-list (cons file-name symlinks))))))))
(if (null? args)
(make-dict pairs)
(if (not (keyword? (car args)))
(error 'make-member-record "Optional arguments must be keywords" (car args))
(if (null? (cdr args))
(error 'make-member-record "Each optional keyword argument must have a value" (car args))
(loop (cddr args)
(cons (cons (string->symbol (keyword->string (car args)))
(cadr args))
pairs)))))))
;; Convenience accessor
(define (member-file-path mr)
(dict-ref mr 'file-path))
;; Returns opened input file for this record (used by parser).
(define (member-record-input-file mr)
(open-input-file
(dict-ref mr 'file-path)))
;; Sets pairs of keys/values for given member record.
(define (member-record-set mr . args)
(let loop ((args args)
(mr mr))
(if (null? args)
mr
(if (not (keyword? (car args)))
(error 'member-record-set "Needs argument keyword" (car args))
(if (null? (cdr args))
(error 'member-record-set "Argument needs value" (car args))
(loop (cddr args)
(dict-set mr (string->symbol (keyword->string (car args)))
(cadr args))))))))
;; Adds highlight identified by line number, message, pass number and
;; type (error, warning, info).
(define (member-record-add-highlight mr line-number message pass type)
(dict-set mr 'highlights
(cons (list line-number message pass type)
(dict-ref mr 'highlights '()))))
;; Returns a key from particular section
(define (member-record-sub-ref mr sec key . defaults)
(let ((sec-dict (dict-ref mr sec)))
(if (null? defaults)
(dict-ref sec-dict key)
(dict-ref sec-dict key (car defaults)))))
;; Sets a key in particular section
(define (member-record-sub-set mr sec key val)
(let ((sec-dict (dict-ref mr sec)))
(dict-set mr sec
(dict-set sec-dict key val))))
;; Prepends value to given subkey
(define (member-record-sub-prepend mr sec key val)
(member-record-sub-set mr sec key
(cons val
(member-record-sub-ref mr sec key '()))))
;; Returns true if given section contains given key
(define (member-record-sub-has-key? mr sec key)
(dict-has-key? (dict-ref mr sec) key))
;; Returns new member record with section updated by defaults, the
;; section must already exist.
(define (member-record-sub-ensure mr sec . kvs)
(let loop ((kvs kvs)
(sd (dict-ref mr sec)))
(if (null? kvs)
(dict-set mr sec sd)
(if (null? (cdr kvs))
(error 'member-record-sub-ensure "Needs pairs of keys and values" kvs)
(let ((key (car kvs))
(val (cadr kvs)))
(loop (cddr kvs)
(if (dict-has-key? sd key)
sd
(dict-set sd key val))))))))
;; Returns member info key value
(define (member-record-info mr key . defaults)
(let ((info (dict-ref mr 'info)))
(if (null? defaults)
(dict-ref info key)
(dict-ref info key (car defaults)))))
;; Return mandatory keys with #f as value
(define (member-missing-keys mr)
(dict-reduce '()
(lambda (acc k v)
(if v acc (cons k acc)))
(dict-ref mr 'info)))
;; True if there are any source highlights
(define (member-has-highlights? mr)
(dict-has-key? mr 'highlights))
;; Returns true if there is at least one highlight of given type
(define (member-highlights-has-type? mr type)
(let loop ((hls (dict-ref mr 'highlights '())))
(if (null? hls)
#f
(if (eq? (cadddr (car hls)) type)
#t
(loop (cdr hls))))))
;; Returns true if there is at least one highlight with error type
(define (member-has-errors? mr)
(member-highlights-has-type? mr 'error))
;; Absolutely required
(define (member-record-usable? mr)
(dict-has-key? (dict-ref mr 'info) 'member))
;; True if member record is OK
(define (member-has-problems? mr)
(or (member-has-errors? mr)
(not (member-record-usable? mr))
(not (is-4digit-prime? (member-id mr)))))
;; Returns true if the member record represents non-existing
;; member. The *current-month* is a global parameter from period
;; module.
(define (member-destroyed? mr)
(and (not (member-existing? mr))
(let ((member (member-record-info mr 'member)))
(if (null? member)
#f
(month>=? (*current-month*)
(period-since (car member)))))))
;; Generic period-based predicate
(define ((member-period-predicate? key) mr)
(let ((periods (member-record-info mr key #f)))
(and periods
(month-in-periods? periods))))
;; Returns true if the member is now suspended
(define member-is-suspended?
(member-period-predicate? 'suspend))
;; Suspended must not be destroyed
(define (member-suspended? mr)
(and (member-is-suspended? mr)
(not (member-destroyed? mr))))
;; True if the member is student
(define member-is-student?
(member-period-predicate? 'student))
;; Only active members can be students.
(define (member-student? mr)
(and (member-active? mr)
(member-is-student? mr)))
;; Returns true if the member is active (not suspended or destroyed).
(define (member-active? mr)
(and (month-in-periods? (member-record-info mr 'member))
(not (member-suspended? mr))))
;; Returns true if the member is currently a member
(define (member-existing? mr)
(month-in-periods?
(member-record-info mr 'member)))
;; Returns a list of flags of given member record.
(define (member-flags mr)
(filter identity
(list (if (member-student? mr) 'student #f)
(if (member-suspended? mr) 'suspended #f)
(if (member-active? mr) 'active #f)
(if (member-destroyed? mr) 'destroyed #f)
(if (member-existing? mr) 'existing #f))))
;; Nickname as string
(define (member-nick mr)
(member-record-info mr 'nick))
;; Returns member id
(define (member-id mr)
(dict-ref mr 'id))
;; Returns the number of months the user is suspended. Zero if not
;; suspended.
(define (member-suspended-months mr)
(if (member-suspended? mr)
(let ((period (periods-match (member-record-info mr 'suspend))))
(if period
(month-diff (car period) (*current-month*))
0))
0))
;; Member formatting function for general use.
(define (member-format fmt mr)
(let loop ((fmtl (string->list fmt))
(resl '()))
(if (null? fmtl)
(string-intersperse (reverse resl) "")
(let ((ch (car fmtl)))
(if (eq? ch #\~)
(loop (cddr fmtl)
(cons (case (cadr fmtl)
((#\N) (member-record-info mr 'nick))
((#\I) (number->string (member-record-info mr 'id)))
((#\S) (number->string (member-suspended-months mr)))
((#\E)
(let ((n (length (dict-ref mr 'highlights '()))))
(if (eq? n 0)
""
(sprintf "[~A]" n))))
((#\~) "~"))
resl))
(loop (cdr fmtl)
(cons (make-string 1 (car fmtl)) resl)))))))
;; Comparator of member records based on nickname.
(define (member<? a b)
(string-ci<? (member-nick a)
(member-nick b)))
;; Prepends new payment to given member record payments
(define (member-record-add-payment mr pt)
(dict-set mr 'payments
(cons pt
(dict-ref mr 'payments '()))))
;; Returns alist of member payments
(define (member-payments mr)
(dict-ref mr 'payments '()))
;; Balances totals
(define (member-balance mr)
(dict-ref mr 'balance (make-dict)))
;; Self-tests
(define (member-record-tests!)
(run-tests
member-record
(test-equal? make-member-record
(make-member-record '|1234| "members/1234" '(|member|))
'((file-name . |1234|)
(file-path . "members/1234")
(symlinks |member|)
(id . 1234)))
(test-equal? make-member-record
(make-member-record '|1234| "members/1234" '(|member|) #:msg "msg")
'((msg . "msg")
(file-name . |1234|)
(file-path . "members/1234")
(symlinks |member|)
(id . 1234)))
(test-equal? member-record-set
(member-record-set '() #:id 1234)
'((id . 1234)))
(test-equal? member-record-add-highlight
(member-record-add-highlight '() 123 "Interesting..." 0 'info)
'((highlights . ((123 "Interesting..." 0 info)))))
(test-true member-destroyed?
(parameterize ((*current-month* (list 2023 2)))
(member-destroyed? '((info . ((member . (((2010 1) (2010 5))))))))))
(test-false member-destroyed?
(parameterize ((*current-month* (list 2009 2)))
(member-destroyed? '((info . ((member . (((2001 1) (2010 5))))))))))
(test-false member-suspended?
(member-suspended? '((info . ((member . (((2015 1) #f))))))))
(test-true member-suspended?
(parameterize ((*current-month* (list 2015 2)))
(member-suspended? '((info . ((member . (((2015 1) #f)))
(suspend ((2010 1) (2022 4) #f #f))))))))
(test-true member-suspended?
(parameterize ((*current-month* (list 2015 2)))
(member-suspended? '((info . ((member . (((2015 1) #f)))
(suspend ((2010 1) #f #f #f))))))))
(test-false member-suspended?
(parameterize ((*current-month* (list 2023 2)))
(member-suspended? '((info . ((member . (((2015 1) #f)))
(suspend ((2010 1) (2022 4) #f #f))))))))
(test-true member-active?
(parameterize ((*current-month* (list 2023 2)))
(member-active? '((info . ((member . (((2015 1) #f)))
(suspend ((2010 1) (2022 4) #f #f))))))))
))
)

200
src/members-base.scm Normal file
View file

@ -0,0 +1,200 @@
;;
;; members-base.scm
;;
;; Storage for member files.
;;
;; 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 members-base))
(module
members-base
(
load-members
find-member-by-id
find-member-by-nick
list-members-ids
filter-members-by-predicate
list-members-nicks
members-base-info
members-base-stats
get-free-members-ids
gen-member-id
members-base-update
)
(import scheme
(chicken base)
(chicken string)
(chicken random)
testing
utils
dictionary
primes
member-record
ansi
period
month
configuration
progress
members-dir)
;; Loads members database, if the second argument is true, shows
;; progress. Members database is a dictionary with id being the key
;; (number) and member record being the value.
(define (load-members dn . opts)
(let ((progress? (and (not (null? opts))
(car opts))))
(with-progress%
progress? "members"
(let* ((fss (load-members-dir dn))
(tot (sub1 (length (dict-keys fss))))
(mb0 (dict-map
(lambda (symfn symlinks prg)
(progress%-advance (/ prg tot))
(members-dir-load-member dn
symfn
symlinks))
fss))
(mb1 (dict-reduce (make-dict)
(lambda (acc symfn mr)
(dict-set acc (dict-ref mr 'id) mr))
mb0))
(mb (dict-reduce '()
(lambda (acc id mr)
(cons mr acc))
mb1)))
mb))))
;; Gets member based by generic predicate
(define (find-member-by-predicate mb pred)
(let loop ((mdb mb))
(if (null? mdb)
#f
(let ((mr (car mdb)))
(if (pred mr)
mr
(loop (cdr mdb)))))))
;; Returns member record found by id
(define (find-member-by-id mb id)
(find-member-by-predicate
mb
(lambda (mr)
(eq? (dict-ref mr 'id) id))))
;; Returns member record found by id
(define (find-member-by-nick mb nick)
(find-member-by-predicate
mb
(lambda (mr)
(string-ci=?
(dict-ref
(dict-ref mr 'info)
'nick)
nick))))
;; Returns all ids found in the database
(define (list-members-ids mb)
(map (lambda (mr) (dict-ref mr 'id)) mb))
;; Returns a list of members which match given predicate.
(define (filter-members-by-predicate mb pred)
(let loop ((mb mb)
(res '()))
(if (null? mb)
res
(let ((mr (car mb)))
(loop (cdr mb)
(if (pred mr)
(cons mr res)
res))))))
;; Returns all nicks found in the database
(define (list-members-nicks mb)
(map (lambda (mr) (dict-ref (dict-ref mr 'info) 'nick)) mb))
;; Returns dictionary with statistics about the members base.
(define (members-base-info mb-arg)
(let* ((mb (filter-members-by-predicate mb-arg member-record-usable?))
(di0 (make-dict))
(di1 (dict-set di0 'invalid
(filter-members-by-predicate mb
(compose not is-4digit-prime? member-id))))
(di2 (dict-set di1 'active
(filter-members-by-predicate mb member-active?)))
(di3 (dict-set di2 'suspended
(filter-members-by-predicate mb member-suspended?)))
(di4 (dict-set di3 'students
(filter-members-by-predicate mb member-student?)))
(di5 (dict-set di4 'destroyed
(filter-members-by-predicate mb member-destroyed?)))
(di6 (dict-set di5 'month (*current-month*)))
(di7 (dict-set di6 'total mb)))
di7))
(define (members-base-oldest-month mb)
(make-month 2015 1))
;; Returns a list two lists: keys, data.
;; Each data record contains values for all keys.
(define (members-base-stats mb)
(let ((keys '(month total active suspended students destroyed invalid)))
(let mloop ((data '())
(month (members-base-oldest-month mb)))
(if (month<? month (*current-month*))
(let ((bi (parameterize ((*current-month* month))
(members-base-info mb))))
(let kloop ((row (list (dict-ref bi 'month)))
(keys (cdr keys)))
(if (null? keys)
(mloop (cons (reverse row) data)
(month-add month 1))
(kloop (cons (length (dict-ref bi (car keys))) row)
(cdr keys)))))
(list keys (reverse data))))))
;; Returns all free ids
(define (get-free-members-ids mb)
(let ((ids (list-members-ids mb)))
(filter
(lambda (id)
(not (member id ids)))
(gen-all-4digit-primes))))
;; Generates random vector id.
(define (gen-member-id mb)
(let* ((fids (get-free-members-ids mb))
(vfids (list->vector fids)))
(vector-ref vfids (pseudo-random-integer (vector-length vfids)))))
;; Returns new members base with member records matching the
;; predicate processed by proc.
(define (members-base-update mb pred? proc)
(map (lambda (mr)
(if (pred? mr)
(proc mr)
mr))
mb))
)

184
src/members-dir.scm Normal file
View file

@ -0,0 +1,184 @@
;;
;; members-dir.scm
;;
;; Storage for member files.
;;
;; 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 members-dir))
(module
members-dir
(
load-members-dir
members-dir-load-member
members-dir-tests!
)
(import scheme
(chicken base)
(chicken pathname)
(chicken file posix)
(chicken file)
(chicken format)
(chicken irregex)
testing
dictionary
utils
member-record
member-parser)
;; Gets all files and symbolic links from given directory. The
;; symbolic links are represented by cons cells with car being the
;; name and cdr the link target.
(define (get-files+symlinks dn)
(let loop ((fns (directory dn))
(rs '()))
(if (null? fns)
rs
(let* ((fn (car fns))
(ffn (make-pathname dn fn)))
(loop (cdr fns)
(if (symbolic-link? ffn)
(cons (cons (string->symbol fn)
(string->symbol (read-symbolic-link ffn)))
rs)
(if (regular-file? ffn)
(cons (string->symbol fn) rs)
rs)))))))
;; Converts a list of symlinks and files in aforementioned format
;; into a dictionary of regular files as keys with lists of symlinks
;; as values. If the target file does not exist, adds 'error-0 symbol
;; as the first alias to this list with the number increasing with
;; each nonexistent file encountered. The error record is also
;; generated for symlinks pointing outside of the directory.
(define (files+symlinks->files-dictionary ls)
(let* ((links (filter pair? ls))
(files (filter symbol? ls))
(fdict
(let loop ((files files)
(res (make-dict)))
(if (null? files)
res
(loop (cdr files)
(dict-set res (car files) '()))))))
(let loop ((links links)
(res fdict)
(errs 0))
(if (null? links)
res
(let* ((link (car links))
(name (car link))
(target (cdr link)))
(if (dict-has-key? res target)
(loop (cdr links)
(dict-set res target (cons name (dict-ref res target)))
errs)
(loop (cdr links)
(dict-set res target
(list (string->symbol (sprintf "error-~A" errs))
name))
(+ errs 1))))))))
;; Checks whether given string is a 4-digit decimal number.
(define (is-4digit-string? s)
(if (irregex-search (irregex "^[0-9]{4}$") s)
#t
#f))
;; checks whether given symbol is a 4-digit one.
(define (is-4digit-symbol? s)
(is-4digit-string?
(symbol->string s)))
;; Returns true if the list contains at least one 4-digit symbol.
(define (list-contains-4digit-symbol? lst)
(let loop ((lst lst))
(if (null? lst)
#f
(if (is-4digit-symbol? (car lst))
#t
(loop (cdr lst))))))
;; Returns the first 4-digit symbol from the list.
(define (get-4digit-symbol-from-list lst)
(let loop ((lst lst))
(if (null? lst)
#f
(if (is-4digit-symbol? (car lst))
(car lst)
(loop (cdr lst))))))
;; Returns dictionary containing only records with either 4-digit
;; name or one of its aliases being 4-digit.
(define (files-dictionary-filter-4digit-symbols d)
(dict-filter
(lambda (k v)
(list-contains-4digit-symbol? (cons k v)))
d))
;; Loads the members directory as dictionary of files to symlinks
;; mapping.
(define (load-members-dir dn)
(files-dictionary-filter-4digit-symbols
(files+symlinks->files-dictionary
(get-files+symlinks dn))))
;; Returns a dictionary containing file-name, symlinks, id and info
;; keys. The info key contains whatever load-member-file from the
;; member-file module returns. The id key contains whatever is the
;; first 4-digit symbol in (cons fname aliases) list.
(define (members-dir-load-member mdir fname symlinks)
(let* ((mr0 (make-member-record fname
(make-pathname mdir (symbol->string fname))
symlinks)))
(load-member-file mr0)))
;; Performs self-tests of this module.
(define (members-dir-tests!)
(run-tests
members-base
(test-equal? files+symlinks->files-dictionary
(files+symlinks->files-dictionary
'(joe (2803 . joe)))
'((joe 2803)))
(test-equal? files+symlinks->files-dictionary
(files+symlinks->files-dictionary
'(joe
(2803 . joe)
(666 . nonexistent)))
'((nonexistent error-0 666)
(joe 2803)))
(test-true is-4digit-string? (is-4digit-string? "0000"))
(test-false is-4digit-string? (is-4digit-string? "AAAA"))
(test-false is-4digit-string? (is-4digit-string? "666"))
(test-true is-4digit-symbol? (is-4digit-symbol? '|0000|))
(test-false is-4digit-symbol? (is-4digit-symbol? '|ABC|))
(test-true list-contains-4digit-symbol? (list-contains-4digit-symbol? '(|0000| abc |666|)))
(test-false list-contains-4digit-symbol? (list-contains-4digit-symbol? '(|00000| abc |666|)))
(test-eq? get-4digit-symbol-from-list
(get-4digit-symbol-from-list '(|000| abc |6666| qwer))
'|6666|)
))
)

143
src/members-payments.scm Normal file
View file

@ -0,0 +1,143 @@
;;
;; members-payments.scm
;;
;; Adding payment information to member records from bank account statement.
;;
;; 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 members-payments))
(module
members-payments
(
members-payments-process
member-payments-total
)
(import scheme
(chicken base)
(chicken string)
(chicken io)
(chicken irregex)
(chicken sort)
bank-account
member-record
members-base
bank-fio
dictionary
member-fees
period)
;; Exchange rates
(define exchange-rates-lookup-table
(make-period-lookup-table
'(((2010 1) 25))))
;; Lookup CZK/EUR
(define (lookup-eur-rate)
(car (lookup-by-period exchange-rates-lookup-table)))
;; Extract probable member-id from transaction
(define (transaction-extract-member-id transaction)
(if (equal? (bank-transaction-type transaction) "Poplatek")
#f
(let* ((varsym-id0
(string->number
(bank-transaction-varsym transaction)))
(varsym-id
(or varsym-id0
(let* ((msg (bank-transaction-message transaction))
(ci (substring-index "," msg))
(vs (if ci
(substring msg 0 ci)
msg)))
(string->number vs)))))
varsym-id)))
;; Merges bank account statement into members payment keys. The
;; payment key will be a list of transactions.
(define (members-payments-process-bank mb ba)
(let loop ((mb mb)
(transactions (bank-account-transactions ba)))
(if (null? transactions)
mb
(let* ((transaction (car transactions))
(varsym-id (transaction-extract-member-id transaction)))
(loop (members-base-update mb
(lambda (mr)
(eq? (member-id mr)
varsym-id))
(lambda (mr)
(member-record-add-payment mr transaction)))
(cdr transactions))))))
;; Reads the payments
(define (load-accounts-list apikeys)
(map (compose car string-split)
(read-lines
(open-input-file apikeys))))
;; Loads all accounts - it expects .csv files in the current
;; directory.
(define (load-accounts accounts-list)
(map (lambda (acc)
(bank-fio-parse (string-append acc ".csv")))
accounts-list))
;; If apikeys is not #f, loads the account numbers, loads bank
;; accounts and processes transactions.
(define (members-payments-process mb apikeys-file)
(if apikeys-file
(let* ((accounts (load-accounts
(load-accounts-list apikeys-file))))
(map member-add-balance
(foldl members-payments-process-bank
mb
accounts)))
mb))
;; Adds all balances - payments are converted to CZK.
(define (member-add-balance mr)
(let ((mr0 (dict-set mr
'balance
(make-dict `((fees . ,(member-fees-total mr))
(credit . ,(member-credit-total mr))
(payment . ,(member-payments-total mr)))))))
(dict-set mr0
'payments
(sort (dict-ref mr0 'payments '())
(lambda (a b)
(string<? (bank-transaction-date a)
(bank-transaction-date b)))))))
;; Total amount paid
(define (member-payments-total mr)
(foldl + 0 (map (lambda (tr)
(let ((amount (bank-transaction-amount tr))
(currency (bank-transaction-currency tr)))
(case currency
((CZK) amount)
((EUR) (* amount (lookup-eur-rate)))
(else 0))))
(member-payments mr))))
)

374
src/members-print.scm Normal file
View file

@ -0,0 +1,374 @@
;;
;; members-print.scm
;;
;; Procedures working with complete member record (as loaded by the
;; members-base).
;;
;; 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 members-print))
(module
members-print
(
print-member-info
print-member-table
print-member-source
print-members-base-info
print-members-base-table
print-members-base-stats
print-members-ids-stats
print-members-fees-table
)
(import scheme
(chicken base)
(chicken string)
(chicken sort)
(chicken format)
dictionary
member-record
month
utils
table
listing
ansi
period
primes
members-base
configuration
bank-account
member-fees)
;; Prints human-readable information
(define (print-member-info mr)
(let* ((id (dict-ref mr 'id))
(aliases (dict-ref mr 'symlinks))
(info (dict-ref mr 'info))
(sinfo (sort info
(lambda (a b)
(string<?
(symbol->string (car a))
(symbol->string (car b)))))))
(print "User " id " alias(es): "
(string-intersperse
(map symbol->string aliases)
", "))
(when (member-suspended? mr)
(print " Suspended for " (member-suspended-months mr) " months."))
(newline)
(let loop ((sinfo sinfo))
(when (not (null? sinfo))
(let* ((kv (car sinfo))
(k (car kv))
(v (cdr kv)))
(loop (cdr sinfo)))))))
;; Returns nicely formatted table
(define (member-info->table mr)
(let* ((aliases (dict-ref mr 'symlinks))
(mid (member-id mr))
(head (list (if (is-4digit-prime? mid)
(list "ID:" mid)
(list (ansi-string #:red #:bold "ID:")
(ansi-string #:red #:bold (number->string mid) " (not prime)")))
(list (sprintf "Alias~A:" (if (> (length aliases) 1) "es" ""))
(string-intersperse (map symbol->string aliases) ", "))
(if (member-suspended? mr)
(list "Suspended for:"
(let ((msm (member-suspended-months mr)))
(sprintf "~A month~A" msm
(if (> msm 1) "s" ""))))
#f)))
(info (dict-ref mr 'info))
(sikeys (sort (dict-keys info)
(lambda (a b)
(string<?
(symbol->string a)
(symbol->string b)))))
(body (map (lambda (k)
(let ((v (dict-ref info k)))
(case k
((card desfire credit)
(list k
(table->string
(map
(lambda (c)
(list (car c) (cdr c)))
v)
#:col-border #t)))
((suspend student member)
(list k
(table->string
(cons (list "Since" "Until")
(map
(lambda (p)
(list
(string-append (month->string (period-since p)) " "
(or (period-scomment p) ""))
(string-append (month->string (period-before p)) " "
(or (period-bcomment p) ""))))
v))
#:col-border #t)))
(else
(if v
(list k v)
(list (ansi-string #:red #:bold (symbol->string k))
(ansi-string #:red #:bold "---")))))))
sikeys))
(result (filter identity (append head body))))
(table->string result #:table-border #f #:row-border #t #:col-border #t #:ansi #t)))
;; Prints nicely formatted table
(define (print-member-table mr)
(print
(table->string
(list (list "Basic Information" "Payments" "Membership Status")
(list (member-info->table mr)
(member-payments->table mr)
(member-calendar->table mr))
)
#:row0-border #t
#:col-border #t)))
;; Nicely prints the member source with any errors recorded.
(define (print-member-source mr)
(let* ((lines (dict-ref mr 'source mr))
(file-name (dict-ref mr 'file-name))
(hls (dict-ref mr 'highlights '())))
(print file-name ":")
(print-source-listing
lines
hls
#:context -1
)))
;; Prints nicely printed payments
(define (member-payments->table mr)
(table->string (cons
(list "Var" "Amount" "Cur" "Date" "TrId")
(map (lambda (tr)
(list (sprintf "\t~A" (bank-transaction-varsym tr))
(sprintf "\t~A" (bank-transaction-amount tr))
(bank-transaction-currency tr)
(bank-transaction-date tr)
(bank-transaction-id tr)))
(member-payments mr)))
#:row0-border #t
#:col-border #t
))
;; Converts member records to string, optional arguments are format
;; and separator. Format defaults to "~N" and separator to ", ".
(define (member-records->string mrs . args)
(let ((fmt (if (null? args) "~N" (car args)))
(sep (if (or (null? args)
(null? (cdr args)))
", "
(cadr args))))
(string-intersperse
(map (lambda (mr)
(member-format fmt mr))
mrs)
sep)))
;; Basic information about members-base in human-readable form.
(define (print-members-base-info mb)
(let ((nicks (list-members-nicks mb))
(ids (list-members-ids mb)))
(print "Known members: "
(length nicks))
(let* ((bi (members-base-info mb))
(invalid-mrs (dict-ref bi 'invalid))
(active-mrs (dict-ref bi 'active))
(suspended-mrs (dict-ref bi 'suspended))
(destroyed-mrs (dict-ref bi 'destroyed))
(student-mrs (dict-ref bi 'students)))
(print a:success " Active (" (length active-mrs) "): " a:default
(member-records->string (sort active-mrs member<?) "~N~E"))
(print a:warning " Suspended (" (length suspended-mrs) "): " a:default
(member-records->string (sort suspended-mrs member<?) "~N~E"))
(print a:warning " Destroyed (" (length destroyed-mrs) "): " a:default
(member-records->string (sort destroyed-mrs member<?) "~N~E"))
(print a:highlight " Students (" (length student-mrs) "): " a:default
(member-records->string (sort student-mrs member<?)))
(let ((suspended2 (filter-members-by-predicate
suspended-mrs
(lambda (mr)
(>= (member-suspended-months mr) 24)))))
(when (not (null? suspended2))
(print (ansi #:magenta) " Suspended for at least 24 months ("
(length suspended2) "): " a:default
(member-records->string (sort suspended2 member<?) "~N (~S)"))))
(when (not (null? invalid-mrs))
(print a:error " Invalid Id (" (length invalid-mrs) "): "
(member-records->string (sort invalid-mrs member<?) "~N (~I)")
a:default)))))
;; Helper function for pretty-formatting the filtered members lists
;; in a table.
(define (members-table-row a:? label mrs fmt)
(list (string-append "\t" a:? label)
(length mrs)
(ansi-paragraph-format
(member-records->string
(sort mrs member<?)
fmt)
60)))
;; Prints nicely aligned members base info
(define (print-members-base-table mb)
(let* ((bi (members-base-info mb))
(all-mrs (dict-ref bi 'total))
(invalid-mrs (dict-ref bi 'invalid))
(active-mrs (dict-ref bi 'active))
(suspended-mrs (dict-ref bi 'suspended))
(destroyed-mrs (dict-ref bi 'destroyed))
(student-mrs (dict-ref bi 'students)))
(print "Known members: " (length all-mrs))
(newline)
(print
(table->string
(filter
identity
(list (list "Type" "Count" "List")
(members-table-row a:success "Active:" active-mrs "~N~E")
(members-table-row a:highlight "Students:" student-mrs "~N~E")
(members-table-row a:warning "Suspended:" suspended-mrs "~N~E")
(members-table-row a:warning "Destroyed:" destroyed-mrs "~N~E")
(let ((suspended2 (filter-members-by-predicate
suspended-mrs
(lambda (mr)
(>= (member-suspended-months mr)
(*member-suspend-max-months*))))))
(if (null? suspended2)
#f
(members-table-row (ansi #:magenta) "Suspended (long):" suspended2 "~N (~S)")))
))
#:ansi #t
#:row-border #t
#:col-border #t
)))
(let ((pmrs (filter-members-by-predicate mb member-has-problems?)))
(when (not (null? pmrs))
(newline)
(print "Member files with errors (" (length pmrs) "): "
(string-intersperse
(map member-file-path pmrs)
", "))))
(let ((pmrs (filter-members-by-predicate mb (lambda (mr)
(and (member-has-highlights? mr)
(not (member-has-problems? mr)))))))
(when (not (null? pmrs))
(newline)
(print "Member files with issues: "
(string-intersperse
(map member-file-path pmrs)
", ")))))
;; Prints the stats in format used by gnuplot.
(define (print-members-base-stats ms)
(let ((keys (car ms))
(data (cadr ms)))
(print "# " (string-intersperse (map symbol->string keys) " "))
(let loop ((rows data))
(when (not (null? rows))
(let* ((row (car rows))
(month (month->string (car row)))
(vals (cdr row)))
(print month " " (string-intersperse (map number->string vals) " "))
(loop (cdr rows)))))))
;; Prints statistics about allocated and unused valid/invalid IDs.
(define (print-members-ids-stats MB)
(print "Allocated IDs: "
(length (list-members-ids MB))
"/"
(length (gen-all-4digit-primes))
" ("
(length (get-free-members-ids MB))
" free)")
(let ((iids (filter (compose not is-4digit-prime?) (list-members-ids MB))))
(when (not (null? iids))
(print " Invalid: "
(length iids)
" ("
(string-intersperse
(map (lambda (id)
(let ((mr (find-member-by-id MB id)))
(member-format
"~I - ~N"
mr)))
iids)
", ")
")"))))
;; Prints summary table of all fees and credits for all members
(define (print-members-fees-table MB)
(print
(table->string
(cons
(list (ansi-string #:bgblue #:brightyellow #:bold "Member")
(ansi-string #:bgblue #:brightyellow #:bold "Fees")
(ansi-string #:bgblue #:brightyellow #:bold "Credit")
(ansi-string #:bgblue #:brightyellow #:bold "Payments")
(ansi-string #:bgblue #:brightyellow #:bold "Balance"))
(append
(map
(lambda (mr)
(let* ((balance (member-balance mr))
(fees (dict-ref balance 'fees))
(credit (dict-ref balance 'credit))
(payment (dict-ref balance 'payment))
(total (- (+ credit payment) fees)))
(list (member-nick mr)
(sprintf "\t~A" fees)
(sprintf "\t~A" credit)
(sprintf "\t~A" payment)
(sprintf "\t~A~A~A"
(if (< total -500)
a:error
(if (< total 0)
a:warning
a:success))
(exact->inexact total)
a:default)
)))
(sort (filter-members-by-predicate MB member-active?) member<?))
(let* ((balances (map member-balance MB))
(fees (foldl + 0 (map (lambda (b) (dict-ref b 'fees)) balances)))
(credit (foldl + 0 (map (lambda (b) (dict-ref b 'credit)) balances)))
(payment (foldl + 0 (map (lambda (b) (dict-ref b 'payment)) balances)))
(total (- (+ credit payment) fees)))
(list (list (ansi-string #:bold "Total")
(ansi-string "\t" #:bold (sprintf "~A" fees))
(ansi-string "\t" #:bold (sprintf "~A" credit))
(ansi-string "\t" #:bold (sprintf "~A" payment))
(ansi-string "\t" #:bold
(sprintf "~A~A"
(if (< total 0)
a:error
a:success)
total))
)))))
#:col-border #t #:row0-border #t #:ansi #t)))
)

182
src/month.scm Normal file
View file

@ -0,0 +1,182 @@
;;
;; 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
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))))
;; 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))
))
)

268
src/period.scm Normal file
View file

@ -0,0 +1,268 @@
;;
;; 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
(
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)
;; 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))
))
)

100
src/primes.scm Normal file
View file

@ -0,0 +1,100 @@
;;
;; primes.scm
;;
;; Simple handling of 4-digit primes.
;;
;; 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 primes))
(module
primes
(
is-4digit-prime?
gen-all-4digit-primes
primes-tests!
)
(import scheme
(chicken base)
testing
utils)
;; Checks whether given number is prime by checking the remainder of
;; the division by all primes less than square root of the number in
;; question.
(define (check-prime primes n)
(let ((prime-at-most
(inexact->exact
(floor
(sqrt n)))))
(let loop ((ps primes))
(if (null? ps)
#t
(let ((cp (car ps)))
(if (<= cp prime-at-most)
(if (eq? (remainder n cp) 0)
#f
(loop (cdr ps)))
#t))))))
;; Generates list of primes less than given argument.
(define (gen-primes less-than . init)
(let loop ((primes (if (null? init)
'(2)
(car init)))
(number 3))
(if (< number less-than)
(loop (if (check-prime primes number)
(append primes (list number))
primes)
(+ number 2))
primes)))
;; Used for checking any primes < 10000
(define primes<100 (gen-primes 100))
;; Check whether given number is four-digit number and whether it is
;; also prime.
(define (is-4digit-prime? n)
(and (>= n 1000)
(<= n 9999)
(check-prime primes<100 n)))
;; Generates all valid member ids
(define (gen-all-4digit-primes)
(filter is-4digit-prime?
(gen-primes 10000 primes<100)))
;; Module self-tests.
(define (primes-tests!)
(run-tests
primes
(test-true check-prime (check-prime primes<100 67))
(test-true is-4digit-prime? (is-4digit-prime? 2803))
(test-false is-4digit-prime? (is-4digit-prime? 666))
(test-false is-4digit-prime? (is-4digit-prime? 997))
(test-false is-4digit-prime? (is-4digit-prime? 6666))
(test-false is-4digit-prime? (is-4digit-prime? 66666))
(test-false is-4digit-prime? (is-4digit-prime? 10007))
))
)

166
src/progress.scm Normal file
View file

@ -0,0 +1,166 @@
;;
;; progress.scm
;;
;; Progress reporting.
;;
;; 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 progress))
(module
progress
(
run-with-progress
progress-advance
with-progress
run-progress-break
progress-break
*progress%-width*
*progress%-step*
run-with-progress%
with-progress%
progress%-advance
)
(import scheme
(chicken base)
(chicken format)
(chicken port))
;; Parameterized current progress string
(define *current-progress* (make-parameter #f))
;; Prints current progress.
(define (print-current-progress . args)
(let ((cp (*current-progress*)))
(when cp
(display (sprintf "\r\x1b[K~A" cp)))))
;; Adds something to current progress and refreshes the display.
(define (progress-advance . args)
(when (*current-progress*)
(let ((str (if (null? args)
"."
(car args))))
(*current-progress* (string-append (*current-progress*) (sprintf "~A" str)))
(print-current-progress))))
;; Runs given procedure within progress environment
(define (run-with-progress echo? pre-msg post-msg thunk)
(parameterize ((*current-progress* (if echo? pre-msg #f)))
(print-current-progress)
(let ((result (thunk)))
(print-current-progress)
(when echo?
(print post-msg))
result)))
;; Allows printing output when progress is advancing.
(define (run-progress-break thunk)
(when (*current-progress*)
(display "\r\x1b[K"))
(thunk)
(print-current-progress))
;; Friendly syntax wrapper.
(define-syntax with-progress
(syntax-rules ()
((_ echo? pre post body ...)
(run-with-progress echo? pre post (lambda () body ...)))))
;; Evaluate some expressions without progress.
(define-syntax progress-break
(syntax-rules ()
((_ body ...)
(run-progress-break (lambda () body ...)))))
;; Progress% visual configuration
(define *progress%-width* (make-parameter 40))
;; Progress% time step configuration
(define *progress%-step* (make-parameter 0.01))
;; Tracking the progress via set of parameters
(define *current-progress%* (make-parameter #f))
(define *current-progress%-echo?* (make-parameter #f))
(define *current-progress%-value* (make-parameter #f))
(define *current-progress%-last-value* (make-parameter #f))
(define *current-progress%-range* (make-parameter (cons 0 1)))
;; Unconditionally prints the current progress.
(define (print-current-progress%)
(when (and (*current-progress%*)
(*current-progress%-echo?*))
(let* ((raw-value (*current-progress%-value*))
(range (*current-progress%-range*))
(value (+ (car range)
(* raw-value
(- (cdr range) (car range)))))
(value% (* 100 value))
(ivalue% (inexact->exact (round value%)))
(bwidth (inexact->exact
(round
(* value (*progress%-width*)))))
(swidth (- (*progress%-width*) bwidth)))
(display
(sprintf "\r[~A~A] ~A% ~A"
(make-string bwidth #\=)
(make-string swidth #\space)
ivalue%
(*current-progress%*))))))
;; If the new value is different-enough from the current one, updates
;; it and re-prints the progress%
(define (progress%-advance new-value)
(when (*current-progress%*)
(*current-progress%-value* new-value)
(let ((old-value (*current-progress%-last-value*)))
(when (>= (abs (- new-value old-value)) (*progress%-step*))
(*current-progress%-last-value* new-value)
(print-current-progress%)))))
;; Procedure realizing the actual progress tracking
(define (run-with-progress% echo? name thunk)
(parameterize ((*current-progress%* name)
(*current-progress%-echo?* echo?)
(*current-progress%-value* 0)
(*current-progress%-last-value* 0)
(*current-progress%-range* (cons 0 1)))
(print-current-progress%)
(let ((result (thunk)))
(print-current-progress%)
(when echo?
(newline))
result)))
;; Runs named progress%
(define-syntax with-progress%
(syntax-rules ()
((_ echo? name body ...)
(run-with-progress%
echo? name
(lambda () body ...)))))
;; If the program uses progress module, disable buffering
(set-buffering-mode! (current-output-port) #:none)
)

394
src/table.scm Normal file
View file

@ -0,0 +1,394 @@
;;
;; table.scm
;;
;; Simple table formatter.
;;
;; 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 table))
(module
table
(
*table-border-style*
table->string
table-tests!
)
(import scheme
(chicken base)
(chicken string)
(chicken format)
(chicken keyword)
(chicken irregex)
ansi
testing
utils)
;; Default table border style to use if not explicitly specified.
(define *table-border-style* (make-parameter 'unicode))
;; Table border styles in visual form
(define table-borders-lookup-source
'((debug
"/=,\\"
"] |["
">-+<"
"'~^`")
(ascii
"+-++"
"| ||"
"+-++"
"+-++")
(unicode
"┌─┬┐"
"│ ││"
"├─┼┤"
"└─┴┘")))
;; Returns a list of strings representing the rows in the original
;; string.
(define (string->rows str)
(string-split str "\n" #t))
;; Creates procedure that ensures a list has given number of elements
;; filling the missing elements with given filler (defaults to empty
;; string).
(define ((make-list-extender ds . ofl) row)
(let ((fl (if (null? ofl) "" (car ofl))))
(let ((rs (length row)))
(if (< rs ds)
(let loop ((rrow (reverse row))
(rs rs))
(if (eq? rs ds)
(reverse rrow)
(loop (cons fl rrow)
(add1 rs))))
row))))
;; Accepts list of lists and makes sure all rows contain the same
;; number of elements using empty strings as filler.
(define (table-rectangularize tbl)
(let ((mrl (apply max (map length tbl))))
(map (make-list-extender mrl) tbl)))
;; Accepts list of lists of anything and returns a list of lists of
;; strings.
(define (table-stringify tbl)
(map
(lambda (r)
(map (lambda (c) (sprintf "~A" c)) r))
tbl))
;; Converts a 2D table - list of list of strings - into a table of
;; cell lists with cell text lines.
(define (table-prepare-cells tbl)
(map
(lambda (r)
(map string->rows r))
tbl))
;; Accepts a list of cells which are list of strings and returns a
;; new list with all cells having the same number of text lines.
(define (table-normalize-row row)
(let ((ml (apply max (map length row))))
(map (make-list-extender ml) row)))
;; Normalizes the number of text lines in each table row.
(define (table-normalize-rows tbl)
(map table-normalize-row tbl))
;; Returns the maximum width of each column of the table.
(define (table-column-widths tbl)
(if (null? tbl)
'()
(let ((cws (map
(lambda (r)
(list->vector
(map
(lambda (c)
(apply max (map ansi-string-length c)))
r)))
tbl)))
(let loop ((ci (sub1 (vector-length (car cws))))
(rcws '()))
(if (>= ci 0)
(loop (sub1 ci)
(cons (apply max (map (lambda (r) (vector-ref r ci)) cws))
rcws))
rcws)))))
;; Normalizes cell line to required width and handles leading and
;; trailing tabs to allow for right and center alignment.
(define (table-normalize-cell-line line w)
(let* ((lst (string->list line))
(first-char (if (null? lst) #f (car lst)))
(last-char (if (or (null? lst)
(null? (cdr lst)))
#f (car (reverse lst))))
(first-tab (eq? first-char #\tab))
(last-tab (eq? last-char #\tab))
(line0 (if first-tab (substring line 1) line))
(line1 (if last-tab (substring line0 0 (sub1 (string-length line0))) line0))
(len (ansi-string-length line1)))
(if (< len w)
(let* ((miss (- w len))
(do-left-pad first-tab)
(do-right-pad (or (not first-tab) last-tab))
(left-pad-len (if do-left-pad
(if do-right-pad
(- miss (quotient miss 2))
miss)
0))
(right-pad-len (- miss left-pad-len))
(left-pad (make-string left-pad-len #\space))
(right-pad (make-string right-pad-len #\space)))
(string-append left-pad line1 right-pad))
line1)))
;; Pads all lines of this cell to required width
(define (table-normalize-cell c w)
(map (lambda (line)
(table-normalize-cell-line line w))
c))
;; Returns a row (list) of cells (list of strings) with all strings
;; padded to given column width.
(define (table-row-normalize-cells row cwidths)
(let loop ((cwidths cwidths)
(cells row)
(res '()))
(if (null? cells)
(reverse res)
(loop (cdr cwidths)
(cdr cells)
(cons (table-normalize-cell (car cells) (car cwidths))
res)))))
;; Normalizes cells in all rows to match the widths of the wides cell
;; in each column.
(define (table-normalize-columns tbl)
(let ((cwidths (table-column-widths tbl)))
(map (lambda (row)
(table-row-normalize-cells row cwidths))
tbl)))
;; Ensures the table is rectangular and each cell is a list of strings.
(define (table-prepare tbl)
(table-normalize-columns
(table-normalize-rows
(table-prepare-cells
(table-stringify
(table-rectangularize tbl))))))
;; Compiled table borders for rendering
(define table-borders-lookup
(map (lambda (src)
(cons (car src)
(list->vector
(irregex-extract (irregex "." 'u)
(string-intersperse (cdr src) "")))))
table-borders-lookup-source))
;; Accepts a table row - list of list of strings - and returns a list
;; of lines (list of strings).
(define (table-row->lines row left-border cell0-separator cell-separator right-border ansi?)
(if (null? row)
'()
(let yloop ((row row)
(res '()))
(if (null? (car row))
(reverse res)
(yloop (map cdr row)
(cons
(string-append
left-border
(let cloop ((srow (map car row))
(res "")
(idx 0))
(if (null? srow)
res
(cloop (cdr srow)
(string-append res
(case idx
((0) "")
((1) cell0-separator)
(else cell-separator))
(car srow)
(if ansi? (ansi #:default) ""))
(add1 idx))))
right-border)
res))))))
;; Creates table row delimiter based on column widths.
(define (table-row-delimiter cws left line cross0 cross right)
(string-append
left
(let cloop ((cws cws)
(res "")
(idx 0))
(if (null? cws)
res
(cloop (cdr cws)
(string-append res
(case idx
((0) "")
((1) cross0)
(else cross))
(string-repeat line (car cws)))
(add1 idx))))
right))
;; Returns table row delimiter based on column widths, extracting
;; line style from particular row of border style vector.
(define (table-row-delimiter/styled tb cb0 cb cws svec srow)
(define (sref i)
(vector-ref svec (+ i (* srow 4))))
(table-row-delimiter cws
(if tb (sref 0) "")
(sref 1)
(if (or cb cb0) (sref 2) "")
(if cb (sref 2) "")
(if tb (sref 3) "")))
;; Converts given table to a string suitable for printing.
(define (table->string tbl . args)
(let ((table (table-prepare tbl)))
(if (or (null? tbl)
(null? (car tbl)))
""
(let* ((table-border (get-keyword #:table-border args (lambda () #f)))
(row-border (get-keyword #:row-border args (lambda () #f)))
(column-border (get-keyword #:col-border args (lambda () #f)))
(row0-border (get-keyword #:row0-border args (lambda () #f)))
(col0-border (get-keyword #:col0-border args (lambda () #f)))
(border-style (get-keyword #:border-style args (lambda () (*table-border-style*))))
(ansi? (get-keyword #:ansi args (lambda () #f)))
(stylepair (assq border-style table-borders-lookup))
(stylevec
(if stylepair
(cdr stylepair)
(cdar table-borders-lookup)))
(cell-borders (list (if table-border (vector-ref stylevec 4) "")
(if (or column-border col0-border)
(vector-ref stylevec 6) "")
(if column-border (vector-ref stylevec 6) "")
(if table-border (vector-ref stylevec 7) "")
ansi?))
(cws (map (compose ansi-string-length car) (car table))))
(let loop ((rows table)
(res (if table-border
(list (table-row-delimiter/styled table-border
col0-border
column-border
cws
stylevec
0))
'()))
(idx 0))
(if (null? rows)
(let ((res0 (if table-border
(cons (table-row-delimiter/styled table-border
col0-border
column-border
cws
stylevec
3)
res)
res)))
(string-intersperse
(flatten (reverse res0))
"\n"))
(let* ((res0
(if (or (and row-border
(> idx 0))
(and row0-border
(= idx 1)))
(cons (table-row-delimiter/styled table-border
col0-border
column-border
cws
stylevec
2)
res)
res))
(res1
(cons
(apply table-row->lines
(car rows)
cell-borders)
res0)))
(loop (cdr rows)
res1
(add1 idx)))))))))
;; Performs module self-tests
(define (table-tests!)
(run-tests
table
(test-equal? string->rows (string->rows "asdf") '("asdf"))
(test-equal? string->rows (string->rows "asdf\nqwer") '("asdf" "qwer"))
(test-equal? string->rows (string->rows "\nasdf\nqwer") '("" "asdf" "qwer"))
(test-equal? make-list-extender
((make-list-extender 5) '("test"))
'("test" "" "" "" ""))
(test-equal? make-list-extender
((make-list-extender 5 "x") '("test"))
'("test" "x" "x" "x" "x"))
(test-equal? table-rectangularize
(table-rectangularize '(("x" "y" "z") ("a" "b") ("1" "2" "3" "4")))
'(("x" "y" "z" "") ("a" "b" "" "") ("1" "2" "3" "4")))
(test-equal? table-stringify
(table-stringify '((1 2 3) (a b c) ("d")))
'(("1" "2" "3") ("a" "b" "c") ("d")))
(test-equal? table-prepare-cells
(table-prepare-cells '(("x" "y" "z" "") ("a" "b" "" "") ("1" "2" "3" "4")))
'((("x") ("y") ("z") ("")) (("a") ("b") ("") ("")) (("1") ("2") ("3") ("4"))))
(test-equal? table-normalize-row
(table-normalize-row '(("") ("a" "b")))
'(("" "") ("a" "b")))
(test-equal? table-column-widths
(table-column-widths
'((("x") ("y") ("zz") ("")) (("a") ("bcde") ("") ("")) (("123") ("2") ("3") ("4"))))
'(3 4 2 1))
(test-equal? table-normalize-cell
(table-normalize-cell '("a" "bb" "ccc" "") 4)
'("a " "bb " "ccc " " "))
(test-equal? table-row-normalize-cells
(table-row-normalize-cells
'(("a") ("bb") ("ccc") (""))
'(1 2 3 4))
'(("a") ("bb") ("ccc") (" ")))
(test-equal? table-normalize-columns
(table-normalize-columns
'((("a") ("bb") ("ccc") (""))
(("") ("b") ("z") ("x"))))
'((("a") ("bb") ("ccc") (" "))
((" ") ("b ") ("z ") ("x"))))
(test-equal? table-row->lines
(table-row->lines '(("a ") ("bb") ("ccc") (" ")) "]" "|" "|" "[" #f)
'("]a |bb|ccc| ["))
(test-equal? table-row-delimiter
(table-row-delimiter '(1 2 3 1) "/" "-" "+" "+" "\\")
"/-+--+---+-\\")
))
)

116
src/testing.scm Normal file
View file

@ -0,0 +1,116 @@
;;
;; testing.scm
;;
;; Infrastructure for sipmle unit tests.
;;
;; 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 testing))
(module
testing
(
test-eq?
test-equal?
test-exn
test-true
test-false
run-tests
)
(import scheme
(chicken condition)
(chicken format))
;; Evaluates body ... expressions with exception handler installed.
(define-syntax with-handler
(syntax-rules ()
((_ handler body ...)
(call-with-current-continuation
(lambda (k)
(with-exception-handler
(lambda (x) (k (handler x)))
(lambda () body ...)))))))
;; Test passes if the-test does not raise an exception and the result
;; is eq? to expected-result.
(define-syntax test-eq?
(syntax-rules ()
((_ name expression expected-result)
(let ((result expression))
(if (equal? result expected-result)
(display ".")
(error 'test-eq? (sprintf "~A expression=~S expected-result=~S result=~S"
'name 'expression expected-result result)))))))
;; Test passes if the-test does not raise an exception and the result
;; is equal? to expected-result.
(define-syntax test-equal?
(syntax-rules ()
((_ name expression expected-result)
(let ((result expression))
(if (equal? result expected-result)
(display ".")
(error 'test-equal? (sprintf "~A expression=~S expected-result=~S result=~S"
'name 'expression expected-result result)))))))
;; Test passes if the expression evaluates to #t, raises exception
;; otherwise.
(define-syntax test-true
(syntax-rules ()
((_ name expression)
(let ((result expression))
(if (eq? result #t)
(display ".")
(error 'test-true (sprintf "~A expression=~S result=~S"
'name 'expression result)))))))
;; Test passes if the expression evaluates to #f, raises exception
;; otherwise.
(define-syntax test-false
(syntax-rules ()
((_ name expression)
(let ((result expression))
(if (eq? result #f)
(display ".")
(error 'test-true (sprintf "~A expression=~S result=~S"
'name 'expression result)))))))
;; Passes if the-test raises an exception
(define-syntax test-exn
(syntax-rules ()
((_ name the-test)
(if (with-handler (lambda (x) #t)
the-test #f)
(display ".")
(error 'unit-test name)))))
;; Displays test specification, evaluates all body ... expressions
;; and prints "ok." at the and of the line if all succeed.
(define-syntax run-tests
(syntax-rules ()
((_ name body ...)
(let ()
(display (sprintf "[test] ~A " 'name))
body ...
(print " ok.")))))
)

99
src/utils.scm Normal file
View file

@ -0,0 +1,99 @@
;;
;; utils.scm
;;
;; Various utilities so that no external libraries are needed.
;;
;; 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 utils))
(module
utils
(
filter
string-repeat
string-first+rest
utils-tests!
)
(import scheme
(chicken base)
(chicken string)
(chicken irregex)
testing)
;; Returns a list with elements matching pred? predicate.
(define (filter pred? lst)
(let loop ((lst lst)
(res '()))
(if (null? lst)
(reverse res)
(if (pred? (car lst))
(loop (cdr lst)
(cons (car lst) res))
(loop (cdr lst)
res)))))
;; Repeats given string.
(define (string-repeat str rep)
(let loop ((rep rep)
(res '()))
(if (> rep 0)
(loop (sub1 rep)
(cons str res))
(string-intersperse res ""))))
;; Extracts first token and the rest as separate string
(define (string-first+rest str)
(let ((dm (irregex-search (irregex "[ \\t]" 'u) str)))
(if dm
(let* ((sep-idx (irregex-match-start-index dm))
(key-str (substring str 0 sep-idx))
(sep+val (substring str sep-idx))
(val (irregex-replace (irregex "^[ \\t]*" 'u) sep+val "")))
(cons key-str val))
(cons str ""))))
;; Performs utils module self-tests.
(define (utils-tests!)
(run-tests
utils
(test-equal? filter (filter odd? '(1 2 3 4)) '(1 3))
(test-equal? filter (filter odd? '(2 4)) '())
(test-equal? string-repeat
(string-repeat "-" 4)
"----")
(test-equal? string-repeat
(string-repeat "š" 4)
"šššš")
(test-equal? string-first+rest
(string-first+rest "asdf rest")
'("asdf" . "rest"))
(test-equal? string-first+rest
(string-first+rest "asdf rest test rest")
'("asdf" . "rest test rest"))
(test-equal? string-first+rest
(string-first+rest "asdf")
'("asdf" . ""))
))
)