Move sources to separate directory.
This commit is contained in:
parent
aa7a340d51
commit
69d0b8ee10
25 changed files with 0 additions and 0 deletions
200
src/members-base.scm
Normal file
200
src/members-base.scm
Normal 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))
|
||||
|
||||
)
|
Loading…
Add table
Add a link
Reference in a new issue