Remove old bdict implementation.
This commit is contained in:
parent
276e60b883
commit
2fe483c947
3 changed files with 7 additions and 472 deletions
16
src/Makefile
16
src/Makefile
|
|
@ -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 \
|
||||
notifications.o util-format.o brmember-format.o logging.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 \
|
||||
util-utf8.o sgr-cell.o template-list-expander.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 \
|
||||
util-set-list.import.scm util-parser.import.scm \
|
||||
util-string.import.scm cal-day.import.scm \
|
||||
util-dict-bst.import.scm util-utf8.import.scm \
|
||||
sgr-state.import.scm sgr-list.import.scm sgr-block.import.scm \
|
||||
template-list-expander.import.scm table-style.import.scm \
|
||||
box-drawing.import.scm
|
||||
util-utf8.import.scm sgr-state.import.scm sgr-list.import.scm \
|
||||
sgr-block.import.scm template-list-expander.import.scm \
|
||||
table-style.import.scm box-drawing.import.scm \
|
||||
util-bst.import.scm
|
||||
|
||||
tests.o: tests.import.scm
|
||||
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.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.o: racket-kwargs.import.scm
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@
|
|||
util-set-list
|
||||
util-parser
|
||||
util-string
|
||||
util-dict-bst
|
||||
util-bst
|
||||
util-utf8
|
||||
sgr-state
|
||||
sgr-list
|
||||
|
|
@ -59,7 +59,7 @@
|
|||
(listing-tests!)
|
||||
(lset-tests!)
|
||||
(ldict-tests!)
|
||||
(bdict-tests!)
|
||||
(util-bst-tests!)
|
||||
(cal-month-tests!)
|
||||
(cal-period-tests!)
|
||||
(cal-day-tests!)
|
||||
|
|
|
|||
|
|
@ -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"))
|
||||
))
|
||||
|
||||
)
|
||||
Loading…
Add table
Add a link
Reference in a new issue