Use the new BST dictionary for indexing members.

This commit is contained in:
Dominik Pantůček 2023-05-18 14:53:22 +02:00
parent 209ef27a90
commit bebb8af611
4 changed files with 71 additions and 40 deletions

View file

@ -125,7 +125,8 @@ MBASE-SOURCES=mbase.scm testing.import.scm util-dict-list.import.scm \
cal-period.import.scm cal-month.import.scm \ cal-period.import.scm cal-month.import.scm \
configuration.import.scm progress.import.scm \ configuration.import.scm progress.import.scm \
table.import.scm mbase-dir.import.scm util-list.import.scm \ table.import.scm mbase-dir.import.scm util-list.import.scm \
util-tag.import.scm util-kwargs.import.scm util-tag.import.scm util-kwargs.import.scm \
util-dict-bst.import.scm
mbase.o: mbase.import.scm mbase.o: mbase.import.scm
mbase.import.scm: $(MBASE-SOURCES) mbase.import.scm: $(MBASE-SOURCES)

View file

@ -49,6 +49,7 @@
mbase-free-ids mbase-free-ids
mbase-gen-id mbase-gen-id
mbase-update-by-id
mbase-update mbase-update
mbase-info mbase-info
@ -79,7 +80,8 @@
progress progress
mbase-dir mbase-dir
util-tag util-tag
util-kwargs) util-kwargs
util-dict-bst)
;; Constant unique tag ;; Constant unique tag
(define TAG-MBASE (make-tag mbase)) (define TAG-MBASE (make-tag mbase))
@ -111,35 +113,31 @@
mb0)) mb0))
(mb (ldict-reduce '() (mb (ldict-reduce '()
(lambda (acc id mr) (lambda (acc id mr)
(cons mr acc)) (cons (cons id mr) acc))
mb1))) mb1)))
mb))))))) (list->bdict (sort mb (lambda (a b) (< (car a) (car b))))))))))))
;; Predicate ;; Predicate
(define (mbase? v) (define (mbase? v)
(and (ldict? v) (and (ldict? v)
(eq? (ldict-ref v 'TAG #f) TAG-MBASE))) (eq? (ldict-ref v 'TAG #f) TAG-MBASE)))
;; Returns the internal members list ;; Returns the internal members BST
(define (mbase-members mb) (define (mbase-members mb)
(ldict-ref mb 'members)) (ldict-ref mb 'members))
;; Gets member based by generic predicate ;; Gets member based by generic predicate
(define (find-member-by-predicate mb pred) (define (find-member-by-predicate mb pred?)
(let loop ((mdb (mbase-members mb))) (bdict-find-value
(if (null? mdb) (mbase-members mb)
#f (lambda (k v)
(let ((mr (car mdb))) (pred? v))))
(if (pred mr)
mr
(loop (cdr mdb)))))))
;; Returns member record found by id ;; Returns member record found by id, accepts numeric id or #f
(define (find-member-by-id mb id) (define (find-member-by-id mb id)
(find-member-by-predicate (if id
mb (bdict-ref (mbase-members mb) id #f)
(lambda (mr) #f))
(eq? (ldict-ref mr 'id) id))))
;; Returns member record found by id ;; Returns member record found by id
(define (find-member-by-nick mb nick) (define (find-member-by-nick mb nick)
@ -153,16 +151,11 @@
nick)))) nick))))
;; Returns a list of members which match given predicate. ;; Returns a list of members which match given predicate.
(define (find-members-by-predicate mb pred) (define (find-members-by-predicate mb pred?)
(let loop ((mb (mbase-members mb)) (bdict-filter-values
(res '())) (mbase-members mb)
(if (null? mb) (lambda (k v)
res (pred? v))))
(let ((mr (car mb)))
(loop (cdr mb)
(if (pred mr)
(cons mr res)
res))))))
;; Returns a list of members whose nick contains pat ;; Returns a list of members whose nick contains pat
(define (find-members-by-nick mb pat) (define (find-members-by-nick mb pat)
@ -173,13 +166,13 @@
;; Returns all ids found in the database ;; Returns all ids found in the database
(define (list-mbase-ids mb) (define (list-mbase-ids mb)
(map (lambda (mr) (ldict-ref mr 'id)) (bdict-keys (mbase-members mb)))
(mbase-members mb)))
;; Returns all nicks found in the database ;; Returns all nicks found in the database
(define (list-mbase-nicks mb) (define (list-mbase-nicks mb)
(map brmember-nick (bdict-map-list (mbase-members mb)
(mbase-members mb))) (lambda (id mr)
(brmember-nick mr))))
;; Returns all free ids ;; Returns all free ids
(define (mbase-free-ids mb) (define (mbase-free-ids mb)
@ -195,16 +188,23 @@
(vfids (list->vector fids))) (vfids (list->vector fids)))
(vector-ref vfids (pseudo-random-integer (vector-length vfids))))) (vector-ref vfids (pseudo-random-integer (vector-length vfids)))))
;; Returns new members base with member specified by id processed by
;; proc.
(define (mbase-update-by-id mb id proc)
(ldict-set mb
'members
(bdict-update (mbase-members mb) id proc)))
;; Returns new members base with member records matching the ;; Returns new members base with member records matching the
;; predicate processed by proc. ;; predicate processed by proc.
(define (mbase-update mb pred? proc) (define (mbase-update mb pred? proc)
(ldict-set mb (ldict-set mb
'members 'members
(map (lambda (mr) (bdict-map-dict (mbase-members mb)
(if (pred? mr) (lambda (id mr)
(proc mr) (if (pred? mr)
mr)) (proc mr)
(mbase-members mb)))) mr)))))
;; Returns dictionary with statistics about the members base. ;; Returns dictionary with statistics about the members base.
(define (mbase-info mb-arg) (define (mbase-info mb-arg)

View file

@ -98,10 +98,9 @@
(varsym-id (transaction-extract-member-id transaction)) (varsym-id (transaction-extract-member-id transaction))
(bmember (find-member-by-id mb varsym-id))) (bmember (find-member-by-id mb varsym-id)))
(loop (if bmember (loop (if bmember
(mbase-update (mbase-update-by-id
mb mb
(lambda (mr) varsym-id
(compare-member-id (brmember-id mr) varsym-id))
(lambda (mr) (lambda (mr)
(brmember-add-payment mr transaction))) (brmember-add-payment mr transaction)))
(if (and (or (not last-checked) (if (and (or (not last-checked)

View file

@ -55,6 +55,11 @@
bdict-filter-pairs bdict-filter-pairs
bdict-filter-keys bdict-filter-keys
bdict-filter-values bdict-filter-values
list->bdict
bdict-map-list
bdict-map-dict
bdict-tests! bdict-tests!
) )
@ -307,6 +312,32 @@
a))) a)))
d)) d))
;; Converts list of pairs into BST dictionary
(define (list->bdict l)
(vector->bdict
(apply vector l)))
;; Returns arbitrary list created by mapping all elements
(define (bdict-map-list d p)
(reverse
(bdict-reduce
'()
(lambda (a k v)
(cons (p k v) a))
d)))
;; Returns new dictionary with all values processed (keys are left
;; intact)
(define (bdict-map-dict d p)
(set-bdict-root
d
(let loop ((n (bdict-root d)))
(if n
(cons (cons (caar n) (p (caar n) (cdar n)))
(cons (loop (cadr n))
(loop (cddr n))))
#f))))
;; Performs module self-tests ;; Performs module self-tests
(define (bdict-tests!) (define (bdict-tests!)
(run-tests (run-tests