Clojure animation library

core.clj

(ns clj-160122-anim.core
  (:gen-class))

(defn clear-folder
  [path]
  (let [files (.listFiles (clojure.java.io/file path))]
    (map clojure.java.io/delete-file files)))

(defn save-file
  [fname contents]
  (with-open [writer (clojure.java.io/writer fname)]
    (.write writer contents)))

(defn svg-wrapper
  [width height body]
  (str "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
<svg version = \"1.1\"
     baseProfile=\"full\"
     xmlns = \"http://www.w3.org/2000/svg\" 
     xmlns:xlink = \"http://www.w3.org/1999/xlink\"
     xmlns:ev = \"http://www.w3.org/2001/xml-events\"
     height=\"" height "px\" width=\"" width "px\">" body "</svg>"))

(defn tag
  [name tags body]
  (let [tags-str
        (map (fn [[tag val]] (str " " tag "=\"" val "\"")) tags)]
    (str "<" name (apply str tags-str) ">" body "</" name ">")))

(tag "img" {"a" "b"} "c")

(defn point-tag
  [[x y]]
  (tag "circle" {"cx" x "cy" y "r" "10px" "fill" "black"} ""))

(defn lin-interpol
  [[x0 x1] [y0 y1]]
  (fn [x]
    (+ (* (- x x0) (/ (- y1 y0) (- x1 x0))) y0)))

(defn in-int?
  [x [x0 x1]]
  (and (< x0 x) (< x x1)))

(defn int-pos
  [x [x0 x1]]
  ((lin-interpol [x0 x1] [0 1]) x))

(defn to-2dx
  [x]
  [x 0])

(defn to-2dy
  [y]
  [0 y])

(defn rotate
  [angle]
  (let [a (* angle 2 Math/PI)
        c (Math/cos a)
        s (Math/sin a)]
    (fn [[x y]]
      [(- (* x c) (* y s))
       (+ (* x s) (* y c))])))

(defn translate
  [[dx dy]]
  (fn [[x y]]
    [(+ x dx) (+ y dy)]))

(defn scale
  [factor]
  (fn [[x y]]
    [(* x factor) (* y factor)]))

(defn vec2d
  [[x1 y1] [x2 y2]]
  [(- x2 x1) (- y2 y1)])

(defn len2d
  [[x y]]
  (Math/sqrt (+ (* x x) (* y y))))

(defn dir2d
  [[x y]]
  (/ (Math/atan2 y x) 2 Math/PI))

(defn add2d
  [[x0 y0] [x1 y1]]
  [(+ x0 x1) (+ y0 y1)])

(defn mul2d
  [[x y] f]
  [(* x f) (* y f)])

(defn dist
  [p1 p2]
  (len2d (vec2d p1 p2)))

(defn trans-interpol
  [p1 q1 p2 q2]
  (let [v1 (vec2d p1 q1)
        v2 (vec2d p2 q2)
        factor (/ (len2d v2) (len2d v1))
        angle (- (dir2d v2) (dir2d v1))
        t1 (translate ((scale -1) p1))
        t2 (translate p2)
        s (scale factor)
        r (rotate angle)]
    {:p1 p1
     :factor factor
     :angle angle
     :p2 p2
     :fun (comp t2 s r t1)}))

(defn dflt-trans
  [p2 q2]
  (trans-interpol [0 0] [1 0] p2 q2 ))

(defn inverse-trans
  [trans]
  (trans-interpol (trans [0 0]) (trans [1 0]) [0 0] [1 0]))

(defn trans-comp
  [& trs]
  (let [funcs (map trans-pt-fun trs)
        apl (fn [pt] reduce #(apply %2 %1) pt funcs)]
    (trans-interpol [0 0] [1 0] (apl [0 0]) (apl [1 0]))))

(defn lin-comb
  [v0 v1 t]
  (if (and (vector? v0) (vector? v1))
    (let [[x0 y0] v0
          [x1 y1] v1]
      [(lin-comb x0 x1 t)
       (lin-comb y0 y1 t)])
    (+ (* v0 (- 1 t)) (* v1 t))))

(defn exp-comb
  [v0 v1 t]
  (Math/exp (lin-comb (Math/log v0) (Math/log v1) t)))

(defn sin-interpol
  [[x0 x1] [y0 y1]]
  (let [in-fn  (lin-interpol [x0 x1] [(* -1/2 Math/PI) (* 1/2 Math/PI)])
        out-fn (lin-interpol [-1 1] [y0 y1])]
    (comp out-fn #(Math/sin %) in-fn)))

(defn circ [t]
  (let [a (* Math/PI 2 t)]
    [(Math/sin a) (Math/cos a)]))

(defn regular-poly [n]
  (fn [i] ((rotate (/ i n)) [1 0])))

(defn apply-while-changes
  [fun init]
  (loop [val init]
    (let [next-val (fun val)]
      (if (= next-val val)
        val
        (recur (fun val))))))

(defn deduce
  [rules]
  (fn [vals]
    (apply-while-changes
     (fn [vals]
       (into
        vals
        (map
         (fn [[in out fun]]
           (if (not (get vals out))
             (let [in-vals (map #(get vals %) in)]
               (if (every? some? in-vals)
                 [out (apply fun in-vals)]))))
         rules)))
     vals)))

(def segment
  (deduce
   [[[:int] :x0
     (fn [int] (int 0))]
    [[:int] :x1
     (fn [int] (int 1))]
    [[:x0 :x1] :int
     (fn [x0 x1] [x0 x1])]
    [[:x0 :x1] :c
     (fn [x0 x1] (/ (+ x0 x1) 2))]
    [[:x0 :x1] :l
     (fn [x0 x1] (- x1 x0))]
    [[:l] :r
     (fn [l] (/ l 2))]
    [[:r] :l
     (fn [r] (* r 2))]
    [[:x0 :l] :x1
     (fn [x0 l] (+ x0 l))]
    [[:x0 :c] :x1
     (fn [x0 c] (+ x0 (* 2 (- c x0))))]
    [[:x1 :c] :x0
     (fn [x1 c] (- x1 (* 2 (- x1 c))))]
    [[:x1 :l] :x0
     (fn [x1 l] (- x1 l))]
    [[:c :r] :x0
     (fn [c r] (- c r))]
    [[:c :r] :x1
     (fn [c r] (+ c r))]]))

(defn glued-seq
  [{:keys [width celln cellw inner outer]}]
  (let [outer (or outer 0)
        glue (+ (dec celln) (* 2 outer))
        width (or width (+ (* cellw celln) (* inner glue)))
        cellw (or cellw (/ (- width (* inner glue)) celln))
        inner (or inner (/ (- width (* cellw celln)) glue))]
    {:width width :celln celln :cellw cellw :inner inner :outer outer
     :in-int (fn [i] (let [x0 (* i (+ cellw inner))] [x0 (+ x0 cellw)]))
     :out-int (let [x0 (- 0 (* inner outer))] [x0 (+ x0 width)])}))

(defn accum-int
  [lengths]
  (let [starts (reductions + 0 lengths)
        out-int [0 (last starts)]]
    {:out-int out-int
     :in-int (fn [i] [(starts i) (starts (inc i))])
     :before-pt (fn [i] (starts i))
     :after-pt (fn [i] (starts (inc i)))
     :where (fn [t]
              (if (in-int? t out-int)
                (dec (count (take-while (partial >= t) starts)))))}))

(defn apl
  [fun val]
  (and fun (fun val)))

(defn rect
  [{:keys
    [center size ix iy r tl tr bl br x0 x1 cx rx w y0 y1 cy ry h ratio]}]
  (let [cx (or cx (apl center 0))
        cy (or cy (apl center 1))
        w  (or w (apl size 0))
        h  (or h (apl size 1))
        x0 (or x0 (apl tl 0) (apl bl 0))
        x1 (or x1 (apl tr 0) (apl br 0))
        y0 (or y0 (apl tl 1) (apl tr 1))
        y1 (or y1 (apl bl 1) (apl br 1))
        rx (or rx (and (vector? r) (r 0)) r)
        ry (or ry (and (vector? r) (r 1)) r)
        seg-x (segment {:x0 x0 :x1 x1 :c cx :r rx :l w :int ix})
        seg-y (segment {:x0 y0 :x1 y1 :c cy :r ry :l h :int iy})
        w1 (or (seg-x :l) (and ratio (/ (seg-y :l) ratio)))
        h1 (or (seg-y :l) (and ratio (* (seg-x :l) ratio)))
        sx (segment (into seg-x [[:l w1]]))
        sy (segment (into seg-y [[:l h1]]))]
    {:x0 (sx :x0)
     :x1 (sx :x1)
     :w (sx :l)
     :cx (sx :c)
     :y0 (sy :x0)
     :y1 (sy :x1)
     :h (sy :l)
     :cy (sy :c)
     :ratio (or ratio (/ (sy :l) (sx :l)))
     :center [(sx :c) (sy :c)]
     :size [(sx :l) (sy :l)]
     :tl [(sx :x0) (sy :x0)]
     :tr [(sx :x1) (sy :x0)]
     :bl [(sx :x0) (sy :x1)]
     :br [(sx :x1) (sy :x1)]
     :r [(sx :r) (sy :r)]
     :rx (sx :r)
     :ry (sy :r)
     :ix (sx :int)
     :iy (sy :int)}))

(defn rect-set-ratio
  [ratio r]
  (let [r1 (rect {:center (r :center) :w (r :w) :ratio ratio})
        r2 (rect {:center (r :center) :h (r :h) :ratio ratio})]
    (if (< (r1 :w) (r2 :w))
      {:in r1 :out r2}
      {:in r2 :out r1})))

(defn short2d
  [val]
  (if (vector? val) val [val val]))

(defn rect-scale
  [coeff r]
  (let [[coefx coefy] (short2d coeff)]
    (rect {:center (r :center)
           :w (* (r :w) coefx)
           :h (* (r :h) coefy)})))

(defn rect-pad
  [pad r]
  (let [[padx pady] (short2d pad)]
    (rect {:center (r :center)
           :rx (+ (r :rx) padx)
           :ry (+ (r :ry) pady)})))

(defn bounding-rect-of-rects
  [rects]
  (let [x0 (apply min (map :x0 rects))
        x1 (apply max (map :x1 rects))
        y0 (apply min (map :y0 rects))
        y1 (apply max (map :y1 rects))]
    (rect {:x0 x0 :x1 x1 :y0 y0 :y1 y1})))

(defn bounding-rect-of-points
  [points]
  (let [x0 (apply min (map first points))
        x1 (apply max (map first points))
        y0 (apply min (map second points))
        y1 (apply max (map second points))]
    (rect {:x0 x0 :x1 x1 :y0 y0 :y1 y1})))

(defn rect-rel-point
  [[x y] r]
  [(lin-comb (r :x0) (r :x1) x)
   (lin-comb (r :y0) (r :y1) y)])

(defn rect-vertices
  [rect]
  [(rect :tl) (rect :tr) (rect :bl) (rect :br)])

(defn transform-rect
  [trans rec]
  (rect {:center (trans (rec :center))
         :tl (trans (rec :tl))}))

(def trans1
  (let [p1 [0 0]
        p2 [1 0]]
    {:p1 p1 :p2 p2
     :pos (fn [t] (lin-comb p1 p2 t))}))



(defn clip1-model
  [{:keys [n]}]
  (let [pos-fun (fn [i] [i 0])
        time-ints (accum-int (repeat n 1))
        trans trans1
        path-transf
        (fn [i] ((lin-interp (trans :p1) (trans :p2) p1 p2) :fun))
        trans-fun (fn [i t]
                    (let [p1 (pos-fun i)
                          p2 (pos-fun (inc i))]
                      (lin-interp)))]
    {}))

(def clip1
  {:svg
   (fn [t]
     (svg-wrapper
      400 400
      (point-tag
       [((sin-interpol [0 1] [0 100]) t)
        ((sin-interpol [0 2] [0 200]) t)])))
   :length 1})

(defn save-clip [clip freq]
  (map #(save-file (format "output/%03d.svg" %) ((clip :svg) (/ % freq)))
       (range (* freq (clip :length)))))

(clear-folder "output")
(save-clip clip1 24)