de5ea4119ef4

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/art/simple.lisp	Fri Jan 26 23:15:34 2018 -0500
@@ -0,0 +1,109 @@
+(losh:eval-dammit
+  (ql:quickload '(:trivial-ppm)))
+
+(defpackage :sand.art.simple
+  (:use
+    :cl
+    :losh
+    :iterate
+    :sand.quickutils))
+
+(in-package :sand.art.simple)
+
+;; http://www.tylerlhobbs.com/writings/triangle-subdivision
+
+(defun v (x y)
+  (make-array 2 :element-type 'single-float :initial-contents (list x y)))
+
+(defun-inline x (v)
+  (aref v 0))
+
+(defun-inline y (v)
+  (aref v 1))
+
+
+(defun v+ (v1 v2)
+  (v (+ (x v1) (x v2))
+     (+ (y v1) (y v2))))
+
+(defun v/ (v scalar)
+  (v (/ (x v) scalar)
+     (/ (y v) scalar)))
+
+
+(defstruct (triangle (:conc-name ""))
+  (a (v 0.0 0.0) :type (simple-array single-float (2)))
+  (b (v 0.0 0.0) :type (simple-array single-float (2)))
+  (c (v 0.0 0.0) :type (simple-array single-float (2))))
+
+(defun triangle (a b c)
+  (make-triangle :a a :b b :c c))
+
+
+(defun image-coords (image point)
+  (destructuring-bind (width height) (array-dimensions image)
+    (values (truncate (* (x point) (1- width)))
+            (truncate (* (y point) (1- height))))))
+
+(defun draw-vertical-line (image p1 p2)
+  (if (< (y p2) (y p1))
+    (draw-vertical-line image p2 p1)
+    (nest
+      (multiple-value-bind (x1 y1) (image-coords image p1))
+      (multiple-value-bind (x2 y2) (image-coords image p2))
+      (iterate (for y :from y1 :below y2)
+               (for x = (floor (map-range y1 y2 x1 x2 y)))
+               (setf (aref image x y) 0)))))
+
+(defun draw-horizontal-line (image p1 p2)
+  (if (< (x p2) (x p1))
+    (draw-horizontal-line image p2 p1)
+    (nest
+      (multiple-value-bind (x1 y1) (image-coords image p1))
+      (multiple-value-bind (x2 y2) (image-coords image p2))
+      (iterate (for x :from x1 :below x2)
+               (for y = (floor (map-range x1 x2 y1 y2 x)))
+               (setf (aref image x y) 0)))))
+
+(defun slope (v1 v2)
+  (let ((run (- (x v2) (x v1)))
+        (rise (- (y v2) (y v1))))
+    (/ rise run)))
+
+(defun draw-line (image p1 p2)
+  (if (or (= (x p1) (x p2))
+          (> (abs (slope p1 p2)) 1))
+    (if (= (y p1) (y p2))
+      nil
+      (draw-vertical-line image p1 p2))
+    (draw-horizontal-line image p1 p2)))
+
+(defun draw-triangle (image triangle)
+    (draw-line image (a triangle) (b triangle))
+    (draw-line image (b triangle) (c triangle))
+    (draw-line image (c triangle) (a triangle)))
+
+(defun split-triangle (triangle)
+  (let* ((a (a triangle))
+         (b (b triangle))
+         (c (c triangle))
+         (n (clamp 0.2 0.8 (random-gaussian 0.5 0.05)))
+         (p (v (lerp (x b) (x c) n)
+               (lerp (y b) (y c) n))))
+    (list (triangle p b a)
+          (triangle p a c))))
+
+
+(defun draw (width height)
+  (let ((image (make-array (list width height) :initial-element 255)))
+    (recursively ((triangle (triangle (v 0.05 0.05)
+                                      (v 0.05 0.95)
+                                      (v 0.95 0.05)))
+                  (depth 6))
+      (if (zerop depth)
+        (draw-triangle image triangle)
+        (dolist (tri (split-triangle triangle))
+          (recur tri (1- depth)))))
+    (trivial-ppm:write-to-file "triangles.pgm" image
+                               :format :pgm
+                               :if-exists :supersede)))