Programming as Composing



(ns my.reagent-examples
  (:require
    [clojure.string :as string]
    [reagent.core :as reagent]
    [reagent.dom.server]
[reagent.ratom]))

(enable-console-print!)
(defn str->url [s t]
(let[blob (js/Blob. #js [s] #js {:type t})]
              (.createObjectURL js/URL blob) ))

(def worker-url (let[ gif-worker-src (.-textContent (. js/document (getElementById "gif-js-worker-code")))] 
(str->url gif-worker-src "application/javascript")))

(defn svgs->animated-gif-url![cb delays svgs]
  (let [delays (if (number? delays) (repeat delays) delays)
       [w h] ((comp (juxt :width :height) second first) svgs)
         gif (js/GIF. #js {:workers 4
                          :quality 1
                          :width w
                          :height h
                          :workerScript worker-url
                          })
        process (fn process[svgs delays](let[img (js/Image.)
                                             svg-url (str->url (reagent.dom.server/render-to-static-markup 
                                                                 (first svgs))
                                                               "image/svg+xml")]
                                          (do
                                            (set! (.-onload img)
                                                  (fn[](do
                                                         (.addFrame gif img #js{:copy true :delay (first delays)})
                                                         (let[r (rest svgs)]
                                                           (if (seq r)
                                                             (process r (rest delays))
                                                             (.render gif)
                                                             )))))
                                            (set! (.-src img) svg-url))))]
    (do
      (.on gif "finished" cb);; partial does not work ?!
      (process svgs delays))))

(defn save-svgs![filename delays svgs]
(letfn [(download-blob! [filename blob]
  (let[download-link (. js/document (createElement "a"))]
    (do
      (set! (.-download download-link) filename)
      (set! (.-href download-link) (.createObjectURL js/URL blob))
      (.click download-link))))]
(svgs->animated-gif-url! (fn[blob](download-blob! filename blob)) delays svgs)))

(defn display-svgs![parent delays svgs]
(svgs->animated-gif-url! (fn[blob]
                          (let[img (js/Image.)]
                            (do
                            (.appendChild parent img)
                            (set! (.-src img) (.createObjectURL js/URL blob)))))
                            delays svgs))

(defn comp [& fs]
(with-meta (apply
(fn ([] identity)
  ([f] f)
  ([f g] 
     (fn 
       ([] (f (g)))
       ([x] (f (g x)))
       ([x y] (f (g x y)))
       ([x y z] (f (g x y z)))
       ([x y z & args] (f (apply g x y z args)))))
  ([f g & fs]
(reduce comp (list* f g fs))))
 fs)
    {:is-from comp
:args fs}))

(defn partial [& args]
(with-meta (apply (fn
([f] f)
  ([f arg1]
   (fn
     ([] (f arg1))
     ([x] (f arg1 x))
     ([x y] (f arg1 x y))
     ([x y z] (f arg1 x y z))
     ([x y z & args] (apply f arg1 x y z args))))
  ([f arg1 arg2]
   (fn
     ([] (f arg1 arg2))
     ([x] (f arg1 arg2 x))
     ([x y] (f arg1 arg2 x y))
     ([x y z] (f arg1 arg2 x y z))
     ([x y z & args] (apply f arg1 arg2 x y z args))))
  ([f arg1 arg2 arg3]
   (fn
     ([] (f arg1 arg2 arg3))
     ([x] (f arg1 arg2 arg3 x))
     ([x y] (f arg1 arg2 arg3 x y))
     ([x y z] (f arg1 arg2 arg3 x y z))
     ([x y z & args] (apply f arg1 arg2 arg3 x y z args))))
  ([f arg1 arg2 arg3 & more]
(fn [& args] (apply f arg1 arg2 arg3 (concat more args)))))
args)
    {:is-from partial
     :args args}))


(defn mapv [& args]
(with-meta (apply (fn
  ([f coll]
     (-> (reduce (fn [v o] (conj! v (f o))) (transient []) coll)
         persistent!))
  ([f c1 c2]
     (into [] (map f c1 c2)))
  ([f c1 c2 c3]
     (into [] (map f c1 c2 c3)))
  ([f c1 c2 c3 & colls]
     (into [] (apply map f c1 c2 c3 colls))))
args)
    {:is-from mapv}))

(defn merged-juxt[fs]
  (with-meta (comp (partial reduce into []) (apply juxt fs))
    {:is-from merged-juxt
     :args fs}))

(defn svg-polyline[ps]
(let[[[x0 y0] & ps] ps
init-point (str "M " x0 ", " y0 " ")
seg (fn[[x y]] (str "L " x ", " y " "))]
(reduce #(str %1 (seg %2)) init-point ps)))
(defn draw-polylines[[w h] pss]
          [:svg {:xmlns "http://www.w3.org/2000/svg" :width w :height h}
[:rect {:x 0 :y 0 :width w :height h :fill "white"}]
          [:path {:stroke "black" :stroke-width 1 :fill "none" :d  (reduce str (map svg-polyline pss))}] ])
(defn add [[x0 y0][x1 y1]]
[(+ x0 x1)(+ y0 y1)])
(def make-polylines-transform (comp (partial partial mapv) (partial partial mapv) ))
(defn sin[x]
  (.sin js/Math x))
(defn cos[x]
          (.cos js/Math x))

(def PI
  (.-PI js/Math))
    (def sqrt #(.sqrt js/Math %))

    (defn rotate [a [x y]]
    (let [c (cos a)
          s (sin a)]
    [(- (* c x) (* s y)) (+ (* s x) (* c y))]))
(defn scale [k p]
(mapv (partial * k) p))
(def minus (partial scale -1.))
(def -INF (.-NEGATIVE_INFINITY js/Number))
(def INF (.-POSITIVE_INFINITY js/Number))

    (defn bounding-box[pss]
    (->> pss (reduce into [])(reduce (fn[[[x-min y-min][x-max y-max]][x y]] [[(min x-min x) (min y-min y)][(max x-max x)(max y-max y)]]) [[INF INF][-INF -INF]])))
      (defn make-fitting-transform[[w h] pss]
      (let[[[x-min y-min][x-max y-max]](bounding-box pss)
      s (min (/ w (- x-max x-min)) (/ h (- y-max y-min)))
      center (scale 0.5  (add [x-min y-min] [x-max y-max]))]
      (comp (partial add [(/ w 2) (/ h 2)]) (partial scale s) (partial add (minus center)))))
      (defn draw-fitted-polylines[wh pss]
      (draw-polylines wh ((make-polylines-transform (make-fitting-transform wh pss)) pss)))
(defn make-rotate-around [r a]
  (comp (partial add r)(partial rotate a) (partial add (minus r))))
(def TWO_PI (* 2 PI))
(defn regular-polygon [n]
(vec (take (inc n)(iterate (partial rotate (/ TWO_PI n)) [1. 0]))))
         (defn fractal-step [[step-f step-elts] current-elts]
  (into step-elts (step-f current-elts)))

(defn fractal [[init-elts step-params] details]
  (nth (iterate (partial fractal-step step-params) init-elts) details))

         (defn merged-juxt[fs]
         (comp (partial reduce into [])(apply juxt fs)))
         ;; cf. infra
         (defn merged-juxt[fs]
         (with-meta (comp (partial reduce into []) (apply juxt fs))
         {:is-from merged-juxt
         :args fs}))


(defn sierpinski-params [n]
  (let[step-elt (regular-polygon n)
       make-transform #(make-polylines-transform (comp (partial add %)
                                                       (partial scale (/ 1 (dec n)))))]
  (condp = n
    3 [[]
       [(merged-juxt (for [i [0 1 2]] (make-transform (rotate (+ PI (* i 2 (/ PI 3))) [1. 0.]))))
        [step-elt]]]
    4 [[]
       [(merged-juxt (let [d [-1 0 1]]
                       (for [dx d dy d :when (not= 0 dx dy)]
                         (make-transform (scale (sqrt 2.) [dx dy])))))
        [(map (partial rotate (/ PI 4)) step-elt)]]])))
(defn tree-params [angles]
  (let[branch [0 -1]
       ratio (/ (+ 1 (sqrt 5.)) 2.)]
    [[]
     [(merged-juxt (for [a angles]
                     (make-polylines-transform
                                             (comp (partial add branch)
                                                      (partial scale (/ 1 ratio))
                                                      (partial rotate a)))))
      [[[0. 0] branch]]]]))
(def koch-params [[[[-0.5 0][0.5 0]]]
                  [(merged-juxt (for [[v a] [[[(/ -1 3) 0] 0]
                                             [[(/ 1 3) 0] 0]
                                             [(rotate (/ PI -3) [(/ 1 6) 0]) (/ PI 3)]
                                             [(rotate (/ PI 3) [(/ -1 6) 0]) (/ PI -3)]]]
                                        (make-polylines-transform (comp (partial add v)
                                                                   (partial rotate a)
                                                                   (partial scale (/ 1 3))))))
                   []]])
    ;; hilbert is different because there is only one polyline. We do not transform and merge sequences of polylines but transform and merge polylines (sequences of points). Also, the initial polyline is only one point long.
(def hilbert-transform
    (comp (merged-juxt
            [(comp (partial mapv (comp (partial add [-0.5 0.5]) (partial rotate (/ PI 2)))) reverse)
             (partial mapv (partial add [-0.5 -0.5]))
        	 (partial mapv (partial add [0.5 -0.5]))
             (comp (partial mapv (comp (partial add [0.5 0.5]) (partial rotate (/ PI -2)))) reverse)])
          (partial mapv (partial scale 0.5))))
(def hilbert-params [[[[0 0]]] [(partial mapv hilbert-transform) []]])
(def koch-transform
(let [s (partial scale (/ 1 3))]
(comp (merged-juxt
        [(partial mapv (comp (partial add [(/ -1 3) 0]) s))
(comp rest (partial mapv (comp (partial add (rotate (/ PI 3) [(/ -1 6) 0])) (partial rotate (/ PI -3)) s)))
(comp rest (partial mapv (comp (partial add (rotate (/ PI -3) [(/ 1 6) 0])) (partial rotate (/ PI 3)) s)))
(comp rest (partial mapv (comp (partial add [(/ 1 3) 0]) s)))]))))
(def koch-line-params [[[[-0.5 0] [0.5 0]]] [(partial mapv koch-transform) []]])
(defn sequence-steps [n step-factor]
  (let [p (* n step-factor)]
    (map #(-> (- p %) (min 1) (max 0)) (range n))))

(defn is-from [v]
  (get (meta v) :is-from :default))

(defn get-args [v]
  (:args (meta v)))

(defmulti stepify (fn [s v] (is-from v)))

(defmethod stepify :default [s v]
  v)

(defmethod stepify partial [s p]
  (let [args (get-args p)
        arg0 (first args)]
    (condp = arg0
      add (partial add (scale s (second args)))
      rotate (partial rotate (* (second args) s))
      scale (partial scale (js/Math.pow (second args) s))
      mapv (partial mapv (stepify s (second args)))
      :default (apply p (map (partial stepify s))))))

(defmethod stepify comp [s c]
  (let [args (get-args c)]
    (apply comp (map stepify
                        (reverse (sequence-steps (count args) s))
                        args))))

(defmethod stepify merged-juxt [s c]
  (let [args (get-args c)]
    (merged-juxt (map stepify
                      (sequence-steps (count args) s)
                      args))))


(defmethod stepify :default [s v]
  v)

(defn params-step [s [init-scene [step-fs step-scene]]]
  [init-scene [(stepify s step-fs) step-scene]])

(def EPSILON 0.01)
(defn fractal-with-steps [params details]
  (let [[init-scene step-params] params
        int-d (int details)
        int-fractal (nth (iterate (partial fractal-step step-params) init-scene) int-d)
        fractional-d (- details int-d)]
    (if (<= fractional-d EPSILON)
      int-fractal
      (fractal-step (second (params-step fractional-d params)) int-fractal))))


    (def memo-fractal (memoize fractal))
    (def fractal-name->params { "hilbert-curve" hilbert-params
                                                      "tree" (tree-params [(/ PI 6) (/ PI -3)])
                                                      "sierp-3" (sierpinski-params 3)
                                                      "sierp-4" (sierpinski-params 4)
      "koch" koch-params
      "koch-line" koch-line-params
      })
(def fractal-state (reagent.core/atom {:params (first (vals fractal-name->params)) :step 0}))
(defn gui-fractals[]
  (let[{:keys [params step]} @fractal-state]
    [:div
     [:div (into [:select {:on-change (fn[e] (swap! fractal-state assoc :params (get fractal-name->params (.-target.value e))))}]
           (mapv (fn[k] [:option {:value k} k]) (keys fractal-name->params)))]
     [:div [:input {:type "range" :value (:step @fractal-state) :min 0 :max 6  :style {:width "90%"}
              :on-change (fn[e] (swap! fractal-state assoc :step (js/parseFloat (.-target.value e))))}]]
     [draw-fitted-polylines [400 400] (memo-fractal params (int step))]]))



    (def memo-fractal (memoize fractal))
    (def fractal-name->params { "hilbert-curve" hilbert-params
                                                      "tree" (tree-params [(/ PI 6) (/ PI -3)])
                                                      "sierp-3" (sierpinski-params 3)
                                                      "sierp-4" (sierpinski-params 4)
      "koch" koch-params
      "koch-line" koch-line-params
      })
(def fractal-state (reagent.core/atom {:params (first (vals fractal-name->params)) :step 0}))
(defn gui-fractals[]
  (let[{:keys [params step]} @fractal-state]
    [:div
     [:div (into [:select {:on-change (fn[e] (swap! fractal-state assoc :params (get fractal-name->params (.-target.value e))))}]
           (mapv (fn[k] [:option {:value k} k]) (keys fractal-name->params)))]
     [:div [:input {:type "range" :value (:step @fractal-state) :min 0 :max 6  :style {:width "90%"}
              :on-change (fn[e] (swap! fractal-state assoc :step (js/parseFloat (.-target.value e))))}]]
     [draw-fitted-polylines [400 400] (memo-fractal params (int step))]]))



    (def memo-fractal-with-steps (memoize fractal-with-steps)) ;; not so sure about a memo with a float arg ! :(
(def fractal-with-steps-state (reagent.core/atom {:params (first (vals fractal-name->params)) :step 0}))
(let [k 32 
      n 5]
(display-svgs! js/klipse-container 200
               (map (comp (partial draw-fitted-polylines [400 400])
                          (partial fractal-with-steps
                                  (get fractal-name->params "sierp-4"))
                          (partial * (/ 1 k))) (range k (* n k)))))

(defn gui-fractals-stepified[]
  (let[{:keys [params step]} @fractal-with-steps-state]
    [:div
     [:div (into [:select {:on-change (fn[e] (swap! fractal-with-steps-state assoc :params (get fractal-name->params (.-target.value e))))}]
           (mapv (fn[k] [:option {:value k} k]) (keys fractal-name->params)))]
     [:div [:input {:type "range" :value (:step @fractal-with-steps-state) :step 0.01 :min 0 :max 6  :style {:width "90%"}
              :on-change (fn[e] (swap! fractal-with-steps-state assoc :step (js/parseFloat (.-target.value e))))}]]
     [draw-fitted-polylines [400 400] (memo-fractal-with-steps params step)]]))



         (defn fractal-step [[step-f step-elts] current-elts]
  (into step-elts (step-f current-elts)))

(defn fractal [[init-elts step-params] details]
  (nth (iterate (partial fractal-step step-params) init-elts) details))

         (defn merged-juxt[fs]
         (comp (partial reduce into [])(apply juxt fs)))
         ;; cf. infra
         (defn merged-juxt[fs]
         (with-meta (comp (partial reduce into []) (apply juxt fs))
         {:is-from merged-juxt
         :args fs}))


(defn sierpinski-params [n]
  (let[step-elt (regular-polygon n)
       make-transform #(make-polylines-transform (comp (partial add %)
                                                       (partial scale (/ 1 (dec n)))))]
  (condp = n
    3 [[]
       [(merged-juxt (for [i [0 1 2]] (make-transform (rotate (+ PI (* i 2 (/ PI 3))) [1. 0.]))))
        [step-elt]]]
    4 [[]
       [(merged-juxt (let [d [-1 0 1]]
                       (for [dx d dy d :when (not= 0 dx dy)]
                         (make-transform (scale (sqrt 2.) [dx dy])))))
        [(map (partial rotate (/ PI 4)) step-elt)]]])))
[draw-fitted-polylines [400 400] (fractal (sierpinski-params 3) 6)]



(def TWO_PI (* 2 PI))
(defn regular-polygon [n]
(vec (take (inc n)(iterate (partial rotate (/ TWO_PI n)) [1. 0]))))
[draw-fitted-polylines [200 200] (map regular-polygon (range 3 7))]



(defn tree-params [angles]
  (let[branch [0 -1]
       ratio (/ (+ 1 (sqrt 5.)) 2.)]
    [[]
     [(merged-juxt (for [a angles]
                     (make-polylines-transform
                                             (comp (partial add branch)
                                                      (partial scale (/ 1 ratio))
                                                      (partial rotate a)))))
      [[[0. 0] branch]]]]))
[draw-fitted-polylines [400 400] (fractal (tree-params [(/ PI 6)(/ PI -3)]) 8)]



(def koch-params [[[[-0.5 0][0.5 0]]]
                  [(merged-juxt (for [[v a] [[[(/ -1 3) 0] 0]
                                             [[(/ 1 3) 0] 0]
                                             [(rotate (/ PI -3) [(/ 1 6) 0]) (/ PI 3)]
                                             [(rotate (/ PI 3) [(/ -1 6) 0]) (/ PI -3)]]]
                                        (make-polylines-transform (comp (partial add v)
                                                                   (partial rotate a)
                                                                   (partial scale (/ 1 3))))))
                   []]])
[draw-fitted-polylines [400 400] (fractal koch-params 4)]



    ;; hilbert is different because there is only one polyline. We do not transform and merge sequences of polylines but transform and merge polylines (sequences of points). Also, the initial polyline is only one point long.
(def hilbert-transform
    (comp (merged-juxt
            [(comp (partial mapv (comp (partial add [-0.5 0.5]) (partial rotate (/ PI 2)))) reverse)
             (partial mapv (partial add [-0.5 -0.5]))
        	 (partial mapv (partial add [0.5 -0.5]))
             (comp (partial mapv (comp (partial add [0.5 0.5]) (partial rotate (/ PI -2)))) reverse)])
          (partial mapv (partial scale 0.5))))
[draw-fitted-polylines [400 400] [(nth (iterate hilbert-transform [[0 0]]) 5)]]



(def hilbert-params [[[[0 0]]] [(partial mapv hilbert-transform) []]])
[draw-fitted-polylines [400 400] (fractal hilbert-params 6)]



(def koch-transform
(let [s (partial scale (/ 1 3))]
(comp (merged-juxt
        [(partial mapv (comp (partial add [(/ -1 3) 0]) s))
(comp rest (partial mapv (comp (partial add (rotate (/ PI 3) [(/ -1 6) 0])) (partial rotate (/ PI -3)) s)))
(comp rest (partial mapv (comp (partial add (rotate (/ PI -3) [(/ 1 6) 0])) (partial rotate (/ PI 3)) s)))
(comp rest (partial mapv (comp (partial add [(/ 1 3) 0]) s)))]))))
[draw-fitted-polylines [400 400] [(nth (iterate koch-transform [[-0.5 0][0.5 0]]) 2)]]



(def koch-line-params [[[[-0.5 0] [0.5 0]]] [(partial mapv koch-transform) []]])
[draw-fitted-polylines [400 400] (fractal koch-line-params 6)]

1 Future Works

Fractal in Fractal : step-elt as a function of step nb to adjust for required precision
hilbert in sierpinski 4
golden ratio squares and curve
golden ratio with sierpinski squares

This is an org fragment With α text^sup

This is an org fragment With α text^sup elisp → org src