tp/tp-transaction.el

;;; tp-transaction.el --- Additive publication transaction contracts -*- lexical-binding: t; -*-

;; Copyright (C) 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:

;; Internal immutable artifacts and one-shot state machines used to shadow TP's
;; v1 publication coordinator.  This module owns no live writer and never edits
;; a buffer.  `tp-reactive' drives the state machine, while `tp-surface' supplies
;; exact target entries backed by the v1 prepare journals and snapshots.

;;; Code:

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

(define-error 'tp-transaction-contract-error
  "Invalid TP publication transaction contract")
(define-error 'tp-publication-binding-error
  "TP publication artifact binding mismatch"
  'tp-transaction-contract-error)
(define-error 'tp-publication-state-error
  "Invalid TP publication artifact state transition"
  'tp-transaction-contract-error)
(define-error 'tp-final-marker-error
  "Invalid TP final-accept marker"
  'tp-transaction-contract-error)

(defconst tp-transaction-protocol 'tp-transaction-protocol-v1+v2
  "Transaction protocol implemented by this TP package version.")

(defconst tp--publication-batch-transitions
  '((prepared staged rolled-back discarded)
    (staged participants rolled-back)
    (participants precommit rolled-back)
    (precommit final-accepting rolled-back)
    (final-accepting committed rolled-back))
  "Allowed one-way state transitions for publication batch candidates.")

(defconst tp--publication-batch-terminal-states
  '(committed rolled-back discarded)
  "Terminal publication batch candidate states.")

(defconst tp--final-marker-max-count 8
  "Maximum number of opaque final markers in one transaction.")

(defconst tp--final-marker-max-slot-writes 16
  "Maximum total fixed marker slot writes in one transaction.")

(defvar tp--transaction-id-counter 0)
(defvar tp--publication-batch-id-counter 0)
(defvar tp--publication-candidate-id-counter 0)
(defvar tp--final-accept-id-counter 0)

(defun tp--next-transaction-id ()
  "Return a fresh monotonic internal transaction identifier."
  (cl-incf tp--transaction-id-counter))

(defun tp--next-publication-batch-id ()
  "Return a fresh monotonic publication batch identifier."
  (cl-incf tp--publication-batch-id-counter))

(defun tp--next-publication-candidate-id ()
  "Return a fresh monotonic target candidate identifier."
  (cl-incf tp--publication-candidate-id-counter))

(defun tp--next-final-accept-id ()
  "Return a fresh monotonic final-accept identifier."
  (cl-incf tp--final-accept-id-counter))

(defun tp--proper-unique-list-p (items)
  "Return non-nil when ITEMS is a proper list with no equal duplicates."
  (and (proper-list-p items)
       (let (seen (unique t))
         (dolist (item items unique)
           (if (member item seen)
               (setq unique nil)
             (push item seen))))))

(cl-defstruct (tp-publication-target-entry
               (:constructor tp--make-publication-target-entry)
               (:copier nil))
  "One exact, immutable target binding in a publication candidate."
  (transaction-id nil :read-only t)
  (batch-id nil :read-only t)
  (candidate-id nil :read-only t)
  (surface-id nil :read-only t)
  (mount-ids nil :read-only t)
  (buffer nil :read-only t)
  (old-revision nil :read-only t)
  (new-revision nil :read-only t)
  (plan nil :read-only t)
  (diff nil :read-only t)
  (ledger nil :read-only t)
  (objects nil :read-only t)
  (ranges nil :read-only t)
  (client-state nil :read-only t)
  (rollback-snapshot nil :read-only t)
  (authority-token nil :read-only t)
  (mapping-generation nil :read-only t)
  operation-counts
  (shadow-expected nil :read-only t)
  (shadow-validator nil :read-only t)
  rollback-result post-rollback-state shadow-actual shadow-proven-p)

(cl-defun tp--publication-target-entry-create
    (&key transaction-id batch-id candidate-id surface-id mount-ids buffer
          old-revision new-revision plan diff ledger objects ranges client-state
          rollback-snapshot authority-token mapping-generation shadow-expected
          shadow-validator operation-counts)
  "Create an exact TRANSACTION-ID and BATCH-ID target binding.
CANDIDATE-ID, SURFACE-ID, MOUNT-IDS, BUFFER, OLD-REVISION, NEW-REVISION, PLAN,
DIFF, LEDGER, OBJECTS, RANGES, CLIENT-STATE, ROLLBACK-SNAPSHOT, and
AUTHORITY-TOKEN describe the target.  MAPPING-GENERATION is optional.
OPERATION-COUNTS is filled from the v1 report.  SHADOW-EXPECTED and
SHADOW-VALIDATOR are private comparison artifacts."
  (unless (and transaction-id batch-id candidate-id surface-id
               (bufferp buffer) (buffer-live-p buffer)
               (integerp old-revision) (>= old-revision 0)
               (integerp new-revision) (= new-revision (1+ old-revision))
               (tp--proper-unique-list-p mount-ids)
               authority-token
               (or (null shadow-validator) (functionp shadow-validator)))
    (signal 'tp-publication-binding-error
            (list :target-entry transaction-id batch-id candidate-id surface-id
                  buffer old-revision new-revision mount-ids authority-token)))
  (tp--make-publication-target-entry
   :transaction-id transaction-id
   :batch-id batch-id
   :candidate-id candidate-id
   :surface-id (tp--copy-property-value surface-id)
   :mount-ids (tp--copy-property-value mount-ids)
   :buffer buffer
   :old-revision old-revision
   :new-revision new-revision
   :plan plan
   :diff (tp--copy-property-value diff)
   :ledger ledger
   :objects objects
   :ranges ranges
   :client-state (tp--copy-property-value client-state)
   :rollback-snapshot rollback-snapshot
   :authority-token authority-token
   :mapping-generation mapping-generation
   :operation-counts (tp--copy-property-value operation-counts)
   :shadow-expected shadow-expected
   :shadow-validator shadow-validator))

(cl-defstruct (tp-publication-outcome-entry
               (:constructor tp--make-publication-outcome-entry)
               (:copier nil))
  "Frozen observational binding copied from one target entry."
  (batch-id nil :read-only t)
  (candidate-id nil :read-only t)
  (surface-id nil :read-only t)
  (mount-ids nil :read-only t)
  (buffer nil :read-only t)
  (authority-token nil :read-only t)
  (old-revision nil :read-only t)
  (new-revision nil :read-only t)
  (mapping-generation nil :read-only t)
  (operation-counts nil :read-only t))

(defun tp--publication-outcome-entry-from-target (entry)
  "Return an observational outcome entry frozen from target ENTRY."
  (tp--make-publication-outcome-entry
   :batch-id (tp-publication-target-entry-batch-id entry)
   :candidate-id (tp-publication-target-entry-candidate-id entry)
   :surface-id
   (tp--copy-property-value (tp-publication-target-entry-surface-id entry))
   :mount-ids
   (tp--copy-property-value (tp-publication-target-entry-mount-ids entry))
   :buffer (tp-publication-target-entry-buffer entry)
   :authority-token (tp-publication-target-entry-authority-token entry)
   :old-revision (tp-publication-target-entry-old-revision entry)
   :new-revision (tp-publication-target-entry-new-revision entry)
   :mapping-generation
   (tp-publication-target-entry-mapping-generation entry)
   :operation-counts
   (tp--copy-property-value
    (tp-publication-target-entry-operation-counts entry))))

(cl-defstruct (tp-committed-success-outcome
               (:constructor tp--make-committed-success-outcome)
               (:copier nil))
  "Preallocated immutable evidence finalized only after final accept."
  (tag nil :read-only t)
  (transaction-id nil :read-only t)
  (final-accept-id nil :read-only t)
  (batch-id nil :read-only t)
  (entries nil :read-only t)
  (mapping-generation nil :read-only t)
  (operation-counts nil :read-only t)
  (phase-timings nil :read-only t)
  (diagnostics nil :read-only t)
  (marker-count nil :read-only t))

(defconst tp--committed-success-outcome-tag-slot 1
  "Private record offset for the sole postaccept success-tag write.")

(cl-defstruct (tp-publication-failure-outcome
               (:constructor tp--make-publication-failure-outcome)
               (:copier nil))
  "Immutable observational evidence built after publication rollback."
  (tag 'publication-failure :read-only t)
  (transaction-id nil :read-only t)
  (batch-id nil :read-only t)
  (failure-stage nil :read-only t)
  (primary-condition nil :read-only t)
  (target-results nil :read-only t)
  (rollback-failures nil :read-only t)
  (post-rollback-state nil :read-only t)
  (diagnostics nil :read-only t))

(cl-defstruct (tp-publication-batch-candidate
               (:constructor tp--make-publication-batch-candidate)
               (:copier nil))
  "A one-shot structured view over the existing v1 transaction state."
  (transaction-id nil :read-only t)
  (id nil :read-only t)
  state
  resolution
  (entries nil :read-only t)
  (participants nil :read-only t)
  (journals nil :read-only t)
  final-accept
  (final-accept-id nil :read-only t)
  diagnostics
  operation-counts
  phase-timings
  markers
  success-outcome-draft
  outcome
  shadow-proof)

(defun tp--publication-target-entry-bound-p (entry transaction-id batch-id)
  "Return non-nil when ENTRY is exactly bound to TRANSACTION-ID and BATCH-ID."
  (and (tp-publication-target-entry-p entry)
       (equal transaction-id
              (tp-publication-target-entry-transaction-id entry))
       (equal batch-id (tp-publication-target-entry-batch-id entry))))

(defun tp--publication-batch-entries-valid-p
    (entries transaction-id batch-id)
  "Return non-nil when ENTRIES bind TRANSACTION-ID and BATCH-ID exactly."
  (and (proper-list-p entries)
       entries
       (cl-every (lambda (entry)
                   (tp--publication-target-entry-bound-p
                    entry transaction-id batch-id))
                 entries)
       (tp--proper-unique-list-p
        (mapcar #'tp-publication-target-entry-candidate-id entries))
       (tp--proper-unique-list-p
        (mapcar #'tp-publication-target-entry-surface-id entries))
       (tp--proper-unique-list-p
        (mapcar #'tp-publication-target-entry-authority-token entries))
       (let ((generation
              (tp-publication-target-entry-mapping-generation (car entries))))
         (cl-every
          (lambda (entry)
            (equal generation
                   (tp-publication-target-entry-mapping-generation entry)))
          entries))))

(cl-defun tp--publication-batch-prepare
    (&key transaction-id batch-id entries participants journals final-accept
          diagnostics)
  "Prepare TRANSACTION-ID and BATCH-ID over exact ENTRIES.
PARTICIPANTS is an ordered reference vector, JOURNALS is the existing v1 state
view, FINAL-ACCEPT is the single coordinator function, and DIAGNOSTICS contains
known preaccept observations."
  (unless (and transaction-id batch-id
               (tp--publication-batch-entries-valid-p
                entries transaction-id batch-id)
               (vectorp participants)
               (functionp final-accept))
    (signal 'tp-publication-binding-error
            (list :batch transaction-id batch-id entries participants)))
  (tp--make-publication-batch-candidate
   :transaction-id transaction-id
   :id batch-id
   :state 'prepared
   :entries (copy-sequence entries)
   :participants participants
   :journals journals
   :final-accept final-accept
   :final-accept-id (tp--next-final-accept-id)
   :diagnostics (tp--copy-property-value diagnostics)))

(defun tp--publication-batch-terminal-p (candidate)
  "Return non-nil when CANDIDATE has one terminal disposition."
  (and (tp-publication-batch-candidate-p candidate)
       (memq (tp-publication-batch-candidate-state candidate)
             tp--publication-batch-terminal-states)))

(defun tp--publication-batch-transition (candidate next)
  "Move CANDIDATE to NEXT through its one-way state machine."
  (unless (tp-publication-batch-candidate-p candidate)
    (signal 'wrong-type-argument
            (list 'tp-publication-batch-candidate-p candidate)))
  (let* ((current (tp-publication-batch-candidate-state candidate))
         (allowed (cdr (assq current tp--publication-batch-transitions))))
    (unless (memq next allowed)
      (signal 'tp-publication-state-error
              (list :batch-state current next
                    (tp-publication-batch-candidate-id candidate))))
    (setf (tp-publication-batch-candidate-state candidate) next)
    (when (memq next tp--publication-batch-terminal-states)
      (setf (tp-publication-batch-candidate-resolution candidate) next))
    candidate))

(defun tp--publication-batch-discard (candidate reason)
  "Discard prepared CANDIDATE for REASON and return nil."
  (unless (and (tp-publication-batch-candidate-p candidate)
               (eq (tp-publication-batch-candidate-state candidate) 'prepared))
    (signal 'tp-publication-state-error
            (list :discard
                  (and (tp-publication-batch-candidate-p candidate)
                       (tp-publication-batch-candidate-state candidate)))))
  (setf (tp-publication-batch-candidate-diagnostics candidate)
        (append (tp-publication-batch-candidate-diagnostics candidate)
                (list (list :discard reason))))
  (tp--publication-batch-transition candidate 'discarded)
  nil)

(defun tp--committed-success-outcome-draft
    (candidate operation-counts phase-timings diagnostics marker-count)
  "Preallocate CANDIDATE evidence using OPERATION-COUNTS and PHASE-TIMINGS.
DIAGNOSTICS contains known preaccept failures and MARKER-COUNT is fixed."
  (unless (tp-publication-batch-candidate-p candidate)
    (signal 'wrong-type-argument
            (list 'tp-publication-batch-candidate-p candidate)))
  (setf (tp-publication-batch-candidate-operation-counts candidate)
        (tp--copy-property-value operation-counts)
        (tp-publication-batch-candidate-phase-timings candidate)
        (tp--copy-property-value phase-timings)
        (tp-publication-batch-candidate-diagnostics candidate)
        (tp--copy-property-value diagnostics))
  (tp--make-committed-success-outcome
   :transaction-id
   (tp-publication-batch-candidate-transaction-id candidate)
   :final-accept-id
   (tp-publication-batch-candidate-final-accept-id candidate)
   :batch-id (tp-publication-batch-candidate-id candidate)
   :entries
   (mapcar #'tp--publication-outcome-entry-from-target
           (tp-publication-batch-candidate-entries candidate))
   :mapping-generation
   (let ((entries (tp-publication-batch-candidate-entries candidate)))
     (and entries
          (tp-publication-target-entry-mapping-generation (car entries))))
   :operation-counts
   (tp--copy-property-value
    (tp-publication-batch-candidate-operation-counts candidate))
   :phase-timings
   (tp--copy-property-value
    (tp-publication-batch-candidate-phase-timings candidate))
   :diagnostics
   (tp--copy-property-value
    (tp-publication-batch-candidate-diagnostics candidate))
   :marker-count marker-count))

(defun tp--committed-success-outcome-finalize (outcome)
  "Finalize preallocated OUTCOME exactly once after final accept."
  (unless (and (tp-committed-success-outcome-p outcome)
               (null (tp-committed-success-outcome-tag outcome)))
    (signal 'tp-publication-state-error (list :success-outcome outcome)))
  ;; The slot is read-only to every accessor.  This single fixed vector write is
  ;; the coordinator's postaccept tag finalization primitive.
  (aset outcome tp--committed-success-outcome-tag-slot 'committed-success)
  outcome)

(defun tp--publication-outcome-entry-matches-target-p (outcome-entry target)
  "Return non-nil when OUTCOME-ENTRY is exactly bound to TARGET."
  (and (tp-publication-outcome-entry-p outcome-entry)
       (tp-publication-target-entry-p target)
       (equal (tp-publication-outcome-entry-batch-id outcome-entry)
              (tp-publication-target-entry-batch-id target))
       (equal (tp-publication-outcome-entry-candidate-id outcome-entry)
              (tp-publication-target-entry-candidate-id target))
       (equal (tp-publication-outcome-entry-surface-id outcome-entry)
              (tp-publication-target-entry-surface-id target))
       (equal (tp-publication-outcome-entry-mount-ids outcome-entry)
              (tp-publication-target-entry-mount-ids target))
       (eq (tp-publication-outcome-entry-buffer outcome-entry)
           (tp-publication-target-entry-buffer target))
       (eq (tp-publication-outcome-entry-authority-token outcome-entry)
           (tp-publication-target-entry-authority-token target))
       (= (tp-publication-outcome-entry-old-revision outcome-entry)
          (tp-publication-target-entry-old-revision target))
       (= (tp-publication-outcome-entry-new-revision outcome-entry)
          (tp-publication-target-entry-new-revision target))
       (equal (tp-publication-outcome-entry-mapping-generation outcome-entry)
              (tp-publication-target-entry-mapping-generation target))
       (equal (tp-publication-outcome-entry-operation-counts outcome-entry)
              (tp-publication-target-entry-operation-counts target))))

(defun tp--committed-success-outcome-valid-for-p
    (outcome candidate &optional mapping-generation)
  "Purely validate OUTCOME against exact CANDIDATE and MAPPING-GENERATION."
  (and (tp-committed-success-outcome-p outcome)
       (eq (tp-committed-success-outcome-tag outcome) 'committed-success)
       (tp-publication-batch-candidate-p candidate)
       (eq (tp-publication-batch-candidate-state candidate) 'committed)
       (equal (tp-committed-success-outcome-transaction-id outcome)
              (tp-publication-batch-candidate-transaction-id candidate))
       (equal (tp-committed-success-outcome-batch-id outcome)
              (tp-publication-batch-candidate-id candidate))
       (equal (tp-committed-success-outcome-operation-counts outcome)
              (tp-publication-batch-candidate-operation-counts candidate))
       (equal (tp-committed-success-outcome-phase-timings outcome)
              (tp-publication-batch-candidate-phase-timings candidate))
       (equal (tp-committed-success-outcome-diagnostics outcome)
              (tp-publication-batch-candidate-diagnostics candidate))
       (= (tp-committed-success-outcome-marker-count outcome)
          (if (consp (tp-publication-batch-candidate-markers candidate))
              (cdr (tp-publication-batch-candidate-markers candidate))
            0))
       (or (null mapping-generation)
           (equal mapping-generation
                  (tp-committed-success-outcome-mapping-generation outcome)))
       (let ((outcome-entries
              (append (tp-committed-success-outcome-entries outcome) nil))
             (targets (tp-publication-batch-candidate-entries candidate)))
         (and (= (length outcome-entries) (length targets))
              (cl-every #'identity
                        (cl-mapcar
                         #'tp--publication-outcome-entry-matches-target-p
                         outcome-entries targets))))))

(defun tp--committed-success-outcome-snapshot (outcome)
  "Return a defensive observational plist for committed OUTCOME."
  (unless (and (tp-committed-success-outcome-p outcome)
               (eq (tp-committed-success-outcome-tag outcome)
                   'committed-success))
    (signal 'tp-publication-binding-error (list :outcome outcome)))
  (list
   :tag 'committed-success
   :transaction-id (tp-committed-success-outcome-transaction-id outcome)
   :final-accept-id (tp-committed-success-outcome-final-accept-id outcome)
   :batch-id (tp-committed-success-outcome-batch-id outcome)
   :entries
   (mapcar
    (lambda (entry)
      (list :batch-id (tp-publication-outcome-entry-batch-id entry)
            :candidate-id (tp-publication-outcome-entry-candidate-id entry)
            :surface-id
            (tp--copy-property-value
             (tp-publication-outcome-entry-surface-id entry))
            :mount-ids
            (tp--copy-property-value
             (tp-publication-outcome-entry-mount-ids entry))
            :buffer (tp-publication-outcome-entry-buffer entry)
            :authority-token
            (tp-publication-outcome-entry-authority-token entry)
            :old-revision
            (tp-publication-outcome-entry-old-revision entry)
            :new-revision
            (tp-publication-outcome-entry-new-revision entry)
            :mapping-generation
            (tp-publication-outcome-entry-mapping-generation entry)
            :operation-counts
            (tp--copy-property-value
             (tp-publication-outcome-entry-operation-counts entry))))
    (append (tp-committed-success-outcome-entries outcome) nil))
   :mapping-generation
   (tp-committed-success-outcome-mapping-generation outcome)
   :operation-counts
   (tp--copy-property-value
    (tp-committed-success-outcome-operation-counts outcome))
   :phase-timings
   (tp--copy-property-value
    (tp-committed-success-outcome-phase-timings outcome))
   :diagnostics
   (tp--copy-property-value
    (tp-committed-success-outcome-diagnostics outcome))
   :marker-count (tp-committed-success-outcome-marker-count outcome)))

(defun tp--publication-failure-outcome-valid-for-p (outcome candidate)
  "Purely validate failure OUTCOME against rolled-back CANDIDATE."
  (and (tp-publication-failure-outcome-p outcome)
       (eq (tp-publication-failure-outcome-tag outcome)
           'publication-failure)
       (tp-publication-batch-candidate-p candidate)
       (eq (tp-publication-batch-candidate-state candidate) 'rolled-back)
       (equal (tp-publication-failure-outcome-transaction-id outcome)
              (tp-publication-batch-candidate-transaction-id candidate))
       (equal (tp-publication-failure-outcome-batch-id outcome)
              (tp-publication-batch-candidate-id candidate))
       (let ((results (tp-publication-failure-outcome-target-results outcome))
             (entries (tp-publication-batch-candidate-entries candidate)))
         (and (= (length results) (length entries))
              (cl-every
               #'identity
               (cl-mapcar
                (lambda (result entry)
                  (and
                   (equal (plist-get result :candidate-id)
                          (tp-publication-target-entry-candidate-id entry))
                   (equal (plist-get result :surface-id)
                          (tp-publication-target-entry-surface-id entry))))
                results entries))))))

(defun tp--publication-failure-outcome-create
    (candidate stage primary-condition rollback-failures diagnostics)
  "Build rolled-back CANDIDATE evidence for STAGE and PRIMARY-CONDITION.
ROLLBACK-FAILURES and DIAGNOSTICS are observational snapshots."
  (unless (and (tp-publication-batch-candidate-p candidate)
               (eq (tp-publication-batch-candidate-state candidate)
                   'rolled-back))
    (signal 'tp-publication-state-error (list :failure-outcome candidate)))
  (let ((entries (tp-publication-batch-candidate-entries candidate)))
    (tp--make-publication-failure-outcome
     :transaction-id
     (tp-publication-batch-candidate-transaction-id candidate)
     :batch-id (tp-publication-batch-candidate-id candidate)
     :failure-stage stage
     :primary-condition (tp--copy-property-value primary-condition)
     :target-results
     (mapcar
      (lambda (entry)
        (list :candidate-id
              (tp-publication-target-entry-candidate-id entry)
              :surface-id
              (tp--copy-property-value
               (tp-publication-target-entry-surface-id entry))
              :result
              (tp--copy-property-value
               (tp-publication-target-entry-rollback-result entry))))
      entries)
     :rollback-failures (tp--copy-property-value rollback-failures)
     :post-rollback-state
     (mapcar
      (lambda (entry)
        (list :candidate-id
              (tp-publication-target-entry-candidate-id entry)
              :surface-id
              (tp--copy-property-value
               (tp-publication-target-entry-surface-id entry))
              :state
              (tp--copy-property-value
               (tp-publication-target-entry-post-rollback-state entry))))
      entries)
     :diagnostics (tp--copy-property-value diagnostics))))

(cl-defstruct (tp--final-marker-operation
               (:constructor tp--make-final-marker-operation)
               (:copier nil))
  "One trusted operation descriptor resolved before final accept."
  (key nil :read-only t)
  (validate nil :read-only t)
  (apply nil :read-only t)
  (restore nil :read-only t)
  (max-slot-writes nil :read-only t))

(cl-defstruct (tp-final-marker-expectation
               (:constructor tp--make-final-marker-expectation)
               (:copier nil))
  "One prebuilt expected scalar stored in a fixed vector slot."
  (target nil :read-only t)
  (index nil :read-only t)
  (value nil :read-only t))

(cl-defstruct (tp-final-marker-slot-write
               (:constructor tp--make-final-marker-slot-write)
               (:copier nil))
  "One prebuilt fixed vector slot write."
  (target nil :read-only t)
  (index nil :read-only t)
  (value nil :read-only t))

(defun tp--final-marker-vector-index-p (target index)
  "Return non-nil when INDEX denotes a writable slot in TARGET."
  (and (vectorp target) (integerp index) (<= 0 index) (< index (length target))))

(cl-defun tp--final-marker-expectation-create (&key target index value)
  "Create an expectation that TARGET slot INDEX currently equals VALUE."
  (unless (tp--final-marker-vector-index-p target index)
    (signal 'tp-final-marker-error (list :expectation target index)))
  (tp--make-final-marker-expectation
   :target target :index index :value value))

(cl-defun tp-final-marker-expectation-create (&key target index value)
  "Create a final-marker expectation for TARGET slot INDEX and VALUE."
  (tp--final-marker-expectation-create
   :target target :index index :value value))

(cl-defun tp--final-marker-slot-write-create (&key target index value)
  "Create one prebuilt write of VALUE into TARGET slot INDEX."
  (unless (tp--final-marker-vector-index-p target index)
    (signal 'tp-final-marker-error (list :slot-write target index)))
  (tp--make-final-marker-slot-write :target target :index index :value value))

(cl-defun tp-final-marker-slot-write-create (&key target index value)
  "Create one bounded final-marker write to TARGET slot INDEX with VALUE."
  (tp--final-marker-slot-write-create
   :target target :index index :value value))

(defun tp--final-marker-expectation-current-p (expectation)
  "Return non-nil when EXPECTATION matches its current fixed slot."
  (and (tp-final-marker-expectation-p expectation)
       (equal
        (aref (tp-final-marker-expectation-target expectation)
              (tp-final-marker-expectation-index expectation))
        (tp-final-marker-expectation-value expectation))))

(defun tp--final-marker-slot-write-shape-p (write)
  "Return non-nil when WRITE still denotes one valid fixed vector slot."
  (and (tp-final-marker-slot-write-p write)
       (tp--final-marker-vector-index-p
        (tp-final-marker-slot-write-target write)
        (tp-final-marker-slot-write-index write))))

(defun tp--final-marker-vector-payload-shape-p (marker)
  "Return non-nil when MARKER has exact paired fixed vector slot payloads."
  (let ((next (tp-final-accept-marker-next-values marker))
        (inverse (tp-final-accept-marker-inverse-values marker))
        (count (tp-final-accept-marker-slot-write-count marker))
        seen valid)
    (setq valid
          (and (vectorp next) (vectorp inverse)
               (= (length next) count) (= (length inverse) count)))
    (let ((index 0))
      (while (and valid (< index count))
        (let ((next-write (aref next index))
              (inverse-write (aref inverse index)))
          (setq valid
                (and
                 (tp--final-marker-slot-write-shape-p next-write)
                 (tp--final-marker-slot-write-shape-p inverse-write)
                 (eq (tp-final-marker-slot-write-target next-write)
                     (tp-final-marker-slot-write-target inverse-write))
                 (= (tp-final-marker-slot-write-index next-write)
                    (tp-final-marker-slot-write-index inverse-write))
                 (not
                  (cl-find-if
                   (lambda (entry)
                     (and
                      (eq (car entry)
                          (tp-final-marker-slot-write-target next-write))
                      (= (cdr entry)
                         (tp-final-marker-slot-write-index next-write))))
                   seen))))
          (when valid
            (push (cons (tp-final-marker-slot-write-target next-write)
                        (tp-final-marker-slot-write-index next-write))
                  seen)))
        (setq index (1+ index))))
    valid))

(defun tp--final-marker-vector-slots-validate (marker)
  "Validate MARKER expectations and inverse values without changing state."
  (and
   (tp--final-marker-vector-payload-shape-p marker)
   (tp--final-marker-expectation-current-p
    (tp-final-accept-marker-expected-token marker))
   (tp--final-marker-expectation-current-p
    (tp-final-accept-marker-expected-version marker))
   (let* ((inverse (tp-final-accept-marker-inverse-values marker))
          (count (length inverse))
          (index 0)
          (valid t))
     (while (and valid (< index count))
       (let ((write (aref inverse index)))
         (setq valid
               (equal
                (aref (tp-final-marker-slot-write-target write)
                      (tp-final-marker-slot-write-index write))
                (tp-final-marker-slot-write-value write))))
       (setq index (1+ index)))
     valid)))

(defun tp--final-marker-vector-slots-apply (marker)
  "Apply MARKER's fixed next-value vector slots in order."
  (let* ((writes (tp-final-accept-marker-next-values marker))
         (count (length writes))
         (index 0))
    (while (< index count)
      (let ((write (aref writes index)))
        (aset (tp-final-marker-slot-write-target write)
              (tp-final-marker-slot-write-index write)
              (tp-final-marker-slot-write-value write)))
      (setq index (1+ index)))))

(defun tp--final-marker-vector-slots-restore (marker)
  "Restore MARKER's fixed inverse-value vector slots in reverse order."
  (let* ((writes (tp-final-accept-marker-inverse-values marker))
         (index (1- (length writes))))
    (while (>= index 0)
      (let ((write (aref writes index)))
        (aset (tp-final-marker-slot-write-target write)
              (tp-final-marker-slot-write-index write)
              (tp-final-marker-slot-write-value write)))
      (setq index (1- index)))))

(defconst tp--final-marker-operation-whitelist
  (list
   (tp--make-final-marker-operation
    :key 'tp-vector-slots/v1
    :validate (symbol-function 'tp--final-marker-vector-slots-validate)
    :apply (symbol-function 'tp--final-marker-vector-slots-apply)
    :restore (symbol-function 'tp--final-marker-vector-slots-restore)
    :max-slot-writes tp--final-marker-max-slot-writes))
  "Closed package-owned final-marker primitive whitelist.")

(defun tp--final-marker-operation-resolve (key)
  "Return the trusted final marker operation registered for KEY."
  (let ((operation
         (cl-find key tp--final-marker-operation-whitelist
                  :key #'tp--final-marker-operation-key :test #'eq)))
    (or operation
        (signal 'tp-final-marker-error (list :operation-not-whitelisted key)))))

(cl-defstruct (tp-final-accept-marker
               (:constructor tp--make-final-accept-marker)
               (:copier nil))
  "One opaque, bounded, one-shot final-accept authority marker."
  (owner-key nil :read-only t)
  (expected-token nil :read-only t)
  (expected-version nil :read-only t)
  (next-values nil :read-only t)
  (inverse-values nil :read-only t)
  (slot-write-count nil :read-only t)
  (operation-key nil :read-only t)
  (operation nil :read-only t)
  state)

(cl-defun tp--final-accept-marker-create
    (&key owner-key expected-token expected-version next-values inverse-values
          slot-write-count operation-key)
  "Create an OWNER-KEY marker after resolving OPERATION-KEY.
EXPECTED-TOKEN and EXPECTED-VERSION bind owner state.  NEXT-VALUES and
INVERSE-VALUES are opaque prebuilt payloads with fixed SLOT-WRITE-COUNT."
  (let ((operation (tp--final-marker-operation-resolve operation-key)))
    (unless (and owner-key
                 (tp-final-marker-expectation-p expected-token)
                 (tp-final-marker-expectation-p expected-version)
                 (integerp
                  (tp-final-marker-expectation-value expected-version))
                 (>= (tp-final-marker-expectation-value expected-version) 0)
                 (integerp slot-write-count) (> slot-write-count 0)
                 (<= slot-write-count
                     (tp--final-marker-operation-max-slot-writes operation)))
      (signal 'tp-final-marker-error
              (list :marker owner-key expected-token expected-version
                    slot-write-count operation-key)))
    (let ((marker
           (tp--make-final-accept-marker
            :owner-key (tp--copy-property-value owner-key)
            :expected-token expected-token
            :expected-version expected-version
            :next-values (and (vectorp next-values)
                              (copy-sequence next-values))
            :inverse-values (and (vectorp inverse-values)
                                 (copy-sequence inverse-values))
            :slot-write-count slot-write-count
            :operation-key operation-key
            :operation operation
            :state 'prepared)))
      (unless (tp--final-marker-vector-payload-shape-p marker)
        (signal 'tp-final-marker-error
                (list :marker-payload owner-key slot-write-count)))
      marker)))

(defun tp--final-accept-marker-validate (marker)
  "Validate MARKER's expected owner state before the critical section."
  (unless (and (tp-final-accept-marker-p marker)
               (eq (tp-final-accept-marker-state marker) 'prepared)
               (funcall
                (tp--final-marker-operation-validate
                 (tp-final-accept-marker-operation marker))
                marker))
    (signal 'tp-final-marker-error
            (list :expected-state
                  (and (tp-final-accept-marker-p marker)
                       (tp-final-accept-marker-owner-key marker)))))
  marker)

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