near/heyarne.thi.ng.utils
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Transducers are magical

Browse source
This commit is contained in:
heyarne 2020-07-22 09:45:00 +02:00
commit a50ce7db4f
2 changed files with 34 additions and 28 deletions
Download patch file Download diff file Expand all files Collapse all files

60
src/heyarne/thi/ng/utils/poisson.clj
View file

@ -9,6 +9,14 @@
;;
;; This namespace implements Poisson-Disk-Sampling in two dimensions with the help of a quadtree.
(defn- find-first
"Returns a reducing function that returns the first item in a collection
satisifying `pred?`"
[pred?]
(completing (fn [_ candidate]
(when (pred? candidate)
(reduced candidate)))))
(defn poisson
"Given a `container` to find points within, the numbers of samples to generate
in each step `k` and a minimum distance between to samples `r`, returns a
@ -21,31 +29,29 @@
keep-sample? (partial g/contains-point? bounds)]
(loop [tree (tree/quadtree bounds)
active #{seed}]
(if (empty? active)
;; we're done! let's flatten the tree. note that we throw out some of
;; our generated samples by calling #(contains-point? container %)
(persistent! (tree/select-with tree (constantly true) (partial g/contains-point? container)))
(if (seq active)
;; while the active list is not empty, choose a random index from it and
;; generate up to `k` within a radius of [r, 2r]; for each point in turn,
;; check if it is within distance r of existing samples
(let [sample (first active)
candidates (into []
(comp
(map #(-> (m/*! % (+ r (m/random r)))
(m/+! sample)))
(filter keep-sample?))
(repeatedly k v/randvec2))
fit (when (seq candidates)
(reduce (fn
([_ candidate]
(when-not (tree/points-in-circle? tree candidate r)
(reduced candidate))))
candidates))]
fit (transduce
;; take k samples and keep the ones within our container
(comp (take k)
(map #(-> (m/*! % (+ r (m/random r)))
(m/+! sample)))
(filter keep-sample?))
;; take the first sample that is not within distance r
(find-first #(not (tree/points-in-circle? tree % r)))
nil
(repeatedly v/randvec2))]
(if fit
;; If a point is adequately far from existing samples, emit it as the next sample and add it to the active list
(recur (g/add-point tree fit fit) (conj active fit))
;; if no such point is found, remove the sample from the list of active samples
(recur tree (disj active sample)))))))))
(recur tree (disj active sample))))
;; we're done! let's flatten the tree. note that we throw out some of
;; our generated samples by calling #(contains-point? container %)
(persistent! (tree/select-with tree (partial g/intersect-shape container) (partial g/contains-point? container))))))))
(comment
;; let's run some benchmarks (on my Thinkpad x230 from 2012)
@ -56,17 +62,17 @@
(crit/with-progress-reporting
(crit/bench (poisson (r/rect [-100 -100] [100 100]) 20 10)))
;; Execution time mean : 33.575985 ms
;; Execution time std-deviation : 805.351384 µs
;; Execution time lower quantile : 32.545556 ms ( 2.5%)
;; Execution time upper quantile : 35.375681 ms (97.5%)
;; Overhead used : 1.869092 ns
;; Execution time mean : 25.688646 ms
;; Execution time std-deviation : 1.258751 ms
;; Execution time lower quantile : 24.332119 ms ( 2.5%)
;; Execution time upper quantile : 28.330404 ms (97.5%)
;; Overhead used : 1.897778 ns
(crit/with-progress-reporting
(crit/bench (poisson (c/circle [-100 -100] 200) 20 10)))
;; Execution time mean : 170.229276 ms
;; Execution time std-deviation : 16.657318 ms
;; Execution time lower quantile : 156.769577 ms ( 2.5%)
;; Execution time upper quantile : 225.024192 ms (97.5%)
;; Overhead used : 1.869092 ns
;; Execution time mean : 126.305551 ms
;; Execution time std-deviation : 8.107330 ms
;; Execution time lower quantile : 119.070887 ms ( 2.5%)
;; Execution time upper quantile : 147.724269 ms (97.5%)
;; Overhead used : 1.897778 ns
)