🎉 Add first impl of wasm-friendly for Shape data structure

common/src/app/common/geom/shapes/transforms.cljc

@@ -280,7 +280,7 @@
         transform  (calculate-transform points center selrect)]
     [selrect transform (when (some? transform) (gmt/inverse transform))]))
 
-(defn- adjust-shape-flips!
+(defn- adjust-shape-flips
   "After some tranformations the flip-x/flip-y flags can change we need
   to check this before adjusting the selrect"
   [shape points]
@@ -299,16 +299,16 @@
 
     (cond-> shape
       (neg? dot-x)
-      (cr/update! :flip-x not)
+      (update :flip-x not)
 
       (neg? dot-x)
-      (cr/update! :rotation -)
+      (update :rotation -)
 
       (neg? dot-y)
-      (cr/update! :flip-y not)
+      (update :flip-y not)
 
       (neg? dot-y)
-      (cr/update! :rotation -))))
+      (update :rotation -))))
 
 (defn- apply-transform-move
   "Given a new set of points transformed, set up the rectangle so it keeps
@@ -318,9 +318,6 @@
         points  (gco/transform-points  (dm/get-prop shape :points) transform-mtx)
         selrect (gco/transform-selrect (dm/get-prop shape :selrect) transform-mtx)
 
-        ;; NOTE: ensure we start with a fresh copy of shape for mutabilty
-        shape   (cr/clone shape)
-
         shape   (if (= type :bool)
                   (update shape :bool-content gpa/transform-content transform-mtx)
                   shape)
@@ -329,14 +326,14 @@
                   shape)
         shape   (if (= type :path)
                   (update shape :content gpa/transform-content transform-mtx)
-                  (cr/assoc! shape
+                  (assoc shape
-                             :x (dm/get-prop selrect :x)
+                         :x (dm/get-prop selrect :x)
-                             :y (dm/get-prop selrect :y)
+                         :y (dm/get-prop selrect :y)
-                             :width (dm/get-prop selrect :width)
+                         :width (dm/get-prop selrect :width)
-                             :height (dm/get-prop selrect :height)))]
+                         :height (dm/get-prop selrect :height)))]
     (-> shape
-        (cr/assoc! :selrect selrect)
+        (assoc :selrect selrect)
-        (cr/assoc! :points points))))
+        (assoc :points points))))
 
 
 (defn- apply-transform-generic
@@ -346,9 +343,7 @@
   (let [points    (-> (dm/get-prop shape :points)
                       (gco/transform-points transform-mtx))
 
-        ;; NOTE: ensure we have a fresh shallow copy of shape
+        shape     (adjust-shape-flips shape points)
-        shape     (cr/clone shape)
-        shape     (adjust-shape-flips! shape points)
 
         center    (gco/points->center points)
         selrect   (calculate-selrect points center)
@@ -367,17 +362,17 @@
 
             shape    (if (= type :path)
                        (update shape :content gpa/transform-content transform-mtx)
-                       (cr/assoc! shape
+                       (assoc shape
-                                  :x (dm/get-prop selrect :x)
+                              :x (dm/get-prop selrect :x)
-                                  :y (dm/get-prop selrect :y)
+                              :y (dm/get-prop selrect :y)
-                                  :width (dm/get-prop selrect :width)
+                              :width (dm/get-prop selrect :width)
-                                  :height (dm/get-prop selrect :height)))]
+                              :height (dm/get-prop selrect :height)))]
         (-> shape
-            (cr/assoc! :transform transform)
+            (assoc :transform transform)
-            (cr/assoc! :transform-inverse inverse)
+            (assoc :transform-inverse inverse)
-            (cr/assoc! :selrect selrect)
+            (assoc :selrect selrect)
-            (cr/assoc! :points points)
+            (assoc :points points)
-            (cr/assoc! :rotation rotation))))))
+            (assoc :rotation rotation))))))
 
 (defn- apply-transform
   "Given a new set of points transformed, set up the rectangle so it keeps

common/src/app/common/record.cljc

@@ -403,30 +403,30 @@
                 nil)))
        ~rsym)))
 
-(defmacro clone
+;; (defmacro clone
-  [ssym]
+;;   [ssym]
-  (if (:ns &env)
+;;   (if (:ns &env)
-    `(cljs.core/clone ~ssym)
+;;     `(cljs.core/clone ~ssym)
-    ssym))
+;;     ssym))
 
-(defmacro assoc!
+;; (defmacro assoc!
-  "A record specific update operation"
+;;   "A record specific update operation"
-  [ssym & pairs]
+;;   [ssym & pairs]
-  (if (:ns &env)
+;;   (if (:ns &env)
-    (let [pairs (partition-all 2 pairs)]
+;;     (let [pairs (partition-all 2 pairs)]
-      `(-> ~ssym
+;;       `(-> ~ssym
-           ~@(map (fn [[ks vs]]
+;;            ~@(map (fn [[ks vs]]
-                    `(cljs.core/-assoc! ~ks ~vs))
+;;                     `(cljs.core/-assoc! ~ks ~vs))
-                  pairs)))
+;;                   pairs)))
-    `(assoc ~ssym ~@pairs)))
+;;     `(assoc ~ssym ~@pairs)))
 
-(defmacro update!
+;; (defmacro update!
-  "A record specific update operation"
+;;   "A record specific update operation"
-  [ssym ksym f & params]
+;;   [ssym ksym f & params]
-  (if (:ns &env)
+;;   (if (:ns &env)
-    (let [ssym (with-meta ssym {:tag 'js})]
+;;     (let [ssym (with-meta ssym {:tag 'js})]
-      `(cljs.core/assoc! ~ssym ~ksym (~f (. ~ssym ~(property-symbol ksym)) ~@params)))
+;;       `(cljs.core/assoc! ~ssym ~ksym (~f (. ~ssym ~(property-symbol ksym)) ~@params)))
-    `(update ~ssym ~ksym ~f ~@params)))
+;;     `(update ~ssym ~ksym ~f ~@params)))
 
 (defmacro define-properties!
   "Define properties in the prototype with `.defineProperty`"

common/src/app/common/types/shape.cljc

@@ -19,6 +19,7 @@
    [app.common.schema.generators :as sg]
    [app.common.transit :as t]
    [app.common.types.color :as ctc]
+   [app.common.types.shape.impl :as impl]
    [app.common.types.grid :as ctg]
    [app.common.types.plugins :as ctpg]
    [app.common.types.shape.attrs :refer [default-color]]
@@ -36,7 +37,7 @@
 
 (defn shape?
   [o]
-  (instance? Shape o))
+  (impl/shape? o))
 
 (def stroke-caps-line #{:round :square})
 (def stroke-caps-marker #{:line-arrow :triangle-arrow :square-marker :circle-marker :diamond-marker})
@@ -244,7 +245,7 @@
 (defn- decode-shape
   [o]
   (if (map? o)
-    (map->Shape o)
+    (impl/map->Shape o)
     o))
 
 (defn- shape-generator
@@ -268,7 +269,7 @@
                             (= type :bool))
                       (merge attrs1 shape attrs3)
                       (merge attrs1 shape attrs2 attrs3)))))
-       (sg/fmap map->Shape)))
+       (sg/fmap impl/map->Shape)))
 
 (def schema:shape
   [:and {:title "Shape"
@@ -472,7 +473,7 @@
              :rotation 0)
 
       :always
-      (map->Shape))))
+      (impl/map->Shape))))
 
 (defn setup-rect
   "Initializes the selrect and points for a shape."
@@ -527,17 +528,3 @@
           (assoc :transform-inverse (gmt/matrix)))
         (gpr/setup-proportions))))
 
-;; --- SHAPE SERIALIZATION
-
-(t/add-handlers!
- {:id "shape"
-  :class Shape
-  :wfn #(into {} %)
-  :rfn map->Shape})
-
-#?(:clj
-   (fres/add-handlers!
-    {:name "penpot/shape"
-     :class Shape
-     :wfn fres/write-map-like
-     :rfn (comp map->Shape fres/read-map-like)}))

common/src/app/common/types/shape/impl.cljc

@@ -0,0 +1,228 @@
+;; 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 INC
+
+(ns app.common.types.shape.impl
+  (:require
+   #?(:clj [app.common.fressian :as fres])
+   [app.common.colors :as clr]
+   [app.common.data :as d]
+   [app.common.data.macros :as dm]
+   [app.common.record :as cr]
+   [app.common.schema :as sm]
+   [app.common.schema.generators :as sg]
+   [app.common.transit :as t]
+   [app.common.uuid :as uuid]
+   [app.common.geom.rect :as grc]
+   [cuerdas.core :as str]
+   [clojure.core :as c]
+   [clojure.set :as set]))
+
+(def ArrayBuffer js/ArrayBuffer)
+(def Float32Array js/Float32Array)
+
+(cr/defrecord Shape [id name type x y width height rotation selrect points
+                     transform transform-inverse parent-id frame-id flip-x flip-y])
+
+(declare ^:private clone-f32-array)
+(declare ^:private impl-assoc)
+(declare ^:private impl-conj)
+(declare ^:private impl-dissoc)
+(declare ^:private read-selrect)
+(declare ^:private write-selrect)
+
+;; TODO: implement lazy MapEntry
+
+#?(:cljs
+   (deftype ShapeWithBuffer [buffer delegate]
+     Object
+     (toString [coll]
+       (str "{" (str/join ", " (for [[k v] coll] (str k " " v))) "}"))
+
+     (equiv [this other]
+       (-equiv this other))
+
+       ;; ICloneable
+       ;; (-clone [_]
+       ;;   (let [bf32 (clone-float32-array buffer)]
+       ;;     (ShapeWithBuffer. bf32 delegate)))
+
+       IWithMeta
+       (-with-meta [coll meta]
+         (ShapeWithBuffer. buffer (with-meta delegate meta)))
+
+       IMeta
+       (-meta [coll] (meta delegate))
+
+       ICollection
+       (-conj [coll entry]
+         (impl-conj coll entry))
+
+       IEquiv
+       (-equiv [coll other]
+         (c/equiv-map coll other))
+
+       IHash
+       (-hash [coll] (hash (into {} coll)))
+
+       ISequential
+
+       ISeqable
+       (-seq [coll]
+         (cons (find coll :selrect)
+               (seq delegate)))
+
+       ICounted
+       (-count [coll]
+         (+ 1 (count delegate)))
+
+       ILookup
+       (-lookup [coll k]
+         (-lookup coll k nil))
+
+       (-lookup [coll k not-found]
+         (if (= k :selrect)
+           (read-selrect buffer)
+           (c/-lookup delegate k not-found)))
+
+       IFind
+       (-find [coll k]
+         (if (= k :selrect)
+           (c/MapEntry. k (read-selrect buffer) nil) ; Replace with lazy MapEntry
+           (c/-find delegate k)))
+
+       IAssociative
+       (-assoc [coll k v]
+         (impl-assoc coll k v))
+
+       (-contains-key? [coll k]
+         (or (= k :selrect)
+             (contains? delegate k)))
+
+       IMap
+       (-dissoc [coll k]
+         (impl-dissoc coll k))
+
+       IFn
+       (-invoke [coll k]
+         (-lookup coll k))
+
+       (-invoke [coll k not-found]
+         (-lookup coll k not-found))
+
+       IPrintWithWriter
+       (-pr-writer [coll writer opts]
+         (-write writer (str "#penpot/shape " (:id delegate))))))
+
+(defn shape?
+  [o]
+  (or (instance? Shape o)
+      (instance? ShapeWithBuffer o)))
+
+;; --- SHAPE IMPL
+
+#?(:cljs
+   (defn- clone-f32-array
+     [^Float32Array src]
+     (let [copy (new Float32Array (.-length src))]
+       (.set copy src)
+       copy)))
+
+#?(:cljs
+   (defn- write-selrect
+     "Write the selrect into the buffer"
+     [data selrect]
+     (assert (instance? Float32Array data) "expected instance of float32array")
+
+     (aset data 0 (dm/get-prop selrect :x1))
+     (aset data 1 (dm/get-prop selrect :y1))
+     (aset data 2 (dm/get-prop selrect :x2))
+     (aset data 3 (dm/get-prop selrect :y2))))
+
+#?(:cljs
+   (defn- read-selrect
+     "Read selrect from internal buffer"
+     [^Float32Array buffer]
+     (let [x1 (aget buffer 0)
+           y1 (aget buffer 1)
+           x2 (aget buffer 2)
+           y2 (aget buffer 3)]
+       (grc/make-rect x1 y1
+                      (- x2 x1)
+                      (- y2 y1)))))
+
+#?(:cljs
+   (defn- impl-assoc
+     [coll k v]
+     (if (= k :selrect)
+       (let [buffer (clone-f32-array (.-buffer coll))]
+         (write-selrect buffer v)
+         (ShapeWithBuffer. buffer (.-delegate coll)))
+
+       (let [delegate  (.-delegate coll)
+             delegate' (assoc delegate k v)]
+         (if (identical? delegate' delegate)
+           coll
+           (let [buffer (clone-f32-array (.-buffer coll))]
+             (ShapeWithBuffer. buffer delegate')))))))
+
+#?(:cljs
+   (defn- impl-dissoc
+     [coll k]
+     (let [delegate  (.-delegate coll)
+           delegate' (dissoc delegate k)]
+       (if (identical? delegate delegate')
+         coll
+         (let [buffer (clone-f32-array (.-buffer coll))]
+           (ShapeWithBuffer. buffer delegate'))))))
+
+#?(:cljs
+   (defn- impl-conj
+     [coll entry]
+     (if (vector? entry)
+       (-assoc coll (-nth entry 0) (-nth entry 1))
+       (loop [ret coll es (seq entry)]
+         (if (nil? es)
+           ret
+           (let [e (first es)]
+             (if (vector? e)
+               (recur (-assoc ret (-nth e 0) (-nth e 1))
+                      (next es))
+               (throw (js/Error. "conj on a map takes map entries or seqables of map entries")))))))))
+
+
+#?(:cljs
+   (defn create-shape
+     "Instanciate a shape from a map"
+     [data]
+     (let [selrect (:selrect data)
+           buffer  (new Float32Array 4)]
+       (write-selrect buffer selrect)
+       (ShapeWithBuffer. buffer (dissoc data :selrect)))))
+
+;; --- SHAPE SERIALIZATION
+
+(t/add-handlers!
+ {:id "shape"
+  :class Shape
+  :wfn #(into {} %)
+  :rfn #?(:cljs create-shape
+          :clj map->Shape)})
+
+(t/add-handlers!
+ {:id "shape"
+  :class ShapeWithBuffer
+  :wfn #(into {} %)
+  :rfn #?(:cljs create-shape
+          :clj map->Shape)})
+
+
+
+#?(:clj
+   (fres/add-handlers!
+    {:name "penpot/shape"
+     :class Shape
+     :wfn fres/write-map-like
+     :rfn (comp map->Shape fres/read-map-like)}))

frontend/src/app/main/ui/workspace/viewport.cljs

@@ -276,18 +276,20 @@
 
     (when ^boolean render.wasm/enabled?
       (mf/with-effect []
-        (when-let [canvas (mf/ref-val canvas-ref)]
+        (time (when-let [canvas (mf/ref-val canvas-ref)]
           (->> render.wasm/module
                (p/fmap (fn [ready?]
                          (when ready?
                            (mf/set-ref-val! canvas-init true)
                            (render.wasm/assign-canvas canvas)))))
           (fn []
-            (render.wasm/clear-canvas))))
+            (render.wasm/clear-canvas)))))
 
-      (mf/with-effect [vbox' base-objects]
+      (mf/with-effect [vbox objects-modified]
-        (when (mf/ref-val canvas-init)
+        (let [sem (when (mf/ref-val canvas-init)
-          (render.wasm/draw-objects base-objects zoom vbox'))))
+                    (render.wasm/draw-objects objects-modified zoom vbox))]
+          (partial render.wasm/cancel-draw sem)))
+      )
 
     (hooks/setup-dom-events zoom disable-paste in-viewport? read-only? drawing-tool drawing-path?)
     (hooks/setup-viewport-size vport viewport-ref)

frontend/src/app/render_wasm.cljs

@@ -17,7 +17,8 @@
 (defonce ^:dynamic internal-module #js {})
 (defonce ^:dynamic internal-gpu-state #js {})
 
-(defn draw-objects [objects zoom vbox]
+(defn draw-objects
+  [objects zoom vbox]
   (let [draw-rect    (unchecked-get internal-module "_draw_rect")
         translate    (unchecked-get internal-module "_translate")
         reset-canvas (unchecked-get internal-module "_reset_canvas")
@@ -35,17 +36,24 @@
          (translate gpu-state (- x) (- y)))
 
        (run! (fn [shape]
+               ;; (js/console.log "render-shape" (.-buffer shape))
                (let [selrect (dm/get-prop shape :selrect)
                      x1      (dm/get-prop selrect :x1)
                      y1      (dm/get-prop selrect :y1)
                      x2      (dm/get-prop selrect :x2)
                      y2      (dm/get-prop selrect :y2)]
+                 ;; (prn (:id shape) selrect)
                  (draw-rect gpu-state x1 y1 x2 y2)))
              (vals objects))
 
        (flush gpu-state)))))
 
-(def canvas-options
+(defn cancel-draw
+  [sem]
+  (when (some? sem)
+    (js/cancelAnimationFrame sem)))
+
+(def ^:private canvas-options
   #js {:antialias true
        :depth true
        :stencil true

frontend/src/debug.cljs

@@ -181,10 +181,12 @@
   [state name]
   (let [page-id (get state :current-page-id)
         objects (get-in state [:workspace-data :pages-index page-id :objects])
-        result  (or (d/seek (fn [[_ shape]] (= name (:name shape))) objects)
+        result  (or (d/seek (fn [shape] (= name (:name shape))) (vals objects))
                     (get objects (uuid/uuid name)))]
-    (logjs name result)
+    #_(logjs name result)
-    nil))
+    result
+
+    #_nil))
 
 (defn ^:export dump-object
   [name]