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

Add util-dict-bst.

Browse source
This commit is contained in:
Dominik Pantůček 2023-05-18 11:51:29 +02:00
parent 2514e93ce3
commit e68919641e
4 changed files with 305 additions and 4 deletions
Download patch file Download diff file Expand all files Collapse all files

8
doc/utils.md
View file

@ -229,6 +229,10 @@ Executes given command ```cmd``` with given argument list ```args```
writing all ```lines``` to its standard input and then reads all the
process output.
### Keyword Arguments
TODO
### List
(import util-list)
@ -443,6 +447,10 @@ Returns a new lset instance from ```ls1``` with all elements in
Returns true if the sets contain exactly the same values.
### Stdout
TODO
### String
(import util-string)

10
src/Makefile
View file

@ -52,7 +52,7 @@ HACKERBASE-OBJS=hackerbase.o testing.o listing.o cal-month.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-kwargs.o
util-kwargs.o util-dict-bst.o
.PHONY: imports
imports: $(HACKERBASE-DEPS)
@ -305,7 +305,7 @@ TESTS-SOURCES=tests.scm listing.import.scm util-dict-list.import.scm \
mbase-dir.import.scm primes.import.scm brmember.import.scm \
table.import.scm util-csv.import.scm util-set-list.import.scm \
util-parser.import.scm util-string.import.scm \
cal-day.import.scm
cal-day.import.scm util-dict-bst.import.scm
tests.o: tests.import.scm
tests.import.scm: $(TESTS-SOURCES)
@ -393,3 +393,9 @@ UTIL-KWARGS-SOURCES=util-kwargs.scm
util-kwargs.o: util-kwargs.import.scm
util-kwargs.import.scm: $(UTIL-KWARGS-SOURCES)
UTIL-DICT-BST-SOURCES=util-dict.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)

6
src/tests.scm
View file

@ -47,7 +47,8 @@
util-csv
util-set-list
util-parser
util-string)
util-string
util-dict-bst)
(define (run-all-tests!)
(listing-tests!)
@ -65,6 +66,7 @@
(csv-simple-tests!)
(lset-tests!)
(parser-tests!)
(string-tests!))
(string-tests!)
(bdict-tests!))
)

285
src/util-dict-bst.scm Normal file
View file

@ -0,0 +1,285 @@
;;
;; 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-reduce
bdict-keys
bdict-values
bdict-balance
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 . lrs)
(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? n 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)))))
;; 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 (loop (bst-node-left n)))
(set-bst-node-right (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)))
;; Performs module self-tests
(define (bdict-tests!)
(run-tests
bdict
(test-equal? make-bdict (make-bdict) `(,TAG-BDICT . #f))
(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))
))
)