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)

(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 rollback-capable side-state participant in a TP transaction."
  key publish rollback)

(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)
(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-published-participants 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-rollback-functions nil)
(defvar tp--transaction-rollback-final-functions nil)
(defvar tp--transaction-committed-functions nil)

(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--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))

;;;###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."
  (unless tp--transaction-active
    (signal 'tp-reactive-error (list :participant-outside-transaction key)))
  (unless key
    (signal 'tp-reactive-error (list :participant-key key)))
  (unless (functionp publish)
    (signal 'wrong-type-argument (list 'functionp publish)))
  (unless (functionp rollback)
    (signal 'wrong-type-argument (list 'functionp rollback)))
  (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 (tp--make-transaction-participant
         :key (tp--copy-property-value key)
         :publish publish :rollback rollback)
        tp--transaction-participants)
  key)

(defun tp--publish-transaction-participants ()
  "Publish registered transaction participants in declaration order."
  (dolist (participant (nreverse tp--transaction-participants))
    (push participant tp--transaction-published-participants)
    (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)
      (condition-case failure
          (funcall (tp--transaction-participant-rollback participant))
        (error
         (push (list :key (tp--transaction-participant-key participant)
                     :error failure)
               failures))))
    (nreverse failures)))

(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--commit-signal-values ()
  "Commit candidate signal values after a successful flush."
  (dolist (signal (nreverse tp--transaction-signals))
    (setf (tp-signal-committed-value signal)
          (gethash signal tp--transaction-signal-values)
          (tp-signal-revision signal) (1+ (tp-signal-revision signal)))))

(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)
      (setq result
            (let ((tp--transaction-active t)
                  (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-published-participants nil)
                  (counter-snapshot (copy-sequence tp--reactive-counters))
                  (tp--transaction-counter-start nil)
                  success transaction-result rollback-failures)
              (setq tp--transaction-counter-start counter-snapshot)
              (unwind-protect
                  (progn
                    (setq transaction-result (funcall function))
                    (tp--flush-dirty-bindings)
                    (run-hooks 'tp--transaction-publish-functions)
                    (tp--publish-transaction-participants)
                    (tp--commit-signal-values)
                    (setq success t)
                    transaction-result)
                (unless success
                  (let ((inhibit-quit t))
                    (setq rollback-failures
                          (tp--rollback-transaction-participants))
                    (run-hooks 'tp--transaction-rollback-functions)
                    (tp--rollback-bindings)
                    (setq tp--reactive-counters counter-snapshot)
                    (run-hooks 'tp--transaction-rollback-final-functions)
                    (when rollback-failures
                      (signal 'tp-reactive-error
                              (list :participant-rollback-failed
                                    rollback-failures))))))
              (when success
                (run-hooks 'tp--transaction-committed-functions)
                (setq after-commit
                      (nreverse tp--transaction-after-commit-callbacks)))
              transaction-result))
      (dolist (callback after-commit) (funcall callback))
      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