tp/tp-reactive.el

;;; tp-reactive.el --- Exact signals and binding scheduler -*- lexical-binding: t -*-

;; Copyright (C) 2024-2026 Geekinney

;; Author: Geekinney (kinneyzhang666@gmail.com)

;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 3 of
;; the License, or (at your option) any later version.

;;; Commentary:

;; TP 1.0's exact signal-to-binding dependency graph, transaction-local
;; scheduler, scoped variable adapters, and rollback state.

;;; Code:

(require 'cl-lib)
(require 'tp-core)
(require 'tp-transaction)

(define-error 'tp-reactive-error "TP reactive runtime error")
(define-error 'tp-invalid-signal-scope "Invalid TP signal scope"
  'tp-reactive-error)
(define-error 'tp-disposed-signal "TP signal is disposed" 'tp-reactive-error)
(define-error 'tp-disposed-binding "TP binding is disposed" 'tp-reactive-error)
(define-error 'tp-binding-cycle "TP binding dependency cycle"
  'tp-reactive-error)

(cl-defstruct (tp-signal (:constructor tp--make-signal))
  "Reactive source with a committed value and exact subscribers."
  id committed-value equality subscribers scope adapter-key disposed revision)

(cl-defstruct (tp-binding (:constructor tp--make-binding))
  "Memoized computation installed on one owner and namespaced key."
  id owner key compute equality last-value initialized-p dependencies
  subscribers dirty state revision lifecycle disposed)

(cl-defstruct (tp--binding-snapshot
               (:constructor tp--make-binding-snapshot))
  compute equality last-value initialized-p dependencies dirty state
  revision lifecycle disposed)

(cl-defstruct (tp--transaction-participant
               (:constructor tp--make-transaction-participant))
  "One structured participant shared by the v1 and v2 transaction views."
  key publish rollback protocol order stage precommit after-commit journal state)

(cl-defstruct (tp--signal-commit-entry
               (:constructor tp--make-signal-commit-entry))
  "One transaction signal's candidate and exact committed rollback state."
  signal old-committed-value old-revision candidate-value)

(defconst tp--reactive-absent (make-symbol "tp-reactive-absent"))

(defvar tp--signal-id-counter 0)
(defvar tp--binding-id-counter 0)
(defvar tp--signals nil)
(defvar tp--bindings nil)
(defvar tp--owner-bindings (make-hash-table :test #'eq))
(defvar tp--variable-signals (make-hash-table :test #'equal))
(defvar tp--variable-signal-watched nil)

(defvar-local tp--buffer-signals nil)

(defvar tp--reactive-counters
  (list :invalidated 0 :recomputed 0 :skipped 0
        :subscription-added 0 :subscription-removed 0))

(defvar tp--transaction-active nil)

;;;###autoload
(defun tp-transaction-active-p ()
  "Return non-nil while the current dynamic extent is in a TP transaction."
  (and tp--transaction-active t))
(defvar tp--transaction-signal-values nil)
(defvar tp--transaction-signals nil)
(defvar tp--transaction-dirty-set nil)
(defvar tp--transaction-dirty-queue nil)
(defvar tp--transaction-binding-snapshots nil)
(defvar tp--transaction-created-bindings nil)
(defvar tp--transaction-recompute-counts nil)
(defvar tp--transaction-extensions nil)
(defvar tp--transaction-counter-start nil)
(defvar tp--transaction-after-commit-callbacks nil)
(defvar tp--transaction-participants nil)
(defvar tp--transaction-participant-keys nil)
(defvar tp--transaction-participant-order 0)
(defvar tp--transaction-published-participants nil)
(defvar tp--transaction-signal-commit-journal nil)
(defvar tp--transaction-id nil)
(defvar tp--transaction-phase nil)
(defvar tp--transaction-phase-start nil)
(defvar tp--transaction-phase-timings nil)
(defvar tp--transaction-publication-batch nil)
(defvar tp--transaction-final-marker-registry nil)
(defvar tp--transaction-final-marker-owner-keys nil)
(defvar tp--transaction-final-marker-count 0)
(defvar tp--transaction-final-marker-slot-writes 0)
(defvar tp--transaction-final-markers-frozen-p nil)
(defvar tp--transaction-applied-final-marker-count 0)
(defvar tp--transaction-marker-restore-failures nil)
(defvar tp--transaction-outcome nil)
(defvar tp--transaction-outcome-cell nil)
(defvar tp--transaction-contained-failures nil)
(defvar tp--last-transaction-diagnostics nil)
(defvar tp--last-transaction-outcome nil)
(defvar tp--last-shadow-proof nil)
(defvar tp--current-binding nil)
(defvar tp--binding-compute-stack nil)
(defvar tp--collected-dependency-set nil)
(defvar tp--collected-dependencies nil)
(defvar tp--binding-touch-function nil)
(defvar tp--binding-changed-functions nil)
(defvar tp--transaction-publish-functions nil)
(defvar tp--transaction-precommit-functions nil
  "Internal TP-owned precommit hook symbols in deterministic order.")
(defconst tp--transaction-precommit-allowed-functions
  '(tp--surface-precommit-transaction)
  "Exact TP-owned symbols allowed in the internal precommit registry.")
(defvar tp--transaction-final-accept-function
  #'tp--transaction-noop-final-accept
  "Internal single final-accept function for the active transaction.")
(defvar tp--transaction-rollback-functions nil)
(defvar tp--transaction-rollback-final-functions nil)
(defvar tp--transaction-committed-functions nil)

(defvar tp--transaction-artifact-mode 'shadow
  "Internal artifact route; the live writer remains the v1 coordinator.")

(defvar tp--transaction-participant-precommit-allowed-functions nil
  "Declared internal structured-participant precommit validators.")

(defconst tp--transaction-condition-trailer-tag
  (make-symbol "tp--transaction-condition-trailer")
  "Unforgeable tag separating primary condition data from TP metadata.")

(defun tp--counter-increment (key)
  "Increment reactive counter KEY."
  (setq tp--reactive-counters
        (plist-put tp--reactive-counters key
                   (1+ (plist-get tp--reactive-counters key)))))

(defun tp-reactive-counters ()
  "Return public signal and binding scheduler counters."
  (copy-sequence tp--reactive-counters))

(defun tp-reactive-reset-counters ()
  "Reset public signal and binding scheduler counters."
  (setq tp--reactive-counters
        (list :invalidated 0 :recomputed 0 :skipped 0
              :subscription-added 0 :subscription-removed 0)))

(defun tp--dependency-subscribers (dependency)
  "Return the subscriber table owned by DEPENDENCY."
  (cond ((tp-signal-p dependency) (tp-signal-subscribers dependency))
        ((tp-binding-p dependency) (tp-binding-subscribers dependency))
        (t (signal 'wrong-type-argument
                   (list '(or tp-signal-p tp-binding-p) dependency)))))

(defun tp--subscription-add (dependency binding)
  "Subscribe BINDING to DEPENDENCY."
  (let ((subscribers (tp--dependency-subscribers dependency)))
    (unless (gethash binding subscribers)
      (puthash binding t subscribers)
      (tp--counter-increment :subscription-added))))

(defun tp--subscription-remove (dependency binding)
  "Unsubscribe BINDING from DEPENDENCY."
  (let ((subscribers (tp--dependency-subscribers dependency)))
    (when (gethash binding subscribers)
      (remhash binding subscribers)
      (tp--counter-increment :subscription-removed))))

(defun tp--sorted-subscribers (dependency)
  "Return DEPENDENCY subscribers ordered by stable binding id."
  (let (bindings)
    (maphash (lambda (binding _present) (push binding bindings))
             (tp--dependency-subscribers dependency))
    (sort bindings (lambda (left right)
                     (< (tp-binding-id left) (tp-binding-id right))))))

(defun tp--binding-snapshot (binding)
  "Return a rollback snapshot of BINDING."
  (tp--make-binding-snapshot
   :compute (tp-binding-compute binding)
   :equality (tp-binding-equality binding)
   :last-value (tp-binding-last-value binding)
   :initialized-p (tp-binding-initialized-p binding)
   :dependencies (copy-sequence (tp-binding-dependencies binding))
   :dirty (tp-binding-dirty binding)
   :state (tp-binding-state binding)
   :revision (tp-binding-revision binding)
   :lifecycle (tp-binding-lifecycle binding)
   :disposed (tp-binding-disposed binding)))

(defun tp--snapshot-binding (binding)
  "Save BINDING once for the active transaction."
  (when (and tp--transaction-active
             (not (memq binding tp--transaction-created-bindings))
             (not (gethash binding tp--transaction-binding-snapshots)))
    (puthash binding (tp--binding-snapshot binding)
             tp--transaction-binding-snapshots)))

(defun tp--owner-binding-table (owner &optional create)
  "Return OWNER's binding table, creating it when CREATE is non-nil."
  (or (gethash owner tp--owner-bindings)
      (when create
        (let ((table (make-hash-table :test #'equal)))
          (puthash owner table tp--owner-bindings)
          table))))

(defun tp--register-binding (binding)
  "Register BINDING under its owner and key."
  (puthash (tp-binding-key binding) binding
           (tp--owner-binding-table (tp-binding-owner binding) t))
  (cl-pushnew binding tp--bindings :test #'eq))

(defun tp--unregister-binding (binding)
  "Remove BINDING from owner and global registries."
  (when-let* ((table (tp--owner-binding-table (tp-binding-owner binding))))
    (remhash (tp-binding-key binding) table)
    (when (zerop (hash-table-count table))
      (remhash (tp-binding-owner binding) tp--owner-bindings)))
  (setq tp--bindings (delq binding tp--bindings)))

(defun tp--enqueue-binding (binding)
  "Add dirty BINDING to the current transaction queue once."
  (unless (gethash binding tp--transaction-dirty-set)
    (puthash binding t tp--transaction-dirty-set)
    (push binding tp--transaction-dirty-queue)))

(defun tp--mark-binding-dirty (binding)
  "Mark live BINDING dirty in the current transaction."
  (when (and (tp-binding-p binding) (not (tp-binding-disposed binding)))
    (tp--snapshot-binding binding)
    (unless (tp-binding-dirty binding)
      (setf (tp-binding-dirty binding) t)
      (tp--counter-increment :invalidated))
    (tp--enqueue-binding binding)))

(defun tp--invalidate-subscribers (dependency &optional skip)
  "Dirty DEPENDENCY subscribers except SKIP."
  (dolist (binding (tp--sorted-subscribers dependency))
    (unless (eq binding skip)
      (tp--mark-binding-dirty binding))))

(defun tp--record-dependency (dependency)
  "Record DEPENDENCY for the binding currently being computed."
  (when tp--current-binding
    (unless (gethash dependency tp--collected-dependency-set)
      (puthash dependency t tp--collected-dependency-set)
      (push dependency tp--collected-dependencies))))

(defun tp--signal-value-in-transaction (signal)
  "Return SIGNAL's candidate or committed value."
  (if tp--transaction-active
      (let ((candidate (gethash signal tp--transaction-signal-values
                                tp--reactive-absent)))
        (if (eq candidate tp--reactive-absent)
            (tp-signal-committed-value signal)
          candidate))
    (tp-signal-committed-value signal)))

(defun tp--validate-live-signal (signal)
  "Signal an error unless SIGNAL is live."
  (unless (tp-signal-p signal)
    (signal 'wrong-type-argument (list 'tp-signal-p signal)))
  (when (tp-signal-disposed signal)
    (signal 'tp-disposed-signal (list (tp-signal-id signal)))))

(defun tp-signal-live-p (signal)
  "Return non-nil when SIGNAL is a live TP signal."
  (and (tp-signal-p signal) (not (tp-signal-disposed signal))))

(defun tp--buffer-signal-kill ()
  "Dispose signals scoped to the buffer being killed."
  (let ((signals tp--buffer-signals))
    (setq tp--buffer-signals nil)
    (dolist (signal signals)
      (tp--dispose-signal signal))))

(cl-defun tp-signal-create (initial-value &key (equality #'equal) (scope 'global))
  "Create a signal holding INITIAL-VALUE.
EQUALITY compares writes.  SCOPE is `global' or a live buffer."
  (unless (functionp equality)
    (signal 'wrong-type-argument (list 'functionp equality)))
  (unless (or (eq scope 'global) (buffer-live-p scope))
    (signal 'tp-invalid-signal-scope (list scope)))
  (let ((signal (tp--make-signal
                 :id (cl-incf tp--signal-id-counter)
                 :committed-value initial-value :equality equality
                 :subscribers (make-hash-table :test #'eq)
                 :scope scope :revision 0)))
    (push signal tp--signals)
    (when (bufferp scope)
      (with-current-buffer scope
        (push signal tp--buffer-signals)
        (add-hook 'kill-buffer-hook #'tp--buffer-signal-kill nil t)))
    signal))

(defun tp-signal-peek (signal)
  "Return SIGNAL's effective value without collecting a dependency."
  (tp--validate-live-signal signal)
  (tp--signal-value-in-transaction signal))

(defun tp-signal-read (signal)
  "Read SIGNAL and register the current binding as a subscriber."
  (tp--validate-live-signal signal)
  (tp--record-dependency signal)
  (tp--signal-value-in-transaction signal))

(defun tp--set-signal-candidate (signal value)
  "Set candidate VALUE for SIGNAL in the active transaction."
  (let ((old (tp--signal-value-in-transaction signal)))
    (unless (funcall (tp-signal-equality signal) old value)
      (when (eq (gethash signal tp--transaction-signal-values
                         tp--reactive-absent)
                tp--reactive-absent)
        (push signal tp--transaction-signals))
      (puthash signal value tp--transaction-signal-values)
      (tp--invalidate-subscribers signal)
      (when (and tp--current-binding
                 (gethash signal tp--collected-dependency-set))
        (tp--mark-binding-dirty tp--current-binding))))
  value)

(defun tp-signal-set (signal value)
  "Set SIGNAL to VALUE transactionally and return VALUE."
  (tp--validate-live-signal signal)
  (if tp--transaction-active
      (tp--set-signal-candidate signal value)
    (tp--call-with-transaction
     (lambda () (tp--set-signal-candidate signal value)))))

(defun tp-signal-subscriber-count (signal)
  "Return the number of subscribers attached to SIGNAL.
Disposed signals return zero."
  (unless (tp-signal-p signal)
    (signal 'wrong-type-argument (list 'tp-signal-p signal)))
  (hash-table-count (tp-signal-subscribers signal)))

(defun tp--binding-dependency-path (start target visited)
  "Return a binding path from START to TARGET, avoiding VISITED."
  (cond
   ((eq start target) (list target))
   ((memq start visited) nil)
   (t
    (cl-loop for dependency in (tp-binding-dependencies start)
             when (tp-binding-p dependency)
             for path = (tp--binding-dependency-path
                         dependency target (cons start visited))
             when path return (cons start path)))))

(defun tp--stack-cycle-path (target)
  "Return the active compute-stack cycle ending at TARGET."
  (let ((path (reverse tp--binding-compute-stack)))
    (while (and path (not (eq (car path) target)))
      (setq path (cdr path)))
    (append path (list target))))

(defun tp--signal-binding-cycle (path)
  "Signal a binding-cycle error for binding PATH."
  (signal 'tp-binding-cycle
          (list (mapcar (lambda (binding)
                          (tp--copy-property-value
                           (tp-binding-key binding)))
                        path))))

(defun tp--validate-binding-read (binding &optional computing-only)
  "Validate reading BINDING from the current computation.
When COMPUTING-ONLY is non-nil, defer old-graph traversal until after a
dirty target has recomputed."
  (when tp--current-binding
    (when (eq (tp-binding-state binding) 'computing)
      (tp--signal-binding-cycle (tp--stack-cycle-path binding)))
    (unless computing-only
      (when-let* ((path (tp--binding-dependency-path
                        binding tp--current-binding nil)))
        (tp--signal-binding-cycle (cons tp--current-binding path))))))

(defun tp--replace-binding-dependencies (binding dependencies)
  "Replace BINDING dependencies with DEPENDENCIES."
  (let ((old (tp-binding-dependencies binding)))
    (dolist (dependency old)
      (unless (memq dependency dependencies)
        (tp--subscription-remove dependency binding)))
    (dolist (dependency dependencies)
      (unless (memq dependency old)
        (tp--subscription-add dependency binding)))
    (setf (tp-binding-dependencies binding) dependencies)))

(defun tp--note-binding-recompute (binding)
  "Record one recomputation of BINDING and reject runaway feedback."
  (let ((count (1+ (gethash binding tp--transaction-recompute-counts 0))))
    (puthash binding count tp--transaction-recompute-counts)
    (when (> count 100)
      (tp--signal-binding-cycle (list binding binding)))))

(defun tp--binding-recompute (binding)
  "Recompute dirty BINDING inside the active transaction."
  (tp--snapshot-binding binding)
  (tp--note-binding-recompute binding)
  (let ((requester tp--current-binding)
        (old (tp-binding-last-value binding))
        (initialized (tp-binding-initialized-p binding))
        (tp--current-binding binding)
        (tp--binding-compute-stack (cons binding tp--binding-compute-stack))
        (tp--collected-dependency-set (make-hash-table :test #'eq))
        (tp--collected-dependencies nil))
    (setf (tp-binding-state binding) 'computing
          (tp-binding-dirty binding) nil)
    (let* ((value (funcall (tp-binding-compute binding)))
           (dependencies (nreverse tp--collected-dependencies))
           (changed (or (not initialized)
                        (not (funcall (tp-binding-equality binding)
                                      old value)))))
      (tp--replace-binding-dependencies binding dependencies)
      (setf (tp-binding-state binding) 'clean)
      (tp--counter-increment :recomputed)
      (if changed
          (progn
            (setf (tp-binding-last-value binding) value
                  (tp-binding-initialized-p binding) t
                  (tp-binding-revision binding)
                  (1+ (tp-binding-revision binding)))
            (run-hook-with-args 'tp--binding-changed-functions
                                binding old value)
            (tp--invalidate-subscribers binding requester))
        (tp--counter-increment :skipped))
      value)))

(defun tp--validate-live-binding (binding)
  "Signal an error unless BINDING is live."
  (unless (tp-binding-p binding)
    (signal 'wrong-type-argument (list 'tp-binding-p binding)))
  (when (tp-binding-disposed binding)
    (signal 'tp-disposed-binding (list (tp-binding-id binding)))))

(defun tp-binding-live-p (binding)
  "Return non-nil when BINDING is a live TP binding."
  (and (tp-binding-p binding) (not (tp-binding-disposed binding))))

(defun tp-binding-read (binding)
  "Read BINDING's memoized value and collect a dependency."
  (tp--validate-live-binding binding)
  (tp--validate-binding-read binding t)
  (when (tp-binding-dirty binding)
    (if tp--transaction-active
        (tp--binding-recompute binding)
      (tp--call-with-transaction (lambda () (tp--binding-recompute binding)))))
  (tp--validate-binding-read binding)
  (tp--record-dependency binding)
  (tp-binding-last-value binding))

(defun tp-binding-subscriber-count (binding)
  "Return the number of bindings depending directly on BINDING.
Disposed bindings return zero."
  (unless (tp-binding-p binding)
    (signal 'wrong-type-argument (list 'tp-binding-p binding)))
  (hash-table-count (tp-binding-subscribers binding)))

(defun tp-binding-dependency-count (binding)
  "Return BINDING's current direct dependency count.
Disposed bindings return zero."
  (unless (tp-binding-p binding)
    (signal 'wrong-type-argument (list 'tp-binding-p binding)))
  (length (tp-binding-dependencies binding)))

(defun tp--validate-binding-options (compute equality lifecycle)
  "Validate binding COMPUTE, EQUALITY, and LIFECYCLE."
  (unless (functionp compute)
    (signal 'wrong-type-argument (list 'functionp compute)))
  (unless (functionp equality)
    (signal 'wrong-type-argument (list 'functionp equality)))
  (unless (memq lifecycle '(delete retain))
    (signal 'tp-reactive-error (list :lifecycle lifecycle))))

(defun tp--bind-in-transaction (owner key compute equality lifecycle)
  "Install COMPUTE for OWNER and KEY in the active transaction.
EQUALITY compares values and LIFECYCLE controls retention."
  (let* ((table (tp--owner-binding-table owner t))
         (binding (gethash key table)))
    (if binding
        (unless (and (eq compute (tp-binding-compute binding))
                     (eq equality (tp-binding-equality binding))
                     (eq lifecycle (tp-binding-lifecycle binding)))
          (tp--snapshot-binding binding)
          (setf (tp-binding-compute binding) compute
                (tp-binding-equality binding) equality
                (tp-binding-lifecycle binding) lifecycle)
          (tp--mark-binding-dirty binding))
      (setq binding
            (tp--make-binding
             :id (cl-incf tp--binding-id-counter)
             :owner owner :key (tp--copy-property-value key) :compute compute
             :equality equality :subscribers (make-hash-table :test #'eq)
             :dirty t :state 'clean :revision 0 :lifecycle lifecycle))
      (tp--register-binding binding)
      (push binding tp--transaction-created-bindings)
      (tp--enqueue-binding binding))
    (when tp--binding-touch-function
      (funcall tp--binding-touch-function binding))
    binding))

(cl-defun tp-bind (owner key compute &key (equality #'equal) (lifecycle 'delete))
  "Idempotently install COMPUTE on OWNER under namespaced KEY.
EQUALITY suppresses unchanged downstream updates.  LIFECYCLE is `delete'
or `retain'."
  (when (null owner)
    (signal 'tp-reactive-error (list :owner owner)))
  (when (null key)
    (signal 'tp-reactive-error (list :binding-key key)))
  (tp--validate-binding-options compute equality lifecycle)
  (if tp--transaction-active
      (tp--bind-in-transaction owner key compute equality lifecycle)
    (tp--call-with-transaction
     (lambda () (tp--bind-in-transaction
                 owner key compute equality lifecycle)))))

(defun tp--bind-precomputed-in-transaction
    (owner key compute value dependencies equality lifecycle)
  "Install OWNER's KEY using COMPUTE, VALUE, and explicit DEPENDENCIES.
EQUALITY controls change detection and LIFECYCLE controls candidate omission."
  (let ((table (tp--owner-binding-table owner t)))
    (when (gethash key table)
      (signal 'tp-reactive-error (list :precomputed-binding-exists key)))
    (dolist (dependency dependencies)
      (cond ((tp-signal-p dependency) (tp--validate-live-signal dependency))
            ((tp-binding-p dependency) (tp--validate-live-binding dependency))
            (t (signal 'wrong-type-argument
                       (list '(or tp-signal-p tp-binding-p) dependency)))))
    (let ((binding
           (tp--make-binding
            :id (cl-incf tp--binding-id-counter)
            :owner owner :key (tp--copy-property-value key) :compute compute
            :equality equality :last-value value :initialized-p t
            :dependencies (copy-sequence dependencies)
            :subscribers (make-hash-table :test #'eq)
            :dirty nil :state 'clean :revision 1 :lifecycle lifecycle)))
      (tp--register-binding binding)
      (push binding tp--transaction-created-bindings)
      (dolist (dependency dependencies)
        (tp--subscription-add dependency binding))
      (when tp--binding-touch-function
        (funcall tp--binding-touch-function binding))
      binding)))

(cl-defun tp-bind-precomputed
    (owner key compute value dependencies
           &key (equality #'equal) (lifecycle 'delete))
  "Install a new binding with precomputed VALUE and explicit DEPENDENCIES.
OWNER and KEY identify the binding; EQUALITY and LIFECYCLE retain their normal
`tp-bind' meanings.
COMPUTE remains the authoritative recomputation function after any dependency
changes.  This entry avoids evaluating COMPUTE merely to rediscover a value
and graph edges already produced by a compiler or pure projection pass."
  (when (null owner)
    (signal 'tp-reactive-error (list :owner owner)))
  (when (null key)
    (signal 'tp-reactive-error (list :binding-key key)))
  (tp--validate-binding-options compute equality lifecycle)
  (unless (proper-list-p dependencies)
    (signal 'wrong-type-argument (list 'proper-list-p dependencies)))
  (if tp--transaction-active
      (tp--bind-precomputed-in-transaction
       owner key compute value dependencies equality lifecycle)
    (tp--call-with-transaction
     (lambda ()
       (tp--bind-precomputed-in-transaction
        owner key compute value dependencies equality lifecycle)))))

(defun tp--detach-binding-dependencies (binding)
  "Remove BINDING from all dependency subscriber tables."
  (dolist (dependency (tp-binding-dependencies binding))
    (tp--subscription-remove dependency binding))
  (setf (tp-binding-dependencies binding) nil))

(defun tp--detach-binding-subscribers (binding)
  "Detach every direct subscriber from BINDING."
  (dolist (subscriber (tp--sorted-subscribers binding))
    (tp--snapshot-binding subscriber)
    (setf (tp-binding-dependencies subscriber)
          (delq binding (tp-binding-dependencies subscriber))
          (tp-binding-dirty subscriber) t)
    (tp--subscription-remove binding subscriber)))

(defun tp--dispose-binding (binding)
  "Dispose live BINDING without starting a transaction."
  (unless (tp-binding-disposed binding)
    (tp--snapshot-binding binding)
    (tp--detach-binding-dependencies binding)
    (tp--detach-binding-subscribers binding)
    (tp--unregister-binding binding)
    (setf (tp-binding-disposed binding) t
          (tp-binding-dirty binding) nil
          (tp-binding-state binding) 'disposed)))

(defun tp-binding-dispose-owner (owner)
  "Dispose every binding installed on OWNER and return the count."
  (let ((bindings (when-let* ((table (tp--owner-binding-table owner)))
                    (let (items)
                      (maphash (lambda (_key binding) (push binding items)) table)
                      (sort items (lambda (left right)
                                    (< (tp-binding-id left)
                                       (tp-binding-id right))))))))
    (if tp--transaction-active
        (dolist (binding bindings) (tp--dispose-binding binding))
      (tp--call-with-transaction
       (lambda () (dolist (binding bindings) (tp--dispose-binding binding)))))
    (length bindings)))

(defun tp-binding-owner-bindings (owner)
  "Return OWNER's live bindings ordered by stable binding id."
  (when-let* ((table (tp--owner-binding-table owner)))
    (let (bindings)
      (maphash (lambda (_key binding) (push binding bindings)) table)
      (sort bindings (lambda (left right)
                       (< (tp-binding-id left) (tp-binding-id right)))))))

(defun tp-binding-dispose (binding)
  "Dispose BINDING and detach all of its graph edges."
  (tp--validate-live-binding binding)
  (if tp--transaction-active
      (tp--dispose-binding binding)
    (tp--call-with-transaction (lambda () (tp--dispose-binding binding))))
  nil)

(defun tp--transaction-extension (key &optional create)
  "Return transaction extension state for KEY.
When CREATE is non-nil, install and return a fresh hash table when absent."
  (unless tp--transaction-active
    (signal 'tp-reactive-error (list :outside-transaction key)))
  (or (gethash key tp--transaction-extensions)
      (when create
        (let ((state (make-hash-table :test #'eq)))
          (puthash key state tp--transaction-extensions)
          state))))

(defun tp--transaction-counter-delta (key)
  "Return active transaction counter delta for KEY."
  (if tp--transaction-counter-start
      (- (plist-get tp--reactive-counters key)
         (plist-get tp--transaction-counter-start key))
    0))

(defun tp--enqueue-after-commit (function)
  "Run FUNCTION after the active outer transaction has exited."
  (unless tp--transaction-active
    (signal 'tp-reactive-error (list :outside-transaction function)))
  (push function tp--transaction-after-commit-callbacks))

(defun tp--transaction-participant-precommit-function-p (function)
  "Return non-nil when FUNCTION is a declared internal participant validator."
  (or (null function)
      (and (symbolp function)
           (memq function
                 tp--transaction-participant-precommit-allowed-functions)
           (fboundp function))))

(defun tp--transaction-register-participant (participant)
  "Register structured PARTICIPANT in the authoritative v1 participant list."
  (unless tp--transaction-active
    (signal 'tp-reactive-error
            (list :participant-outside-transaction
                  (tp--transaction-participant-key participant))))
  (let ((key (tp--transaction-participant-key participant)))
    (unless key
      (signal 'tp-reactive-error (list :participant-key key)))
  (when (member key tp--transaction-participant-keys)
    (signal 'tp-reactive-error (list :duplicate-participant-key key)))
    (push (tp--copy-property-value key) tp--transaction-participant-keys)
    (push participant tp--transaction-participants)
    participant))

(defun tp--transaction-make-participant
    (key publish rollback protocol precommit after-commit journal)
  "Build a participant from KEY, PUBLISH, ROLLBACK, and PROTOCOL.
PRECOMMIT and AFTER-COMMIT are optional internal callbacks; JOURNAL is opaque
owner-local rollback state."
  (unless (functionp publish)
    (signal 'wrong-type-argument (list 'functionp publish)))
  (unless (functionp rollback)
    (signal 'wrong-type-argument (list 'functionp rollback)))
  (unless (tp--transaction-participant-precommit-function-p precommit)
    (signal 'tp-reactive-error
            (list :invalid-participant-precommit precommit)))
  (unless (or (null after-commit) (functionp after-commit))
    (signal 'wrong-type-argument (list 'functionp after-commit)))
  (tp--make-transaction-participant
   :key (tp--copy-property-value key)
   :publish publish
   :rollback rollback
   :protocol protocol
   :order (prog1 tp--transaction-participant-order
            (cl-incf tp--transaction-participant-order))
   :stage publish
   :precommit precommit
   :after-commit after-commit
   :journal journal
   :state 'prepared))

;;;###autoload
(defun tp-transaction-participate (key publish rollback)
  "Register rollback-capable PUBLISH work under transaction-local KEY.
PUBLISH runs after every affected surface has published its candidate buffer
and side state, but before the transaction commits its source values.  If this
or any later publication step fails, ROLLBACK runs in reverse publication
order.  Both functions take no arguments.  KEY must be unique in the outer
transaction.  The public v1 route is retained and receives an internal v2
structured view over the same participant object."
  (unless tp--transaction-active
    (signal 'tp-reactive-error (list :participant-outside-transaction key)))
  (unless key
    (signal 'tp-reactive-error (list :participant-key key)))
  (let ((participant
         (tp--transaction-make-participant
          key publish rollback 'v1-bridge nil nil nil)))
    (tp--transaction-register-participant participant)
    key))

(cl-defun tp--transaction-participate-v2
    (&key key stage rollback precommit after-commit journal)
  "Register internal KEY with STAGE and ROLLBACK through the v1 coordinator.
PRECOMMIT and AFTER-COMMIT are optional declared callbacks.  JOURNAL is the
participant's opaque owner-local state."
  (unless tp--transaction-active
    (signal 'tp-reactive-error (list :participant-outside-transaction key)))
  (unless key
    (signal 'tp-reactive-error (list :participant-key key)))
  (tp--transaction-register-participant
   (tp--transaction-make-participant
    key stage rollback 'v2 precommit after-commit journal)))

(defun tp--transaction-participants-in-registration-order ()
  "Return the authoritative participants in deterministic declaration order."
  (reverse tp--transaction-participants))

(defun tp--publish-transaction-participants ()
  "Publish registered transaction participants in declaration order."
  (dolist (participant (tp--transaction-participants-in-registration-order))
    (push participant tp--transaction-published-participants)
    ;; Mark first so a stage that mutates and then signals remains rollbackable.
    (setf (tp--transaction-participant-state participant) 'staged)
    (funcall (tp--transaction-participant-publish participant))))

(defun tp--rollback-transaction-participants ()
  "Rollback published participants and return any failures."
  (let (failures)
    (dolist (participant tp--transaction-published-participants)
      (unwind-protect
          (condition-case failure
              (funcall (tp--transaction-participant-rollback participant))
            ((error quit)
             (push (list 'participants
                         (tp--transaction-participant-key participant)
                         failure)
                   failures)))
        (setf (tp--transaction-participant-state participant) 'rolled-back)))
    (dolist (participant tp--transaction-participants)
      (when (eq (tp--transaction-participant-state participant) 'prepared)
        (setf (tp--transaction-participant-state participant) 'rolled-back)))
    (nreverse failures)))

(defun tp--run-transaction-participant-precommits ()
  "Run declared structured participant validators in registration order."
  (dolist (participant (tp--transaction-participants-in-registration-order))
    (when-let* ((function (tp--transaction-participant-precommit participant)))
      (unless (tp--transaction-participant-precommit-function-p function)
        (signal 'tp-reactive-error
                (list :invalid-participant-precommit function)))
      (funcall function))))

(defun tp--commit-transaction-participants ()
  "Commit participant states and queue their contained after-commit work."
  (dolist (participant (tp--transaction-participants-in-registration-order))
    (when (eq (tp--transaction-participant-state participant) 'staged)
      (setf (tp--transaction-participant-state participant) 'committed)
      (when-let* ((function
                   (tp--transaction-participant-after-commit participant)))
        (tp--enqueue-after-commit function)))))

(defun tp--dequeue-dirty-binding ()
  "Return and remove the next queued dirty binding."
  (let (binding)
    (while (and tp--transaction-dirty-queue (null binding))
      (let ((candidate (pop tp--transaction-dirty-queue)))
        (when (gethash candidate tp--transaction-dirty-set)
          (remhash candidate tp--transaction-dirty-set)
          (setq binding candidate))))
    binding))

(defun tp--flush-dirty-bindings ()
  "Recompute the transaction's exact dirty closure."
  (let (binding)
    (while (setq binding (tp--dequeue-dirty-binding))
      (when (and (tp-binding-live-p binding) (tp-binding-dirty binding))
        (tp--binding-recompute binding)))))

(defun tp--restore-binding (binding snapshot)
  "Restore BINDING fields from SNAPSHOT."
  (setf (tp-binding-compute binding) (tp--binding-snapshot-compute snapshot)
        (tp-binding-equality binding) (tp--binding-snapshot-equality snapshot)
        (tp-binding-last-value binding) (tp--binding-snapshot-last-value snapshot)
        (tp-binding-initialized-p binding)
        (tp--binding-snapshot-initialized-p snapshot)
        (tp-binding-dependencies binding)
        (copy-sequence (tp--binding-snapshot-dependencies snapshot))
        (tp-binding-dirty binding) (tp--binding-snapshot-dirty snapshot)
        (tp-binding-state binding) (tp--binding-snapshot-state snapshot)
        (tp-binding-revision binding) (tp--binding-snapshot-revision snapshot)
        (tp-binding-lifecycle binding) (tp--binding-snapshot-lifecycle snapshot)
        (tp-binding-disposed binding) (tp--binding-snapshot-disposed snapshot)))

(defun tp--rollback-bindings ()
  "Restore all bindings touched by the active transaction."
  (let (snapshots)
    (maphash (lambda (binding snapshot)
               (push (cons binding snapshot) snapshots))
             tp--transaction-binding-snapshots)
    (dolist (binding (append tp--transaction-created-bindings
                             (mapcar #'car snapshots)))
      (tp--detach-binding-dependencies binding))
    (dolist (binding tp--transaction-created-bindings)
      (tp--unregister-binding binding)
      (setf (tp-binding-disposed binding) t
            (tp-binding-state binding) 'disposed))
    (dolist (entry snapshots)
      (pcase-let ((`(,binding . ,snapshot) entry))
        (tp--restore-binding binding snapshot)
        (unless (tp-binding-disposed binding)
          (tp--register-binding binding)
          (dolist (dependency (tp-binding-dependencies binding))
            (tp--subscription-add dependency binding)))))))

(defun tp--transaction-noop-final-accept ()
  "Accept a pure reactive transaction with no external publication work."
  nil)

(defun tp--transaction-precommit-function-p (function)
  "Return non-nil when FUNCTION is a declared TP-internal hook symbol."
  (and (symbolp function)
       (memq function tp--transaction-precommit-allowed-functions)
       (fboundp function)))

(defun tp--transaction-register-precommit-function (function)
  "Register declared TP-internal precommit FUNCTION once."
  (unless (tp--transaction-precommit-function-p function)
    (signal 'tp-reactive-error
            (list :invalid-precommit-function function)))
  (unless (memq function tp--transaction-precommit-functions)
    (setq tp--transaction-precommit-functions
          (append tp--transaction-precommit-functions (list function))))
  function)

(defun tp--transaction-install-final-accept (function)
  "Install the active transaction's single final-accept FUNCTION."
  (unless tp--transaction-active
    (signal 'tp-reactive-error (list :final-accept-outside-transaction)))
  (unless (functionp function)
    (signal 'wrong-type-argument (list 'functionp function)))
  (unless (eq tp--transaction-final-accept-function
              #'tp--transaction-noop-final-accept)
    (signal 'tp-reactive-error
            (list :duplicate-final-accept-function
                  tp--transaction-final-accept-function function)))
  (setq tp--transaction-final-accept-function function))

(defun tp--transaction-v2-artifacts-enabled-p ()
  "Return non-nil when the additive v2 shadow artifacts are enabled."
  (pcase tp--transaction-artifact-mode
    ('v1 nil)
    ((or 'shadow 'v1+v2-shadow) t)
    (_ (signal 'tp-transaction-contract-error
               (list :artifact-mode tp--transaction-artifact-mode)))))

(defun tp--transaction-current-outcome-cell ()
  "Return the active transaction's caller-retainable one-slot outcome cell."
  (unless tp--transaction-active
    (signal 'tp-reactive-error (list :outcome-cell-outside-transaction)))
  tp--transaction-outcome-cell)

(defun tp--transaction-enter-phase (phase)
  "Record the completed phase duration and enter PHASE."
  (let ((now (float-time)))
    (when (and tp--transaction-phase tp--transaction-phase-start)
      (push (cons tp--transaction-phase
                  (- now tp--transaction-phase-start))
            tp--transaction-phase-timings))
    (setq tp--transaction-phase phase
          tp--transaction-phase-start now)))

(defun tp--transaction-publish-outcome (outcome)
  "Publish internal OUTCOME without changing the public transaction return."
  (setq tp--transaction-outcome outcome
        tp--last-transaction-outcome outcome)
  (when (vectorp tp--transaction-outcome-cell)
    (aset tp--transaction-outcome-cell 0 outcome))
  (when tp--transaction-publication-batch
    (setf (tp-publication-batch-candidate-outcome
           tp--transaction-publication-batch)
          outcome))
  outcome)

(defun tp--transaction-batch-journal-view (surface-journals)
  "Return a fixed view vector over current journals and SURFACE-JOURNALS."
  (vector tp--transaction-extensions
          tp--transaction-signal-values
          tp--transaction-binding-snapshots
          tp--transaction-counter-start
          tp--transaction-signal-commit-journal
          surface-journals))

(defun tp--transaction-begin-publication-batch
    (batch-id entries surface-journals)
  "Install BATCH-ID as the candidate for ENTRIES and SURFACE-JOURNALS."
  (unless tp--transaction-active
    (signal 'tp-reactive-error (list :batch-outside-transaction batch-id)))
  (when tp--transaction-publication-batch
    (signal 'tp-publication-state-error
            (list :duplicate-transaction-batch batch-id)))
  (when (tp--transaction-v2-artifacts-enabled-p)
    (setq tp--transaction-publication-batch
          (tp--publication-batch-prepare
           :transaction-id tp--transaction-id
           :batch-id batch-id
           :entries entries
           :participants
           (vconcat (tp--transaction-participants-in-registration-order))
           :journals (tp--transaction-batch-journal-view surface-journals)
           :final-accept tp--transaction-final-accept-function
           :diagnostics nil)))
  tp--transaction-publication-batch)

(defun tp--transaction-batch-transition (next)
  "Move the active publication candidate to NEXT when one exists."
  (when tp--transaction-publication-batch
    (tp--publication-batch-transition
     tp--transaction-publication-batch next)))

(cl-defun tp--transaction-register-final-marker
    (&key owner-key expected-token expected-version next-values inverse-values
          slot-write-count operation-key)
  "Register a bounded opaque marker for OWNER-KEY before precommit.
EXPECTED-TOKEN and EXPECTED-VERSION bind owner state.  NEXT-VALUES and
INVERSE-VALUES are prebuilt opaque payloads.  SLOT-WRITE-COUNT is checked
against the trusted OPERATION-KEY descriptor and the transaction bound."
  (unless (and tp--transaction-active
               (memq tp--transaction-phase
                     '(body recompute publication participants))
               (not tp--transaction-final-markers-frozen-p))
    (signal 'tp-final-marker-error
            (list :registration-phase tp--transaction-phase)))
  (when (>= tp--transaction-final-marker-count tp--final-marker-max-count)
    (signal 'tp-final-marker-error
            (list :marker-count tp--transaction-final-marker-count)))
  (let ((duplicate nil))
    (dotimes (index tp--transaction-final-marker-count)
      (when (equal owner-key
                   (aref tp--transaction-final-marker-owner-keys index))
        (setq duplicate t)))
    (when duplicate
      (signal 'tp-final-marker-error (list :duplicate-owner-key owner-key))))
  (let ((marker
         (tp--final-accept-marker-create
          :owner-key owner-key
          :expected-token expected-token
          :expected-version expected-version
          :next-values next-values
          :inverse-values inverse-values
          :slot-write-count slot-write-count
          :operation-key operation-key)))
    (when (> (+ tp--transaction-final-marker-slot-writes slot-write-count)
             tp--final-marker-max-slot-writes)
      (signal 'tp-final-marker-error
              (list :slot-write-bound
                    tp--transaction-final-marker-slot-writes
                    slot-write-count)))
    (aset tp--transaction-final-marker-registry
          tp--transaction-final-marker-count marker)
    (aset tp--transaction-final-marker-owner-keys
          tp--transaction-final-marker-count
          (tp--copy-property-value owner-key))
    (cl-incf tp--transaction-final-marker-count)
    (cl-incf tp--transaction-final-marker-slot-writes slot-write-count)
    marker))

(cl-defun tp-transaction-register-final-marker
    (&key owner-key expected-token expected-version next-values inverse-values
          slot-write-count operation-key)
  "Register one bounded final-accept authority marker.
OWNER-KEY must be unique in the active transaction.  EXPECTED-TOKEN and
EXPECTED-VERSION bind owner state; NEXT-VALUES and INVERSE-VALUES are prebuilt
slot-write vectors with fixed SLOT-WRITE-COUNT.  OPERATION-KEY must resolve
through TP's closed marker-operation whitelist."
  (tp--transaction-register-final-marker
   :owner-key owner-key
   :expected-token expected-token
   :expected-version expected-version
   :next-values next-values
   :inverse-values inverse-values
   :slot-write-count slot-write-count
   :operation-key operation-key))

(defun tp--transaction-freeze-final-markers ()
  "Validate and seal every marker before signal commit and final accept."
  (when (and (> tp--transaction-final-marker-count 0)
             (null tp--transaction-publication-batch))
    (signal 'tp-final-marker-error (list :marker-without-publication-batch)))
  (dotimes (index tp--transaction-final-marker-count)
    (tp--final-accept-marker-validate
     (aref tp--transaction-final-marker-registry index)))
  (setq tp--transaction-final-markers-frozen-p t)
  (when tp--transaction-publication-batch
    (setf (tp-publication-batch-candidate-markers
           tp--transaction-publication-batch)
          (cons tp--transaction-final-marker-registry
                tp--transaction-final-marker-count)))
  tp--transaction-final-marker-count)

(defun tp--transaction-sync-publication-batch ()
  "Refresh fixed batch view slots after precommit and signal journaling."
  (when tp--transaction-publication-batch
    (setf (tp-publication-batch-candidate-final-accept
           tp--transaction-publication-batch)
          tp--transaction-final-accept-function)
    (let ((journals
           (tp-publication-batch-candidate-journals
            tp--transaction-publication-batch)))
      (when (vectorp journals)
        (aset journals 4 tp--transaction-signal-commit-journal)))))

(defun tp--transaction-prepare-success-outcome ()
  "Preallocate the active batch's success evidence before final accept."
  (when tp--transaction-publication-batch
    (let ((candidate tp--transaction-publication-batch)
          (text-operations 0)
          (property-operations 0)
          (touched-characters 0)
          target-counts)
      (dolist (entry (tp-publication-batch-candidate-entries candidate))
        (let ((counts (tp-publication-target-entry-operation-counts entry)))
          (unless counts
            (signal 'tp-publication-binding-error
                    (list :missing-operation-counts
                          (tp-publication-target-entry-surface-id entry))))
          (cl-incf text-operations (or (plist-get counts :text-operations) 0))
          (cl-incf property-operations
                   (or (plist-get counts :property-operations) 0))
          (cl-incf touched-characters
                   (or (plist-get counts :touched-characters) 0))
          (push (tp--copy-property-value counts) target-counts)))
      (setf
       (tp-publication-batch-candidate-operation-counts candidate)
       (list :targets
             (length (tp-publication-batch-candidate-entries candidate))
             :participants (length tp--transaction-participants)
             :signals (length tp--transaction-signals)
             :markers tp--transaction-final-marker-count
             :text-operations text-operations
             :property-operations property-operations
             :touched-characters touched-characters
             :target-counts (nreverse target-counts))
       (tp-publication-batch-candidate-phase-timings candidate)
       (nreverse (copy-sequence tp--transaction-phase-timings))
       (tp-publication-batch-candidate-diagnostics candidate)
       (tp--copy-property-value tp--transaction-contained-failures))
      (setf (tp-publication-batch-candidate-success-outcome-draft candidate)
            (tp--committed-success-outcome-draft
             candidate
             (tp-publication-batch-candidate-operation-counts candidate)
             (tp-publication-batch-candidate-phase-timings candidate)
             (tp-publication-batch-candidate-diagnostics candidate)
             tp--transaction-final-marker-count)))))

(defun tp--transaction-apply-one-final-marker (marker)
  "Apply one prevalidated MARKER through its closed package primitive."
  (funcall
   (tp--final-marker-operation-apply
    (tp-final-accept-marker-operation marker))
   marker))

(defun tp--transaction-restore-one-final-marker (marker)
  "Restore one prevalidated MARKER through its closed package primitive."
  (funcall
   (tp--final-marker-operation-restore
    (tp-final-accept-marker-operation marker))
   marker))

(defun tp--transaction-restore-final-marker-at (index failures-cell)
  "Restore marker INDEX, then exhaustively continue using FAILURES-CELL."
  (when (>= index 0)
    (let ((marker (aref tp--transaction-final-marker-registry index)))
      (unwind-protect
          (when (memq (tp-final-accept-marker-state marker)
                      '(applying applied))
            (setf (tp-final-accept-marker-state marker) 'restoring)
            (condition-case failure
                (progn
                  (tp--transaction-restore-one-final-marker marker)
                  (setf (tp-final-accept-marker-state marker) 'restored))
              ((error quit)
               (setf (tp-final-accept-marker-state marker) 'restore-failed)
               (aset
                failures-cell 0
                (cons (list 'final-markers
                            (tp-final-accept-marker-owner-key marker)
                            failure)
                      (aref failures-cell 0))))))
        ;; This cleanup runs even when a test or corrupted primitive exits by
        ;; an arbitrary nonlocal throw, so no earlier applied marker is skipped.
        (tp--transaction-restore-final-marker-at
         (1- index) failures-cell)))))

(defun tp--transaction-restore-applied-final-markers ()
  "Reverse every applied marker and return contained restore failures."
  (let ((index (1- tp--transaction-applied-final-marker-count))
        (failures-cell (vector nil)))
    (setq tp--transaction-applied-final-marker-count 0)
    (tp--transaction-restore-final-marker-at index failures-cell)
    (nreverse (aref failures-cell 0))))

(defun tp--transaction-apply-final-markers ()
  "Apply every sealed marker in registration order."
  (dotimes (index tp--transaction-final-marker-count)
    (let ((marker (aref tp--transaction-final-marker-registry index)))
      ;; Count and mark first so mutate-then-signal is still reverse-restored.
      (setq tp--transaction-applied-final-marker-count (1+ index))
      (setf (tp-final-accept-marker-state marker) 'applying)
      (tp--transaction-apply-one-final-marker marker)
      (setf (tp-final-accept-marker-state marker) 'applied))))

(defun tp--transaction-commit-final-markers ()
  "Finalize marker state through fixed writes after successful accept."
  (dotimes (index tp--transaction-final-marker-count)
    (setf (tp-final-accept-marker-state
           (aref tp--transaction-final-marker-registry index))
          'committed))
  (setq tp--transaction-applied-final-marker-count 0))

(defun tp--transaction-run-final-accept ()
  "Apply markers, invoke the existing single final accept, and finalize tags."
  (tp--transaction-batch-transition 'final-accepting)
  (let (accepted)
    (unwind-protect
        (progn
          (tp--transaction-apply-final-markers)
          (funcall tp--transaction-final-accept-function)
          (setq accepted t))
      (unless accepted
        (setq tp--transaction-marker-restore-failures
              (tp--transaction-restore-applied-final-markers))))
    (when accepted
      (tp--transaction-commit-final-markers)
      (when tp--transaction-publication-batch
        (let* ((candidate tp--transaction-publication-batch)
               (outcome
                (tp-publication-batch-candidate-success-outcome-draft
                 candidate)))
          ;; Every fallible validation and allocation happened before accept.
          (setf (tp-publication-batch-candidate-state candidate) 'committed
                (tp-publication-batch-candidate-resolution candidate) 'committed)
          ;; The success tag is a read-only slot with one coordinator-owned
          ;; fixed write after the existing final accept has returned.
          (aset outcome tp--committed-success-outcome-tag-slot
                'committed-success)
          (tp--transaction-publish-outcome outcome))))))

(defun tp--transaction-run-shadow-proof (phase)
  "Compare v2 artifacts with the single v1 live result for PHASE."
  (when (and tp--transaction-publication-batch
             (tp--transaction-v2-artifacts-enabled-p))
    (let ((ok t) results outcome-equivalent)
      (dolist (entry
               (tp-publication-batch-candidate-entries
                tp--transaction-publication-batch))
        (let ((validator (tp-publication-target-entry-shadow-validator entry)))
          (condition-case failure
              (let ((result (and validator (funcall validator entry phase))))
                (setf (tp-publication-target-entry-shadow-actual entry) result
                      (tp-publication-target-entry-shadow-proven-p entry)
                      (and result (plist-get result :equivalent)))
                (unless (tp-publication-target-entry-shadow-proven-p entry)
                  (setq ok nil))
                (when (eq phase 'rollback)
                  (setf (tp-publication-target-entry-rollback-result entry)
                        (if (plist-get result :equivalent) 'restored 'mismatch)
                        (tp-publication-target-entry-post-rollback-state entry)
                        (plist-get result :actual)))
                (push result results))
            ((error quit)
             (setq ok nil)
             (push (list :equivalent nil :failure failure) results)))))
      (setq outcome-equivalent
            (pcase phase
              ('commit
               (tp--committed-success-outcome-valid-for-p
                tp--transaction-outcome tp--transaction-publication-batch))
              ('rollback
               (and tp--transaction-outcome
                    (tp--publication-failure-outcome-valid-for-p
                     tp--transaction-outcome
                     tp--transaction-publication-batch)))))
      (when (and (eq phase 'commit) (not outcome-equivalent))
        (setq ok nil))
      (let ((proof (list :phase phase :equivalent ok
                         :outcome-equivalent outcome-equivalent
                         :entries (nreverse results))))
        (setf (tp-publication-batch-candidate-shadow-proof
               tp--transaction-publication-batch)
              proof)
        (setq tp--last-shadow-proof
              (list :phase phase :equivalent ok
                    :outcome-equivalent outcome-equivalent
                    :entry-count
                    (length
                     (tp-publication-batch-candidate-entries
                      tp--transaction-publication-batch))))
        (unless ok
          (push (list 'shadow-proof phase proof)
                tp--transaction-contained-failures))
        proof))))

(defun tp--transaction-finalize-rollback-shadow-outcome ()
  "Correlate the failure outcome with the already compared rollback artifacts."
  (when-let* ((candidate tp--transaction-publication-batch)
              (proof (tp-publication-batch-candidate-shadow-proof candidate)))
    (let* ((outcome-equivalent
            (tp--publication-failure-outcome-valid-for-p
             tp--transaction-outcome candidate))
           (equivalent
            (and (plist-get proof :equivalent) outcome-equivalent)))
      (setq proof (plist-put proof :outcome-equivalent outcome-equivalent)
            proof (plist-put proof :equivalent equivalent))
      (setf (tp-publication-batch-candidate-shadow-proof candidate) proof)
      (setq tp--last-shadow-proof
            (list :phase 'rollback :equivalent equivalent
                  :outcome-equivalent outcome-equivalent
                  :entry-count
                  (length (tp-publication-batch-candidate-entries candidate))))
      (unless equivalent
        (push (list 'shadow-proof 'rollback-outcome proof)
              tp--transaction-contained-failures))
      proof)))

(defun tp--transaction-finish-rollback (primary-condition rollback-failures)
  "Finalize failure evidence for PRIMARY-CONDITION and ROLLBACK-FAILURES."
  (dotimes (index tp--transaction-final-marker-count)
    (let ((marker (aref tp--transaction-final-marker-registry index)))
      (when (eq (tp-final-accept-marker-state marker) 'prepared)
        (setf (tp-final-accept-marker-state marker) 'rolled-back))))
  (when tp--transaction-publication-batch
    (let ((candidate tp--transaction-publication-batch))
      (unless (tp--publication-batch-terminal-p candidate)
        (if (eq (tp-publication-batch-candidate-state candidate) 'prepared)
            (progn
              (setf (tp-publication-batch-candidate-state candidate) 'discarded
                    (tp-publication-batch-candidate-resolution candidate)
                    'discarded))
          (tp--publication-batch-transition candidate 'rolled-back)))
      (tp--transaction-run-shadow-proof 'rollback)
      (when (and primary-condition
                 (eq (tp-publication-batch-candidate-state candidate)
                     'rolled-back))
        (tp--transaction-publish-outcome
         (tp--publication-failure-outcome-create
          candidate tp--transaction-phase primary-condition rollback-failures
          tp--transaction-contained-failures))
        (tp--transaction-finalize-rollback-shadow-outcome)))))

(defun tp--run-contained-transaction-functions (phase functions)
  "Run postaccept PHASE FUNCTIONS and record contained failures."
  (dolist (function (tp--transaction-hook-functions functions))
    (let ((inhibit-quit t)
          (quit-flag nil))
      (condition-case failure
          (funcall function)
        ((error quit)
         (push (list phase function failure)
               tp--transaction-contained-failures))))))

(defun tp--run-transaction-precommit-functions ()
  "Run the internal declared precommit registry in deterministic order."
  (dolist (function tp--transaction-precommit-functions)
    (unless (tp--transaction-precommit-function-p function)
      (signal 'tp-reactive-error
              (list :invalid-precommit-function function)))
    (funcall function)))

(defun tp--prepare-signal-commit-journal ()
  "Capture every touched signal before any committed field is mutated."
  (setq tp--transaction-signal-commit-journal
        (mapcar
         (lambda (signal)
           (tp--make-signal-commit-entry
            :signal signal
            :old-committed-value (tp-signal-committed-value signal)
            :old-revision (tp-signal-revision signal)
            :candidate-value
            (gethash signal tp--transaction-signal-values)))
         (nreverse (copy-sequence tp--transaction-signals)))))

(defun tp--commit-signal-entry (entry)
  "Commit signal journal ENTRY exactly once."
  (let ((signal (tp--signal-commit-entry-signal entry)))
    (setf (tp-signal-committed-value signal)
          (tp--signal-commit-entry-candidate-value entry)
          (tp-signal-revision signal)
          (1+ (tp--signal-commit-entry-old-revision entry)))))

(defun tp--restore-signal-entry (entry)
  "Restore signal journal ENTRY's exact committed state."
  (let ((signal (tp--signal-commit-entry-signal entry)))
    (setf (tp-signal-committed-value signal)
          (tp--signal-commit-entry-old-committed-value entry)
          (tp-signal-revision signal)
          (tp--signal-commit-entry-old-revision entry))))

(defun tp--commit-signal-values ()
  "Journal and commit candidate signals in stable first-touch order."
  (tp--prepare-signal-commit-journal)
  (dolist (entry tp--transaction-signal-commit-journal)
    (tp--commit-signal-entry entry)))

(defun tp--restore-transaction-counters (snapshot)
  "Restore reactive counters from SNAPSHOT."
  (setq tp--reactive-counters snapshot))

(defun tp--transaction-hook-functions (value)
  "Return hook VALUE as one ordered function list."
  (cond
   ((null value) nil)
   ((functionp value) (list value))
   (t value)))

(defun tp--rollback-hook-phase (phase functions)
  "Run rollback PHASE FUNCTIONS and return ordered failures."
  (let (failures)
    (dolist (function (tp--transaction-hook-functions functions))
      (condition-case failure
          (funcall function)
        ((error quit)
         (push (list phase function failure) failures))))
    (nreverse failures)))

(defun tp--rollback-signal-journal ()
  "Restore every signal journal entry and return ordered failures."
  (let (failures)
    (dolist (entry tp--transaction-signal-commit-journal)
      (condition-case failure
          (tp--restore-signal-entry entry)
        ((error quit)
         (push (list 'signal-journal
                     (tp-signal-id
                      (tp--signal-commit-entry-signal entry))
                     failure)
               failures))))
    (nreverse failures)))

(defun tp--rollback-transaction-state (counter-snapshot)
  "Restore COUNTER-SNAPSHOT through every rollback phase.
Return contained failures in phase order."
  (let ((failures (copy-sequence tp--transaction-marker-restore-failures)))
    (setq failures
          (append
           failures
           (tp--rollback-transaction-participants)
           (tp--rollback-hook-phase
            'rollback-hooks tp--transaction-rollback-functions)
           (tp--rollback-signal-journal)))
    (condition-case failure
        (tp--rollback-bindings)
      ((error quit)
       (setq failures
             (append failures
                     (list (list 'bindings 'binding-graph failure))))))
    (condition-case failure
        (tp--restore-transaction-counters counter-snapshot)
      ((error quit)
       (setq failures
             (append failures
                     (list (list 'counters 'reactive-counters failure))))))
    (append
     failures
     (tp--rollback-hook-phase
      'rollback-final tp--transaction-rollback-final-functions))))

(defun tp--resignal-transaction-primary (primary-condition failures)
  "Re-signal PRIMARY-CONDITION with ordered rollback FAILURES attached."
  (signal (car primary-condition)
          (if failures
              (append (cdr primary-condition)
                      (list tp--transaction-condition-trailer-tag
                            (list :rollback-failures failures)))
            (cdr primary-condition))))

(defun tp--transaction-condition-trailer (condition property)
  "Return PROPERTY from the exact transaction trailer of CONDITION.
Transaction rollback metadata is appended after, and never merged into,
the primary condition data."
  (let ((trailer (last condition 2)))
    (and (eq (car trailer) tp--transaction-condition-trailer-tag)
         (plist-get (cadr trailer) property))))

(defun tp--call-with-transaction (function)
  "Call FUNCTION in one atomic signal and binding transaction."
  (if tp--transaction-active
      (funcall function)
    (let (after-commit result
          (tp--transaction-contained-failures nil))
      (setq tp--last-transaction-outcome nil
            tp--last-shadow-proof nil)
      (setq result
            (let ((tp--transaction-active t)
                  (tp--transaction-id (tp--next-transaction-id))
                  (tp--transaction-phase 'body)
                  (tp--transaction-phase-start (float-time))
                  (tp--transaction-phase-timings nil)
                  (tp--transaction-signal-values
                   (make-hash-table :test #'eq))
                  (tp--transaction-signals nil)
                  (tp--transaction-dirty-set (make-hash-table :test #'eq))
                  (tp--transaction-dirty-queue nil)
                  (tp--transaction-binding-snapshots
                   (make-hash-table :test #'eq))
                  (tp--transaction-created-bindings nil)
                  (tp--transaction-recompute-counts
                   (make-hash-table :test #'eq))
                  (tp--transaction-extensions (make-hash-table :test #'eq))
                  (tp--transaction-after-commit-callbacks nil)
                  (tp--transaction-participants nil)
                  (tp--transaction-participant-keys nil)
                  (tp--transaction-participant-order 0)
                  (tp--transaction-published-participants nil)
                  (tp--transaction-signal-commit-journal nil)
                  (tp--transaction-publication-batch nil)
                  (tp--transaction-final-marker-registry
                   (make-vector tp--final-marker-max-count nil))
                  (tp--transaction-final-marker-owner-keys
                   (make-vector tp--final-marker-max-count nil))
                  (tp--transaction-final-marker-count 0)
                  (tp--transaction-final-marker-slot-writes 0)
                  (tp--transaction-final-markers-frozen-p nil)
                  (tp--transaction-applied-final-marker-count 0)
                  (tp--transaction-marker-restore-failures nil)
                  (tp--transaction-outcome nil)
                  (tp--transaction-outcome-cell (vector nil))
                  (tp--transaction-final-accept-function
                   #'tp--transaction-noop-final-accept)
                  (counter-snapshot (copy-sequence tp--reactive-counters))
                  (tp--transaction-counter-start nil)
                  success transaction-result primary-condition
                  rollback-failures pending-quit)
              (setq tp--transaction-counter-start counter-snapshot)
              (unwind-protect
                  (condition-case condition
                      (progn
                        (setq transaction-result (funcall function))
                        (tp--transaction-enter-phase 'recompute)
                        (tp--flush-dirty-bindings)
                        (tp--transaction-enter-phase 'publication)
                        (run-hooks 'tp--transaction-publish-functions)
                        (tp--transaction-batch-transition 'participants)
                        (tp--transaction-enter-phase 'participants)
                        (tp--publish-transaction-participants)
                        (tp--transaction-batch-transition 'precommit)
                        (tp--transaction-enter-phase 'precommit)
                        (tp--run-transaction-participant-precommits)
                        (tp--run-transaction-precommit-functions)
                        (tp--transaction-freeze-final-markers)
                        (tp--transaction-sync-publication-batch)
                        (tp--transaction-enter-phase 'signal-commit)
                        (tp--commit-signal-values)
                        (tp--transaction-sync-publication-batch)
                        (tp--transaction-enter-phase 'final-accept)
                        (tp--transaction-prepare-success-outcome)
                        (condition-case deferred-quit
                            (progn
                              (let ((inhibit-quit t)
                                    (quit-flag nil))
                                (unwind-protect
                                    (progn
                                      (unless
                                          (functionp
                                           tp--transaction-final-accept-function)
                                        (signal
                                         'tp-reactive-error
                                         (list
                                          :invalid-final-accept-function
                                          tp--transaction-final-accept-function)))
                                      (tp--transaction-run-final-accept)
                                      (setq success t)
                                      (tp--commit-transaction-participants)
                                      (tp--transaction-run-shadow-proof 'commit)
                                      (when quit-flag
                                        (setq pending-quit t
                                              quit-flag nil))
                                      (tp--run-contained-transaction-functions
                                       'committed
                                       tp--transaction-committed-functions)
                                      (setq after-commit
                                            (nreverse
                                             tp--transaction-after-commit-callbacks))
                                      (when pending-quit
                                        (push
                                         (list 'final-accept
                                               tp--transaction-final-accept-function
                                               '(quit))
                                         tp--transaction-contained-failures)))
                                  (setq quit-flag nil)))
                              nil)
                          (quit
                           (if success
                               (push
                                (list 'final-accept
                                      tp--transaction-final-accept-function
                                      deferred-quit)
                                tp--transaction-contained-failures)
                             (signal (car deferred-quit)
                                     (cdr deferred-quit))))))
                    ((error quit)
                     (setq primary-condition condition)))
                (unless success
                  (let ((inhibit-quit t)
                        (quit-flag nil))
                    (unwind-protect
                        (progn
                          (setq tp--transaction-phase
                                (or tp--transaction-phase 'rollback)
                                rollback-failures
                                (tp--rollback-transaction-state
                                 counter-snapshot))
                          (tp--transaction-finish-rollback
                           primary-condition rollback-failures))
                      (setq quit-flag nil)))))
              (when primary-condition
                (tp--resignal-transaction-primary
                 primary-condition rollback-failures))
              transaction-result))
      (tp--run-contained-transaction-functions 'after-commit after-commit)
      (setq tp--last-transaction-diagnostics
            (nreverse tp--transaction-contained-failures))
      result)))

;;;###autoload
(defmacro tp-with-transaction (&rest body)
  "Evaluate BODY in one atomic signal and binding transaction."
  (declare (indent 0) (debug t))
  `(tp--call-with-transaction (lambda () ,@body)))

(defun tp--variable-signal-key (symbol scope)
  "Return the adapter key for SYMBOL and SCOPE."
  (cons symbol scope))

(defun tp--variable-signal-watcher (symbol new-value operation where)
  "Forward SYMBOL's NEW-VALUE write into its exact signal adapter.
OPERATION and WHERE follow the standard variable watcher protocol."
  (when (eq operation 'set)
    (when-let* ((signal (gethash (tp--variable-signal-key
                                 symbol (or where 'global))
                                tp--variable-signals)))
      (when (tp-signal-live-p signal)
        (tp-signal-set signal new-value)))))

(defun tp--variable-signal-initial-value (symbol scope)
  "Return SYMBOL's initial adapter value in SCOPE."
  (if (eq scope 'global)
      (if (default-boundp symbol) (default-value symbol) nil)
    (with-current-buffer scope
      (if (boundp symbol) (symbol-value symbol) nil))))

(defun tp-variable-signal (symbol &optional buffer)
  "Return the signal adapting SYMBOL globally or in BUFFER."
  (unless (symbolp symbol)
    (signal 'wrong-type-argument (list 'symbolp symbol)))
  (when (and buffer (not (buffer-live-p buffer)))
    (signal 'tp-invalid-signal-scope (list buffer)))
  (let* ((scope (or buffer 'global))
         (key (tp--variable-signal-key symbol scope)))
    (or (gethash key tp--variable-signals)
        (let ((signal (tp-signal-create
                       (tp--variable-signal-initial-value symbol scope)
                       :scope scope)))
          (setf (tp-signal-adapter-key signal) key)
          (puthash key signal tp--variable-signals)
          (unless (memq symbol tp--variable-signal-watched)
            (add-variable-watcher symbol #'tp--variable-signal-watcher)
            (push symbol tp--variable-signal-watched))
          signal))))

(defun tp--symbol-has-variable-signal-p (symbol)
  "Return non-nil when SYMBOL still owns an adapter signal."
  (let ((found nil))
    (maphash (lambda (key _signal)
               (when (eq (car key) symbol) (setq found t)))
             tp--variable-signals)
    found))

(defun tp--dispose-signal (signal)
  "Dispose SIGNAL and detach its graph and adapter state."
  (unless (tp-signal-disposed signal)
    (dolist (binding (tp--sorted-subscribers signal))
      (setf (tp-binding-dependencies binding)
            (delq signal (tp-binding-dependencies binding))
            (tp-binding-dirty binding) t))
    (clrhash (tp-signal-subscribers signal))
    (when-let* ((key (tp-signal-adapter-key signal)))
      (remhash key tp--variable-signals)
      (let ((symbol (car key)))
        (unless (tp--symbol-has-variable-signal-p symbol)
          (remove-variable-watcher symbol #'tp--variable-signal-watcher)
          (setq tp--variable-signal-watched
                (delq symbol tp--variable-signal-watched)))))
    (when-let* ((scope (and (bufferp (tp-signal-scope signal))
                           (tp-signal-scope signal))))
      (when (buffer-live-p scope)
        (with-current-buffer scope
          (setq tp--buffer-signals (delq signal tp--buffer-signals)))))
    (setf (tp-signal-disposed signal) t)
    (setq tp--signals (delq signal tp--signals))))

(defun tp-signal-dispose (signal)
  "Dispose SIGNAL, detach its subscriptions, and return nil."
  (unless (tp-signal-p signal)
    (signal 'wrong-type-argument (list 'tp-signal-p signal)))
  (when tp--transaction-active
    (signal 'tp-reactive-error (list :dispose-during-transaction)))
  (tp--dispose-signal signal)
  nil)

(defun tp--reactive-graph-reset ()
  "Clear all signal, binding, adapter, and scheduler state."
  (when tp--transaction-active
    (signal 'tp-reactive-error (list :reset-during-transaction)))
  (dolist (binding tp--bindings)
    (tp--detach-binding-dependencies binding)
    (clrhash (tp-binding-subscribers binding))
    (setf (tp-binding-disposed binding) t
          (tp-binding-state binding) 'disposed))
  (dolist (signal (copy-sequence tp--signals))
    (tp--dispose-signal signal))
  (clrhash tp--owner-bindings)
  (clrhash tp--variable-signals)
  (setq tp--bindings nil
        tp--signals nil
        tp--variable-signal-watched nil)
  (tp-reactive-reset-counters))

;;;###autoload
(defun tp-reactive-reset ()
  "Reset TP's signal, binding, adapter, and scheduler graph."
  (interactive)
  (tp--reactive-graph-reset))

(provide 'tp-reactive)
;;; tp-reactive.el ends here