mirror of
https://github.com/penpot/penpot.git
synced 2026-11-09 03:20:57 +00:00
5d54f5ffa1
- Shared macro expansion for shapes and containers. - Shared runtime construction for rectangles, paths, and circles. - Centralized container attribute validation. - Simplified imports in the seven callers. - Added behaviour tests for seeded IDs, defaults, expression evaluation order, and container failures. AI-assisted-by: gpt-6.1-sol
514 lines
21 KiB
Clojure
514 lines
21 KiB
Clojure
;; This Source Code Form is subject to the terms of the Mozilla Public
|
|
;; License, v. 2.0. If a copy of the MPL was not distributed with this
|
|
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
|
;;
|
|
;; Copyright (c) KALEIDOS SUBSIDIARY SL
|
|
|
|
(ns benches.render-wasm.builder
|
|
"Seeded construction of benchmark scenes.
|
|
|
|
A `scene` consists of one seeded number generator, one object map, and one
|
|
label map.
|
|
|
|
Shape and container calls attach objects to the current parent in evaluation
|
|
order. Coordinates are page-relative. Frames use authored bounds; groups and
|
|
booleans derive geometry from their children after the body completes.
|
|
|
|
`scene` accepts a required :seed, optional :root attributes and :defaults.
|
|
It returns a validated snapshot with :objects and :refs. Labels name objects
|
|
within that snapshot. A container whose body or finalizer throws becomes
|
|
unfinished, and `finish!` rejects the snapshot.
|
|
|
|
Default attributes follow the same theme: `*defaults*` maps a shape type to
|
|
an attribute generator map, bound by the `scene` macro from the scope
|
|
params. Per-shape attrs are merged over the generated values, so a recipe
|
|
can override values locally and rebind `*defaults*` around a section.
|
|
|
|
Ordinary :require loads the macros and runtime helpers. Scene bodies support
|
|
let, doseq and calls to functions defined outside the scope."
|
|
#?(:cljs (:require-macros [benches.render-wasm.builder]))
|
|
#?(:cljs
|
|
(:require
|
|
[app.common.data :as d]
|
|
[app.common.files.helpers :as cfh]
|
|
[app.common.geom.shapes :as gsh]
|
|
[app.common.types.path :as path]
|
|
[app.common.types.shape :as cts]
|
|
[app.common.types.shape-tree :as ctst]
|
|
[app.common.uuid :as uuid]
|
|
[benches.render-wasm.random :as rnd :refer
|
|
[rng-float rng-hex-color rng-int rng-opacity rng-uuid]]
|
|
[benches.render-wasm.snapshot :as snapshot])))
|
|
|
|
#?(:clj
|
|
(do
|
|
(defn- emit-shape
|
|
[constructor label attrs]
|
|
`(~constructor
|
|
benches.render-wasm.builder/*state*
|
|
benches.render-wasm.builder/*defaults*
|
|
~label
|
|
~attrs))
|
|
|
|
(defn- emit-container
|
|
[type label-or-attrs body]
|
|
(let [labeled? (or (keyword? label-or-attrs) (vector? label-or-attrs))
|
|
attrs (if labeled? (first body) label-or-attrs)
|
|
label (when labeled? label-or-attrs)
|
|
body (if labeled? (rest body) body)]
|
|
`(benches.render-wasm.builder/with-container
|
|
~type ~attrs ~label (fn [] ~@body))))
|
|
|
|
(defmacro scene
|
|
"Runs `body` in a scene scope and returns the validated snapshot."
|
|
[params & body]
|
|
`(let [params# ~params
|
|
state# (benches.render-wasm.builder/start params#)]
|
|
(binding [benches.render-wasm.builder/*state* state#
|
|
benches.render-wasm.builder/*defaults* (:defaults params#)]
|
|
~@body
|
|
(benches.render-wasm.builder/finish! state#))))
|
|
|
|
(defmacro rect
|
|
"Adds a rectangle and returns its uuid.
|
|
|
|
Forms: (rect), (rect attrs), (rect label), (rect label attrs).
|
|
A single map argument supplies attributes; keywords and vectors label
|
|
the object in :refs. Attributes override the generated defaults."
|
|
([]
|
|
(emit-shape 'benches.render-wasm.builder/rect! nil {}))
|
|
([label-or-attrs]
|
|
(emit-shape 'benches.render-wasm.builder/rect! label-or-attrs {}))
|
|
([label attrs]
|
|
(emit-shape 'benches.render-wasm.builder/rect! label attrs)))
|
|
|
|
(defmacro path
|
|
"Adds a path and returns its uuid.
|
|
|
|
Forms: (path), (path attrs), (path label), (path label attrs).
|
|
A single map argument supplies attributes; keywords and vectors label
|
|
the object in :refs. Attributes override the generated defaults."
|
|
([]
|
|
(emit-shape 'benches.render-wasm.builder/path! nil {}))
|
|
([label-or-attrs]
|
|
(emit-shape 'benches.render-wasm.builder/path! label-or-attrs {}))
|
|
([label attrs]
|
|
(emit-shape 'benches.render-wasm.builder/path! label attrs)))
|
|
|
|
(defmacro circle
|
|
"Adds an ellipse and returns its uuid.
|
|
|
|
Forms: (circle), (circle attrs), (circle label), (circle label attrs).
|
|
A single map argument supplies attributes; keywords and vectors label
|
|
the object in :refs. Attributes override the generated defaults."
|
|
([]
|
|
(emit-shape 'benches.render-wasm.builder/circle! nil {}))
|
|
([label-or-attrs]
|
|
(emit-shape 'benches.render-wasm.builder/circle! label-or-attrs {}))
|
|
([label attrs]
|
|
(emit-shape 'benches.render-wasm.builder/circle! label attrs)))
|
|
|
|
(defmacro frame
|
|
"Adds a frame, runs `body` with the frame as parent, and returns its uuid.
|
|
|
|
Forms: (frame attrs & body), (frame label attrs & body).
|
|
A keyword or vector form supplies a label in :refs. Attributes must
|
|
carry numeric :x :y :width :height. Children use page-relative
|
|
coordinates. Frames allow an empty body."
|
|
[label-or-attrs & body]
|
|
(emit-container :frame label-or-attrs body))
|
|
|
|
(defmacro group
|
|
"Adds a group, runs `body` with the group as parent, and returns its uuid.
|
|
|
|
Forms: (group attrs & body), (group label attrs & body).
|
|
A keyword or vector form supplies a label in :refs. Groups derive their
|
|
geometry from children and require at least one child. With
|
|
:masked-group true, the first child supplies the mask geometry."
|
|
[label-or-attrs & body]
|
|
(emit-container :group label-or-attrs body))
|
|
|
|
(defmacro bool
|
|
"Adds a boolean shape, runs `body` with it as parent, and returns its uuid.
|
|
|
|
Forms: (bool attrs & body), (bool label attrs & body).
|
|
A keyword or vector form supplies a label in :refs. Attributes require
|
|
:bool-type :union, :difference, :intersection or :exclude.
|
|
|
|
Content and geometry derive from the children. Styles inherit from the
|
|
first child for :difference and the last child otherwise; supplied
|
|
non-nil styles take precedence. A bool requires at least one child and
|
|
accepts paths, rectangles, ellipses, groups and other booleans."
|
|
[label-or-attrs & body]
|
|
(emit-container :bool label-or-attrs body))))
|
|
|
|
#?(:cljs
|
|
(do
|
|
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Attribute generators
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defn gen-int
|
|
"Integer generator over `[min, max)`."
|
|
[min max]
|
|
(fn [rng] (rng-int rng min max)))
|
|
|
|
(defn gen-float
|
|
"Float generator rounded to three decimals so snapshots stay readable."
|
|
[min max]
|
|
(fn [rng] (rnd/round3 (rng-float rng min max))))
|
|
|
|
(defn gen-hex-color
|
|
"Generator of a random `#rrggbb` string."
|
|
[]
|
|
(fn [rng] (rng-hex-color rng)))
|
|
|
|
(defn gen-one-of
|
|
"Generator that picks one value per draw. Rejects an empty collection."
|
|
[values]
|
|
(when (empty? values)
|
|
(throw (ex-info "gen-one-of requires at least one value"
|
|
{:type ::no-values})))
|
|
(fn [rng] (nth values (rng-int rng 0 (count values)))))
|
|
|
|
(defn gen-fill
|
|
"Generator of one translucent solid fill."
|
|
[]
|
|
(fn [rng]
|
|
{:fill-color (rng-hex-color rng)
|
|
:fill-opacity (rng-opacity rng)}))
|
|
|
|
(defn gen-stroke
|
|
"Centered stroke like the interim rectangle workload."
|
|
[width]
|
|
(fn [rng]
|
|
{:stroke-width width
|
|
:stroke-alignment :center
|
|
:stroke-color (rng-hex-color rng)
|
|
:stroke-opacity (rng-opacity rng)}))
|
|
|
|
(defn gen-vector
|
|
"Composes generators into a generator of a vector, one value per generator."
|
|
[& generators]
|
|
(fn [rng] (mapv #(% rng) generators)))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Scope state
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(def ^:dynamic *state*
|
|
"Current scene scope; bound by the `scene` macro."
|
|
nil)
|
|
|
|
(def ^:dynamic *defaults*
|
|
"Per-shape-type attribute generator maps bound by the `scene` macro,
|
|
e.g. `{:rect {:x (gen-int 0 1920) ...}}`. Values are literals or one-arg
|
|
functions of the scope random source."
|
|
{})
|
|
|
|
(def ^:dynamic *parent*
|
|
"Current insertion point as `{:id parent-id :frame-id containing-frame}`;
|
|
bound by the container scopes, `uuid/zero` at the top."
|
|
{:id uuid/zero :frame-id uuid/zero})
|
|
|
|
(defn- check-seed!
|
|
"Requires a scene seed from 0 through 4294967295, retaining the builder
|
|
error type."
|
|
[seed]
|
|
(when-not (rnd/seed? seed)
|
|
(throw (ex-info "scene scope requires an integer :seed in [0, 2^32)"
|
|
{:type ::invalid-seed
|
|
:seed seed}))))
|
|
|
|
(defn start
|
|
"Starts a scene scope and returns its state atom with objects, refs and :rng.
|
|
The seeded generator belongs to this scope; other scopes and report draws
|
|
cannot advance its state."
|
|
[params]
|
|
(when (some? *state*)
|
|
(throw (ex-info "scene scopes cannot nest"
|
|
{:type ::nested-scope})))
|
|
(check-seed! (:seed params))
|
|
(let [seed (:seed params)
|
|
root (cts/setup-shape (merge (:root params)
|
|
{:id uuid/zero
|
|
:type :frame
|
|
:name "Root Frame"
|
|
:parent-id uuid/zero
|
|
:frame-id uuid/zero
|
|
:shapes []}))]
|
|
(atom {:seed seed
|
|
:rng (rnd/create seed)
|
|
:objects {uuid/zero root}
|
|
:refs {}
|
|
:unfinished {}})))
|
|
|
|
(defn- ensure-state
|
|
[state]
|
|
(or state
|
|
(throw (ex-info "shape used outside a scene scope"
|
|
{:type ::outside-scope}))))
|
|
|
|
(defn- resolve-attr
|
|
[rng spec]
|
|
(if (fn? spec) (spec rng) spec))
|
|
|
|
(defn- resolve-attrs
|
|
[rng defaults attrs]
|
|
(merge (reduce-kv (fn [result key spec]
|
|
(assoc result key (resolve-attr rng spec)))
|
|
{}
|
|
defaults)
|
|
attrs))
|
|
|
|
(defn- register-ref!
|
|
[state label id]
|
|
(when (some? label)
|
|
(when (contains? (:refs @state) label)
|
|
(throw (ex-info (str "duplicate scene label: " label)
|
|
{:type ::duplicate-label
|
|
:label label})))
|
|
(swap! state assoc-in [:refs label] id)))
|
|
|
|
(defn- add-object!
|
|
"Inserts `shape` under the current parent and registers `label`."
|
|
[state label shape]
|
|
(let [{:keys [id frame-id]} *parent*]
|
|
(register-ref! state label (:id shape))
|
|
(swap! state
|
|
(fn [scope]
|
|
(ctst/add-shape (:id shape) shape scope frame-id id nil true)))))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Shape constructors
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defn- normalize-label-and-attrs
|
|
"Resolves map attributes and keyword/vector labels for shape construction."
|
|
[label attrs]
|
|
(cond
|
|
(and (map? label) (empty? attrs)) [nil label]
|
|
(nil? label) [nil attrs]
|
|
(or (keyword? label) (vector? label)) [label attrs]
|
|
:else (throw (ex-info "rect label must be a keyword or vector"
|
|
{:type ::invalid-label
|
|
:label label}))))
|
|
|
|
(defn- construct-shape
|
|
[state defaults type label attrs]
|
|
(let [state (ensure-state state)
|
|
[label attrs] (normalize-label-and-attrs label attrs)
|
|
rng (:rng @state)
|
|
attrs (resolve-attrs rng (get defaults type) attrs)
|
|
id (rng-uuid rng)
|
|
shape (cts/setup-shape (merge attrs
|
|
{:id id
|
|
:type type}))]
|
|
(add-object! state label shape)
|
|
id))
|
|
|
|
(defn rect!
|
|
"Adds a rectangle with the selected defaults and attributes, returning its uuid."
|
|
[state defaults label attrs]
|
|
(construct-shape state defaults :rect label attrs))
|
|
|
|
(defn path!
|
|
"Adds a path with the selected defaults and attributes, returning its uuid."
|
|
[state defaults label attrs]
|
|
(construct-shape state defaults :path label attrs))
|
|
|
|
(defn circle!
|
|
"Adds an ellipse with the selected defaults and attributes, returning its uuid."
|
|
[state defaults label attrs]
|
|
(construct-shape state defaults :circle label attrs))
|
|
|
|
(def ^:private frame-bounds-keys
|
|
"Frames do not derive their bounds from children."
|
|
[:x :y :width :height])
|
|
|
|
(def ^:private group-geometry-keys
|
|
"Group geometry derives from its children."
|
|
[:x :y :width :height :selrect :points])
|
|
|
|
(def ^:private bool-geometry-keys
|
|
"Bool geometry, content and placement derive from its children."
|
|
[:x :y :width :height :selrect :points :content])
|
|
|
|
(def ^:private bool-transform-keys
|
|
"Construction does not accept transforms: `path/update-geometry` would
|
|
pivot them on the empty pre-finalization selrect."
|
|
[:transform :transform-inverse :rotation :flip-x :flip-y])
|
|
|
|
(defn- reject-attrs!
|
|
"Throws when `attrs` carries any of `attr-keys`. Shared by containers
|
|
whose geometry or content derives from their children."
|
|
[attrs id error-type message attr-keys]
|
|
(doseq [key attr-keys]
|
|
(when (some? (get attrs key))
|
|
(throw (ex-info message
|
|
{:type error-type
|
|
:id id
|
|
:key key})))))
|
|
|
|
(defn- setup-frame
|
|
[id attrs]
|
|
(doseq [key frame-bounds-keys]
|
|
(let [value (get attrs key)]
|
|
(cond
|
|
(nil? value)
|
|
(throw (ex-info "frame requires :x :y :width :height"
|
|
{:type ::frame-bounds
|
|
:id id
|
|
:missing key}))
|
|
|
|
(not (d/num? value))
|
|
(throw (ex-info "frame bounds must be numbers"
|
|
{:type ::frame-bounds
|
|
:id id
|
|
:invalid key})))))
|
|
(cts/setup-shape (assoc attrs :id id :type :frame)))
|
|
|
|
(defn- setup-group
|
|
[id attrs]
|
|
(reject-attrs! attrs id ::group-geometry
|
|
"group derives its geometry from children"
|
|
group-geometry-keys)
|
|
(cts/setup-shape (assoc attrs :id id :type :group)))
|
|
|
|
(defn- setup-bool
|
|
[id attrs]
|
|
(reject-attrs! attrs id ::bool-geometry
|
|
"bool derives its geometry and content from children"
|
|
bool-geometry-keys)
|
|
(reject-attrs! attrs id ::bool-transform
|
|
"bool construction does not accept transforms"
|
|
bool-transform-keys)
|
|
(when-not (contains? cts/bool-types (:bool-type attrs))
|
|
(throw (ex-info "bool requires :bool-type :union :difference :intersection or :exclude"
|
|
{:type ::bool-type
|
|
:id id
|
|
:bool-type (:bool-type attrs)
|
|
:supported cts/bool-types})))
|
|
(cts/setup-shape (assoc attrs :id id :type :bool)))
|
|
|
|
(defn- bool-head
|
|
"Canonical style head: the first child is the base for `:difference`, the
|
|
last child otherwise."
|
|
[bool-shape children]
|
|
(if (= :difference (:bool-type bool-shape))
|
|
(first children)
|
|
(last children)))
|
|
|
|
(defn- finalize-bool!
|
|
[state id]
|
|
(let [scope @state
|
|
bool (get-in scope [:objects id])
|
|
children (mapv (:objects scope) (:shapes bool))]
|
|
(when (empty? children)
|
|
(throw (ex-info "bool requires at least one child"
|
|
{:type ::empty-bool
|
|
:id id})))
|
|
(when-let [frame (first (filter cfh/frame-shape? children))]
|
|
(throw (ex-info "bool children cannot be frames"
|
|
{:type ::frame-in-bool
|
|
:id id
|
|
:child (:id frame)})))
|
|
(let [inherited (d/without-nils
|
|
(select-keys (bool-head bool children)
|
|
path/bool-style-properties))
|
|
supplied (d/without-nils
|
|
(select-keys (get-in scope [:container-attrs id])
|
|
path/bool-style-properties))
|
|
bool (-> bool (merge inherited) (merge supplied))
|
|
|
|
;; `path/update-bool-shape` dispatches to `path/wasm:calc-bool-content`,
|
|
;; the renderer override, so scene content would depend on renderer
|
|
;; initialization and A/B configuration. Compose the pure helpers:
|
|
;; scene generation is untimed and must not vary with the renderer
|
|
;; being compared.
|
|
content (path/calc-bool-content bool (:objects scope))
|
|
bool (path/update-geometry bool content)]
|
|
(swap! state assoc-in [:objects id] bool))))
|
|
|
|
(defn- finalize-group!
|
|
[state id]
|
|
(let [scope @state
|
|
group (get-in scope [:objects id])
|
|
children (mapv (:objects scope) (:shapes group))]
|
|
(when (empty? children)
|
|
(throw (ex-info "group requires at least one child"
|
|
{:type ::empty-group
|
|
:id id})))
|
|
(let [group (if (:masked-group group)
|
|
(gsh/update-mask-selrect group children)
|
|
(gsh/update-group-selrect group children))]
|
|
(swap! state assoc-in [:objects id] group))))
|
|
|
|
(def ^:private container-specs
|
|
"Per-container behavior: how to build it, which parent scope it opens,
|
|
and how to finalize it after the body. `:keep-attrs?` records the raw
|
|
attrs in the scope so the finalizer can let supplied styles win over
|
|
inherited ones."
|
|
{:frame {:setup setup-frame
|
|
:parent (fn [id _parent] {:id id :frame-id id})
|
|
:finalize (fn [_state _id] nil)}
|
|
:group {:setup setup-group
|
|
:parent (fn [id parent] {:id id :frame-id (:frame-id parent)})
|
|
:finalize finalize-group!}
|
|
:bool {:setup setup-bool
|
|
:parent (fn [id parent] {:id id :frame-id (:frame-id parent)})
|
|
:finalize finalize-bool!
|
|
:keep-attrs? true}})
|
|
|
|
(defn- check-container-attrs
|
|
[type id attrs]
|
|
(when-not (map? attrs)
|
|
(throw (ex-info (str (name type) " attrs must be a map; the label form takes the attrs map next")
|
|
{:type ::invalid-attrs :id id})))
|
|
attrs)
|
|
|
|
(defn with-container
|
|
"Creates a frame, group or bool, runs `thunk` with the new parent in
|
|
scope, finalizes the containers that derive state from children, and
|
|
returns the container uuid.
|
|
|
|
Any exception from the body or the finalizer marks the container
|
|
unfinished and propagates; `finish!` then rejects the instance even if the
|
|
caller catches the exception."
|
|
[type attrs label thunk]
|
|
(let [{:keys [setup parent finalize keep-attrs?]}
|
|
(or (get container-specs type)
|
|
(throw (ex-info "unsupported container type"
|
|
{:type ::invalid-container
|
|
:container-type type})))
|
|
state (ensure-state *state*)
|
|
id (rng-uuid (:rng @state))
|
|
attrs (check-container-attrs type id attrs)
|
|
shape (setup id attrs)]
|
|
(when keep-attrs?
|
|
(swap! state assoc-in [:container-attrs id] attrs))
|
|
(add-object! state label shape)
|
|
(binding [*parent* (parent id *parent*)]
|
|
(try
|
|
(thunk)
|
|
(finalize state id)
|
|
(catch :default cause
|
|
(swap! state assoc-in [:unfinished id] true)
|
|
(throw cause))))
|
|
id))
|
|
|
|
(defn finish!
|
|
"Validates the scope snapshot and returns it."
|
|
[state]
|
|
(let [{:keys [objects refs unfinished]} @state]
|
|
(when (seq unfinished)
|
|
(throw (ex-info "scene contains an unfinished container"
|
|
{:type ::unfinished-container
|
|
:ids (vec (keys unfinished))})))
|
|
(let [instance {:objects objects
|
|
:refs refs}]
|
|
(snapshot/validate! instance)
|
|
instance)))))
|