234 lines
9.2 KiB
EmacsLisp
234 lines
9.2 KiB
EmacsLisp
;;; ebox-patch-plan.el --- Pure Ebox patch artifact planning -*- lexical-binding: t; -*-
|
|
|
|
;; SPDX-License-Identifier: GPL-3.0-or-later
|
|
|
|
;;; Commentary:
|
|
|
|
;; Reduces tentative patch operations into one deterministic antichain. The
|
|
;; planner consumes only operation plists and an immutable node parent table;
|
|
;; it does not read a buffer, call a surface, or publish an artifact.
|
|
|
|
;;; Code:
|
|
|
|
(require 'cl-lib)
|
|
(require 'subr-x)
|
|
(require 'ebox-runtime-index)
|
|
|
|
(define-error 'ebox-patch-plan-error "Invalid Ebox patch plan input")
|
|
|
|
(defconst ebox-patch-plan--dirty-kind-order
|
|
'(paint span geometry placement structure)
|
|
"Dirty kinds ordered from cheapest to most disruptive.")
|
|
|
|
(defun ebox-patch-plan--operation-strength (strategy)
|
|
"Return structural dominance strength for patch STRATEGY."
|
|
(pcase strategy
|
|
('native-frame 4)
|
|
('owner-rerender 3)
|
|
('span-patch 2)
|
|
('paint-patch 1)
|
|
((or 'child-splice 'child-reorder) 0)
|
|
(_ 0)))
|
|
|
|
(defun ebox-patch-plan--dirty-kind-strength (kind)
|
|
"Return relative disruption strength for dirty KIND."
|
|
(or (cl-position kind ebox-patch-plan--dirty-kind-order) -1))
|
|
|
|
(defun ebox-patch-plan--dirty-node-ids (dirty)
|
|
"Return distinct source node ids recorded by DIRTY."
|
|
(delete-dups
|
|
(append (when-let* ((node-id (plist-get dirty :node-id)))
|
|
(list node-id))
|
|
(copy-sequence (or (plist-get dirty :node-ids) nil)))))
|
|
|
|
(defun ebox-patch-plan--merge-dirty (primary secondary)
|
|
"Merge SECONDARY dirty provenance into PRIMARY without mutating either."
|
|
(cond
|
|
((null primary) (copy-sequence secondary))
|
|
((null secondary) (copy-sequence primary))
|
|
(t
|
|
(let ((merged (copy-sequence primary)))
|
|
(setq merged
|
|
(plist-put
|
|
merged :node-ids
|
|
(delete-dups
|
|
(append (ebox-patch-plan--dirty-node-ids primary)
|
|
(ebox-patch-plan--dirty-node-ids secondary)))))
|
|
(dolist (key '(:changed-keys :region-ids :old-region-ids
|
|
:new-region-ids :impact-vector))
|
|
(setq merged
|
|
(plist-put
|
|
merged key
|
|
(delete-dups
|
|
(append (copy-sequence (or (plist-get primary key) nil))
|
|
(copy-sequence
|
|
(or (plist-get secondary key) nil)))))))
|
|
(when (or (plist-get primary :requires-owned-overflow-coverage)
|
|
(plist-get secondary :requires-owned-overflow-coverage))
|
|
(setq merged
|
|
(plist-put merged :requires-owned-overflow-coverage t)))
|
|
(when (> (ebox-patch-plan--dirty-kind-strength
|
|
(plist-get secondary :dirty-kind))
|
|
(ebox-patch-plan--dirty-kind-strength
|
|
(plist-get primary :dirty-kind)))
|
|
(setq merged
|
|
(plist-put merged :dirty-kind
|
|
(plist-get secondary :dirty-kind))))
|
|
merged))))
|
|
|
|
(defun ebox-patch-plan--merge-op-dirty (op absorbed)
|
|
"Return OP with ABSORBED's dirty provenance merged into a fresh plist."
|
|
(let ((merged (copy-sequence op)))
|
|
(plist-put merged :dirty
|
|
(ebox-patch-plan--merge-dirty
|
|
(plist-get op :dirty)
|
|
(plist-get absorbed :dirty)))))
|
|
|
|
(defun ebox-patch-plan--merge-same-owner (left right)
|
|
"Return the stronger same-owner op with merged dirty provenance."
|
|
(let* ((left-strength
|
|
(ebox-patch-plan--operation-strength (plist-get left :op)))
|
|
(right-strength
|
|
(ebox-patch-plan--operation-strength (plist-get right :op)))
|
|
(left-dirty-strength
|
|
(ebox-patch-plan--dirty-kind-strength
|
|
(plist-get (plist-get left :dirty) :dirty-kind)))
|
|
(right-dirty-strength
|
|
(ebox-patch-plan--dirty-kind-strength
|
|
(plist-get (plist-get right :dirty) :dirty-kind)))
|
|
(left-wins
|
|
(or (> left-strength right-strength)
|
|
(and (= left-strength right-strength)
|
|
(>= left-dirty-strength right-dirty-strength))))
|
|
(winner (if left-wins left right))
|
|
(loser (if left-wins right left)))
|
|
(ebox-patch-plan--merge-op-dirty winner loser)))
|
|
|
|
(defun ebox-patch-plan--validate-op (op)
|
|
"Signal unless OP is one complete tentative patch artifact."
|
|
(unless (and (proper-list-p op)
|
|
(plist-member op :op)
|
|
(plist-member op :owner-id))
|
|
(signal 'ebox-patch-plan-error (list :malformed-operation op)))
|
|
op)
|
|
|
|
(defun ebox-patch-plan--ancestor-set (parent-table owner-id)
|
|
"Return OWNER-ID's strict ancestors from immutable PARENT-TABLE."
|
|
(let ((ancestors (make-hash-table :test #'equal))
|
|
(seen (make-hash-table :test #'equal))
|
|
(walk (ebox-runtime-index-get owner-id parent-table)))
|
|
(while walk
|
|
(when (gethash walk seen)
|
|
(signal 'ebox-patch-plan-error
|
|
(list :cyclic-parent-table :node-id walk)))
|
|
(puthash walk t seen)
|
|
(puthash walk t ancestors)
|
|
(setq walk (ebox-runtime-index-get walk parent-table)))
|
|
ancestors))
|
|
|
|
(defun ebox-patch-plan--make-index ()
|
|
"Return fresh planner-local antichain merge state."
|
|
(list :owner-table (make-hash-table :test #'equal)
|
|
:ancestor-table (make-hash-table :test #'equal)
|
|
:serial 0))
|
|
|
|
(defun ebox-patch-plan--index-insert (index entry)
|
|
"Register planner ENTRY in INDEX."
|
|
(puthash (plist-get (aref entry 0) :owner-id)
|
|
entry (plist-get index :owner-table))
|
|
(let ((ancestor-table (plist-get index :ancestor-table)))
|
|
(maphash
|
|
(lambda (ancestor-id _present)
|
|
(push entry (gethash ancestor-id ancestor-table)))
|
|
(aref entry 2))))
|
|
|
|
(defun ebox-patch-plan--index-remove (index entry)
|
|
"Remove planner ENTRY from INDEX."
|
|
(remhash (plist-get (aref entry 0) :owner-id)
|
|
(plist-get index :owner-table))
|
|
(let ((ancestor-table (plist-get index :ancestor-table)))
|
|
(maphash
|
|
(lambda (ancestor-id _present)
|
|
(puthash ancestor-id
|
|
(delq entry (gethash ancestor-id ancestor-table))
|
|
ancestor-table))
|
|
(aref entry 2))))
|
|
|
|
(defun ebox-patch-plan--index-add (parent-table index candidate)
|
|
"Merge CANDIDATE into INDEX using immutable PARENT-TABLE ancestry."
|
|
(setq candidate (ebox-patch-plan--validate-op candidate))
|
|
(let* ((owner-table (plist-get index :owner-table))
|
|
(owner-id (plist-get candidate :owner-id))
|
|
(same-owner (gethash owner-id owner-table)))
|
|
(when same-owner
|
|
(setq candidate
|
|
(ebox-patch-plan--merge-same-owner
|
|
(aref same-owner 0) candidate))
|
|
(ebox-patch-plan--index-remove index same-owner))
|
|
(let* ((ancestors
|
|
(ebox-patch-plan--ancestor-set parent-table owner-id))
|
|
dominator)
|
|
(maphash
|
|
(lambda (ancestor-id _present)
|
|
(when-let* ((entry (gethash ancestor-id owner-table)))
|
|
(when (and (>= (ebox-patch-plan--operation-strength
|
|
(plist-get (aref entry 0) :op))
|
|
(ebox-patch-plan--operation-strength 'span-patch))
|
|
(or (null dominator)
|
|
(< (aref entry 1) (aref dominator 1))))
|
|
(setq dominator entry))))
|
|
ancestors)
|
|
(if dominator
|
|
(aset dominator 0
|
|
(ebox-patch-plan--merge-op-dirty
|
|
(aref dominator 0) candidate))
|
|
(when (>= (ebox-patch-plan--operation-strength
|
|
(plist-get candidate :op))
|
|
(ebox-patch-plan--operation-strength 'span-patch))
|
|
(dolist (entry
|
|
(sort
|
|
(copy-sequence
|
|
(gethash owner-id (plist-get index :ancestor-table)))
|
|
(lambda (left right)
|
|
(< (aref left 1) (aref right 1)))))
|
|
(setq candidate
|
|
(ebox-patch-plan--merge-op-dirty
|
|
candidate (aref entry 0)))
|
|
(ebox-patch-plan--index-remove index entry)))
|
|
(let ((entry (vector candidate
|
|
(plist-get index :serial)
|
|
ancestors)))
|
|
(plist-put index :serial (1+ (plist-get index :serial)))
|
|
(ebox-patch-plan--index-insert index entry))))))
|
|
|
|
(defun ebox-patch-plan--index-result (index)
|
|
"Return INDEX's surviving operations in stable insertion order."
|
|
(let (entries)
|
|
(maphash (lambda (_owner-id entry) (push entry entries))
|
|
(plist-get index :owner-table))
|
|
(mapcar (lambda (entry) (aref entry 0))
|
|
(sort entries
|
|
(lambda (left right)
|
|
(< (aref left 1) (aref right 1)))))))
|
|
|
|
(defun ebox-patch-plan-merge-ops (parent-table operations)
|
|
"Return the pure deterministic antichain for tentative OPERATIONS.
|
|
|
|
PARENT-TABLE maps a node id to its parent id and is treated as immutable.
|
|
OPERATIONS are patch artifact plists. This function mutates neither input and
|
|
has no publication capability."
|
|
(unless (ebox-runtime-index-like-p parent-table)
|
|
(signal 'ebox-patch-plan-error
|
|
(list :malformed-parent-table parent-table)))
|
|
(unless (proper-list-p operations)
|
|
(signal 'ebox-patch-plan-error
|
|
(list :malformed-operations operations)))
|
|
(let ((index (ebox-patch-plan--make-index)))
|
|
(dolist (operation operations)
|
|
(ebox-patch-plan--index-add parent-table index operation))
|
|
(ebox-patch-plan--index-result index)))
|
|
|
|
(provide 'ebox-patch-plan)
|
|
|
|
;;; ebox-patch-plan.el ends here
|