tp/tp-surface.el

;;; tp-surface.el --- Retained text surfaces and publication -*- lexical-binding: t; -*-

;; Copyright (C) 2026 Geekinney

;; Author: Geekinney (kinneyzhang666@gmail.com)

;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 3 of
;; the License, or (at your option) any later version.

;;; Commentary:

;; Generic retained plans, candidate object identity, marker-backed mounts,
;; range property ownership, side indexes, and atomic buffer publication.
;; This module knows nothing about a consumer's layout or domain vocabulary.

;;; Code:

(require 'cl-lib)
(require 'seq)
(require 'tp-core)
(require 'tp-style)
(require 'tp-reactive)

(define-error 'tp-surface-error "TP retained surface error")
(define-error 'tp-invalid-surface-plan "Invalid TP surface plan"
  'tp-surface-error)
(define-error 'tp-duplicate-object-key "Duplicate TP object key"
  'tp-invalid-surface-plan)
(define-error 'tp-invalid-prepare-context "Invalid TP prepare context"
  'tp-surface-error)
(define-error 'tp-stale-object "Stale TP object" 'tp-surface-error)
(define-error 'tp-cross-surface-object "Cross-surface TP object"
  'tp-surface-error)
(define-error 'tp-orphan-object "Orphan TP object" 'tp-surface-error)
(define-error 'tp-capability-error "TP mount capability violation"
  'tp-surface-error)
(define-error 'tp-stale-mount "Stale TP mount" 'tp-surface-error)
(define-error 'tp-property-conflict "TP property ownership conflict"
  'tp-surface-error)
(define-error 'tp-dead-surface "Dead TP surface" 'tp-surface-error)
(define-error 'tp-invalid-range-anchor "Invalid TP range anchor"
  'tp-surface-error)
(define-error 'tp-invalid-content-range "Invalid TP content leaf range"
  'tp-surface-error)
(define-error 'tp-producer-buffer-mutation
  "TP producer mutated a live surface buffer during prepare"
  'tp-surface-error)
(define-error 'tp-publication-mismatch
  "TP publication was changed by an external buffer hook"
  'tp-surface-error)
(define-error 'tp-scope-mismatch "Scoped TP update changed outside its objects"
  'tp-surface-error)
(define-error 'tp-owned-result-error "Invalid TP owned producer result"
  'tp-surface-error)
(define-error 'tp-surface-rollback-error "TP surface rollback phase failed"
  'tp-surface-error)

(cl-defstruct (tp-surface-plan (:constructor tp--make-surface-plan))
  "Pure retained node data accepted by a TP surface."
  key kind text props children tags capability)

(cl-defstruct (tp-surface-result
               (:constructor tp--make-surface-result
                             (plan client-state &optional plan-owned-p
                                   owner-context)))
  "A producer result carrying PLAN and opaque CLIENT-STATE.
PLAN-OWNED-P marks an explicit candidate-local ownership transfer.  The
owned result is bound to OWNER-CONTEXT and consumed once during prepare."
  plan client-state plan-owned-p owner-context consumed-p)

(cl-defstruct (tp-retained-content-candidate
               (:constructor tp--make-retained-content-candidate))
  "Candidate for a content-only update on an unchanged TP object tree.
PLAN is the candidate's unchanged object topology with a new text leaf,
RENDERED is the candidate text, RANGES are the candidate-owned content-range
attachments, and PROPERTY-CONTRIBUTIONS are ordered relative range property
layers composed by TP during prepare.  CONTEXT authenticates the one-shot
producer result to the active prepare transaction."
  plan rendered ranges property-contributions client-state context
  full-surface-p consumed-p)

(cl-defstruct (tp-commit-batch (:constructor tp--make-commit-batch))
  "One precomputed content commit for a stable retained surface topology."
  base-revision target-revision base-extent target-extent patches
  coordinate-patches client-state)

(cl-defstruct (tp-commit-batch-candidate
               (:constructor tp--make-commit-batch-candidate))
  "One prepare-context-authenticated precomputed commit result."
  batch context mount-specs exact-mount-specs-p client-state
  exact-client-state-p reuse-mount-projection-p consumed-p)

(cl-defstruct (tp-surface
               (:constructor tp--make-surface)
               (:conc-name tp--surface-))
  "One live retained tree mounted in a buffer."
  id buffer capability start end options producer producer-binding plan objects
  mounts index mount-index ledger client-state revision report live stale
  observers)

(cl-defstruct (tp-object
               (:constructor tp--make-surface-object)
               (:conc-name tp--surface-object-))
  "Opaque retained identity local to one surface."
  id surface parent key kind path live disposed candidate-context)

(cl-defstruct (tp-prepare-context
               (:constructor tp--make-prepare-context)
               (:conc-name tp--context-))
  "Short-lived candidate identity and attachment owner."
  surface objects touched retained bindings attachments fragment-attachments
  content-range-attachments child-seen
  child-positions new-objects created-anchors active ephemeral)

(cl-defstruct (tp-range-anchor
               (:constructor tp--make-range-anchor)
               (:conc-name tp--anchor-))
  "Opaque marker-backed host text range."
  id buffer start end boundary-policy live stale surfaces candidate-context)

(cl-defstruct (tp--surface-mount (:constructor tp--make-surface-mount))
  object start end tags capability anchor)

(defun tp--mount-position (position)
  "Return numeric POSITION for a marker or coordinate mount endpoint."
  (if (markerp position) (marker-position position) position))

(cl-defstruct (tp--property-ledger (:constructor tp--make-property-ledger))
  start end property baseline-present baseline-value published-present
  published-value anchors)

(cl-defstruct (tp--prepared-surface (:constructor tp--make-prepared-surface))
  surface context plan rendered mount-specs ledger-specs property-operations
  objects client-state producer initial created removed moved reconciled
  scope-objects scope-patches scope-fallback live-mounts live-mount-index
  live-ledger report retained-content-p commit-batch
  retained-mount-state-p mount-coordinate-updates mount-coordinate-undo)

(cl-defstruct (tp--surface-snapshot (:constructor tp--make-surface-snapshot))
  plan objects mounts index mount-index ledger client-state producer revision
  report live stale)

(defvar tp--surface-id-counter 0)
(defvar tp--object-id-counter 0)
(defvar tp--anchor-id-counter 0)
(defvar tp--surface-transaction-id 0)
(defvar tp--surfaces (make-hash-table :test #'eql :weakness 'value))
(defvar tp--current-prepare-context nil)
(defvar tp--surface-publishing nil)
(defvar tp--surface-guarding-prepare nil)
(defvar tp--surface-publication-step-function nil)
(defvar tp--surface-precommit-step-function nil)
(defvar tp--surface-cleanup-step-function nil)
(defvar tp--content-published-ranges nil)

(defvar-local tp--buffer-surfaces nil)
(defvar-local tp--surface-character-tick 0)
(defvar-local tp--surface-before-change-state nil)

(defconst tp--surface-producer-key '(tp/surface . producer))
(defconst tp--surface-extension-key 'tp-surface)

(defun tp--normalize-surface-observers (observers)
  "Validate OBSERVERS and return them once each, in declaration order."
  (unless (listp observers)
    (signal 'wrong-type-argument (list 'listp observers)))
  (let (normalized)
    (dolist (observer observers)
      (unless (functionp observer)
        (signal 'wrong-type-argument (list 'functionp observer)))
      (unless (memq observer normalized)
        (push observer normalized)))
    (nreverse normalized)))

(defun tp--surface-observation-clock ()
  "Return the current time for optional surface publication observation."
  (float-time))

(defun tp--plist-shape-p (value)
  "Return non-nil when VALUE is an even property list with symbol keys."
  (and (listp value)
       (zerop (% (length value) 2))
       (cl-loop for (key _value) on value by #'cddr always (symbolp key))))

(defun tp--validate-plan-fields (kind text props children capability)
  "Validate plan KIND, TEXT, PROPS, CHILDREN, and CAPABILITY."
  (unless kind
    (signal 'tp-invalid-surface-plan (list :kind kind)))
  (unless (or (null text) (stringp text))
    (signal 'tp-invalid-surface-plan (list :text text)))
  (unless (tp--plist-shape-p props)
    (signal 'tp-invalid-surface-plan (list :props props)))
  (unless (and (listp children) (cl-every #'tp-surface-plan-p children))
    (signal 'tp-invalid-surface-plan (list :children children)))
  (when (and text children)
    (signal 'tp-invalid-surface-plan (list :text-and-children kind)))
  (unless (memq capability '(nil content properties))
    (signal 'tp-capability-error (list capability))))

(defun tp--validate-sibling-keys (children)
  "Reject duplicate explicit keys among CHILDREN."
  (let ((seen (make-hash-table :test #'equal)))
    (dolist (child children)
      (when-let* ((key (tp-surface-plan-key child)))
        (when (gethash key seen)
          (signal 'tp-duplicate-object-key (list key)))
        (puthash key t seen)))))

(defun tp--validate-surface-plan-tree (plan)
  "Validate PLAN recursively without copying its caller-owned values."
  (unless (tp-surface-plan-p plan)
    (signal 'wrong-type-argument (list 'tp-surface-plan-p plan)))
  (let ((children (tp-surface-plan-children plan)))
    (tp--validate-plan-fields
     (tp-surface-plan-kind plan)
     (tp-surface-plan-text plan)
     (tp-surface-plan-props plan)
     children
     (tp-surface-plan-capability plan))
    (tp--validate-sibling-keys children)
    (dolist (child children)
      (tp--validate-surface-plan-tree child)))
  plan)

(defun tp--copy-surface-plan (plan &optional cache)
  "Return a validated defensive snapshot of PLAN.
CACHE is shared by one top-level snapshot so repeated source identities retain
one copied identity across sibling nodes without canonicalizing equal values."
  (unless (tp-surface-plan-p plan)
    (signal 'wrong-type-argument (list 'tp-surface-plan-p plan)))
  (let* ((cache (or cache (make-hash-table :test #'eq)))
         (children
          (mapcar (lambda (child)
                    (tp--copy-surface-plan child cache))
                  (tp-surface-plan-children plan)))
         (kind (tp--copy-property-value (tp-surface-plan-kind plan) cache))
         (text (tp--copy-property-value (tp-surface-plan-text plan) cache))
         (props (tp--copy-property-value (tp-surface-plan-props plan) cache))
         (capability (tp-surface-plan-capability plan)))
    (tp--validate-plan-fields kind text props children capability)
    (tp--validate-sibling-keys children)
    (tp--make-surface-plan
     :key (tp--copy-property-value (tp-surface-plan-key plan) cache)
     :kind kind :text text :props props :children children
     :tags (tp--copy-property-value (tp-surface-plan-tags plan) cache)
     :capability capability)))

(cl-defun tp-surface-plan-create
    (&key key kind text props children tags capability)
  "Create a defensive surface plan node.
KEY is sibling-local identity, KIND is an opaque discriminator, TEXT is a
leaf string, PROPS are final direct text properties, CHILDREN are ordered
plans, TAGS are opaque metadata, and CAPABILITY is `content' or `properties'."
  (tp--copy-surface-plan
   (tp--make-surface-plan
    :key key :kind kind :text text :props props :children children
    :tags tags :capability capability)))

(cl-defun tp-surface-plan-create-owned
    (&key key kind text props children tags capability)
  "Create a candidate-local surface plan without copying its values.
KEY, KIND, TEXT, PROPS, CHILDREN, TAGS, and CAPABILITY have the same meanings
as in `tp-surface-plan-create'.  The caller transfers ownership of those
values; after this call they must not be mutated or exposed to another owner.
Use `tp-surface-plan-create' for ordinary caller-owned values."
  (tp--validate-surface-plan-tree
   (tp--make-surface-plan
    :key key :kind kind :text text :props props :children children
    :tags tags :capability capability)))

(defun tp-surface-result-create (plan &optional client-state)
  "Return a producer result containing PLAN and opaque CLIENT-STATE.
TP always renders the submitted plan inside its prepare transaction.  This
keeps the plan as the single authoritative source for published content."
  (tp--make-surface-result
   (tp--copy-surface-plan plan) client-state))

(defun tp-surface-result-create-owned (context plan &optional client-state)
  "Create a one-shot result by adopting candidate-local PLAN.
CONTEXT must be the active prepare context that owns PLAN.  PLAN and all
nested values must be freshly allocated for that candidate and must not be
  mutated or exposed after this call.  CLIENT-STATE is opaque producer state.
Use `tp-surface-result-create' for ordinary caller-owned plans."
  (tp--validate-prepare-context context)
  (unless (eq context tp--current-prepare-context)
    (signal 'tp-owned-result-error
            (list :context-not-current context tp--current-prepare-context)))
  (tp--make-surface-result
   (tp--validate-surface-plan-tree plan) client-state t context))

(defun tp-surface-retained-content-result-create
    (context plan rendered ranges &optional client-state full-surface-p
             property-contributions)
  "Create a one-shot retained content candidate for CONTEXT.
PLAN must preserve the committed TP object topology and contain the new text
leaf.  RENDERED is the final propertized text and RANGES are candidate-local
content attachments already associated with PLAN's text leaf.
PROPERTY-CONTRIBUTIONS is an ordered list of relative `:start', `:end', and
`:props' plists.  TP composes them over RENDERED using registered property
merge policy before diff and publication.  This entry point is intentionally
narrow: callers must prove that object topology is unchanged; TP still
validates every object, range, scope, and publication phase."
  (tp--validate-prepare-context context)
  (unless (eq context tp--current-prepare-context)
    (signal 'tp-owned-result-error
            (list :context-not-current context tp--current-prepare-context)))
  (unless (and (tp-surface-plan-p plan)
               (stringp rendered)
               (proper-list-p ranges))
    (signal 'tp-invalid-surface-plan
            (list :retained-content plan rendered ranges)))
  (tp--make-retained-content-candidate
   :plan plan :rendered rendered :ranges ranges
   :property-contributions property-contributions
   :client-state client-state :context context
   :full-surface-p full-surface-p))

(defun tp--compose-relative-property-contributions (rendered contributions)
  "Compose ordered relative CONTRIBUTIONS over RENDERED.
Each contribution contains `:start', `:end', and direct `:props'."
  (unless (proper-list-p contributions)
    (signal 'tp-invalid-content-range
            (list :property-contributions contributions)))
  (let ((result (copy-sequence rendered))
        (limit (length rendered)))
    (dolist (contribution contributions)
      (let ((start (plist-get contribution :start))
            (end (plist-get contribution :end))
            (props (plist-get contribution :props)))
        (unless (and (integerp start) (integerp end)
                     (<= 0 start) (<= start end) (<= end limit))
          (signal 'tp-invalid-content-range
                  (list :property-contribution contribution
                        :leaf-length limit)))
        (unless (tp--plist-shape-p props)
          (signal 'tp-invalid-surface-plan
                  (list :property-contribution-props props)))
        (cl-loop for (property value) on props by #'cddr
                 do
                 (let ((position start)
                       (merge
                        (tp-property-policy-merge
                         (tp-register-text-property property))))
                   (while (< position end)
                     (let* ((next
                             (or (next-single-property-change
                                  position property result end)
                                 end))
                            (cell
                             (plist-member
                              (text-properties-at position result) property))
                            (target
                             (cond
                              ((null value) nil)
                              (cell (funcall merge (cadr cell) value))
                              (t (tp--copy-property-value value)))))
                       (put-text-property position next property target result)
                       (setq position next)))))))
    result))

(defun tp--property-value-equal-p (property left right)
  "Return non-nil when PROPERTY values LEFT and RIGHT are policy-equal."
  (funcall (tp-property-policy-equality (tp-register-text-property property))
           left right))

(defun tp--plan-props-equal-p (left right)
  "Return non-nil when text property plists LEFT and RIGHT are policy-equal."
  (and (= (length left) (length right))
       (cl-loop for (property value) on left by #'cddr
                for cell = (plist-member right property)
                always (and cell
                            (tp--property-value-equal-p
                             property value (cadr cell))))))

(defun tp--plan-equal-p (left right)
  "Return non-nil when LEFT and RIGHT plans are semantically equal."
  (and (equal (tp-surface-plan-key left) (tp-surface-plan-key right))
       (equal (tp-surface-plan-kind left) (tp-surface-plan-kind right))
       (let ((a (tp-surface-plan-text left))
             (b (tp-surface-plan-text right)))
         (if (and (stringp a) (stringp b))
             (equal-including-properties a b)
           (equal a b)))
       (tp--plan-props-equal-p (tp-surface-plan-props left)
                               (tp-surface-plan-props right))
       (equal (tp-surface-plan-tags left) (tp-surface-plan-tags right))
       (eq (tp-surface-plan-capability left)
           (tp-surface-plan-capability right))
       (let ((a (tp-surface-plan-children left))
             (b (tp-surface-plan-children right)))
         (and (= (length a) (length b))
              (cl-every #'identity
                        (cl-mapcar #'tp--plan-equal-p a b))))))

(defun tp--hash-copy (table)
  "Return a shallow copy of hash TABLE."
  (let ((copy (make-hash-table :test (hash-table-test table))))
    (maphash (lambda (key value) (puthash key value copy)) table)
    copy))

(defun tp--context-parent-key (context parent)
  "Return the child-table key for PARENT in CONTEXT."
  (or parent (tp--context-surface context)))

(defun tp--context-child-table (context parent)
  "Return CONTEXT's explicit child-key table for PARENT."
  (let* ((owner (tp--context-parent-key context parent))
         (tables (tp--context-child-seen context)))
    (or (gethash owner tables)
        (let ((table (make-hash-table :test #'equal)))
          (puthash owner table tables)
          table))))

(defun tp--context-next-position (context parent)
  "Return and advance CONTEXT's unkeyed child position for PARENT."
  (let* ((owner (tp--context-parent-key context parent))
         (positions (tp--context-child-positions context))
         (position (gethash owner positions 0)))
    (puthash owner (1+ position) positions)
    position))

(defun tp--object-path-segment (context parent key kind)
  "Return CONTEXT's candidate path segment for KEY and KIND below PARENT."
  (if key
      (let ((seen (tp--context-child-table context parent)))
        (when (gethash key seen)
          (signal 'tp-duplicate-object-key (list key)))
        (puthash key t seen)
        key)
    (list :position (tp--context-next-position context parent) :kind kind)))

(defun tp--validate-context-parent (context parent)
  "Validate PARENT for candidate CONTEXT."
  (when parent
    (unless (tp-object-p parent)
      (signal 'wrong-type-argument (list 'tp-object-p parent)))
    (unless (eq (tp--surface-object-surface parent)
                (tp--context-surface context))
      (signal 'tp-cross-surface-object (list parent)))
    (unless (gethash (tp--surface-object-path parent)
                     (tp--context-objects context))
      (signal 'tp-stale-object (list parent)))))

(defun tp--validate-prepare-context (context)
  "Signal unless CONTEXT is active."
  (unless (and (tp-prepare-context-p context) (tp--context-active context))
    (signal 'tp-invalid-prepare-context (list context))))

(defun tp--new-candidate-object (context parent key kind path)
  "Create a candidate object for KEY and KIND in CONTEXT below PARENT at PATH."
  (let ((object (tp--make-surface-object
                 :id (cl-incf tp--object-id-counter)
                 :surface (tp--context-surface context) :parent parent
                 :key (tp--copy-property-value key)
                 :kind kind :path path
                 :candidate-context context)))
    (push object (tp--context-new-objects context))
    object))

(defun tp-object-ensure (context parent key kind)
  "Return candidate identity for KEY and KIND below PARENT in CONTEXT."
  (tp--validate-prepare-context context)
  (tp--validate-context-parent context parent)
  (unless kind
    (signal 'tp-invalid-surface-plan (list :kind kind)))
  (let* ((segment (tp--object-path-segment context parent key kind))
         (path (append (and parent (tp--surface-object-path parent))
                       (list segment)))
         (objects (tp--context-objects context))
         (old (gethash path objects))
         (object (if (and old (equal kind (tp--surface-object-kind old)))
                     old
                   (tp--new-candidate-object context parent key kind path))))
    (puthash path object objects)
    (puthash object t (tp--context-touched context))
    object))

(defun tp-object-ensure-at (context parent key kind position)
  "Return candidate identity at explicit sibling POSITION below PARENT.
KEYED objects retain their normal explicit-key identity; POSITION is used only
for anonymous objects.  This is the compiled-topology entry point and does not
depend on replaying preceding siblings to discover the same slot."
  (tp--validate-prepare-context context)
  (tp--validate-context-parent context parent)
  (unless kind
    (signal 'tp-invalid-surface-plan (list :kind kind)))
  (unless (and (integerp position) (>= position 0))
    (signal 'tp-invalid-surface-plan (list :position position)))
  (let* ((segment
          (if key
              (let ((seen (tp--context-child-table context parent)))
                (when (gethash key seen)
                  (signal 'tp-duplicate-object-key (list key)))
                (puthash key t seen)
                key)
            (list :position position :kind kind)))
         (path (append (and parent (tp--surface-object-path parent))
                       (list segment)))
         (objects (tp--context-objects context))
         (old (gethash path objects))
         (object (if (and old (equal kind (tp--surface-object-kind old)))
                     old
                   (tp--new-candidate-object context parent key kind path))))
    (puthash path object objects)
    (puthash object t (tp--context-touched context))
    object))

(defun tp-object-live-p (object)
  "Return non-nil when OBJECT is committed on a live surface."
  (and (tp-object-p object) (tp--surface-object-live object)
       (not (tp--surface-object-disposed object))
       (tp-surface-live-p (tp--surface-object-surface object))))

(defun tp-object-resolve (surface key-path)
  "Resolve live object in SURFACE by explicit KEY-PATH without scanning text."
  (tp--validate-live-surface surface)
  (let ((object (gethash key-path (tp--surface-objects surface))))
    (and (tp-object-live-p object) object)))

(defun tp-object-mounted-p (object)
  "Return non-nil when live OBJECT owns at least one published mount.
This predicate does not copy mount tags; use `tp-object-mounts' when callers
need the public coordinate and metadata snapshots."
  (unless (tp-object-live-p object)
    (signal 'tp-stale-object (list object)))
  (and (gethash object
                (tp--surface-mount-index
                 (tp--surface-object-surface object)))
       t))

(defun tp-object-mounts (object)
  "Return OBJECT's live numeric mount ranges and opaque tags.
Each result is a plist with `:start', `:end', and `:tags'.  Marker objects
remain private so callers cannot mutate TP's publication coordinates."
  (unless (tp-object-live-p object)
    (signal 'tp-stale-object (list object)))
  (let* ((surface (tp--surface-object-surface object))
         (mounts (gethash object (tp--surface-mount-index surface))))
    (mapcar
     (lambda (mount)
       (list :start (tp--mount-position (tp--surface-mount-start mount))
             :end (tp--mount-position (tp--surface-mount-end mount))
             :tags (tp--copy-property-value
                    (tp--surface-mount-tags mount))))
     mounts)))

(defun tp--make-context (surface &optional ephemeral)
  "Create a prepare context for SURFACE.
When EPHEMERAL is non-nil, no identity may be promoted."
  (tp--make-prepare-context
   :surface surface
   :objects (if (tp--surface-objects surface)
                (tp--hash-copy (tp--surface-objects surface))
              (make-hash-table :test #'equal))
   :touched (make-hash-table :test #'eq)
   :retained (make-hash-table :test #'eq)
   :bindings (make-hash-table :test #'eq)
   :attachments (make-hash-table :test #'eq)
   :fragment-attachments (make-hash-table :test #'eq)
         :content-range-attachments (make-hash-table :test #'eq)
   :child-seen (make-hash-table :test #'eq)
   :child-positions (make-hash-table :test #'eq)
   :active t :ephemeral ephemeral))

(defun tp--validate-context-object (context object)
  "Require OBJECT to be a candidate in active CONTEXT."
  (tp--validate-prepare-context context)
  (unless (and (tp-object-p object)
               (eq (tp--surface-object-surface object)
                   (tp--context-surface context))
               (or (gethash object (tp--context-touched context))
                   (gethash object (tp--context-retained context))))
    (signal 'tp-stale-object (list object))))

(defun tp-object-retain (context object)
  "Retain candidate OBJECT in CONTEXT even when it owns no output fragment."
  (tp--validate-context-object context object)
  (puthash object t (tp--context-retained context))
  object)

(defun tp-object-reuse (context object)
  "Reuse one proven unchanged live OBJECT in CONTEXT.
The object and its live bindings remain in the candidate without being marked
as touched.  The caller owns the proof that identity, parent path, output, and
lifecycle are unchanged."
  (tp--validate-prepare-context context)
  (unless (tp-object-p object)
    (signal 'wrong-type-argument (list 'tp-object-p object)))
  (let* ((surface (tp--context-surface context))
         (path (tp--surface-object-path object))
         (objects (tp--context-objects context)))
    (unless (and (tp-object-live-p object)
                 (eq (tp--surface-object-surface object) surface)
                 (eq object (gethash path objects)))
      (signal 'tp-stale-object (list object)))
    (puthash object t (tp--context-retained context))
    (dolist (binding (tp-binding-owner-bindings object))
      (when (tp-binding-live-p binding)
        (puthash binding t (tp--context-bindings context)))))
  object)

(defun tp--object-path-prefix-p (prefix path)
  "Return non-nil when PREFIX is a path prefix of PATH."
  (and (<= (length prefix) (length path))
       (equal prefix (cl-subseq path 0 (length prefix)))))

(defun tp-object-retain-subtree (context root)
  "Retain the existing object subtree rooted at live ROOT in CONTEXT.
ROOT must be a live object already owned by CONTEXT's surface.  The operation
marks ROOT and every already-known descendant as touched and retained, and
also keeps their live bindings in the candidate lifecycle.  It does not
create missing objects or prove that an omitted subtree is unchanged; the
producer must provide that proof and a complete candidate plan separately."
  (tp--validate-prepare-context context)
  (unless (tp-object-p root)
    (signal 'wrong-type-argument (list 'tp-object-p root)))
  (let* ((surface (tp--context-surface context))
         (path (tp--surface-object-path root))
         (objects (tp--context-objects context)))
    (unless (and (tp-object-live-p root)
                 (eq root (gethash path objects)))
      (signal 'tp-stale-object (list root)))
    (maphash
     (lambda (_candidate-path object)
       (when (tp--object-path-prefix-p
              path (tp--surface-object-path object))
         (unless (and (eq (tp--surface-object-surface object) surface)
                      (tp-object-live-p object))
           (signal 'tp-stale-object (list object)))
         (puthash object t (tp--context-touched context))
         (puthash object t (tp--context-retained context))
         (dolist (binding (tp-binding-owner-bindings object))
           (when (tp-binding-live-p binding)
             (puthash binding t (tp--context-bindings context))))))
     objects))
  root)

(defun tp-object-reuse-subtree (context root)
  "Reuse a proven unchanged live subtree in CONTEXT.
ROOT must be a live object already owned by CONTEXT's surface.  The subtree's
objects and live bindings remain in the candidate, but are not marked touched
or reconciled.  The caller must still provide a complete candidate plan and
prove that the subtree's identity, output, and lifecycle are unchanged."
  (tp--validate-prepare-context context)
  (unless (tp-object-p root)
    (signal 'wrong-type-argument (list 'tp-object-p root)))
  (let* ((surface (tp--context-surface context))
         (path (tp--surface-object-path root))
         (objects (tp--context-objects context)))
    (unless (and (tp-object-live-p root)
                 (eq root (gethash path objects)))
      (signal 'tp-stale-object (list root)))
    (maphash
     (lambda (_candidate-path object)
       (when (tp--object-path-prefix-p
              path (tp--surface-object-path object))
         (unless (and (eq (tp--surface-object-surface object) surface)
                      (tp-object-live-p object))
           (signal 'tp-stale-object (list object)))
         (puthash object t (tp--context-retained context))
         (dolist (binding (tp-binding-owner-bindings object))
           (when (tp-binding-live-p binding)
             (puthash binding t (tp--context-bindings context))))))
     objects))
  root)

(defun tp-object-attach-fragment (context object fragment &optional tags)
  "Attach logical OBJECT to output FRAGMENT with opaque TAGS in CONTEXT.
OBJECT and FRAGMENT must be candidate handles from the same content surface.
The plan remains pure; this side attachment may give OBJECT several disjoint
marker-backed mounts after publication."
  (tp--validate-context-object context object)
  (tp--validate-context-object context fragment)
  (unless (eq (tp--surface-capability (tp--context-surface context)) 'content)
    (signal 'tp-capability-error (list :fragment-attachment)))
  (let ((attachments (gethash fragment
                              (tp--context-fragment-attachments context))))
    (when (assq object attachments)
      (signal 'tp-surface-error (list :duplicate-fragment object fragment)))
    (puthash fragment
             (cons (cons object (tp--copy-property-value tags)) attachments)
             (tp--context-fragment-attachments context)))
  (tp-object-retain context object))

(defun tp--validate-content-range (start end)
  "Signal unless START and END describe a nonempty local leaf range."
  (unless (and (integerp start) (integerp end)
               (>= start 0) (> end start))
    (signal 'tp-invalid-content-range (list :start start :end end))))

(defun tp--copy-content-range-tags (tags &optional copies)
  "Return a defensive copy of non-nil content-range TAGS.
COPIES, when non-nil, is a call-local `eq' cache owned by one bulk attach
operation.  A singular attach always snapshots TAGS independently, so later
caller mutation cannot alter an earlier attachment."
  (if (null tags)
      nil
    (let ((copy (and copies (gethash tags copies))))
      (or copy
          (let ((copy (tp--copy-property-value tags)))
            (when copies
              (puthash tags copy copies))
            copy)))))

(defun tp-object-attach-content-range
    (context object leaf start end &optional tags)
  "Attach OBJECT to [START, END) in candidate content LEAF for CONTEXT.
START and END are character offsets relative to LEAF's text, not buffer
positions.  LEAF must be a candidate text leaf in the same content surface;
the range is validated against its rendered length during prepare.  TAGS are
opaque metadata copied into the eventual marker-backed mount."
  (tp--validate-context-object context object)
  (tp--validate-context-object context leaf)
  (tp--validate-content-range start end)
  (let ((attachments
         (gethash leaf (tp--context-content-range-attachments context))))
    (puthash leaf
             (cons (list :object object :start start :end end
                         :tags (tp--copy-content-range-tags tags))
                   attachments)
             (tp--context-content-range-attachments context)))
  (unless (gethash object (tp--context-retained context))
    (tp-object-retain context object)))

(defun tp--attach-content-ranges (context leaf ranges copy-tags-p)
  "Attach RANGES to LEAF for CONTEXT, copying TAGS when COPY-TAGS-P is non-nil."
  (tp--validate-context-object context leaf)
  (let ((attachments (gethash leaf
                              (tp--context-content-range-attachments context)))
        (copies (and copy-tags-p (make-hash-table :test #'eq)))
        added)
    (dolist (range ranges)
      (let ((object (plist-get range :object))
            (start (plist-get range :start))
            (end (plist-get range :end))
            (tags (plist-get range :tags)))
        (tp--validate-context-object context object)
        (tp--validate-content-range start end)
        (push (list :object object :start start :end end
                    :tags (if copy-tags-p
                              (tp--copy-content-range-tags tags copies)
                            tags))
              added)
        (unless (gethash object (tp--context-retained context))
          (tp-object-retain context object))))
    (puthash leaf (nconc added attachments)
             (tp--context-content-range-attachments context)))
  ranges)

(defun tp-object-attach-content-ranges (context leaf ranges)
  "Attach multiple OBJECT ranges to candidate content LEAF for CONTEXT.
RANGES contains plists with `:object', `:start', `:end', and optional `:tags'.
TP defensively copies every non-nil TAGS value.  The ranges retain input order
after publication and reuse a snapshot only when the same TAGS object recurs
in one bulk attach."
  (tp--attach-content-ranges context leaf ranges t))

(defun tp-object-attach-content-ranges-owned (context leaf ranges)
  "Attach candidate RANGES to LEAF for CONTEXT with owned TAGS snapshots.
Use this only when each non-nil TAGS value was freshly allocated for the
candidate and will not be mutated or exposed to caller mutation after this
call.  TP transfers those values without copying; failed candidates discard
the transferred values with the rest of their prepare state."
  (tp--attach-content-ranges context leaf ranges nil))

(defun tp--touch-context-binding (context binding)
  "Record BINDING as touched by CONTEXT."
  (let ((owner (tp-binding-owner binding)))
    (unless (and (tp-object-p owner)
                 (eq (tp--surface-object-surface owner)
                     (tp--context-surface context)))
      (signal 'tp-cross-surface-object (list owner)))
    (puthash binding t (tp--context-bindings context))))

(defun tp--plist-overlay (parent child &optional owned-p)
  "Return a fresh plist where CHILD values override PARENT values.
When OWNED-P is non-nil, reuse candidate-owned property values while copying
only the plist spine.  The non-owned path keeps the defensive value copies
needed by ordinary TP callers."
  (let ((result (if owned-p
                    (copy-sequence parent)
                  (tp--copy-property-value parent))))
    (cl-loop for (property value) on child by #'cddr
             do (setq result
                      (plist-put result property
                                 (if owned-p
                                     value
                                   (tp--copy-property-value value)))))
    result))

(defun tp--plan-segment (plan position)
  "Return PLAN's path segment at sibling POSITION."
  (or (tp-surface-plan-key plan)
      (list :position position :kind (tp-surface-plan-kind plan))))

(defun tp--render-plan (plan context &optional owned-p)
  "Return PLAN's propertized string and side records in CONTEXT.
OWNED-P transfers candidate-local property values through the render pass."
  (let (records)
    (cl-labels
        ((walk (node path inherited offset)
           (let* ((props (tp--plist-overlay
                          inherited (tp-surface-plan-props node) owned-p))
                  (begin offset)
                  (children (tp-surface-plan-children node))
                  pieces)
             (if children
                 (cl-loop for child in children for position from 0
                          for child-path =
                          (append path (list (tp--plan-segment child position)))
                          for result = (walk child child-path props offset)
                          do (push (car result) pieces)
                          do (setq offset (cdr result)))
               (let ((text (copy-sequence
                            (or (tp-surface-plan-text node) ""))))
                 (when (> (length text) 0)
                   (add-text-properties 0 (length text) props text))
                 (push text pieces)
                 (setq offset (+ offset (length text)))))
             (let ((object (gethash path (tp--context-objects context))))
               (unless object
                 (signal 'tp-orphan-object (list path)))
               (push (list :path path :object object :start begin :end offset
                           :props props :tags (tp-surface-plan-tags node)
                           :leaf (null children))
                     records))
             (cons (apply #'concat (nreverse pieces)) offset))))
      (let* ((path (list (tp--plan-segment plan 0)))
             (result (walk plan path nil 0)))
        (cons (car result) (nreverse records))))))

(defun tp--ensure-plan-objects (context plan &optional parent)
  "Ensure identities for PLAN recursively below PARENT in CONTEXT."
  (let ((object (tp-object-ensure
                 context parent (tp-surface-plan-key plan)
                 (tp-surface-plan-kind plan))))
    (dolist (child (tp-surface-plan-children plan))
      (tp--ensure-plan-objects context child object))
    object))

(defun tp--plan-paths (plan)
  "Return PLAN's object paths in traversal order."
  (let (paths)
    (cl-labels
        ((walk (node path)
           (push path paths)
           (cl-loop for child in (tp-surface-plan-children node)
                    for position from 0
                    do (walk child
                             (append path
                                     (list (tp--plan-segment child position)))))))
      (walk plan (list (tp--plan-segment plan 0))))
    (nreverse paths)))

(defun tp--validate-context-tree (context plan)
  "Validate PLAN and CONTEXT's retained and fragment object paths."
  (let ((expected (make-hash-table :test #'equal))
        (actual (make-hash-table :test #'equal)))
    (dolist (path (tp--plan-paths plan)) (puthash path t expected))
    (maphash
     (lambda (_path object)
       (when (or (gethash object (tp--context-touched context))
                 (gethash object (tp--context-retained context)))
         (puthash (tp--surface-object-path object) object actual)))
     (tp--context-objects context))
    (maphash
     (lambda (path _present)
       (unless (gethash path actual)
        (signal 'tp-orphan-object (list :missing path))))
     expected)
    (maphash
     (lambda (path object)
       (unless (or (gethash path expected)
                   (gethash object (tp--context-retained context)))
         (signal 'tp-orphan-object (list :extra path))))
     actual)
    (maphash
     (lambda (fragment _attachments)
       (unless (gethash (tp--surface-object-path fragment) expected)
         (signal 'tp-orphan-object
                 (list :unplanned-fragment
                       (tp--surface-object-path fragment)))))
     (tp--context-fragment-attachments context))))

(defun tp--validate-plan-capability (plan capability)
  "Validate PLAN recursively against mount CAPABILITY."
  (let ((declared (tp-surface-plan-capability plan)))
    (when (and declared (not (eq declared capability)))
      (signal 'tp-capability-error (list declared capability)))
    (when (and (eq capability 'properties) (tp-surface-plan-text plan))
      (signal 'tp-capability-error (list :properties-text)))
    (dolist (child (tp-surface-plan-children plan))
      (tp--validate-plan-capability child capability))))

(defun tp--producer-result (value surface options context)
  "Normalize producer VALUE for SURFACE and active CONTEXT using OPTIONS."
  (cond
   ((tp-commit-batch-candidate-p value)
    (unless (and context
                 (tp--context-active context)
                 (eq context tp--current-prepare-context)
                 (eq context (tp-commit-batch-candidate-context value))
                 (not (tp-commit-batch-candidate-consumed-p value)))
      (signal 'tp-owned-result-error (list value context)))
    (setf (tp-commit-batch-candidate-consumed-p value) t
          (tp-commit-batch-candidate-context value) nil)
    (list :commit-batch value))
   ((tp-retained-content-candidate-p value)
    (unless (and context
                 (tp--context-active context)
                 (eq context tp--current-prepare-context)
                 (eq context
                     (tp-retained-content-candidate-context value))
                 (not (tp-retained-content-candidate-consumed-p value)))
      (signal 'tp-owned-result-error (list value context)))
    (setf (tp-retained-content-candidate-consumed-p value) t
          (tp-retained-content-candidate-context value) nil)
    (list :retained-content value))
   ((tp-surface-result-p value)
    (let ((owned-p (tp-surface-result-plan-owned-p value)))
      (if owned-p
          (progn
            (unless (and context
                         (tp--context-active context)
                         (eq context tp--current-prepare-context)
                         (eq context (tp-surface-result-owner-context value))
                         (not (tp-surface-result-consumed-p value)))
              (signal 'tp-owned-result-error (list value context)))
              (let ((plan (tp-surface-result-plan value))
                  (client-state (tp-surface-result-client-state value)))
              (setf (tp-surface-result-consumed-p value) t
                    (tp-surface-result-plan value) nil
                    (tp-surface-result-client-state value) nil
                    (tp-surface-result-owner-context value) nil)
              (list plan client-state t)))
        (list (tp--copy-surface-plan (tp-surface-result-plan value))
              (tp-surface-result-client-state value) nil))))
   ((tp-surface-plan-p value)
   (list (tp--copy-surface-plan value)
          (if (plist-member options :client-state)
              (plist-get options :client-state)
            (tp--surface-client-state surface))
          nil))
   (t (signal 'tp-invalid-surface-plan (list value)))))

(defun tp--context-binding-removals (context objects)
  "Return default-lifecycle bindings omitted from CONTEXT among OBJECTS."
  (cl-loop for object in objects append
           (cl-loop for binding in (tp-binding-owner-bindings object)
                    unless (or (gethash binding (tp--context-bindings context))
                               (eq (tp-binding-lifecycle binding) 'retain))
                    collect binding)))

(defun tp--context-live-objects (surface)
  "Return SURFACE's current objects."
  (let (objects)
    (when (tp--surface-objects surface)
      (maphash (lambda (_path object) (push object objects))
               (tp--surface-objects surface)))
    objects))

(defun tp--object-set-difference (left right)
  "Return objects in LEFT that are not `eq' to an object in RIGHT."
  (cl-remove-if (lambda (object) (memq object right)) left))

(defun tp--plan-key-positions (plan)
  "Return an alist from PLAN keyed paths to sibling positions."
  (let (positions)
    (cl-labels
        ((walk (node path)
           (cl-loop for child in (tp-surface-plan-children node)
                    for position from 0
                    for key = (tp-surface-plan-key child)
                    for child-path = (and key (append path (list key)))
                    when key do (push (cons child-path position) positions)
                    do (walk child
                             (or child-path
                                 (append path
                                         (list (tp--plan-segment
                                                child position))))))))
      (walk plan (list (tp--plan-segment plan 0))))
    positions))

(defun tp--plan-moved-count (old new)
  "Return the number of keyed objects moved between OLD and NEW plans."
  (if (null old)
      0
    (let ((old-positions (tp--plan-key-positions old)))
      (cl-loop for (path . position) in (tp--plan-key-positions new)
               for old-position = (alist-get path old-positions nil nil #'equal)
               count (and old-position (/= old-position position))))))

(defun tp--candidate-object-list (context)
  "Return CONTEXT's touched and retained candidate objects."
  (let (objects)
    (maphash
     (lambda (_path object)
       (when (or (gethash object (tp--context-touched context))
                 (gethash object (tp--context-retained context)))
         (push object objects)))
     (tp--context-objects context))
    objects))

(defun tp--candidate-reconciled-count (context created)
  "Return the number of touched retained objects in CONTEXT excluding CREATED."
  (- (hash-table-count (tp--context-touched context))
     (length created)))

(defun tp--content-mount-spec (object record &optional tags tags-owned-p)
  "Return one content mount spec for OBJECT over RECORD with TAGS.
TAGS-OWNED-P skips a second snapshot when TAGS already belongs to the candidate."
  (list :object object :start (plist-get record :start)
        :end (plist-get record :end)
        :tags (if tags-owned-p
                  tags
                (tp--copy-property-value
                 (if tags tags (plist-get record :tags))))))

(defun tp--content-mount-specs (records context)
  "Return direct and logical range mount specs for RECORDS in CONTEXT."
  (let (specs)
    (dolist (record records)
      (let* ((leaf (plist-get record :object))
             (fragment-attachments
              (nreverse
               (copy-sequence
                (gethash leaf
                         (tp--context-fragment-attachments context)))))
             (range-attachments
              (nreverse
               (copy-sequence
                (gethash leaf
                         (tp--context-content-range-attachments context))))))
        (push (tp--content-mount-spec leaf record) specs)
        (dolist (attachment fragment-attachments)
          (push (tp--content-mount-spec
                 (car attachment) record (cdr attachment) t)
                specs))
        (when range-attachments
          (unless (plist-get record :leaf)
            (signal 'tp-invalid-content-range
                    (list :leaf leaf :reason 'not-a-text-leaf)))
          (let ((leaf-start (plist-get record :start))
                (leaf-length (- (plist-get record :end)
                                (plist-get record :start))))
            (dolist (attachment range-attachments)
              (let ((start (plist-get attachment :start))
                    (end (plist-get attachment :end)))
                (unless (and (<= end leaf-length)
                             (<= start end))
                  (signal 'tp-invalid-content-range
                          (list :start start :end end
                                :leaf-length leaf-length)))
                (push (list :object (plist-get attachment :object)
                            :start (+ leaf-start start)
                            :end (+ leaf-start end)
                            :tags (plist-get attachment :tags))
                      specs)))))))
    (nreverse specs)))

(defun tp--plan-record-mount-specs (records capability context)
  "Build candidate mount specs from RECORDS for CAPABILITY in CONTEXT."
  (if (eq capability 'content)
      (tp--content-mount-specs records context)
    (tp--properties-mount-specs records context)))

(defun tp--ranges-overlap-p (left-start left-end right-start right-end)
  "Return non-nil when LEFT-START..LEFT-END overlaps RIGHT-START..RIGHT-END."
  (and (< left-start left-end) (< right-start right-end)
       (< left-start right-end) (< right-start left-end)))

(defun tp--candidate-ranges (surface mount-specs rendered)
  "Return SURFACE ranges described by MOUNT-SPECS and RENDERED."
  (if (eq (tp--surface-capability surface) 'content)
      (let ((start (marker-position (tp--surface-start surface))))
        (list (cons start (+ start (length rendered)))))
    (mapcar (lambda (spec)
              (cons (plist-get spec :start) (plist-get spec :end)))
            mount-specs)))

(defun tp--validate-cross-surface-ranges (surface mount-specs rendered)
  "Reject MOUNT-SPECS and RENDERED when SURFACE overlaps another surface."
  (let ((ranges (tp--candidate-ranges surface mount-specs rendered)))
    (with-current-buffer (tp--surface-buffer surface)
      (dolist (other tp--buffer-surfaces)
        (unless (eq other surface)
          (dolist (mount (tp--surface-mounts other))
            (let ((start (tp--mount-position (tp--surface-mount-start mount)))
                  (end (tp--mount-position (tp--surface-mount-end mount))))
              (when (cl-some (lambda (range)
                               (tp--ranges-overlap-p
                                (car range) (cdr range) start end))
                             ranges)
                (signal 'tp-capability-error
                        (list :cross-surface-overlap
                              (tp--surface-id other)))))))))))

(defun tp--prepare-input (surface input options context)
  "Run INPUT for SURFACE in CONTEXT and normalize its result."
  (let ((tp--current-prepare-context context)
        (tp--binding-touch-function
         (lambda (binding) (tp--touch-context-binding context binding))))
    (if (functionp input)
      (tp--producer-result (funcall input context) surface options context)
      (let ((plan (tp--copy-surface-plan input)))
        (tp--ensure-plan-objects context plan)
        (list plan
              (if (plist-member options :client-state)
                  (plist-get options :client-state)
                (tp--surface-client-state surface)))))))

(defun tp--call-with-prepare-buffer-guard (surface function)
  "Call FUNCTION while rejecting producer edits to SURFACE's buffer."
  (let* ((buffer (tp--surface-buffer surface))
         (before-tick (with-current-buffer buffer
                        (buffer-modified-tick)))
         (group (tp--prepare-change-group-for-buffers (list buffer)))
         (tp--surface-guarding-prepare t))
    (unwind-protect
        (let ((result (funcall function)))
          (unless (= before-tick
                     (with-current-buffer buffer
                       (buffer-modified-tick)))
            (signal 'tp-producer-buffer-mutation
                    (list (tp--surface-id surface))))
          result)
      (tp--cancel-change-group-safely group))))

(defun tp--normalize-surface-scopes (surface objects)
  "Return validated retained OBJECTS owned by SURFACE."
  (unless (and (proper-list-p objects) objects)
    (signal 'wrong-type-argument (list 'non-empty-proper-list-p objects)))
  (setq objects
        (cl-delete-duplicates (copy-sequence objects) :test #'eq))
  (dolist (object objects)
    (unless (tp-object-p object)
      (signal 'wrong-type-argument (list 'tp-object-p object)))
    (unless (tp-object-live-p object)
      (signal 'tp-stale-object (list object)))
    (unless (eq (tp--surface-object-surface object) surface)
      (signal 'tp-cross-surface-object (list object surface))))
  objects)

(defun tp--coalesce-ranges (ranges)
  "Return sorted, merged nonempty RANGES."
  (setq ranges
        (sort (cl-remove-if (lambda (range) (>= (car range) (cdr range)))
                            (mapcar (lambda (range)
                                      (cons (car range) (cdr range)))
                                    ranges))
              (lambda (left right) (< (car left) (car right)))))
  (let (merged)
    (dolist (range ranges (nreverse merged))
      (if (and merged (<= (car range) (cdar merged)))
          (setcdr (car merged) (max (cdar merged) (cdr range)))
        (push range merged)))))

(defun tp--subtract-ranges (ranges exclusions)
  "Return RANGES with EXCLUSIONS removed.
Both arguments contain numeric half-open relative intervals."
  (let (result)
    (dolist (range ranges (nreverse result))
      (let ((cursor (car range))
            (end (cdr range)))
        (dolist (exclusion exclusions)
          (when (and (< cursor end) (> (cdr exclusion) cursor))
            (when (< cursor (car exclusion))
              (push (cons cursor (min end (car exclusion))) result))
            (setq cursor (max cursor (cdr exclusion)))))
        (when (< cursor end)
          (push (cons cursor end) result))))))

(defun tp--live-scope-ranges (surface objects &optional relative)
  "Return live mount ranges for OBJECTS on SURFACE.
When RELATIVE is non-nil, return offsets from the surface start."
  (let ((base (if relative
                  (marker-position (tp--surface-start surface))
                0))
        ranges)
    (dolist (object objects)
      (dolist (mount (gethash object (tp--surface-mount-index surface)))
        (let ((start (tp--mount-position (tp--surface-mount-start mount)))
              (end (tp--mount-position (tp--surface-mount-end mount))))
          (unless (and start end)
            (signal 'tp-stale-mount (list object)))
          (push (cons (- start base) (- end base)) ranges))))
    (tp--coalesce-ranges ranges)))

(defun tp--candidate-scope-ranges (mount-specs objects)
  "Return relative candidate MOUNT-SPECS ranges owned by OBJECTS."
  (let ((scope-set (make-hash-table :test #'eq)) ranges)
    (dolist (object objects) (puthash object t scope-set))
    (dolist (spec mount-specs)
      (when (gethash (plist-get spec :object) scope-set)
        (push (cons (plist-get spec :start) (plist-get spec :end)) ranges)))
    (tp--coalesce-ranges ranges)))

(defun tp--surface-content-string (surface)
  "Return SURFACE's current propertized content string."
  (pcase-let ((`(,start . ,end) (tp--surface-range surface)))
    (with-current-buffer (tp--surface-buffer surface)
      (save-restriction
        (widen)
        (buffer-substring start end)))))

(defun tp--complement-ranges (length ranges)
  "Return the nonempty complement of RANGES inside zero to LENGTH."
  (let ((cursor 0) complement)
    (dolist (range ranges)
      (when (< cursor (car range))
        (push (cons cursor (car range)) complement))
      (setq cursor (cdr range)))
    (when (< cursor length)
      (push (cons cursor length) complement))
    (nreverse complement)))

(defun tp--substring-ranges (string ranges)
  "Return STRING content from RANGES concatenated with properties."
  (apply #'concat
         (mapcar (lambda (range)
                   (substring string (car range) (cdr range)))
                 ranges)))

(defun tp--pair-outside-ranges (old-ranges new-ranges)
  "Pair equal-length pieces of OLD-RANGES and NEW-RANGES in order."
  (let ((old-ranges (copy-tree old-ranges))
        (new-ranges (copy-tree new-ranges))
        pairs)
    (while (and old-ranges new-ranges)
      (let* ((old (car old-ranges))
             (new (car new-ranges))
             (length (min (- (cdr old) (car old))
                          (- (cdr new) (car new)))))
        (push (list (car old) (+ (car old) length)
                    (car new) (+ (car new) length))
              pairs)
        (setcar old-ranges (cons (+ (car old) length) (cdr old)))
        (setcar new-ranges (cons (+ (car new) length) (cdr new)))
        (when (= (caar old-ranges) (cdar old-ranges)) (pop old-ranges))
        (when (= (caar new-ranges) (cdar new-ranges)) (pop new-ranges))))
    (nreverse pairs)))

(defun tp--text-properties-canonical-at (text position)
  "Return TEXT properties at POSITION in deterministic key order."
  (sort
   (cl-loop for (property value) on (text-properties-at position text)
            by #'cddr
            collect (cons property value))
   (lambda (left right)
     (string< (symbol-name (car left))
              (symbol-name (car right))))))

(defun tp--text-property-semantic-equal-p (left right)
  "Return non-nil when propertized strings LEFT and RIGHT are policy-equal."
  (when (and (stringp left)
             (stringp right)
             (= (length left) (length right)))
    ;; Compare characters once.  The property loop below visits only
    ;; property-boundary positions, avoiding a substring/all-runs allocation
    ;; on every scoped update.
    (and (equal (substring-no-properties left)
                (substring-no-properties right))
         (let ((position 0)
               (limit (length left))
               equal-p)
           (setq equal-p t)
           (while (and equal-p (< position limit))
             (unless (equal-including-properties
                      (tp--text-properties-canonical-at left position)
                      (tp--text-properties-canonical-at right position))
               (setq equal-p nil))
             (setq position
                   (min (or (next-property-change position left limit) limit)
                        (or (next-property-change position right limit) limit))))
           equal-p))))

(defun tp--layout-separator-only-p (text)
  "Return non-nil when TEXT contains only layout line separators."
  (and (stringp text)
       (cl-every (lambda (char) (= char ?\n))
                 (substring-no-properties text))))

(defun tp--scope-outside-separator-equivalent-p (left right)
  "Return non-nil when scoped outside gaps differ only by line separators.
Logical Ebox owners may absorb a newline between two owned rendered runs when
one candidate line grows or shrinks.  Treating that delimiter as part of the
owner preserves scoped publication while still rejecting every non-separator
outside change."
  (and (tp--layout-separator-only-p left)
       (tp--layout-separator-only-p right)))

(defun tp--scope-patches-between-anchors (old new anchors)
  "Return patches between equal outside ANCHORS in OLD and NEW."
  (let ((old-position 0) (new-position 0) patches)
    (dolist (anchor (append anchors
                            (list (list (length old) (length old)
                                        (length new) (length new)))))
      (let* ((old-end (nth 0 anchor))
             (new-end (nth 2 anchor))
             (replacement (substring new new-position new-end)))
        (unless (tp--text-property-semantic-equal-p
                 (substring old old-position old-end) replacement)
          (push (list :old-start old-position :old-end old-end
                      :new-start new-position :new-end new-end
                      :replacement replacement)
                patches)))
      (setq old-position (nth 1 anchor)
            new-position (nth 3 anchor)))
    (nreverse patches)))

(defun tp--scope-replacement-analysis (old new old-ranges new-ranges)
  "Compare OLD-RANGES and NEW-RANGES from OLD to NEW.
Return scoped replacement metadata, or nil on mismatch."
  (let* ((old-outside (tp--complement-ranges (length old) old-ranges))
         (new-outside (tp--complement-ranges (length new) new-ranges)))
    (let ((old-gap (tp--substring-ranges old old-outside))
          (new-gap (tp--substring-ranges new new-outside)))
      (when (or (tp--text-property-semantic-equal-p old-gap new-gap)
                (tp--scope-outside-separator-equivalent-p old-gap new-gap))
        (list :patches
              (tp--scope-patches-between-anchors
               old new (tp--pair-outside-ranges old-outside new-outside)))))))

(defun tp--prepare-content-scope
    (surface rendered mount-specs objects options)
  "Return scoped publication metadata for RENDERED on SURFACE.
MOUNT-SPECS describe the candidate OBJECTS.  OPTIONS accepts
`:on-mismatch' as `error' or `root'."
  (let* ((old (tp--surface-content-string surface))
         (old-ranges (tp--live-scope-ranges surface objects t))
         (new-ranges (tp--candidate-scope-ranges mount-specs objects))
         (analysis
          (tp--scope-replacement-analysis
           old rendered old-ranges new-ranges)))
    (cond
     (analysis (list :patches (plist-get analysis :patches) :fallback nil))
     ((eq (plist-get options :on-mismatch) 'root)
      (list :patches nil :fallback t))
     (t
      (signal 'tp-scope-mismatch
              (list :surface (tp--surface-id surface)
                    :old-ranges old-ranges :new-ranges new-ranges))))))

(defun tp--range-contained-in-p (start end ranges)
  "Return non-nil when START..END is inside one of RANGES."
  (cl-some (lambda (range)
             (and (<= (car range) start) (<= end (cdr range))))
           ranges))

(defun tp--prepare-properties-scope
    (surface mount-specs operations objects options)
  "Validate scoped property OPERATIONS for OBJECTS on SURFACE.
MOUNT-SPECS describe the candidate object ranges and OPTIONS controls mismatch."
  (let* ((old-ranges (tp--live-scope-ranges surface objects))
         (new-ranges (tp--candidate-scope-ranges mount-specs objects))
         (ranges (tp--coalesce-ranges
                  (append old-ranges new-ranges)))
         (outside
          (cl-find-if
           (lambda (operation)
             (not (tp--range-contained-in-p
                   (plist-get operation :start) (plist-get operation :end)
                   ranges)))
           operations)))
    (cond
     ((not outside) (list :patches ranges :fallback nil))
     ((eq (plist-get options :on-mismatch) 'root)
      (list :patches nil :fallback t))
     (t
      (signal 'tp-scope-mismatch
              (list :surface (tp--surface-id surface)
                    :operation outside :ranges ranges))))))

(defun tp--prepare-retained-content
    (surface candidate context scope-objects scope-options initial)
  "Prepare CANDIDATE without traversing or rendering its unchanged plan.
The candidate is valid only when its plan has the same three-level content
surface topology as the committed plan.  Its text and content attachments are
still validated and published through the ordinary TP transaction phases."
  (when initial
    (signal 'tp-invalid-surface-plan
            (list :retained-content-initial t)))
  (unless (eq (tp--surface-capability surface) 'content)
    (signal 'tp-capability-error (list :retained-content 'properties)))
  (let* ((plan (tp-retained-content-candidate-plan candidate))
         (rendered
          (tp--compose-relative-property-contributions
           (tp-retained-content-candidate-rendered candidate)
           (tp-retained-content-candidate-property-contributions candidate)))
         (ranges (tp-retained-content-candidate-ranges candidate))
         (objects (tp--context-objects context))
         (root-path (list (tp--plan-segment plan 0)))
         (fragment-plan (car (tp-surface-plan-children plan)))
         (fragment-path (append root-path
                                (list (tp--plan-segment fragment-plan 0))))
         (text-plan (car (tp-surface-plan-children fragment-plan)))
         (text-path (append fragment-path
                            (list (tp--plan-segment text-plan 0))))
         (surface-root (gethash root-path objects))
         (fragment-root (gethash fragment-path objects))
         (text-leaf (gethash text-path objects)))
    (unless (and surface-root fragment-root text-leaf
                 (null (tp-surface-plan-props plan))
                 (null (tp-surface-plan-props fragment-plan))
                 (null (tp-surface-plan-props text-plan))
                 (null (tp-surface-plan-children text-plan))
                 (equal (tp-surface-plan-key plan)
                        (tp-surface-plan-key (tp--surface-plan surface))))
      (signal 'tp-invalid-surface-plan
              (list :retained-content-topology plan)))
    (tp--validate-plan-capability plan (tp--surface-capability surface))
    ;; `ebox-surface--owned-ranges' transfers freshly allocated range plists
    ;; for this candidate.  Install that list directly after validating the
    ;; same invariants as the public attach operation; copying it again here
    ;; would recreate the hot-path allocation we are removing.
    (when (and ranges
               (null (gethash text-leaf
                             (tp--context-content-range-attachments context))))
      (tp--validate-context-object context text-leaf)
      (dolist (range ranges)
        (let ((object (plist-get range :object))
              (start (plist-get range :start))
              (end (plist-get range :end)))
          (tp--validate-context-object context object)
          (tp--validate-content-range start end)
          (unless (<= end (length rendered))
            (signal 'tp-invalid-content-range
                    (list :start start :end end
                          :leaf-length (length rendered))))))
      (puthash text-leaf ranges
               (tp--context-content-range-attachments context)))
    (let* ((length (length rendered))
           (records (list (list :object text-leaf :start 0 :end length
                                :props nil :tags nil :leaf t)
                            (list :object fragment-root :start 0 :end length
                                  :props nil :tags nil :leaf nil)
                            (list :object surface-root :start 0 :end length
                                  :props nil :tags nil :leaf nil)))
           (mount-specs (tp--content-mount-specs records context))
           (_ranges (tp--validate-cross-surface-ranges
                     surface mount-specs rendered))
           (full-surface-p
            (tp-retained-content-candidate-full-surface-p candidate))
           (scope-analysis
            (cond
             ;; A root Ebox scroll owner is the only retained-content caller
             ;; allowed to widen this proof.  Its semantic root owns every
             ;; rendered line, including separator characters that are not
             ;; tagged by a child mount, so the full surface replacement is
             ;; the exact scope rather than a fallback.
             ((and full-surface-p scope-objects)
              (let ((old-length (length (tp--surface-content-string surface))))
                (list :patches
                      (list (list :old-start 0 :old-end old-length
                                  :new-start 0 :new-end (length rendered)
                                  :replacement rendered))
                      :fallback nil)))
             (scope-objects
              (tp--prepare-content-scope
               surface rendered mount-specs scope-objects scope-options))))
           (scope-patches (plist-get scope-analysis :patches))
           (retained-content-p
            (and full-surface-p
                 scope-analysis
                 (not (plist-get scope-analysis :fallback))))
           (old-objects (tp--context-live-objects surface))
           (candidate-objects (tp--candidate-object-list context)))
      (unless (equal (sort (copy-sequence old-objects)
                           (lambda (left right)
                             (< (tp--surface-object-id left)
                                (tp--surface-object-id right))))
                     (sort (copy-sequence candidate-objects)
                           (lambda (left right)
                             (< (tp--surface-object-id left)
                                (tp--surface-object-id right)))))
        (signal 'tp-orphan-object (list :retained-content-object-set)))
      (tp--make-prepared-surface
       :surface surface :context context :plan plan :rendered rendered
       :mount-specs mount-specs :objects candidate-objects
       :client-state (tp-retained-content-candidate-client-state candidate)
       :producer candidate :initial nil :created nil :removed nil :moved 0
       :reconciled 0 :scope-objects scope-objects
       :scope-patches scope-patches
       :scope-fallback (plist-get scope-analysis :fallback)
       :retained-content-p retained-content-p))))

(defun tp--commit-batch-rebase-position (patches position end-p)
  "Map old POSITION through ordered coordinate PATCHES.
END-P selects the right boundary when POSITION lies inside a replacement."
  (let ((delta 0) result)
    (while (and patches (null result))
      (let* ((patch (car patches))
             (old-start (plist-get patch :old-start))
             (old-end (plist-get patch :old-end))
             (new-start (plist-get patch :new-start))
             (new-end (plist-get patch :new-end)))
        (cond
         ((< position old-start) (setq result (+ position delta)))
         ((= position old-start) (setq result new-start))
         ((< position old-end) (setq result (if end-p new-end new-start)))
         ((= position old-end) (setq result new-end))
         (t (setq delta (- new-end old-end)
                  patches (cdr patches))))))
    (or result (+ position delta))))

(defun tp--commit-batch-mount-specs (surface batch)
  "Return SURFACE coordinate mounts rebased through BATCH."
  (let ((base (marker-position (tp--surface-start surface))))
    (mapcar
     (lambda (mount)
       (let ((start (- (tp--mount-position
                        (tp--surface-mount-start mount)) base))
             (end (- (tp--mount-position
                      (tp--surface-mount-end mount)) base))
             (patches (tp-commit-batch-coordinate-patches batch)))
         (list :object (tp--surface-mount-object mount)
               :start (tp--commit-batch-rebase-position patches start nil)
               :end (tp--commit-batch-rebase-position patches end t)
               :tags (copy-tree (tp--surface-mount-tags mount)))))
     (tp--surface-mounts surface))))

(defun tp--commit-batch-retained-mount-state
    (surface mount-specs context target-extent)
  "Return exact coordinate updates when SURFACE can retain MOUNT-SPECS.
The returned cons distinguishes an exact empty update set from a proof miss."
  (let ((base (marker-position (tp--surface-start surface)))
        (mounts (tp--surface-mounts surface))
        (specs mount-specs)
        (retainable
         (and (plist-get (tp--surface-options surface) :coordinate-mounts) t))
        (updates
         (and (plist-get (tp--surface-options surface) :coordinate-mounts)
              (make-vector (* 3 (length mount-specs)) nil)))
        (update-index 0))
    (while specs
      (let* ((spec (pop specs))
             (mount (and mounts (pop mounts)))
             (object (plist-get spec :object))
             (start (plist-get spec :start))
             (end (plist-get spec :end)))
        (unless (and (tp-object-p object)
                     (or (gethash object (tp--context-touched context))
                         (gethash object (tp--context-retained context)))
                     (integerp start) (integerp end)
                     (<= 0 start end target-extent))
          (signal 'tp-surface-error
                  (list :commit-mount-range start end target-extent)))
        (if (and retainable mount
                 (integerp (tp--surface-mount-start mount))
                 (integerp (tp--surface-mount-end mount))
                 (eq (tp--surface-mount-object mount) object)
                 (eq (tp--surface-mount-tags mount)
                     (plist-get spec :tags)))
            (progn
              (aset updates update-index mount)
              (aset updates (1+ update-index) (+ base start))
              (aset updates (+ update-index 2) (+ base end))
              (setq update-index (+ update-index 3)))
          (setq retainable nil
                updates nil))))
    (when mounts (setq retainable nil))
    (and retainable (cons t updates))))

(defun tp--commit-batch-stable-object-set-p (surface objects)
  "Return non-nil when OBJECTS are exactly SURFACE's retained identities."
  (let ((live (tp--surface-objects surface)))
    (and (hash-table-p live)
         (= (hash-table-count live) (length objects))
         (cl-every
          (lambda (object)
            (eq (gethash (tp--surface-object-path object) live) object))
          objects))))

(defun tp--commit-batch-coordinate-identity-p (batch)
  "Return non-nil when BATCH cannot move any retained coordinate."
  (and (= (tp-commit-batch-base-extent batch)
          (tp-commit-batch-target-extent batch))
       (cl-every
        (lambda (patch)
          (and (= (plist-get patch :old-start)
                  (plist-get patch :new-start))
               (= (plist-get patch :old-end)
                  (plist-get patch :new-end))))
        (tp-commit-batch-coordinate-patches batch))))

(defun tp--prepare-commit-batch
    (surface candidate context scope-objects input initial)
  "Prepare strict equal-coordinate CANDIDATE for stable SURFACE topology."
  (when initial
    (signal 'tp-invalid-surface-plan (list :commit-batch-initial t)))
  (unless (and (eq (tp--surface-capability surface) 'content)
               (plist-get (tp--surface-options surface) :coordinate-mounts))
    (signal 'tp-capability-error (list :commit-batch-coordinate-surface)))
  (let* ((batch (tp-commit-batch-candidate-batch candidate))
         (extent (- (marker-position (tp--surface-end surface))
                    (marker-position (tp--surface-start surface))))
         (objects (tp--candidate-object-list context))
         (reuse-mount-projection-p
          (tp-commit-batch-candidate-reuse-mount-projection-p candidate))
         (coordinate-identity-p
          (and (not reuse-mount-projection-p)
               (not (tp-commit-batch-candidate-exact-mount-specs-p candidate))
               (tp--commit-batch-coordinate-identity-p batch)))
         (mount-specs
          (cond
           ((tp-commit-batch-candidate-exact-mount-specs-p candidate)
            (tp-commit-batch-candidate-mount-specs candidate))
           (reuse-mount-projection-p nil)
           (coordinate-identity-p nil)
           (t (tp--commit-batch-mount-specs surface batch))))
         (retained-mount-state
          (if (or reuse-mount-projection-p coordinate-identity-p)
              (cons t [])
            (tp--commit-batch-retained-mount-state
             surface mount-specs context
             (tp-commit-batch-target-extent batch)))))
    (unless (and (= (tp-commit-batch-base-revision batch)
                    (tp--surface-revision surface))
                 (= (tp-commit-batch-target-revision batch)
                    (1+ (tp--surface-revision surface)))
                 (= extent (tp-commit-batch-base-extent batch))
                 (or (not reuse-mount-projection-p)
                     (= (tp-commit-batch-base-extent batch)
                        (tp-commit-batch-target-extent batch))))
      (signal 'tp-surface-error (list :unsupported-commit-batch batch)))
    (unless (tp--commit-batch-stable-object-set-p surface objects)
      (signal 'tp-orphan-object (list :commit-batch-object-set)))
    (tp--make-prepared-surface
     :surface surface :context context :plan (tp--surface-plan surface)
     :rendered nil :mount-specs mount-specs
     :objects objects
     :client-state
     (if (tp-commit-batch-candidate-exact-client-state-p candidate)
         (tp-commit-batch-candidate-client-state candidate)
       (tp-commit-batch-client-state batch))
     :producer input :initial nil :created nil :removed nil :moved 0
     :reconciled 0 :scope-objects scope-objects
     :scope-patches (tp-commit-batch-patches batch)
     :scope-fallback nil :commit-batch batch
     :retained-mount-state-p (and retained-mount-state t)
     :mount-coordinate-updates (cdr retained-mount-state))))

(defun tp--prepare-surface (surface input options initial)
  "Prepare INPUT for SURFACE without publishing it.
OPTIONS configure the mount and INITIAL is non-nil for first publication."
  (tp--validate-surface-buffer surface initial)
  (when (and (not initial) (tp--surface-stale surface))
    (signal 'tp-stale-mount (list (tp--surface-id surface))))
  (let* ((scope-request (tp--surface-scope-request surface))
         (context (tp--make-context surface))
         (scope-objects
          (and scope-request
               (tp--normalize-surface-scopes
                surface (plist-get scope-request :objects))))
         (scope-options (plist-get scope-request :options))
         (success nil)
         result)
    (unwind-protect
        (let ((normalized
               (tp--call-with-prepare-buffer-guard
                surface
                (lambda ()
                  (tp--prepare-input surface input options context)))))
          (if (memq (car normalized) '(:retained-content :commit-batch))
              (setq result
                    (if (eq (car normalized) :retained-content)
                        (tp--prepare-retained-content
                         surface (cadr normalized) context scope-objects
                         scope-options initial)
                      (tp--prepare-commit-batch
                       surface (cadr normalized) context scope-objects
                       input initial)))
            (let* ((plan (nth 0 normalized))
                   (client-state (nth 1 normalized))
                   (owned-p (nth 2 normalized))
                   (_capability (tp--validate-plan-capability
                                 plan (tp--surface-capability surface)))
                   (_tree (tp--validate-context-tree context plan))
                   (render-result (tp--render-plan plan context owned-p))
                   (rendered (car render-result))
                   (records (cdr render-result))
                   (objects (tp--candidate-object-list context))
                   (old-objects (tp--context-live-objects surface))
                   (created (tp--object-set-difference objects old-objects))
                   (removed (tp--object-set-difference old-objects objects))
                   (mount-specs (tp--plan-record-mount-specs
                                 records (tp--surface-capability surface)
                                 context))
                   (_ranges (tp--validate-cross-surface-ranges
                             surface mount-specs rendered))
                   (property-result
                    (when (eq (tp--surface-capability surface) 'properties)
                      (tp--prepare-property-ledger surface mount-specs)))
                   (scope-analysis
                    (when scope-objects
                      (if (eq (tp--surface-capability surface) 'content)
                          (tp--prepare-content-scope
                           surface rendered mount-specs scope-objects
                           scope-options)
                        (tp--prepare-properties-scope
                         surface mount-specs (cdr property-result)
                         scope-objects scope-options)))))
              (setq result
                    (tp--make-prepared-surface
                     :surface surface :context context :plan plan
                     :rendered rendered :mount-specs mount-specs
                     :ledger-specs (car property-result)
                     :property-operations (cdr property-result)
                     :objects objects :client-state client-state
                     :producer input :initial initial :created created
                     :removed removed
                     :moved (tp--plan-moved-count
                             (tp--surface-plan surface) plan)
                     :reconciled
                     (tp--candidate-reconciled-count context created)
                     :scope-objects scope-objects
                     :scope-patches (plist-get scope-analysis :patches)
                     :scope-fallback
                     (plist-get scope-analysis :fallback)))))
          (setq success t)
          result)
      (unless success (tp--discard-context context)))))

(cl-defun tp-range-anchor-create
    (buffer start end &key (start-insertion-type nil) (end-insertion-type t)
            (boundary-policy 'stale))
  "Create an opaque marker-backed range in BUFFER from START to END.
START-INSERTION-TYPE and END-INSERTION-TYPE control marker movement.
BOUNDARY-POLICY is `stale', `shorten', or `remove'."
  (tp--validate-buffer-range buffer start end)
  (unless (memq boundary-policy '(stale shorten remove))
    (signal 'tp-invalid-range-anchor (list boundary-policy)))
  (let ((anchor (tp--make-range-anchor
                 :id (cl-incf tp--anchor-id-counter) :buffer buffer
                 :start (copy-marker start start-insertion-type)
                 :end (copy-marker end end-insertion-type)
                 :boundary-policy boundary-policy :live t
                 :candidate-context tp--current-prepare-context)))
    (when tp--current-prepare-context
      (push anchor (tp--context-created-anchors tp--current-prepare-context)))
    anchor))

(defun tp-range-anchor-live-p (anchor)
  "Return non-nil when ANCHOR still has live markers."
  (and (tp-range-anchor-p anchor) (tp--anchor-live anchor)
       (buffer-live-p (tp--anchor-buffer anchor))
       (marker-position (tp--anchor-start anchor))
       (marker-position (tp--anchor-end anchor))))

(defun tp--validate-anchor (anchor surface)
  "Validate ANCHOR for SURFACE."
  (unless (tp-range-anchor-live-p anchor)
    (signal 'tp-invalid-range-anchor (list anchor)))
  (unless (eq (tp--anchor-buffer anchor) (tp--surface-buffer surface))
    (signal 'tp-cross-surface-object (list anchor surface)))
  (when (and (tp--anchor-surfaces anchor)
             (not (memq surface (tp--anchor-surfaces anchor))))
    (signal 'tp-cross-surface-object (list anchor surface)))
  (when (tp--anchor-stale anchor)
    (signal 'tp-stale-mount (list (tp--anchor-id anchor)))))

(defun tp-object-attach-range (context object anchor)
  "Attach OBJECT to marker-backed ANCHOR in candidate CONTEXT."
  (tp--validate-context-object context object)
  (tp--validate-anchor anchor (tp--context-surface context))
  (when (gethash object (tp--context-attachments context))
    (signal 'tp-invalid-range-anchor (list :duplicate object)))
  (puthash object anchor (tp--context-attachments context))
  object)

(defun tp--properties-mount-specs (records context)
  "Return properties mount specs from RECORDS and CONTEXT attachments."
  (let (specs)
    (dolist (record records)
      (let* ((object (plist-get record :object))
             (anchor (gethash object (tp--context-attachments context))))
        (when anchor
          (push (list :object object :anchor anchor
                      :start (marker-position (tp--anchor-start anchor))
                      :end (marker-position (tp--anchor-end anchor))
                      :props (plist-get record :props)
                      :tags (tp--copy-property-value
                             (plist-get record :tags)))
                specs))))
    (maphash
     (lambda (object _anchor)
       (unless (cl-find object records :key (lambda (item)
                                              (plist-get item :object))
                        :test #'eq)
         (signal 'tp-orphan-object (list object))))
     (tp--context-attachments context))
    (nreverse specs)))

(defun tp--property-state-at (buffer position property)
  "Return direct PROPERTY presence and value at POSITION in BUFFER."
  (with-current-buffer buffer
    (let ((cell (plist-member (text-properties-at position buffer) property)))
      (cons (and cell t) (and cell (cadr cell))))))

(defun tp--property-state-equal-p (left right)
  "Return non-nil when property states LEFT and RIGHT are equal."
  (and (eq (car left) (car right))
       (equal (cdr left) (cdr right))))

(defun tp--property-state-policy-equal-p (property left right)
  "Return non-nil when PROPERTY states LEFT and RIGHT are policy-equal."
  (and (eq (car left) (car right))
       (or (not (car left))
           (tp--property-value-equal-p property (cdr left) (cdr right)))))

(defun tp--ledger-position (marker)
  "Return live MARKER position or signal a stale-mount error."
  (or (marker-position marker)
      (signal 'tp-stale-mount (list marker))))

(defun tp--old-ledger-at (surface position property)
  "Return SURFACE ledger entry covering POSITION for PROPERTY."
  (cl-find-if
   (lambda (entry)
     (and (eq property (tp--property-ledger-property entry))
          (<= (tp--ledger-position (tp--property-ledger-start entry)) position)
          (< position (tp--ledger-position (tp--property-ledger-end entry)))))
   (tp--surface-ledger surface)))

(defun tp--contribution-properties (mount-specs surface)
  "Return all property names in MOUNT-SPECS and SURFACE's old ledger."
  (let (properties)
    (dolist (spec mount-specs)
      (cl-loop for (property _value) on (plist-get spec :props) by #'cddr
               do (cl-pushnew property properties :test #'eq)))
    (dolist (entry (tp--surface-ledger surface))
      (cl-pushnew (tp--property-ledger-property entry) properties :test #'eq))
    properties))

(defun tp--property-boundaries (buffer mount-specs surface properties)
  "Return sorted interval boundaries in BUFFER.
MOUNT-SPECS and SURFACE provide ranges for PROPERTIES."
  (let (boundaries intervals)
    (dolist (spec mount-specs)
      (let ((start (plist-get spec :start))
            (end (plist-get spec :end)))
        (push start boundaries)
        (push end boundaries)
        (push (cons start end) intervals)))
    (dolist (entry (tp--surface-ledger surface))
      (let ((start (tp--ledger-position (tp--property-ledger-start entry)))
            (end (tp--ledger-position (tp--property-ledger-end entry))))
        (push start boundaries)
        (push end boundaries)
        (push (cons start end) intervals)))
    (setq boundaries (sort (delete-dups boundaries) #'<))
    (with-current-buffer buffer
      (dolist (interval (tp--coalesce-ranges intervals))
        (dolist (property properties)
          (let ((position (car interval))
                (maximum (cdr interval)))
            (while (< position maximum)
              (setq position (next-single-property-change
                              position property buffer maximum))
              (push position boundaries))))))
    (sort (delete-dups boundaries) #'<)))

(defun tp--covering-contributions (mount-specs start end property)
  "Return ordered MOUNT-SPECS covering START..END and declaring PROPERTY."
  (cl-remove-if-not
   (lambda (spec)
     (and (<= (plist-get spec :start) start)
          (>= (plist-get spec :end) end)
          (plist-member (plist-get spec :props) property)))
   mount-specs))

(defun tp--merge-property-contributions (baseline contributions property)
  "Merge PROPERTY CONTRIBUTIONS over BASELINE property state."
  (let ((state baseline)
        (merge (tp-property-policy-merge
                (tp-register-text-property property))))
    (dolist (spec contributions)
      (let ((value (plist-get (plist-get spec :props) property)))
        (setq state
              (cons t (if (null value)
                          nil
                        (if (car state)
                            (funcall merge (cdr state) value)
                          value))))))
    state))

(defun tp--ledger-baseline-state (old current)
  "Return OLD ledger baseline state, or CURRENT when there is no OLD entry."
  (if old
      (cons (tp--property-ledger-baseline-present old)
            (tp--property-ledger-baseline-value old))
    current))

(defun tp--ledger-published-state (entry)
  "Return ENTRY's last published property state."
  (cons (tp--property-ledger-published-present entry)
        (tp--property-ledger-published-value entry)))

(defun tp--property-segment-result
    (surface mount-specs start end property)
  "Prepare one PROPERTY segment from START to END for SURFACE and MOUNT-SPECS."
  (let* ((buffer (tp--surface-buffer surface))
         (current (tp--property-state-at buffer start property))
         (old (tp--old-ledger-at surface start property))
         (contributions
          (tp--covering-contributions mount-specs start end property)))
    (when (and old (not (tp--property-state-policy-equal-p
                         property current (tp--ledger-published-state old))))
      (signal 'tp-property-conflict
              (list (tp--surface-id surface) start end property current)))
    (let* ((baseline (tp--ledger-baseline-state old current))
           (target (tp--merge-property-contributions
                    baseline contributions property))
           (anchors (delete-dups
                     (mapcar (lambda (spec) (plist-get spec :anchor))
                             contributions))))
      (list :operation
            (unless (tp--property-state-policy-equal-p property current target)
              (list :start start :end end :property property
                    :present (car target) :value (cdr target)))
            :ledger
            (when contributions
              (list :start start :end end :property property
                    :baseline-present (car baseline)
                    :baseline-value (cdr baseline)
                    :published-present (car target)
                    :published-value (cdr target) :anchors anchors))))))

(defun tp--prepare-property-ledger (surface mount-specs)
  "Return ledger specs and property operations for SURFACE and MOUNT-SPECS."
  (let* ((buffer (tp--surface-buffer surface))
         (properties (tp--contribution-properties mount-specs surface))
         (boundaries (tp--property-boundaries
                      buffer mount-specs surface properties))
         ledger operations)
    (cl-loop for (start end) on boundaries while end do
             (dolist (property properties)
               (let ((result (tp--property-segment-result
                              surface mount-specs start end property)))
                 (when-let* ((entry (plist-get result :ledger)))
                   (push entry ledger))
                 (when-let* ((operation (plist-get result :operation)))
                   (push operation operations)))))
    (cons (nreverse ledger) (nreverse operations))))

(defun tp--validate-live-surface (surface)
  "Signal unless SURFACE is live and its buffer exists."
  (unless (tp-surface-p surface)
    (signal 'wrong-type-argument (list 'tp-surface-p surface)))
  (unless (and (tp--surface-live surface)
               (buffer-live-p (tp--surface-buffer surface)))
    (signal 'tp-dead-surface (list (and (tp-surface-p surface)
                                        (tp--surface-id surface))))))

(defun tp-surface-live-p (surface)
  "Return non-nil when SURFACE is mounted in a live buffer."
  (and (tp-surface-p surface) (tp--surface-live surface)
       (buffer-live-p (tp--surface-buffer surface))))

(defun tp-surface-revision (surface)
  "Return SURFACE's committed revision."
  (unless (tp-surface-p surface)
    (signal 'wrong-type-argument (list 'tp-surface-p surface)))
  (tp--surface-revision surface))

(defun tp-surface-client-state (surface)
  "Return SURFACE's opaque committed client state."
  (tp--validate-live-surface surface)
  (tp--surface-client-state surface))

(cl-defun tp-commit-batch-create
    (&key base-revision target-revision base-extent target-extent
          patches coordinate-patches client-state)
  "Create a validated precomputed content commit batch.
PATCHES are ordered plists containing :old-start, :old-end, :new-start,
:new-end, and a propertized :replacement string."
  (unless (and (integerp base-revision) (>= base-revision 0)
               (integerp target-revision)
               (= target-revision (1+ base-revision)))
    (signal 'tp-surface-error
            (list :commit-revision base-revision target-revision)))
  (unless (and (integerp base-extent) (>= base-extent 0)
               (integerp target-extent) (>= target-extent 0)
               (proper-list-p patches) (proper-list-p coordinate-patches))
    (signal 'tp-surface-error
            (list :commit-extents base-extent target-extent)))
  (let ((old-cursor 0) (new-cursor 0) copy coordinate-copy)
    (dolist (patch patches)
      (let ((old-start (plist-get patch :old-start))
            (old-end (plist-get patch :old-end))
            (new-start (plist-get patch :new-start))
            (new-end (plist-get patch :new-end))
            (replacement (plist-get patch :replacement)))
        (unless (and (integerp old-start) (integerp old-end)
                     (integerp new-start) (integerp new-end)
                     (<= old-cursor old-start old-end base-extent)
                     (<= new-cursor new-start new-end target-extent)
                     (= (- old-start old-cursor)
                        (- new-start new-cursor))
                     (stringp replacement)
                     (= (length replacement) (- new-end new-start)))
          (signal 'tp-surface-error (list :commit-patch patch)))
        (push (copy-tree patch) copy)
        (setq old-cursor old-end new-cursor new-end)))
    (unless (= (- base-extent old-cursor)
               (- target-extent new-cursor))
      (signal 'tp-surface-error
              (list :commit-tail old-cursor new-cursor)))
    (setq old-cursor 0 new-cursor 0)
    (dolist (patch coordinate-patches)
      (let ((old-start (plist-get patch :old-start))
            (old-end (plist-get patch :old-end))
            (new-start (plist-get patch :new-start))
            (new-end (plist-get patch :new-end)))
        (unless (and (integerp old-start) (integerp old-end)
                     (integerp new-start) (integerp new-end)
                     (<= old-cursor old-start old-end base-extent)
                     (<= new-cursor new-start new-end target-extent)
                     (= (- old-start old-cursor)
                        (- new-start new-cursor)))
          (signal 'tp-surface-error
                  (list :commit-coordinate-patch patch)))
        (push (copy-tree patch) coordinate-copy)
        (setq old-cursor old-end new-cursor new-end)))
    (unless (= (- base-extent old-cursor)
               (- target-extent new-cursor))
      (signal 'tp-surface-error
              (list :commit-coordinate-tail old-cursor new-cursor)))
    (tp--make-commit-batch
     :base-revision base-revision :target-revision target-revision
     :base-extent base-extent :target-extent target-extent
     :patches (nreverse copy)
     :coordinate-patches (nreverse coordinate-copy)
     :client-state (tp--copy-property-value client-state))))

(cl-defun tp-commit-batch-result-create
    (context batch
             &key (mount-specs nil mount-specs-p)
             (client-state nil client-state-p)
             reuse-mount-projection)
  "Return one authenticated producer result carrying precomputed BATCH.
When MOUNT-SPECS is supplied, it is the complete target coordinate projection
for the batch.  Each spec contains `:object', `:start', `:end', and optional
`:tags'.  When CLIENT-STATE is supplied, it replaces BATCH's defensive state
snapshot.  The active prepare context owns and transfers these candidate
values without another materialization.  REUSE-MOUNT-PROJECTION asserts that
the producer proved the complete target mount topology and coordinates equal
to the committed projection, as with `tp-object-reuse-subtree'."
  (unless (and (tp-prepare-context-p context)
               (tp--context-active context)
               (eq context tp--current-prepare-context)
               (tp-commit-batch-p batch))
    (signal 'tp-owned-result-error (list :commit-batch context batch)))
  (when (and mount-specs-p reuse-mount-projection)
    (signal 'tp-surface-error (list :conflicting-commit-mount-projection)))
  (when mount-specs-p
    (unless (proper-list-p mount-specs)
      (signal 'tp-surface-error (list :commit-mount-specs))))
  (tp--make-commit-batch-candidate
   :batch batch :context context :mount-specs mount-specs
   :exact-mount-specs-p mount-specs-p :client-state client-state
   :exact-client-state-p client-state-p
   :reuse-mount-projection-p (and reuse-mount-projection t)))

(defun tp--commit-batch-apply-patches (surface batch)
  "Apply BATCH's already validated patches to SURFACE."
  (let ((buffer (tp--surface-buffer surface))
        (base (marker-position (tp--surface-start surface))))
    (with-current-buffer buffer
      (save-restriction
        (widen)
        (let ((inhibit-read-only
               (plist-get (tp--surface-options surface)
                          :inhibit-read-only)))
          (dolist (patch (reverse (tp-commit-batch-patches batch)))
            (let ((start (+ base (plist-get patch :old-start)))
                  (end (+ base (plist-get patch :old-end)))
                  (replacement (plist-get patch :replacement)))
              (delete-region start end)
              (goto-char start)
              (insert replacement))))))
    (set-marker (tp--surface-start surface) base buffer)
    (set-marker (tp--surface-end surface)
                (+ base (tp-commit-batch-target-extent batch)) buffer)))

(defun tp--commit-batch-validate-buffer (surface batch)
  "Validate BATCH's published extent and changed spans on SURFACE."
  (let ((buffer (tp--surface-buffer surface))
        (base (marker-position (tp--surface-start surface))))
    (let ((actual (- (marker-position (tp--surface-end surface)) base))
          (expected (tp-commit-batch-target-extent batch)))
      (unless (= actual expected)
        (signal 'tp-publication-mismatch
                (list :commit-extent :actual actual :expected expected))))
    (dolist (patch (tp-commit-batch-patches batch))
      (let ((start (+ base (plist-get patch :new-start)))
            (end (+ base (plist-get patch :new-end)))
            (replacement (plist-get patch :replacement)))
        (unless (equal-including-properties
                 (with-current-buffer buffer (buffer-substring start end))
                 replacement)
          (signal 'tp-publication-mismatch
                  (list :commit-patch patch)))))))

(defun tp--commit-batch-validate-mounts (surface batch mounts)
  "Validate target MOUNTS for BATCH inside SURFACE."
  (let ((base (marker-position (tp--surface-start surface)))
        (limit (+ (marker-position (tp--surface-start surface))
                  (tp-commit-batch-target-extent batch))))
    (dolist (mount mounts)
      (let ((start (tp--mount-position (tp--surface-mount-start mount)))
            (end (tp--mount-position (tp--surface-mount-end mount))))
        (unless (and start end (<= base start end limit))
          (signal 'tp-publication-mismatch
                  (list :commit-mount mount)))))))

;;;###autoload
(defun tp-surface-commit-batch (surface batch)
  "Atomically apply precomputed BATCH to stable content SURFACE."
  (tp--validate-live-surface surface)
  (unless (and (tp-commit-batch-p batch)
               (eq (tp--surface-capability surface) 'content)
               (= (tp--surface-revision surface)
                  (tp-commit-batch-base-revision batch))
               (= (- (marker-position (tp--surface-end surface))
                     (marker-position (tp--surface-start surface)))
                  (tp-commit-batch-base-extent batch)))
    (signal 'tp-surface-error (list :stale-commit-batch surface batch)))
  (let* ((buffer (tp--surface-buffer surface))
         (old-revision (tp--surface-revision surface))
         (old-client-state (tp--surface-client-state surface))
         (old-report (tp--surface-report surface))
         (views (tp--capture-view-state (list buffer)))
         (group (tp--prepare-change-group-for-buffers (list buffer)))
         success)
    (unwind-protect
        (progn
          (tp--commit-batch-apply-patches surface batch)
          (tp--commit-batch-validate-buffer surface batch)
          (tp--commit-batch-validate-mounts
           surface batch (tp--surface-mounts surface))
          (setf (tp--surface-client-state surface)
                (tp-commit-batch-client-state batch)
                (tp--surface-revision surface)
                (tp-commit-batch-target-revision batch)
                (tp--surface-report surface)
                (list :transaction-id (cl-incf tp--surface-transaction-id)
                      :surface-id (tp--surface-id surface)
                      :old-revision old-revision
                      :new-revision (tp-commit-batch-target-revision batch)
                      :text-operations (length (tp-commit-batch-patches batch))
                      :property-operations 0 :commit-batch t
                      :rolled-back nil :failure nil))
          (accept-change-group group)
          (setq success t)
          (tp-surface-report surface))
      (unless success
        (tp--cancel-change-group-safely group)
        (setf (tp--surface-client-state surface) old-client-state
              (tp--surface-revision surface) old-revision
              (tp--surface-report surface) old-report))
      (tp--restore-view-state views))))

(defun tp--validate-surface-buffer (surface initial)
  "Validate SURFACE's buffer before prepare; INITIAL permits a candidate."
  (let ((buffer (tp--surface-buffer surface)))
    (unless (buffer-live-p buffer)
      (signal 'tp-dead-surface (list (tp--surface-id surface))))
    (when (buffer-base-buffer buffer)
      (signal 'tp-unsupported-buffer (list :indirect buffer)))
    (unless (or initial (tp--surface-live surface))
      (signal 'tp-dead-surface (list (tp--surface-id surface))))
    (with-current-buffer buffer
      (when (and buffer-read-only
                 (not (plist-get (tp--surface-options surface)
                                 :inhibit-read-only)))
        (signal 'buffer-read-only (list buffer))))))

(defun tp--surface-range (surface)
  "Return SURFACE's live start and end positions."
  (let ((start (marker-position (tp--surface-start surface)))
        (end (marker-position (tp--surface-end surface))))
    (unless (and start end)
      (signal 'tp-stale-mount (list (tp--surface-id surface))))
    (cons start end)))

(defun tp--create-surface (buffer capability options)
  "Create an unmounted BUFFER surface with CAPABILITY and OPTIONS."
  (unless (memq capability '(content properties))
    (signal 'tp-capability-error (list capability)))
  (when (buffer-base-buffer buffer)
    (signal 'tp-unsupported-buffer (list :indirect buffer)))
  (let* ((range (with-current-buffer buffer
                  (save-restriction
                    (widen)
                    (cons (or (plist-get options :start) (point-min))
                          (or (plist-get options :end) (point-max))))))
         (_valid (tp--validate-buffer-range buffer (car range) (cdr range))))
    (tp--make-surface
     :id (cl-incf tp--surface-id-counter) :buffer buffer
     :capability capability :start (copy-marker (car range) nil)
     :end (copy-marker (cdr range) t)
     :options (tp--copy-property-value options)
     :objects (make-hash-table :test #'equal) :mounts nil :index nil
     :mount-index (make-hash-table :test #'eq)
     :ledger nil :revision 0 :live nil :stale nil
     :observers
     (tp--normalize-surface-observers (plist-get options :observers)))))

(defun tp--surface-compute-function (surface input options initial)
  "Return SURFACE's producer binding for INPUT, OPTIONS, and INITIAL state."
  (lambda ()
    (tp--prepare-surface
     surface input options (and initial (not (tp--surface-live surface))))))

(defun tp--install-surface-producer (surface input options initial)
  "Install INPUT as SURFACE's producer binding."
  (tp--clear-surface-scope-request surface)
  (let ((binding
         (tp-bind surface tp--surface-producer-key
                  (tp--surface-compute-function surface input options initial)
                  :equality (lambda (_old _new) nil) :lifecycle 'retain)))
    (setf (tp--surface-producer-binding surface) binding)
    binding))

(defun tp--dispose-marker (marker)
  "Detach MARKER when it is live."
  (when (markerp marker) (set-marker marker nil)))

(defun tp--dispose-anchor (anchor)
  "Invalidate ANCHOR and detach its markers."
  (when (and (tp-range-anchor-p anchor) (tp--anchor-live anchor))
    (tp--dispose-marker (tp--anchor-start anchor))
    (tp--dispose-marker (tp--anchor-end anchor))
    (setf (tp--anchor-live anchor) nil
          (tp--anchor-stale anchor) t
          (tp--anchor-surfaces anchor) nil)))

(defun tp--discard-new-objects (context)
  "Invalidate CONTEXT's uncommitted object handles."
  (dolist (object (tp--context-new-objects context))
    (unless (tp--surface-object-live object)
      (tp-binding-dispose-owner object)
      (setf (tp--surface-object-disposed object) t
            (tp--surface-object-candidate-context object) nil))))

(defun tp--discard-context (context)
  "Release unpromoted handles owned by CONTEXT."
  (when (and (tp-prepare-context-p context) (tp--context-active context))
    (setf (tp--context-active context) nil)
    (tp--discard-new-objects context)
    (dolist (anchor (tp--context-created-anchors context))
      (unless (tp--anchor-surfaces anchor) (tp--dispose-anchor anchor)))))

(defun tp--surface-mount-cleanup (surface)
  "Release candidate markers and bindings for failed SURFACE mount."
  (tp-binding-dispose-owner surface)
  (tp--dispose-marker (tp--surface-start surface))
  (tp--dispose-marker (tp--surface-end surface))
  (setf (tp--surface-live surface) nil))

;;;###autoload
(defun tp-surface-mount (buffer plan-or-producer &optional options)
  "Mount PLAN-OR-PRODUCER into BUFFER according to OPTIONS.
OPTIONS accepts :capability (`content' or `properties'), :start, :end,
:inhibit-read-only, :coordinate-mounts, :client-state, and :observers.  When
:coordinate-mounts is non-nil, content mounts store numeric coordinates rather
than private markers; use it only when host edits make the whole content
surface stale and all writes are published through TP.  Return a surface
handle."
  (let* ((target (get-buffer buffer))
         (_live (unless (buffer-live-p target)
                  (signal 'tp-unsupported-buffer (list buffer))))
         (capability (or (plist-get options :capability)
                         (and (tp-surface-plan-p plan-or-producer)
                              (tp-surface-plan-capability plan-or-producer))
                         'content))
         (surface (tp--create-surface target capability options))
         success)
    (unwind-protect
        (progn
          (tp--install-surface-producer surface plan-or-producer options t)
          (setq success t)
          surface)
      (unless success (tp--surface-mount-cleanup surface)))))

;;;###autoload
(defun tp-surface-update (surface plan-or-producer)
  "Atomically update SURFACE from PLAN-OR-PRODUCER and return its report."
  (tp--validate-live-surface surface)
  (tp--install-surface-producer
   surface plan-or-producer (tp--surface-options surface) nil)
  (tp-surface-report surface))

;;;###autoload
(defun tp-surface-add-observer (surface observer)
  "Add function OBSERVER to live SURFACE and return SURFACE.
OBSERVER receives SURFACE and a defensive REPORT copy after each successful
publication.  Adding the same function more than once has no effect."
  (tp--validate-live-surface surface)
  (unless (functionp observer)
    (signal 'wrong-type-argument (list 'functionp observer)))
  (unless (memq observer (tp--surface-observers surface))
    (setf (tp--surface-observers surface)
          (append (tp--surface-observers surface) (list observer))))
  surface)

;;;###autoload
(defun tp-surface-remove-observer (surface observer)
  "Remove function OBSERVER from live SURFACE and return SURFACE.
Removing a function that is not registered has no effect."
  (tp--validate-live-surface surface)
  (unless (functionp observer)
    (signal 'wrong-type-argument (list 'functionp observer)))
  (setf (tp--surface-observers surface)
        (delq observer (tp--surface-observers surface)))
  surface)

;;;###autoload
(defun tp-surface-update-scoped
    (surface objects plan-or-producer &optional options)
  "Atomically update SURFACE within retained OBJECTS.
PLAN-OR-PRODUCER has the same full candidate contract as
`tp-surface-update'.  TP resolves OBJECTS through its mount index and rejects
any candidate output change outside their ranges before publication.

OPTIONS accepts `:on-mismatch' and `:return-report'.  Its default mismatch
policy, `error', signals `tp-scope-mismatch'; `root' permits an explicit
full-surface fallback.  The report is returned as a defensive snapshot by
default; `:return-report nil' avoids materializing that snapshot when the
caller reads the scalar summary from the surface instead."
  (tp--validate-live-surface surface)
  (setq objects (tp--normalize-surface-scopes surface objects))
  (let ((on-mismatch (or (plist-get options :on-mismatch) 'error))
        (return-report (if (plist-member options :return-report)
                           (plist-get options :return-report)
                         t)))
    (unless (memq on-mismatch '(error root))
      (signal 'wrong-type-argument
              (list '(member error root) on-mismatch)))
    (tp--call-with-transaction
     (lambda ()
       (tp--install-surface-producer
        surface plan-or-producer (tp--surface-options surface) nil)
       (tp--set-surface-scope-request
        surface objects (list :on-mismatch on-mismatch))))
  (when return-report
    (tp-surface-report surface))))

(defun tp--edit-touches-span-p (beg edit-end start end)
  "Return non-nil when BEG..EDIT-END touches the old START..END span."
  (if (= beg edit-end)
      (and (> beg start) (< beg end))
    (and (< beg end) (> edit-end start))))

(defun tp--surface-before-change (beg end)
  "Capture retained ranges before a BUFFER edit from BEG to END."
  (setq tp--surface-before-change-state nil)
  (unless (or tp--surface-publishing tp--surface-guarding-prepare)
    (let ((anchors (make-hash-table :test #'eq)) content anchor-ranges)
      (dolist (surface tp--buffer-surfaces)
        (when (tp-surface-live-p surface)
          (if (eq (tp--surface-capability surface) 'content)
              (pcase-let ((`(,start . ,finish) (tp--surface-range surface)))
                (push (list surface start finish) content))
            (dolist (mount (tp--surface-mounts surface))
              (when-let* ((anchor (tp--surface-mount-anchor mount)))
                (unless (gethash anchor anchors)
                  (puthash anchor t anchors)
                  (push (list anchor
                              (marker-position (tp--anchor-start anchor))
                              (marker-position (tp--anchor-end anchor)))
                        anchor-ranges)))))))
      (setq tp--surface-before-change-state
            (list :beg beg :end end
                  :content content :anchors anchor-ranges)))))

(defun tp--mark-anchor-from-old-range (entry beg end)
  "Apply ENTRY anchor policy for an old edit range BEG..END."
  (pcase-let ((`(,anchor ,start ,finish) entry))
    (when (and start finish
               (tp--edit-touches-span-p beg end start finish))
      (pcase (tp--anchor-boundary-policy anchor)
        ('shorten nil)
        ('remove (setf (tp--anchor-stale anchor) 'remove))
        (_ (setf (tp--anchor-stale anchor) t))))))

(defun tp--surface-after-change (_beg _end _old-length)
  "Maintain mount staleness after a host text edit."
  (let* ((tick (buffer-chars-modified-tick))
         (character-change (/= tick tp--surface-character-tick))
         (state tp--surface-before-change-state))
    (setq tp--surface-character-tick tick)
    (setq tp--surface-before-change-state nil)
    (when (and character-change state
               (not tp--surface-publishing)
               (not tp--surface-guarding-prepare))
      (let ((old-beg (plist-get state :beg))
            (old-end (plist-get state :end)))
        (dolist (entry (plist-get state :content))
          (pcase-let ((`(,surface ,start ,end) entry))
            (when (and (tp-surface-live-p surface)
                       (tp--edit-touches-span-p old-beg old-end start end))
              (setf (tp--surface-stale surface) t))))
        (dolist (entry (plist-get state :anchors))
          (tp--mark-anchor-from-old-range entry old-beg old-end))))))

(defun tp--surface-buffer-killed ()
  "Dispose every retained surface owned by the current buffer."
  (let ((surfaces tp--buffer-surfaces))
    (setq tp--buffer-surfaces nil)
    (dolist (surface surfaces) (tp--teardown-surface surface t))))

(defun tp--register-live-surface (surface)
  "Register committed SURFACE under its buffer lifecycle owner."
  (puthash (tp--surface-id surface) surface tp--surfaces)
  (with-current-buffer (tp--surface-buffer surface)
    (cl-pushnew surface tp--buffer-surfaces :test #'eq)
    (setq tp--surface-character-tick (buffer-chars-modified-tick))
    (add-hook 'before-change-functions #'tp--surface-before-change nil t)
    (add-hook 'after-change-functions #'tp--surface-after-change nil t)
    (add-hook 'kill-buffer-hook #'tp--surface-buffer-killed nil t)))

(defun tp--surface-extension-state ()
  "Return the surface extension state for the active transaction."
  (tp--transaction-extension tp--surface-extension-key t))

(defun tp--surface-scope-table (&optional create)
  "Return the transaction-local scope table, creating it when CREATE is non-nil."
  (when-let* ((state (tp--transaction-extension
                     tp--surface-extension-key create)))
    (or (gethash 'scopes state)
        (when create
          (let ((table (make-hash-table :test #'eq)))
            (puthash 'scopes table state)
            table)))))

(defun tp--surface-scope-request (surface)
  "Return SURFACE's one-shot scope request in the active transaction."
  (when-let* ((table (tp--surface-scope-table)))
    (gethash surface table)))

(defun tp--clear-surface-scope-request (surface)
  "Clear SURFACE's pending one-shot scope request when one exists."
  (when tp--transaction-active
    (when-let* ((table (tp--surface-scope-table)))
      (remhash surface table))))

(defun tp--set-surface-scope-request (surface objects options)
  "Set SURFACE's one-shot scope request to OBJECTS and OPTIONS."
  (puthash surface
           (list :objects (copy-sequence objects)
                 :options (tp--copy-property-value options))
           (tp--surface-scope-table t)))

(defun tp--surface-prepared-table ()
  "Return the transaction-local surface candidate table."
  (let ((state (tp--surface-extension-state)))
    (or (gethash 'prepared state)
        (let ((table (make-hash-table :test #'eq)))
          (puthash 'prepared table state)
          table))))

(defun tp--surface-binding-changed (binding _old new)
  "Queue NEW when BINDING is a retained surface producer."
  (when (and (equal (tp-binding-key binding) tp--surface-producer-key)
             (tp-surface-p (tp-binding-owner binding)))
    (unless (tp--prepared-surface-p new)
      (signal 'tp-invalid-surface-plan (list :producer-result new)))
    (let* ((table (tp--surface-prepared-table))
           (surface (tp-binding-owner binding))
           (previous (gethash surface table)))
      (when previous
        (tp--discard-context (tp--prepared-surface-context previous)))
      (puthash surface new table))))

(defun tp--prepared-mount-signature (prepared)
  "Return PREPARED's stable mount attachment signature."
  (mapcar (lambda (spec)
            (list (plist-get spec :object) (plist-get spec :anchor)
                  (plist-get spec :start) (plist-get spec :end)
                  (plist-get spec :tags)))
          (tp--prepared-surface-mount-specs prepared)))

(defun tp--live-mount-signature (surface)
  "Return SURFACE's stable live mount signature."
  (let ((base (if (eq (tp--surface-capability surface) 'content)
                  (marker-position (tp--surface-start surface))
                0)))
    (mapcar (lambda (mount)
              (list (tp--surface-mount-object mount)
                    (tp--surface-mount-anchor mount)
                    (- (tp--mount-position (tp--surface-mount-start mount)) base)
                    (- (tp--mount-position (tp--surface-mount-end mount)) base)
                    (tp--surface-mount-tags mount)))
            (tp--surface-mounts surface))))

(defun tp--content-output-equal-p (prepared)
  "Return non-nil when PREPARED already matches its content mount."
  (let ((surface (tp--prepared-surface-surface prepared)))
    (if (not (eq (tp--surface-capability surface) 'content))
        t
      (pcase-let ((`(,start . ,end) (tp--surface-range surface)))
        (with-current-buffer (tp--surface-buffer surface)
          (save-restriction
            (widen)
            (equal-including-properties
             (buffer-substring start end)
             (tp--prepared-surface-rendered prepared))))))))

(defun tp--prepared-changed-p (prepared)
  "Return non-nil when PREPARED differs from its committed surface."
  (let ((surface (tp--prepared-surface-surface prepared)))
    (or (tp--prepared-surface-initial prepared)
        (not (tp--plan-equal-p (tp--surface-plan surface)
                               (tp--prepared-surface-plan prepared)))
        (not (equal (tp--surface-client-state surface)
                    (tp--prepared-surface-client-state prepared)))
        (not (eq (tp--surface-producer surface)
                 (tp--prepared-surface-producer prepared)))
        (tp--prepared-surface-created prepared)
        (tp--prepared-surface-removed prepared)
        (not (tp--content-output-equal-p prepared))
        (not (equal (tp--live-mount-signature surface)
                    (tp--prepared-mount-signature prepared))))))

(defun tp--sorted-prepared-surfaces (table)
  "Return changed candidates in TABLE ordered by surface id."
  (let (prepared)
    (maphash (lambda (_surface candidate)
               (when (tp--prepared-changed-p candidate)
                 (push candidate prepared)))
             table)
    (sort prepared
          (lambda (left right)
            (< (tp--surface-id (tp--prepared-surface-surface left))
               (tp--surface-id (tp--prepared-surface-surface right)))))))

(defun tp--all-prepared-surfaces (table)
  "Return every candidate in TABLE ordered by stable surface id."
  (let (prepared)
    (maphash (lambda (_surface candidate) (push candidate prepared)) table)
    (sort prepared
          (lambda (left right)
            (< (tp--surface-id (tp--prepared-surface-surface left))
               (tp--surface-id (tp--prepared-surface-surface right)))))))

(defun tp--publication-step (step surface)
  "Run the internal publication failure hook for STEP and SURFACE."
  (when tp--surface-publication-step-function
    (funcall tp--surface-publication-step-function step surface)))

(defun tp--common-prefix-length (left right)
  "Return the common character prefix length of LEFT and RIGHT."
  (let ((limit (min (length left) (length right))) (index 0))
    (while (and (< index limit) (= (aref left index) (aref right index)))
      (setq index (1+ index)))
    index))

(defun tp--common-suffix-length (left right prefix)
  "Return LEFT and RIGHT's common suffix length after PREFIX."
  (let ((limit (- (min (length left) (length right)) prefix)) (count 0))
    (while (and (< count limit)
                (= (aref left (- (length left) count 1))
                   (aref right (- (length right) count 1))))
      (setq count (1+ count)))
    count))

(defun tp--validate-published-content-range (buffer start rendered)
  "Validate inserted BUFFER text from START with RENDERED.
Return whether the properties match.
An external `after-change-functions' hook may alter the inserted properties;
return nil for that recoverable case so TP reapplies the rendered runs.  A
character rewrite is not recoverable at the property layer and signals before
the transaction can commit."
  (with-current-buffer buffer
    (let ((end (+ start (length rendered))))
      (unless (and (<= (point-min) start) (<= end (point-max))
                   (equal (buffer-substring-no-properties start end)
                          (substring-no-properties rendered)))
        (signal 'tp-publication-mismatch
                (list :buffer buffer :start start :end end)))
      (equal-including-properties
       (buffer-substring start end) rendered))))

(defun tp--content-text-operation (surface rendered)
  "Publish SURFACE's minimal character replacement for RENDERED."
  (pcase-let* ((`(,start . ,end) (tp--surface-range surface))
               (old (buffer-substring-no-properties start end))
               (new (substring-no-properties rendered))
               (prefix (tp--common-prefix-length old new))
               (suffix (tp--common-suffix-length old new prefix)))
    (unless (equal old new)
      (delete-region (+ start prefix) (- end suffix))
      (goto-char (+ start prefix))
      (let ((inserted (substring rendered prefix (- (length rendered) suffix))))
        (insert inserted)
        (when (tp--validate-published-content-range
               (tp--surface-buffer surface) (+ start prefix) inserted)
          (push (cons prefix (- (length new) suffix))
                tp--content-published-ranges))))
    (set-marker (tp--surface-start surface) start)
    (set-marker (tp--surface-end surface) (+ start (length new)))
    (if (equal old new) 0 1)))

(defun tp--string-property-run-diff-p (buffer start rendered from to)
  "Return non-nil when BUFFER at START differs from RENDERED on FROM..TO.
The rendered interval is already one direct-property run.  Compare its
boundary value once and reject an interior buffer boundary; scanning every
character makes a large rendered surface quadratic in its number of runs."
  (let* ((buffer-start (+ start from))
         (buffer-end (+ start to))
         (buffer-next (or (next-property-change
                          buffer-start buffer buffer-end)
                         buffer-end)))
    (or (not (tp--plan-props-equal-p
              (text-properties-at buffer-start buffer)
              (text-properties-at from rendered)))
        (< buffer-next buffer-end))))

(defun tp--content-property-operations-in-range
    (buffer start rendered from to)
  "Return property operations for RENDERED FROM..TO at BUFFER position START."
  (let ((offset from) operations)
    (while (< offset to)
      (let* ((next (next-property-change offset rendered to))
             (props (text-properties-at offset rendered)))
        (when (tp--string-property-run-diff-p
               buffer start rendered offset next)
          (push (list :start (+ start offset) :end (+ start next)
                      :props props)
                operations))
        (setq offset next)))
    (nreverse operations)))

(defun tp--content-property-operations
    (surface rendered &optional ranges scoped)
  "Return exact direct-property operations for SURFACE and RENDERED.
When SCOPED is non-nil, inspect only RANGES, including an empty set."
  (let* ((buffer (tp--surface-buffer surface))
         (start (marker-position (tp--surface-start surface)))
         (ranges (if scoped ranges (list (cons 0 (length rendered)))))
         (ranges
          (if tp--content-published-ranges
              (tp--subtract-ranges
               ranges (tp--coalesce-ranges tp--content-published-ranges))
            ranges))
         operations)
    (dolist (range ranges operations)
      (setq operations
            (nconc operations
                   (tp--content-property-operations-in-range
                    buffer start rendered (car range) (cdr range)))))))

(defun tp--apply-content-property-operations (buffer operations)
  "Apply content property OPERATIONS in BUFFER silently."
  (with-current-buffer buffer
    (with-silent-modifications
      (dolist (operation operations)
        (set-text-properties (plist-get operation :start)
                             (plist-get operation :end)
                             (plist-get operation :props) buffer)))))

(defun tp--apply-property-operation (buffer operation)
  "Apply one host-range property OPERATION in BUFFER."
  (let ((start (plist-get operation :start))
        (end (plist-get operation :end))
        (property (plist-get operation :property)))
    (if (plist-get operation :present)
        (put-text-property start end property
                           (plist-get operation :value) buffer)
      (remove-list-of-text-properties start end (list property) buffer))))

(defun tp--apply-properties-operations (surface operations)
  "Apply properties-only OPERATIONS for SURFACE silently."
  (let ((buffer (tp--surface-buffer surface)))
    (with-current-buffer buffer
      (with-silent-modifications
        (dolist (operation operations)
          (tp--apply-property-operation buffer operation))))))

(defun tp--make-content-mounts (prepared)
  "Create content mounts for PREPARED using its declared coordinate policy."
  (let* ((surface (tp--prepared-surface-surface prepared))
         (buffer (tp--surface-buffer surface))
         (base (marker-position (tp--surface-start surface)))
         (coordinate-p (plist-get (tp--surface-options surface)
                                  :coordinate-mounts)))
    (mapcar
     (lambda (spec)
       (tp--make-surface-mount
        :object (plist-get spec :object)
        :start (if coordinate-p
                   (+ base (plist-get spec :start))
                 (with-current-buffer buffer
                   (copy-marker (+ base (plist-get spec :start)) nil)))
        :end (if coordinate-p
                 (+ base (plist-get spec :end))
               (with-current-buffer buffer
                 (copy-marker (+ base (plist-get spec :end)) t)))
        :tags (plist-get spec :tags) :capability 'content))
     (tp--prepared-surface-mount-specs prepared))))

(defun tp--make-properties-mounts (prepared)
  "Create property mounts for PREPARED from its live anchors."
  (mapcar
   (lambda (spec)
     (let ((anchor (plist-get spec :anchor)))
       (tp--make-surface-mount
        :object (plist-get spec :object)
        :start (tp--anchor-start anchor) :end (tp--anchor-end anchor)
        :tags (plist-get spec :tags) :capability 'properties :anchor anchor)))
   (tp--prepared-surface-mount-specs prepared)))

(defun tp--make-live-ledger (prepared)
  "Create marker-backed property ledger entries for PREPARED."
  (let ((buffer (tp--surface-buffer (tp--prepared-surface-surface prepared))))
    (mapcar
     (lambda (spec)
       (tp--make-property-ledger
        :start (with-current-buffer buffer
                 (copy-marker (plist-get spec :start) nil))
        :end (with-current-buffer buffer
               (copy-marker (plist-get spec :end) t))
        :property (plist-get spec :property)
        :baseline-present (plist-get spec :baseline-present)
        :baseline-value (plist-get spec :baseline-value)
        :published-present (plist-get spec :published-present)
        :published-value (plist-get spec :published-value)
        :anchors (plist-get spec :anchors)))
     (tp--prepared-surface-ledger-specs prepared))))

(defun tp--index-mounts-by-object (mounts)
  "Return an object-keyed index of marker-backed MOUNTS."
  (let ((index (make-hash-table :test #'eq)))
    (dolist (mount mounts)
      (push mount (gethash (tp--surface-mount-object mount) index)))
    (maphash (lambda (object entries)
               (puthash object (nreverse entries) index))
             index)
    index))

(defun tp--create-candidate-mount-state (prepared)
  "Create PREPARED's marker-backed mount, ledger, and index candidates."
  (let* ((surface (tp--prepared-surface-surface prepared))
         (mounts (if (eq (tp--surface-capability surface) 'content)
                     (tp--make-content-mounts prepared)
                   (tp--make-properties-mounts prepared)))
         (ledger (and (eq (tp--surface-capability surface) 'properties)
                      (tp--make-live-ledger prepared))))
    (setf (tp--prepared-surface-live-mounts prepared) mounts
          (tp--prepared-surface-live-mount-index prepared)
          (tp--index-mounts-by-object mounts)
          (tp--prepared-surface-live-ledger prepared) ledger)
    mounts))

(defun tp--retain-candidate-mount-state (prepared)
  "Apply PREPARED coordinate updates while retaining mount identity and index."
  (let* ((surface (tp--prepared-surface-surface prepared))
         (mounts (tp--surface-mounts surface))
         (updates (tp--prepared-surface-mount-coordinate-updates prepared))
         (undo (make-vector (* 2 (/ (length updates) 3)) nil))
         (update-index 0)
         (undo-index 0))
    (while (< update-index (length updates))
      (let ((mount (aref updates update-index)))
        (aset undo undo-index (tp--surface-mount-start mount))
        (aset undo (1+ undo-index) (tp--surface-mount-end mount))
        (setf (tp--surface-mount-start mount)
              (aref updates (1+ update-index))
              (tp--surface-mount-end mount)
              (aref updates (+ update-index 2)))
        (setq update-index (+ update-index 3)
              undo-index (+ undo-index 2))))
    (setf (tp--prepared-surface-mount-coordinate-undo prepared)
          undo
          (tp--prepared-surface-live-mounts prepared) mounts
          (tp--prepared-surface-live-mount-index prepared)
          (tp--surface-mount-index surface)
          (tp--prepared-surface-live-ledger prepared)
          (tp--surface-ledger surface))
    mounts))

(defun tp--restore-retained-mount-state (prepared)
  "Restore PREPARED retained mount coordinates after rollback."
  (let ((updates (tp--prepared-surface-mount-coordinate-updates prepared))
        (undo (tp--prepared-surface-mount-coordinate-undo prepared))
        (update-index 0)
        (undo-index 0))
    (when (and (vectorp updates) (vectorp undo))
      (while (< update-index (length updates))
        (let ((mount (aref updates update-index)))
          (setf (tp--surface-mount-start mount) (aref undo undo-index)
                (tp--surface-mount-end mount) (aref undo (1+ undo-index)))
          (setq update-index (+ update-index 3)
                undo-index (+ undo-index 2))))))
  (setf (tp--prepared-surface-mount-coordinate-undo prepared) nil))

(defun tp--surface-snapshot (surface)
  "Return a rollback snapshot of SURFACE side state."
  (tp--make-surface-snapshot
   :plan (tp--surface-plan surface) :objects (tp--surface-objects surface)
   :mounts (tp--surface-mounts surface) :index (tp--surface-index surface)
   :mount-index (tp--surface-mount-index surface)
   :ledger (tp--surface-ledger surface)
   :client-state (tp--surface-client-state surface)
   :producer (tp--surface-producer surface)
   :revision (tp--surface-revision surface) :report (tp--surface-report surface)
   :live (tp--surface-live surface) :stale (tp--surface-stale surface)))

(defun tp--surface-object-table (objects)
  "Return a path-indexed hash table containing OBJECTS."
  (let ((table (make-hash-table :test #'equal)))
    (dolist (object objects)
      (puthash (tp--surface-object-path object) object table))
    table))

(defun tp--surface-report-value (prepared text-ops property-ops)
  "Build PREPARED's report from TEXT-OPS and PROPERTY-OPS."
  (let* ((surface (tp--prepared-surface-surface prepared))
         (old-revision (tp--surface-revision surface))
         (new-revision (1+ old-revision))
         (scoped (tp--prepared-surface-scope-objects prepared))
         (fallback (tp--prepared-surface-scope-fallback prepared))
         (patches (tp--prepared-surface-scope-patches prepared))
         (touched
          (if-let* ((batch (tp--prepared-surface-commit-batch prepared)))
              (cl-loop for patch in (tp-commit-batch-patches batch)
                       sum (length (plist-get patch :replacement)))
            (if (and scoped (not fallback))
              (cl-loop for patch in patches
                       sum (if (eq (tp--surface-capability surface) 'content)
                               (length (plist-get patch :replacement))
                             (- (cdr patch) (car patch))))
              (length (tp--prepared-surface-rendered prepared))))))
    (list :transaction-id tp--surface-transaction-id
          :surface-id (tp--surface-id surface)
          :old-revision old-revision :new-revision new-revision
          :candidate-source-writes (length tp--transaction-signals)
          :invalidated-bindings (tp--transaction-counter-delta :invalidated)
          :recomputed-bindings (tp--transaction-counter-delta :recomputed)
          :skipped-bindings (tp--transaction-counter-delta :skipped)
          :reconciled-objects (tp--prepared-surface-reconciled prepared)
          :created-objects (length (tp--prepared-surface-created prepared))
          :removed-objects (length (tp--prepared-surface-removed prepared))
          :moved-objects (tp--prepared-surface-moved prepared)
          :text-operations text-ops :property-operations property-ops
          :retained-content-p
          (tp--prepared-surface-retained-content-p prepared)
          :touched-characters touched
          :full-root (or (null scoped) fallback)
          :scope-count (length scoped)
          :scope-range-count (and scoped (length patches))
          :scope-fallback fallback
          :property-conflicts nil :rolled-back nil
          :commit-batch (and (tp--prepared-surface-commit-batch prepared) t)
          :retained-mount-state
          (and (tp--prepared-surface-retained-mount-state-p prepared) t)
          :failure nil :observer-errors nil :timing nil)))

(defun tp--scoped-content-ranges (patches)
  "Return candidate relative ranges from scoped PATCHES."
  (mapcar (lambda (patch)
            (cons (plist-get patch :new-start)
                  (plist-get patch :new-end)))
          patches))

(defun tp--publish-scoped-content-text (surface rendered patches)
  "Publish scoped PATCHES from RENDERED for SURFACE.
Return the number of text operations."
  (let ((base (marker-position (tp--surface-start surface)))
        (count 0))
    (dolist (patch (reverse patches))
      (let* ((start (+ base (plist-get patch :old-start)))
             (end (+ base (plist-get patch :old-end)))
             (replacement (plist-get patch :replacement))
             (old-plain (buffer-substring-no-properties start end))
             (new-plain (substring-no-properties replacement))
             (prefix (tp--common-prefix-length old-plain new-plain))
             (suffix (tp--common-suffix-length old-plain new-plain prefix))
             (old-end (- end suffix))
             (new-end (- (length replacement) suffix)))
        (unless (equal old-plain new-plain)
          (delete-region (+ start prefix) old-end)
          (goto-char (+ start prefix))
          (let ((inserted (substring replacement prefix new-end)))
            (insert inserted)
            (when (tp--validate-published-content-range
                   (tp--surface-buffer surface) (+ start prefix) inserted)
              (push (cons (+ (plist-get patch :new-start) prefix)
                          (+ (plist-get patch :new-start) new-end))
                    tp--content-published-ranges)))
          (cl-incf count))))
    (set-marker (tp--surface-start surface) base)
    (set-marker (tp--surface-end surface) (+ base (length rendered)))
    count))

(defun tp--publish-retained-content-text (prepared)
  "Publish a full-surface retained content candidate in one text operation.
The candidate proof guarantees that the retained surface scope is exactly the
surface range.  RENDERED already carries its final text properties, so a
delete/insert preserves the authoritative property runs without constructing
the generic property-operation ledger."
  (let* ((surface (tp--prepared-surface-surface prepared))
         (buffer (tp--surface-buffer surface))
         (rendered (tp--prepared-surface-rendered prepared))
         (range (tp--surface-range surface))
         (start (car range))
         (end (cdr range))
         (changed (not (equal-including-properties
                        (with-current-buffer buffer
                          (buffer-substring start end))
                        rendered))))
    (with-current-buffer buffer
      (let ((inhibit-read-only
             (plist-get (tp--surface-options surface) :inhibit-read-only)))
        (unless (= start (point))
          (goto-char start))
        (when changed
          (delete-region start end)
          (goto-char start)
          (insert rendered))
        (set-marker (tp--surface-start surface) start)
        (set-marker (tp--surface-end surface) (+ start (length rendered)))))
    (when changed
      (with-current-buffer buffer
        (unless (tp--validate-published-content-range buffer start rendered)
          (signal 'tp-publication-mismatch
                  (list :surface (tp--surface-id surface)
                        :reason 'retained-content-properties)))))
    (if changed 1 0)))

(defun tp--publish-buffer-content (prepared)
  "Publish PREPARED's text and properties, returning operation counts."
  (cl-block publish
    (when-let* ((batch (tp--prepared-surface-commit-batch prepared)))
      (let ((surface (tp--prepared-surface-surface prepared)))
        (tp--commit-batch-apply-patches surface batch)
        (tp--publication-step 'text surface)
        (tp--commit-batch-validate-buffer surface batch)
        (tp--publication-step 'property surface)
        (cl-return-from publish
          (cons (length (tp-commit-batch-patches batch)) 0))))
  (let* ((surface (tp--prepared-surface-surface prepared))
         (buffer (tp--surface-buffer surface))
         (rendered (tp--prepared-surface-rendered prepared))
         (scoped (tp--prepared-surface-scope-objects prepared))
         (fallback (tp--prepared-surface-scope-fallback prepared))
         (patches (tp--prepared-surface-scope-patches prepared))
         (text-operations 0)
         property-operations)
    (let (tp--content-published-ranges)
      (with-current-buffer buffer
        (let ((point-before (point)))
          (unwind-protect
              (save-restriction
            (widen)
            (let ((inhibit-read-only
                   (plist-get (tp--surface-options surface) :inhibit-read-only)))
              (setq text-operations
                    (if (tp--prepared-surface-retained-content-p prepared)
                        (tp--publish-retained-content-text prepared)
                      (if (and scoped (not fallback))
                          (tp--publish-scoped-content-text
                           surface rendered patches)
                        (tp--content-text-operation surface rendered))))
              (tp--publication-step 'text surface)
              (unless (tp--prepared-surface-retained-content-p prepared)
                (setq property-operations
                      (tp--content-property-operations
                       surface rendered
                       (and scoped (not fallback)
                            (tp--scoped-content-ranges patches))
                       (and scoped (not fallback))))
                (tp--apply-content-property-operations buffer property-operations)
                (tp--publication-step 'property surface))
              (when (tp--prepared-surface-retained-content-p prepared)
                (tp--publication-step 'property surface))))
            (goto-char (min point-before (point-max)))))
      (cons text-operations (length property-operations)))))))

(defun tp--publish-buffer-properties (prepared)
  "Publish PREPARED's host-range property operations."
  (let* ((surface (tp--prepared-surface-surface prepared))
         (operations (tp--prepared-surface-property-operations prepared)))
    (tp--publication-step 'text surface)
    (tp--apply-properties-operations surface operations)
    (tp--publication-step 'property surface)
    (cons 0 (length operations))))

(defun tp--promote-prepared-objects (prepared)
  "Promote PREPARED's touched identities to live state."
  (let ((surface (tp--prepared-surface-surface prepared))
        (context (tp--prepared-surface-context prepared)))
    (dolist (object (tp--prepared-surface-objects prepared))
      (setf (tp--surface-object-surface object) surface
            (tp--surface-object-live object) t
            (tp--surface-object-disposed object) nil
            (tp--surface-object-candidate-context object) nil))
    (setf (tp--context-active context) nil)))

(defun tp--swap-surface-state (prepared counts)
  "Promote PREPARED side state using operation COUNTS."
  (let* ((surface (tp--prepared-surface-surface prepared))
         (mounts (tp--prepared-surface-live-mounts prepared))
         (ledger (tp--prepared-surface-live-ledger prepared))
         (report (tp--surface-report-value prepared (car counts) (cdr counts))))
    (tp--promote-prepared-objects prepared)
    (setf (tp--surface-plan surface) (tp--prepared-surface-plan prepared)
          (tp--surface-objects surface)
          (if (tp--prepared-surface-retained-mount-state-p prepared)
              (tp--surface-objects surface)
            (tp--surface-object-table
             (tp--prepared-surface-objects prepared)))
          (tp--surface-mounts surface) mounts
          (tp--surface-index surface) mounts
          (tp--surface-mount-index surface)
          (tp--prepared-surface-live-mount-index prepared)
          (tp--surface-ledger surface) ledger
          (tp--surface-client-state surface)
          (tp--prepared-surface-client-state prepared)
          (tp--surface-producer surface) (tp--prepared-surface-producer prepared)
          (tp--surface-revision surface) (1+ (tp--surface-revision surface))
          (tp--surface-report surface) report
          (tp--surface-live surface) t
          (tp--surface-stale surface) nil
          (tp--prepared-surface-report prepared) report)
    (tp--publication-step 'client-state surface)
    (when (tp--prepared-surface-initial prepared)
      (tp--register-live-surface surface))))

(defun tp--publish-one-surface (prepared)
  "Publish PREPARED buffer and side state."
  (let* ((surface (tp--prepared-surface-surface prepared))
         (observed (tp--surface-observers surface))
         (started (and observed (tp--surface-observation-clock)))
         (counts (if (eq (tp--surface-capability surface) 'content)
                     (tp--publish-buffer-content prepared)
                   (tp--publish-buffer-properties prepared))))
    (if (tp--prepared-surface-retained-mount-state-p prepared)
        (tp--retain-candidate-mount-state prepared)
      (tp--create-candidate-mount-state prepared))
    (when-let* ((batch (and (not (tp--prepared-surface-retained-mount-state-p
                                 prepared))
                           (tp--prepared-surface-commit-batch prepared))))
      (tp--commit-batch-validate-mounts
       surface batch (tp--prepared-surface-live-mounts prepared)))
    (tp--publication-step 'marker surface)
    (tp--publication-step 'index surface)
    (tp--swap-surface-state prepared counts)
    (when started
      (let* ((duration-ms
              (* 1000.0 (- (tp--surface-observation-clock) started)))
             (report (tp--surface-report surface)))
        (setq report (plist-put report :provider 'tp)
              report (plist-put report :stage 'publication)
              report (plist-put report :duration-ms duration-ms)
              report (plist-put report :timing
                                (list :publication (/ duration-ms 1000.0))))
        (setf (tp--surface-report surface) report
              (tp--prepared-surface-report prepared) report)))))

(defun tp--journal-intervals (prepared-list)
  "Return buffer intervals whose properties PREPARED-LIST may mutate."
  (let (entries)
    (dolist (prepared prepared-list)
      (let ((surface (tp--prepared-surface-surface prepared)))
        (if (eq (tp--surface-capability surface) 'content)
            (if (and (tp--prepared-surface-scope-objects prepared)
                     (not (tp--prepared-surface-scope-fallback prepared)))
                (let ((base (marker-position (tp--surface-start surface))))
                  (dolist (patch (tp--prepared-surface-scope-patches prepared))
                    (push (list (tp--surface-buffer surface)
                                (+ base (plist-get patch :old-start))
                                (+ base (plist-get patch :old-end)))
                          entries)))
              (pcase-let ((`(,start . ,end) (tp--surface-range surface)))
                (push (list (tp--surface-buffer surface) start end) entries)))
          (dolist (operation
                   (tp--prepared-surface-property-operations prepared))
            (push (list (tp--surface-buffer surface)
                        (plist-get operation :start)
                        (plist-get operation :end))
                  entries)))))
    entries))

(defun tp--merge-buffer-intervals (entries)
  "Merge overlapping journal ENTRIES per buffer."
  (let ((by-buffer (make-hash-table :test #'eq)) result)
    (dolist (entry entries)
      (push (cdr entry) (gethash (car entry) by-buffer)))
    (maphash
     (lambda (buffer intervals)
       (setq intervals (sort intervals (lambda (a b) (< (car a) (car b)))))
       (let (merged)
         (dolist (interval intervals)
           (if (and merged (<= (car interval) (cadar merged)))
               (setcar (cdar merged) (max (cadar merged) (cadr interval)))
             (push (copy-sequence interval) merged)))
         (dolist (interval (nreverse merged))
           (push (list buffer (car interval) (cadr interval)) result))))
     by-buffer)
    result))

(defun tp--capture-property-journals (prepared-list)
  "Capture direct property journals for PREPARED-LIST."
  (mapcar
   (lambda (entry)
     (pcase-let ((`(,buffer ,start ,end) entry))
       (list buffer start end
             (with-current-buffer buffer
               (save-restriction
                 (widen) (buffer-substring start end))))))
   (tp--merge-buffer-intervals (tp--journal-intervals prepared-list))))

(defun tp--replay-string-properties (buffer start string)
  "Restore STRING's direct properties into BUFFER starting at START."
  (let ((length (length string)) (offset 0))
    (when (> length 0)
      (set-text-properties start (+ start length) nil buffer)
      (while (< offset length)
        (let ((next (next-property-change offset string length)))
          (set-text-properties (+ start offset) (+ start next)
                               (text-properties-at offset string) buffer)
          (setq offset next))))))

(defun tp--restore-property-journals (journals)
  "Restore direct property JOURNALS after buffer change cancellation."
  (dolist (journal journals)
    (pcase-let ((`(,buffer ,start ,_end ,string) journal))
      (when (buffer-live-p buffer)
        (with-current-buffer buffer
          (save-restriction
            (widen)
            (let ((inhibit-read-only t))
              (with-silent-modifications
                (tp--replay-string-properties buffer start string)))))))))

(defun tp--prepared-buffers (prepared-list)
  "Return distinct live buffers affected by PREPARED-LIST."
  (let ((seen (make-hash-table :test #'eq)) buffers)
    (dolist (prepared prepared-list)
      (let ((buffer
             (tp--surface-buffer (tp--prepared-surface-surface prepared))))
        (unless (gethash buffer seen)
          (puthash buffer t seen)
          (push buffer buffers))))
    (nreverse buffers)))

(defun tp--capture-view-state (buffers)
  "Capture point, windows, and modified state for BUFFERS."
  (let (states success)
    (unwind-protect
        (progn
          (dolist (buffer buffers)
            (with-current-buffer buffer
              (let ((state
                     ;; Point is a cursor location, not an insertion anchor:
                     ;; content publication must not make it follow a patch
                     ;; to the end of the inserted text.
                     (list buffer (copy-marker (point) nil)
                           (buffer-modified-p) nil)))
                (push state states)
                (dolist (window (get-buffer-window-list buffer nil t))
                  (push (cons window
                              (copy-marker (window-start window) nil))
                        (nth 3 state)))
                (setf (nth 3 state) (nreverse (nth 3 state))))))
          (setq states (nreverse states)
                success t)
          states)
      (unless success (tp--dispose-view-state states)))))

(defun tp--dispose-view-state (states)
  "Dispose marker storage retained by captured view STATES."
  (dolist (state states)
    (pcase-let ((`(,_buffer ,point-marker ,_modified ,windows) state))
      (tp--dispose-marker point-marker)
      (dolist (entry windows) (tp--dispose-marker (cdr entry))))))

(defun tp--restore-view-state (states &optional retain-markers)
  "Restore captured point, window, and modified STATES.
When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
  (dolist (state states)
    (pcase-let ((`(,buffer ,point-marker ,modified ,windows) state))
      (when (buffer-live-p buffer)
        (with-current-buffer buffer
          (when-let* ((position (marker-position point-marker)))
            (goto-char (min (point-max) (max (point-min) position))))
          (set-buffer-modified-p modified))
        (dolist (entry windows)
          (when (window-live-p (car entry))
            (when-let* ((position (marker-position (cdr entry))))
              (set-window-start (car entry) position t)))))
      (unless retain-markers
        (tp--dispose-marker point-marker)
        (dolist (entry windows) (tp--dispose-marker (cdr entry)))))))

(defun tp--dispose-content-mounts (mounts)
  "Detach private markers owned by content MOUNTS."
  (dolist (mount mounts)
    (when (eq (tp--surface-mount-capability mount) 'content)
      (tp--dispose-marker (tp--surface-mount-start mount))
      (tp--dispose-marker (tp--surface-mount-end mount)))))

(defun tp--dispose-ledger (ledger)
  "Detach interval markers owned by property LEDGER entries."
  (dolist (entry ledger)
    (tp--dispose-marker (tp--property-ledger-start entry))
    (tp--dispose-marker (tp--property-ledger-end entry))))

(defun tp--unregister-surface (surface)
  "Remove SURFACE from weak and buffer-local registries."
  (remhash (tp--surface-id surface) tp--surfaces)
  (when (buffer-live-p (tp--surface-buffer surface))
    (with-current-buffer (tp--surface-buffer surface)
      (setq tp--buffer-surfaces (delq surface tp--buffer-surfaces))
      (unless tp--buffer-surfaces
        (remove-hook 'before-change-functions #'tp--surface-before-change t)
        (remove-hook 'after-change-functions #'tp--surface-after-change t)
        (remove-hook 'kill-buffer-hook #'tp--surface-buffer-killed t)))))

(defun tp--restore-surface-snapshot (prepared snapshot)
  "Restore PREPARED's surface from SNAPSHOT after failed publication."
  (let ((surface (tp--prepared-surface-surface prepared)))
    (tp--restore-retained-mount-state prepared)
    (tp--dispose-content-mounts
     (tp--prepared-surface-live-mounts prepared))
    (tp--dispose-ledger (tp--prepared-surface-live-ledger prepared))
    (if (not (buffer-live-p (tp--surface-buffer surface)))
        (progn
          (when (tp--surface-snapshot-objects snapshot)
            (maphash (lambda (_path object)
                       (setf (tp--surface-object-live object) nil
                             (tp--surface-object-disposed object) t))
                     (tp--surface-snapshot-objects snapshot)))
          (setf (tp--surface-live surface) nil
                (tp--surface-stale surface) 'killed
                (tp--surface-objects surface)
                (tp--surface-snapshot-objects snapshot)
                (tp--surface-mounts surface)
                (tp--surface-snapshot-mounts snapshot)
                (tp--surface-index surface)
                (tp--surface-snapshot-index snapshot)
            (tp--surface-mount-index surface)
            (tp--surface-snapshot-mount-index snapshot)
            (tp--surface-ledger surface)
            (tp--surface-snapshot-ledger snapshot)))
      (when (and (tp--surface-live surface)
                 (not (tp--surface-snapshot-live snapshot)))
        (tp--unregister-surface surface))
      (dolist (object (tp--prepared-surface-created prepared))
        (setf (tp--surface-object-live object) nil
              (tp--surface-object-disposed object) t))
      (when (tp--surface-snapshot-objects snapshot)
        (maphash (lambda (_path object)
                   (setf (tp--surface-object-live object)
                         (tp--surface-snapshot-live snapshot)
                         (tp--surface-object-disposed object) nil))
                 (tp--surface-snapshot-objects snapshot)))
          (setf (tp--surface-plan surface) (tp--surface-snapshot-plan snapshot)
            (tp--surface-objects surface) (tp--surface-snapshot-objects snapshot)
            (tp--surface-mounts surface) (tp--surface-snapshot-mounts snapshot)
            (tp--surface-index surface) (tp--surface-snapshot-index snapshot)
            (tp--surface-mount-index surface)
            (tp--surface-snapshot-mount-index snapshot)
            (tp--surface-ledger surface) (tp--surface-snapshot-ledger snapshot)
            (tp--surface-client-state surface)
            (tp--surface-snapshot-client-state snapshot)
            (tp--surface-producer surface)
            (tp--surface-snapshot-producer snapshot)
            (tp--surface-revision surface)
            (tp--surface-snapshot-revision snapshot)
            (tp--surface-report surface) (tp--surface-snapshot-report snapshot)
            (tp--surface-live surface) (tp--surface-snapshot-live snapshot)
            (tp--surface-stale surface) (tp--surface-snapshot-stale snapshot)))))

(defun tp--prepare-change-group-for-buffers (buffers)
  "Prepare and activate one multi-buffer change group for BUFFERS."
  (let (handle success)
    (unwind-protect
        (progn
          (dolist (buffer buffers)
            (unless (buffer-live-p buffer)
              (signal 'tp-dead-surface (list buffer)))
            (setq handle (nconc handle (prepare-change-group buffer))))
          (activate-change-group handle)
          (setq success t)
          handle)
      (unless success (tp--cancel-change-group-safely handle)))))

(defun tp--surface-state-snapshots (prepared-list)
  "Return side-state snapshots for PREPARED-LIST."
  (mapcar (lambda (prepared)
            (cons prepared
                  (tp--surface-snapshot
                   (tp--prepared-surface-surface prepared))))
          prepared-list))

(defun tp--surface-publish-transaction ()
  "Prepare journals and publish every queued changed surface atomically."
  (let* ((state (tp--surface-extension-state))
         (table (gethash 'prepared state))
         (prepared (and table (tp--sorted-prepared-surfaces table))))
    (when prepared
      (let* ((buffers (tp--prepared-buffers prepared))
             (journals (tp--capture-property-journals prepared))
             (views (tp--capture-view-state buffers))
             snapshots group)
        (puthash 'changed prepared state)
        (puthash 'journals journals state)
        (puthash 'views views state)
        (setq snapshots (tp--surface-state-snapshots prepared))
        (puthash 'snapshots snapshots state)
        (setq group (tp--prepare-change-group-for-buffers buffers))
        (puthash 'change-group group state)
        (puthash 'surface-transaction-id-before
                 tp--surface-transaction-id state)
        (cl-incf tp--surface-transaction-id)
        (let ((tp--surface-publishing t))
          (dolist (candidate prepared)
            (tp--publish-one-surface candidate)))))))

(defun tp--surface-precommit-step (step state)
  "Report precommit STEP for transaction STATE."
  (when tp--surface-precommit-step-function
    (funcall tp--surface-precommit-step-function step state)))

(defun tp--validate-retained-batch-precommit (prepared snapshot)
  "Validate PREPARED retained batch from constant-time committed identities."
  (let* ((surface (tp--prepared-surface-surface prepared))
         (batch (tp--prepared-surface-commit-batch prepared))
         (mounts (tp--surface-mounts surface))
         (mount-index (tp--surface-mount-index surface)))
    (tp--validate-live-surface surface)
    (unless (and batch
                 (eq (tp--surface-plan surface)
                     (tp--prepared-surface-plan prepared))
                 (eq (tp--surface-objects surface)
                     (tp--surface-snapshot-objects snapshot))
                 (eq mounts (tp--surface-snapshot-mounts snapshot))
                 (eq mount-index
                     (tp--surface-snapshot-mount-index snapshot))
                 (eq (tp--surface-index surface) mounts)
                 (eq (tp--prepared-surface-live-mounts prepared) mounts)
                 (eq (tp--prepared-surface-live-mount-index prepared)
                     mount-index)
                 (= (tp--surface-revision surface)
                    (tp-commit-batch-target-revision batch))
                 (not (tp--context-active
                       (tp--prepared-surface-context prepared)))
                 (plist-get (tp--surface-report surface) :commit-batch)
                 (plist-get (tp--surface-report surface)
                            :retained-mount-state))
      (signal 'tp-surface-error
              (list :invalid-retained-batch-precommit
                    (tp--surface-id surface))))))

(defun tp--validate-surface-precommit (state)
  "Validate final published semantics and rollback ownership in STATE."
  (unless (and (gethash 'change-group state)
               (listp (gethash 'changed state))
               (listp (gethash 'snapshots state))
               (listp (gethash 'views state)))
    (signal 'tp-surface-error (list :invalid-precommit-state)))
  (dolist (view (gethash 'views state))
    (unless (and (bufferp (nth 0 view))
                 (markerp (nth 1 view))
                 (cl-every (lambda (entry) (markerp (cdr entry)))
                           (nth 3 view)))
      (signal 'tp-surface-error (list :invalid-view-cleanup view))))
  (dolist (entry (gethash 'snapshots state))
    (unless (and (tp--prepared-surface-p (car entry))
                 (tp--surface-snapshot-p (cdr entry)))
      (signal 'tp-surface-error (list :invalid-surface-cleanup entry)))
    (let ((prepared (car entry))
          (snapshot (cdr entry)))
      (if (tp--prepared-surface-retained-mount-state-p prepared)
          (tp--validate-retained-batch-precommit prepared snapshot)
        (let* ((surface (tp--prepared-surface-surface prepared))
               (plan (tp--surface-plan surface))
               (objects (tp--surface-objects surface))
               (mounts (tp--surface-mounts surface))
               (mount-index (tp--surface-mount-index surface))
               (capability (tp--surface-capability surface))
               (mount-set (make-hash-table :test #'eq))
               (indexed-mount-set (make-hash-table :test #'eq)))
      (tp--validate-live-surface surface)
      (unless (eq plan (tp--prepared-surface-plan prepared))
        (signal 'tp-surface-error (list :invalid-published-plan surface)))
      (tp--validate-surface-plan-tree plan)
      (tp--validate-plan-capability plan capability)
      (tp--validate-context-tree (tp--prepared-surface-context prepared) plan)
      (unless (and (hash-table-p objects) (hash-table-p mount-index)
                   (eq (tp--surface-index surface) mounts))
        (signal 'tp-surface-error (list :invalid-published-index surface)))
      (maphash
       (lambda (path object)
         (unless (and (tp-object-p object)
                      (equal path (tp--surface-object-path object))
                      (eq (tp--surface-object-surface object) surface)
                      (tp--surface-object-live object)
                      (not (tp--surface-object-disposed object))
                      (null (tp--surface-object-candidate-context object)))
           (signal 'tp-surface-error
                   (list :invalid-published-object path object))))
       objects)
      (dolist (mount mounts)
        (when (gethash mount mount-set)
          (signal 'tp-surface-error
                  (list :duplicate-published-mount mount)))
        (puthash mount t mount-set))
      (maphash
       (lambda (object entries)
         (unless (and (tp-object-p object)
                      (eq (gethash (tp--surface-object-path object) objects)
                          object))
           (signal 'tp-surface-error
                   (list :invalid-mount-index-owner object)))
         (dolist (mount entries)
           (unless (and (gethash mount mount-set)
                        (eq (tp--surface-mount-object mount) object)
                        (not (gethash mount indexed-mount-set)))
             (signal 'tp-surface-error
                     (list :invalid-mount-index-entry object mount)))
           (puthash mount t indexed-mount-set)))
       mount-index)
      (unless (= (hash-table-count mount-set)
                 (hash-table-count indexed-mount-set))
        (signal 'tp-surface-error (list :incomplete-mount-index surface)))
      (dolist (mount mounts)
        (let ((object (and (tp--surface-mount-p mount)
                           (tp--surface-mount-object mount))))
          (unless (and object
                       (eq (gethash (tp--surface-object-path object) objects)
                           object)
                       (eq (tp--surface-mount-capability mount) capability)
                       (gethash mount indexed-mount-set))
            (signal 'tp-surface-error
                    (list :invalid-published-mount mount)))
          (tp--validate-buffer-range
           (tp--surface-buffer surface)
           (tp--surface-mount-start mount)
           (tp--surface-mount-end mount))
          (if (eq capability 'properties)
              (let ((anchor (tp--surface-mount-anchor mount)))
                (tp--validate-anchor anchor surface)
                (unless (and (eq (tp--surface-mount-start mount)
                                 (tp--anchor-start anchor))
                             (eq (tp--surface-mount-end mount)
                                 (tp--anchor-end anchor)))
                  (signal 'tp-surface-error
                          (list :invalid-published-anchor mount))))
            (when (tp--surface-mount-anchor mount)
              (signal 'tp-surface-error
                      (list :invalid-content-anchor mount)))))))))
  state))

(defun tp--surface-prevalidate-cleanup (state)
  "Validate marker-backed cleanup lists retained in surface STATE."
  (dolist (entry (gethash 'snapshots state))
    (let ((prepared (car entry)))
      (unless (tp--prepared-surface-retained-mount-state-p prepared)
        (let* ((snapshot (cdr entry))
               (surface (tp--prepared-surface-surface prepared))
               (coordinate-p
                (plist-get (tp--surface-options surface) :coordinate-mounts)))
          (dolist (mount (tp--surface-snapshot-mounts snapshot))
            (when (eq (tp--surface-mount-capability mount) 'content)
              (unless (or (and (markerp (tp--surface-mount-start mount))
                               (markerp (tp--surface-mount-end mount)))
                          (and coordinate-p
                               (integerp (tp--surface-mount-start mount))
                               (integerp (tp--surface-mount-end mount))))
                (signal 'tp-surface-error
                        (list :invalid-mount-cleanup mount)))))
          (dolist (ledger (tp--surface-snapshot-ledger snapshot))
            (unless (and (markerp (tp--property-ledger-start ledger))
                         (markerp (tp--property-ledger-end ledger)))
              (signal 'tp-surface-error
                      (list :invalid-ledger-cleanup ledger))))))))
  state)

(defun tp--surface-final-accept ()
  "Accept the active surface transaction's prepared change group."
  (when-let* ((state (tp--transaction-extension tp--surface-extension-key)))
    (when-let* ((group (gethash 'change-group state)))
      (accept-change-group group))))

(defun tp--surface-precommit-transaction ()
  "Prepare every fallible surface transition before signal commit."
  (when-let* ((state (tp--transaction-extension tp--surface-extension-key)))
    (when-let* ((table (gethash 'prepared state)))
      (let ((all-prepared (tp--all-prepared-surfaces table))
            (changed (gethash 'changed state)))
        (when changed
          (tp--surface-precommit-step 'validate state)
          (tp--validate-surface-precommit state)
          (tp--surface-precommit-step 'view state)
          (tp--restore-view-state (gethash 'views state) t)
          (tp--surface-precommit-step 'anchors state)
          (let (anchors)
            (dolist (entry (gethash 'snapshots state))
              (let* ((prepared (car entry))
                     (snapshot (cdr entry))
                     (surface (tp--prepared-surface-surface prepared)))
                (unless (tp--prepared-surface-retained-mount-state-p prepared)
                  (dolist (mounts
                           (list (tp--surface-snapshot-mounts snapshot)
                                 (tp--surface-mounts surface)))
                    (dolist (mount mounts)
                      (when-let* ((anchor (tp--surface-mount-anchor mount)))
                        (push anchor anchors)))))))
            (puthash 'anchor-undo
                     (tp--capture-anchor-ownership-undo (nreverse anchors))
                     state))
          (dolist (entry (gethash 'snapshots state))
            (let* ((prepared (car entry))
                   (snapshot (cdr entry))
                   (surface (tp--prepared-surface-surface prepared)))
              (unless (tp--prepared-surface-retained-mount-state-p prepared)
                (tp--apply-anchor-ownership
                 surface (tp--surface-snapshot-mounts snapshot)
                 (tp--surface-mounts surface))))))
        (tp--surface-precommit-step 'lifecycle state)
        (dolist (prepared all-prepared)
          (tp--finalize-object-lifecycle prepared)
          (tp--surface-precommit-step 'lifecycle-finalized state))
        (when changed
          (tp--surface-precommit-step 'observers state)
          (dolist (prepared changed)
            (tp--enqueue-surface-observers
             (tp--prepared-surface-surface prepared)))
          (tp--surface-precommit-step 'cleanup state)
          (tp--surface-prevalidate-cleanup state)
          (tp--transaction-install-final-accept
           #'tp--surface-final-accept))))))

(defun tp--cancel-change-group-safely (group)
  "Cancel active change GROUP without allowing quit to interrupt rollback."
  (when group
    (let ((inhibit-quit t)
          (inhibit-modification-hooks t)
          (tp--surface-publishing t))
      (condition-case nil
          (cancel-change-group group)
        ((error quit) nil)))))

(defun tp--cancel-change-group-for-rollback (group)
  "Cancel active change GROUP while allowing failure aggregation."
  (when group
    (let ((inhibit-quit t)
          (inhibit-modification-hooks t)
          (tp--surface-publishing t))
      (cancel-change-group group))))

(defun tp--surface-rollback-transaction ()
  "Rollback buffers, side state, markers, and contexts for this transaction."
  (when-let* ((state (tp--transaction-extension tp--surface-extension-key)))
    (let (failures)
      (cl-labels
          ((attempt (owner function)
             (condition-case failure
                 (funcall function)
               ((error quit)
                (push (list owner failure) failures)))))
        (attempt 'change-group
                 (lambda ()
                   (tp--cancel-change-group-for-rollback
                    (gethash 'change-group state))))
        (attempt 'properties
                 (lambda ()
                   (tp--restore-property-journals
                    (gethash 'journals state))))
        (dolist (entry (gethash 'snapshots state))
          (attempt
           (list 'surface
                 (tp--surface-id
                  (tp--prepared-surface-surface (car entry))))
           (lambda ()
             (tp--restore-surface-snapshot (car entry) (cdr entry)))))
        (attempt 'view
                 (lambda ()
                   (tp--restore-view-state (gethash 'views state))))
        (attempt 'anchors
                 (lambda ()
                   (tp--undo-anchor-ownership
                    (gethash 'anchor-undo state))))
        (attempt 'surface-counter
                 (lambda ()
                   (when (gethash 'surface-transaction-id-before state)
                     (setq tp--surface-transaction-id
                           (gethash 'surface-transaction-id-before state))))))
        (when failures
          (signal 'tp-surface-rollback-error
                  (list :failures (nreverse failures)))))))

(defun tp--surface-finalize-killed-rollback ()
  "Dispose candidate contexts and reapply killed-buffer teardown."
  (when-let* ((state (tp--transaction-extension tp--surface-extension-key)))
    (let (failures)
      (when-let* ((table (gethash 'prepared state)))
        (dolist (prepared (tp--all-prepared-surfaces table))
          (let ((surface (tp--prepared-surface-surface prepared)))
            (condition-case failure
                (let ((context (tp--prepared-surface-context prepared)))
                  (setf (tp--context-active context) t)
                  (tp--discard-context context)
                  (unless (buffer-live-p (tp--surface-buffer surface))
                    (tp--teardown-surface surface t)))
              ((error quit)
               (push (list (tp--surface-id surface) failure)
                     failures))))))
      (when failures
        (signal 'tp-surface-rollback-error
                (list :finalize-failures (nreverse failures)))))))

(defun tp--anchors-in-mounts (mounts)
  "Return distinct range anchors referenced by MOUNTS."
  (let ((seen (make-hash-table :test #'eq)) anchors)
    (dolist (mount mounts)
      (when-let* ((anchor (tp--surface-mount-anchor mount)))
        (unless (gethash anchor seen)
          (puthash anchor t seen)
          (push anchor anchors))))
    (nreverse anchors)))

(defun tp--capture-anchor-ownership-undo (anchors)
  "Capture exact ownership undo entries for opaque ANCHORS."
  (let ((seen (make-hash-table :test #'eq)) undo)
    (dolist (anchor anchors)
      (unless (gethash anchor seen)
        (puthash anchor t seen)
        (push (list anchor (copy-sequence (tp--anchor-surfaces anchor))
                    (tp--anchor-candidate-context anchor))
              undo)))
    (nreverse undo)))

(defun tp--apply-anchor-ownership (surface old-mounts new-mounts)
  "Apply SURFACE ownership from OLD-MOUNTS to NEW-MOUNTS."
  (let ((old (tp--anchors-in-mounts old-mounts))
        (new (tp--anchors-in-mounts new-mounts))
        (new-set (make-hash-table :test #'eq)))
    (dolist (anchor new) (puthash anchor t new-set))
    (dolist (anchor old)
      (unless (gethash anchor new-set)
        (setf (tp--anchor-surfaces anchor)
              (delq surface (tp--anchor-surfaces anchor)))))
    (dolist (anchor new)
      (cl-pushnew surface (tp--anchor-surfaces anchor) :test #'eq)
      (setf (tp--anchor-candidate-context anchor) nil))))

(defun tp--undo-anchor-ownership (undo)
  "Restore anchors from ownership UNDO entries."
  (dolist (entry undo)
    (setf (tp--anchor-surfaces (nth 0 entry)) (nth 1 entry)
          (tp--anchor-candidate-context (nth 0 entry)) (nth 2 entry))))

(defun tp--finalize-object-lifecycle (prepared)
  "Delete omitted bindings and removed objects after PREPARED commits."
  (let* ((context (tp--prepared-surface-context prepared))
         (objects (tp--prepared-surface-objects prepared))
         (omitted (tp--context-binding-removals context objects)))
    (dolist (binding omitted)
      (when (tp-binding-live-p binding) (tp-binding-dispose binding)))
    (dolist (object (tp--prepared-surface-removed prepared))
      (tp-binding-dispose-owner object)
      (setf (tp--surface-object-live object) nil
            (tp--surface-object-disposed object) t))
    (setf (tp--context-active context) nil)))

(defun tp--record-observer-error (surface observer failure)
  "Record OBSERVER FAILURE in SURFACE's latest report."
  (let ((report (tp--copy-property-value (tp--surface-report surface))))
    (setq report
          (plist-put report :observer-errors
                     (append (plist-get report :observer-errors)
                             (list (list :observer observer :error failure)))))
    (setf (tp--surface-report surface) report)))

(defun tp--record-cleanup-error (surface owner failure)
  "Record contained cleanup OWNER FAILURE on SURFACE."
  (let ((report (tp--copy-property-value (tp--surface-report surface))))
    (setq report
          (plist-put report :cleanup-errors
                     (append (plist-get report :cleanup-errors)
                             (list (list :owner owner :error failure)))))
    (setf (tp--surface-report surface) report)))

(defun tp--run-surface-observers (surface observers report)
  "Run SURFACE OBSERVERS with REPORT and record their errors."
  (dolist (observer observers)
    (let ((inhibit-quit t)
          (quit-flag nil))
      (condition-case failure
          (funcall observer surface report)
        ((error quit)
         (tp--record-observer-error surface observer failure))))))

(defun tp--enqueue-surface-observers (surface)
  "Schedule SURFACE observers outside the publishing transaction."
  (when-let* ((observers (tp--surface-observers surface)))
    (let ((observers (copy-sequence observers))
          (report (tp-surface-report surface)))
      (tp--enqueue-after-commit
       (lambda () (tp--run-surface-observers surface observers report))))))

(defun tp--surface-commit-transaction ()
  "Run contained postaccept cleanup for every transaction surface."
  (when-let* ((state (tp--transaction-extension tp--surface-extension-key)))
    (let ((changed (gethash 'changed state))
          (snapshots (gethash 'snapshots state)))
      (cl-labels
          ((cleanup (surface owner function)
             (let ((inhibit-quit t)
                   (quit-flag nil))
               (condition-case failure
                   (progn
                     (when tp--surface-cleanup-step-function
                       (funcall tp--surface-cleanup-step-function
                                surface owner))
                     (funcall function))
                 ((error quit)
                  (tp--record-cleanup-error surface owner failure))))))
        (when-let* ((prepared (car changed)))
          (cleanup
           (tp--prepared-surface-surface prepared) 'view-markers
           (lambda () (tp--dispose-view-state (gethash 'views state)))))
        (dolist (entry snapshots)
          (let* ((prepared (car entry))
                 (snapshot (cdr entry))
                 (surface (tp--prepared-surface-surface prepared)))
            (unless (tp--prepared-surface-retained-mount-state-p prepared)
              (dolist (anchor
                       (tp--anchors-in-mounts
                        (tp--surface-snapshot-mounts snapshot)))
                (when (null (tp--anchor-surfaces anchor))
                  (cleanup
                   surface (list 'old-anchor (tp--anchor-id anchor))
                   (lambda () (tp--dispose-anchor anchor)))))
              (cleanup
               surface 'old-mounts
               (lambda ()
                 (tp--dispose-content-mounts
                  (tp--surface-snapshot-mounts snapshot))))
              (cleanup
               surface 'old-ledger
               (lambda ()
                 (tp--dispose-ledger
                  (tp--surface-snapshot-ledger snapshot)))))))
        (when-let* ((table (gethash 'prepared state)))
          (dolist (prepared (tp--all-prepared-surfaces table))
            (let* ((surface (tp--prepared-surface-surface prepared))
                   (context (tp--prepared-surface-context prepared)))
              (dolist (anchor (tp--context-created-anchors context))
                (when (null (tp--anchor-surfaces anchor))
                  (cleanup
                   surface (list 'candidate-anchor (tp--anchor-id anchor))
                   (lambda () (tp--dispose-anchor anchor))))))))))))

(defun tp-surface-materialize-string (plan-or-producer)
  "Materialize PLAN-OR-PRODUCER without creating live runtime state."
  (let* ((surface (tp--make-surface
                   :id 0 :capability 'content :options nil
                   :objects (make-hash-table :test #'equal)))
         (context (tp--make-context surface t))
         (success nil)
         rendered)
    (unwind-protect
        (let* ((normalized
                (tp--prepare-input surface plan-or-producer nil context))
               (plan (car normalized))
               (owned-p (nth 2 normalized)))
          (tp--validate-plan-capability plan 'content)
          (tp--validate-context-tree context plan)
          (setq rendered (car (tp--render-plan plan context owned-p))
                success t)
          rendered)
      (setf (tp--context-active context) t)
      (tp--discard-context context)
      (unless success (setq rendered nil)))))

(defun tp--rebase-ledger-entry (surface entry)
  "Return current-property segments rebased from ledger ENTRY on SURFACE."
  (let* ((buffer (tp--surface-buffer surface))
         (start (tp--ledger-position (tp--property-ledger-start entry)))
         (end (tp--ledger-position (tp--property-ledger-end entry)))
         (property (tp--property-ledger-property entry))
         segments)
    (while (< start end)
      (let* ((next (with-current-buffer buffer
                     (next-single-property-change start property buffer end)))
             (state (tp--property-state-at buffer start property)))
        (push (tp--make-property-ledger
               :start (with-current-buffer buffer (copy-marker start nil))
               :end (with-current-buffer buffer (copy-marker next t))
               :property property :baseline-present (car state)
               :baseline-value (cdr state) :published-present (car state)
               :published-value (cdr state)
               :anchors (tp--property-ledger-anchors entry))
              segments)
        (setq start next)))
    (tp--dispose-marker (tp--property-ledger-start entry))
    (tp--dispose-marker (tp--property-ledger-end entry))
    (nreverse segments)))

(defun tp-range-rebase (anchor)
  "Accept current host properties as the new baseline for ANCHOR."
  (unless (tp-range-anchor-live-p anchor)
    (signal 'tp-invalid-range-anchor (list anchor)))
  (dolist (surface (copy-sequence (tp--anchor-surfaces anchor)))
    (when (tp-surface-live-p surface)
      (let (ledger)
        (dolist (entry (tp--surface-ledger surface))
          (setq ledger
                (nconc ledger
                       (if (memq anchor (tp--property-ledger-anchors entry))
                           (tp--rebase-ledger-entry surface entry)
                         (list entry)))))
        (setf (tp--surface-ledger surface) ledger))))
  (setf (tp--anchor-stale anchor) nil)
  anchor)

(defun tp--unmount-ledger-segments (surface entry)
  "Return SURFACE restoration operations and conflicts for ledger ENTRY."
  (let* ((buffer (tp--surface-buffer surface))
         (start (tp--ledger-position (tp--property-ledger-start entry)))
         (end (tp--ledger-position (tp--property-ledger-end entry)))
         (property (tp--property-ledger-property entry))
         (published (tp--ledger-published-state entry))
         operations conflicts)
    (while (< start end)
      (let* ((next (with-current-buffer buffer
                     (next-single-property-change start property buffer end)))
             (current (tp--property-state-at buffer start property)))
        (if (tp--property-state-equal-p current published)
            (push (list :start start :end next :property property
                        :present (tp--property-ledger-baseline-present entry)
                        :value (tp--property-ledger-baseline-value entry))
                  operations)
          (push (list :start start :end next :property property
                      :current current :published published)
                conflicts))
        (setq start next)))
    (cons (nreverse operations) (nreverse conflicts))))

(defun tp--unmount-property-operations (surface)
  "Return restoration operations and conflicts for SURFACE."
  (let (operations conflicts)
    (dolist (entry (tp--surface-ledger surface))
      (pcase-let ((`(,entry-operations . ,entry-conflicts)
                   (tp--unmount-ledger-segments surface entry)))
        (setq operations (nconc operations entry-operations)
              conflicts (nconc conflicts entry-conflicts))))
    (cons operations conflicts)))

(defun tp--unmount-journals (surface operations)
  "Capture property rollback journals for SURFACE and OPERATIONS."
  (let ((entries
         (if (eq (tp--surface-capability surface) 'content)
             (pcase-let ((`(,start . ,end) (tp--surface-range surface)))
               (list (list (tp--surface-buffer surface) start end)))
           (mapcar (lambda (operation)
                     (list (tp--surface-buffer surface)
                           (plist-get operation :start)
                           (plist-get operation :end)))
                   operations))))
    (mapcar
     (lambda (entry)
       (pcase-let ((`(,buffer ,start ,end) entry))
         (list buffer start end
               (with-current-buffer buffer (buffer-substring start end)))))
     (tp--merge-buffer-intervals entries))))

(defun tp--publish-unmount (surface operations)
  "Remove SURFACE content or apply property restoration OPERATIONS."
  (let ((buffer (tp--surface-buffer surface))
        (tp--surface-publishing t))
    (with-current-buffer buffer
      (save-restriction
        (widen)
        (let ((inhibit-read-only
               (plist-get (tp--surface-options surface) :inhibit-read-only)))
          (if (eq (tp--surface-capability surface) 'content)
              (pcase-let ((`(,start . ,end) (tp--surface-range surface)))
                (delete-region start end))
            (with-silent-modifications
              (dolist (operation operations)
                (tp--apply-property-operation buffer operation)))))))))

(defun tp--remove-surface-anchor-ownership (surface)
  "Detach SURFACE from every range anchor it owns."
  (dolist (anchor (tp--anchors-in-mounts (tp--surface-mounts surface)))
    (setf (tp--anchor-surfaces anchor)
          (delq surface (tp--anchor-surfaces anchor)))
    (unless (tp--anchor-surfaces anchor) (tp--dispose-anchor anchor))))

(defun tp--teardown-surface (surface killed)
  "Release SURFACE runtime state; KILLED means its buffer is gone."
  (when (tp-surface-p surface)
    (tp--unregister-surface surface)
    (tp-binding-dispose-owner surface)
    (when (tp--surface-objects surface)
      (maphash
       (lambda (_path object)
         (tp-binding-dispose-owner object)
         (setf (tp--surface-object-live object) nil
               (tp--surface-object-disposed object) t))
       (tp--surface-objects surface)))
    (tp--remove-surface-anchor-ownership surface)
    (tp--dispose-content-mounts (tp--surface-mounts surface))
    (tp--dispose-ledger (tp--surface-ledger surface))
    (tp--dispose-marker (tp--surface-start surface))
    (tp--dispose-marker (tp--surface-end surface))
    (setf (tp--surface-live surface) nil
          (tp--surface-stale surface) (and killed 'killed)
          (tp--surface-objects surface) (make-hash-table :test #'equal)
          (tp--surface-mounts surface) nil (tp--surface-index surface) nil
          (tp--surface-mount-index surface) (make-hash-table :test #'eq)
          (tp--surface-ledger surface) nil
          (tp--surface-client-state surface) nil
          (tp--surface-observers surface) nil)))

;;;###autoload
(defun tp-surface-unmount (surface)
  "Unmount SURFACE and return a generic report.
Properties-only mounts restore their baseline only when TP's last value still
owns the property; conflicting host values are preserved and reported."
  (tp--validate-live-surface surface)
  (when tp--transaction-active
    (signal 'tp-surface-error (list :unmount-during-transaction)))
  (let* ((property-result
          (if (eq (tp--surface-capability surface) 'properties)
              (tp--unmount-property-operations surface)
            (cons nil nil)))
         (operations (car property-result))
         (conflicts (cdr property-result))
         (journals (tp--unmount-journals surface operations))
         (views (tp--capture-view-state (list (tp--surface-buffer surface))))
         (group (tp--prepare-change-group-for-buffers
                 (list (tp--surface-buffer surface))))
         success)
    (unwind-protect
        (progn
          (tp--publish-unmount surface operations)
          (accept-change-group group)
          (setq success t))
      (unless success
        (tp--cancel-change-group-safely group)
        (tp--restore-property-journals journals))
      (tp--restore-view-state views))
    (let ((report (list :transaction-id (cl-incf tp--surface-transaction-id)
                        :surface-id (tp--surface-id surface)
                        :old-revision (tp--surface-revision surface)
                        :new-revision nil :text-operations
                        (if (eq (tp--surface-capability surface) 'content) 1 0)
                        :property-operations (length operations)
                        :property-conflicts conflicts :unmounted t)))
      (tp--teardown-surface surface nil)
      report)))

(defun tp-surface-at-point (&optional position buffer)
  "Return live objects mounted at POSITION in BUFFER from side indexes."
  (let ((target (if buffer (get-buffer buffer) (current-buffer)))
        objects)
    (unless (buffer-live-p target)
      (signal 'tp-unsupported-buffer (list buffer)))
    (with-current-buffer target
      (let ((point (or position (point))))
        (dolist (surface tp--buffer-surfaces)
          (dolist (mount (tp--surface-index surface))
            (let ((start (tp--mount-position (tp--surface-mount-start mount)))
                  (end (tp--mount-position (tp--surface-mount-end mount))))
              (when (and start end (<= start point) (< point end))
                (cl-pushnew (tp--surface-mount-object mount) objects
                            :test #'eq)))))))
    (sort objects
          (lambda (left right)
            (< (length (tp--surface-object-path left))
               (length (tp--surface-object-path right)))))))

(defun tp-surface-report (surface)
  "Return a defensive copy of SURFACE's latest generic commit report."
  (unless (tp-surface-p surface)
    (signal 'wrong-type-argument (list 'tp-surface-p surface)))
  (tp--copy-property-value (tp--surface-report surface)))

(defun tp-surface-report-summary (surface)
  "Return scalar commit metrics for SURFACE without copying its full report.
The returned plist contains only numbers, symbols, booleans, or nil.  Use
`tp-surface-report' when callers need arbitrary report payloads or a defensive
snapshot of nested values."
  (unless (tp-surface-p surface)
    (signal 'wrong-type-argument (list 'tp-surface-p surface)))
  (let ((report (tp--surface-report surface)))
    (list :transaction-id (plist-get report :transaction-id)
          :text-operations (plist-get report :text-operations)
          :property-operations (plist-get report :property-operations)
          :full-root (plist-get report :full-root)
          :scope-count (plist-get report :scope-count)
          :scope-range-count (plist-get report :scope-range-count)
          :scope-fallback (plist-get report :scope-fallback)
          :reconciled-objects (plist-get report :reconciled-objects)
          :created-objects (plist-get report :created-objects)
          :removed-objects (plist-get report :removed-objects)
          :moved-objects (plist-get report :moved-objects))))

(defun tp-surface-inspect (surface)
  "Return read-only retained diagnostics for SURFACE."
  (tp--validate-live-surface surface)
  (list :surface surface :id (tp--surface-id surface)
        :buffer (tp--surface-buffer surface)
        :capability (tp--surface-capability surface)
        :revision (tp--surface-revision surface)
        :object-count (hash-table-count (tp--surface-objects surface))
        :mount-count (length (tp--surface-mounts surface))
        :client-state (tp--surface-client-state surface)
        :report (tp-surface-report surface)))

(defun tp--watch-producer (anchor compute)
  "Return a properties producer backed by ANCHOR and COMPUTE."
  (lambda (context)
    (let* ((object (tp-object-ensure
                    context nil 'watch 'text-properties))
           (binding
            (tp-bind object '(tp/watch . declarations)
                     (lambda ()
                       (tp--project-text-declarations (funcall compute))))))
      (tp-object-attach-range context object anchor)
      (tp-surface-plan-create
       :key 'watch :kind 'text-properties
       :props (tp-binding-read binding) :capability 'properties))))

;;;###autoload
(defun tp-watch (buffer start end compute)
  "Reactively apply declarations from COMPUTE to BUFFER from START to END.
COMPUTE is a zero-argument function returning native text declarations.
Return the underlying properties-only surface for inspection or unmounting."
  (unless (functionp compute)
    (signal 'wrong-type-argument (list 'functionp compute)))
  (let ((anchor (tp-range-anchor-create buffer start end)) surface)
    (unwind-protect
        (setq surface
              (tp-surface-mount
               buffer (tp--watch-producer anchor compute)
               '(:capability properties :inhibit-read-only t)))
      (unless surface (tp--dispose-anchor anchor)))
    surface))

(add-hook 'tp--binding-changed-functions #'tp--surface-binding-changed)
(add-hook 'tp--transaction-publish-functions #'tp--surface-publish-transaction)
(tp--transaction-register-precommit-function
 'tp--surface-precommit-transaction)
(add-hook 'tp--transaction-rollback-functions #'tp--surface-rollback-transaction)
(add-hook 'tp--transaction-rollback-final-functions
          #'tp--surface-finalize-killed-rollback)
(add-hook 'tp--transaction-committed-functions #'tp--surface-commit-transaction)

(provide 'tp-surface)
;;; tp-surface.el ends here