From e68919641ed019f46d41e00018caa76f80d0b578 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Thu, 18 May 2023 11:51:29 +0200 Subject: [PATCH] Add util-dict-bst. --- doc/utils.md | 8 ++ src/Makefile | 10 +- src/tests.scm | 6 +- src/util-dict-bst.scm | 285 ++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 305 insertions(+), 4 deletions(-) create mode 100644 src/util-dict-bst.scm diff --git a/doc/utils.md b/doc/utils.md index 0e16f7a..9a2211e 100644 --- a/doc/utils.md +++ b/doc/utils.md @@ -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) diff --git a/src/Makefile b/src/Makefile index 9f791b9..b3ebf6c 100644 --- a/src/Makefile +++ b/src/Makefile @@ -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) diff --git a/src/tests.scm b/src/tests.scm index e2a65f4..335d79d 100644 --- a/src/tests.scm +++ b/src/tests.scm @@ -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!)) ) diff --git a/src/util-dict-bst.scm b/src/util-dict-bst.scm new file mode 100644 index 0000000..d7543bd --- /dev/null +++ b/src/util-dict-bst.scm @@ -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 +;; +;; 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)) + )) + + )