Delight, Generating Interactive Controls over Electric Code

reactive_render.cljc

;; This is free and unencumbered software released into the public domain.
;;
;; Anyone is free to copy, modify, publish, use, compile, sell, or
;; distribute this software, either in source code form or as a compiled
;; binary, for any purpose, commercial or non-commercial, and by any
;; means.
;;
;; In jurisdictions that recognize copyright laws, the author or authors
;; of this software dedicate any and all copyright interest in the
;; software to the public domain. We make this dedication for the benefit
;; of the public at large and to the detriment of our heirs and
;; successors. We intend this dedication to be an overt act of
;; relinquishment in perpetuity of all present and future rights to this
;; software under copyright law.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR
;; OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
;; ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
;; OTHER DEALINGS IN THE SOFTWARE.
;;
;; For more information, please refer to <https://unlicense.org>

(ns app.reactive-render
  #?(:cljs (:require-macros [app.reactive-render :refer [atomize-form]]))
  (:require
   [hyperfiddle.electric :as e]
   [hyperfiddle.electric-dom2 :as dom]
   [hyperfiddle.electric-ui4 :as ui]
   [hyperfiddle.electric-svg :as svg]
   [clojure.walk :as walk]
   [clojure.string :as str]
   [zprint.core :as zp]))

(defn extract-then-atomize-let-decls
  "Extracts the let declarations from form and \"atomize\" them. For
  instance, given (let [a 1 b 2] ...), the atomized let decls would be
  [!a (atom 1), a (e/watch !a), !b (atom 2), b (e/watch !b)]."
  [form]
  (letfn [(subexpressions [form]
            ;; all subexpressions
            (cond
              (not (coll? form)) '()
              :else
              (cons form (mapcat subexpressions form))))
          (extract-let-decls [form]
            ;; get let decls from form
            (if (and (list? form) (= 'let (first form)))
              (second form)
              nil))
          (atomize-decls [decls]
            ;; turn decls into atomized decls
            (vec
             (apply concat
                    (map (fn [[sym val]]
                           [(symbol (str "!" (name sym))) `(atom ~val)
                            sym `(e/watch ~(symbol (str "!" (name sym))))])
                         (partition 2 decls)))))]
    (->> (subexpressions form)
         (map extract-let-decls)
         (remove nil?)
         (map atomize-decls)
         (apply concat)
         vec)))

(defn placeholder-split-and-transform
  "Takes s, which has placeholders prefixed with % for let
  declarations, e.g. (let [%x 1 %y 2]). We split s into a list so that
  everything that is not in let declaration is wrapped with dom/text.
  Placeholders along with their values are transformed using transform-fn."
  [s transform-fn]
  (let [;; match declaration variable and value pair (e.g. "%x 1"), or just text without %
        decl-var-and-value-pattern
        #"(%[^()\[\]\"\s]+ [^()\[\]\"\s]+)|[^%]+"
        ]
    (->>
     (re-seq decl-var-and-value-pattern s)
     ;; re-seq produces a list of two-elem vectors
     (map (fn [[x decl?]]
            (cond decl?
                  (let [[var value-str] (str/split (subs x 1) #" ")]
                    (transform-fn (symbol var)
                                  value-str))
                  :else
                  `(dom/text ~x)))))))

(defn insert-controls
  "Given transform-fn (which defines how the control should look:
  slider, button, etc.), insert controls (generated through
  transform-fn) after let declarations. Returns a list of dom/text and
  control elements."
  [form transform-fn]
  ;; we can probably do some validation of format string w/ count of controls
  (letfn [(map-first-and-every-other [f coll]
            (map-indexed (fn [idx item] (if (even? idx) (f item) item))
                         coll))]
    (-> (walk/postwalk
         (fn [form]
           (cond (and (list? form) (= 'let (first form)))
                 (let [bindings (second form)
                       body     (drop 2 form)]
                   `(~'let ~(vec (map-first-and-every-other
                                  (fn [sym]
                                    (symbol (str "%" sym)))
                                  bindings))
                     ~@body))
                 (list? form)
                 form
                 :else
                 form))
         form)
        zp/zprint-str
        ;; at this point, we have string with placeholders
        (placeholder-split-and-transform transform-fn)
        )))


(defn remove-all-let-decls
  "A helper function which removes all let declarations from a form."
  [form]
  (letfn [(remove-let-decls [form]
            (drop 2 form))]
    (->
     (walk/prewalk
      (fn [form]
        (if (list? form)
          (mapcat
           (fn [subform]
             (cond (and (list? subform) (= (first subform) 'let))
                   (if (= (count subform) 2)
                     nil
                     (drop 2 subform))
                   :else
                   (list subform)))
           form)
          form))
      (list form))
     first)))

#?(:clj
   (defmacro atomize-form
     "Creates a display where one pane is the evaluation of the form
     (i.e. rendered dom) and the other is the form itself. The catch
     is that these two panes are connected; the form pane has controls
     for each let binding, and changing these controls changes the
     rendering pane."
     [form]
     `(dom/div
        (dom/props {:class (str "[&>*]:p-4 [&>*]:rounded-lg "
                                "flex flex-col gap-4 m-10 text-2xl p-10 rounded-xl")})
        (let ~(extract-then-atomize-let-decls form)
          ;; rendered dom, we "pull" all the let declarations to the top (so that they can be shared)
          ;; currently, two let declarations with the same variable name are not handled separately
          (dom/div
            (dom/props {:class "bg-base-200 w-64"})
            ~(remove-all-let-decls form))
          ;; form itself, with controls
          (dom/div
            (dom/props {:class "bg-base-200 text-md w-fit"})
            (dom/pre
             ~@(insert-controls
                form
                (fn [x value-string]
                  (let [!x       (symbol (str "!" (name x)))
                        value    (read-string value-string)
                        interval 50]
                    `(let [!showing (atom false)
                           showing  (e/watch !showing)]
                       (dom/div
                         (dom/props {:class "inline-block mb-4"})
                         (ui/range
                          ~x
                          (e/fn [v]
                            (reset! ~!x v))
                          (dom/props {:min   ~(- value interval)
                                      :max   ~(+ value interval)
                                      :class "range range-sm w-32"
                                      })
                          (dom/on "click" (e/fn [e]
                                            (.stopPropagation e))))
                         (dom/div
                           (dom/props
                            {:class "w-32 flex justify-between text-xs px-2 absolute"})
                           (dom/span (dom/text ~(- value interval)))
                           (dom/span (dom/text ~value))
                           (dom/span (dom/text ~(+ value interval)))))
                       (dom/text " " ~(name x))))))))))))

(e/defn ReactiveRenderApp []
  (atomize-form
   (let [w 20 h 20]
     (svg/svg
      (dom/props {:width w :height h
                  :class "border-2 border-black"})
      (let [x1           5 x2 5
            y1           0 y2 10
            stroke-width 1]
        (svg/line (dom/props {:x1     x1       :x2           x2
                              :y1     y1       :y2           y2
                              :stroke "black", :stroke-width stroke-width})))))))