;;; 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-producer-buffer-mutation
  "TP producer mutated a live surface buffer during prepare"
  'tp-surface-error)
(define-error 'tp-scope-mismatch "Scoped TP update changed outside its objects"
  '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)))
  "A producer result carrying PLAN and opaque CLIENT-STATE."
  plan client-state)

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

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

(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-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--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--copy-surface-plan (plan)
  "Return a validated defensive copy of PLAN."
  (unless (tp-surface-plan-p plan)
    (signal 'wrong-type-argument (list 'tp-surface-plan-p plan)))
  (let* ((children (mapcar #'tp--copy-surface-plan
                           (tp-surface-plan-children plan)))
         (kind (tp--copy-property-value (tp-surface-plan-kind plan)))
         (text (tp--copy-property-value (tp-surface-plan-text plan)))
         (props (tp--copy-property-value (tp-surface-plan-props plan)))
         (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))
     :kind kind :text text :props props :children children
     :tags (tp--copy-property-value (tp-surface-plan-tags plan))
     :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)))

(defun tp-surface-result-create (plan &optional client-state)
  "Return a producer result containing PLAN and opaque CLIENT-STATE."
  (tp--make-surface-result (tp--copy-surface-plan plan) client-state))

(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-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-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 (marker-position (tp--surface-mount-start mount))
             :end (marker-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)
   :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))
               (gethash object (tp--context-touched 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-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--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)
  "Return a fresh plist where CHILD values override PARENT values."
  (let ((result (tp--copy-property-value parent)))
    (cl-loop for (property value) on child by #'cddr
             do (setq result
                      (plist-put result property
                                 (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)
  "Return PLAN's propertized string and side records in CONTEXT."
  (let (records)
    (cl-labels
        ((walk (node path inherited offset)
           (let* ((props (tp--plist-overlay
                          inherited (tp-surface-plan-props node)))
                  (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))
                     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 (object _present)
               (puthash (tp--surface-object-path object) object actual))
             (tp--context-touched 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)
  "Normalize producer VALUE for SURFACE using OPTIONS."
  (cond
   ((tp-surface-result-p value)
    (cons (tp--copy-surface-plan (tp-surface-result-plan value))
          (tp-surface-result-client-state value)))
   ((tp-surface-plan-p value)
    (cons (tp--copy-surface-plan value)
          (if (plist-member options :client-state)
              (plist-get options :client-state)
            (tp--surface-client-state surface))))
   (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 objects."
  (let (objects)
    (maphash (lambda (object _present) (push object objects))
             (tp--context-touched context))
    objects))

(defun tp--content-mount-spec (object record &optional tags)
  "Return one content mount spec for OBJECT over RECORD with TAGS."
  (list :object object :start (plist-get record :start)
        :end (plist-get record :end)
        :tags (tp--copy-property-value
               (if tags tags (plist-get record :tags)))))

(defun tp--content-mount-specs (records context)
  "Return direct and logical-fragment mount specs for RECORDS in CONTEXT."
  (let (specs)
    (dolist (record records)
      (let* ((fragment (plist-get record :object))
             (attachments
              (nreverse
               (copy-sequence
                (gethash fragment
                         (tp--context-fragment-attachments context))))))
        (push (tp--content-mount-spec fragment record) specs)
        (dolist (attachment attachments)
          (push (tp--content-mount-spec
                 (car attachment) record (cdr attachment))
                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 (marker-position (tp--surface-mount-start mount)))
                  (end (marker-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)
      (let ((plan (tp--copy-surface-plan input)))
        (tp--ensure-plan-objects context plan)
        (tp--producer-result plan surface options)))))

(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--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 (marker-position (tp--surface-mount-start mount)))
              (end (marker-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--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 (equal-including-properties
                 (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)))
    (when (equal-including-properties
           (tp--substring-ranges old old-outside)
           (tp--substring-ranges new new-outside))
      (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-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))))
               (plan (car normalized))
               (client-state (cdr 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))
               (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 (- (length objects) (length 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))

(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 (copy-sequence (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, :client-state, and :observers.  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-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'.  Its default, `error', signals
`tp-scope-mismatch'; `root' permits an explicit full-surface fallback."
  (tp--validate-live-surface surface)
  (setq objects (tp--normalize-surface-scopes surface objects))
  (let ((on-mismatch (or (plist-get options :on-mismatch) 'error)))
    (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)))))
  (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)
                    (- (marker-position (tp--surface-mount-start mount)) base)
                    (- (marker-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--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--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))
      (insert (substring new prefix (- (length new) suffix))))
    (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."
  (cl-loop for offset from from below to
           thereis
           (not (tp--plan-props-equal-p
                 (text-properties-at (+ start offset) buffer)
                 (text-properties-at offset rendered)))))

(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)))))
         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 marker-backed content mounts for PREPARED."
  (let* ((surface (tp--prepared-surface-surface prepared))
         (buffer (tp--surface-buffer surface))
         (base (marker-position (tp--surface-start surface))))
    (mapcar
     (lambda (spec)
       (tp--make-surface-mount
        :object (plist-get spec :object)
        :start (with-current-buffer buffer
                 (copy-marker (+ base (plist-get spec :start)) nil))
        :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--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 (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
          :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
          :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))
             (plain (substring-no-properties replacement)))
        (unless (equal (buffer-substring-no-properties start end) plain)
          (delete-region start end)
          (goto-char start)
          (insert plain)
          (cl-incf count))))
    (set-marker (tp--surface-start surface) base)
    (set-marker (tp--surface-end surface) (+ base (length rendered)))
    count))

(defun tp--publish-buffer-content (prepared)
  "Publish PREPARED's text and properties, returning operation counts."
  (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)
    (with-current-buffer buffer
      (save-restriction
        (widen)
        (let ((inhibit-read-only
               (plist-get (tp--surface-options surface) :inhibit-read-only)))
          (setq text-operations
                (if (and scoped (not fallback))
                    (tp--publish-scoped-content-text
                     surface rendered patches)
                  (tp--content-text-operation surface rendered)))
          (tp--publication-step 'text surface)
          (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))))
    (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)
          (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* ((started (float-time))
         (surface (tp--prepared-surface-surface prepared))
         (counts (if (eq (tp--surface-capability surface) 'content)
                     (tp--publish-buffer-content prepared)
                   (tp--publish-buffer-properties prepared))))
    (tp--create-candidate-mount-state prepared)
    (tp--publication-step 'marker surface)
    (tp--publication-step 'index surface)
    (tp--swap-surface-state prepared counts)
    (let ((report (plist-put (tp--surface-report surface) :timing
                             (list :publication (- (float-time) started)))))
      (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."
  (delete-dups
   (mapcar (lambda (prepared)
             (tp--surface-buffer (tp--prepared-surface-surface prepared)))
           prepared-list)))

(defun tp--capture-view-state (buffers)
  "Capture point, windows, and modified state for BUFFERS."
  (mapcar
   (lambda (buffer)
     (with-current-buffer buffer
       (list buffer (copy-marker (point) t) (buffer-modified-p)
             (mapcar (lambda (window)
                       (cons window (copy-marker (window-start window) nil)))
                     (get-buffer-window-list buffer nil t)))))
   buffers))

(defun tp--restore-view-state (states)
  "Restore captured point, window, and modified STATES."
  (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)))))
      (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--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)
    (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)
    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 (tp--surface-state-snapshots prepared))
             (group (tp--prepare-change-group-for-buffers buffers)))
        (puthash 'changed prepared state)
        (puthash 'journals journals state)
        (puthash 'views views state)
        (puthash 'snapshots snapshots state)
        (puthash 'change-group group state)
        (cl-incf tp--surface-transaction-id)
        (let ((tp--surface-publishing t))
          (dolist (candidate prepared)
            (tp--publish-one-surface candidate)))))))

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

(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)))
    (tp--cancel-change-group-safely (gethash 'change-group state))
    (tp--restore-property-journals (gethash 'journals state))
    (dolist (entry (gethash 'snapshots state))
      (tp--restore-surface-snapshot (car entry) (cdr entry)))
    (tp--restore-view-state (gethash 'views state))
    (when-let ((table (gethash 'prepared state)))
      (maphash (lambda (_surface prepared)
                 (let ((context (tp--prepared-surface-context prepared)))
                   (setf (tp--context-active context) t)
                   (tp--discard-context context)))
               table))))

(defun tp--surface-finalize-killed-rollback ()
  "Reapply authoritative teardown after graph rollback for killed buffers."
  (when-let ((state (tp--transaction-extension tp--surface-extension-key)))
    (when-let ((table (gethash 'prepared state)))
      (maphash
       (lambda (surface _prepared)
         (unless (buffer-live-p (tp--surface-buffer surface))
           (tp--teardown-surface surface t)))
       table))))

(defun tp--anchors-in-mounts (mounts)
  "Return distinct range anchors referenced by MOUNTS."
  (delete-dups
   (delq nil (mapcar #'tp--surface-mount-anchor mounts))))

(defun tp--update-anchor-ownership (surface old-mounts new-mounts)
  "Update anchor ownership for SURFACE from OLD-MOUNTS to NEW-MOUNTS."
  (let ((old (tp--anchors-in-mounts old-mounts))
        (new (tp--anchors-in-mounts new-mounts)))
    (dolist (anchor old)
      (unless (memq anchor new)
        (setf (tp--anchor-surfaces anchor)
              (delq surface (tp--anchor-surfaces anchor)))
        (unless (tp--anchor-surfaces anchor) (tp--dispose-anchor anchor))))
    (dolist (anchor new)
      (cl-pushnew surface (tp--anchor-surfaces anchor) :test #'eq)
      (setf (tp--anchor-candidate-context anchor) nil))))

(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--finalize-context (prepared published)
  "Finalize PREPARED after commit; PUBLISHED means side state was swapped."
  (let* ((surface (tp--prepared-surface-surface prepared))
         (context (tp--prepared-surface-context prepared)))
    (if published
        (progn
          (tp--finalize-object-lifecycle prepared)
          (dolist (anchor (tp--context-created-anchors context))
            (unless (tp--anchor-surfaces anchor) (tp--dispose-anchor anchor))))
      (tp--finalize-object-lifecycle prepared)
      (dolist (object (tp--context-new-objects context))
        (unless (tp--surface-object-live object)
          (setf (tp--surface-object-disposed object) t)))
      (dolist (anchor (tp--context-created-anchors context))
        (unless (memq surface (tp--anchor-surfaces anchor))
          (tp--dispose-anchor anchor))))))

(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--run-surface-observers (surface observers report)
  "Run SURFACE OBSERVERS with REPORT and record their errors."
  (dolist (observer observers)
    (condition-case failure
        (funcall observer surface report)
      (error (tp--record-observer-error surface observer failure)))))

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

(defun tp--surface-commit-transaction ()
  "Commit buffer edits and finalize every transaction surface."
  (when-let ((state (tp--transaction-extension tp--surface-extension-key)))
    (when-let ((group (gethash 'change-group state)))
      (accept-change-group group))
    (tp--restore-view-state (gethash 'views state))
    (let ((changed (gethash 'changed state))
          (snapshots (gethash 'snapshots state)))
      (dolist (entry snapshots)
        (let* ((prepared (car entry))
               (snapshot (cdr entry))
               (surface (tp--prepared-surface-surface prepared)))
          (tp--update-anchor-ownership
           surface (tp--surface-snapshot-mounts snapshot)
           (tp--surface-mounts surface))
          (tp--dispose-content-mounts (tp--surface-snapshot-mounts snapshot))
          (tp--dispose-ledger (tp--surface-snapshot-ledger snapshot))))
      (when-let ((table (gethash 'prepared state)))
        (maphash (lambda (_surface prepared)
                   (tp--finalize-context prepared (memq prepared changed)))
                 table))
      (dolist (prepared changed)
        (tp--enqueue-surface-observers
         (tp--prepared-surface-surface prepared))))))

(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)))
          (tp--validate-plan-capability plan 'content)
          (tp--validate-context-tree context plan)
          (setq rendered (car (tp--render-plan plan context))
                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)))

;;;###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 (marker-position (tp--surface-mount-start mount)))
                  (end (marker-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-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)
(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