docs/API-REFERENCE.md

@@ -390,19 +390,6 @@ 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,49 +161,6 @@
       (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,46 +14,6 @@
 (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,30 +99,6 @@
    :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
@@ -336,17 +312,10 @@
    :type 'tp-publication-binding-error)
   (with-temp-buffer
     (let* ((mount-ids (list 'mount-a))
-           (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))
+           (entry (tp-transaction-test--entry :mount-ids mount-ids))
            (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
@@ -357,10 +326,6 @@
       (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,7 +279,6 @@ 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)
@@ -310,7 +309,6 @@ 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)))
@@ -346,7 +344,6 @@ 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)
@@ -409,8 +406,7 @@ 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, vectors and character tables are copied recursively.
-Functions, records,
+Cons cells, strings, and vectors 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
@@ -424,29 +420,6 @@ 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)
@@ -458,8 +431,7 @@ 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, character-table and non-record vector graphs are copied with sharing
-and cycles intact."
+string, 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,51 +205,12 @@ 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 #'tp--native-property-value-equal-p
+         id :equality #'equal
          :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))
-             (tp--text-property-semantic-equal-p a b)
+             (equal-including-properties a b)
            (equal a b)))
        (tp--plan-props-equal-p (tp-surface-plan-props left)
                                (tp-surface-plan-props right))
@@ -1244,21 +1244,15 @@ 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--mouse-face-groups-equal-p
-    (left left-start left-end right right-start right-end)
-  "Compare native hover boundaries in LEFT and RIGHT without comparing identities.
-LEFT-START..LEFT-END and RIGHT-START..RIGHT-END delimit equal-length ranges.
-Each snapshot may own different face objects, but its contiguous grouping
-must agree.  Native interval traversal requires no property-value copies."
-  (let ((match t))
-    (while (and match (< left-start left-end))
-      (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-properties-canonical-at (text position)
+  "Return TEXT properties at POSITION in deterministic key order."
+  (sort
+   (cl-loop for (property value) on (text-properties-at position text)
+            by #'cddr
+            collect (cons property value))
+   (lambda (left right)
+     (string< (symbol-name (car left))
+              (symbol-name (car right))))))
 
 (defun tp--text-property-semantic-equal-p (left right)
   "Return non-nil when propertized strings LEFT and RIGHT are policy-equal."
@@ -1270,16 +1264,14 @@ must agree.  Native interval traversal requires no property-value copies."
     ;; 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 (tp--plan-props-equal-p
-                      (text-properties-at position left)
-                      (text-properties-at position right))
+             (unless (equal-including-properties
+                      (tp--text-properties-canonical-at left position)
+                      (tp--text-properties-canonical-at right position))
                (setq equal-p nil))
              (setq position
                    (min (or (next-property-change position left limit) limit)
@@ -1324,35 +1316,14 @@ 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))
-         (anchors (tp--pair-outside-ranges old-outside new-outside))
-         previous)
-    (when
-        (or
-         (and (= (cl-loop for (start . end) in old-outside sum (- end start))
-                 (cl-loop for (start . end) in new-outside sum (- end start)))
-              (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)))))
+         (new-outside (tp--complement-ranges (length new) new-ranges)))
+    (let ((old-gap (tp--substring-ranges old old-outside))
+          (new-gap (tp--substring-ranges new new-outside)))
+      (when (or (tp--text-property-semantic-equal-p old-gap new-gap)
+                (tp--scope-outside-separator-equivalent-p old-gap new-gap))
+        (list :patches
+              (tp--scope-patches-between-anchors
+               old new (tp--pair-outside-ranges old-outside new-outside)))))))
 
 (defun tp--prepare-content-scope
     (surface rendered mount-specs objects options)
@@ -1832,6 +1803,11 @@ 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))
@@ -2006,10 +1982,7 @@ 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.  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."
+:new-end, and a propertized :replacement string."
   (unless (and (integerp base-revision) (>= base-revision 0)
                (integerp target-revision)
                (= target-revision (1+ base-revision)))
@@ -2036,17 +2009,7 @@ construction, and only the final propertized replacement is retained."
                      (stringp replacement)
                      (= (length replacement) (- new-end new-start)))
           (signal 'tp-surface-error (list :commit-patch patch)))
-        (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))
+        (push (copy-tree patch) copy)
         (setq old-cursor old-end new-cursor new-end)))
     (unless (= (- base-extent old-cursor)
                (- target-extent new-cursor))
@@ -2110,13 +2073,9 @@ 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 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."
+  "Apply BATCH's already validated patches to SURFACE."
   (let ((buffer (tp--surface-buffer surface))
-        (base (marker-position (tp--surface-start surface)))
-        (text-operations 0) (property-operations 0))
+        (base (marker-position (tp--surface-start surface))))
     (with-current-buffer buffer
       (save-restriction
         (widen)
@@ -2124,39 +2083,15 @@ Return the actual (TEXT-OPERATIONS . PROPERTY-OPERATIONS) counts."
                (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))
-                   (old (buffer-substring-no-properties start end))
-                   (prefix (tp--common-prefix-length old 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))))))))
+                  (replacement (plist-get patch :replacement)))
+              (delete-region start end)
+              (goto-char start)
+              (insert replacement))))))
     (set-marker (tp--surface-start surface) base buffer)
     (set-marker (tp--surface-end surface)
-                (+ base (tp-commit-batch-target-extent batch)) buffer)
-    (cons text-operations property-operations)))
+                (+ base (tp-commit-batch-target-extent batch)) buffer)))
 
 (defun tp--commit-batch-validate-buffer (surface batch)
   "Validate BATCH's published extent and changed spans on SURFACE."
@@ -2171,7 +2106,7 @@ Return the actual (TEXT-OPERATIONS . PROPERTY-OPERATIONS) counts."
       (let ((start (+ base (plist-get patch :new-start)))
             (end (+ base (plist-get patch :new-end)))
             (replacement (plist-get patch :replacement)))
-        (unless (tp--text-property-semantic-equal-p
+        (unless (equal-including-properties
                  (with-current-buffer buffer (buffer-substring start end))
                  replacement)
           (signal 'tp-publication-mismatch
@@ -2205,23 +2140,12 @@ Return the actual (TEXT-OPERATIONS . PROPERTY-OPERATIONS) counts."
          (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)))
-         counts success)
+         success)
     (unwind-protect
         (progn
-          (setq counts (tp--commit-batch-apply-patches surface batch))
+          (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))
@@ -2234,15 +2158,14 @@ Return the actual (TEXT-OPERATIONS . PROPERTY-OPERATIONS) counts."
                       :surface-id (tp--surface-id surface)
                       :old-revision old-revision
                       :new-revision (tp-commit-batch-target-revision batch)
-                      :text-operations (car counts)
-                      :property-operations (cdr counts) :commit-batch t
+                      :text-operations (length (tp-commit-batch-patches batch))
+                      :property-operations 0 :commit-batch t
                       :rolled-back nil :failure nil))
           (accept-change-group group)
           (setq success t)
           (tp-surface-report surface))
       (unless success
         (tp--cancel-change-group-safely group)
-        (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))
@@ -2561,27 +2484,13 @@ 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 &optional retained-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)))))
+(defun tp--prepared-mount-signature (prepared)
+  "Return PREPARED's stable mount attachment signature."
   (mapcar (lambda (spec)
             (list (plist-get spec :object) (plist-get spec :anchor)
                   (plist-get spec :start) (plist-get spec :end)
                   (plist-get spec :tags)))
-            (tp--prepared-surface-mount-specs prepared))))
+          (tp--prepared-surface-mount-specs prepared)))
 
 (defun tp--live-mount-signature (surface)
   "Return SURFACE's stable live mount signature."
@@ -2601,65 +2510,40 @@ RETAINED-SIGNATURE may supply the already captured live signature."
   (or (tp--surface-mount-id mount)
       (setf (tp--surface-mount-id mount) (cl-incf tp--mount-id-counter))))
 
-(defun tp--mount-match-queues (mounts object capability seen)
-  "Group matching MOUNTS by anchor identity and equal tags in live order.
-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))
+(defun tp--mount-spec-matches-live-p (spec mount capability)
+  "Return non-nil when SPEC denotes live MOUNT for CAPABILITY."
+  (and (eq (plist-get spec :object) (tp--surface-mount-object mount))
        (eq capability (tp--surface-mount-capability mount))
-                 (not (gethash mount seen)))
-        (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))
+       (eq (plist-get spec :anchor) (tp--surface-mount-anchor mount))
+       (equal (plist-get spec :tags) (tp--surface-mount-tags mount))))
 
 (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))
-         (live (tp--surface-mounts surface)))
+         (capability (tp--surface-capability 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* ((object (plist-get spec :object))
-                   (anchors
-                    (or (gethash object queues-by-object)
-                        ;; Cache empty queues too: later unmatched specs must
-                        ;; not rebuild the same object's live bucket.
-                        (puthash object
-                                 (tp--mount-match-queues
-                                  (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))
+          (let ((match
+                 (cl-find-if
+                  (lambda (mount)
+                    (and (not (gethash mount used))
+                         (tp--mount-spec-matches-live-p
+                          spec mount capability)))
+                  (gethash (plist-get spec :object) live-by-object))))
+            (when match (puthash match t used))
             (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)
@@ -2684,7 +2568,7 @@ same mount record twice.  Queue spines are private; no mount IDs are allocated."
         (with-current-buffer (tp--surface-buffer surface)
           (save-restriction
             (widen)
-            (tp--text-property-semantic-equal-p
+            (equal-including-properties
              (buffer-substring start end)
              (tp--prepared-surface-rendered prepared))))))))
 
@@ -2692,10 +2576,6 @@ 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)
@@ -2764,7 +2644,7 @@ the transaction can commit."
                           (substring-no-properties rendered)))
         (signal 'tp-publication-mismatch
                 (list :buffer buffer :start start :end end)))
-      (tp--text-property-semantic-equal-p
+      (equal-including-properties
        (buffer-substring start end) rendered))))
 
 (defun tp--content-text-operation (surface rendered)
@@ -2800,68 +2680,8 @@ 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."
@@ -2884,9 +2704,6 @@ 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
@@ -3158,7 +2975,7 @@ the generic property-operation ledger."
          (range (tp--surface-range surface))
          (start (car range))
          (end (cdr range))
-         (changed (not (tp--text-property-semantic-equal-p
+         (changed (not (equal-including-properties
                         (with-current-buffer buffer
                           (buffer-substring start end))
                         rendered))))
@@ -3185,12 +3002,13 @@ 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))
-             (counts (tp--commit-batch-apply-patches surface batch)))
+      (let ((surface (tp--prepared-surface-surface prepared)))
+        (tp--commit-batch-apply-patches surface batch)
         (tp--publication-step 'text surface)
         (tp--commit-batch-validate-buffer surface batch)
         (tp--publication-step 'property surface)
-        (cl-return-from publish counts)))
+        (cl-return-from publish
+          (cons (length (tp-commit-batch-patches batch)) 0))))
   (let* ((surface (tp--prepared-surface-surface prepared))
          (buffer (tp--surface-buffer surface))
          (rendered (tp--prepared-surface-rendered prepared))
@@ -3588,162 +3406,13 @@ 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 ((patches (tp-commit-batch-patches batch)))
-    (if (null patches)
-        (copy-sequence string)
-      (let ((cursor 0) pieces)
-        (dolist (patch patches)
-          (push (substring string cursor (plist-get patch :old-start)) pieces)
-          (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)))))))
+  (let ((result (copy-sequence string)))
+    (dolist (patch (reverse (tp-commit-batch-patches batch)))
+      (setq result
+            (concat (substring result 0 (plist-get patch :old-start))
+                    (plist-get patch :replacement)
+                    (substring result (plist-get patch :old-end)))))
+    result))
 
 (defun tp--shadow-apply-property-operations-to-string
     (string base operations)
@@ -3770,9 +3439,7 @@ segment and seam evidence with precommit validation without copying output."
   (let ((surface (tp--prepared-surface-surface prepared)))
     (if (eq (tp--surface-capability surface) 'content)
         (if-let* ((batch (tp--prepared-surface-commit-batch prepared)))
-            (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))
+            (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
@@ -3784,6 +3451,24 @@ segment and seam evidence with precommit validation without copying output."
   (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))
@@ -3798,21 +3483,11 @@ segment and seam evidence with precommit validation without copying output."
        (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))
-       (let ((output (plist-get expected :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))))))
+       (equal-including-properties
+        (plist-get expected :output) (plist-get actual :output))))
 
-(defun tp--shadow-current-artifact (surface &optional expected-output)
-  "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."
+(defun tp--shadow-current-artifact (surface)
+  "Return a normalized read-only artifact for current SURFACE state."
   (list :buffer (tp--surface-buffer surface)
         :revision (tp--surface-revision surface)
         :plan (tp--surface-plan surface)
@@ -3822,25 +3497,12 @@ custom, or unstable comparison keeps an independent snapshot for diagnostics."
         :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
-        (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))))
+        :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.
-For real surface entries, the diff slot references PREPARED's exact commit
-batch, or nil when publication does not use a commit batch."
+JOURNALS and VIEWS are exact references to the shared rollback state."
   (let* ((prepared (tp--assign-prepared-mount-ids prepared))
          (surface (tp--prepared-surface-surface prepared))
          (buffer (tp--surface-buffer surface))
@@ -3849,11 +3511,6 @@ batch, or nil when publication does not use a commit batch."
          (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
@@ -3863,8 +3520,8 @@ batch, or nil when publication does not use a commit batch."
                 :object-ids
                 (tp--shadow-object-ids
                  (tp--prepared-surface-objects prepared))
-                :mount-ids target-mount-ids
-                :mounts (tp--prepared-mount-signature prepared old-mounts)
+                :mount-ids (tp--prepared-target-mount-ids prepared)
+                :mounts (tp--prepared-mount-signature prepared)
                 :ledger
                 (tp--shadow-ledger-spec-signature
                  (tp--prepared-surface-ledger-specs prepared))
@@ -3886,53 +3543,36 @@ batch, or nil when publication does not use a commit batch."
                 :point point
                 :output old-output))
          (expected (list :commit commit-expected
-                         :rollback rollback-expected))
-         (old-revision (tp--surface-snapshot-revision snapshot))
-         (new-revision (1+ old-revision))
-         (shadow-validator
-          (lambda (_entry phase)
-            (let* ((target (plist-get expected
-                                      (if (eq phase 'commit)
-                                          :commit
-                                        :rollback)))
-                   (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)))))
-    (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
+                         :rollback rollback-expected)))
+    (tp--publication-target-entry-create
      :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)
+     :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 old-revision
-     :new-revision new-revision
+     :old-revision (tp--surface-snapshot-revision snapshot)
+     :new-revision (1+ (tp--surface-snapshot-revision snapshot))
      :plan (tp--prepared-surface-plan prepared)
-     :diff commit-batch
+     :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 authority-token
+     :authority-token (make-symbol "tp-publication-entry-authority")
      :mapping-generation mapping-generation
      :shadow-expected expected
-     :shadow-validator shadow-validator)))
+     :shadow-validator
+     (lambda (_entry phase)
+       (let* ((target (plist-get expected
+                                 (if (eq phase 'commit)
+                                     :commit
+                                   :rollback)))
+              (actual (tp--shadow-current-artifact surface)))
+         (list :equivalent (tp--shadow-artifact-equal-p target actual)
+               :surface-id (tp--surface-id surface)
+               :expected target :actual actual))))))
 
 (defun tp--surface-shadow-target-entries
     (prepared snapshots journals views batch-id mapping-generation)
@@ -3953,19 +3593,9 @@ batch, or nil when publication does not use a commit batch."
                         (aref rollback 0)))
          (snapshot (and prepared (aref rollback 1)))
          (surface (and (tp--prepared-surface-p 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))))
+                       (tp--prepared-surface-surface prepared))))
     (unless
-        (and surface (tp--surface-snapshot-p snapshot)
-             (tp-prepare-context-p context)
-             (tp--context-active context)
-             (eq (tp--context-surface context) surface)
+        (and surface snapshot
              (tp--publication-target-entry-bound-p
               entry
               (tp-publication-batch-candidate-transaction-id candidate)
@@ -3976,8 +3606,6 @@ batch, or nil when publication does not use a commit batch."
                  (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)
@@ -3988,23 +3616,8 @@ batch, or nil when publication does not use a commit batch."
                  (tp--prepared-surface-objects prepared))
              (eq (tp-publication-target-entry-ranges entry)
                  (tp--prepared-surface-mount-specs prepared))
-             (eq (tp-publication-target-entry-client-state entry)
+             (equal (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
@@ -4118,25 +3731,6 @@ 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)
@@ -4235,7 +3829,6 @@ Ordinary publication and the full postcommit shadow remain diagnostic."
             (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)
@@ -4267,9 +3860,6 @@ Ordinary publication and the full postcommit shadow remain diagnostic."
   "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 ()
@@ -4339,39 +3929,6 @@ Ordinary publication and the full postcommit shadow remain diagnostic."
           (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)))
@@ -4390,7 +3947,6 @@ on rollback restores native group identities even when a host disabled undo."
                  (lambda ()
                    (tp--restore-property-journals
                     (gethash 'journals state))))
-        (attempt 'retained-output #'tp--restore-retained-batch-output)
         (dolist (entry (gethash 'snapshots state))
           (attempt
            (list 'surface
@@ -4652,7 +4208,7 @@ on rollback restores native group identities even when a host disabled undo."
       (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-policy-equal-p property current published)
+        (if (tp--property-state-equal-p current published)
             (push (list :start start :end next :property property
                         :present (tp--property-ledger-baseline-present entry)
                         :value (tp--property-ledger-baseline-value entry))

tp-transaction.el

@@ -83,12 +83,11 @@
 (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 (make-hash-table :test #'equal))
-             (unique t))
+       (let (seen (unique t))
          (dolist (item items unique)
-           (if (gethash item seen)
+           (if (member item seen)
                (setq unique nil)
-             (puthash item t seen))))))
+             (push item seen))))))
 
 (cl-defstruct (tp-publication-target-entry
                (:constructor tp--make-publication-target-entry)
@@ -116,20 +115,6 @@
   (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
@@ -141,9 +126,13 @@ 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 (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)
+  (unless (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)))
     (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)))