fix: preserve native interaction properties in incremental publication

Preserve keymap ownership and hover grouping while applying minimal text patches. Reduce retained publication allocations without weakening policy comparisons or transactional rollback.

Validation: 451 ERT tests, README doctests, strict byte compilation and checkdoc passed.

docs/API-REFERENCE.md

@@ -390,6 +390,19 @@ Report 的常用字段包括：
 :scope-fallback、:property-conflicts、:rolled-back、:failure、
 :observer-errors、:timing。
 
+已经精确计算出变更区间的 producer 可以使用 `tp-commit-batch-create` 构造
+批次，再由 `tp-commit-batch-result-create` 绑定当前 prepare context；发布和
+回滚仍使用相同 surface 事务。批次绑定前后 revision、extent 和坐标映射。
+每个 patch 的 `:replacement` 是完整属性文本，也可以携带局部
+`:property-contributions`：其中 `:start`/`:end` 相对于该 replacement，按列表
+顺序使用已注册的 property merge policy 合成。策略在**构造批次时**求值；
+批次只保留合成后的文本快照，不保留贡献列表，之后的调用方修改或策略替换
+不会重新计算这份批次。函数、record 等 opaque 属性身份按既有 snapshot 规则保留。
+
+producer 只有在证明整个挂载拓扑、tags 和坐标均与已提交版本相同时，才能向
+`tp-commit-batch-result-create` 传 `:reuse-mount-projection t`。它不能与显式
+`:mount-specs` 同时使用；数量相同或对象没有增删都不能替代完整的不变证明。
+
 ### 6.3 Host range 和 tp-watch
 
 ~~~elisp

tests/tp-core-tests.el

@@ -161,6 +161,49 @@
       (should (equal (nth 0 copy) "value"))
       (should (equal (nth 1 copy) ["nested"])))))
 
+(ert-deftest tp-core-test-property-value-copy-isolates-full-keymaps ()
+  "Full keymaps, parent maps and self-references retain an isolated graph."
+  (let* ((map (make-keymap))
+         (parent (make-keymap))
+         (callback (lambda () "callback")))
+    (define-key map (kbd "RET") callback)
+    (define-key parent (kbd "x") #'ignore)
+    (define-key map [prefix] map)
+    (set-keymap-parent map parent)
+    (let ((copy (tp-property-value-copy map)))
+      (should-not (eq copy map))
+      (should-not (eq (keymap-parent copy) parent))
+      (should (eq (lookup-key copy [prefix]) copy))
+      (should (eq (lookup-key copy (kbd "RET")) callback))
+      (define-key map (kbd "RET") #'forward-char)
+      (define-key parent (kbd "x") #'backward-char)
+      (should (eq (lookup-key copy (kbd "RET")) callback))
+      (should (eq (lookup-key copy (kbd "x")) #'ignore)))))
+
+(ert-deftest tp-core-test-property-value-copy-preserves-character-table-structure ()
+  "Local ranges, defaults, parents, extra slots and cycles are copied faithfully."
+  (let ((purpose (make-symbol "tp-copy-table")))
+    (put purpose 'char-table-extra-slots 1)
+    (let* ((parent (make-char-table purpose))
+           (table (make-char-table purpose))
+           (value (list 'value)))
+      (set-char-table-range parent ?p value)
+      (set-char-table-range table ?x value)
+      (set-char-table-range table ?s table)
+      (set-char-table-extra-slot table 0 value)
+      (set-char-table-parent table parent)
+      (let ((copy (tp-property-value-copy table)))
+        (should (eq (char-table-range copy ?s) copy))
+        (should (eq (char-table-range copy ?x) (char-table-extra-slot copy 0)))
+        (should (eq (char-table-range copy ?x)
+                    (char-table-range (char-table-parent copy) ?p)))
+        (set-char-table-range (char-table-parent copy) ?p 'new)
+        (should (eq (char-table-range copy ?p) 'new))
+        (set-char-table-range copy nil 'default)
+        (should (eq (char-table-range copy ?z) 'default))
+        (setcar value 'mutated)
+        (should (equal (char-table-range copy ?x) '(value)))))))
+
 (ert-deftest tp-core-test-property-value-copy-keeps-list-functions-opaque ()
   "Property copies keep list-shaped function values opaque."
   (let ((function-value '(lambda () 1)))

tests/tp-style-tests.el

@@ -14,6 +14,46 @@
 (require 'tp-style)
 (require 'tp-layer)
 
+(ert-deftest tp-style-test-native-keymaps-preserve-all-binding-facts ()
+  "Snapshots compare by prompts, menu order, parents and literal commands."
+  (let* ((factory (eval '(lambda ()
+                          (let ((n 0))
+                            (lambda () (setq n (1+ n))))) t))
+         (first (funcall factory)) (second (funcall factory))
+         (map (make-keymap "Root"))
+         (prefix (make-sparse-keymap "Prefix"))
+         (parent (make-sparse-keymap "Parent")))
+    (define-key map (kbd "RET") first)
+    (define-key map [t] #'ignore)
+    (define-key prefix [self] prefix)
+    (define-key prefix [one] '(menu-item "One" ignore))
+    (define-key prefix [two] '(menu-item "Two" forward-char))
+    (define-key map [prefix] prefix)
+    (define-key parent [inherited] #'backward-char)
+    (set-keymap-parent map parent)
+    (should (equal first second))
+    (should (tp--native-property-value-equal-p map (tp-property-value-copy map)))
+    (dolist (kind '(root-prompt prefix-prompt parent-prompt menu-order
+                   callback default inherited))
+      (let ((copy (tp-property-value-copy map)))
+        (pcase kind
+          ((or 'root-prompt 'prefix-prompt 'parent-prompt)
+           (let* ((target (pcase kind
+                            ('root-prompt copy)
+                            ('prefix-prompt (lookup-key copy [prefix]))
+                            ('parent-prompt (keymap-parent copy))))
+                  (cell (memq (keymap-prompt target) target)))
+             (setcar cell "Changed")))
+          ('menu-order
+           (let* ((target (lookup-key copy [prefix]))
+                  (one (lookup-key target [one])))
+             (define-key target [one] nil t)
+             (define-key target [one] one)))
+          ('callback (define-key copy (kbd "RET") second))
+          ('default (define-key copy [t] #'forward-char))
+          ('inherited (define-key (keymap-parent copy) [inherited] #'ignore)))
+        (should-not (tp--native-property-value-equal-p map copy))))))
+
 (defmacro tp-style-test--isolated (&rest body)
   "Run BODY with isolated TP property and named-style registries."
   (declare (indent 0) (debug t))

tests/tp-transaction-tests.el

@@ -99,6 +99,30 @@
    :final-accept #'ignore
    :diagnostics nil))
 
+(ert-deftest tp-transaction-test-unique-identities-use-equal-semantics ()
+  "Distinct identity values stay distinct; equal values remain duplicates."
+  (dolist (items (list nil '(nil) '(1 1.0) '(nil mount-a "mount-a")
+                      (number-sequence 1 2000)))
+    (let ((before (copy-tree items)))
+      (should (tp--proper-unique-list-p items))
+      (should (equal items before))))
+  (dolist (items (list '(nil nil) '(mount-a mount-a)
+                      (list (copy-sequence "mount") (copy-sequence "mount"))
+                      (list (list 'owner 1) (list 'owner 1))
+                      (list (vector 'owner 1) (vector 'owner 1))))
+    (should-not (tp--proper-unique-list-p items))
+    (should-error (tp-transaction-test--entry :mount-ids items)
+                  :type 'tp-publication-binding-error)))
+
+(ert-deftest tp-transaction-test-unique-identities-reject-improper-lists ()
+  "Malformed identity sequences cannot enter publication authority bindings."
+  (let ((cycle (list 'mount-a 'mount-b)))
+    (setcdr (last cycle) cycle)
+    (dolist (items (list 'mount-a [mount-a] '(mount-a . mount-b) cycle))
+      (should-not (tp--proper-unique-list-p items))
+      (should-error (tp-transaction-test--entry :mount-ids items)
+                    :type 'tp-publication-binding-error))))
+
 (defun tp-transaction-test--slot-writes (target values)
   "Return fixed slot writes assigning VALUES into TARGET from index zero."
   (vconcat
@@ -312,10 +336,17 @@
    :type 'tp-publication-binding-error)
   (with-temp-buffer
     (let* ((mount-ids (list 'mount-a))
-           (entry (tp-transaction-test--entry :mount-ids mount-ids))
+           (diff (list :replace (list 1 2)))
+           (client-state (list :client (list 'candidate)))
+           (entry (tp-transaction-test--entry
+                   :mount-ids mount-ids
+                   :diff diff
+                   :client-state client-state))
            (entries (list entry))
            (batch (tp-transaction-test--batch entries)))
       (setcar mount-ids 'mutated-after-create)
+      (setcar (plist-get diff :replace) 'mutated-after-create)
+      (setcar (plist-get client-state :client) 'mutated-after-create)
       (setcar entries (tp-transaction-test--entry
                        :candidate-id 'replacement
                        :surface-id 'replacement-surface
@@ -326,6 +357,10 @@
       (should (equal (tp-publication-target-entry-mount-ids
                       (car (tp-publication-batch-candidate-entries batch)))
                      '(mount-a)))
+      (should (equal (tp-publication-target-entry-diff entry)
+                     '(:replace (1 2))))
+      (should (equal (tp-publication-target-entry-client-state entry)
+                     '(:client (candidate))))
       (should (eq (car (tp-publication-batch-candidate-entries batch)) entry))
       (should-error
        (tp-transaction-test--batch (list entry entry))

tp-core.el

@@ -279,6 +279,7 @@ Otherwise, START-OR-STRING and END define the range."
   (and (not (functionp value))
        (or (consp value)
            (stringp value)
+           (char-table-p value)
            (and (vectorp value) (not (recordp value))))))
 
 (defun tp--copy-cons-spine (value cache)
@@ -309,6 +310,7 @@ so dotted tails, shared suffixes, and cycles retain their source topology."
                (if (and (not (functionp item))
                         (or (consp item)
                             (stringp item)
+                            (char-table-p item)
                             (and (vectorp item) (not (recordp item)))))
                    (tp--copy-property-value item cache)
                  item)))
@@ -344,6 +346,7 @@ back-references from cars while `copy-sequence' supplies the spine cheaply."
             (when (and (not (functionp item))
                        (or (consp item)
                            (stringp item)
+                           (char-table-p item)
                            (and (vectorp item) (not (recordp item)))))
               (setcar target (tp--copy-property-value item cache))))
           (setq source (cdr source)
@@ -406,7 +409,8 @@ values are recursively isolated."
 (defun tp--copy-property-value (value &optional cache)
   "Return a defensive copy of mutable containers in property VALUE.
 Optional CACHE preserves sharing and cycles across recursive copies.
-Cons cells, strings, and vectors are copied recursively.  Functions, records,
+Cons cells, strings, vectors and character tables are copied recursively.
+Functions, records,
 and other opaque objects keep their identity; functions are never executed."
   (if (not (tp--copy-mutable-property-value-p value))
       value
@@ -420,6 +424,29 @@ and other opaque objects keep their identity; functions are never executed."
               (tp--copy-proper-cons-list value cache)
             (tp--copy-cons-spine value cache)))
          ((stringp value) (tp--copy-string-with-properties value cache))
+         ((char-table-p value)
+          (let ((copy (copy-sequence value))
+                (default (char-table-range value nil))
+                entries)
+            (puthash value copy cache)
+            ;; Enumerate only local assignments, without inherited/default
+            ;; ranges becoming explicit assignments in the copied table.
+            (set-char-table-parent copy nil)
+            (set-char-table-range copy nil nil)
+            (map-char-table (lambda (range item) (push (cons range item) entries))
+                            copy)
+            (dolist (entry entries)
+              (set-char-table-range
+               copy (car entry) (tp--copy-property-value (cdr entry) cache)))
+            (set-char-table-range copy nil (tp--copy-property-value default cache))
+            (set-char-table-parent
+             copy (tp--copy-property-value (char-table-parent value) cache))
+            (dotimes (index (or (get (char-table-subtype value)
+                                     'char-table-extra-slots) 0))
+              (set-char-table-extra-slot
+               copy index (tp--copy-property-value
+                           (char-table-extra-slot value index) cache)))
+            copy))
          ((vectorp value)
           (let ((copy (copy-sequence value)))
             (puthash value copy cache)
@@ -431,7 +458,8 @@ and other opaque objects keep their identity; functions are never executed."
 (defun tp-property-value-copy (value)
   "Return a defensive copy of mutable text-property VALUE.
 Functions, records, and other opaque identities are retained; mutable cons,
-string, and non-record vector graphs are copied with sharing and cycles intact."
+string, character-table and non-record vector graphs are copied with sharing
+and cycles intact."
   (tp--copy-property-value value (make-hash-table :test #'eq)))
 
 (defun tp--deep-merge-plist (base new)

tp-style.el

@@ -205,12 +205,51 @@ OPTIONS support :normalizer, :validator, :equality, :merge, and :projector."
       #'tp--merge-face-values
     (lambda (_old new) new)))
 
+(defun tp--native-keymap-equal-p (left right)
+  "Compare native snapshots LEFT and RIGHT, retaining commands and menu order."
+  (let ((seen (make-hash-table :test #'eq)))
+    (cl-labels
+        ((bindings (map)
+           (let ((local (copy-sequence (if (symbolp map)
+                                           (indirect-function map) map)))
+                 entries)
+             (set-keymap-parent local nil)
+             (map-keymap (lambda (key value) (push (cons key value) entries)) local)
+             entries))
+         (same (old new)
+           (cond
+            ((eq old new) t)
+            ((memq new (gethash old seen)) t)
+            ((and (keymapp old) (keymapp new))
+             (puthash old (cons new (gethash old seen)) seen)
+             (and (equal-including-properties (keymap-prompt old)
+                                               (keymap-prompt new))
+                  (same (bindings old) (bindings new))
+                  (same (keymap-parent old) (keymap-parent new))))
+            ((or (functionp old) (functionp new)) nil)
+            ((and (consp old) (consp new))
+             (puthash old (cons new (gethash old seen)) seen)
+             (and (same (car old) (car new)) (same (cdr old) (cdr new))))
+            ((and (vectorp old) (vectorp new) (= (length old) (length new)))
+             (puthash old (cons new (gethash old seen)) seen)
+             (cl-loop for index below (length old)
+                      always (same (aref old index) (aref new index))))
+            (t (equal old new)))))
+      (same left right))))
+
+(defun tp--native-property-value-equal-p (left right)
+  "Compare native values LEFT and RIGHT while preserving callable identity."
+  (cond
+   ((and (keymapp left) (keymapp right)) (tp--native-keymap-equal-p left right))
+   ((or (functionp left) (functionp right)) (eq left right))
+   (t (equal left right))))
+
 (defun tp-register-text-property (property)
   "Register and return a direct policy for Emacs PROPERTY."
   (let ((id (tp-text-property-id property)))
     (or (tp-property-policy id)
         (tp-define-property-policy
-         id :equality #'equal
+         id :equality #'tp--native-property-value-equal-p
          :merge (tp--text-property-merge-function property)
          :projector (lambda (value) (list property value))))))
 

tp-surface.el

@@ -383,7 +383,7 @@ Each contribution contains `:start', `:end', and direct `:props'."
        (let ((a (tp-surface-plan-text left))
              (b (tp-surface-plan-text right)))
          (if (and (stringp a) (stringp b))
-             (equal-including-properties a b)
+             (tp--text-property-semantic-equal-p a b)
            (equal a b)))
        (tp--plan-props-equal-p (tp-surface-plan-props left)
                                (tp-surface-plan-props right))
@@ -1244,15 +1244,21 @@ When RELATIVE is non-nil, return offsets from the surface start."
         (when (= (caar new-ranges) (cdar new-ranges)) (pop new-ranges))))
     (nreverse pairs)))
 
-(defun tp--text-properties-canonical-at (text position)
+(defun tp--mouse-face-groups-equal-p
-  "Return TEXT properties at POSITION in deterministic key order."
+    (left left-start left-end right right-start right-end)
-  (sort
+  "Compare native hover boundaries in LEFT and RIGHT without comparing identities.
-   (cl-loop for (property value) on (text-properties-at position text)
+LEFT-START..LEFT-END and RIGHT-START..RIGHT-END delimit equal-length ranges.
-            by #'cddr
+Each snapshot may own different face objects, but its contiguous grouping
-            collect (cons property value))
+must agree.  Native interval traversal requires no property-value copies."
-   (lambda (left right)
+  (let ((match t))
-     (string< (symbol-name (car left))
+    (while (and match (< left-start left-end))
-              (symbol-name (car right))))))
+      (let ((left-next (next-single-property-change
+                        left-start 'mouse-face left left-end))
+            (right-next (next-single-property-change
+                         right-start 'mouse-face right right-end)))
+        (setq match (= (- left-next left-start) (- right-next right-start))
+              left-start left-next right-start right-next)))
+    (and match (= left-start left-end) (= right-start right-end))))
 
 (defun tp--text-property-semantic-equal-p (left right)
   "Return non-nil when propertized strings LEFT and RIGHT are policy-equal."
@@ -1264,14 +1270,16 @@ When RELATIVE is non-nil, return offsets from the surface start."
     ;; on every scoped update.
     (and (equal (substring-no-properties left)
                 (substring-no-properties right))
+         (tp--mouse-face-groups-equal-p left 0 (length left)
+                                       right 0 (length right))
          (let ((position 0)
                (limit (length left))
                equal-p)
            (setq equal-p t)
            (while (and equal-p (< position limit))
-             (unless (equal-including-properties
+             (unless (tp--plan-props-equal-p
-                      (tp--text-properties-canonical-at left position)
+                      (text-properties-at position left)
-                      (tp--text-properties-canonical-at right position))
+                      (text-properties-at position right))
                (setq equal-p nil))
              (setq position
                    (min (or (next-property-change position left limit) limit)
@@ -1316,14 +1324,35 @@ outside change."
   "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)))
+         (new-outside (tp--complement-ranges (length new) new-ranges))
-    (let ((old-gap (tp--substring-ranges old old-outside))
+         (anchors (tp--pair-outside-ranges old-outside new-outside))
-          (new-gap (tp--substring-ranges new new-outside)))
+         previous)
-      (when (or (tp--text-property-semantic-equal-p old-gap new-gap)
+    (when
-                (tp--scope-outside-separator-equivalent-p old-gap new-gap))
+        (or
-        (list :patches
+         (and (= (cl-loop for (start . end) in old-outside sum (- end start))
-              (tp--scope-patches-between-anchors
+                 (cl-loop for (start . end) in new-outside sum (- end start)))
-               old new (tp--pair-outside-ranges old-outside new-outside)))))))
+              (cl-every
+               (lambda (anchor)
+                 (pcase-let ((`(,old-start ,old-end ,new-start ,new-end) anchor))
+                   (prog1
+                       (and
+                        ;; Only real adjacent intervals have a shared hover
+                        ;; boundary.  A removed scope must not create one.
+                        (or (null previous)
+                            (/= (nth 1 previous) old-start)
+                            (/= (nth 3 previous) new-start)
+                            (eq (eq (get-text-property (1- old-start) 'mouse-face old)
+                                    (get-text-property old-start 'mouse-face old))
+                                (eq (get-text-property (1- new-start) 'mouse-face new)
+                                    (get-text-property new-start 'mouse-face new))))
+                        (tp--shadow-text-range-equal-p
+                         old old-start old-end new new-start new-end))
+                     (setq previous anchor))))
+               anchors))
+         (tp--scope-outside-separator-equivalent-p
+          (tp--substring-ranges old old-outside)
+          (tp--substring-ranges new new-outside)))
+      (list :patches (tp--scope-patches-between-anchors old new anchors)))))
 
 (defun tp--prepare-content-scope
     (surface rendered mount-specs objects options)
@@ -1803,11 +1832,6 @@ BOUNDARY-POLICY is `stale', `shorten', or `remove'."
     (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))
@@ -1982,7 +2006,10 @@ BASE-REVISION and TARGET-REVISION bind the transition; BASE-EXTENT and
 TARGET-EXTENT bind its coordinates.  COORDINATE-PATCHES project retained
 mounts, and CLIENT-STATE is opaque owner state.
 PATCHES are ordered plists containing :old-start, :old-end, :new-start,
-:new-end, and a propertized :replacement string."
+:new-end, and a propertized :replacement string.  Optional patch-local
+:property-contributions use ordered :start, :end, and :props ranges within
+that replacement.  Registered merge policies are evaluated now, at batch
+construction, and only the final propertized replacement is retained."
   (unless (and (integerp base-revision) (>= base-revision 0)
                (integerp target-revision)
                (= target-revision (1+ base-revision)))
@@ -2009,7 +2036,17 @@ PATCHES are ordered plists containing :old-start, :old-end, :new-start,
                      (stringp replacement)
                      (= (length replacement) (- new-end new-start)))
           (signal 'tp-surface-error (list :commit-patch patch)))
-        (push (copy-tree patch) copy)
+        (let ((candidate
+               (if (plist-member patch :property-contributions)
+                   (tp--copy-property-value patch)
+                 (copy-tree patch))))
+          (when (plist-member patch :property-contributions)
+            (plist-put candidate :replacement
+                       (tp--compose-relative-property-contributions
+                        (plist-get candidate :replacement)
+                        (plist-get candidate :property-contributions)))
+            (cl-remf candidate :property-contributions))
+          (push candidate copy))
         (setq old-cursor old-end new-cursor new-end)))
     (unless (= (- base-extent old-cursor)
                (- target-extent new-cursor))
@@ -2073,9 +2110,13 @@ to the committed projection, as with `tp-object-reuse-subtree'."
    :reuse-mount-projection-p (and reuse-mount-projection t)))
 
 (defun tp--commit-batch-apply-patches (surface batch)
-  "Apply BATCH's already validated patches to SURFACE."
+  "Apply BATCH's validated patches to SURFACE, retaining unchanged characters.
+The prefix/suffix proof preserves cursor and window anchors in unchanged
+text.  Properties are still projected over each complete declared patch.
+Return the actual (TEXT-OPERATIONS . PROPERTY-OPERATIONS) counts."
   (let ((buffer (tp--surface-buffer surface))
-        (base (marker-position (tp--surface-start surface))))
+        (base (marker-position (tp--surface-start surface)))
+        (text-operations 0) (property-operations 0))
     (with-current-buffer buffer
       (save-restriction
         (widen)
@@ -2083,15 +2124,39 @@ to the committed projection, as with `tp-object-reuse-subtree'."
                (plist-get (tp--surface-options surface)
                           :inhibit-read-only)))
           (dolist (patch (reverse (tp-commit-batch-patches batch)))
-            (let ((start (+ base (plist-get patch :old-start)))
+            (let* ((start (+ base (plist-get patch :old-start)))
                    (end (+ base (plist-get patch :old-end)))
-                  (replacement (plist-get patch :replacement)))
+                   (replacement (plist-get patch :replacement))
-              (delete-region start end)
+                   (old (buffer-substring-no-properties start end))
-              (goto-char start)
+                   (prefix (tp--common-prefix-length old replacement))
-              (insert replacement))))))
+                   (suffix (tp--common-suffix-length old replacement prefix)))
+              (unless (and (= prefix (length old))
+                           (= prefix (length replacement)))
+                (delete-region (+ start prefix) (- end suffix))
+                (goto-char (+ start prefix))
+                (let ((inserted (substring replacement prefix
+                                           (- (length replacement) suffix))))
+                  (insert inserted)
+                  (cl-incf text-operations)
+                  (unless (tp--validate-published-content-range
+                           buffer (+ start prefix) inserted)
+                    (signal 'tp-publication-mismatch
+                            (list :commit-patch patch)))))
+              ;; Keep undo recording for the standalone public batch API as
+              ;; well as transaction publication.  Host property hooks are
+              ;; inhibited just as in the ordinary content-property writer.
+              (let ((inhibit-modification-hooks t))
+                (dolist (operation
+                         (tp--content-property-operations-in-range
+                          buffer start replacement 0 (length replacement)))
+                  (set-text-properties (plist-get operation :start)
+                                       (plist-get operation :end)
+                                       (plist-get operation :props))
+                  (cl-incf property-operations))))))))
     (set-marker (tp--surface-start surface) base buffer)
     (set-marker (tp--surface-end surface)
-                (+ base (tp-commit-batch-target-extent batch)) buffer)))
+                (+ base (tp-commit-batch-target-extent batch)) buffer)
+    (cons text-operations property-operations)))
 
 (defun tp--commit-batch-validate-buffer (surface batch)
   "Validate BATCH's published extent and changed spans on SURFACE."
@@ -2106,7 +2171,7 @@ to the committed projection, as with `tp-object-reuse-subtree'."
       (let ((start (+ base (plist-get patch :new-start)))
             (end (+ base (plist-get patch :new-end)))
             (replacement (plist-get patch :replacement)))
-        (unless (equal-including-properties
+        (unless (tp--text-property-semantic-equal-p
                  (with-current-buffer buffer (buffer-substring start end))
                  replacement)
           (signal 'tp-publication-mismatch
@@ -2140,12 +2205,23 @@ to the committed projection, as with `tp-object-reuse-subtree'."
          (old-revision (tp--surface-revision surface))
          (old-client-state (tp--surface-client-state surface))
          (old-report (tp--surface-report surface))
+         (journals
+          (with-current-buffer buffer
+            (save-restriction
+              (widen)
+              (let ((base (marker-position (tp--surface-start surface))))
+                (mapcar
+                 (lambda (patch)
+                   (let ((start (+ base (plist-get patch :old-start)))
+                         (end (+ base (plist-get patch :old-end))))
+                     (list buffer start end (buffer-substring start end))))
+                 (tp-commit-batch-patches batch))))))
          (views (tp--capture-view-state (list buffer)))
          (group (tp--prepare-change-group-for-buffers (list buffer)))
-         success)
+         counts success)
     (unwind-protect
         (progn
-          (tp--commit-batch-apply-patches surface batch)
+          (setq counts (tp--commit-batch-apply-patches surface batch))
           (tp--commit-batch-validate-buffer surface batch)
           (tp--commit-batch-validate-mounts
            surface batch (tp--surface-mounts surface))
@@ -2158,14 +2234,15 @@ to the committed projection, as with `tp-object-reuse-subtree'."
                       :surface-id (tp--surface-id surface)
                       :old-revision old-revision
                       :new-revision (tp-commit-batch-target-revision batch)
-                      :text-operations (length (tp-commit-batch-patches batch))
+                      :text-operations (car counts)
-                      :property-operations 0 :commit-batch t
+                      :property-operations (cdr counts) :commit-batch t
                       :rolled-back nil :failure nil))
           (accept-change-group group)
           (setq success t)
           (tp-surface-report surface))
       (unless success
         (tp--cancel-change-group-safely group)
+        (tp--restore-property-journals journals)
         (setf (tp--surface-client-state surface) old-client-state
               (tp--surface-revision surface) old-revision
               (tp--surface-report surface) old-report))
@@ -2484,13 +2561,27 @@ caller reads the scalar summary from the surface instead."
         (tp--discard-context (tp--prepared-surface-context previous)))
       (puthash surface new table))))
 
-(defun tp--prepared-mount-signature (prepared)
+(defun tp--prepared-mount-signature (prepared &optional retained-signature)
-  "Return PREPARED's stable mount attachment signature."
+  "Return PREPARED's exact target mount attachment signature.
+RETAINED-SIGNATURE may supply the already captured live signature."
+  (if (tp--prepared-surface-retained-mount-state-p prepared)
+      (let* ((surface (tp--prepared-surface-surface prepared))
+             (updates (tp--prepared-surface-mount-coordinate-updates prepared))
+             (base (marker-position (tp--surface-start surface))))
+        (if (zerop (length updates))
+            (or retained-signature (tp--live-mount-signature surface))
+          (cl-loop for index from 0 below (length updates) by 3
+                   for mount = (aref updates index)
+                   collect (list (tp--surface-mount-object mount)
+                                 (tp--surface-mount-anchor mount)
+                                 (- (aref updates (1+ index)) base)
+                                 (- (aref updates (+ index 2)) base)
+                                 (tp--surface-mount-tags mount)))))
     (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)))
+            (tp--prepared-surface-mount-specs prepared))))
 
 (defun tp--live-mount-signature (surface)
   "Return SURFACE's stable live mount signature."
@@ -2510,40 +2601,65 @@ caller reads the scalar summary from the surface instead."
   (or (tp--surface-mount-id mount)
       (setf (tp--surface-mount-id mount) (cl-incf tp--mount-id-counter))))
 
-(defun tp--mount-spec-matches-live-p (spec mount capability)
+(defun tp--mount-match-queues (mounts object capability seen)
-  "Return non-nil when SPEC denotes live MOUNT for CAPABILITY."
+  "Group matching MOUNTS by anchor identity and equal tags in live order.
-  (and (eq (plist-get spec :object) (tp--surface-mount-object mount))
+Only include OBJECT and CAPABILITY by identity.  SEEN prevents enqueuing the
+same mount record twice.  Queue spines are private; no mount IDs are allocated."
+  (let ((anchors (make-hash-table :test #'eq)))
+    (dolist (mount mounts)
+      (when (and (eq object (tp--surface-mount-object mount))
                  (eq capability (tp--surface-mount-capability mount))
-       (eq (plist-get spec :anchor) (tp--surface-mount-anchor mount))
+                 (not (gethash mount seen)))
-       (equal (plist-get spec :tags) (tp--surface-mount-tags mount))))
+        (puthash mount t seen)
+        (let* ((anchor (tp--surface-mount-anchor mount))
+               (tags (tp--surface-mount-tags mount))
+               (by-tags (or (gethash anchor anchors)
+                            (puthash anchor (make-hash-table :test #'equal)
+                                     anchors))))
+          (push mount (gethash tags by-tags)))))
+    (maphash
+     (lambda (_anchor by-tags)
+       (maphash (lambda (tags queue)
+                  (puthash tags (nreverse queue) by-tags))
+                by-tags))
+     anchors)
+    anchors))
 
 (defun tp--assign-prepared-mount-ids (prepared)
   "Bind PREPARED mount specs to stable live or fresh private mount ids."
   (let* ((surface (tp--prepared-surface-surface prepared))
-         (capability (tp--surface-capability surface))
+         (live (tp--surface-mounts surface)))
-         (live (tp--surface-mounts surface))
-         (live-by-object (tp--surface-mount-index surface))
-         (used (make-hash-table :test #'eq)))
     (if (tp--prepared-surface-retained-mount-state-p prepared)
         (dolist (mount live) (tp--ensure-surface-mount-id mount))
+      (let ((capability (tp--surface-capability surface))
+            (live-by-object (tp--surface-mount-index surface))
+            (queues-by-object (make-hash-table :test #'eq))
+            (seen (make-hash-table :test #'eq)))
         (setf
          (tp--prepared-surface-mount-specs prepared)
          (mapcar
           (lambda (spec)
-          (let ((match
+            (let* ((object (plist-get spec :object))
-                 (cl-find-if
+                   (anchors
-                  (lambda (mount)
+                    (or (gethash object queues-by-object)
-                    (and (not (gethash mount used))
+                        ;; Cache empty queues too: later unmatched specs must
-                         (tp--mount-spec-matches-live-p
+                        ;; not rebuild the same object's live bucket.
-                          spec mount capability)))
+                        (puthash object
-                  (gethash (plist-get spec :object) live-by-object))))
+                                 (tp--mount-match-queues
-            (when match (puthash match t used))
+                                  (gethash object live-by-object)
+                                  object capability seen)
+                                 queues-by-object)))
+                   (by-tags (gethash (plist-get spec :anchor) anchors))
+                   (tags (plist-get spec :tags))
+                   (queue (and by-tags (gethash tags by-tags)))
+                   (match (car queue)))
+              (when match (puthash tags (cdr queue) by-tags))
               (plist-put
                spec :mount-id
                (if match
                    (tp--ensure-surface-mount-id match)
                  (cl-incf tp--mount-id-counter)))))
-        (tp--prepared-surface-mount-specs prepared))))
+          (tp--prepared-surface-mount-specs prepared)))))
     prepared))
 
 (defun tp--prepared-target-mount-ids (prepared)
@@ -2568,7 +2684,7 @@ caller reads the scalar summary from the surface instead."
         (with-current-buffer (tp--surface-buffer surface)
           (save-restriction
             (widen)
-            (equal-including-properties
+            (tp--text-property-semantic-equal-p
              (buffer-substring start end)
              (tp--prepared-surface-rendered prepared))))))))
 
@@ -2576,6 +2692,10 @@ caller reads the scalar summary from the surface instead."
   "Return non-nil when PREPARED differs from its committed surface."
   (let ((surface (tp--prepared-surface-surface prepared)))
     (or (tp--prepared-surface-initial prepared)
+        ;; An authenticated batch explicitly advances the revision, including
+        ;; an empty batch.  Preparation already checked its base and topology;
+        ;; its retained plan is not a new candidate to compare recursively.
+        (tp--prepared-surface-commit-batch prepared)
         (not (tp--plan-equal-p (tp--surface-plan surface)
                                (tp--prepared-surface-plan prepared)))
         (not (equal (tp--surface-client-state surface)
@@ -2644,7 +2764,7 @@ the transaction can commit."
                           (substring-no-properties rendered)))
         (signal 'tp-publication-mismatch
                 (list :buffer buffer :start start :end end)))
-      (equal-including-properties
+      (tp--text-property-semantic-equal-p
        (buffer-substring start end) rendered))))
 
 (defun tp--content-text-operation (surface rendered)
@@ -2680,8 +2800,68 @@ character makes a large rendered surface quadratic in its number of runs."
     (or (not (tp--plan-props-equal-p
               (text-properties-at buffer-start buffer)
               (text-properties-at from rendered)))
+        ;; Unlike ordinary face paint, native mouse-face boundaries are
+        ;; defined by identity.  Every published run must use the candidate
+        ;; group's exact value, even when its face attributes compare equal.
+        (not (eq (get-text-property buffer-start 'mouse-face buffer)
+                 (get-text-property from 'mouse-face rendered)))
         (< buffer-next buffer-end))))
 
+(defun tp--align-scoped-mouse-face-groups! (buffer base rendered ranges)
+  "Preserve native hover identities crossing scoped RANGES in RENDERED.
+BUFFER at BASE already has the candidate characters.  An unchanged outside
+gap authenticates the existing identity for its whole contiguous candidate
+group.  Separate groups are never interned by paint value.  If outside gaps
+disagree on identity, the requested scope cannot publish that group change."
+  (let ((seen (make-hash-table :test #'eql))
+        (limit (length rendered)))
+    (dolist (range ranges)
+      (let ((position (car range)))
+        (while (< position (cdr range))
+          (let* ((value (get-text-property position 'mouse-face rendered))
+                 (end (next-single-property-change
+                       position 'mouse-face rendered limit))
+                 (start (previous-single-property-change
+                         (1+ position) 'mouse-face rendered 0)))
+            (when (and value (not (gethash start seen)))
+              (puthash start t seen)
+              (let ((outside (tp--subtract-ranges (list (cons start end)) ranges))
+                    identity found)
+                (dolist (gap outside)
+                  (let ((cursor (+ base (car gap)))
+                        (stop (+ base (cdr gap))))
+                    (while (< cursor stop)
+                      (let ((actual (get-text-property cursor 'mouse-face buffer)))
+                        (unless (and (tp--property-value-equal-p
+                                      'mouse-face value actual)
+                                     (or (not found) (eq identity actual)))
+                          (signal 'tp-scope-mismatch
+                                  (list :mouse-face-group start end)))
+                        (setq identity actual found t
+                              cursor (next-single-property-change
+                                      cursor 'mouse-face buffer stop))))))
+                (when found
+                  ;; Reusing the outside identity must not silently erase a
+                  ;; candidate boundary against another unchanged group.
+                  (dolist (neighbor (list (1- start) end))
+                    (when (and (<= 0 neighbor) (< neighbor limit)
+                               (not (tp--range-contained-in-p
+                                     neighbor (1+ neighbor) ranges))
+                               (eq identity
+                                   (get-text-property (+ base neighbor)
+                                                      'mouse-face buffer)))
+                      (signal 'tp-scope-mismatch
+                              (list :mouse-face-boundary start end))))
+                  (unless (eq identity value)
+                    (put-text-property start end 'mouse-face identity rendered)
+                    ;; Inserted text was validated before this ownership
+                    ;; alignment.  Reapply its properties too when its native
+                    ;; group now adopts an unchanged outside identity.
+                    (setq tp--content-published-ranges
+                          (tp--subtract-ranges tp--content-published-ranges
+                                               (list (cons start end))))))))
+            (setq position end)))))))
+
 (defun tp--content-property-operations-in-range
     (buffer start rendered from to)
   "Return property operations for RENDERED FROM..TO at BUFFER position START."
@@ -2704,6 +2884,9 @@ 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)))))
+         (_hover-groups
+          (when scoped
+            (tp--align-scoped-mouse-face-groups! buffer start rendered ranges)))
          (ranges
           (if tp--content-published-ranges
               (tp--subtract-ranges
@@ -2975,7 +3158,7 @@ the generic property-operation ledger."
          (range (tp--surface-range surface))
          (start (car range))
          (end (cdr range))
-         (changed (not (equal-including-properties
+         (changed (not (tp--text-property-semantic-equal-p
                         (with-current-buffer buffer
                           (buffer-substring start end))
                         rendered))))
@@ -3002,13 +3185,12 @@ the generic property-operation ledger."
   "Publish PREPARED's text and properties, returning operation counts."
   (cl-block publish
     (when-let* ((batch (tp--prepared-surface-commit-batch prepared)))
-      (let ((surface (tp--prepared-surface-surface prepared)))
+      (let* ((surface (tp--prepared-surface-surface prepared))
-        (tp--commit-batch-apply-patches surface batch)
+             (counts (tp--commit-batch-apply-patches surface batch)))
         (tp--publication-step 'text surface)
         (tp--commit-batch-validate-buffer surface batch)
         (tp--publication-step 'property surface)
-        (cl-return-from publish
+        (cl-return-from publish counts)))
-          (cons (length (tp-commit-batch-patches batch)) 0))))
   (let* ((surface (tp--prepared-surface-surface prepared))
          (buffer (tp--surface-buffer surface))
          (rendered (tp--prepared-surface-rendered prepared))
@@ -3406,13 +3588,162 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
 
 (defun tp--shadow-apply-commit-batch-to-string (string batch)
   "Return STRING with BATCH patches applied without touching a buffer."
-  (let ((result (copy-sequence string)))
+  (let ((patches (tp-commit-batch-patches batch)))
-    (dolist (patch (reverse (tp-commit-batch-patches batch)))
+    (if (null patches)
-      (setq result
+        (copy-sequence string)
-            (concat (substring result 0 (plist-get patch :old-start))
+      (let ((cursor 0) pieces)
-                    (plist-get patch :replacement)
+        (dolist (patch patches)
-                    (substring result (plist-get patch :old-end)))))
+          (push (substring string cursor (plist-get patch :old-start)) pieces)
-    result))
+          (push (plist-get patch :replacement) pieces)
+          (setq cursor (plist-get patch :old-end)))
+        (push (substring string cursor) pieces)
+        (apply #'concat (nreverse pieces))))))
+
+(cl-defstruct (tp--shadow-batch-output
+               (:constructor tp--make-shadow-batch-output))
+  "Detached patch evidence over the unchanged output of a retained surface."
+  base patches extent)
+
+(defun tp--shadow-batch-output-create (base batch)
+  "Snapshot BASE and BATCH's output evidence without rebuilding the target.
+BASE is the already captured buffer string.  Patch strings and coordinates
+are detached before publication, so changing a staged patch cannot change
+the expected output.  Native callback identities survive the snapshot."
+  (tp--make-shadow-batch-output
+   :base base :extent (tp-commit-batch-target-extent batch)
+   :patches
+   (mapcar
+    (lambda (patch)
+      (list :old-start (plist-get patch :old-start)
+            :old-end (plist-get patch :old-end)
+            :new-start (plist-get patch :new-start)
+            :new-end (plist-get patch :new-end)
+            :mouse-face-first
+            (let ((text (plist-get patch :replacement)))
+              (and (> (length text) 0) (get-text-property 0 'mouse-face text)))
+            :mouse-face-last
+            (let ((text (plist-get patch :replacement)))
+              (and (> (length text) 0)
+                   (get-text-property (1- (length text)) 'mouse-face text)))
+            :replacement
+            (tp-property-value-copy (plist-get patch :replacement))))
+    (tp-commit-batch-patches batch))))
+
+(defun tp--shadow-props-identical-p (left right)
+  "Return non-nil when property lists LEFT and RIGHT have identical values.
+An identity match is sufficient proof even for opaque native callbacks.
+Different order or copied values require the ordinary policy comparison."
+  (while (and left right (eq (car left) (car right))
+              (eq (cadr left) (cadr right)))
+    (setq left (cddr left) right (cddr right)))
+  (and (null left) (null right)))
+
+(defvar tp--shadow-output-reusable-p nil
+  "Non-nil while a live output proof has used only identity or pure policies.
+Custom equality functions may retain or mutate their arguments without
+changing the buffer tick, so their proofs need a separate actual snapshot.")
+
+(defun tp--shadow-text-range-equal-p
+  (left left-start left-end right right-start right-end)
+  "Compare LEFT from LEFT-START to LEFT-END with RIGHT's corresponding range.
+RIGHT-START and RIGHT-END delimit that range in the RIGHT string or buffer.
+Unchanged runs use property identity as a proof; changed identities still
+use the same native-property policies as ordinary publication."
+  (and (= (- left-end left-start) (- right-end right-start))
+       (eq t (if (bufferp right)
+                 (compare-strings
+                  left left-start left-end
+                  (with-current-buffer right
+                    (buffer-substring-no-properties right-start right-end))
+                  0 nil)
+               (compare-strings left left-start left-end
+                                right right-start right-end)))
+       (tp--mouse-face-groups-equal-p
+        left left-start left-end right right-start right-end)
+       (let ((equal-p t))
+         (while (and equal-p (< left-start left-end))
+           (let ((left-props (text-properties-at left-start left))
+                 (right-props (text-properties-at right-start right)))
+             (unless (or (tp--shadow-props-identical-p left-props right-props)
+                         (progn
+                           (when tp--shadow-output-reusable-p
+                             (setq tp--shadow-output-reusable-p
+                                   (cl-loop for (property _value) on left-props by #'cddr
+                                            always
+                                            (memq (tp-property-policy-equality
+                                                   (tp-register-text-property property))
+                                                  '(eq equal tp--native-property-value-equal-p)))))
+                           (tp--plan-props-equal-p left-props right-props)))
+               (setq equal-p nil)))
+           (let ((step
+                  (min (- (next-property-change left-start left left-end)
+                          left-start)
+                       (- (next-property-change right-start right right-end)
+                          right-start))))
+             (setq left-start (+ left-start step)
+                   right-start (+ right-start step))))
+         equal-p)))
+
+(defun tp--shadow-batch-output-equal-p
+    (expected actual &optional actual-start actual-end groups-only)
+  "Prove ACTUAL equals EXPECTED's patches and every unchanged outside gap.
+This checks the whole output, including hostile writes made with hooks or
+undo recording inhibited.  Only construction of a second full output and
+semantic comparison of identical property values are avoided.
+ACTUAL may be a buffer delimited by ACTUAL-START and ACTUAL-END.
+With GROUPS-ONLY, compare only native hover topology.  This shares the same
+segment and seam evidence with precommit validation without copying output."
+  (setq actual-start (or actual-start 0)
+        actual-end (or actual-end (and (stringp actual) (length actual))))
+  (and (or (stringp actual) (buffer-live-p actual))
+       actual-end
+       (= (- actual-end actual-start) (tp--shadow-batch-output-extent expected))
+       (let ((base (tp--shadow-batch-output-base expected))
+             (patches (tp--shadow-batch-output-patches expected))
+             (old-position 0) (new-position 0) (equal-p t)
+             previous-face have-previous)
+         (cl-labels
+             ((segment-equal-p
+               (source from to target-start target-end first-face last-face)
+               (setq target-start (+ actual-start target-start)
+                     target-end (+ actual-start target-end))
+               (and
+                (or (= from to)
+                    (prog1
+                        (or (not have-previous)
+                            (eq (eq previous-face first-face)
+                                (eq (get-text-property (1- target-start)
+                                                       'mouse-face actual)
+                                    (get-text-property target-start
+                                                       'mouse-face actual))))
+                      (setq previous-face last-face have-previous t)))
+                (if groups-only
+                    (tp--mouse-face-groups-equal-p
+                     source from to actual target-start target-end)
+                  (tp--shadow-text-range-equal-p
+                   source from to actual target-start target-end))))
+              (base-equal-p (from to target-start target-end)
+                (segment-equal-p
+                 base from to target-start target-end
+                 (and (< from to) (get-text-property from 'mouse-face base))
+                 (and (< from to) (get-text-property (1- to) 'mouse-face base)))))
+         (while (and equal-p patches)
+           (let* ((patch (pop patches))
+                  (old-start (plist-get patch :old-start))
+                  (new-start (plist-get patch :new-start))
+                  (replacement (plist-get patch :replacement)))
+             (setq equal-p
+                   (and (base-equal-p old-position old-start new-position new-start)
+                        (segment-equal-p
+                         replacement 0 (length replacement)
+                         new-start (plist-get patch :new-end)
+                         (plist-get patch :mouse-face-first)
+                         (plist-get patch :mouse-face-last))))
+             (setq old-position (plist-get patch :old-end)
+                   new-position (plist-get patch :new-end))))
+         (and equal-p
+              (base-equal-p old-position (length base)
+                            new-position (- actual-end actual-start)))))))
 
 (defun tp--shadow-apply-property-operations-to-string
     (string base operations)
@@ -3439,7 +3770,9 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
   (let ((surface (tp--prepared-surface-surface prepared)))
     (if (eq (tp--surface-capability surface) 'content)
         (if-let* ((batch (tp--prepared-surface-commit-batch prepared)))
-            (tp--shadow-apply-commit-batch-to-string old-output batch)
+            (if (tp--prepared-surface-retained-mount-state-p prepared)
+                (tp--shadow-batch-output-create old-output batch)
+              (tp--shadow-apply-commit-batch-to-string old-output batch))
           (copy-sequence (tp--prepared-surface-rendered prepared)))
       (pcase-let ((`(,start . ,_end) (tp--surface-range surface)))
         (tp--shadow-apply-property-operations-to-string
@@ -3451,24 +3784,6 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
   (when-let* ((state (cl-find buffer views :key #'car :test #'eq)))
     (marker-position (cadr state))))
 
-(defun tp--shadow-prepared-diff (prepared)
-  "Return PREPARED's deterministic v2 diff artifact."
-  (cond
-   ((tp--prepared-surface-commit-batch prepared)
-    (let ((batch (tp--prepared-surface-commit-batch prepared)))
-      (list :kind 'commit-batch
-            :patches (tp-commit-batch-patches batch)
-            :coordinate-patches (tp-commit-batch-coordinate-patches batch))))
-   ((and (tp--prepared-surface-scope-objects prepared)
-         (not (tp--prepared-surface-scope-fallback prepared)))
-    (list :kind 'scoped
-          :patches (tp--prepared-surface-scope-patches prepared)))
-   (t
-    (list :kind 'full
-          :target-extent
-          (and (tp--prepared-surface-rendered prepared)
-               (length (tp--prepared-surface-rendered prepared)))))))
-
 (defun tp--shadow-artifact-equal-p (expected actual)
   "Return non-nil when EXPECTED and ACTUAL publication artifacts are equal."
   (and (eq (plist-get expected :buffer) (plist-get actual :buffer))
@@ -3483,11 +3798,21 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
        (equal (plist-get expected :mounts) (plist-get actual :mounts))
        (equal (plist-get expected :ledger) (plist-get actual :ledger))
        (= (plist-get expected :point) (plist-get actual :point))
-       (equal-including-properties
+       (let ((output (plist-get expected :output)))
-        (plist-get expected :output) (plist-get actual :output))))
+         (if (tp--shadow-batch-output-p output)
+             (or (eq output (plist-get actual :output))
+                 (tp--shadow-batch-output-equal-p output (plist-get actual :output)))
+           (tp--text-property-semantic-equal-p
+            output (plist-get actual :output))))))
 
-(defun tp--shadow-current-artifact (surface)
+(defun tp--shadow-current-artifact (surface &optional expected-output)
-  "Return a normalized read-only artifact for current SURFACE state."
+  "Return a normalized read-only artifact for current SURFACE state.
+When EXPECTED-OUTPUT is retained patch evidence, first compare all live text
+and properties with it.  A successful proof can use that immutable output as
+its policy-equivalent representation, avoiding another full property copy.
+The buffer tick must stay unchanged and no custom equality may run: custom
+policies can retain mutable evidence without changing that tick.  A failed,
+custom, or unstable comparison keeps an independent snapshot for diagnostics."
   (list :buffer (tp--surface-buffer surface)
         :revision (tp--surface-revision surface)
         :plan (tp--surface-plan surface)
@@ -3497,12 +3822,25 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
         :mounts (tp--live-mount-signature surface)
         :ledger (tp--shadow-live-ledger-signature (tp--surface-ledger surface))
         :point (with-current-buffer (tp--surface-buffer surface) (point))
-        :output (tp--shadow-surface-output surface)))
+        :output
+        (if (and (tp--shadow-batch-output-p expected-output)
+                 (with-current-buffer (tp--surface-buffer surface)
+                   (pcase-let ((`(,start . ,end) (tp--surface-range surface))
+                               (tick (buffer-modified-tick))
+                               (tp--shadow-output-reusable-p t))
+                     (and (tp--shadow-batch-output-equal-p
+                           expected-output (current-buffer) start end)
+                          tp--shadow-output-reusable-p
+                          (= tick (buffer-modified-tick))))))
+            expected-output
+          (tp--shadow-surface-output surface))))
 
 (defun tp--surface-shadow-target-entry
     (prepared snapshot journals views batch-id mapping-generation)
   "Build a BATCH-ID target view over PREPARED and SNAPSHOT.
-JOURNALS and VIEWS are exact references to the shared rollback state."
+JOURNALS and VIEWS are exact references to the shared rollback state.
+For real surface entries, the diff slot references PREPARED's exact commit
+batch, or nil when publication does not use a commit batch."
   (let* ((prepared (tp--assign-prepared-mount-ids prepared))
          (surface (tp--prepared-surface-surface prepared))
          (buffer (tp--surface-buffer surface))
@@ -3511,6 +3849,11 @@ JOURNALS and VIEWS are exact references to the shared rollback state."
          (old-ledger
           (tp--shadow-live-ledger-signature
            (tp--surface-snapshot-ledger snapshot)))
+         (context (tp--prepared-surface-context prepared))
+         (commit-batch (tp--prepared-surface-commit-batch prepared))
+         (target-mount-ids (tp--prepared-target-mount-ids prepared))
+         (candidate-id (tp--next-publication-candidate-id))
+         (authority-token (make-symbol "tp-publication-entry-authority"))
          (point (tp--shadow-view-point views buffer))
          (commit-expected
           (list :buffer buffer
@@ -3520,8 +3863,8 @@ JOURNALS and VIEWS are exact references to the shared rollback state."
                 :object-ids
                 (tp--shadow-object-ids
                  (tp--prepared-surface-objects prepared))
-                :mount-ids (tp--prepared-target-mount-ids prepared)
+                :mount-ids target-mount-ids
-                :mounts (tp--prepared-mount-signature prepared)
+                :mounts (tp--prepared-mount-signature prepared old-mounts)
                 :ledger
                 (tp--shadow-ledger-spec-signature
                  (tp--prepared-surface-ledger-specs prepared))
@@ -3543,36 +3886,53 @@ JOURNALS and VIEWS are exact references to the shared rollback state."
                 :point point
                 :output old-output))
          (expected (list :commit commit-expected
-                         :rollback rollback-expected)))
+                         :rollback rollback-expected))
-    (tp--publication-target-entry-create
+         (old-revision (tp--surface-snapshot-revision snapshot))
-     :transaction-id tp--transaction-id
+         (new-revision (1+ old-revision))
-     :batch-id batch-id
+         (shadow-validator
-     :candidate-id (tp--next-publication-candidate-id)
-     :surface-id (tp--surface-id surface)
-     :mount-ids (tp--prepared-target-mount-ids prepared)
-     :buffer buffer
-     :old-revision (tp--surface-snapshot-revision snapshot)
-     :new-revision (1+ (tp--surface-snapshot-revision snapshot))
-     :plan (tp--prepared-surface-plan prepared)
-     :diff (tp--shadow-prepared-diff prepared)
-     :ledger (tp--prepared-surface-ledger-specs prepared)
-     :objects (tp--prepared-surface-objects prepared)
-     :ranges (tp--prepared-surface-mount-specs prepared)
-     :client-state (tp--prepared-surface-client-state prepared)
-     :rollback-snapshot (vector prepared snapshot journals views)
-     :authority-token (make-symbol "tp-publication-entry-authority")
-     :mapping-generation mapping-generation
-     :shadow-expected expected
-     :shadow-validator
           (lambda (_entry phase)
             (let* ((target (plist-get expected
                                       (if (eq phase 'commit)
                                           :commit
                                         :rollback)))
-              (actual (tp--shadow-current-artifact surface)))
+                   (actual
+                    (if (tp--shadow-batch-output-p (plist-get target :output))
+                        (tp--shadow-current-artifact surface (plist-get target :output))
+                      (tp--shadow-current-artifact surface))))
               (list :equivalent (tp--shadow-artifact-equal-p target actual)
                     :surface-id (tp--surface-id surface)
-               :expected target :actual actual))))))
+                    :expected target :actual actual)))))
+    (unless
+        (and (tp-prepare-context-p context)
+             (tp--context-active context)
+             (eq (tp--context-surface context) surface)
+             (= old-revision (tp--surface-revision surface))
+             (tp--publication-target-entry-arguments-valid-p
+              tp--transaction-id batch-id candidate-id (tp--surface-id surface)
+              target-mount-ids buffer
+              old-revision new-revision authority-token shadow-validator))
+      (signal 'tp-publication-binding-error
+              (list :prepared-target prepared snapshot)))
+    (tp--make-publication-target-entry
+     :transaction-id tp--transaction-id
+     :batch-id batch-id
+     :candidate-id candidate-id
+     :surface-id (tp--copy-property-value (tp--surface-id surface))
+     :mount-ids (tp--copy-property-value target-mount-ids)
+     :buffer buffer
+     :old-revision old-revision
+     :new-revision new-revision
+     :plan (tp--prepared-surface-plan prepared)
+     :diff commit-batch
+     :ledger (tp--prepared-surface-ledger-specs prepared)
+     :objects (tp--prepared-surface-objects prepared)
+     :ranges (tp--prepared-surface-mount-specs prepared)
+     :client-state (tp--prepared-surface-client-state prepared)
+     :rollback-snapshot (vector prepared snapshot journals views)
+     :authority-token authority-token
+     :mapping-generation mapping-generation
+     :shadow-expected expected
+     :shadow-validator shadow-validator)))
 
 (defun tp--surface-shadow-target-entries
     (prepared snapshots journals views batch-id mapping-generation)
@@ -3593,9 +3953,19 @@ JOURNALS and VIEWS are exact references to the shared rollback state."
                         (aref rollback 0)))
          (snapshot (and prepared (aref rollback 1)))
          (surface (and (tp--prepared-surface-p prepared)
-                       (tp--prepared-surface-surface prepared))))
+                       (tp--prepared-surface-surface prepared)))
+         (context (and surface (tp--prepared-surface-context prepared)))
+         (commit-batch
+          (and surface (tp--prepared-surface-commit-batch prepared)))
+         (expected (and surface
+                        (tp-publication-target-entry-shadow-expected entry)))
+         (commit-expected (and expected (plist-get expected :commit)))
+         (rollback-expected (and expected (plist-get expected :rollback))))
     (unless
-        (and surface snapshot
+        (and surface (tp--surface-snapshot-p snapshot)
+             (tp-prepare-context-p context)
+             (tp--context-active context)
+             (eq (tp--context-surface context) surface)
              (tp--publication-target-entry-bound-p
               entry
               (tp-publication-batch-candidate-transaction-id candidate)
@@ -3606,6 +3976,8 @@ JOURNALS and VIEWS are exact references to the shared rollback state."
                  (tp--surface-buffer surface))
              (= (tp-publication-target-entry-old-revision entry)
                 (tp--surface-snapshot-revision snapshot))
+             (= (tp-publication-target-entry-old-revision entry)
+                (tp--surface-revision surface))
              (= (tp-publication-target-entry-new-revision entry)
                 (1+ (tp--surface-snapshot-revision snapshot)))
              (eq (tp-publication-target-entry-plan entry)
@@ -3616,8 +3988,23 @@ JOURNALS and VIEWS are exact references to the shared rollback state."
                  (tp--prepared-surface-objects prepared))
              (eq (tp-publication-target-entry-ranges entry)
                  (tp--prepared-surface-mount-specs prepared))
-             (equal (tp-publication-target-entry-client-state entry)
+             (eq (tp-publication-target-entry-client-state entry)
                  (tp--prepared-surface-client-state prepared))
+             (eq (tp-publication-target-entry-diff entry) commit-batch)
+             (or
+              (null commit-batch)
+              (and
+               (= (tp-publication-target-entry-old-revision entry)
+                  (tp-commit-batch-base-revision commit-batch))
+               (= (tp-publication-target-entry-new-revision entry)
+                  (tp-commit-batch-target-revision commit-batch))
+               (= (tp-commit-batch-base-extent commit-batch)
+                  (length (plist-get rollback-expected :output)))
+               (= (tp-commit-batch-target-extent commit-batch)
+                  (let ((output (plist-get commit-expected :output)))
+                    (if (tp--shadow-batch-output-p output)
+                        (tp--shadow-batch-output-extent output)
+                      (length output))))))
              (= (tp-publication-target-entry-mapping-generation entry)
                 tp--surface-transaction-id))
       (signal 'tp-publication-binding-error
@@ -3731,6 +4118,25 @@ JOURNALS and VIEWS are exact references to the shared rollback state."
               (list :invalid-retained-batch-precommit
                     (tp--surface-id surface))))))
 
+(defun tp--validate-retained-batch-hover-groups ()
+  "Reject native hover regrouping in retained publication before acceptance.
+Use the authenticated detached patch evidence and live interval boundaries.
+Ordinary publication and the full postcommit shadow remain diagnostic."
+  (when tp--transaction-publication-batch
+    (dolist (entry (tp-publication-batch-candidate-entries
+                    tp--transaction-publication-batch))
+      (let* ((expected (tp-publication-target-entry-shadow-expected entry))
+             (output (plist-get (plist-get expected :commit) :output)))
+        (when (tp--shadow-batch-output-p output)
+          (let* ((prepared (aref (tp-publication-target-entry-rollback-snapshot entry) 0))
+                 (surface (tp--prepared-surface-surface prepared))
+                 (range (tp--surface-range surface)))
+            (unless (tp--shadow-batch-output-equal-p
+                     output (tp--surface-buffer surface) (car range) (cdr range) t)
+              (signal 'tp-scope-mismatch
+                      (list :surface (tp--surface-id surface)
+                            :reason 'retained-hover-group-boundaries)))))))))
+
 (defun tp--validate-surface-precommit (state)
   "Validate final published semantics and rollback ownership in STATE."
   (unless (and (gethash 'change-group state)
@@ -3829,6 +4235,7 @@ JOURNALS and VIEWS are exact references to the shared rollback state."
             (when (tp--surface-mount-anchor mount)
               (signal 'tp-surface-error
                       (list :invalid-content-anchor mount)))))))))
+  (tp--validate-retained-batch-hover-groups)
   state))
 
 (defun tp--surface-prevalidate-cleanup (state)
@@ -3860,6 +4267,9 @@ JOURNALS and VIEWS are exact references to the shared rollback state."
   "Accept the active surface transaction's prepared change group."
   (when-let* ((state (tp--transaction-extension tp--surface-extension-key)))
     (when-let* ((group (gethash 'change-group state)))
+      ;; Lifecycle and cleanup callbacks run after precommit validation.
+      ;; A second boundary-only check also covers those unrecorded writes.
+      (tp--validate-retained-batch-hover-groups)
       (accept-change-group group))))
 
 (defun tp--surface-precommit-transaction ()
@@ -3929,6 +4339,39 @@ JOURNALS and VIEWS are exact references to the shared rollback state."
           (tp--surface-publishing t))
       (cancel-change-group group))))
 
+(defun tp--restore-retained-batch-output ()
+  "Restore retained output after cancellation, including unrecorded writes.
+The old output already belongs to the publication entry.  Replaying it only
+on rollback restores native group identities even when a host disabled undo."
+  (when tp--transaction-publication-batch
+    (dolist (entry (tp-publication-batch-candidate-entries
+                    tp--transaction-publication-batch))
+      (let* ((expected (tp-publication-target-entry-shadow-expected entry))
+             (output (plist-get (plist-get expected :commit) :output)))
+        (when (tp--shadow-batch-output-p output)
+          (let* ((prepared (aref (tp-publication-target-entry-rollback-snapshot entry) 0))
+                 (surface (tp--prepared-surface-surface prepared))
+                 (buffer (tp--surface-buffer surface))
+                 (old (tp--shadow-batch-output-base output)))
+            (when (buffer-live-p buffer)
+              (with-current-buffer buffer
+                (save-restriction
+                  (widen)
+                  (pcase-let* ((`(,start . ,end) (tp--surface-range surface))
+                               (plain (buffer-substring-no-properties start end))
+                               (prefix (tp--common-prefix-length plain old))
+                               (suffix (tp--common-suffix-length plain old prefix))
+                               (inhibit-read-only t)
+                               (inhibit-modification-hooks t)
+                               (buffer-undo-list t))
+                    (unless (equal plain (substring-no-properties old))
+                      (delete-region (+ start prefix) (- end suffix))
+                      (goto-char (+ start prefix))
+                      (insert (substring old prefix (- (length old) suffix))))
+                    (set-marker (tp--surface-start surface) start)
+                    (set-marker (tp--surface-end surface) (+ start (length old)))
+                    (tp--replay-string-properties buffer start old)))))))))))
+
 (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)))
@@ -3947,6 +4390,7 @@ JOURNALS and VIEWS are exact references to the shared rollback state."
                  (lambda ()
                    (tp--restore-property-journals
                     (gethash 'journals state))))
+        (attempt 'retained-output #'tp--restore-retained-batch-output)
         (dolist (entry (gethash 'snapshots state))
           (attempt
            (list 'surface
@@ -4208,7 +4652,7 @@ JOURNALS and VIEWS are exact references to the shared rollback state."
       (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)
+        (if (tp--property-state-policy-equal-p property current published)
             (push (list :start start :end next :property property
                         :present (tp--property-ledger-baseline-present entry)
                         :value (tp--property-ledger-baseline-value entry))

tp-transaction.el

@@ -83,11 +83,12 @@
 (defun tp--proper-unique-list-p (items)
   "Return non-nil when ITEMS is a proper list with no equal duplicates."
   (and (proper-list-p items)
-       (let (seen (unique t))
+       (let ((seen (make-hash-table :test #'equal))
+             (unique t))
          (dolist (item items unique)
-           (if (member item seen)
+           (if (gethash item seen)
                (setq unique nil)
-             (push item seen))))))
+             (puthash item t seen))))))
 
 (cl-defstruct (tp-publication-target-entry
                (:constructor tp--make-publication-target-entry)
@@ -115,6 +116,20 @@
   (shadow-validator nil :read-only t)
   rollback-result post-rollback-state shadow-actual shadow-proven-p)
 
+(defun tp--publication-target-entry-arguments-valid-p
+    (transaction-id batch-id candidate-id surface-id mount-ids buffer
+                    old-revision new-revision authority-token shadow-validator)
+  "Return non-nil when target arguments bind TRANSACTION-ID and BATCH-ID.
+CANDIDATE-ID, SURFACE-ID, MOUNT-IDS, BUFFER, OLD-REVISION, NEW-REVISION,
+AUTHORITY-TOKEN, and SHADOW-VALIDATOR must have valid publication shapes."
+  (and transaction-id batch-id candidate-id surface-id
+       (bufferp buffer) (buffer-live-p buffer)
+       (integerp old-revision) (>= old-revision 0)
+       (integerp new-revision) (= new-revision (1+ old-revision))
+       (tp--proper-unique-list-p mount-ids)
+       authority-token
+       (or (null shadow-validator) (functionp shadow-validator))))
+
 (cl-defun tp--publication-target-entry-create
     (&key transaction-id batch-id candidate-id surface-id mount-ids buffer
           old-revision new-revision plan diff ledger objects ranges client-state
@@ -126,13 +141,9 @@ DIFF, LEDGER, OBJECTS, RANGES, CLIENT-STATE, ROLLBACK-SNAPSHOT, and
 AUTHORITY-TOKEN describe the target.  MAPPING-GENERATION is optional.
 OPERATION-COUNTS is filled from the live report.  SHADOW-EXPECTED and
 SHADOW-VALIDATOR are private comparison artifacts."
-  (unless (and transaction-id batch-id candidate-id surface-id
+  (unless (tp--publication-target-entry-arguments-valid-p
-               (bufferp buffer) (buffer-live-p buffer)
+           transaction-id batch-id candidate-id surface-id mount-ids buffer
-               (integerp old-revision) (>= old-revision 0)
+           old-revision new-revision authority-token shadow-validator)
-               (integerp new-revision) (= new-revision (1+ old-revision))
-               (tp--proper-unique-list-p mount-ids)
-               authority-token
-               (or (null shadow-validator) (functionp shadow-validator)))
     (signal 'tp-publication-binding-error
             (list :target-entry transaction-id batch-id candidate-id surface-id
                   buffer old-revision new-revision mount-ids authority-token)))