From 5edd85474d6d8f3a0cc06cc0250ed3db8b26fcfa Mon Sep 17 00:00:00 2001
From: Vladimir Azarov <avm@intermediate-node.net>
Date: Sat, 17 May 2025 14:45:50 +0200
Subject: Function-like macros

---
 tree.sml | 75 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 75 insertions(+)
 create mode 100644 tree.sml

(limited to 'tree.sml')

diff --git a/tree.sml b/tree.sml
new file mode 100644
index 0000000..597e469
--- /dev/null
+++ b/tree.sml
@@ -0,0 +1,75 @@
+structure Tree: TREE = struct
+  datatype ('k, 'v) t = Node of 'k * 'v * ('k, 'v) t * ('k, 'v) t | Empty
+
+  exception Exists
+
+  val empty = Empty
+
+  fun insert _ Empty k v = Node (k, v, Empty, Empty)
+    | insert cmp (Node (k', v', left, right)) k v =
+        case cmp k k' of
+          LESS => Node (k', v', insert cmp left k v, right)
+        | EQUAL => raise Exists
+        | GREATER => Node (k', v', left, insert cmp right k v)
+
+  fun lookup _ Empty _ = NONE
+    | lookup cmp (Node (k', v', left, right)) k =
+        case cmp k k' of
+          LESS => lookup cmp left k
+        | EQUAL => SOME v'
+        | GREATER => lookup cmp right k
+
+  datatype ('k, 'v) arc =
+    Left of 'k * 'v * ('k, 'v) t |
+    Right of 'k * 'v * ('k, 'v) t
+
+  fun assemble n buf =
+  let
+    fun assemble' tree (Left (k, v, right) :: tail) =
+      assemble' (Node (k, v, tree, right)) tail
+      | assemble' tree (Right (k, v, left) :: tail) =
+      assemble' (Node (k, v, left, tree)) tail
+      | assemble' tree [] = tree
+  in
+    assemble' n buf
+  end
+
+  fun lookup' _ _ Empty _ _ g = (g, NONE)
+    | lookup' buf cmp (Node (k', v', left, right)) k f g =
+        case cmp k k' of
+          LESS => lookup' (Left (k', v', right) :: buf) cmp left k f g
+        | GREATER => lookup' (Right (k', v', left) :: buf) cmp right k f g
+        | EQUAL =>
+        let
+          val (newV, result) = f v'
+        in
+          case newV of
+               NONE => (result, NONE)
+             | SOME v => (result, SOME (assemble (Node (k', v, left, right)) buf))
+        end
+
+  fun lookup2 cmp t k (f, g) =
+  let
+    val (result, newTree) = lookup' [] cmp t k f g
+  in
+    (result, case newTree of
+         NONE => t
+       | SOME t => t)
+  end
+
+  fun print t key2str value2str =
+  let
+    fun Pkey z = bindWith2str key2str z
+    fun Pvalue z = bindWith2str value2str z
+
+    fun print' off Empty = printf R off `"()\n" %
+      | print' off (Node (k, v, left, right)) = (
+        printf R off `"(" Pkey k `", " Pvalue v `"\n";
+        print' (off + 1) left;
+        print' (off + 1) right;
+        printf R off `")\n" %
+      )
+  in
+    print' 0 t
+  end
+end
-- 
cgit v1.2.3