Remove old bdict implementation.

This commit is contained in:
Dominik Pantůček 2023-07-07 11:01:27 +02:00
parent 276e60b883
commit 2fe483c947
3 changed files with 7 additions and 472 deletions

View file

@ -51,7 +51,7 @@ HACKERBASE-OBJS=hackerbase.o testing.o listing.o cal-month.o \
util-parser.o texts.o tests.o util-proc.o util-mail.o \ util-parser.o texts.o tests.o util-proc.o util-mail.o \
notifications.o util-format.o brmember-format.o logging.o \ notifications.o util-format.o brmember-format.o logging.o \
specification.o util-git.o cal-day.o util-stdout.o \ specification.o util-git.o cal-day.o util-stdout.o \
cal-format.o util-dict-bst.o table.o sgr-list.o sgr-block.o \ cal-format.o table.o sgr-list.o sgr-block.o \
table-processor.o table-border.o table-style.o sgr-state.o \ table-processor.o table-border.o table-style.o sgr-state.o \
util-utf8.o sgr-cell.o template-list-expander.o \ util-utf8.o sgr-cell.o template-list-expander.o \
box-drawing.o util-list.o export-web-static.o util-dir.o \ box-drawing.o util-list.o export-web-static.o util-dir.o \
@ -317,10 +317,10 @@ TESTS-SOURCES=tests.scm listing.import.scm util-dict-list.import.scm \
primes.import.scm brmember.import.scm util-csv.import.scm \ primes.import.scm brmember.import.scm util-csv.import.scm \
util-set-list.import.scm util-parser.import.scm \ util-set-list.import.scm util-parser.import.scm \
util-string.import.scm cal-day.import.scm \ util-string.import.scm cal-day.import.scm \
util-dict-bst.import.scm util-utf8.import.scm \ util-utf8.import.scm sgr-state.import.scm sgr-list.import.scm \
sgr-state.import.scm sgr-list.import.scm sgr-block.import.scm \ sgr-block.import.scm template-list-expander.import.scm \
template-list-expander.import.scm table-style.import.scm \ table-style.import.scm box-drawing.import.scm \
box-drawing.import.scm util-bst.import.scm
tests.o: tests.import.scm tests.o: tests.import.scm
tests.import.scm: $(TESTS-SOURCES) tests.import.scm: $(TESTS-SOURCES)
@ -405,12 +405,6 @@ CAL-FORMAT-SOURCES=cal-format.scm cal-day.import.scm cal-month.import.scm
cal-format.o: cal-format.import.scm cal-format.o: cal-format.import.scm
cal-format.import.scm: $(CAL-FORMAT-SOURCES) cal-format.import.scm: $(CAL-FORMAT-SOURCES)
UTIL-DICT-BST-SOURCES=util-dict-bst.scm util-tag.import.scm \
testing.import.scm
util-dict-bst.o: util-dict-bst.import.scm
util-dict-bst.import.scm: $(UTIL-DICT-BST-SOURCES)
RACKET-KWARGS-SOURCES=racket-kwargs.scm RACKET-KWARGS-SOURCES=racket-kwargs.scm
racket-kwargs.o: racket-kwargs.import.scm racket-kwargs.o: racket-kwargs.import.scm

View file

@ -46,7 +46,7 @@
util-set-list util-set-list
util-parser util-parser
util-string util-string
util-dict-bst util-bst
util-utf8 util-utf8
sgr-state sgr-state
sgr-list sgr-list
@ -59,7 +59,7 @@
(listing-tests!) (listing-tests!)
(lset-tests!) (lset-tests!)
(ldict-tests!) (ldict-tests!)
(bdict-tests!) (util-bst-tests!)
(cal-month-tests!) (cal-month-tests!)
(cal-period-tests!) (cal-period-tests!)
(cal-day-tests!) (cal-day-tests!)

View file

@ -1,459 +0,0 @@
;;
;; util-dict-bst.scm
;;
;; Simple dictionary implementation using BST backend. Only numbers
;; supported as keys.
;;
;; 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 util-dict-bst))
(module
util-dict-bst
(
make-bdict
bdict?
bdict-empty?
bdict-contains?
bdict-ref
bdict-set
bdict-remove
bdict-update
bdict-find-pair
bdict-find-value
bdict-find-key
bdict-reduce
bdict-keys
bdict-values
bdict-balance
bdict-filter-pairs
bdict-filter-keys
bdict-filter-values
list->bdict
bdict-map-list
bdict-map-dict
bdict-tests!
)
(import scheme
(chicken base)
util-tag
testing)
;; Unique tag
(define TAG-BDICT (make-tag dict-bst))
;; Creates BST node with no children
(define (make-bst-node key value)
(cons (cons key value)
(cons #f #f)))
;; Read-only accessors to BST node
(define bst-node-key caar)
(define bst-node-value cdar)
(define bst-node-left cadr)
(define bst-node-right cddr)
;; Returns BST node with updated node value
(define (set-bst-node-value n v)
(cons (cons (bst-node-key n) v)
(cdr n)))
;; Updates BST node left child
(define (set-bst-node-left n l)
(cons (car n)
(cons l (bst-node-right n))))
;; Updates BST node right child
(define (set-bst-node-right n r)
(cons (car n)
(cons (bst-node-left n) r)))
;; Creates empty BST dictionary
(define (make-bdict)
(cons TAG-BDICT #f))
;; Accessor for root
(define bdict-root cdr)
;; Updates BST dictionary root node
(define (set-bdict-root d r)
(cons (car d) r))
;; Checks whether given value is BST dictionary
(define (bdict? v)
(and (pair? v)
(eq? (car v) TAG-BDICT)))
;; Returns true if given dictionary is empty
(define (bdict-empty? d)
(and (bdict? d)
(not (bdict-root d))))
;; Returns true if dictionary contains given key
(define (bdict-contains? d k)
(let loop ((n (bdict-root d)))
(if n
(let ((nk (bst-node-key n)))
(if (eq? k nk)
#t
(loop (if (< k nk)
(bst-node-left n)
(bst-node-right n)))))
#f)))
;; Returns the value associated with given key
(define (bdict-ref d k . vs)
(let loop ((n (bdict-root d)))
(if n
(let ((nk (bst-node-key n)))
(if (eq? k nk)
(bst-node-value n)
(loop (if (< k nk)
(bst-node-left n)
(bst-node-right n)))))
(if (null? vs)
(error 'bdict-ref "Key does not exist" k)
(car vs)))))
;; Returns a dictionary with given key set to given value
(define (bdict-set d k v)
(set-bdict-root
d
(let loop ((n (bdict-root d)))
(if n
(let ((nk (bst-node-key n)))
(if (eq? k nk)
(set-bst-node-value n v)
(if (< k nk)
(set-bst-node-left n (loop (bst-node-left n)))
(set-bst-node-right n (loop (bst-node-right n))))))
(make-bst-node k v)))))
;; Functional update with optional default value (defaults to #f)
(define (bdict-update d k p . vs)
(let ((v (if (null? vs)
#f
(car vs))))
(set-bdict-root
d
(let loop ((n (bdict-root d)))
(if n
(let ((nk (bst-node-key n)))
(if (eq? k nk)
(set-bst-node-value n (p (bst-node-value n)))
(if (< k nk)
(set-bst-node-left n (loop (bst-node-left n)))
(set-bst-node-right n (loop (bst-node-right n))))))
(make-bst-node k (p v)))))))
;; Finds key-value pair based on predicate - linear search from left
;; to right
(define (bdict-find-pair d p?)
(let loop ((n (bdict-root d)))
(if n
(let ((l (loop (bst-node-left n))))
(or l
(if (p? (bst-node-key n) (bst-node-value n))
(car n)
(loop (bst-node-right n)))))
#f)))
;; Finds value based on predicate
(define (bdict-find-value d p?)
(let ((p (bdict-find-pair d p?)))
(if p
(cdr p)
#f)))
;; Finds key based on predicate
(define (bdict-find-key d p?)
(let ((p (bdict-find-pair d p?)))
(if p
(car p)
#f)))
;; Returns a dictionary with given key removed, if last argument is
;; #t, allows "removing" non-existent keys
(define (bdict-remove d k . nos)
(let ((new-root
(let loop ((n (bdict-root d)))
(if n
(let ((nk (bst-node-key n)))
(if (eq? nk k)
(if (bst-node-left n)
(if (bst-node-right n)
(let aloop ((an (bst-node-right n)))
(if an
(set-bst-node-left an
(aloop (bst-node-left an)))
(bst-node-left n)))
(bst-node-left n))
(if (bst-node-right n)
(bst-node-right n)
#f))
(if (< k nk)
(set-bst-node-left n (loop (bst-node-left n)))
(set-bst-node-right n (loop (bst-node-right n))))))
(if (and (not (null? nos))
(car nos))
#f
(error 'bdict-remove "Key does not exist" k))))))
(if new-root
(set-bdict-root d new-root)
d)))
;; Reduce over key-value pairs
(define (bdict-reduce init proc bd)
(let loop ((n (bdict-root bd))
(acc init))
(if n
(loop (bst-node-right n)
(proc (loop (bst-node-left n) acc)
(bst-node-key n) (bst-node-value n)))
acc)))
;; Returns all the keys contained in given dictionary
(define (bdict-keys d)
(reverse
(bdict-reduce '() (lambda (a k v) (cons k a)) d)))
;; Returns only values
(define (bdict-values d)
(reverse
(bdict-reduce '() (lambda (a k v) (cons v a)) d)))
;; Converts to vector of key-value cons cells
(define (bdict->vector d)
(apply
vector
(reverse
(bdict-reduce '() (lambda (a k v) (cons (cons k v) a)) d))))
;; Converts a vector of key-value cons cells to BST dictionary
(define (vector->bdict v)
(cons
TAG-BDICT
(let loop ((s 0)
(e (vector-length v)))
(if (= s e)
#f
(let* ((c (- e s))
(h (quotient c 2))
(m (+ s h))
(kv (vector-ref v m)))
(cons kv
(cons (loop s m)
(loop (add1 m) e))))))))
;; Returns optimally-balanced version of given dictionary
(define (bdict-balance d)
(vector->bdict
(bdict->vector d)))
;; Returns a list of key-value pairs matching predicate
(define (bdict-filter-pairs d p)
(bdict-reduce
'()
(lambda (a k v)
(let ((e (p k v)))
(if e
(cons (cons k v) a)
a)))
d))
;; Returns a list of keys pairs matching predicate
(define (bdict-filter-keys d p)
(bdict-reduce
'()
(lambda (a k v)
(let ((e (p k v)))
(if e
(cons k a)
a)))
d))
;; Returns a list of keys pairs matching predicate
(define (bdict-filter-values d p)
(bdict-reduce
'()
(lambda (a k v)
(let ((e (p k v)))
(if e
(cons v a)
a)))
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
(define (bdict-tests!)
(run-tests
bdict
(test-equal? make-bdict (make-bdict) `(,TAG-BDICT . #f))
(test-true bdict-empty?
(bdict-empty? (make-bdict)))
(test-false bdict-set/bdict-empty?
(bdict-empty?
(bdict-set
(make-bdict)
1 "Hello")))
(test-true bdict-set/bdict-contains?
(bdict-contains?
(bdict-set
(make-bdict)
1 "Hello")
1))
(test-false bdict-set/bdict-contains?
(bdict-contains?
(bdict-set
(make-bdict)
1 "Hello")
2))
(test-true bdict-set/bdict-contains?
(bdict-contains?
(bdict-set
(bdict-set
(make-bdict)
1 "Hello")
2 "World")
1))
(test-equal? bdict-keys
(bdict-keys
(bdict-set
(bdict-set
(bdict-set
(make-bdict)
23 "Hello")
666 "World")
7 "BST"))
'(7 23 666))
(test-false bdict-remove
(bdict-contains?
(bdict-remove
(bdict-set
(bdict-set
(bdict-set
(make-bdict)
23 "Hello")
666 "World")
7 "BST")
23)
23))
(test-equal? bdict-balance
(bdict-keys
(bdict-balance
(bdict-set
(bdict-set
(bdict-set
(make-bdict)
1 "Hello")
2 "World")
3 "BST")))
'(1 2 3))
(test-equal? bdict-values
(bdict-values
(bdict-balance
(bdict-set
(bdict-set
(bdict-set
(make-bdict)
1 "Hello")
2 "World")
3 "BST")))
'("Hello" "World" "BST"))
(test-exn bdict-ref
(bdict-ref (make-bdict) 1))
(test-equal? bdict-ref
(bdict-ref
(bdict-set
(bdict-set
(bdict-set
(make-bdict)
1 "Hello")
2 "World")
3 "BST")
2)
"World")
(test-equal? bdict-update
(bdict-ref
(bdict-update
(bdict-set
(bdict-set
(bdict-set
(make-bdict)
1 "Hello")
2 "World")
3 "BST")
2
(lambda (v)
"Scheme"))
2)
"Scheme")
(test-equal? bdict-find-pair
(bdict-find-pair
(bdict-set
(bdict-set
(bdict-set
(make-bdict)
1 "Hello")
2 "World")
3 "BST")
(lambda (k v)
(equal? v "World")))
(cons 2 "World"))
))
)