Advertisement
Guest User

Untitled

a guest
Jul 25th, 2016
73
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 5.88 KB | None | 0 0
  1. (ns physics-demos.fractals
  2. (:require
  3. [thi.ng.geom.core :as g]
  4. [thi.ng.geom.core.vector :as v :refer [vec2 vec3]]
  5. [thi.ng.geom.core.matrix :as mat :refer [M32 M44]]
  6. [thi.ng.geom.circle :as c]
  7. [thi.ng.geom.spatialtree :as accel]
  8. [thi.ng.geom.svg.core :as svg]
  9. [thi.ng.geom.physics.core :as phys]
  10. [thi.ng.geom.webgl.animator :refer [animate]]
  11. [thi.ng.domus.core :as dom]
  12. [shodan.inspection :as shodan]))
  13.  
  14.  
  15. (def pi (.-PI js/Math))
  16. (def cos #(.cos js/Math %))
  17. (def sin #(.sin js/Math %))
  18. (def sqrt #(.sqrt js/Math %))
  19. (def sign #(if (>= % 0) 1 -1))
  20. (def abs #(if (>= % 0) % (- %)))
  21.  
  22. (defn add-functional-meta [f]
  23. (fn [& args]
  24. (with-meta (apply f args)
  25. {:is f
  26. :args args
  27. })))
  28.  
  29. (def my-partial (add-functional-meta partial))
  30.  
  31.  
  32. (defn merged-juxt[fs] (comp (partial reduce into []) (apply juxt fs)))
  33.  
  34. (defn rotate [a [x y]]
  35. [(- (* (cos a) x) (* (sin a) y))
  36. (+ (* (sin a) x) (* (cos a) y))])
  37.  
  38. (defn add [[x0 y0] [x1 y1]]
  39. [(+ x0 x1) (+ y0 y1)])
  40.  
  41. (defn minus [[x0 y0] [x1 y1]]
  42. [(- x0 x1) (- y0 y1)])
  43.  
  44. (defn rotate-around [center a p]
  45. (add center (rotate a (minus p center))))
  46.  
  47. (defn cross-product [[x0 y0] [x1 y1]]
  48. (+ (* x0 x1) (* y0 y1)))
  49.  
  50. (def norm-sq #(cross-product % %))
  51.  
  52. (defn scalar-multiply [k [x y]]
  53. [(* k x) (* k y)])
  54.  
  55.  
  56.  
  57. ;; TODO macro !!!
  58. ;; (def comp (add-functional-meta comp))
  59. ;; (def juxt (add-functional-meta juxt))
  60. ;; (def apply (add-functional-meta apply))
  61.  
  62. ;; (def add (add-functional-meta add))
  63. ;; (def rotate (add-functional-meta rotate))
  64. ;; (def scalar-multiply (add-functional-meta scalar-multiply))
  65.  
  66. ;; (def mapv (add-functional-meta mapv))
  67. ;; (def merged-juxt (add-functional-meta merged-juxt))
  68.  
  69.  
  70.  
  71. (defn eltwise_op [op [x0 y0] [x1 y1]]
  72. [(op x0 x1) (op y0 y1)])
  73.  
  74.  
  75. (defn barycenter [ps]
  76. (scalar-multiply (/ 1 (count ps)) (reduce add [0. 0.] ps)))
  77.  
  78. (defn regular-polygon [n]
  79. (take n (iterate (partial rotate (/ (* 2 pi) n)) [1. 0.])))
  80.  
  81. (defn fractal-step [[step-f step-elts] current-elts]
  82. (into step-elts (step-f current-elts)))
  83.  
  84. (defn fractal [[init-elts step-params] details]
  85. (nth (iterate (partial fractal-step step-params) init-elts) details))
  86.  
  87. (defn close-polygon [ps] (conj (into [] ps) (first ps)))
  88.  
  89. (defn sierpinski-params [n]
  90. (let[step-elt (close-polygon (regular-polygon n))
  91. scale-f (partial scalar-multiply (/ 1 (dec n)))]
  92. (condp = n
  93. 3 [[]
  94. [(merged-juxt (for [i [0 1 2]](partial mapv (partial mapv (comp (partial add (rotate (+ pi (* i 2 (/ pi 3))) [1. 0.])) scale-f)))))
  95. [step-elt]]]
  96. 4 [[]
  97. [(merged-juxt (let [d [-1 0 1]](for [dx d
  98. dy d
  99. :when (not= 0 dx dy)]
  100. (partial mapv (partial mapv (comp (partial add (scalar-multiply (sqrt 2.) [dx dy])) scale-f))))))
  101. [(map (partial rotate (/ pi 4)) step-elt)]]])))
  102.  
  103. (defn tree-params [angles]
  104. (let[branch [0 1]
  105. ratio (/ (+ 1 (sqrt 5.)) 2.)]
  106. [[]
  107. [(merged-juxt (for [a angles](partial mapv (partial mapv (comp (partial add branch)
  108. (partial scalar-multiply (/ 1 ratio))
  109. (partial rotate a))))))
  110. [[[0. 0] branch]]]]))
  111.  
  112. (def koch-params [[[[-0.5 0][0.5 0]]]
  113. [(merged-juxt (for [[v a] [[[(/ -1 3) 0] 0]
  114. [[(/ 1 3) 0] 0]
  115. [(rotate (/ pi 3) [(/ 1 6) 0]) (/ pi -3)]
  116. [(rotate (/ pi -3) [(/ -1 6) 0]) (/ pi 3)]]]
  117. (partial mapv (partial mapv (comp (partial add v) (partial rotate a) (partial scalar-multiply (/ 1 3)))))))
  118. []]])
  119.  
  120. (def positive-infinity (.-POSITIVE_INFINITY js/Number))
  121. (def negative-infinity (.-NEGATIVE_INFINITY js/Number))
  122.  
  123. (defn bounding-box [ps]
  124. (reduce (fn [[[x-min y-min][x-max y-max]] [x y]]
  125. [ [(min x-min x) (min y-min y)] [(max x-max x) (max y-max y)]])
  126. [[positive-infinity positive-infinity] [negative-infinity negative-infinity]]
  127. ps))
  128.  
  129. (defn merge-bb [[[x-min y-min][x-max y-max]] [[X-min Y-min][X-max Y-max]]]
  130. [[(min x-min X-min) (min y-min Y-min)] [(max x-max X-max) (max y-max Y-max)]])
  131.  
  132. (defn adjust-bounding-box [preserve-ratio target-box scene]
  133. (let [scene-bb (reduce merge-bb (map bounding-box scene))
  134. center-f (fn[box] (let[center (barycenter box)][center (apply minus (mapv #(minus % center) box))]))
  135. [target-c target-centered] (center-f target-box)
  136. [scene-c scene-centered] (center-f scene-bb)
  137. scaling (partial eltwise_op *
  138. (let[tmp (eltwise_op / target-centered scene-centered)]
  139. (if preserve-ratio
  140. (scalar-multiply (apply min (map abs tmp)) (map sign tmp))
  141. tmp)))]
  142. (fn[v] (-> v (minus scene-c) scaling (add target-c)))))
  143.  
  144. (defn display-fractal [id params details]
  145. (let [root (dom/by-id id)
  146. display-params {:width 300 :height 300}
  147. color "#000"
  148. draw #(svg/line-strip % )
  149. display #(dom/create-dom! (let [[w h] ((juxt :width :height) display-params)
  150. f (adjust-bounding-box true [[0 h][w 0]] %)]
  151. (svg/svg display-params (svg/group {:stroke color} (map (comp draw (partial mapv f)) %))))
  152. root)
  153. scene (fractal params details)]
  154. (display scene)))
  155.  
  156. (defn -main
  157. []
  158. (do
  159. (let[ f (my-partial add [0 1])
  160. ]
  161. (shodan/inspect (meta f)))
  162. (doall (for [details (range 1 5)
  163. params [(sierpinski-params 3)
  164. (sierpinski-params 4)
  165. koch-params
  166. (tree-params [(/ pi 6) (/ pi -3)])
  167. ]]
  168. (display-fractal (str "fractals-" details) params details)))
  169. )
  170. )
  171.  
  172. (-main)
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement