rose-ash/lib/haskell/map.sx

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