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.

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-surface-tests.el

@@ -24,6 +24,189 @@
   (tp-surface-plan-create
    :key key :kind 'text :text text :props props :capability 'content))
 
+(ert-deftest tp-surface-test-native-callback-replacement-preserves-identity ()
+  "Different equal-shaped callbacks publish through text and contribution paths."
+  (dolist (as-text '(nil t))
+    (tp-surface-test--with-buffer
+      (let* ((factory (eval '(lambda ()
+                              (let ((n 0))
+                                (lambda (_w _o _p) (setq n (1+ n))))) t))
+             (first (funcall factory)) (second (funcall factory))
+             (plan (lambda (callback)
+                     (tp-surface-test--leaf
+                      'root (if as-text (propertize "text" 'help-echo callback)
+                              "text")
+                      (unless as-text (list 'help-echo callback)))))
+             (surface (tp-surface-mount (current-buffer) (funcall plan first)
+                                        '(:capability content))))
+        (should (equal first second))
+        (should-not (eq first second))
+        (tp-surface-update surface (funcall plan second))
+        (should (= (tp-surface-revision surface) 2))
+        (should (eq (get-text-property (point-min) 'help-echo) second))
+        (should (= (funcall first nil nil nil) 1))
+        (should (= (funcall second nil nil nil) 1))))))
+
+(ert-deftest tp-surface-test-native-keymap-prompts-publish-and-respect-scope ()
+  "Copied maps allow local publication; changed nested prompts stay in scope."
+  (dolist (as-text '(nil t))
+    (dolist (nested '(nil t))
+      (tp-surface-test--with-buffer
+        (let ((prompt "Before") (middle "B") middle-object)
+          (let* ((make-map
+                  (lambda ()
+                    (let ((map (make-sparse-keymap prompt)))
+                      (define-key map (kbd "RET") #'ignore)
+                      (if nested
+                          (let ((outer (make-sparse-keymap "Outer")))
+                            (define-key outer [prefix] map)
+                            outer)
+                        map))))
+                 (producer
+                  (lambda (context)
+                    (let ((root (tp-object-ensure context nil 'root 'group)))
+                      (setq middle-object
+                            (tp-object-ensure context root 'middle 'text))
+                      (tp-object-ensure context root 'right 'text))
+                    (let ((map (funcall make-map)))
+                      (tp-surface-plan-create
+                       :key 'root :kind 'group :capability 'content
+                       :children
+                       (list (tp-surface-test--leaf 'middle middle)
+                             (tp-surface-test--leaf
+                              'right (if as-text (propertize "C" 'keymap map) "C")
+                              (unless as-text (list 'keymap map))))))))
+                 (surface (tp-surface-mount buffer producer '(:capability content))))
+            (setq middle "M")
+            (tp-surface-update-scoped surface (list middle-object) producer)
+            (should (equal (buffer-substring-no-properties 1 3) "MC"))
+            (setq prompt "After" middle "N")
+            (should-error
+             (tp-surface-update-scoped surface (list middle-object) producer)
+             :type 'tp-scope-mismatch)
+            (should (= (tp-surface-revision surface) 2))
+            (should (equal (buffer-substring-no-properties 1 3) "MC"))
+            (tp-surface-update surface producer)
+            (let* ((map (get-text-property 2 'keymap))
+                   (target (if nested (lookup-key map [prefix]) map)))
+              (should (equal (keymap-prompt target) "After")))))))))
+
+(ert-deftest tp-surface-test-native-hover-group-survives-local-publication ()
+  "Scoped text and property edits preserve groups without merging equal faces."
+  (dolist (scoped '(nil t))
+    (tp-surface-test--with-buffer
+      (let ((middle "b") (help "old") logical)
+        (let* ((producer
+                (lambda (context)
+                  (let* ((root (tp-object-ensure context nil 'root 'text))
+                         (hover (list :background "blue"))
+                         (text (concat (propertize (concat "a" middle "c")
+                                                  'mouse-face hover)
+                                       (propertize "z" 'mouse-face (copy-sequence hover)))))
+                    (setq logical (tp-object-ensure context root 'logical 'item))
+                    (tp-object-attach-content-range context logical root
+                                                    1 (1+ (length middle)))
+                    (put-text-property 1 (1+ (length middle)) 'help-echo help text)
+                    (tp-surface-test--leaf 'root text))))
+               (surface (tp-surface-mount buffer producer '(:capability content))))
+          (dolist (operation '(property text rollback))
+            (let ((before (buffer-string))
+                  (revision (tp-surface-revision surface)))
+              (setq help (symbol-name operation))
+              (when (eq operation 'text) (setq middle "longer"))
+              (cl-labels ((update ()
+                            (if scoped
+                                (tp-surface-update-scoped surface (list logical) producer)
+                              (tp-surface-update surface producer))))
+                (if (eq operation 'rollback)
+                    (let ((tp--surface-publication-step-function
+                           (lambda (step _surface)
+                             (when (eq step 'property) (error "Reject hover")))))
+                      (should-error (update))
+                      (should (= revision (tp-surface-revision surface)))
+                      (dotimes (position (length before))
+                        (should (eq (get-text-property position 'mouse-face before)
+                                    (get-text-property (1+ position) 'mouse-face)))))
+                  (update))))
+            (let ((hover (get-text-property 1 'mouse-face))
+                  (last (+ 2 (length middle))))
+              (cl-loop for position from 1 to last do
+                       (should (eq hover (get-text-property position 'mouse-face))))
+              (should (equal hover (get-text-property (1+ last) 'mouse-face)))
+              (should-not (eq hover (get-text-property (1+ last) 'mouse-face))))))))))
+
+(ert-deftest tp-surface-test-scoped-hover-cannot-regroup-outside-groups ()
+  "Equal paint does not authorize merging or splitting groups outside scope."
+  (dolist (initial '(nil t))
+    (tp-surface-test--with-buffer
+      (let ((unify initial) logical)
+        (let* ((producer
+                (lambda (context)
+                  (let* ((root (tp-object-ensure context nil 'root 'text))
+                         (hover (list :background "blue"))
+                         (text (concat (propertize "ab" 'mouse-face hover)
+                                       (propertize "c" 'mouse-face
+                                                   (if unify hover (copy-sequence hover))))))
+                    (setq logical (tp-object-ensure context root 'logical 'item))
+                    (tp-object-attach-content-range context logical root 1 2)
+                    (put-text-property 1 2 'help-echo (if unify "new" "old") text)
+                    (tp-surface-test--leaf 'root text))))
+               (surface (tp-surface-mount buffer producer '(:capability content)))
+               (left (get-text-property 1 'mouse-face))
+               (right (get-text-property 3 'mouse-face)))
+          (setq unify (not initial))
+          (should-error (tp-surface-update-scoped surface (list logical) producer)
+                        :type 'tp-scope-mismatch)
+          (should (= (tp-surface-revision surface) 1))
+          (should (eq left (get-text-property 1 'mouse-face)))
+          (should (eq right (get-text-property 3 'mouse-face))))))))
+
+(ert-deftest tp-surface-test-scoped-hover-checks-entire-outside-gap ()
+  "A remote same-paint group change is outside scope even with fresh snapshots."
+  (dolist (initial '(nil t))
+    (tp-surface-test--with-buffer
+      (let ((unify initial) logical)
+        (let* ((producer
+                (lambda (context)
+                  (let* ((root (tp-object-ensure context nil 'root 'text))
+                         (hover (list :background "blue"))
+                         (text (concat "abc" (propertize "d" 'mouse-face hover)
+                                       (propertize "e" 'mouse-face
+                                                   (if unify hover (copy-sequence hover))))))
+                    (setq logical (tp-object-ensure context root 'logical 'item))
+                    (tp-object-attach-content-range context logical root 1 2)
+                    (put-text-property 1 2 'help-echo (if unify "new" "old") text)
+                    (tp-surface-test--leaf 'root text))))
+               (surface (tp-surface-mount buffer producer '(:capability content))))
+          (setq unify (not initial))
+          (should-error (tp-surface-update-scoped surface (list logical) producer)
+                        :type 'tp-scope-mismatch)
+          (should (= (tp-surface-revision surface) 1)))))))
+
+(ert-deftest tp-surface-test-scoped-hover-does-not-join-separated-outside-gaps ()
+  "A scope with no hover separates equal outside faces regardless of identity."
+  (tp-surface-test--with-buffer
+    (let (separate logical)
+      (let* ((producer
+              (lambda (context)
+                (let* ((root (tp-object-ensure context nil 'root 'text))
+                       (hover (list :background "blue"))
+                       (text (concat (propertize "a" 'mouse-face hover)
+                                     (propertize "b" 'help-echo (if separate "new" "old"))
+                                     (propertize "c" 'mouse-face
+                                                 (if separate (copy-sequence hover) hover)))))
+                  (setq logical (tp-object-ensure context root 'logical 'item))
+                  (tp-object-attach-content-range context logical root 1 2)
+                  (tp-surface-test--leaf 'root text))))
+             (surface (tp-surface-mount buffer producer '(:capability content))))
+        (setq separate t)
+        (tp-surface-update-scoped surface (list logical) producer)
+        (should (= (tp-surface-revision surface) 2))
+        (should (equal (get-text-property 2 'help-echo) "new"))
+        (should-not (get-text-property 2 'mouse-face))
+        (should (equal (get-text-property 1 'mouse-face)
+                       (get-text-property 3 'mouse-face)))))))
+
 (defun tp-surface-test--producer (signal)
   "Return a retained content producer reading SIGNAL."
   (lambda (context)
@@ -521,6 +704,395 @@ the batch instead of retaining their unchanged coordinates."
                (eq (cadr entry) 'commit)))
         tp--last-transaction-diagnostics)))))
 
+(ert-deftest tp-surface-test-retained-batch-avoids-full-plan-and-output-replay ()
+  "Revision-bearing batches bypass duplicate plan walks, even for no-op text."
+  (dolist (replacement '("X" "b" nil))
+    (tp-surface-test--with-buffer
+      (let* ((surface
+              (tp-surface-mount buffer (tp-surface-test--leaf 'root "abc")
+                                '(:capability content :coordinate-mounts t)))
+             (root (tp-object-resolve surface '(root)))
+             (batch (if replacement
+                        (tp-surface-test--replacement-batch surface replacement)
+                      (tp-commit-batch-create
+                       :base-revision 1 :target-revision 2
+                       :base-extent 3 :target-extent 3))))
+        (cl-letf (((symbol-function 'tp--plan-equal-p)
+                   (lambda (&rest _) (ert-fail "Retained plan was traversed")))
+                  ((symbol-function 'tp--shadow-apply-commit-batch-to-string)
+                   (lambda (&rest _) (ert-fail "Full output was rebuilt"))))
+          (tp-surface-test--commit-batch-update
+           surface root batch '(:owned next)
+           (lambda (entry _prepared)
+             (should
+              (tp--shadow-batch-output-p
+               (plist-get
+                (plist-get (tp-publication-target-entry-shadow-expected entry)
+                           :commit)
+                :output))))))
+        (should (= (tp-surface-revision surface) 2))
+        (should (equal (buffer-string) (if (equal replacement "X") "aXc" "abc")))
+        (should (plist-get tp--last-shadow-proof :equivalent))))))
+
+(ert-deftest tp-surface-test-batch-writes-only-changed-characters ()
+  "Direct and retained batches retain anchors and write only the changed digit."
+  (dolist (retained '(nil t))
+    (tp-surface-test--with-buffer
+      (let* ((text (propertize "prefix 00 suffix" 'help-echo "old"))
+             (surface
+              (tp-surface-mount buffer (tp-surface-test--leaf 'root text)
+                                '(:capability content :coordinate-mounts t)))
+             (root (tp-object-resolve surface '(root)))
+             (prefix-anchor (copy-marker 4))
+             (suffix-anchor (copy-marker 14))
+             changes)
+        (unwind-protect
+            (progn
+              (goto-char 4)
+              (add-hook 'before-change-functions
+                        (lambda (start end) (push (- end start) changes)) nil t)
+              (let ((batch
+                     (tp-commit-batch-create
+                      :base-revision 1 :target-revision 2
+                      :base-extent 16 :target-extent 16
+                      :patches
+                      (list (list :old-start 0 :old-end 16 :new-start 0 :new-end 16
+                                  :replacement
+                                  (propertize "prefix 01 suffix" 'help-echo "new"))))))
+                (if retained
+                    (tp-surface-test--commit-batch-update surface root batch nil #'ignore)
+                  (tp-surface-commit-batch surface batch)))
+              (should (= (point) 4))
+              (should (= (marker-position prefix-anchor) 4))
+              (should (= (marker-position suffix-anchor) 14))
+              (should (= (apply #'+ changes) 1))
+              (should (= (plist-get (tp-surface-report surface) :text-operations) 1))
+              (should (> (plist-get (tp-surface-report surface) :property-operations) 0))
+              (should (equal (buffer-string) "prefix 01 suffix"))
+              (dotimes (position 16)
+                (should (equal (get-text-property (1+ position) 'help-echo) "new"))))
+          (set-marker prefix-anchor nil)
+          (set-marker suffix-anchor nil))))))
+
+(ert-deftest tp-surface-test-batch-property-only-final-accept-rolls-back ()
+  "Property-only batches journal unchanged characters for both public paths."
+  (dolist (retained '(nil t))
+    (tp-surface-test--with-buffer
+      (let* ((first (lambda (&rest _) "first"))
+             (second (lambda (&rest _) "second"))
+             (surface
+              (tp-surface-mount
+               buffer (tp-surface-test--leaf 'root (propertize "abc" 'help-echo first))
+               '(:capability content :coordinate-mounts t)))
+             (root (tp-object-resolve surface '(root)))
+             (batch (tp-surface-test--replacement-batch
+                     surface (propertize "b" 'help-echo second))))
+        (goto-char 2)
+        (cl-letf (((symbol-function 'accept-change-group)
+                   (lambda (_group) (error "Reject property batch"))))
+          (should-error
+           (if retained
+               (tp-surface-test--commit-batch-update surface root batch nil #'ignore)
+             (tp-surface-commit-batch surface batch))))
+        (should (= (point) 2))
+        (should (eq first (get-text-property 2 'help-echo)))
+        (should (= (tp-surface-revision surface) 1))
+        (dolist (expected-property-operations '(1 0))
+          (let ((next (tp-surface-test--replacement-batch
+                       surface (propertize "b" 'help-echo second))))
+            (if retained
+                (tp-surface-test--commit-batch-update surface root next nil #'ignore)
+              (tp-surface-commit-batch surface next)))
+          (should (= (plist-get (tp-surface-report surface) :text-operations) 0))
+          (should (= (plist-get (tp-surface-report surface) :property-operations)
+                     expected-property-operations)))
+        (should (= (tp-surface-revision surface) 3))))))
+
+(ert-deftest tp-surface-test-retained-batch-shadow-detects-unrecorded-outside-writes ()
+  "Outside writes remain diagnosed with undo and change hooks disabled."
+  (dolist (side '(1 3))
+    (dolist (fault '(text property callback keymap))
+      (tp-surface-test--with-buffer
+        (let* ((factory (eval '(lambda ()
+                                (let ((n 0))
+                                  (lambda (&rest _) (setq n (1+ n))))) t))
+               (first (funcall factory)) (second (funcall factory))
+               (map (make-sparse-keymap "Before"))
+               (_binding (define-key map [return] first))
+               (surface
+                (tp-surface-mount
+                 buffer (tp-surface-test--leaf
+                         'root (propertize "abc" 'help-echo first 'keymap map))
+                 '(:capability content :coordinate-mounts t)))
+               (root (tp-object-resolve surface '(root)))
+               (batch (tp-surface-test--replacement-batch
+                       surface (propertize "X" 'help-echo first 'keymap map)))
+               (tp--surface-publication-step-function
+                (lambda (step _surface)
+                  (when (eq step 'client-state)
+                    (let ((inhibit-modification-hooks t)
+                          (buffer-undo-list t))
+                      (pcase fault
+                        ('text (subst-char-in-region side (1+ side)
+                                                     (char-after side) ?Z))
+                        ('property (put-text-property side (1+ side) 'alien t))
+                        ('callback
+                         (put-text-property side (1+ side) 'help-echo second))
+                        ('keymap
+                         (let ((other (make-sparse-keymap "After")))
+                           (define-key other [return] second)
+                           (put-text-property side (1+ side) 'keymap other)))))))))
+          (should (equal first second))
+          (should-not (eq first second))
+          (tp-surface-test--commit-batch-update surface root batch nil #'ignore)
+          (should (= (tp-surface-revision surface) 2))
+          (should-not (plist-get tp--last-shadow-proof :equivalent)))))))
+
+(ert-deftest tp-surface-test-retained-shadow-patch-evidence-is-detached ()
+  "Staged string and native map mutations cannot rewrite expected evidence."
+  (dolist (fault '(character callback keymap))
+    (tp-surface-test--with-buffer
+      (let* ((callback (lambda (&rest _) "first"))
+             (replacement-map (make-sparse-keymap "Before"))
+             (_binding (define-key replacement-map [return] callback))
+             (surface
+              (tp-surface-mount buffer (tp-surface-test--leaf 'root "abc")
+                                '(:capability content :coordinate-mounts t)))
+             (root (tp-object-resolve surface '(root)))
+             (batch (tp-surface-test--replacement-batch
+                     surface (propertize (copy-sequence "X")
+                                         'help-echo callback 'keymap replacement-map))))
+        (tp-surface-test--commit-batch-update
+         surface root batch nil
+         (lambda (_entry _prepared)
+           (let ((replacement (plist-get (car (tp-commit-batch-patches batch))
+                                         :replacement)))
+             (pcase fault
+               ('character (aset replacement 0 ?Z))
+               ('callback (put-text-property 0 1 'help-echo #'ignore replacement))
+               ('keymap (define-key (get-text-property 0 'keymap replacement)
+                                    [return] #'ignore))))))
+        (should-not (plist-get tp--last-shadow-proof :equivalent))))))
+
+(ert-deftest tp-surface-test-retained-shadow-detects-same-paint-regrouping ()
+  "Retained proof rejects outside group changes without relying on undo hooks."
+  (dolist (phase '(client-state cleanup))
+  (dolist (tamper '(nil gap seam))
+    (tp-surface-test--with-buffer
+      (let* ((surface
+              (tp-surface-mount
+               buffer (tp-surface-test--leaf
+                       'root (propertize "abcde" 'mouse-face (list :background "blue")))
+               '(:capability content :coordinate-mounts t)))
+             (root (tp-object-resolve surface '(root)))
+             (hover (get-text-property 1 'mouse-face))
+             (batch
+              (tp-commit-batch-create
+               :base-revision 1 :target-revision 2 :base-extent 5 :target-extent 5
+               :patches (list (list :old-start 1 :old-end 2 :new-start 1 :new-end 2
+                                   :replacement (propertize "X" 'mouse-face hover)))))
+             (mutate
+              (lambda (step _state)
+                (when (and tamper (eq step phase))
+                  (let ((inhibit-modification-hooks t) (buffer-undo-list t)
+                        (start (if (eq tamper 'gap) 4 2)))
+                    (put-text-property start (1+ start) 'mouse-face
+                                       (copy-sequence hover))))))
+             (tp--surface-publication-step-function mutate)
+             (tp--surface-precommit-step-function mutate))
+        (if tamper
+            (progn
+              (should-error
+               (tp-surface-test--commit-batch-update surface root batch nil #'ignore)
+               :type 'tp-scope-mismatch)
+              (should (= (tp-surface-revision surface) 1))
+              (should (equal (buffer-string) "abcde"))
+              (dotimes (offset 5)
+                (should (eq hover (get-text-property (1+ offset) 'mouse-face))))
+              (should (eq (plist-get tp--last-shadow-proof :phase) 'rollback)))
+          (tp-surface-test--commit-batch-update surface root batch nil #'ignore)
+          (should (= (tp-surface-revision surface) 2)))
+        (should (plist-get tp--last-shadow-proof :equivalent)))))))
+
+(ert-deftest tp-surface-test-retained-batch-final-accept-restores-native-properties ()
+  "Final-accept error and quit restore native identity and retained side state."
+  (dolist (injected '((error "Retained accept failure") (quit)))
+    (tp-surface-test--with-buffer
+      (let* ((first (lambda (&rest _) "first"))
+             (second (lambda (&rest _) "second"))
+             (map (make-sparse-keymap "Before"))
+             (_binding (define-key map [return] #'ignore))
+             (surface
+              (tp-surface-mount
+               buffer (tp-surface-test--leaf
+                       'root (propertize "abc" 'help-echo first 'keymap map))
+               '(:capability content :coordinate-mounts t)))
+             (root (tp-object-resolve surface '(root)))
+             (mounts (tp--surface-mounts surface))
+             (index (tp--surface-mount-index surface))
+             (output (buffer-string))
+             (batch (tp-surface-test--replacement-batch
+                     surface (propertize "X" 'help-echo second 'keymap map)))
+             failure)
+        (cl-letf (((symbol-function 'accept-change-group)
+                   (lambda (_group) (signal (car injected) (cdr injected)))))
+          (setq failure
+                (tp-surface-test--capture-condition
+                 (lambda ()
+                   (tp-surface-test--commit-batch-update
+                    surface root batch '(:owned next) #'ignore)))))
+        (should (equal failure injected))
+        (should (tp--text-property-semantic-equal-p output (buffer-string)))
+        (should (eq first (get-text-property 2 'help-echo)))
+        (should (eq mounts (tp--surface-mounts surface)))
+        (should (eq index (tp--surface-mount-index surface)))
+        (should (= (tp-surface-revision surface) 1))
+        (should-not (tp-surface-client-state surface))
+        (should (eq (plist-get tp--last-shadow-proof :phase) 'rollback))
+        (should (plist-get tp--last-shadow-proof :equivalent))
+        (tp-surface-test--commit-batch-update
+         surface root batch '(:owned next) #'ignore)
+        (should (eq second (get-text-property 2 'help-echo)))
+        (should (= (tp-surface-revision surface) 2))
+        (should (plist-get tp--last-shadow-proof :equivalent))))))
+
+(ert-deftest tp-surface-test-retained-shadow-range-proof-matches-full-replay ()
+  "Patch evidence covers all gaps, insertions, removals, and property boundaries."
+  (dolist (specs '(((0 0 "α") (1 3 "XY") (6 6 "尾"))
+                   ((0 6 "") (6 6 "新值"))
+                   ((1 2 "") (2 2 "二") (4 5 "四五六"))
+                   ((2 2 "一") (2 2 "二")) nil))
+    (let ((base (concat (propertize "abc" 'face '(bold))
+                        (propertize "def" 'face '(italic))))
+          (old-position 0) (new-position 0) patches)
+      (dolist (spec specs)
+        (pcase-let* ((`(,start ,end ,text) spec)
+                     (new-start (+ new-position (- start old-position)))
+                     (new-end (+ new-start (length text))))
+          (push (list :old-start start :old-end end
+                      :new-start new-start :new-end new-end
+                      :replacement (propertize text 'face '(underline))) patches)
+          (setq old-position end new-position new-end)))
+      (setq patches (nreverse patches))
+      (let* ((extent (+ new-position (- (length base) old-position)))
+             (batch (tp-commit-batch-create
+                     :base-revision 0 :target-revision 1 :base-extent 6
+                     :target-extent extent :patches patches
+                     :coordinate-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)))
+                             patches)))
+             (expected (tp--shadow-batch-output-create base batch))
+             (actual (tp-surface-test--shadow-apply-commit-batch-oracle base batch)))
+        (should (tp--shadow-batch-output-equal-p expected actual))
+        (with-temp-buffer
+          (insert "prefix" actual "suffix")
+          (should (tp--shadow-batch-output-equal-p
+                   expected (current-buffer) 7 (+ 7 extent))))
+        (dotimes (position extent)
+          (let ((changed (copy-sequence actual)))
+            (put-text-property position (1+ position) 'alien t changed)
+            (should-not (tp--shadow-batch-output-equal-p expected changed))
+            (with-temp-buffer
+              (insert "prefix" changed "suffix")
+              (should-not (tp--shadow-batch-output-equal-p
+                           expected (current-buffer) 7 (+ 7 extent))))))
+        (should-not (tp--shadow-batch-output-equal-p expected (concat actual "!")))))))
+
+(ert-deftest tp-surface-test-retained-shadow-reuses-only-verified-output ()
+  "Verified evidence avoids copying output; opaque mismatches retain diagnostics."
+  (tp-surface-test--with-buffer
+    (let* ((factory (eval '(lambda () (let ((n 0))
+                                      (lambda (&rest _) (setq n (1+ n))))) t))
+           (first (funcall factory)) (second (funcall factory))
+           (surface (tp-surface-mount
+                     buffer (tp-surface-test--leaf 'root (propertize "abc" 'help-echo first))
+                     '(:capability content :coordinate-mounts t)))
+           (expected (tp--shadow-batch-output-create
+                      (buffer-string)
+                      (tp-commit-batch-create :base-revision 1 :target-revision 2
+                                              :base-extent 3 :target-extent 3))))
+      (cl-letf (((symbol-function 'tp--shadow-surface-output)
+                 (lambda (_) (ert-fail "Verified output was copied again"))))
+        (should (eq expected (plist-get (tp--shadow-current-artifact surface expected)
+                                       :output))))
+      (should (equal first second))
+      (should-not (eq first second))
+      (let ((inhibit-modification-hooks t) (buffer-undo-list t))
+        (put-text-property 3 4 'help-echo second))
+      (let* ((actual (tp--shadow-current-artifact surface expected))
+             (target (plist-put (copy-sequence actual) :output expected)))
+        (should (stringp (plist-get actual :output)))
+        (should (eq second (get-text-property 2 'help-echo (plist-get actual :output))))
+        (should-not (tp--shadow-artifact-equal-p target actual))))))
+
+(ert-deftest tp-surface-test-retained-shadow-verifies-custom-policy-and-buffer-tick ()
+  "Custom policy equality is honored without reusing evidence across its writes."
+  (tp-surface-test--with-buffer
+    (let* ((property (make-symbol "shadow-custom-policy"))
+           mutate
+           (_policy (tp-define-property-policy
+                     (tp-text-property-id property) :equality
+                     (lambda (a b)
+                       (when mutate
+                         (let ((inhibit-modification-hooks t) (buffer-undo-list t))
+                           (put-text-property 1 2 'alien t buffer)))
+                       (equal (downcase a) (downcase b)))))
+           (surface (tp-surface-mount
+                     buffer (tp-surface-test--leaf 'root (propertize "abc" property "OLD"))
+                     '(:capability content :coordinate-mounts t)))
+           (expected (tp--shadow-batch-output-create
+                      (buffer-string)
+                      (tp-commit-batch-create :base-revision 1 :target-revision 2
+                                              :base-extent 3 :target-extent 3))))
+      (let ((inhibit-modification-hooks t))
+        (put-text-property 1 4 property "old"))
+      (let* ((actual (tp--shadow-current-artifact surface expected))
+             (target (plist-put (copy-sequence actual) :output expected)))
+        (should (stringp (plist-get actual :output)))
+        (should (tp--shadow-artifact-equal-p target actual)))
+      (setq mutate t)
+      (let* ((actual (tp--shadow-current-artifact surface expected))
+             (target (plist-put (copy-sequence actual) :output expected)))
+        (should (stringp (plist-get actual :output)))
+        (should (get-text-property 0 'alien (plist-get actual :output)))
+        (should-not (tp--shadow-artifact-equal-p target actual))))))
+
+(ert-deftest tp-surface-test-retained-shadow-isolates-custom-policy-evidence ()
+  "A custom policy cannot alias actual evidence by retaining its expected value."
+  (dolist (when-to-mutate '(during after))
+    (tp-surface-test--with-buffer
+      (let* ((property (make-symbol "shadow-retained-evidence"))
+             captured
+             (_policy (tp-define-property-policy
+                       (tp-text-property-id property) :equality
+                       (lambda (a b)
+                         (prog1 (equal (downcase a) (downcase b))
+                           (setq captured a)
+                           (when (eq when-to-mutate 'during) (aset a 0 ?X))))))
+             (surface (tp-surface-mount
+                       buffer (tp-surface-test--leaf
+                               'root (propertize "abc" property (copy-sequence "OLD")))
+                       '(:capability content :coordinate-mounts t)))
+             (expected (tp--shadow-batch-output-create
+                        (buffer-string)
+                        (tp-commit-batch-create :base-revision 1 :target-revision 2
+                                                :base-extent 3 :target-extent 3))))
+        (let ((inhibit-modification-hooks t)) (put-text-property 1 4 property "old"))
+        (let* ((tick (buffer-modified-tick))
+               (actual (tp--shadow-current-artifact surface expected)))
+          (should (stringp (plist-get actual :output)))
+          (should captured)
+          (when (eq when-to-mutate 'after) (aset captured 0 ?X))
+          (should (= tick (buffer-modified-tick)))
+          (should (equal (get-text-property 0 property (plist-get actual :output)) "old"))
+          (should-not
+           (tp--shadow-artifact-equal-p
+            (plist-put (copy-sequence actual) :output expected) actual)))))))
+
 (ert-deftest tp-surface-test-shadow-batch-replay-preserves-exact-properties ()
   "Shadow replay preserves Unicode, properties, order, and input ownership."
   (let* ((opaque (make-symbol "owner"))

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))
@@ -2086,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)
@@ -2096,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)))
+                   (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."
@@ -2119,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
@@ -2153,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))
@@ -2171,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))
@@ -2620,7 +2684,7 @@ same mount record twice.  Queue spines are private; no mount IDs are allocated."
         (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))))))))
 
@@ -2628,6 +2692,10 @@ same mount record twice.  Queue spines are private; no mount IDs are allocated."
   "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)
@@ -2696,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)
@@ -2732,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."
@@ -2756,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
@@ -3027,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))))
@@ -3054,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))
@@ -3469,6 +3599,152 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
         (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)
   "Return STRING with absolute property OPERATIONS rebased from BASE."
@@ -3494,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
@@ -3520,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)
@@ -3534,7 +3822,18 @@ 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)
@@ -3596,7 +3895,10 @@ batch, or nil when publication does not use a commit batch."
                                       (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)))))
@@ -3699,7 +4001,10 @@ batch, or nil when publication does not use a commit batch."
                (= (tp-commit-batch-base-extent commit-batch)
                   (length (plist-get rollback-expected :output)))
                (= (tp-commit-batch-target-extent commit-batch)
-                  (length (plist-get commit-expected :output)))))
+                  (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
@@ -3813,6 +4118,25 @@ batch, or nil when publication does not use a commit batch."
               (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)
@@ -3911,6 +4235,7 @@ batch, or nil when publication does not use a commit batch."
             (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)
@@ -3942,6 +4267,9 @@ batch, or nil when publication does not use a commit batch."
   "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 ()
@@ -4011,6 +4339,39 @@ batch, or nil when publication does not use a commit batch."
           (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)))
@@ -4029,6 +4390,7 @@ batch, or nil when publication does not use a commit batch."
                  (lambda ()
                    (tp--restore-property-journals
                     (gethash 'journals state))))
+        (attempt 'retained-output #'tp--restore-retained-batch-output)
         (dolist (entry (gethash 'snapshots state))
           (attempt
            (list 'surface
@@ -4290,7 +4652,7 @@ batch, or nil when publication does not use a commit batch."
       (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))