tp/tp-style.el

;;; tp-style.el --- Schema-driven text property cascade -*- 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:

;; Pure property schema, structured selector, and cascade computation for TP.
;; This module owns no buffers, markers, mounts, or reactive subscriptions.

;;; Code:

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

(define-error 'tp-style-error "TP style error")
(define-error 'tp-invalid-property-schema "Invalid TP property schema"
  'tp-style-error)
(define-error 'tp-invalid-style "Invalid TP style declaration"
  'tp-style-error)
(define-error 'tp-invalid-selector "Invalid TP selector" 'tp-style-error)

(cl-defstruct (tp-property-schema
               (:constructor tp--make-property-schema))
  "Schema governing one namespaced cascade property."
  id initial inherits normalizer validator equality merge projector shorthand)

(cl-defstruct (tp-subject (:constructor tp--make-subject))
  "Generic selector subject independent of any rendering consumer."
  type id classes attributes state parent children)

(cl-defstruct (tp-computed-style (:constructor tp--make-computed-style))
  "Computed values, active properties, custom properties, and provenance."
  values custom-properties active-properties provenance)

(cl-defstruct (tp-stylesheet
               (:constructor tp-stylesheet-create ())
               (:conc-name tp--stylesheet-))
  "Independent ordered rule and cascade-layer collection."
  rules layers (source-order 0))

(cl-defstruct (tp--computed-source (:constructor tp--make-computed-source))
  function)

(cl-defstruct (tp--wide (:constructor tp--make-wide)) kind)
(cl-defstruct (tp--important (:constructor tp--make-important)) value)
(cl-defstruct (tp--var-ref (:constructor tp--make-var-ref))
  name fallback-present-p fallback)

(cl-defstruct (tp--style-rule (:constructor tp--make-style-rule))
  selector declarations origin layer layer-rank scope specificity source-order)

(cl-defstruct (tp--candidate (:constructor tp--make-candidate))
  property value origin important layer layer-rank specificity scope-distance
  source-order declaration-order selector)

(defconst tp--style-origin-order
  '(default theme package author inline runtime user)
  "Cascade origins ordered from weakest to strongest.")

(defconst tp--wide-kinds '(initial inherit unset revert revert-layer)
  "Supported CSS-wide value kinds.")

(defconst tp--style-all-rules (make-symbol "tp-all-style-rules"))
(defconst tp--style-invalid (make-symbol "tp-invalid-style-value"))
(defconst tp--style-absent (make-symbol "tp-absent-style-value"))

(defvar tp--property-schemas (make-hash-table :test #'eq))
(defvar tp--property-schema-order nil)
(defvar tp--named-styles (make-hash-table :test #'eq))
(defvar tp--stylesheet-rules nil)
(defvar tp--cascade-layers nil)
(defvar tp--style-source-order 0)

(defconst tp--style-runtime-properties
  '(tp-name tp-layers tp-meta tp-hidden tp-text)
  "Runtime-only properties excluded from declarative text styles.")

(defun tp--canonical-property-id-p (id)
  "Return non-nil when ID is a namespaced property symbol."
  (and (symbolp id)
       (let ((name (symbol-name id)))
         (and (string-match-p "/" name)
              (not (string-prefix-p "/" name))
              (not (string-suffix-p "/" name))))))

(defun tp--custom-property-p (property)
  "Return non-nil when PROPERTY names a custom cascade variable."
  (and (symbolp property)
       (string-prefix-p "--" (symbol-name property))))

(defun tp--callable-option-p (value)
  "Return non-nil when VALUE is nil or callable."
  (or (null value) (functionp value)))

(defun tp--validate-schema-functions (options)
  "Validate callable fields in schema OPTIONS."
  (dolist (key '(:normalizer :validator :equality :merge
                 :projector :shorthand))
    (unless (tp--callable-option-p (plist-get options key))
      (signal 'tp-invalid-property-schema
              (list key (plist-get options key))))))

(defun tp--schema-option (options key default)
  "Return KEY from OPTIONS when present, otherwise DEFAULT."
  (if (plist-member options key) (plist-get options key) default))

(defun tp--build-property-schema (id options)
  "Build and validate a property schema for ID from OPTIONS."
  (unless (tp--canonical-property-id-p id)
    (signal 'tp-invalid-property-schema (list :property id)))
  (tp--validate-schema-functions options)
  (tp--make-property-schema
   :id id
   :initial (plist-get options :initial)
   :inherits (and (plist-get options :inherits) t)
   :normalizer (tp--schema-option options :normalizer #'identity)
   :validator (tp--schema-option options :validator (lambda (_value) t))
   :equality (tp--schema-option options :equality #'equal)
   :merge (tp--schema-option options :merge (lambda (_old new) new))
   :projector (plist-get options :projector)
   :shorthand (plist-get options :shorthand)))

;;;###autoload
(defun tp-define-property (id &rest options)
  "Register namespaced property ID using schema OPTIONS.
OPTIONS support :initial, :inherits, :normalizer, :validator, :equality,
:merge, :projector, and :shorthand.  Registration is atomic."
  (let ((schema (tp--build-property-schema id options)))
    (unless (gethash id tp--property-schemas)
      (setq tp--property-schema-order
            (append tp--property-schema-order (list id))))
    (puthash id schema tp--property-schemas)
    schema))

(defun tp-property-schema (id)
  "Return the registered property schema for ID, or nil."
  (gethash id tp--property-schemas))

(defun tp-text-property-id (property)
  "Return the canonical `text/' schema id for Emacs PROPERTY."
  (unless (symbolp property)
    (signal 'wrong-type-argument (list 'symbolp property)))
  (intern (format "text/%s" property)))

(defun tp--text-property-inherits-p (property)
  "Return non-nil when PROPERTY inherits in TP's text domain."
  (memq property '(face font-lock-face)))

(defun tp--text-property-merge-function (property)
  "Return the schema merge function for Emacs PROPERTY."
  (if (memq property tp-face-properties)
      #'tp--merge-face-values
    (lambda (_old new) new)))

(defun tp-register-text-property (property)
  "Register and return a canonical schema for Emacs PROPERTY."
  (let ((id (tp-text-property-id property)))
    (or (tp-property-schema id)
        (tp-define-property
         id :initial nil :inherits (tp--text-property-inherits-p property)
         :equality #'equal :merge (tp--text-property-merge-function property)
         :projector (lambda (value) (list property value))))))

(defun tp--register-default-text-properties ()
  "Register schemas for TP's known native Emacs properties."
  (dolist (property tp--builtin-text-properties)
    (tp-register-text-property property)))

(defun tp-text-declarations (properties)
  "Convert raw Emacs PROPERTIES to canonical text declarations."
  (unless (tp--declaration-list-p properties)
    (signal 'tp-invalid-style (list :text-properties properties)))
  (cl-loop for (property value) on properties by #'cddr
           unless (memq property tp--style-runtime-properties)
           append (list (tp-property-schema-id
                         (tp-register-text-property property))
                        (copy-tree value))))

(defun tp-style-reset-rules (&optional stylesheet)
  "Clear rules and cascade-layer order in optional STYLESHEET.
With nil STYLESHEET, reset TP's process-wide default stylesheet."
  (if stylesheet
      (progn
        (unless (tp-stylesheet-p stylesheet)
          (signal 'wrong-type-argument
                  (list 'tp-stylesheet-p stylesheet)))
        (setf (tp--stylesheet-rules stylesheet) nil
              (tp--stylesheet-layers stylesheet) nil
              (tp--stylesheet-source-order stylesheet) 0))
    (setq tp--stylesheet-rules nil
          tp--cascade-layers nil
          tp--style-source-order 0)))

(defun tp-style-reset ()
  "Clear TP's schemas, named styles, and default stylesheet state.
Caller-owned stylesheet instances retain their rules until reset explicitly."
  (clrhash tp--property-schemas)
  (clrhash tp--named-styles)
  (setq tp--property-schema-order nil)
  (tp-style-reset-rules)
  (tp--register-default-text-properties))

(defun tp-undefine-style (name)
  "Remove named style NAME and return nil."
  (remhash name tp--named-styles)
  nil)

;;;###autoload
(defun tp-computed (function)
  "Return an explicit computed value source wrapping FUNCTION."
  (unless (functionp function)
    (signal 'wrong-type-argument (list 'functionp function)))
  (tp--make-computed-source :function function))

;;;###autoload
(defun tp-wide-value (kind)
  "Return a tagged CSS-wide value of KIND."
  (unless (memq kind tp--wide-kinds)
    (signal 'tp-invalid-style (list :wide-value kind)))
  (tp--make-wide :kind kind))

;;;###autoload
(defun tp-important (value)
  "Return VALUE tagged as an important declaration."
  (tp--make-important :value value))

;;;###autoload
(defun tp-var (name &rest fallback)
  "Return a custom-property reference to NAME with optional FALLBACK."
  (unless (tp--custom-property-p name)
    (signal 'tp-invalid-style (list :custom-property name)))
  (when (> (length fallback) 1)
    (signal 'wrong-number-of-arguments (list 'tp-var (+ 1 (length fallback)))))
  (tp--make-var-ref :name name
                    :fallback-present-p (and fallback t)
                    :fallback (car fallback)))

(cl-defun tp-subject-create (&key type id classes attributes state parent children)
  "Create a generic cascade subject from TYPE, ID, and metadata.
CLASSES and STATE are token lists compared with `equal'.  ATTRIBUTES is an
alist.  PARENT and CHILDREN must be TP subjects when present."
  (when (and parent (not (tp-subject-p parent)))
    (signal 'wrong-type-argument (list 'tp-subject-p parent)))
  (let ((subject (tp--make-subject
                  :type type :id id :classes (copy-sequence classes)
                  :attributes (copy-tree attributes)
                  :state (copy-sequence state) :parent parent)))
    (tp-subject-set-children subject children)))

(defun tp-subject-set-children (subject children)
  "Replace SUBJECT's CHILDREN and establish their parent links."
  (unless (tp-subject-p subject)
    (signal 'wrong-type-argument (list 'tp-subject-p subject)))
  (dolist (child children)
    (unless (tp-subject-p child)
      (signal 'wrong-type-argument (list 'tp-subject-p child))))
  (dolist (old-child (tp-subject-children subject))
    (when (eq (tp-subject-parent old-child) subject)
      (setf (tp-subject-parent old-child) nil)))
  (setf (tp-subject-children subject) (copy-sequence children))
  (dolist (child children)
    (setf (tp-subject-parent child) subject))
  subject)

(defun tp--subject-attribute-cell (subject name)
  "Return SUBJECT's attribute cell for NAME."
  (assq name (tp-subject-attributes subject)))

(defun tp--subject-previous-siblings (subject)
  "Return SUBJECT's preceding siblings in document order."
  (when-let ((parent (tp-subject-parent subject)))
    (let ((siblings (tp-subject-children parent)) result)
      (while (and siblings (not (eq (car siblings) subject)))
        (push (pop siblings) result))
      (nreverse result))))

(defun tp--selector-form-p (selector kind arity)
  "Return non-nil when SELECTOR is KIND with ARITY arguments."
  (and (consp selector) (eq (car selector) kind)
       (= (length (cdr selector)) arity)))

(defun tp--validate-selector-list (selectors)
  "Validate every selector in SELECTORS."
  (and selectors (cl-every #'tp--selector-valid-p selectors)))

(defun tp--selector-valid-p (selector)
  "Return non-nil when SELECTOR is a valid structured selector."
  (pcase (and (consp selector) (car selector))
    ((or :type :id :class :state)
     (tp--selector-form-p selector (car selector) 1))
    (:attr (memq (length (cdr selector)) '(1 2)))
    ((or :and :is :where :not)
     (tp--validate-selector-list (cdr selector)))
    ((or :descendant :child :adjacent :sibling)
     (and (tp--selector-form-p selector (car selector) 2)
          (tp--validate-selector-list (cdr selector))))
    (:universal (null (cdr selector)))
    (_ nil)))

(defun tp--validate-selector (selector)
  "Signal an error unless SELECTOR is structurally valid."
  (unless (tp--selector-valid-p selector)
    (signal 'tp-invalid-selector (list selector)))
  selector)

(defun tp--selector-match-attribute (selector subject)
  "Return whether attribute SELECTOR matches SUBJECT."
  (let ((cell (tp--subject-attribute-cell subject (nth 1 selector))))
    (and cell
         (or (= (length selector) 2)
             (equal (cdr cell) (nth 2 selector))))))

(defun tp--selector-match-descendant (selector subject)
  "Return whether descendant SELECTOR matches SUBJECT."
  (and (tp-selector-match-p (nth 2 selector) subject)
       (cl-loop for parent = (tp-subject-parent subject)
                then (tp-subject-parent parent)
                while parent
                thereis (tp-selector-match-p (nth 1 selector) parent))))

(defun tp--selector-match-adjacent (selector subject)
  "Return whether adjacent SELECTOR matches SUBJECT."
  (let ((siblings (tp--subject-previous-siblings subject)))
    (and siblings
         (tp-selector-match-p (nth 1 selector) (car (last siblings)))
         (tp-selector-match-p (nth 2 selector) subject))))

(defun tp--selector-match-sibling (selector subject)
  "Return whether sibling SELECTOR matches SUBJECT."
  (and (tp-selector-match-p (nth 2 selector) subject)
       (cl-some (lambda (sibling)
                  (tp-selector-match-p (nth 1 selector) sibling))
                (tp--subject-previous-siblings subject))))

(defun tp--selector-match-valid (selector subject)
  "Match already validated SELECTOR against SUBJECT."
  (pcase (car selector)
    (:universal t)
    (:type (equal (nth 1 selector) (tp-subject-type subject)))
    (:id (equal (nth 1 selector) (tp-subject-id subject)))
    (:class (member (nth 1 selector) (tp-subject-classes subject)))
    (:state (member (nth 1 selector) (tp-subject-state subject)))
    (:attr (tp--selector-match-attribute selector subject))
    (:and (cl-every (lambda (item) (tp-selector-match-p item subject))
                    (cdr selector)))
    (:is (cl-some (lambda (item) (tp-selector-match-p item subject))
                  (cdr selector)))
    (:where (cl-some (lambda (item) (tp-selector-match-p item subject))
                     (cdr selector)))
    (:not (not (cl-some (lambda (item) (tp-selector-match-p item subject))
                        (cdr selector))))
    (:descendant (tp--selector-match-descendant selector subject))
    (:child (and (tp-selector-match-p (nth 2 selector) subject)
                 (when-let ((parent (tp-subject-parent subject)))
                   (tp-selector-match-p (nth 1 selector) parent))))
    (:adjacent (tp--selector-match-adjacent selector subject))
    (:sibling (tp--selector-match-sibling selector subject))))

;;;###autoload
(defun tp-selector-match-p (selector subject)
  "Return non-nil when structured SELECTOR matches SUBJECT."
  (unless (tp-subject-p subject)
    (signal 'wrong-type-argument (list 'tp-subject-p subject)))
  (tp--validate-selector selector)
  (tp--selector-match-valid selector subject))

(defun tp--specificity-add (left right)
  "Add specificity triples LEFT and RIGHT."
  (cl-mapcar #'+ left right))

(defun tp--specificity-max (values)
  "Return the lexicographically greatest specificity in VALUES."
  (cl-reduce (lambda (left right)
               (if (tp--specificity-greater-p left right) left right))
             values :initial-value '(0 0 0)))

(defun tp--specificity-list-sum (selectors)
  "Return the combined specificity of SELECTORS."
  (cl-reduce #'tp--specificity-add selectors
             :key #'tp-selector-specificity
             :initial-value '(0 0 0)))

(defun tp-selector-specificity (selector)
  "Return SELECTOR specificity as an (ID CLASS TYPE) list."
  (tp--validate-selector selector)
  (pcase (car selector)
    (:id '(1 0 0))
    ((or :class :attr :state) '(0 1 0))
    (:type '(0 0 1))
    ((or :universal :where) '(0 0 0))
    (:and (tp--specificity-list-sum (cdr selector)))
    ((or :is :not)
     (tp--specificity-max (mapcar #'tp-selector-specificity
                                  (cdr selector))))
    ((or :descendant :child :adjacent :sibling)
     (tp--specificity-list-sum (cdr selector)))))

(defun tp--declaration-list-p (declarations)
  "Return non-nil when DECLARATIONS is an even property/value list."
  (and (listp declarations) (zerop (% (length declarations) 2))))

(defun tp--validate-declaration-property (property)
  "Return PROPERTY when it names a registered or custom property."
  (unless (or (tp--custom-property-p property)
              (gethash property tp--property-schemas))
    (signal 'tp-invalid-style (list :unknown-property property)))
  property)

(defun tp--unwrap-important (value)
  "Return VALUE and whether it carries an important tag."
  (if (tp--important-p value)
      (cons (tp--important-value value) t)
    (cons value nil)))

(defun tp--tag-expanded-important (declarations important)
  "Tag expanded DECLARATIONS as IMPORTANT when requested."
  (if (not important)
      declarations
    (cl-loop for (property value) on declarations by #'cddr
             append (list property (tp-important value)))))

(defun tp--expand-declaration (property value)
  "Expand one PROPERTY VALUE declaration into canonical longhands."
  (tp--validate-declaration-property property)
  (let ((schema (gethash property tp--property-schemas)))
    (if-let ((expander (and schema (tp-property-schema-shorthand schema))))
        (pcase-let* ((`(,raw . ,important) (tp--unwrap-important value))
                     (expanded (funcall expander raw)))
          (unless (tp--declaration-list-p expanded)
            (signal 'tp-invalid-style (list :shorthand property expanded)))
          (cl-loop for (longhand _value) on expanded by #'cddr
                   do (tp--validate-declaration-property longhand)
                   when (tp-property-schema-shorthand
                         (gethash longhand tp--property-schemas))
                   do (signal 'tp-invalid-style
                              (list :nested-shorthand property longhand)))
          (tp--tag-expanded-important expanded important))
      (list property value))))

(defun tp--expand-declarations (declarations)
  "Validate and expand DECLARATIONS into canonical longhands."
  (unless (tp--declaration-list-p declarations)
    (signal 'tp-invalid-style (list :declarations declarations)))
  (cl-loop for (property value) on declarations by #'cddr
           append (tp--expand-declaration property value)))

;;;###autoload
(defun tp-define-style (name declarations)
  "Define named style NAME from DECLARATIONS and return NAME."
  (unless (symbolp name)
    (signal 'tp-invalid-style (list :style-name name)))
  (let ((expanded (tp--expand-declarations declarations)))
    (puthash name (copy-tree expanded) tp--named-styles)
    name))

(defun tp-style-declarations (name)
  "Return a defensive copy of named style NAME declarations."
  (when-let ((declarations (gethash name tp--named-styles)))
    (copy-tree declarations)))

(defun tp--validate-rule-origin (origin)
  "Return ORIGIN when it is a registered cascade origin."
  (unless (memq origin tp--style-origin-order)
    (signal 'tp-invalid-style (list :origin origin)))
  origin)

(defun tp--register-cascade-layer (layer stylesheet)
  "Register LAYER in first-seen order for optional STYLESHEET.
Return LAYER's zero-based rank, or nil for an unlayered rule."
  (when layer
    (let ((layers (if stylesheet
                      (tp--stylesheet-layers stylesheet)
                    tp--cascade-layers)))
      (unless (memq layer layers)
        (setq layers (append layers (list layer)))
        (if stylesheet
            (setf (tp--stylesheet-layers stylesheet) layers)
          (setq tp--cascade-layers layers)))
      (cl-position layer layers))))

(defun tp--next-style-source-order (stylesheet)
  "Increment and return source order for optional STYLESHEET."
  (if stylesheet
      (cl-incf (tp--stylesheet-source-order stylesheet))
    (cl-incf tp--style-source-order)))

(defun tp--append-stylesheet-rule (rule stylesheet)
  "Append RULE to optional STYLESHEET and return RULE."
  (if stylesheet
      (setf (tp--stylesheet-rules stylesheet)
            (append (tp--stylesheet-rules stylesheet) (list rule)))
    (setq tp--stylesheet-rules
          (append tp--stylesheet-rules (list rule))))
  rule)

;;;###autoload
(cl-defun tp-stylesheet-add-rule
    (selector declarations &key (origin 'author) layer scope stylesheet)
  "Add a structured SELECTOR rule with DECLARATIONS.
ORIGIN defaults to `author'.  LAYER is ordered by first appearance.  SCOPE,
when non-nil, is a selector that must match the subject or an ancestor.
STYLESHEET isolates rules and layer order from TP's default stylesheet."
  (tp--validate-selector selector)
  (when scope (tp--validate-selector scope))
  (tp--validate-rule-origin origin)
  (when (and stylesheet (not (tp-stylesheet-p stylesheet)))
    (signal 'wrong-type-argument (list 'tp-stylesheet-p stylesheet)))
  (let* ((expanded (tp--expand-declarations declarations))
         (layer-rank (tp--register-cascade-layer layer stylesheet))
         (rule (tp--make-style-rule
                :selector (copy-tree selector)
                :declarations (copy-tree expanded)
                :origin origin :layer layer :layer-rank layer-rank
                :scope (copy-tree scope)
                :specificity (tp-selector-specificity selector)
                :source-order (tp--next-style-source-order stylesheet))))
    (tp--append-stylesheet-rule rule stylesheet)))

(defun tp--scope-distance (scope subject)
  "Return distance from SUBJECT to matching SCOPE, or nil."
  (if (null scope)
      most-positive-fixnum
    (cl-loop for current = subject then (tp-subject-parent current)
             for distance from 0
             while current
             when (tp-selector-match-p scope current) return distance)))

(defun tp--rule-matches-p (rule subject)
  "Return non-nil if RULE matches SUBJECT."
  (and (tp-selector-match-p (tp--style-rule-selector rule) subject)
       (numberp (tp--scope-distance (tp--style-rule-scope rule) subject))))

(defun tp--candidate-from-entry (rule property value subject declaration-order)
  "Create a candidate from RULE PROPERTY VALUE for SUBJECT.
DECLARATION-ORDER is the property's position within RULE."
  (pcase-let ((`(,raw . ,important) (tp--unwrap-important value)))
    (tp--make-candidate
     :property property :value raw
     :origin (tp--style-rule-origin rule) :important important
     :layer (tp--style-rule-layer rule)
     :layer-rank (tp--style-rule-layer-rank rule)
     :specificity (tp--style-rule-specificity rule)
     :scope-distance (tp--scope-distance (tp--style-rule-scope rule) subject)
     :source-order (tp--style-rule-source-order rule)
     :declaration-order declaration-order
     :selector (tp--style-rule-selector rule))))

(defun tp--rule-candidates (rule subject)
  "Return all property candidates from matching RULE for SUBJECT."
  (when (tp--rule-matches-p rule subject)
    (cl-loop for (property value) on (tp--style-rule-declarations rule)
             by #'cddr
             for declaration-order from 0
             collect (tp--candidate-from-entry
                      rule property value subject declaration-order))))

(defun tp--inline-candidates (declarations)
  "Return inline candidates for DECLARATIONS."
  (when declarations
    (cl-loop for (property value) on (tp--expand-declarations declarations)
             by #'cddr
             for declaration-order from 0
             collect
             (pcase-let ((`(,raw . ,important) (tp--unwrap-important value)))
               (tp--make-candidate
                :property property :value raw :origin 'inline
                :important important :layer nil :layer-rank nil
                :specificity '(1 0 0)
                :scope-distance most-positive-fixnum
                :source-order (1+ tp--style-source-order)
                :declaration-order declaration-order
                :selector :inline)))))

(defun tp--collect-candidates (subject declarations rules)
  "Collect matching candidates for SUBJECT, DECLARATIONS, and RULES."
  (append
   (cl-loop for rule in rules append (tp--rule-candidates rule subject))
   (tp--inline-candidates declarations)))

(defun tp--specificity-greater-p (left right)
  "Return non-nil when specificity LEFT is greater than RIGHT."
  (catch 'result
    (cl-mapc (lambda (a b)
               (cond ((> a b) (throw 'result t))
                     ((< a b) (throw 'result nil))))
             left right)
    nil))

(defun tp--origin-rank (origin)
  "Return precedence rank for ORIGIN."
  (or (cl-position origin tp--style-origin-order) -1))

(defun tp--layer-rank (candidate)
  "Return cascade layer rank for CANDIDATE."
  (let ((layer (tp--candidate-layer candidate))
        (rank (tp--candidate-layer-rank candidate))
        (important (tp--candidate-important candidate)))
    (cond
     ((and important (null layer)) -1000000)
     ((null layer) 1000000)
     (important (- (or rank 0)))
     (t (or rank 0)))))

(defun tp--compare-number (left right)
  "Compare LEFT and RIGHT, returning 1, -1, or 0."
  (cond ((> left right) 1) ((< left right) -1) (t 0)))

(defun tp--candidate-ranks (candidate)
  "Return ordered scalar ranks for CANDIDATE."
  (list (if (tp--candidate-important candidate) 1 0)
        (tp--origin-rank (tp--candidate-origin candidate))
        (tp--layer-rank candidate)))

(defun tp--rank-list-comparison (left right)
  "Compare numeric rank lists LEFT and RIGHT."
  (catch 'comparison
    (cl-mapc (lambda (a b)
               (let ((value (tp--compare-number a b)))
                 (unless (zerop value) (throw 'comparison value))))
             left right)
    0))

(defun tp--candidate-higher-p (left right)
  "Return non-nil when candidate LEFT outranks RIGHT."
  (let ((rank (tp--rank-list-comparison
               (tp--candidate-ranks left) (tp--candidate-ranks right))))
    (cond
     ((not (zerop rank)) (> rank 0))
     ((not (equal (tp--candidate-specificity left)
                  (tp--candidate-specificity right)))
      (tp--specificity-greater-p (tp--candidate-specificity left)
                                 (tp--candidate-specificity right)))
     ((/= (tp--candidate-scope-distance left)
          (tp--candidate-scope-distance right))
      (< (tp--candidate-scope-distance left)
         (tp--candidate-scope-distance right)))
     ((/= (tp--candidate-source-order left)
          (tp--candidate-source-order right))
      (> (tp--candidate-source-order left)
         (tp--candidate-source-order right)))
     (t (> (tp--candidate-declaration-order left)
           (tp--candidate-declaration-order right))))))

(defun tp--group-candidates (candidates)
  "Group CANDIDATES by property in a hash table."
  (let ((table (make-hash-table :test #'eq)))
    (dolist (candidate candidates)
      (let ((property (tp--candidate-property candidate)))
        (puthash property (cons candidate (gethash property table)) table)))
    (maphash (lambda (property values)
               (puthash property
                        (sort values #'tp--candidate-higher-p) table))
             table)
    table))

(defun tp--skip-reverted-origin (candidates winner)
  "Remove WINNER's origin and importance group from CANDIDATES."
  (seq-remove
   (lambda (candidate)
     (and (eq (tp--candidate-origin candidate)
              (tp--candidate-origin winner))
          (eq (tp--candidate-important candidate)
              (tp--candidate-important winner))))
   candidates))

(defun tp--skip-reverted-layer (candidates winner)
  "Remove WINNER's layer group from CANDIDATES."
  (seq-remove
   (lambda (candidate)
     (and (eq (tp--candidate-origin candidate)
              (tp--candidate-origin winner))
          (eq (tp--candidate-important candidate)
              (tp--candidate-important winner))
          (eq (tp--candidate-layer candidate)
              (tp--candidate-layer winner))))
   candidates))

(defun tp--evaluate-computed-source (value)
  "Evaluate VALUE only when it is an explicit computed source."
  (if (tp--computed-source-p value)
      (funcall (tp--computed-source-function value))
    value))

(defun tp--parent-values (parent-style)
  "Return computed values plist from PARENT-STYLE."
  (cond ((tp-computed-style-p parent-style)
         (tp-computed-style-values parent-style))
        ((listp parent-style) parent-style)
        (t nil)))

(defun tp--parent-custom-properties (parent-style)
  "Return custom property plist from PARENT-STYLE."
  (when (tp-computed-style-p parent-style)
    (tp-computed-style-custom-properties parent-style)))

(defun tp--parent-property-active-p (parent-style property)
  "Return non-nil when PARENT-STYLE actively contributes PROPERTY."
  (cond
   ((tp-computed-style-p parent-style)
    (memq property (tp-computed-style-active-properties parent-style)))
   ((listp parent-style) (and (plist-member parent-style property) t))))

(defun tp--property-default-value (schema parent-style)
  "Return SCHEMA's inherited or initial value using PARENT-STYLE."
  (let* ((property (tp-property-schema-id schema))
         (parent-values (tp--parent-values parent-style)))
    (if (and (tp-property-schema-inherits schema)
             (plist-member parent-values property))
        (plist-get parent-values property)
      (tp-property-schema-initial schema))))

(defun tp--wide-default-value (wide schema parent-style)
  "Resolve non-revert WIDE value for SCHEMA using PARENT-STYLE."
  (pcase (tp--wide-kind wide)
    ('initial (tp-property-schema-initial schema))
    ('inherit
     (let ((values (tp--parent-values parent-style))
           (property (tp-property-schema-id schema)))
       (if (plist-member values property)
           (plist-get values property)
         (tp-property-schema-initial schema))))
    ('unset (if (tp-property-schema-inherits schema)
                (tp--wide-default-value (tp-wide-value 'inherit)
                                        schema parent-style)
              (tp-property-schema-initial schema)))))

(defun tp--custom-raw-table (candidate-table parent-style)
  "Build raw custom properties from CANDIDATE-TABLE and PARENT-STYLE."
  (let ((table (make-hash-table :test #'eq)))
    (cl-loop for (property value) on (tp--parent-custom-properties parent-style)
             by #'cddr do (puthash property value table))
    (maphash
     (lambda (property candidates)
       (when (tp--custom-property-p property)
         (let ((selected (tp--select-custom-candidate candidates table)))
           (if (eq selected tp--style-absent)
               (remhash property table)
             (puthash property selected table)))))
     candidate-table)
    table))

(defun tp--select-custom-candidate (candidates inherited-table)
  "Select raw custom value from CANDIDATES and INHERITED-TABLE."
  (let ((remaining candidates) selected done)
    (while (and remaining (not done))
      (let* ((candidate (pop remaining))
             (value (tp--evaluate-computed-source
                     (tp--candidate-value candidate))))
        (if (not (tp--wide-p value))
            (setq selected value done t)
          (pcase (tp--wide-kind value)
            ('revert (setq remaining
                           (tp--skip-reverted-origin remaining candidate)))
            ('revert-layer (setq remaining
                                 (tp--skip-reverted-layer remaining candidate)))
            ((or 'inherit 'unset)
             (let ((old (gethash (tp--candidate-property candidate)
                                 inherited-table tp--style-absent)))
               (setq selected old done t)))
            ('initial (setq selected tp--style-absent done t))))))
    (if done selected
      (gethash (tp--candidate-property (car candidates))
               inherited-table tp--style-absent))))

(defun tp--resolve-var-fallback (reference raw resolved stack)
  "Resolve REFERENCE fallback using RAW, RESOLVED, and STACK."
  (if (tp--var-ref-fallback-present-p reference)
      (tp--resolve-variable-value (tp--var-ref-fallback reference)
                                  raw resolved stack)
    tp--style-invalid))

(defun tp--resolve-custom-property (name raw resolved stack)
  "Resolve custom property NAME using RAW, RESOLVED, and STACK."
  (let ((memo (gethash name resolved tp--style-absent)))
    (cond
     ((not (eq memo tp--style-absent)) memo)
     ((memq name stack) tp--style-invalid)
     (t
      (let ((value (gethash name raw tp--style-absent)))
        (if (eq value tp--style-absent)
            tp--style-invalid
          (let ((answer (tp--resolve-variable-value
                         value raw resolved (cons name stack))))
            (puthash name answer resolved)
            answer)))))))

(defun tp--resolve-variable-value (value raw resolved stack)
  "Resolve custom references in VALUE using RAW, RESOLVED, and STACK."
  (if (not (tp--var-ref-p value))
      value
    (let ((answer (tp--resolve-custom-property
                   (tp--var-ref-name value) raw resolved stack)))
      (if (eq answer tp--style-invalid)
          (tp--resolve-var-fallback value raw resolved stack)
        answer))))

(defun tp--resolved-custom-properties (raw)
  "Return resolved custom properties plist from RAW table."
  (let ((resolved (make-hash-table :test #'eq)) names result)
    (maphash
     (lambda (name _value) (push name names)) raw)
    (dolist (name (sort names
                        (lambda (left right)
                          (string< (symbol-name left) (symbol-name right)))))
      (let ((value (tp--resolve-custom-property name raw resolved nil)))
        (unless (eq value tp--style-invalid)
          (setq result (plist-put result name value)))))
    result))

(defun tp--resolve-property-value (value schema parent-style custom)
  "Resolve VALUE for SCHEMA using PARENT-STYLE and CUSTOM properties."
  (setq value (tp--evaluate-computed-source value))
  (cond
   ((and (tp--wide-p value)
         (memq (tp--wide-kind value) '(initial inherit unset)))
    (tp--wide-default-value value schema parent-style))
   ((tp--var-ref-p value)
    (let ((raw (make-hash-table :test #'eq))
          (resolved (make-hash-table :test #'eq)))
      (cl-loop for (name item) on custom by #'cddr
               do (puthash name item raw))
      (tp--resolve-variable-value value raw resolved nil)))
   (t value)))

(defun tp--normalize-property-value (schema value)
  "Normalize and validate VALUE for SCHEMA, or return invalid sentinel."
  (if (eq value tp--style-invalid)
      value
    (let ((normalized (funcall (tp-property-schema-normalizer schema) value)))
      (if (funcall (tp-property-schema-validator schema) normalized)
          normalized
        tp--style-invalid))))

(defun tp--property-candidate-value (candidate schema parent-style custom)
  "Resolve CANDIDATE for SCHEMA using PARENT-STYLE and CUSTOM."
  (tp--normalize-property-value
   schema
   (tp--resolve-property-value (tp--candidate-value candidate)
                               schema parent-style custom)))

(defun tp--candidate-provenance (candidate)
  "Return public provenance plist for CANDIDATE."
  (if (null candidate)
      '(:selector :initial :origin default)
    (list :selector (copy-tree (tp--candidate-selector candidate))
          :origin (tp--candidate-origin candidate)
          :important (and (tp--candidate-important candidate) t)
          :layer (tp--candidate-layer candidate)
          :specificity (copy-sequence (tp--candidate-specificity candidate))
          :scope-distance (tp--candidate-scope-distance candidate)
          :source-order (tp--candidate-source-order candidate)
          :declaration-order (tp--candidate-declaration-order candidate))))

(defun tp--resolve-property-candidates (schema candidates parent-style custom)
  "Resolve SCHEMA from ordered CANDIDATES, PARENT-STYLE, and CUSTOM."
  (let ((remaining candidates) winner value)
    (while (and remaining (null winner))
      (let* ((candidate (pop remaining))
             (raw (tp--evaluate-computed-source
                   (tp--candidate-value candidate))))
        (cond
         ((and (tp--wide-p raw) (eq (tp--wide-kind raw) 'revert))
          (setq remaining (tp--skip-reverted-origin remaining candidate)))
         ((and (tp--wide-p raw) (eq (tp--wide-kind raw) 'revert-layer))
          (setq remaining (tp--skip-reverted-layer remaining candidate)))
         (t
          (setf (tp--candidate-value candidate) raw)
          (setq winner candidate
                value (tp--property-candidate-value
                       candidate schema parent-style custom))))))
    (unless winner
      (setq value (tp--normalize-property-value
                   schema (tp--property-default-value schema parent-style))))
    (when (eq value tp--style-invalid)
      (setq value (tp--normalize-property-value
                   schema (tp--property-default-value schema parent-style))))
    (cons value winner)))

(defun tp--compute-property-values (candidate-table parent-style custom provenance-p)
  "Compute values from CANDIDATE-TABLE, PARENT-STYLE, and CUSTOM.
When PROVENANCE-P is non-nil, also retain winning declaration facts."
  (let (values active provenance)
    (dolist (property tp--property-schema-order)
      (let ((schema (gethash property tp--property-schemas)))
        (unless (tp-property-schema-shorthand schema)
          (pcase-let ((`(,value . ,winner)
                       (tp--resolve-property-candidates
                        schema (gethash property candidate-table)
                        parent-style custom)))
            (setq values (plist-put values property value))
            (when (or winner value
                      (and (tp-property-schema-inherits schema)
                           (tp--parent-property-active-p
                            parent-style property)))
              (push property active))
            (when provenance-p
              (setq provenance
                    (plist-put provenance property
                               (tp--candidate-provenance winner))))))))
    (list values (nreverse active) provenance)))

;;;###autoload
(cl-defun tp-compute-style
    (subject &key declarations (rules tp--style-all-rules)
             parent-style provenance)
  "Compute a deterministic style for SUBJECT.
DECLARATIONS are inline values.  RULES defaults to the registered stylesheet;
an isolated stylesheet instance selects only its rules, and explicit nil
disables stylesheet rules.  PARENT-STYLE may be a computed style or values
plist.  When PROVENANCE is non-nil, winner metadata is retained."
  (unless (tp-subject-p subject)
    (signal 'wrong-type-argument (list 'tp-subject-p subject)))
  (let* ((active-rules (if (eq rules tp--style-all-rules)
                           tp--stylesheet-rules
                         (if (tp-stylesheet-p rules)
                             (tp--stylesheet-rules rules)
                           rules)))
         (candidate-table
          (tp--group-candidates
           (tp--collect-candidates subject declarations active-rules)))
         (raw-custom (tp--custom-raw-table candidate-table parent-style))
         (custom (tp--resolved-custom-properties raw-custom)))
    (pcase-let ((`(,values ,active ,facts)
                 (tp--compute-property-values
                  candidate-table parent-style custom provenance)))
      (tp--make-computed-style
       :values values :custom-properties custom
       :active-properties active :provenance facts))))

(defun tp--projected-value (schema values active)
  "Project SCHEMA from computed VALUES when its PROPERTY is ACTIVE."
  (when-let ((projector (tp-property-schema-projector schema)))
    (let* ((property (tp-property-schema-id schema))
           (value (plist-get values property)))
      (when (or value (memq property active))
        (funcall projector value)))))

;;;###autoload
(defun tp-project-style (style)
  "Project computed STYLE into final direct Emacs text properties."
  (unless (tp-computed-style-p style)
    (signal 'wrong-type-argument (list 'tp-computed-style-p style)))
  (let ((values (tp-computed-style-values style))
        (active (tp-computed-style-active-properties style))
        result)
    (dolist (property tp--property-schema-order)
      (let* ((schema (gethash property tp--property-schemas))
             (projected (and (not (tp-property-schema-shorthand schema))
                             (tp--projected-value schema values active))))
        (when projected
          (unless (tp--declaration-list-p projected)
            (signal 'tp-invalid-style (list :projection property projected)))
          (setq result (tp--deep-merge-plist result projected)))))
    result))

(defun tp--project-text-declarations (declarations)
  "Project native text property DECLARATIONS through the style core."
  (tp-project-style
   (tp-compute-style
    (tp-subject-create :type 'text)
    :declarations (tp-text-declarations declarations)
    :rules nil)))

(tp--register-default-text-properties)

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