haskell: Phase 11 — Data.Map BST skeleton (Adams weight-balanced)

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>

lib/haskell/map.sx

@@ -0,0 +1,134 @@
+;; map.sx — Phase 11 Data.Map: weight-balanced BST in pure SX.
+;;
+;; Algorithm: Adams's weight-balanced tree (the same family as Haskell's
+;; Data.Map). Each node tracks its size; rotations maintain the invariant
+;;
+;;     size(small-side) * delta >= size(large-side)        (delta = 3)
+;;
+;; with single or double rotations chosen by the gamma ratio (gamma = 2).
+;; The size field is an Int and is included so `size`, `lookup`, etc. are
+;; O(log n) on both extremes of the tree.
+;;
+;; Representation:
+;;   Empty → ("Map-Empty")
+;;   Node  → ("Map-Node" key val left right size)
+;;
+;; All operations are pure SX — no mutation of nodes once constructed.
+;; The user-facing Haskell layer (Phase 11 next iteration) wraps these
+;; for `import Data.Map as Map`.
+
+;; ── Constructors ────────────────────────────────────────────
+(define hk-map-empty (list "Map-Empty"))
+
+(define
+  hk-map-node
+  (fn
+    (k v l r)
+    (list "Map-Node" k v l r (+ 1 (+ (hk-map-size l) (hk-map-size r))))))
+
+;; ── Predicates and accessors ────────────────────────────────
+(define hk-map-empty? (fn (m) (and (list? m) (= (first m) "Map-Empty"))))
+
+(define hk-map-node? (fn (m) (and (list? m) (= (first m) "Map-Node"))))
+
+(define
+  hk-map-size
+  (fn (m) (cond ((hk-map-empty? m) 0) (:else (nth m 5)))))
+
+(define hk-map-key (fn (m) (nth m 1)))
+(define hk-map-val (fn (m) (nth m 2)))
+(define hk-map-left (fn (m) (nth m 3)))
+(define hk-map-right (fn (m) (nth m 4)))
+
+;; ── Weight-balanced rotations ───────────────────────────────
+;; delta and gamma per Adams 1992 / Haskell Data.Map.
+
+(define hk-map-delta 3)
+(define hk-map-gamma 2)
+
+(define
+  hk-map-single-l
+  (fn
+    (k v l r)
+    (let
+      ((rk (hk-map-key r))
+        (rv (hk-map-val r))
+        (rl (hk-map-left r))
+        (rr (hk-map-right r)))
+      (hk-map-node rk rv (hk-map-node k v l rl) rr))))
+
+(define
+  hk-map-single-r
+  (fn
+    (k v l r)
+    (let
+      ((lk (hk-map-key l))
+        (lv (hk-map-val l))
+        (ll (hk-map-left l))
+        (lr (hk-map-right l)))
+      (hk-map-node lk lv ll (hk-map-node k v lr r)))))
+
+(define
+  hk-map-double-l
+  (fn
+    (k v l r)
+    (let
+      ((rk (hk-map-key r))
+        (rv (hk-map-val r))
+        (rl (hk-map-left r))
+        (rr (hk-map-right r))
+        (rlk (hk-map-key (hk-map-left r)))
+        (rlv (hk-map-val (hk-map-left r)))
+        (rll (hk-map-left (hk-map-left r)))
+        (rlr (hk-map-right (hk-map-left r))))
+      (hk-map-node
+        rlk
+        rlv
+        (hk-map-node k v l rll)
+        (hk-map-node rk rv rlr rr)))))
+
+(define
+  hk-map-double-r
+  (fn
+    (k v l r)
+    (let
+      ((lk (hk-map-key l))
+        (lv (hk-map-val l))
+        (ll (hk-map-left l))
+        (lr (hk-map-right l))
+        (lrk (hk-map-key (hk-map-right l)))
+        (lrv (hk-map-val (hk-map-right l)))
+        (lrl (hk-map-left (hk-map-right l)))
+        (lrr (hk-map-right (hk-map-right l))))
+      (hk-map-node
+        lrk
+        lrv
+        (hk-map-node lk lv ll lrl)
+        (hk-map-node k v lrr r)))))
+
+;; ── Balanced node constructor ──────────────────────────────
+;; Use this in place of hk-map-node when one side may have grown
+;; or shrunk by one and we need to restore the weight invariant.
+(define
+  hk-map-balance
+  (fn
+    (k v l r)
+    (let
+      ((sl (hk-map-size l)) (sr (hk-map-size r)))
+      (cond
+        ((<= (+ sl sr) 1) (hk-map-node k v l r))
+        ((> sr (* hk-map-delta sl))
+          (let
+            ((rl (hk-map-left r)) (rr (hk-map-right r)))
+            (cond
+              ((< (hk-map-size rl) (* hk-map-gamma (hk-map-size rr)))
+                (hk-map-single-l k v l r))
+              (:else (hk-map-double-l k v l r)))))
+        ((> sl (* hk-map-delta sr))
+          (let
+            ((ll (hk-map-left l)) (lr (hk-map-right l)))
+            (cond
+              ((< (hk-map-size lr) (* hk-map-gamma (hk-map-size ll)))
+                (hk-map-single-r k v l r))
+              (:else (hk-map-double-r k v l r)))))
+        (:else (hk-map-node k v l r))))))