diff --git a/tests/tp-surface-tests.el b/tests/tp-surface-tests.el index 4c0a075..9d47d22 100644 --- a/tests/tp-surface-tests.el +++ b/tests/tp-surface-tests.el @@ -2003,6 +2003,141 @@ prepare context." (should (tp-object-live-p hidden)) (should-not (tp-object-mounts hidden))))) +(ert-deftest tp-surface-test-prepared-mount-ids-preserve-signature-order () + "Mount IDs follow first-unused EQ identities and equal tags in spec order." + (let* ((tp--mount-id-counter 1000) + (object (tp--make-surface-object :id 1)) + (equal-object (copy-sequence object)) + (other-object (tp--make-surface-object :id 2)) + (anchor (tp--make-range-anchor :id 1)) + (equal-anchor (copy-sequence anchor)) + (index (make-hash-table :test #'eq)) + (records + (list (list nil object 'content anchor '(:slot unused)) + (list 11 object 'content anchor '(:slot duplicate)) + (list 12 object 'properties anchor '(:slot duplicate)) + (list nil object 'content anchor '(:slot duplicate)) + (list 13 object 'content equal-anchor '(:slot duplicate)) + (list 14 object 'content anchor '(:slot other)) + (list 21 equal-object 'content anchor '(:slot duplicate)) + (list 31 other-object 'content nil '(:slot other)))) + (live + (cl-loop for (id owner capability attachment tags) in records + for position from 1 + collect (tp--make-surface-mount + :id id :object owner :capability capability + :anchor attachment :tags (copy-tree tags) + :start position :end (1+ position)))) + (spec-signatures + (list (list object anchor '(:slot other)) + (list equal-object anchor '(:slot duplicate)) + (list object anchor '(:slot duplicate)) + (list object equal-anchor '(:slot duplicate)) + (list object anchor '(:slot duplicate)) + (list object anchor '(:slot duplicate)) + (list equal-object equal-anchor '(:slot duplicate)) + (list equal-object anchor '(:slot duplicate)) + (list other-object nil '(:slot other)) + (list object anchor '(:slot absent)))) + (specs + (cl-loop for (owner attachment tags) in spec-signatures + for position from 101 + collect (list :object owner :anchor attachment + :tags (copy-tree tags) :mount-id -1 + :start position :end (+ position 2)))) + (surface (tp--make-surface :capability 'content + :mounts live :mount-index index)) + (prepared (tp--make-prepared-surface :surface surface :mount-specs specs)) + saved-buckets) + (should (equal object equal-object)) + (should-not (eq object equal-object)) + (should (equal anchor equal-anchor)) + (should-not (eq anchor equal-anchor)) + (dolist (mount live) + (let ((owner (tp--surface-mount-object mount))) + (puthash owner (append (gethash owner index) (list mount)) index))) + ;; Preserve the matcher's single-use and identity checks even when a + ;; bucket repeats a record or contains an entry owned by another object. + (puthash object (append (gethash object index) + (list (nth 1 live) (nth 6 live))) + index) + (maphash + (lambda (owner bucket) + (push (list owner bucket (copy-sequence bucket) + (cl-loop for tail on bucket collect tail)) + saved-buckets)) + index) + (should (eq prepared (tp--assign-prepared-mount-ids prepared))) + (should (equal (mapcar (lambda (spec) (plist-get spec :mount-id)) + (tp--prepared-surface-mount-specs prepared)) + '(14 21 11 13 1001 1002 1003 1004 31 1005))) + (should (= tp--mount-id-counter 1005)) + ;; An unmatched live mount must not receive an ID while an index is built. + (should-not (tp--surface-mount-id (car live))) + (should (= (tp--surface-mount-id (nth 3 live)) 1001)) + (should (eq live (tp--surface-mounts surface))) + (should (eq index (tp--surface-mount-index surface))) + (should (= (hash-table-count index) 3)) + (dolist (saved saved-buckets) + (let ((bucket (gethash (nth 0 saved) index))) + (should (eq (nth 1 saved) bucket)) + (should (equal (nth 2 saved) bucket)) + (should (cl-every #'identity + (cl-mapcar #'eq (nth 3 saved) + (cl-loop for tail on bucket collect tail)))))) + (cl-loop for spec in (tp--prepared-surface-mount-specs prepared) + for (owner attachment tags) in spec-signatures + for position from 101 + do (should (eq owner (plist-get spec :object))) + (should (eq attachment (plist-get spec :anchor))) + (should (equal tags (plist-get spec :tags))) + (should (= position (plist-get spec :start))) + (should (= (+ position 2) (plist-get spec :end)))))) + +(ert-deftest tp-surface-test-prepared-mount-ids-bound-candidate-scans () + "Growing duplicate mounts must not repeatedly scan their used prefix." + (let ((assign (tp-surface-test--source-function 'tp--assign-prepared-mount-ids)) + (find-if (symbol-function 'cl-find-if)) + samples) + (dolist (count '(16 32 64)) + (let* ((tp--mount-id-counter 1000) + (object (tp--make-surface-object :id 1)) + (live (cl-loop for id from 1 to count + collect (tp--make-surface-mount + :id id :object object :capability 'content + :tags (list :slot 'same) :start id :end (1+ id)))) + (index (make-hash-table :test #'eq)) + (surface (tp--make-surface :capability 'content + :mounts live :mount-index index)) + (prepared + (tp--make-prepared-surface + :surface surface + :mount-specs + (cl-loop for position from 101 below (+ 101 count) + collect (list :object object :tags (list :slot 'same) + :start position :end (1+ position))))) + (visits 0)) + (puthash object live index) + ;; Count actual predicate visits, including candidates rejected by the + ;; used-prefix check before comparing their matching signature. + ;; This bounds candidate scans, not the complete assignment algorithm. + (cl-letf (((symbol-function 'cl-find-if) + (lambda (predicate sequence &rest options) + (apply find-if + (lambda (mount) + (cl-incf visits) + (funcall predicate mount)) + sequence options)))) + (funcall assign prepared)) + (should (equal (mapcar (lambda (spec) (plist-get spec :mount-id)) + (tp--prepared-surface-mount-specs prepared)) + (number-sequence 1 count))) + (should (= tp--mount-id-counter 1000)) + (push (cons count visits) samples))) + (ert-info ((format "mount count / candidate visits: %S" (reverse samples))) + (dolist (sample samples) + (should (<= (cdr sample) (* 2 (car sample)))))))) + (ert-deftest tp-surface-test-disjoint-mount-index-rolls-back-atomically () "Failed publication restores every mount of a retained logical object." (tp-surface-test--with-buffer @@ -2028,6 +2163,10 @@ prepare context." buffer producer '(:capability content))) (logical (tp-object-resolve surface '(root logical))) (mounts (tp-object-mounts logical)) + (live (tp--surface-mounts surface)) + (index (tp--surface-mount-index surface)) + (bucket (gethash logical index)) + (mount-ids (mapcar #'tp--surface-mount-id live)) (revision (tp-surface-revision surface))) (setq value "LONG") (let ((tp--surface-publication-step-function @@ -2038,7 +2177,20 @@ prepare context." (should (= (tp-surface-revision surface) revision)) (should (equal (buffer-string) "AA")) (should (eq logical (tp-object-resolve surface '(root logical)))) - (should (equal (tp-object-mounts logical) mounts)))))) + (should (equal (tp-object-mounts logical) mounts)) + (should (eq live (tp--surface-mounts surface))) + (should (eq index (tp--surface-mount-index surface))) + (should (eq bucket (gethash logical index))) + (should (equal mount-ids (mapcar #'tp--surface-mount-id live))) + (tp-surface-update surface producer) + (should (= (tp-surface-revision surface) (1+ revision))) + (should (equal (buffer-string) "LONGLONG")) + (should (eq logical (tp-object-resolve surface '(root logical)))) + (should (equal mount-ids + (mapcar #'tp--surface-mount-id (tp--surface-mounts surface)))) + (should (equal (tp-object-mounts logical) + '((:start 1 :end 5 :tags left) + (:start 5 :end 9 :tags right)))))))) (ert-deftest tp-surface-test-properties-capability-rejects-text () "A properties-only mount cannot replace host text." diff --git a/tp-surface.el b/tp-surface.el index 70d7a9a..164fa49 100644 --- a/tp-surface.el +++ b/tp-surface.el @@ -2510,40 +2510,65 @@ caller reads the scalar summary from the surface instead." (or (tp--surface-mount-id mount) (setf (tp--surface-mount-id mount) (cl-incf tp--mount-id-counter)))) -(defun tp--mount-spec-matches-live-p (spec mount capability) - "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)) - (eq (plist-get spec :anchor) (tp--surface-mount-anchor mount)) - (equal (plist-get spec :tags) (tp--surface-mount-tags mount)))) +(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)) + (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)) (defun tp--assign-prepared-mount-ids (prepared) "Bind PREPARED mount specs to stable live or fresh private mount ids." (let* ((surface (tp--prepared-surface-surface prepared)) - (capability (tp--surface-capability surface)) - (live (tp--surface-mounts surface)) - (live-by-object (tp--surface-mount-index surface)) - (used (make-hash-table :test #'eq))) + (live (tp--surface-mounts surface))) (if (tp--prepared-surface-retained-mount-state-p prepared) (dolist (mount live) (tp--ensure-surface-mount-id mount)) - (setf - (tp--prepared-surface-mount-specs prepared) - (mapcar - (lambda (spec) - (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)))) + (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)) + (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))))) prepared)) (defun tp--prepared-target-mount-ids (prepared)