(ns death-mountains.core
  (:require [quil.core :as quil])
  (:import java.awt.Point))

(defrecord Tri [^Point left ^Point right ^Point top])

(defrecord Line [^Point p1 ^Point p2])

(defn point [x y] (Point. x y))

(defn triangle [xbase len height]
  (Tri. (point (- xbase (/ len 2)) 0) 
        (point (+ xbase (/ len 2)) 0)
        (point xbase height)))

(defn line 
  ([p1 p2] (with-meta (Line. p1 p2) 
                      {:dir (if (> (. p2 y) (. p1 y)) :up :down) 
                       :slope (let [denom (- (. p2 x) (. p1 x))]
                                (if (zero? denom) 0
                                  (/ (- (. p2 y) (. p1 y)) 
                                     (- (. p2 x) (. p1 x)))))}))
  ([x1 y1 x2 y2] (line (point x1 y1) (point x2 y2))))

(defn fx [^Line l] (. (:p1 l) x))

(defn lx [^Line l] (. (:p2 l) x))

(defn fy [^Line l] (. (:p1 l) y))

(defn ly [^Line l] (. (:p2 l) y))

(defn slope [^Line l] (:slope (meta l)))

(defn left-line? [^Line l] (= (:dir (meta l)) :up))

(defn contiguous? [^Line l1 ^Line l2] (= (:p2 l1) (:p1 l2)))

(defn tri-lines [^Tri tri] [(line (:left tri) (:top tri)) (line (:top tri) (:right tri))])

(defn compare-lines [^Line l1 ^Line l2]
  (cond 
   (< (fx l1) (fx l2)) -1
   (> (fx l1) (fx l2)) 1
   (> (slope l1) (slope l2)) -1
   :else 1))

(defn to-point [l t] 
  (let [len-x (- (lx l) (fx l)) len-y (- (ly l) (fy l))]
    (point (+ (fx l) (* t len-x)) (+ (fy l) (* t len-y)))))

(defn intersect? [^Line l1 ^Line l2]
  (if (= (:p2 l1) (:p2 l2)) false
    (letfn [(pip [^Line l1 ^Line l2]
                 (let [nx (- (fy l1) (ly l1)) ny (- 0 (- (fx l1) (lx l1)))
                       n (+ (* nx (- (fx l2) (fx l1))) (* ny (- (fy l2) (fy l1))))
                       d (+ (* (- 0 nx) (- (lx l2) (fx l2))) (* (- 0 ny) (- (ly l2) (fy l2))))]
                   (if (= 0 d) -1 (/ n d))))
            (fpip [^Line l1 ^Line l2] 
                  (let [t1 (pip l1 l2) t2 (pip l2 l1)]
                    (if (and (>= t1 0) (<= t1 1) (>= t2 0) (<= t2 1)) t2 -1)))]
      (let [t (fpip l1 l2) div (if (pos? t) (to-point l1 t) nil)]
        (if (pos? t)
          [(double t) (line (:p1 l1) div) (line div (:p2 l2))] 
          false)))))

(defn passed-seg? [last-seg test-seg] (< (lx test-seg) (lx last-seg)))

(defn drop-passed-segs [last-seg segs]
  (sort compare-lines (remove (partial passed-seg? last-seg) segs)))

(defn get-line-segs [tris] 
  (sort compare-lines (flatten (map tri-lines tris))))

(defn get-up-lines [segs] (filter left-line? segs))

(defn get-down-lines [segs] (filter (comp left-line?) segs))

(defn false-positive? [seg intersection]
  (let [part-seg (second intersection) 
        cross-seg (last intersection) 
        curr-slope (slope seg)
        part-slope (slope part-seg)
        cross-slope (slope cross-seg)]
    (if (or (and (neg? curr-slope) (neg? cross-slope) (> curr-slope cross-slope))
            (and (pos? curr-slope) (neg? cross-slope) (not= (:p1 cross-seg) (:p2 seg)))
            (= (:p1 part-seg) (:p2 part-seg)))
      true false)))

(defn intersect-points [seg segs]
  (sort-by first < (remove (partial false-positive? seg) (remove false? (map (partial intersect? seg) segs)))))

(defn next-seg [seg segs]
  (let [intersections (intersect-points seg segs)]
    (if (empty? intersections) [seg (first (drop-passed-segs seg (get-up-lines segs)))]
      [(second (first intersections)) (last (first intersections))])))

(defn divider [len] (apply str (conj (vec (repeat len "=-")) "=")))

(defn silhouette-segs [top-segs test-seg rem-segs]
  (if (nil? test-seg) []
    (let [next-top (next-seg test-seg rem-segs)]
      [(conj top-segs (first next-top)) (second next-top) (drop-passed-segs (first next-top) rem-segs)])))

(defn full-silhouette [segs]
  (->> [[] (first segs) segs]
       (iterate #(apply silhouette-segs %))
       (take-while not-empty)
       (last)
       (first)))

(defn full-silhouette-from-tris [tris] 
  (full-silhouette (get-line-segs tris)))

(defn rand-tri [w h] 
  (let [xbase (+ 10 (rand-int (- w 10)))
        len-bounds (if (< xbase (- w xbase)) xbase (- w xbase))]
    (triangle xbase (+ 10 (rand-int (- len-bounds 10))) (+ 10 (rand-int (- h 10))))))

(defn apply-colors [tris] (map #(with-meta % {:r (rand-int 200) :g (rand-int 200) :b (rand-int 200)}) tris))

(defn rand-tris [n w h] (repeatedly n #(rand-tri w h)))

(defn area-under-seg [seg]
  (let [b (- (lx seg) (fx seg))
        h (Math/abs (- (ly seg) (fy seg)))
        h2 (if (= (:dir (meta seg)) :up) (fy seg) (ly seg))]
    (+ (/ (* b h) 2) (* b h2))))

(defn setup []
  (quil/smooth)
  (quil/frame-rate 1)
  (quil/background 255 255 255))

(defn draw-tri [^Tri tri] 
  (quil/fill (:r (meta tri)) (:g (meta tri)) (:b (meta tri)) 50)
  (quil/triangle (. (:left tri) x) (. (:left tri) y)
                 (. (:top tri) x) (. (:top tri) y)
                 (. (:right tri) x) (. (:right tri) y)))

(defn draw [n w h]
  (let [tris (apply-colors (rand-tris n w h))
        silhouette (full-silhouette-from-tris tris)
        total-area (double (apply + (map area-under-seg silhouette)))
        _ (prn tris)
        _ (prn silhouette)
        _ (prn (count silhouette))]
    (fn []
      (quil/push-matrix)
      (quil/background 255 255 255)
      (quil/translate 0 (- h 1))
      (quil/scale 1 (- 0 1))
      (quil/stroke 255 255 255 0)
      (doall (map draw-tri tris))
      (quil/stroke 0 0 0 255)
      (quil/stroke-weight 2)
      (doall (map #(quil/line (fx %) (fy %) (lx %) (ly %)) silhouette))
      (quil/pop-matrix)
      (quil/fill 0 0 0 255)
      (quil/text-size 32)
      (quil/text (str "Area = " total-area " square units") 50 50))))

(let [w 800 h 600]
  (quil/defsketch example
                  :title "Death Mountains"
                  :setup setup
                  :draw (draw 200 w h)
                  :size [w h]))

Did you know? CLOSE

  • There are keyboard shortcuts!
    • When Creating A Paste
      • ALT+P Toggle Private
      • CTRL+Enter Create Paste
      • ALT+W Toggle word wrap
    • When Viewing A Paste
      • ALT+G Go to a line
      • ALT+CTRL+E Edit the paste
      • ALT+R Show the raw code
  • There are URL options!
    • When Creating A Paste
      • ?lang=Javascript to default to javascript
    • When Viewing A Paste
      • #L-N Jump to line number N
?