rose-ash/lib/content/crdt.sx

;; content-on-sx — collaborative merge (state-based CvRDT).
;;
;; The merge is a join (least upper bound) on a semilattice, so it is
;; commutative, associative and idempotent BY CONSTRUCTION — applying ops in any
;; order, or merging replicas in any order / twice, converges to the same
;; document. This is NOT last-write-wins-as-cop-out: ordering uses unique dense
;; position keys (Logoot), presence uses OR-tombstones (remove-wins), and each
;; field is an LWW-Register keyed by a logical (ts, actor) clock — an explicit,
;; deterministic per-field conflict policy.
;;
;; Every op (insert/update/delete) contributes a PARTIAL element; the per-id
;; state is the join of all contributions. So update-before-insert and
;; delete-before-insert are not lost — they merge when the rest arrives.
;;
;; Shapes:
;;   state    = {:elements <dict id -> element>}
;;   element  = {:id :pos :type :deleted :fields <dict fname -> register>}
;;   register = {:value v :ts <int> :actor <int>}
;;   position = list of cells; cell = (list digit actor); lexicographic order
;;
;; Requires (loaded by harness): block.sx, doc.sx.

(define CRDT-BASE 65536)

;; ── position order (Logoot) ──
(define
  crdt-cell-cmp
  (fn
    (c1 c2)
    (let
      ((d1 (first c1)) (d2 (first c2)))
      (cond
        ((< d1 d2) -1)
        ((> d1 d2) 1)
        (else
          (let
            ((a1 (first (rest c1))) (a2 (first (rest c2))))
            (cond
              ((< a1 a2) -1)
              ((> a1 a2) 1)
              (else 0))))))))

(define
  crdt-pos-compare
  (fn
    (p1 p2)
    (cond
      ((and (= (len p1) 0) (= (len p2) 0)) 0)
      ((= (len p1) 0) -1)
      ((= (len p2) 0) 1)
      (else
        (let
          ((c (crdt-cell-cmp (first p1) (first p2))))
          (if (= c 0) (crdt-pos-compare (rest p1) (rest p2)) c))))))

;; single-cell position constructor (handy for explicit tests)
(define crdt-pos (fn (digit actor) (list (list digit actor))))

;; allocate a position strictly between left and right (nil = unbounded)
(define
  cr-alloc
  (fn
    (left right actor i acc)
    (let
      ((ld (if (< i (len left)) (first (nth left i)) 0))
        (rd (if (< i (len right)) (first (nth right i)) CRDT-BASE)))
      (if
        (> (- rd ld) 1)
        (append
          acc
          (list
            (list
              (+
                ld
                (+
                  1
                  (floor (/ (- (- rd ld) 1) 2))))
              actor)))
        (cr-alloc
          left
          right
          actor
          (+ i 1)
          (append
            acc
            (list
              (list
                ld
                (if (< i (len left)) (first (rest (nth left i))) actor)))))))))

(define
  crdt-pos-between
  (fn
    (left right actor)
    (cr-alloc
      (if (= left nil) (list) left)
      (if (= right nil) (list) right)
      actor
      0
      (list))))

;; ── register (LWW by logical (ts, actor)) ──
(define
  crdt-reg-max
  (fn
    (r1 r2)
    (cond
      ((= r1 nil) r2)
      ((= r2 nil) r1)
      (else
        (let
          ((t1 (get r1 :ts)) (t2 (get r2 :ts)))
          (cond
            ((> t1 t2) r1)
            ((< t1 t2) r2)
            (else (if (>= (get r1 :actor) (get r2 :actor)) r1 r2))))))))

;; ── small set/dict helpers ──
(define
  crdt-member?
  (fn
    (x xs)
    (cond
      ((= (len xs) 0) false)
      ((= (first xs) x) true)
      (else (crdt-member? x (rest xs))))))

(define
  crdt-dedup-loop
  (fn
    (xs seen)
    (if
      (= (len xs) 0)
      (reverse seen)
      (if
        (crdt-member? (first xs) seen)
        (crdt-dedup-loop (rest xs) seen)
        (crdt-dedup-loop (rest xs) (cons (first xs) seen))))))

(define crdt-dedup (fn (xs) (crdt-dedup-loop xs (list))))

(define
  crdt-union-keys
  (fn (d1 d2) (crdt-dedup (append (keys d1) (keys d2)))))

;; ── element join ──
(define
  crdt-merge-pos
  (fn
    (p1 p2)
    (cond
      ((= p1 nil) p2)
      ((= p2 nil) p1)
      ((<= (crdt-pos-compare p1 p2) 0) p1)
      (else p2))))

(define crdt-merge-type (fn (t1 t2) (if (= t1 nil) t2 t1)))

(define
  crdt-merge-fields-loop
  (fn
    (names f1 f2 acc)
    (if
      (= (len names) 0)
      acc
      (let
        ((nm (first names)))
        (crdt-merge-fields-loop
          (rest names)
          f1
          f2
          (assoc acc nm (crdt-reg-max (get f1 nm) (get f2 nm))))))))

(define
  crdt-merge-fields
  (fn
    (f1 f2)
    (crdt-merge-fields-loop (crdt-union-keys f1 f2) f1 f2 {})))

(define crdt-merge-element (fn (e1 e2) {:fields (crdt-merge-fields (get e1 :fields) (get e2 :fields)) :id (get e1 :id) :type (crdt-merge-type (get e1 :type) (get e2 :type)) :deleted (or (= (get e1 :deleted) true) (= (get e2 :deleted) true)) :pos (crdt-merge-pos (get e1 :pos) (get e2 :pos))}))

;; ── state ──
(define crdt-empty (fn () {:elements {}}))

(define
  crdt-add-element
  (fn
    (state elem)
    (let
      ((elems (get state :elements)) (id (get elem :id)))
      (let
        ((existing (get elems id)))
        (assoc
          state
          :elements (assoc
            elems
            id
            (if (= existing nil) elem (crdt-merge-element existing elem))))))))

(define
  crdt-build-fields-loop
  (fn
    (pairs ts actor acc)
    (if
      (= (len pairs) 0)
      acc
      (crdt-build-fields-loop
        (rest pairs)
        ts
        actor
        (assoc acc (first (first pairs)) {:ts ts :actor actor :value (first (rest (first pairs)))})))))

(define
  crdt-build-fields
  (fn (pairs ts actor) (crdt-build-fields-loop pairs ts actor {})))

;; ── ops as partial-element contributions ──
(define
  crdt-insert
  (fn
    (state id type pos fields ts actor)
    (crdt-add-element state {:fields (crdt-build-fields fields ts actor) :id id :type type :deleted false :pos pos})))

(define
  crdt-update
  (fn (state id fname value ts actor) (crdt-add-element state {:fields (assoc {} fname {:ts ts :actor actor :value value}) :id id :type nil :deleted false :pos nil})))

(define crdt-delete (fn (state id) (crdt-add-element state {:fields {} :id id :type nil :deleted true :pos nil})))

;; ── state merge (join) ──
(define
  crdt-merge-loop
  (fn
    (ids ea eb acc)
    (if
      (= (len ids) 0)
      acc
      (let
        ((id (first ids)))
        (let
          ((x (get ea id)) (y (get eb id)))
          (crdt-merge-loop
            (rest ids)
            ea
            eb
            (assoc
              acc
              id
              (cond
                ((= x nil) y)
                ((= y nil) x)
                (else (crdt-merge-element x y))))))))))

(define crdt-merge (fn (a b) {:elements (crdt-merge-loop (crdt-union-keys (get a :elements) (get b :elements)) (get a :elements) (get b :elements) {})}))

(define
  crdt-merge-all
  (fn
    (states)
    (if
      (= (len states) 0)
      (crdt-empty)
      (if
        (= (len states) 1)
        (first states)
        (crdt-merge (first states) (crdt-merge-all (rest states)))))))

;; ── op interpreter ──
(define crdt-op-insert (fn (id type pos fields ts actor) {:ts ts :fields fields :id id :type type :op "insert" :actor actor :pos pos}))

(define crdt-op-update (fn (id field value ts actor) {:ts ts :field field :id id :op "update" :actor actor :value value}))

(define crdt-op-delete (fn (id) {:id id :op "delete"}))

(define
  crdt-apply
  (fn
    (state op)
    (let
      ((k (get op :op)))
      (cond
        ((= k "insert")
          (crdt-insert
            state
            (get op :id)
            (get op :type)
            (get op :pos)
            (get op :fields)
            (get op :ts)
            (get op :actor)))
        ((= k "update")
          (crdt-update
            state
            (get op :id)
            (get op :field)
            (get op :value)
            (get op :ts)
            (get op :actor)))
        ((= k "delete") (crdt-delete state (get op :id)))
        (else (error (str "unknown crdt op: " k)))))))

(define
  crdt-apply-all
  (fn
    (state ops)
    (if
      (= (len ops) 0)
      state
      (crdt-apply-all (crdt-apply state (first ops)) (rest ops)))))

;; ── materialise to a Phase-1 document ──
(define
  crdt-elements-list
  (fn
    (state)
    (map
      (fn (id) (get (get state :elements) id))
      (keys (get state :elements)))))

(define
  crdt-live?
  (fn
    (e)
    (and
      (= (get e :deleted) false)
      (if (= (get e :pos) nil) false true)
      (if (= (get e :type) nil) false true))))

(define
  crdt-live-elements
  (fn (state) (filter crdt-live? (crdt-elements-list state))))

(define
  crdt-insert-sorted
  (fn
    (e sorted)
    (cond
      ((= (len sorted) 0) (list e))
      ((< (crdt-pos-compare (get e :pos) (get (first sorted) :pos)) 0)
        (cons e sorted))
      (else (cons (first sorted) (crdt-insert-sorted e (rest sorted)))))))

(define
  crdt-sort-by-pos
  (fn
    (elems)
    (if
      (= (len elems) 0)
      (list)
      (crdt-insert-sorted (first elems) (crdt-sort-by-pos (rest elems))))))

(define
  crdt-field-pairs
  (fn
    (fields)
    (map (fn (nm) (list nm (get (get fields nm) :value))) (keys fields))))

(define
  crdt-element->block
  (fn
    (e)
    (mk-block (get e :type) (get e :id) (crdt-field-pairs (get e :fields)))))

(define
  crdt-order
  (fn
    (state)
    (map
      (fn (e) (get e :id))
      (crdt-sort-by-pos (crdt-live-elements state)))))

(define
  crdt-materialize
  (fn
    (doc-id state)
    (doc-new
      doc-id
      (map crdt-element->block (crdt-sort-by-pos (crdt-live-elements state))))))