Add util-dict-bst.

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)

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)

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!))
 
  )

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 <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))
+    ))
+
+ )