From c234f883bdefaf32320ae27b334b391c9633f6dd Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?=
 <dominik.pantucek@trustica.cz>
Date: Fri, 7 Jul 2023 10:19:43 +0200
Subject: [PATCH] Work on functional updates.

---
 src/Makefile          |  2 +-
 src/mbase.scm         |  2 +-
 src/util-bst-dict.scm |  3 +++
 src/util-bst.scm      | 24 +++++++++++++++++++++++-
 4 files changed, 28 insertions(+), 3 deletions(-)

diff --git a/src/Makefile b/src/Makefile
index ffa409d..319866d 100644
--- a/src/Makefile
+++ b/src/Makefile
@@ -155,7 +155,7 @@ MBASE-SOURCES=mbase.scm testing.import.scm util-dict-list.import.scm	\
 	 cal-period.import.scm cal-month.import.scm			\
 	 configuration.import.scm progress.import.scm			\
 	 mbase-dir.import.scm util-tag.import.scm			\
-	 racket-kwargs.import.scm util-dict-bst.import.scm		\
+	 racket-kwargs.import.scm util-bst-dict.import.scm		\
 	 util-list.import.scm
 
 mbase.o: mbase.import.scm
diff --git a/src/mbase.scm b/src/mbase.scm
index e2daa1d..07685f3 100644
--- a/src/mbase.scm
+++ b/src/mbase.scm
@@ -82,7 +82,7 @@
 	 mbase-dir
 	 util-tag
 	 racket-kwargs
-	 util-dict-bst)
+	 util-bst-dict)
 
  ;; Constant unique tag
  (define TAG-MBASE (make-tag mbase))
diff --git a/src/util-bst-dict.scm b/src/util-bst-dict.scm
index aa82d9a..33a7241 100644
--- a/src/util-bst-dict.scm
+++ b/src/util-bst-dict.scm
@@ -14,6 +14,7 @@
   bdict-keys
   bdict-map-list
   bdict-map-dict
+  bdict-update
   )
 
  (import scheme
@@ -39,4 +40,6 @@
 
  (define bdict-map-dict bst-map-bst)
 
+ (define bdict-update bst-update)
+
  )
diff --git a/src/util-bst.scm b/src/util-bst.scm
index b63550b..f8a33ca 100644
--- a/src/util-bst.scm
+++ b/src/util-bst.scm
@@ -34,6 +34,8 @@
 
   list->bst
 
+  bst-update
+
   util-bst-tests!
   )
 
@@ -41,7 +43,8 @@
 	 (chicken condition)
 	 (chicken sort)
 	 util-tag
-	 testing)
+	 testing
+	 racket-kwargs)
 
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; Node
@@ -348,6 +351,25 @@
 		(cons subtag
 		      (cons EQ? <?))))))
 
+ (define*/doc (bst-update bst k proc (v #f))
+   ("")
+   (let-comparators
+    (EQ? <? bst)
+    (let-values	(((new-root add-count)
+		  (let loop ((n (bst-root bst)))
+		    (if n
+			(let ((nk (bst-node-key n)))
+			  (if (EQ? k nk)
+			      (values (set-bst-node-value n (proc (bst-node-value n)))
+				      0)
+			      (if (<? k nk)
+				  (loop (bst-node-left n))
+				  (loop (bst-node-right n)))))
+			(values (make-bst-node k (proc v)) 1)))))
+      (set-bst-root+count bst
+			  new-root
+			  (+ (bst-count bst) add-count)))))
+
  ;; Module self-tests
  (define (util-bst-tests!)
    (run-tests