github/penpot
1
0
Fork 0
mirror of https://github.com/penpot/penpot.git synced 2026-10-29 22:10:34 +00:00
Code Issues Packages Projects Releases Wiki Activity

✨ Retrofit the overlay: rules, resolved refs, intervals, tokens

Browse Source 
Four architectural results of the 2026-08-20 study become structure
(docs.local/graph/20260820-report-graph-overlay-datascript.md):

The relation vocabulary is a rule set, not raw clauses: child-of,
descendant-of, instance-of, refers-to, fills-swap-slot and uses-token
are named once in app.graph.overlay.queries, and every consumer query
and backported beadpot assertion traverses relations through them, so
an encoding can change under a rule without a consumer moving.

The subtle helpers run in the builder, never in a query:
ctf/find-ref-shape is called once per copy shape at build time and its
answer is the plain :shape/refers-to reference. The sync path
re-resolves the affected set when resolution inputs change: the shape
on :shape-ref, the subtree on head attributes and reparents, every
instance subtree of a component whose record or copy moved.

Containment carries a second form: one global Euler-tour numbering,
one DFS per container from a single global counter, so "inside subtree
X" is two interval comparisons. Per-container counters are the bug the
suite pins against: ranges would overlap numerically across pages.
The sync path renumbers a container from beyond the global maximum;
interval containment, not the numbers, is the invariant.

Token applications fold the property into the attribute name:
{:token/fill "layerTwo.background"} over the closed vocabulary of
app.common.types.token/all-keys, behind the uses-token rule so the
choice stays reversible. The relation-entity encoding and its two
extra datoms per application are gone.

31 tests, 650 assertions, 0 failures across the three suites.

AI-assisted-by: claude-fable-5
This commit is contained in:
Álvaro Tejero Cantero 2026-08-21 04:05:48 +02:00
parent 1fe5215d12
commit 7185fcee64
No known key found for this signature in database
7 changed files with 1030 additions and 388 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
backend/src/app/graph/debug.clj
View File

@ -42,7 +42,7 @@
" ?filter_src_id ?filter_tgt_id\n"
" :in $ %\n"
" :where\n"
" (is-instance-of ?s ?c)\n"
" (instance-of ?s ?c)\n"
" [?c :component/name ?component]\n"
" [?s :shape/name ?instance]\n"
" [?s :shape/container ?pc]\n"
@ -270,14 +270,16 @@
db queries/rules)))
(defn- token-use-edges
"UsesToken edges from the folded token attributes, joined to token
entities by name (one edge per matching token when names repeat across
sets, the same join the `uses-token` rule performs)."
[db]
(keep (fn [dtm]
(let [e (d/entity db (:e dtm))]
(when-let [token (:token-use/token e)]
{:source (str (:db/id (:token-use/shape e)))
:target (str (:db/id token))
:rel "UsesToken"})))
(d/datoms db :avet :token-use/shape)))
(for [attr overlay/token-attrs
dtm (d/datoms db :aevt attr)
token (map :e (d/datoms db :avet :token/name (:v dtm)))]
{:source (str (:e dtm))
:target (str token)
:rel "UsesToken"}))
(defn export-graph-data!
"Export the node/edge inventory of the overlay for `profile-id` as plain
@ -298,7 +300,7 @@
(into (ref-edges db :typography/document "IsChildOf"))
(into (ref-edges db :token-set/document "IsChildOf"))
(into (ref-edges db :token/set "IsChildOf"))
(into (rule-edges db 'is-instance-of "IsInstanceOf"))
(into (rule-edges db 'instance-of "IsInstanceOf"))
(into (rule-edges db 'refers-to "RefersTo"))
(into (rule-edges db 'fills-swap-slot "FillsSwapSlot"))
(into (ref-edges db :shape/fill-color "UsesColor"))

298
backend/src/app/graph/overlay.clj
View File

@ -24,17 +24,54 @@
parent links are datascript entity references, so topology is interned
by construction.
Three results of the 2026-08-20 study are structural here
(docs.local/graph/20260820-report-graph-overlay-datascript.md):
- **Subtle helpers run in the builder, never in a query.**
`ctf/find-ref-shape` is called once per copy shape at build time and
its answer becomes the plain `:shape/refers-to` reference; a query
never touches the helper. Unresolvable references (libraries not
loaded) simply produce no edge.
- **Containment carries a second form**: one global Euler-tour
numbering, one DFS per container drawing from a single global
counter, so `inside subtree X` is two interval comparisons. The
counter is global because per-container counters overlap numerically
and silently match other pages.
- **Token applications fold the property into the attribute name**:
`{:token/fill \"layerTwo.background\"}` on the shape itself, over the
closed vocabulary of `app.common.types.token/all-keys`. The
`uses-token` rule in `app.graph.overlay.queries` hides the encoding,
so the choice stays reversible.
The namespace is deliberately JVM-free (no imports, no interop): the
same code moves to the browser worker as a `.cljc` rename when the
mirror experiment lands, which is the point of choosing datascript."
(:require
[app.common.types.text :as txt]
[app.common.types.component :as ctk]
[app.common.types.container :as ctn]
[app.common.types.file :as ctf]
[app.common.types.text :as txt]
[app.common.types.token :as cto]
[app.common.types.tokens-lib :as ctob]
[datascript.core :as d]))
(def schema-version
"penpot-graph-overlay-1")
"penpot-graph-overlay-2")
(def token-attr
"The overlay attribute carrying one applied-token property:
`:fill` -> `:token/fill`."
(into {} (map (fn [k] [k (keyword "token" (name k))])) cto/all-keys))
(def token-attrs
"The closed folded-token vocabulary, one attribute per applied-token
property of `app.common.types.token/all-keys`."
(into #{} (vals token-attr)))
(defn token-attr->prop
"`:token/fill` -> `:fill`."
[attr]
(keyword (name attr)))
(def schema
"Only identity, type, topology, and the attributes a standing query has
@ -45,7 +82,8 @@
rather than as one union, because the sync path receives `:set` ops one
attribute at a time and must be able to rebuild each contribution
independently. The `uses-color` rule in `app.graph.overlay.queries`
reunites them."
reunites them. Folded token attributes (`:token/fill`, ...) are plain
string values and need no declaration."
{;; document
:document/id {:db/unique :db.unique/identity}
;; containers: pages, and components that carry their own :objects
@ -60,6 +98,11 @@
:shape/component-file {:db/index true}
:shape/shape-ref {:db/index true}
:shape/swap-slot {:db/index true}
;; the builder-resolved reference edge: ctf/find-ref-shape's answer
:shape/refers-to {:db/valueType :db.type/ref}
;; global Euler-tour containment intervals
:shape/enter {:db/index true}
:shape/exit {:db/index true}
;; asset links (the beadpot ledger's asset link transforms)
:shape/fill-color {:db/valueType :db.type/ref
:db/cardinality :db.cardinality/many}
@ -81,11 +124,7 @@
:token-set/document {:db/valueType :db.type/ref}
:token/id {:db/unique :db.unique/identity}
:token/name {:db/index true}
:token/set {:db/valueType :db.type/ref}
;; applied tokens: one entity per (shape, property, token), because an
;; edge with a payload needs a relation entity in a triple store
:token-use/shape {:db/valueType :db.type/ref}
:token-use/token {:db/valueType :db.type/ref}})
:token/set {:db/valueType :db.type/ref}})
(def shape-type->table
"The Ladybug projection's node table names, kept for parity counting and
@ -152,14 +191,7 @@
(into #{} (keep :typography-ref-id) (some-> content txt/node-seq)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; entity construction
;;
;; `asset-ctx` abstracts over build and sync: `:colors`, `:typographies`
;; map locally defined asset ids to entity references (string tempids at
;; build time, resolved eids at sync time), and `:tokens-by-name` maps a
;; token name to the references of every token carrying it. Only
;; resolvable references become edges, mirroring beadpot's `node_exists`
;; guard.
;; Euler-tour numbering
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- resolvable-parent?
@ -169,8 +201,64 @@
(not= parent-id (:id shape))
(contains? objects parent-id))))
(defn euler-numbering
"Euler-tour intervals for one container's `:objects`, drawn from the
global `counter`: a DFS from the container roots in stored child order,
then a degenerate interval for any shape the tree cannot reach, so the
whole map stays indexed. Returns [{shape-id [enter exit]} counter'].
The counter is global across containers on purpose: per-container
counters produce numerically overlapping ranges, and an interval query
would silently match shapes of other pages."
[objects counter]
(let [roots (into []
(comp (filter #(not (resolvable-parent? objects %)))
(map :id))
(vals objects))]
(loop [events (into [] (map (fn [id] [:enter id])) roots)
counter (long counter)
acc (transient {})]
(if-let [[kind id] (peek events)]
(let [events (pop events)]
(case kind
:enter
(let [children (into []
(filter #(contains? objects %))
(get-in objects [id :shapes]))]
(recur (-> events
(conj [:exit id])
(into (map (fn [c] [:enter c])) (rseq children)))
(inc counter)
(assoc! acc id [counter nil])))
:exit
(recur events
(inc counter)
(assoc! acc id (assoc (get acc id) 1 counter)))))
(let [walked (persistent! acc)
;; degenerate intervals for orphans the tree cannot reach
[walked counter]
(reduce (fn [[m c] id]
(if (contains? m id)
[m c]
[(assoc m id [c (inc c)]) (+ c 2)]))
[walked counter]
(keys objects))]
[walked counter])))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; entity construction
;;
;; `build-ctx` carries the resolution state of one build: `:colors` and
;; `:typographies` map locally defined asset ids to entity references
;; (string tempids at build time, resolved eids on the sync path);
;; `:resolve-ref` answers a shape's `:shape-ref` with the reference of
;; the shape `ctf/find-ref-shape` names, or nil; `:numbering` maps a
;; shape id to its Euler interval within the current container.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn shape-asset-attrs
"The asset-edge attributes of one shape, resolved through `asset-ctx`."
"The asset-edge attributes of one shape, resolved through the ctx."
[shape {:keys [colors typographies]}]
(let [ref-vals (fn [m ids] (into [] (keep m) ids))
fills (ref-vals colors (fill-color-ref-ids (:fills shape)))
@ -184,11 +272,25 @@
(seq text) (assoc :shape/text-color text)
(seq typs) (assoc :shape/uses-typography typs))))
(defn shape-token-attrs
"The folded applied-token attributes of one shape: one datom per applied
property, value the applied token name, attribute from the closed
vocabulary. Unresolvable names are stored too; the `uses-token` rule
joins on `:token/name`, so they surface only when the token exists."
[applied-tokens]
(reduce-kv (fn [acc k v]
(if-let [attr (token-attr k)]
(assoc acc attr v)
acc))
{}
(or applied-tokens {})))
(defn shape-attrs
"The plain indexed attributes of one shape (no identity, no topology)."
[shape]
(let [swap-slot (ctk/get-swap-slot shape)]
(cond-> {:shape/type (:type shape)}
(cond-> (merge {:shape/type (:type shape)}
(shape-token-attrs (:applied-tokens shape)))
(some? (:name shape)) (assoc :shape/name (:name shape))
(some? (:component-id shape)) (assoc :shape/component-id (:component-id shape))
(some? (:component-file shape)) (assoc :shape/component-file (:component-file shape))
@ -204,44 +306,31 @@
self-referential, which covers the page root frame (its `:parent-id` is
itself) and the root copy of a component container (its parent lives on
a page)."
[container-ref container-id objects shape asset-ctx]
(merge {:db/id (shape-tempid container-id (:id shape))
:shape/id (:id shape)
:shape/container container-ref
:shape/parent (if (resolvable-parent? objects shape)
(shape-tempid container-id (:parent-id shape))
container-ref)}
(shape-attrs shape)
(shape-asset-attrs shape asset-ctx)))
(defn token-use-entities
"One (shape, property, token) entity per applied token that resolves.
Token names are unique within a set but not across sets, so one applied
name may match several tokens; every match links, exactly as beadpot's
name join does (`beadpot.graph.transform.tokens/LinkAppliedTokens`)."
[shape-ref applied-tokens tokens-by-name]
(for [[prop token-name] applied-tokens
token-ref (get tokens-by-name token-name)]
{:token-use/shape shape-ref
:token-use/token token-ref
:token-use/prop prop}))
[container-ref container-id objects shape {:keys [resolve-ref numbering] :as ctx}]
(let [[enter exit] (get numbering (:id shape))
ref (when resolve-ref (resolve-ref shape))]
(merge (cond-> {:db/id (shape-tempid container-id (:id shape))
:shape/id (:id shape)
:shape/container container-ref
:shape/parent (if (resolvable-parent? objects shape)
(shape-tempid container-id (:parent-id shape))
container-ref)}
(some? enter) (assoc :shape/enter enter :shape/exit exit)
(some? ref) (assoc :shape/refers-to ref))
(shape-attrs shape)
(shape-asset-attrs shape ctx))))
(defn container-entities
"Entities for every shape of one container's `:objects` map, plus the
applied-token relation entities.
"Entities for every shape of one container's `:objects` map.
The whole map is indexed, not the tree walk from the root: a shape the
tree cannot reach is a document defect the index should expose to
queries rather than hide (the Ladybug projection walks and drops such
shapes with a warning; this is a recorded divergence)."
[container-ref container-id objects asset-ctx]
[container-ref container-id objects ctx]
(into []
(mapcat (fn [shape]
(cons (shape-entity container-ref container-id objects shape asset-ctx)
(token-use-entities (shape-tempid container-id (:id shape))
(:applied-tokens shape)
(:tokens-by-name asset-ctx)))))
(map (fn [shape]
(shape-entity container-ref container-id objects shape ctx)))
(vals objects)))
(defn component-entity
@ -262,7 +351,7 @@
"The component record entity, plus a container over its own `:objects`
when it carries one (deleted components keep the main-instance subtree,
`app.common.types.file/load-component-objects`)."
[component asset-ctx]
[component ctx]
(let [objects (:objects component)]
(cond-> [(component-entity component)]
(seq objects)
@ -271,17 +360,17 @@
:container/kind :component
:container/document doc-tempid})
(into (container-entities (container-tempid (:id component))
(:id component) objects asset-ctx))))))
(:id component) objects ctx))))))
(defn- page-tx
[page asset-ctx]
[page ctx]
(into [(cond-> {:db/id (container-tempid (:id page))
:container/id (:id page)
:container/kind :page
:container/document doc-tempid}
(some? (:name page)) (assoc :container/name (:name page)))]
(container-entities (container-tempid (:id page))
(:id page) (:objects page) asset-ctx)))
(:id page) (:objects page) ctx)))
(defn- tokens-tx
"Token set and token entities from the file's tokens lib.
@ -305,51 +394,82 @@
:token/set (token-set-tempid set-id)})))))
(some-> tokens-lib ctob/get-sets)))
(defn- build-tokens-by-name
"Token name -> tempids of every token carrying that name."
[tokens-lib]
(reduce (fn [acc set*]
(reduce-kv (fn [acc _ token]
(update acc (:name token) (fnil conj [])
(token-tempid (:id token))))
acc
(ctob/get-tokens- set*)))
{}
(some-> tokens-lib ctob/get-sets)))
(defn- ref-resolver
"The build-time `:resolve-ref`: `ctf/find-ref-shape` once per copy
shape, against one ctn container, its answer minted as the target's
build tempid. The subtle helper runs here, in the builder, never in a
query; its fostered-children and swap fallbacks stay its own."
[data file-id ctn-container]
(let [file {:id file-id :data data}]
(fn [shape]
(when (:shape-ref shape)
(when-let [ref (ctf/find-ref-shape file ctn-container {} shape
:include-deleted? true
:with-context? true)]
(when-let [target-container-id (:id (:container (meta ref)))]
(shape-tempid target-container-id (:id ref))))))))
(defn- build-asset-ctx
(defn- build-asset-maps
[data]
{:colors (into {} (map (fn [[id _]] [id (color-tempid id)]))
(:colors data))
:typographies (into {} (map (fn [[id _]] [id (typography-tempid id)]))
(:typographies data))
:tokens-by-name (build-tokens-by-name (:tokens-lib data))})
{:colors (into {} (map (fn [[id _]] [id (color-tempid id)]))
(:colors data))
:typographies (into {} (map (fn [[id _]] [id (typography-tempid id)]))
(:typographies data))})
(defn build-tx
"The full transaction that projects file `data` into an empty overlay.
`file` supplies `:id` and `:name` when `data` does not carry them."
`file` supplies `:id` and `:name` when `data` does not carry them. The
Euler counter threads globally across containers, components first,
pages after, so every interval in the file is disjoint."
[data file]
(let [doc-id (or (:id data) (:id file))
ctx (build-asset-ctx data)]
(-> [(cond-> {:db/id doc-tempid :document/id doc-id}
(some? (:name file)) (assoc :document/name (:name file)))]
(into (map (fn [[id color]]
(cond-> {:db/id (color-tempid id)
:color/id id
:color/document doc-tempid}
(some? (:name color)) (assoc :color/name (:name color)))))
(:colors data))
(into (map (fn [[id typ]]
(cond-> {:db/id (typography-tempid id)
:typography/id id
:typography/document doc-tempid}
(some? (:name typ)) (assoc :typography/name (:name typ)))))
(:typographies data))
(into (tokens-tx (:tokens-lib data)))
(into (mapcat #(component-tx (val %) ctx)) (:components data))
(into (mapcat #(page-tx (get-in data [:pages-index %]) ctx))
(filter #(get-in data [:pages-index %]) (:pages data))))))
assets (build-asset-maps data)
head (-> [(cond-> {:db/id doc-tempid :document/id doc-id}
(some? (:name file)) (assoc :document/name (:name file)))]
(into (map (fn [[id color]]
(cond-> {:db/id (color-tempid id)
:color/id id
:color/document doc-tempid}
(some? (:name color)) (assoc :color/name (:name color)))))
(:colors data))
(into (map (fn [[id typ]]
(cond-> {:db/id (typography-tempid id)
:typography/id id
:typography/document doc-tempid}
(some? (:name typ)) (assoc :typography/name (:name typ)))))
(:typographies data))
(into (tokens-tx (:tokens-lib data))))
[tx _counter]
(as-> [head 0] state
(reduce (fn [[tx counter] component]
(let [objects (:objects component)
[numbering counter]
(if (seq objects)
(euler-numbering objects counter)
[{} counter])
ctx (assoc assets
:numbering numbering
:resolve-ref
(ref-resolver data doc-id
(ctn/make-container component :component)))]
[(into tx (component-tx component ctx)) counter]))
state
(vals (:components data)))
(reduce (fn [[tx counter] page-id]
(if-let [page (get-in data [:pages-index page-id])]
(let [[numbering counter]
(euler-numbering (:objects page) counter)
ctx (assoc assets
:numbering numbering
:resolve-ref
(ref-resolver data doc-id
(ctn/make-container page :page)))]
[(into tx (page-tx page ctx)) counter])
[tx counter]))
state
(:pages data)))]
tx))
(defn build
"Project file `data` into a fresh overlay. Pure: returns a datascript

292
backend/src/app/graph/overlay/queries.clj
View File

@ -5,89 +5,121 @@
;; Copyright (c) KALEIDOS INC Sucursal en España SL
(ns app.graph.overlay.queries
"The standing question set over the overlay, plus the rule set the
console shares.
"The relation vocabulary and the standing question set over the overlay.
**The relation vocabulary is a rule set, not raw clauses**
(docs.local/graph/20260820-report-graph-overlay-datascript.md).
`child-of`, `descendant-of`, `instance-of`, `refers-to`,
`fills-swap-slot` and `uses-token` are named once here, implemented per
engine and per encoding, and every consumer query and every backported
beadpot assertion is written against the rules only. The encodings can
change under a rule without a consumer noticing: `refers-to` reads a
builder-resolved reference today and read an id join before,
`uses-token` reads folded token attributes today and read relation
entities before, and the consumer texts did not move.
Rule signatures are subject first: `(child-of ?c ?p)` reads \"?c is a
child of ?p\", `(descendant-of ?d ?a)` reads \"?d is a descendant of
?a\".
Division of labour, stated once and applied throughout: **when the
caller holds the document, Penpot's helper is the query.** The upward
walk (`ctn/get-parent-heads` over `cfh/get-parents-with-self`) runs
about 1 500 times faster than the datalog formulation because the
document already encodes it as a pointer chain
(docs.local/graph/20260819-report-graph-overlay-datascript.md). The
functions here exist for the reverse and cross-container questions the
document cannot answer without a full scan, and for callers that hold
only the index. Where a function mirrors a helper, its docstring names
that helper, and the semantic suite pins the equality; the helper stays
the oracle and is never reimplemented here."
about three orders of magnitude faster than any datalog formulation
because the document already encodes it as a pointer chain, and even
the interval form of containment loses to `cfh/get-children-ids` by an
order of magnitude (14.89 ms against 1.09 ms on an 808-child frame).
The functions here exist for the reverse and cross-container questions
the document cannot answer without a full scan, and for callers that
hold only the index. Where a function mirrors a helper, its docstring
names that helper, and the semantic suite pins the equality; the helper
stays the oracle and is never reimplemented here."
(:require
[app.common.uuid :as uuid]
[app.graph.overlay :as overlay]
[datascript.core :as d]))
(def rules
"The shared rule set. Edge kinds that the Ladybug projection
materialized as relationship tables are rules here: they derive from
indexed attributes at query time, so they can never drift from the
attributes they restate.
"The relation vocabulary, plus the helper fragments the standing set
composes (`anc-or-self`, `uses-color`, `on-page`).
The predicates the rules restate live in `app.common.types.component`
and stay authoritative: `instance-head?` is `(some? (:component-id
shape))`, which is exactly the `[?s :shape/component-id _]` clause;
`is-instance-of` requires `component-file` as the head marker just as
`ctk/instance-of?` does; `fills-swap-slot` reads the swap slot that
`ctk/get-swap-slot` extracted at build time."
'[;; ancestors, self included: cfh/get-parents-with-self as a rule
[(anc-or-self ?s ?a)
[(identity ?s) ?a]]
[(anc-or-self ?s ?a)
[?s :shape/parent ?p]
(anc-or-self ?p ?a)]
`descendant-of` is implemented over the global Euler-tour intervals the
builder assigns: two comparisons instead of a recursive walk (14.89 ms
against 93.98 ms on an 808-child frame). `descendant-of-walk` keeps the
recursive form: it is the invariant check for the numbering and the
slow side of that measurement, never a consumer surface.
;; strict descendants: cfh/get-children-ids as a rule
[(desc ?a ?d)
[?d :shape/parent ?a]]
[(desc ?a ?d)
[?x :shape/parent ?a]
(desc ?x ?d)]
`uses-token` hides the folded token encoding: an attribute-variable
clause over the closed vocabulary of `app.common.types.token/all-keys`,
joined to the token entity by name, so the encoding stays reversible
behind the rule."
(into
'[;; containment, one edge
[(child-of ?c ?p)
[?c :shape/parent ?p]]
;; IsInstanceOf: ctk/instance-of? against a live component record
[(is-instance-of ?s ?c)
[?s :shape/type :frame]
[?s :shape/component-id ?cid]
[?s :shape/component-file _]
[?c :component/id ?cid]
(not [?c :component/deleted true])]
;; containment, transitive: the Euler-tour interval form
[(descendant-of ?d ?a)
[?a :shape/enter ?e0]
[?a :shape/exit ?e1]
[?d :shape/enter ?de]
[(< ?e0 ?de)]
[(< ?de ?e1)]]
;; RefersTo: is-main-of? read backwards — the instance shape points
;; at its homologue by :shape-ref, joined on the target's id
[(refers-to ?s ?t)
[?s :shape/shape-ref ?r]
[?t :shape/id ?r]]
;; containment, transitive: the recursive form, kept as the
;; numbering's invariant check and the measured slow side
[(descendant-of-walk ?d ?a)
(child-of ?d ?a)]
[(descendant-of-walk ?d ?a)
(child-of ?d ?x)
(descendant-of-walk ?x ?a)]
;; FillsSwapSlot: the swapped-in shape names the replaced slot
[(fills-swap-slot ?s ?t)
[?s :shape/swap-slot ?slot]
[?t :shape/id ?slot]
[?s :shape/id ?sid]
[(not= ?sid ?slot)]]
;; ancestors, self included: cfh/get-parents-with-self as a rule
[(anc-or-self ?s ?a)
[(identity ?s) ?a]]
[(anc-or-self ?s ?a)
[?s :shape/parent ?p]
(anc-or-self ?p ?a)]
;; UsesColor: the per-source attributes reunited
[(uses-color ?s ?col)
[?s :shape/fill-color ?col]]
[(uses-color ?s ?col)
[?s :shape/stroke-color ?col]]
[(uses-color ?s ?col)
[?s :shape/text-color ?col]]
;; IsInstanceOf: ctk/instance-of? against a live component record
[(instance-of ?s ?c)
[?s :shape/type :frame]
[?s :shape/component-id ?cid]
[?s :shape/component-file _]
[?c :component/id ?cid]
(not [?c :component/deleted true])]
;; UsesToken: the relation entity flattened to an edge
[(uses-token ?s ?t)
[?u :token-use/shape ?s]
[?u :token-use/token ?t]]
;; RefersTo: the reference ctf/find-ref-shape resolved at build time
[(refers-to ?s ?t)
[?s :shape/refers-to ?t]]
;; scope helper: shapes living on a page (component containers hold
;; bookkeeping copies, ctf/load-component-objects)
[(on-page ?s)
[?s :shape/container ?c]
[?c :container/kind :page]]])
;; FillsSwapSlot: the swapped-in shape names the replaced slot
[(fills-swap-slot ?s ?t)
[?s :shape/swap-slot ?slot]
[?t :shape/id ?slot]
[?s :shape/id ?sid]
[(not= ?sid ?slot)]]
;; UsesColor: the per-source attributes reunited
[(uses-color ?s ?col)
[?s :shape/fill-color ?col]]
[(uses-color ?s ?col)
[?s :shape/stroke-color ?col]]
[(uses-color ?s ?col)
[?s :shape/text-color ?col]]
;; scope helper: shapes living on a page (component containers hold
;; bookkeeping copies, ctf/load-component-objects)
[(on-page ?s)
[?s :shape/container ?c]
[?c :container/kind :page]]]
;; UsesToken over the folded encoding; the closed vocabulary is
;; embedded as data so the rule stays engine-portable
[(vector '(uses-token ?s ?tok)
'[?s ?a ?n]
[(list 'contains? overlay/token-attrs '?a)]
'[?tok :token/name ?n])]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; entity resolution
@ -115,7 +147,7 @@
(mapv :e (d/datoms db :avet :shape/id shape-id)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; the standing question set
;; the standing question set — every relation traversal via the rules
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- entity-depth
@ -152,20 +184,21 @@
[page-id shape-id] pairs.
The document-side equivalent is a full scan of every page's `:objects`
filtered by `ctk/instance-of?`; the overlay answers it from two AVET
lookups. Scoped to page containers because component records hold their
own copies of shapes."
filtered by `ctk/instance-of?`; the overlay answers it from the
`instance-of` rule plus one attribute constraint. Scoped to page
containers because component records hold their own copies of shapes."
[db component-id file-id]
(d/q '[:find ?pid ?id
:in $ ?cid ?fid
:in $ % ?cid ?fid
:where
[?e :shape/component-id ?cid]
[?comp :component/id ?cid]
(instance-of ?e ?comp)
[?e :shape/component-file ?fid]
(on-page ?e)
[?e :shape/container ?c]
[?c :container/kind :page]
[?c :container/id ?pid]
[?e :shape/id ?id]]
db component-id file-id))
db rules component-id file-id))
(defn descendant-ids
"Descendant shape ids of (container, shape), self excluded: the overlay
@ -178,7 +211,21 @@
[?c :container/id ?cid]
[?s :shape/container ?c]
[?s :shape/id ?sid]
(desc ?s ?d)
(descendant-of ?d ?s)
[?d :shape/id ?id]]
db rules container-id shape-id)))
(defn descendant-ids-walk
"The recursive-rule form of `descendant-ids`: the numbering invariant's
slow side, kept for the A/B measurement, never a consumer surface."
[db container-id shape-id]
(set (d/q '[:find [?id ...]
:in $ % ?cid ?sid
:where
[?c :container/id ?cid]
[?s :shape/container ?c]
[?s :shape/id ?sid]
(descendant-of-walk ?d ?s)
[?d :shape/id ?id]]
db rules container-id shape-id)))
@ -193,7 +240,7 @@
[?c :container/id ?cid]
[?s :shape/container ?c]
[?s :shape/id ?sid]
(desc ?s ?d)
(descendant-of ?d ?s)
[?d :shape/type ?type]
[?d :shape/id ?id]]
db rules container-id shape-id type)))
@ -216,13 +263,28 @@
(`ctk/instance-head?` over the whole document)."
[db]
(d/q '[:find ?pid ?id
:in $ %
:where
[?s :shape/component-id _]
(on-page ?s)
[?s :shape/container ?c]
[?c :container/kind :page]
[?c :container/id ?pid]
[?s :shape/id ?id]]
db))
db rules))
(defn refers-to-pairs
"Resolved reference pairs [[src-container src-id tgt-container tgt-id]]
from the `refers-to` rule (builder-resolved `ctf/find-ref-shape`)."
[db]
(d/q '[:find ?scid ?sid ?tcid ?tid
:in $ %
:where
(refers-to ?s ?t)
[?s :shape/container ?sc] [?sc :container/id ?scid]
[?s :shape/id ?sid]
[?t :shape/container ?tc] [?tc :container/id ?tcid]
[?t :shape/id ?tid]]
db rules))
(defn shapes-using-color
"Shapes referencing library color `color-id`, as [container-id shape-id]
@ -252,22 +314,37 @@
[?s :shape/id ?id]]
db typography-id))
(defn- applied-props
"The applied-token properties under which `eid` carries `token-name`,
recovered from the folded attributes of the entity."
[db eid token-name]
(let [e (d/entity db eid)]
(into []
(keep (fn [attr]
(when (= token-name (get e attr))
(overlay/token-attr->prop attr))))
overlay/token-attrs)))
(defn shapes-using-token
"Applied-token uses of the token named `token-name`, as
[container-id shape-id property] triples (the LinkAppliedTokens
question)."
question). The relation comes from the `uses-token` rule; the property
is recovered from the folded attributes per matched shape."
[db token-name]
(d/q '[:find ?cid ?id ?prop
:in $ ?name
:where
[?t :token/name ?name]
[?u :token-use/token ?t]
[?u :token-use/prop ?prop]
[?u :token-use/shape ?s]
[?s :shape/container ?c]
[?c :container/id ?cid]
[?s :shape/id ?id]]
db token-name))
(let [pairs (d/q '[:find ?cid ?id ?s
:in $ % ?name
:where
[?tok :token/name ?name]
(uses-token ?s ?tok)
[?s :shape/container ?c]
[?c :container/id ?cid]
[?s :shape/id ?id]]
db rules token-name)]
(into #{}
(mapcat (fn [[cid id eid]]
(map (fn [prop] [cid id prop])
(applied-props db eid token-name))))
pairs)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; inventory and parity
@ -277,6 +354,11 @@
[db attr]
(count (d/datoms db :avet attr)))
(defn token-application-count
"Datoms across the folded token attributes."
[db]
(transduce (map #(count (d/datoms db :aevt %))) + 0 overlay/token-attrs))
(defn stats
"Entity and edge inventory of the overlay."
[db]
@ -289,7 +371,9 @@
:typographies (attr-count db :typography/id)
:token-sets (attr-count db :token-set/id)
:tokens (attr-count db :token/id)
:token-uses (attr-count db :token-use/shape)})
:token-uses (token-application-count db)
:refs-resolved (attr-count db :shape/refers-to)
:refs-carried (attr-count db :shape/shape-ref)})
(defn edge-counts
"Count of every edge kind under the overlay's own conventions (all
@ -299,17 +383,16 @@
{:is-child-of (+ (attr-count db :shape/parent)
(attr-count db :container/document)
(attr-count db :component/document))
:is-instance-of (count (d/q '[:find ?s ?c :in $ % :where (is-instance-of ?s ?c)]
db rules))
:refers-to (count (d/q '[:find ?s ?t :in $ % :where (refers-to ?s ?t)]
:is-instance-of (count (d/q '[:find ?s ?c :in $ % :where (instance-of ?s ?c)]
db rules))
:refers-to (attr-count db :shape/refers-to)
:fills-swap-slot (count (d/q '[:find ?s ?t :in $ % :where (fills-swap-slot ?s ?t)]
db rules))
:uses-color (+ (attr-count db :shape/fill-color)
(attr-count db :shape/stroke-color)
(attr-count db :shape/text-color))
:uses-typography (attr-count db :shape/uses-typography)
:uses-token (attr-count db :token-use/shape)})
:uses-token (token-application-count db)})
(defn ladybug-parity-counts
"Edge counts under the Ladybug projection's own conventions, for the
@ -317,19 +400,20 @@
an overlay extension), root frames excluded (the projection skips
them), live components only.
A count that disagrees with the projection's relation table is a
finding to explain in writing, never to average away: the two likely
causes are a porting bug here and a projection limitation there, and
they demand opposite responses."
`refers-to` diverges by construction since the builder-resolution
retrofit: the projection's RefersTo is an id join over page shapes,
the overlay's is `ctf/find-ref-shape`'s answer, and the two differ
exactly where the id join is ambiguous or the helper's fallbacks
apply. The difference is a semantics upgrade, recorded rather than
reconciled."
[db]
(let [zero uuid/zero
page-shapes (d/q '[:find [?s ...]
:in $ ?zero
:in $ % ?zero
:where
[?s :shape/container ?c]
[?c :container/kind :page]
(on-page ?s)
(not [?s :shape/id ?zero])]
db zero)
db rules zero)
pages (count (d/q '[:find [?c ...]
:where [?c :container/kind :page]]
db))
@ -343,7 +427,7 @@
:in $ %
:where
(on-page ?s)
(is-instance-of ?s ?c)]
(instance-of ?s ?c)]
db rules))
:refers-to (count (d/q '[:find ?s ?t
:in $ %

322
backend/src/app/graph/overlay/sync.clj
View File

@ -14,6 +14,21 @@
the overlay does not index (geometry, style payloads), the mirror is a
no-op by design.
Two derived layers ride every structural change:
- **Euler intervals.** A structural change renumbers its container from
beyond the current global maximum, from overlay topology alone. The
numbers differ from a rebuild's (different DFS order, different
range); interval containment is the invariant, and the suite pins
containment, never the numbers.
- **Resolved references.** `:shape/refers-to` is the builder's
`ctf/find-ref-shape` answer, so the sync path re-resolves it for
every shape whose resolution inputs changed: the shape itself on
`:shape-ref`, the subtree on head-attribute changes and reparents,
and every instance subtree of a component whose record or own copy
changed. The resolution walks the same head chain the helper walks,
over the index instead of the document.
Everything here is pure: db value in, db value out. The session layer
owns the atom and the revision bookkeeping."
(:require
@ -43,34 +58,21 @@
(some-> (first (d/datoms db :avet :document/id)) :e))
(defn- sync-asset-ctx
"The `asset-ctx` of `app.graph.overlay`, resolved against the live db:
values are eids rather than tempids."
"The asset half of `app.graph.overlay`'s build-ctx, resolved against the
live db: values are eids rather than tempids."
[db]
{:colors (into {} (map (fn [dtm] [(:v dtm) (:e dtm)]))
(d/datoms db :avet :color/id))
:typographies (into {} (map (fn [dtm] [(:v dtm) (:e dtm)]))
(d/datoms db :avet :typography/id))
:tokens-by-name (reduce (fn [acc dtm]
(update acc (:v dtm) (fnil conj []) (:e dtm)))
{}
(d/datoms db :avet :token/name))})
(d/datoms db :avet :typography/id))})
(defn- change-container-id
[{:keys [page-id component-id]}]
(or page-id component-id))
(defn- token-use-eids
[db shape-eid]
(mapv :e (d/datoms db :avet :token-use/shape shape-eid)))
(defn- retract-shape-tx
"Retract one shape entity plus its applied-token relation entities
(`:db.fn/retractEntity` clears datoms pointing at the shape, but the
relation entity itself would survive as garbage)."
[db eid]
(into [[:db.fn/retractEntity eid]]
(map (fn [tu] [:db.fn/retractEntity tu]))
(token-use-eids db eid)))
[_db eid]
[[:db.fn/retractEntity eid]])
(defn- child-eids
[db eid]
@ -96,6 +98,131 @@
(mapcat #(retract-shape-tx db %))
(container-shape-eids db container-eid)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Euler renumbering
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- next-euler-counter
[db]
(transduce (map (comp long :v)) (completing (fn [acc v] (max acc (inc v)))) 0
(d/datoms db :avet :shape/exit)))
(defn- renumber-container-tx
"Fresh Euler intervals for every shape of `ceid`, drawn from beyond the
current global maximum so ranges stay disjoint file-wide. Rebuilt from
overlay topology alone: the DFS order differs from the builder's,
interval containment is the invariant."
[db ceid]
(let [eids (container-shape-eids db ceid)
by-parent (group-by (fn [e] (:db/id (:shape/parent (d/entity db e)))) eids)
roots (vec (sort (get by-parent ceid [])))
base (next-euler-counter db)]
(loop [events (into [] (map (fn [e] [:enter e])) (rseq roots))
counter (long base)
seen (transient #{})
tx (transient [])]
(if-let [[kind eid] (peek events)]
(let [events (pop events)]
(case kind
:enter
(recur (-> events
(conj [:exit eid])
(into (map (fn [c] [:enter c]))
(sort (get by-parent eid []))))
(inc counter)
(conj! seen eid)
(conj! tx [:db/add eid :shape/enter counter]))
:exit
(recur events
(inc counter)
seen
(conj! tx [:db/add eid :shape/exit counter]))))
(let [seen (persistent! seen)
tx (persistent! tx)]
;; degenerate intervals for shapes outside the reachable tree
(first
(reduce (fn [[tx c] eid]
(if (contains? seen eid)
[tx c]
[(conj tx
[:db/add eid :shape/enter c]
[:db/add eid :shape/exit (inc c)])
(+ c 2)]))
[tx (+ base (* 2 (count seen)))]
eids)))))))
(defn- with-renumber
[db ceid]
(d/db-with db (renumber-container-tx db ceid)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; reference re-resolution
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- parent-heads-of
"The instance heads on the parent chain of `eid`, self included,
top-down: `ctn/get-parent-heads` over the index."
[db eid]
(loop [cur (d/entity db eid) acc ()]
(if (and cur (:shape/id cur))
(recur (:shape/parent cur)
(cond-> acc (:shape/component-id cur) (conj cur)))
(vec acc))))
(defn- resolve-ref-eid
"The sync-path mirror of `ctf/find-ref-shape`: try each parent head
top-down; through the head's component record (deleted included) find
the container that holds the component's shapes — the component's own
copy when it carries one, the main-instance page otherwise — and look
the `:shape/shape-ref` id up there."
[db eid]
(let [ref-id (:shape/shape-ref (d/entity db eid))]
(when ref-id
(some (fn [head]
(when-let [comp (d/entity db [:component/id (:shape/component-id head)])]
(let [ceid (if (:container/id comp)
(:db/id comp)
(some->> (:component/main-instance-page comp)
(queries/container-eid db)))]
(when ceid
(queries/shape-eid db ceid ref-id)))))
(parent-heads-of db eid)))))
(defn- reresolve-refs-tx
[db eids]
(into []
(keep (fn [eid]
(let [current (:db/id (:shape/refers-to (d/entity db eid)))
fresh (resolve-ref-eid db eid)]
(cond
(= current fresh) nil
(nil? fresh) [:db.fn/retractAttribute eid :shape/refers-to]
:else [:db/add eid :shape/refers-to fresh]))))
eids))
(defn- with-reresolved
[db eids]
(let [tx (reresolve-refs-tx db eids)]
(cond-> db (seq tx) (d/db-with tx))))
(defn- component-affected-eids
"Every shape whose reference resolution reads component `cid`: the
subtrees of its instance heads, plus its own container copies."
[db cid]
(let [heads (mapv :e (d/datoms db :avet :shape/component-id cid))
own (when-let [comp (d/entity db [:component/id cid])]
(when (:container/id comp)
(container-shape-eids db (:db/id comp))))]
(-> []
(into (mapcat #(subtree-eids db %)) heads)
(into own)
distinct
vec)))
(defn- with-component-reresolved
[db cid]
(with-reresolved db (component-affected-eids db cid)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; per-change application
;;
@ -134,11 +261,13 @@
:shape/container ceid
:shape/parent peid}
(overlay/shape-attrs shape)
(overlay/shape-asset-attrs shape ctx)))
(into (overlay/token-use-entities
tempid (:applied-tokens shape)
(:tokens-by-name ctx))))]
(ok (d/db-with db tx))))))
(overlay/shape-asset-attrs shape ctx))))
db' (d/db-with db tx)
new-eid (queries/shape-eid db' ceid id)]
(-> db'
(with-reresolved (if new-eid [new-eid] []))
(with-renumber ceid)
(ok))))))
(def ^:private plain-attr->overlay
{:name :shape/name
@ -146,6 +275,11 @@
:component-file :shape/component-file
:shape-ref :shape/shape-ref})
(def ^:private head-attrs
"Shape attributes whose change moves reference resolution for the whole
subtree below the shape."
#{:component-id :component-file})
(defn- replace-attr-tx
[eid attr val]
(if (some? val)
@ -168,6 +302,16 @@
(ctk/get-swap-slot {:touched touched}))]
(replace-attr-tx eid :shape/swap-slot slot)))
(defn- applied-tokens-tx
"Replace the folded token attributes from a fresh `:applied-tokens`
value: retract the closed vocabulary, assert the new applications."
[eid applied]
(into (mapv (fn [a] [:db.fn/retractAttribute eid a]) overlay/token-attrs)
(keep (fn [[k v]]
(when-let [attr (overlay/token-attr k)]
[:db/add eid attr v])))
(or applied {})))
(defn- set-op-tx
"Transaction data for one `:set` / `:set-touched` operation on `eid`.
Attributes the overlay does not index yield nil (a designed no-op),
@ -202,8 +346,7 @@
(overlay/content-typography-ref-ids val))))
(= :applied-tokens attr)
(into (mapv (fn [tu] [:db.fn/retractEntity tu]) (token-use-eids db eid))
(overlay/token-use-entities eid val (:tokens-by-name ctx)))
(applied-tokens-tx eid val)
:else nil))
@ -214,8 +357,14 @@
(if-not eid
(skip db :missing-shape)
(let [ctx (sync-asset-ctx db)
tx (into [] (mapcat #(set-op-tx db eid ctx %)) operations)]
(ok (cond-> db (seq tx) (d/db-with tx)))))))
tx (into [] (mapcat #(set-op-tx db eid ctx %)) operations)
db' (cond-> db (seq tx) (d/db-with tx))
set-attrs (into #{} (keep :attr) operations)
affected (cond
(some head-attrs set-attrs) (subtree-eids db' eid)
(contains? set-attrs :shape-ref) [eid]
:else nil)]
(ok (cond-> db' (seq affected) (with-reresolved affected)))))))
(defn- apply-del-obj
[db {:keys [id] :as change}]
@ -232,19 +381,21 @@
(defn- apply-mov-objects
"Reparenting only: `:mov-objects` carries shape ids and a parent id and
nothing else (`common/src/app/common/files/changes.cljc`), and the
overlay stores no sibling order, so the whole change is one
`:shape/parent` re-point per moved shape."
overlay stores no sibling order, so the move is a `:shape/parent`
re-point per shape, a container renumber, and a reference re-resolution
of the moved subtrees (their head chains changed)."
[db {:keys [parent-id shapes] :as change}]
(let [ceid (queries/container-eid db (change-container-id change))
peid (when ceid (queries/shape-eid db ceid parent-id))]
(if-not peid
(skip db :missing-parent)
(let [tx (into []
(keep (fn [sid]
(when-let [eid (queries/shape-eid db ceid sid)]
[:db/add eid :shape/parent peid])))
shapes)]
(ok (cond-> db (seq tx) (d/db-with tx)))))))
(let [moved (into []
(keep (fn [sid] (queries/shape-eid db ceid sid)))
shapes)
tx (mapv (fn [eid] [:db/add eid :shape/parent peid]) moved)
db' (cond-> db (seq tx) (d/db-with tx))
db' (with-renumber db' ceid)]
(ok (with-reresolved db' (into [] (mapcat #(subtree-eids db' %)) moved)))))))
(defn- apply-add-page
"Mirror of `process-change :add-page`: id+name means a fresh empty page
@ -256,7 +407,7 @@
page-id (:id page)]
(if (queries/container-eid db page-id)
(ok db)
(let [ctx (sync-asset-ctx db)
(let [ctx (assoc (sync-asset-ctx db) :numbering {} :resolve-ref nil)
tid (overlay/container-tempid page-id)
tx (into [(cond-> {:db/id tid
:container/id page-id
@ -264,8 +415,11 @@
:container/document (doc-eid db)}
(some? (:name page))
(assoc :container/name (:name page)))]
(overlay/container-entities tid page-id (:objects page) ctx))]
(ok (d/db-with db tx))))))
(overlay/container-entities tid page-id (:objects page) ctx))
db' (d/db-with db tx)
ceid (queries/container-eid db' page-id)
db' (with-renumber db' ceid)]
(ok (with-reresolved db' (container-shape-eids db' ceid)))))))
(defn- apply-del-page
[db {:keys [id]}]
@ -296,7 +450,7 @@
(ok db)
(let [tx (into [{:db/id -1 :component/id id :component/document (doc-eid db)}]
(component-attrs-tx -1 change))]
(ok (d/db-with db tx)))))
(ok (with-component-reresolved (d/db-with db tx) id)))))
(defn- clear-component-container-tx
"Drop a component's own shape copies and its container role, keeping the
@ -311,7 +465,7 @@
(defn- component-container-tx
"Give the component entity a container role over `objects`."
[db eid component-id objects]
(let [ctx (sync-asset-ctx db)]
(let [ctx (assoc (sync-asset-ctx db) :numbering {} :resolve-ref nil)]
(into [[:db/add eid :container/id component-id]
[:db/add eid :container/kind :component]
[:db/add eid :container/document (doc-eid db)]]
@ -324,19 +478,27 @@
only when the change carries objects."
[db {:keys [id objects] :as change}]
(if-let [eid (d/entid db [:component/id id])]
(let [tx (-> (component-attrs-tx eid change)
(into (clear-component-container-tx db eid))
(cond-> (some? objects)
(into (component-container-tx db eid id objects))))]
(ok (cond-> db (seq tx) (d/db-with tx))))
(let [tx (-> (component-attrs-tx eid change)
(into (clear-component-container-tx db eid))
(cond-> (some? objects)
(into (component-container-tx db eid id objects))))
db' (cond-> db (seq tx) (d/db-with tx))
db' (cond-> db' (some? objects) (with-renumber eid))]
(ok (with-component-reresolved db' id)))
(skip db :missing-component)))
(defn- entity-shape-attrs
"The indexed attrs of a live shape entity, as assertable values (asset
references flattened to eids)."
references flattened to eids; Euler intervals excluded, the copy is
renumbered; the resolved reference excluded, the copy is re-resolved)."
[ent]
(let [many-ids #(into [] (map :db/id) %)]
(cond-> {:shape/type (:shape/type ent)}
(cond-> (reduce (fn [acc attr]
(if-some [v (get ent attr)]
(assoc acc attr v)
acc))
{:shape/type (:shape/type ent)}
overlay/token-attrs)
(some? (:shape/name ent)) (assoc :shape/name (:shape/name ent))
(some? (:shape/component-id ent)) (assoc :shape/component-id (:shape/component-id ent))
(some? (:shape/component-file ent)) (assoc :shape/component-file (:shape/component-file ent))
@ -351,9 +513,9 @@
"Mirror of `ctf/load-component-objects`: copy the main-instance subtree
from its page into the component's own container, same ids, new
(container, shape) entities. The copy is taken from the overlay itself,
which is exactly the identity/type/topology slice the rebuild would
project from the document's copy. Geometry (`delta`) is not indexed, so
the move that accompanies an undo of cut-paste is a designed no-op."
which is exactly the indexed slice the rebuild would project from the
document's copy. Geometry (`delta`) is not indexed, so the move that
accompanies an undo of cut-paste is a designed no-op."
[db comp-eid]
(let [ent (d/entity db comp-eid)
comp-id (:component/id ent)
@ -369,55 +531,55 @@
(into [[:db/add comp-eid :container/id comp-id]
[:db/add comp-eid :container/kind :component]
[:db/add comp-eid :container/document (doc-eid db)]]
(mapcat (fn [eid]
(let [src (d/entity db eid)
tempid (copy-tempid eid)
parent (:db/id (:shape/parent src))
copy (merge {:db/id tempid
:shape/id (:shape/id src)
:shape/container comp-eid
:shape/parent (if (contains? eidset parent)
(copy-tempid parent)
comp-eid)}
(entity-shape-attrs src))
uses (for [tu (token-use-eids db eid)]
(let [tue (d/entity db tu)]
{:token-use/shape tempid
:token-use/token (:db/id (:token-use/token tue))
:token-use/prop (:token-use/prop tue)}))]
(cons copy uses))))
(map (fn [eid]
(let [src (d/entity db eid)
parent (:db/id (:shape/parent src))]
(merge {:db/id (copy-tempid eid)
:shape/id (:shape/id src)
:shape/container comp-eid
:shape/parent (if (contains? eidset parent)
(copy-tempid parent)
comp-eid)}
(entity-shape-attrs src)))))
eids)))))
(defn- apply-del-component
"Mirror of `ctf/delete-component`: with `skip-undelete?` the component
goes entirely; otherwise it is marked deleted and keeps its own copy of
the main-instance subtree."
the main-instance subtree. Either way the resolution targets of every
instance of this component move, so the affected references re-resolve."
[db {:keys [id skip-undelete?]}]
(if-let [eid (d/entid db [:component/id id])]
(if skip-undelete?
(ok (d/db-with db (conj (retract-container-shapes-tx db eid)
[:db.fn/retractEntity eid])))
(ok (d/db-with db (into [[:db/add eid :component/deleted true]]
(snapshot-component-tx db eid)))))
(let [db' (d/db-with db (conj (retract-container-shapes-tx db eid)
[:db.fn/retractEntity eid]))]
(ok (with-component-reresolved db' id)))
(let [snapshot (snapshot-component-tx db eid)
db' (d/db-with db (into [[:db/add eid :component/deleted true]]
snapshot))
db' (cond-> db' (seq snapshot) (with-renumber eid))]
(ok (with-component-reresolved db' id))))
(ok db)))
(defn- apply-restore-component
"Mirror of `ctf/restore-component`: undelete, drop the component's own
copy, optionally repoint the main-instance page."
copy, optionally repoint the main-instance page; the resolution targets
move back to the page, so the affected references re-resolve."
[db {:keys [id page-id]}]
(if-let [eid (d/entid db [:component/id id])]
(let [tx (cond-> (into [[:db.fn/retractAttribute eid :component/deleted]]
(clear-component-container-tx db eid))
(some? page-id)
(conj [:db/add eid :component/main-instance-page page-id]))]
(ok (d/db-with db tx)))
(let [tx (cond-> (into [[:db.fn/retractAttribute eid :component/deleted]]
(clear-component-container-tx db eid))
(some? page-id)
(conj [:db/add eid :component/main-instance-page page-id]))]
(ok (with-component-reresolved (d/db-with db tx) id)))
(skip db :missing-component)))
(defn- apply-purge-component
[db {:keys [id]}]
(if-let [eid (d/entid db [:component/id id])]
(ok (d/db-with db (conj (retract-container-shapes-tx db eid)
[:db.fn/retractEntity eid])))
(let [db' (d/db-with db (conj (retract-container-shapes-tx db eid)
[:db.fn/retractEntity eid]))]
(ok (with-component-reresolved db' id)))
(ok db)))
(defn- apply-change

34
backend/test/backend_tests/graph_overlay_console_test.clj
View File

@ -78,9 +78,39 @@
#(console/run-query (fixture-db) "[:find ?v :where"))]
(t/is (= :graph-query-invalid (:code data)))))
(t/deftest shared-rule-invocations-pass-the-gate
;; The gate's allowlist derives from `queries/rules`
;; (`app.graph.overlay.console/check-query!`), so rule renames pass
;; automatically: the default query proves `instance-of`, and these
;; hold the door open for `descendant-of` (with rows) and `uses-token`
;; (the fixture defines no tokens, so the gate acceptance is the
;; point).
(let [db (fixture-db)]
(let [{:keys [rows]} (console/run-query
db
"[:find ?n :in $ % :where [?p :shape/name \"Main\"] (descendant-of ?d ?p) [?d :shape/name ?n]]")]
(t/is (= #{"Child A" "Child B"} (set (map first rows)))))
(let [{:keys [rows]} (console/run-query
db
"[:find ?name :in $ % :where (uses-token ?s ?tok) [?tok :token/name ?name]]")]
(t/is (empty? rows)))))
(t/deftest the-old-rule-name-is-rejected
;; The vocabulary is closed: `is-instance-of` is gone, renamed
;; `instance-of`, and the old name must not pass the gate — the
;; allowlist derives from the rule set, not from a hardcoded list.
(let [data (thrown-data
#(console/run-query
(fixture-db)
"[:find ?s :in $ % :where (is-instance-of ?s ?c)]"))]
(t/is (= :graph-query-not-read-only (:code data)))
(t/is (str/includes? (:hint data) "is-instance-of")
"the error must name the old rule")))
(t/deftest the-default-query-runs-through-the-console
;; The shipped default invokes the shared `is-instance-of` rule with
;; `%`; a rule invocation must pass the gate and return rows.
;; The shipped default invokes the shared `instance-of` rule (renamed
;; from `is-instance-of` by the retrofit) with `%`; a rule invocation
;; must pass the gate and return rows.
(let [{:keys [columns rows truncated? row-count]}
(console/run-query (fixture-db) debug/default-query)]
(t/is (= ["component" "instance" "page" "filter_src_id" "filter_tgt_id"]

141
backend/test/backend_tests/graph_overlay_sync_test.clj
View File

@ -29,6 +29,7 @@
[app.common.types.tokens-lib :as ctob]
[app.common.uuid :as uuid]
[app.graph.overlay :as overlay]
[app.graph.overlay.queries :as queries]
[app.graph.overlay.sync :as sync]
[clojure.set :as set]
[clojure.test :as t]
@ -97,8 +98,10 @@
an editing session would emit them, and every indexed attribute at least
once: topology (add, reparent, delete a subtree), the `:mod-obj` set ops
with their asset refs (`app.graph.overlay.sync/set-op-tx`), a touched
swap slot on a shape inside a copy (`ctk/get-swap-slot`), and the whole
component lifecycle from add to purge."
swap slot on a shape inside a copy (`ctk/get-swap-slot`), a copy
child's `:shape-ref` repointed at another main shape (the resolved
`:shape/refers-to` must follow), and the whole component lifecycle from
add to purge."
[{:type :add-obj :page-id page-id :id frame-id
:parent-id uuid/zero :frame-id uuid/zero
:obj (shape frame-id :frame {:name "Board" :width 400 :height 300})}
@ -141,7 +144,7 @@
:val [(assoc (ths/sample-fill-color :fill-color "#ABCDEF" :fill-opacity 1)
:fill-color-ref-id color-id)]}]}
;; an applied token: one token-use entity (shape, property, token)
;; an applied token: one folded application (shape, property, name)
{:type :mod-obj :page-id page-id :id rect2-id
:operations [{:type :set :attr :applied-tokens
:val {:fill "brand.primary"}
@ -197,13 +200,17 @@
{:type :set :attr :main-instance :val false}]}
;; a copy of the component on the same page: `shape-ref` marks the
;; homologue, which is what makes `ctk/in-component-copy?` true
;; homologue, which is what makes `ctk/in-component-copy?` true. The
;; copy root carries `:component-file` like `ctn/make-component-instance`
;; sets it (the local library id), which is what lets
;; `ctf/find-ref-shape` resolve it at build time.
{:type :add-obj :page-id page-id :id copy-root-id
:parent-id uuid/zero :frame-id uuid/zero
:obj (shape copy-root-id :frame {:name "Copy" :parent-id uuid/zero :frame-id uuid/zero
:width 200 :height 200
:shape-ref comp-root-id
:component-id comp-id
:component-file file-id
:component-root true})}
{:type :add-obj :page-id page-id :id copy-child-id
@ -213,6 +220,12 @@
:shape-ref comp-child-id
:component-id comp-id})}
;; repoint a copy child at a different main shape: the resolved
;; reference must follow on both paths (`:shape/refers-to` re-resolves
;; through `ctf/find-ref-shape`'s sync mirror)
{:type :mod-obj :page-id page-id :id copy-child-id
:operations [{:type :set :attr :shape-ref :val comp-root-id}]}
;; a swap slot on a shape inside the copy: only the slot is indexed,
;; and only because `ctk/get-swap-slot` extracts it
{:type :mod-obj :page-id page-id :id copy-root-id
@ -245,8 +258,9 @@
(defn- entity-key
"The document key of one entity: `[:document id]`, `[:container id]`,
`[:component id]`, `[:shape container-id shape-id]`, `[:color id]`,
`[:typography id]`, `[:token-set id]`, `[:token id]`, or
`[:token-use shape-key token-id prop]`."
`[:typography id]`, `[:token-set id]`, or `[:token id]`. Token-use
entities are gone: the folded encoding stores applied tokens as shape
attributes."
[db eid]
(let [ent (d/entity db eid)]
(cond
@ -274,15 +288,7 @@
[:token-set (:token-set/id ent)]
(some? (:token/id ent))
[:token (:token/id ent)]
(some? (:token-use/shape ent))
(let [s (:token-use/shape ent)
t (:token-use/token ent)]
[:token-use
[:shape (:container/id (:shape/container s)) (:shape/id s)]
(:token/id t)
(:token-use/prop ent)]))))
[:token (:token/id ent)])))
(defn- ref-key
[keymap ref]
@ -323,17 +329,25 @@
:container/document (ref-key keymap (:container/document ent))}
(some? (:shape/id ent))
{:shape/type (:shape/type ent)
:shape/name (:shape/name ent)
:shape/component-id (:shape/component-id ent)
:shape/component-file (:shape/component-file ent)
:shape/shape-ref (:shape/shape-ref ent)
:shape/swap-slot (:shape/swap-slot ent)
:shape/parent (ref-key keymap (:shape/parent ent))
:shape/fill-color (ref-keys keymap (:shape/fill-color ent))
:shape/stroke-color (ref-keys keymap (:shape/stroke-color ent))
:shape/text-color (ref-keys keymap (:shape/text-color ent))
:shape/uses-typography (ref-keys keymap (:shape/uses-typography ent))}
(merge {:shape/type (:shape/type ent)
:shape/name (:shape/name ent)
:shape/component-id (:shape/component-id ent)
:shape/component-file (:shape/component-file ent)
:shape/shape-ref (:shape/shape-ref ent)
:shape/refers-to (ref-key keymap (:shape/refers-to ent))
:shape/swap-slot (:shape/swap-slot ent)
:shape/parent (ref-key keymap (:shape/parent ent))
:shape/fill-color (ref-keys keymap (:shape/fill-color ent))
:shape/stroke-color (ref-keys keymap (:shape/stroke-color ent))
:shape/text-color (ref-keys keymap (:shape/text-color ent))
:shape/uses-typography (ref-keys keymap (:shape/uses-typography ent))}
;; folded token attributes: plain strings, presence-checked
(into {} (map (fn [a] [a (get ent a)])) overlay/token-attrs))
;; Euler intervals deliberately excluded: the builder and the sync
;; renumber draw them from different DFS orders, so the values are
;; not comparable — interval containment is the invariant, pinned by
;; the-intervals-agree-after-the-full-replay (presence is checked
;; there)
(some? (:color/id ent))
{:color/id (:color/id ent)
@ -354,11 +368,7 @@
{:token/id (:token/id ent)
:token/name (:token/name ent)
:token/type (:token/type ent)
:token/set (ref-key keymap (:token/set ent))}
;; a token-use entity: shape, token and property all live in the key
:else {}))
:token/set (ref-key keymap (:token/set ent))}))
(defn- normal-form
"The overlay as entity-id-independent data: a set of
[entity-key attr-map] pairs."
@ -424,14 +434,19 @@
(t/deftest soft-delete-keeps-the-component-container-copy
;; `ctf/delete-component` without `skip-undelete?` stores the
;; main-instance subtree on the component (`ctf/load-component-objects`);
;; the overlay mirrors it as a component container, on both paths.
;; the overlay mirrors it as a component container, on both paths. The
;; copies' builder-resolved references must move with it: after
;; normalisation the synced and rebuilt forms agree on
;; `:shape/refers-to`, and both point at the snapshot copies.
(let [first-del (first (keep-indexed
(fn [i ch] (when (= :del-component (:type ch)) i))
changes))
prefix (subvec changes 0 (inc first-del))
data0 (base-data)
result (sync/apply-changes (overlay/build data0) prefix)
rebuilt (overlay/build (cp/process-changes data0 prefix false))]
rebuilt (overlay/build (cp/process-changes data0 prefix false))
synced-m (into {} (normal-form (:db result)))
rebuilt-m (into {} (normal-form rebuilt))]
(doseq [form [(normal-form (:db result)) (normal-form rebuilt)]]
(let [keys (into #{} (map first) form)]
(t/is (contains? keys [:shape comp-id comp-root-id])
@ -449,14 +464,25 @@
:container/id comp-id
:container/kind :component
:container/name nil
:container/document [:document file-id]}]))))))
:container/document [:document file-id]}]))))
;; the copies' `:shape/refers-to` equals the rebuild's, pointing at
;; the snapshot copies (the repointed copy child resolves to the
;; root copy, its :shape-ref was set to comp-root-id)
(t/is (= (get-in rebuilt-m [[:shape page-id copy-root-id] :shape/refers-to])
(get-in synced-m [[:shape page-id copy-root-id] :shape/refers-to])))
(t/is (= [:shape comp-id comp-root-id]
(get-in synced-m [[:shape page-id copy-root-id] :shape/refers-to])))
(t/is (= [:shape comp-id comp-root-id]
(get-in synced-m [[:shape page-id copy-child-id] :shape/refers-to])))))
(t/deftest the-diff-catches-an-injected-sync-bug
;; The round trip is only worth running if it fails when sync is wrong.
;; Drop the reparenting :mov-objects from the list the overlay sees,
;; keep it in the list the document sees, and the moved shape's entity
;; key must appear in the difference: the check is locatable, not just
;; boolean.
;; boolean. Euler intervals are out of the normal form, so it is the
;; parent ref (the moved shape's `:shape/parent` key) that names it.
(let [data0 (base-data)
data1 (cp/process-changes data0 changes false)
crippled (remove #(and (= :mov-objects (:type %))
@ -469,3 +495,48 @@
moved (into #{} (map first) diff)]
(t/is (contains? moved [:shape page-id text-id])
"a sync that skips a reparent must name the moved shape's key")))
(t/deftest the-intervals-agree-after-the-full-replay
;; The Euler-tour invariants hold on the synced db, not only on the
;; built one. The sync path renumbers a container from beyond the
;; global maximum with a different DFS order than the builder
;; (`app.graph.overlay.sync/renumber-container-tx`), so interval
;; values are not comparable between the two paths — containment is.
;; Here: every shape of every container carries an interval, the
;; interval form answers the recursive walk exactly, and intervals are
;; disjoint-or-nested file-wide (a partial overlap is the signature of
;; a per-container counter).
(let [db (-> (base-data) (overlay/build) (sync/apply-changes changes) :db)
containers (d/q '[:find [?c ...] :where [?c :container/id _]] db)]
;; presence: every shape of every container carries a fresh interval
(doseq [seid (d/q '[:find [?s ...] :where [?s :shape/container _]] db)]
(let [e (d/entity db seid)]
(t/is (and (some? (:shape/enter e)) (some? (:shape/exit e)))
(str "shape " (pr-str (:shape/id e)) " lost its interval"))))
;; containment: the interval form answers the recursive walk, per
;; container, per shape
(doseq [ceid containers
:let [cid (:container/id (d/entity db ceid))]
seid (d/q '[:find [?s ...] :in $ ?c
:where [?s :shape/container ?c]]
db ceid)
:let [sid (:shape/id (d/entity db seid))]]
(t/is (= (queries/descendant-ids db cid sid)
(queries/descendant-ids-walk db cid sid))
(str "interval vs walk in container " cid " shape " sid)))
;; the global-counter claim across all containers
(let [enters (into {} (map (juxt :e :v)) (d/datoms db :avet :shape/enter))
exits (into {} (map (juxt :e :v)) (d/datoms db :avet :shape/exit))
intervals (mapv (fn [[eid enter]] [enter (get exits eid)]) enters)
ok? (fn [[e0 e1] [f0 f1]]
(or (<= e1 f0) (<= f1 e0)
(and (< e0 f0) (< f1 e1))
(and (< f0 e0) (< e1 f1))))]
(doseq [i (range (count intervals))
j (range (inc i) (count intervals))]
(t/is (ok? (nth intervals i) (nth intervals j))
(str "intervals " (pr-str (nth intervals i)) " and "
(pr-str (nth intervals j)) " partially overlap"))))))

311
backend/test/backend_tests/graph_overlay_test.clj
View File

@ -30,6 +30,7 @@
[app.common.types.component :as ctk]
[app.common.types.components-list :as ctkl]
[app.common.types.container :as ctn]
[app.common.types.file :as ctf]
[app.common.types.shape :as cts]
[app.common.types.text :as txt]
[app.common.types.tokens-lib :as ctob]
@ -37,6 +38,7 @@
[app.graph.overlay :as overlay]
[app.graph.overlay.queries :as queries]
[clojure.test :as t]
[datascript.built-ins :as bi]
[datascript.core :as d]))
(t/use-fixtures :each thi/test-fixture)
@ -84,17 +86,44 @@
(assoc :content (refs-content "Typography sample" typography-id color-id)
:position-data nil)))
(defn- oracle-containers
"The builder's resolution containers, one per page plus one per
component that carries its own `:objects` snapshot, as [ctn-container
container-id] pairs (`app.graph.overlay/ref-resolver`)."
[data]
(concat (map (fn [[id page]] [(ctn/make-container page :page) id])
(:pages-index data))
(keep (fn [[cid component]]
(when (seq (:objects component))
[(ctn/make-container component :component) cid]))
(:components data))))
(defn- document-containers
"Every [container-id objects] pair the overlay indexes: the pages, plus
the `:objects` snapshot a deleted component carries
(`app.common.types.file/load-component-objects`)."
[data]
(concat (map (fn [page] [(:id page) (:objects page)])
(vals (:pages-index data)))
(keep (fn [[cid component]]
(when (seq (:objects component))
[cid (:objects component)]))
(:components data))))
(map (fn [[container cid]] [cid (:objects container)])
(oracle-containers data)))
(defn- oracle-refs
"`ctf/find-ref-shape`'s answer for every copy shape, as
[src-container src-id tgt-container tgt-id]: the oracle behind the
builder-resolved `:shape/refers-to` (`:include-deleted? true`,
`:with-context? true`)."
[data]
(let [file {:id (:id data) :data data}]
(into #{}
(for [[container cid] (oracle-containers data)
shape (vals (:objects container))
:when (:shape-ref shape)
:let [ref (ctf/find-ref-shape file container {} shape
:include-deleted? true
:with-context? true)]
:when (some? ref)]
[cid (:id shape)
(:id (:container (meta ref)))
(:id ref)]))))
(defn- semantic-fixture
"One rich file exercising every indexed attribute:
@ -267,16 +296,21 @@
;; the inventory the rest of the suite leans on, pinned once:
;; 22 page shapes + 2 root frames + 2 snapshot shapes = 26 shape
;; entities; 2 pages + the deleted component's snapshot = 3 containers
(t/is (= {:documents 1
:containers 3
:shapes 26
:components 5
:colors 3
:typographies 2
:token-sets 2
:tokens 4
:token-uses 4}
;; entities; 2 pages + the deleted component's snapshot = 3
;; containers; 5 folded token applications (the 4 resolvable uses
;; plus the ghost name, which the encoding stores); 6 copy shapes
;; carrying a shape-ref, all 6 resolved by the builder
(t/is (= {:documents 1
:containers 3
:shapes 26
:components 5
:colors 3
:typographies 2
:token-sets 2
:tokens 4
:token-uses 5
:refs-resolved 6
:refs-carried 6}
(dissoc (queries/stats db) :datoms)))))
(t/deftest components-are-children-of-the-document
@ -292,47 +326,28 @@
(t/is (= (count (:components data)) (count attached)))
(t/is (every? #(= doc-eid (second %)) attached))))
(t/deftest refers-to-pairs-match-shape-refs
(t/deftest refers-to-pairs-match-find-ref-shape
;; beadpot:tests/graph/transform/test_components.py::test_refers_to_edges_match_shape_refs
;; One RefersTo per resolvable shape-ref, each pointing at the referenced
;; shape. Oracle: `ctk/is-main-of?` on the page objects. The rule itself
;; is unscoped; the page scoping here mirrors the Ladybug projection,
;; which materialises page shapes only.
;; One RefersTo per copy shape the helper resolves, each pointing at the
;; shape `ctf/find-ref-shape` names. Oracle: `ctf/find-ref-shape` with
;; `:include-deleted? true` and `:with-context? true`, per copy shape,
;; per container. The builder-resolution retrofit replaced the id-join
;; encoding (`:shape/shape-ref` joined on `:shape/id`) with the helper's
;; answer materialised at build time; the consumer texts (`queries/refers-to-pairs`
;; and the `refers-to` rule) did not move.
(let [{:keys [data db]} (semantic-fixture)
pages (vals (:pages-index data))
pairs (d/q '[:find ?sid ?tid
:in $ %
:where
(on-page ?s)
(refers-to ?s ?t)
(on-page ?t)
[?s :shape/id ?sid]
[?t :shape/id ?tid]]
db queries/rules)
shapes (mapcat #(vals (:objects %)) pages)
refs (filter :shape-ref shapes)
on-page? (fn [id] (some #(contains? (:objects %) id) pages))]
pairs (set (queries/refers-to-pairs db))]
;; every on-page shape with a resolvable :shape-ref has an outgoing pair
(t/is (= (set (map :id (filter #(on-page? (:shape-ref %)) refs)))
(set (map first pairs))))
;; every pair is a main link in the oracle's reading, and the target id
;; equals the source's :shape-ref
(doseq [[sid tid] pairs]
(let [objects (some (fn [p] (when (contains? (:objects p) sid) (:objects p)))
pages)
source (get objects sid)
target (get objects tid)]
(t/is (some? source))
(t/is (ctk/is-main-of? target source))))
;; every pair is the helper's answer: target container and id from
;; the context the helper attaches
(t/is (= (oracle-refs data) pairs))
;; all six copy shapes on the fixture resolve
(t/is (= 6 (count pairs)))))
(t/deftest instance-heads-link-only-to-live-components
;; beadpot:tests/graph/transform/test_components.py::test_all_instance_heads_linked_to_their_component
;; Oracle: `ctk/instance-of?`. The is-instance-of rule scoped to page
;; Oracle: `ctk/instance-of?`. The `instance-of` rule scoped to page
;; shapes must equal a scan of the predicate over the live component
;; records. The deleted component contributes nothing, even though its
;; orphaned main root still passes the raw predicate.
@ -342,7 +357,7 @@
:in $ %
:where
(on-page ?s)
(is-instance-of ?s ?c)
(instance-of ?s ?c)
[?c :component/id ?cid]
[?s :shape/id ?sid]]
db queries/rules))
@ -360,7 +375,7 @@
(t/is (empty? (d/q '[:find [?sid ...]
:in $ % ?cid
:where
(is-instance-of ?s ?c)
(instance-of ?s ?c)
[?c :component/id ?cid]
[?s :shape/id ?sid]]
db queries/rules deleted-id)))
@ -413,18 +428,27 @@
(t/deftest instances-of-matches-an-instance-of-scan
;; beadpot:tests/graph/transform/test_components.py::test_all_instance_heads_linked_to_their_component
;; (the exhaustive complement: the query against the scan)
;; Oracle: `ctk/instance-of?` over every page's objects. The query is the
;; raw index lookup: it does not check whether the component record is
;; live, which is the is-instance-of rule's business, so the scan runs
;; over every component record, deleted ones included.
;; Oracle: `ctk/instance-of?` over every page's objects. The standing
;; query traverses the `instance-of` rule, whose live-component guard
;; is the rule's business, so the scan runs over the live component
;; records only; the deleted component's orphaned main root is pinned
;; below to answer nothing.
(let [{:keys [data db]} (semantic-fixture)]
(doseq [component (vals (:components data))]
(doseq [component (ctkl/components-seq data)]
(let [expected (set (for [[pid page] (:pages-index data)
[sid shape] (:objects page)
:when (ctk/instance-of? shape (:id data) (:id component))]
[pid sid]))]
(t/is (= expected (set (queries/instances-of db (:id component) (:id data))))
(str "instances of " (:name component)))))))
(str "instances of " (:name component)))))
;; the deleted component: the rule's live guard answers nothing,
;; while the raw predicate still sees the orphaned main root
(let [deleted-id (thi/id :comp-2)]
(t/is (empty? (queries/instances-of db deleted-id (:id data))))
(let [main-root (get-in data [:pages-index (thi/id :main-page)
:objects (thi/id :comp-2-root)])]
(t/is (ctk/instance-of? main-root (:id data) deleted-id))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; descendants and identity
@ -438,7 +462,7 @@
;; must resolve through `queries/shape-eid`. The overlay does NOT
;; denormalize component-id downward (beadpot and Ladybug do): the
;; [?a :shape/component-id _] datom must equal `ctk/instance-head?`
;; exactly, or the is-instance-of rule stops answering `ctk/instance-of?`.
;; exactly, or the `instance-of` rule stops answering `ctk/instance-of?`.
;; Oracle: `cfh/get-children-ids` and `ctk/instance-head?`.
(let [{:keys [data db]} (semantic-fixture)
page1-id (thi/id :main-page)
@ -487,6 +511,46 @@
(when (:component-id shape)
(t/is (= (:component-id shape) (:shape/component-id entity))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Euler-tour numbering
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(t/deftest euler-intervals-equal-the-walk-and-are-globally-disjoint-or-nested
;; No beadpot counterpart. The Euler-tour retrofit's two invariants:
;; (1) the interval form answers the recursive form, and both equal
;; `cfh/get-children-ids` (the oracle) for every frame of every
;; container; (2) one global counter numbers every container
;; (`app.graph.overlay/euler-numbering` threads it file-wide), so
;; [enter exit] intervals across the whole file are pairwise
;; disjoint-or-nested — a partial overlap is the signature of the
;; per-container-counter bug the 20260820 report guards against.
(let [{:keys [data db]} (semantic-fixture)]
(doseq [[cid objects] (document-containers data)
shape (vals objects)
:when (= :frame (:type shape))]
(let [sid (:id shape)
expected (set (cfh/get-children-ids objects sid))]
(t/is (= expected (queries/descendant-ids db cid sid))
(str "interval descendants of " sid))
(t/is (= expected (queries/descendant-ids-walk db cid sid))
(str "walk descendants of " sid))))
;; the global-counter claim: every [enter exit] pair across all
;; containers is disjoint or properly nested, never partially
;; overlapping
(let [enters (into {} (map (juxt :e :v)) (d/datoms db :avet :shape/enter))
exits (into {} (map (juxt :e :v)) (d/datoms db :avet :shape/exit))
intervals (mapv (fn [[eid enter]] [enter (get exits eid)]) enters)
ok? (fn [[e0 e1] [f0 f1]]
(or (<= e1 f0) (<= f1 e0)
(and (< e0 f0) (< f1 e1))
(and (< f0 e0) (< e1 f1))))]
(doseq [i (range (count intervals))
j (range (inc i) (count intervals))]
(t/is (ok? (nth intervals i) (nth intervals j))
(str "intervals " (pr-str (nth intervals i)) " and "
(pr-str (nth intervals j)) " partially overlap"))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; swap slots
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -573,9 +637,10 @@
;; plus ::test_shared_token_has_multiple_incoming_edges and
;; ::test_same_token_two_attributes_yields_two_edges
;; Oracle: a scan of every container's :applied-tokens, restricted to
;; names the lib defines; the overlay's token-use entities must equal it.
;; beadpot's enum-key parsing test is a document-format concern that
;; Clojure keywords make moot.
;; names the lib defines. The consumer texts are unchanged; underneath,
;; the token-use entities are gone and the `uses-token` rule reads the
;; folded token attributes instead. beadpot's enum-key parsing test is a
;; document-format concern that Clojure keywords make moot.
(let [{:keys [data db]} (semantic-fixture)
lib-names (into #{} (map :name) (ctob/get-all-tokens (:tokens-lib data)))
expected (set (for [[cid objects] (document-containers data)
@ -586,7 +651,10 @@
actual (set (mapcat #(queries/shapes-using-token db %) lib-names))]
(t/is (= expected actual))
(t/is (= 4 (:token-uses (queries/stats db))))
;; 5 folded applications on the fixture: the 4 resolvable uses the
;; rule surfaces, plus the ghost name the encoding still stores
(t/is (= 5 (:token-uses (queries/stats db))))
;; a token applied by two shapes has two uses
(let [shared (queries/shapes-using-token db "color.fill")]
@ -599,8 +667,16 @@
(t/is (= 1 (count (set (map second two-attrs)))))
(t/is (= #{:width :height} (set (map #(nth % 2) two-attrs)))))
;; a name the lib never defines produces no edge
(t/is (empty? (queries/shapes-using-token db "ghost.token")))))
;; a name the lib never defines produces no edge...
(t/is (empty? (queries/shapes-using-token db "ghost.token")))
;; ...but the folded encoding stores it: the datom is present, the
;; rule hides it (its join on :token/name finds no entity)
(let [ghost-eid (queries/shape-eid db (queries/container-eid db (thi/id :main-page))
(thi/id :ghost-rect))]
(t/is (= "ghost.token" (:token/fill (d/entity db ghost-eid))))
(t/is (= [[:token/fill "ghost.token"]]
(map (juxt :a :v) (d/datoms db :eavt ghost-eid :token/fill)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; colors and typographies
@ -660,6 +736,96 @@
(t/is (empty? (queries/shapes-using-color db (thi/id :color-ghost))))
(t/is (empty? (queries/shapes-using-typography db (thi/id :typo-ghost))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; the R1 invariance pin
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def ^:private control-symbols
"Clause heads that structure a query rather than call a function, the
console gate's own list (`app.graph.overlay.console`)."
'#{not not-join or or-join and pull})
(def ^:private rule-names
(into #{} (map (comp first first)) queries/rules))
(def ^:private allowed-query-symbols
"The closed call vocabulary: the shared rules, datascript's built-in
query fns and aggregates, and the control forms — exactly the set the
console gate admits."
(-> #{}
(into (keys bi/query-fns))
(into (keys bi/aggregates))
(into control-symbols)
(into rule-names)))
(defn- query-call-symbols
"Every symbol in call position: heads of list clauses (rule
invocations, predicates, control forms). Mirrors the console gate's
walk over the query form."
[form]
(cond
(seq? form)
(into (if (symbol? (first form)) [(first form)] [])
(mapcat query-call-symbols)
(rest form))
(coll? form)
(into [] (mapcat query-call-symbols) form)
:else []))
(t/deftest consumer-query-texts-invoke-only-shared-rules
;; The R1 invariance claim. The 20260820 report verified the same
;; consumer query texts across the pre-retrofit and post-retrofit
;; encodings (docs.local/graph/20260820-report-graph-overlay-datascript.md);
;; this test holds two of them — instances inside a subtree, shapes
;; using a token — written once, runs them against the current
;; encoding, and pins that their call positions name only shared rules
;; and datascript built-ins. A text that cannot see an encoding cannot
;; break when the encoding changes.
(let [{:keys [data db]} (semantic-fixture)
lib-names (into #{} (map :name) (ctob/get-all-tokens (:tokens-lib data)))
instances-in-subtree
'[:find ?pid ?id
:in $ % ?cid ?sid
:where
[?c :container/id ?cid]
[?s :shape/container ?c]
[?s :shape/id ?sid]
(descendant-of ?i ?s)
(instance-of ?i ?comp)
[?i :shape/container ?pc]
[?pc :container/id ?pid]
[?i :shape/id ?id]]
shapes-using-token
'[:find ?cid ?id
:in $ % ?name
:where
[?tok :token/name ?name]
(uses-token ?s ?tok)
[?s :shape/container ?c]
[?c :container/id ?cid]
[?s :shape/id ?id]]]
;; the texts answer on the current encoding: instances inside
;; comp-c's root are exactly the nested comp-a head
(t/is (= #{[(thi/id :main-page) (thi/id :nested-a)]}
(set (d/q instances-in-subtree db queries/rules
(thi/id :main-page) (thi/id :comp-c-root)))))
;; and every token text's answer equals the standing fn's
(doseq [name lib-names]
(t/is (= (set (map #(subvec % 0 2) (queries/shapes-using-token db name)))
(set (d/q shapes-using-token db queries/rules name)))
(str "token query text on " name)))
;; the texts only reference rule names: every list-clause head is a
;; shared rule or a datascript built-in, nothing else
(doseq [q [instances-in-subtree shapes-using-token]]
(doseq [sym (query-call-symbols q)]
(t/is (contains? allowed-query-symbols sym)
(str "call symbol " sym " in " (pr-str q)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; parity counting
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -669,13 +835,20 @@
;; so the parity fn itself is pinned: page shapes minus root frames,
;; pages, and live components. 22 page shapes + 2 pages + 4 live
;; components = 28 IsChildOf; 8 on-page instance heads against live
;; components; 6 on-page resolvable shape-refs; 1 on-page swap slot.
;; components; 1 on-page swap slot. `:refers-to` now counts the
;; builder-resolved page->page references (the `refers-to` rule scoped
;; to page shapes on both sides), not id-join pairs: the derivation
;; below reads `ctf/find-ref-shape`'s answer per copy shape and keeps
;; the page->page ones. On this fixture every copy resolves to a live
;; main on a page, so the count is still 6 — the encoding changed, the
;; number did not.
(let [{:keys [data db]} (semantic-fixture)
pages (vals (:pages-index data))
page-shapes (remove #(= uuid/zero (:id %))
(mapcat #(vals (:objects %)) pages))
live-comps (ctkl/components-seq data)
on-page? (fn [id] (some #(contains? (:objects %) id) pages))
shape-on-page? (fn [id] (some #(contains? (:objects %) id) pages))
page-container? (fn [cid] (contains? (:pages-index data) cid))
live-head? (fn [shape]
(some (fn [component]
(ctk/instance-of? shape (:id data) (:id component)))
@ -684,11 +857,11 @@
(count pages)
(count live-comps))
:is-instance-of (count (filter live-head? page-shapes))
:refers-to (count (filter #(and (:shape-ref %)
(on-page? (:shape-ref %)))
page-shapes))
:refers-to (count (filter (fn [[_scid _sid tcid _tid]]
(page-container? tcid))
(oracle-refs data)))
:fills-swap-slot (count (filter #(let [slot (ctk/get-swap-slot %)]
(and slot (on-page? slot)))
(and slot (shape-on-page? slot)))
page-shapes))}]
(t/is (= derived (queries/ladybug-parity-counts db)))