--- a/flax.asd Mon Mar 05 14:33:44 2018 -0500
+++ b/flax.asd Tue Mar 06 22:40:20 2018 -0500
@@ -6,6 +6,7 @@
:depends-on (
+ :sb-cga ; for lofi-tri only
:cl-pcg
:cl-svg
:cl-vectors
@@ -16,23 +17,27 @@
)
:serial t
- :components ((:module "vendor" :serial t
- :components ((:file "quickutils-package")
- (:file "quickutils")))
- (:file "package")
- (:module "src" :serial t
- :components
- ((:file "base")
- (:file "coordinates")
- (:file "colors")
- (:module "drawing" :serial t
- :components ((:file "api")
- (:file "png")
- (:file "svg")))
- (:module "looms" :serial nil
- :components
- ((:file "001-triangles")
- (:file "002-wobbly-lines")
- (:file "003-basic-l-systems")
- (:file "004-turtle-curves")))))))
+ :components
+ ((:module "vendor" :serial t
+ :components ((:file "quickutils-package")
+ (:file "quickutils")
+ (:module "lofi-tri"
+ :components ((:file "lofi.tri")))))
+ (:file "package")
+ (:module "src" :serial t
+ :components
+ ((:file "base")
+ (:file "coordinates")
+ (:file "colors")
+ (:module "drawing" :serial t
+ :components ((:file "api")
+ (:file "png")
+ (:file "svg")))
+ (:module "looms" :serial nil
+ :components
+ ((:file "001-triangles")
+ (:file "002-wobbly-lines")
+ (:file "003-basic-l-systems")
+ (:file "004-turtle-curves")
+ (:file "005-simple-triangulations")))))))
--- a/package.lisp Mon Mar 05 14:33:44 2018 -0500
+++ b/package.lisp Tue Mar 06 22:40:20 2018 -0500
@@ -7,7 +7,8 @@
(:export
:coord :x :y
:distance
- :clerp))
+ :clerp
+ :coord-to-cons))
(defpackage :flax.colors
(:use :cl :iterate :losh :flax.base :flax.quickutils)
@@ -28,7 +29,8 @@
:triangle
:path
:points
- :rectangle))
+ :rectangle
+ :circle))
(defpackage :flax.looms.001-triangles
@@ -54,4 +56,10 @@
:flax.coordinates)
(:export :loom))
+(defpackage :flax.looms.005-simple-triangulations
+ (:use :cl :iterate :losh :flax.base :flax.quickutils
+ :flax.colors
+ :flax.coordinates)
+ (:export :loom))
+
--- a/src/coordinates.lisp Mon Mar 05 14:33:44 2018 -0500
+++ b/src/coordinates.lisp Tue Mar 06 22:40:20 2018 -0500
@@ -16,3 +16,6 @@
(defun clerp (from to n)
(coord (lerp (x from) (x to) n)
(lerp (y from) (y to) n)))
+
+(defun coord-to-cons (c)
+ (cons (x c) (y c)))
--- a/src/drawing/api.lisp Mon Mar 05 14:33:44 2018 -0500
+++ b/src/drawing/api.lisp Tue Mar 06 22:40:20 2018 -0500
@@ -21,16 +21,30 @@
0 dimension
value))
+(defun convert-magnitude (canvas magnitude)
+ (let ((dim (min (height canvas) (width canvas))))
+ (lerp 0 (- dim (* 2 *padding* dim)) magnitude)))
+
+
(defmacro with-coordinates (canvas bindings &body body)
- (with-gensyms (width height)
- `(with-canvas (,canvas ,width ,height)
- (let* ,(iterate (for (x-symbol y-symbol coord) :in bindings)
- (for c = (gensym "coord"))
- (appending
- (list `(,c ,coord)
- `(,x-symbol (convert-coord (x ,c) ,width))
- `(,y-symbol (convert-coord (y ,c) ,height)))))
- ,@body))))
+ (once-only (canvas)
+ (with-gensyms (width height)
+ (labels ((parse-coord-binding (binding)
+ (with-gensyms (coord)
+ (destructuring-bind (x-symbol y-symbol value) binding
+ `((,coord ,value)
+ (,x-symbol (convert-coord (x ,coord) ,width))
+ (,y-symbol (convert-coord (y ,coord) ,height))))))
+ (parse-magnitude-binding (binding)
+ (destructuring-bind (magnitude-symbol value) binding
+ `((,magnitude-symbol (convert-magnitude ,canvas ,value)))))
+ (parse-binding (binding)
+ (ecase (length binding)
+ (2 (parse-magnitude-binding binding))
+ (3 (parse-coord-binding binding)))))
+ `(with-canvas (,canvas ,width ,height)
+ (let* ,(mapcan #'parse-binding bindings)
+ ,@body))))))
(defun coord-to-string (c)
@@ -91,7 +105,7 @@
(defclass* (rectangle :conc-name "") (drawable)
((a :type coord)
(b :type coord)
- (round-corners :type (or null integer))))
+ (round-corners :type float :initform 0.0)))
(defun rectangle (a b &key (opacity 1.0d0) (color *black*) round-corners)
(make-instance 'rectangle :a a :b b
@@ -116,6 +130,24 @@
0))
+;;;; Circles ------------------------------------------------------------------
+(defclass* (circle :conc-name "") (drawable)
+ ((center :type coord)
+ (radius :type single-float)))
+
+(defun circle (center radius &key (opacity 1.0d0) (color *black*))
+ (make-instance 'circle :center center :radius radius
+ :color color
+ :opacity (coerce opacity 'double-float)))
+
+(defmethod print-object ((o circle) s)
+ (print-unreadable-object (o s :type t :identity nil)
+ (format s "(~D, ~D) radius ~D"
+ (x (center o))
+ (y (center o))
+ (radius o))))
+
+
;;;; Rendering ----------------------------------------------------------------
(defgeneric render-object (canvas object))
--- a/src/drawing/png.lisp Mon Mar 05 14:33:44 2018 -0500
+++ b/src/drawing/png.lisp Tue Mar 06 22:40:20 2018 -0500
@@ -57,12 +57,18 @@
(defmethod draw ((canvas png-canvas) (rect rectangle))
(with-coordinates canvas
((ax ay (a rect))
- (bx by (b rect)))
- (-<> (paths:make-rectangle-path
- ax ay bx by
- :round (compute-corner-rounding canvas rect))
- ;; paths:make-simple-path
- ;; (paths:stroke-path <> 1)
+ (bx by (b rect))
+ (r (round-corners rect)))
+ (-<> (paths:make-rectangle-path ax ay bx by :round r)
+ (vectors:update-state (state canvas) <>))))
+
+
+;;;; Circles ------------------------------------------------------------------
+(defmethod draw ((canvas png-canvas) (circ circle))
+ (with-coordinates canvas
+ ((x y (center circ))
+ (r (radius circ)))
+ (-<> (paths:make-circle-path x y r)
(vectors:update-state (state canvas) <>))))
--- a/src/drawing/svg.lisp Mon Mar 05 14:33:44 2018 -0500
+++ b/src/drawing/svg.lisp Tue Mar 06 22:40:20 2018 -0500
@@ -28,17 +28,27 @@
(defmethod draw ((canvas svg-canvas) (rect rectangle))
(with-coordinates canvas
((ax ay (a rect))
- (bx by (b rect)))
- (let ((rounding (compute-corner-rounding canvas rect)))
- (svg:draw (scene canvas) (:rect
- :x (min ax bx)
- :y (min ay by)
- :rx rounding
- :ry rounding
- :width (abs (- ax bx))
- :height (abs (- ay by))
- :fill (web-color (color rect))
- :fill-opacity (opacity rect))))))
+ (bx by (b rect))
+ (r (round-corners rect)))
+ (svg:draw (scene canvas) (:rect
+ :x (min ax bx)
+ :y (min ay by)
+ :rx r
+ :ry r
+ :width (abs (- ax bx))
+ :height (abs (- ay by))
+ :fill (web-color (color rect))
+ :fill-opacity (opacity rect)))))
+
+
+;;;; Circles ------------------------------------------------------------------
+(defmethod draw ((canvas svg-canvas) (circ circle))
+ (with-coordinates canvas
+ ((x y (center circ))
+ (r (radius circ)))
+ (svg:draw (scene canvas) (:circle :cx x :cy y :r r
+ :fill (web-color (color circ))
+ :fill-opacity (opacity circ)))))
;;;; Paths --------------------------------------------------------------------
@@ -73,7 +83,7 @@
(list bx by)
(list cx cy)))
:fill "none"
- :stroke-width 0.25
+ :stroke-width 1
:stroke-opacity (opacity tri)
:stroke (web-color (color tri))))))
--- a/src/looms/003-basic-l-systems.lisp Mon Mar 05 14:33:44 2018 -0500
+++ b/src/looms/003-basic-l-systems.lisp Tue Mar 06 22:40:20 2018 -0500
@@ -107,4 +107,4 @@
:callback (lambda (iteration word)
(flax.drawing:render canvas (convert word iteration)))))))
-;; (time (loom-anabaena-catenula nil "out" :svg 2000 2000))
+;; (time (loom-anabaena-catenula nil "out" :png 2000 2000))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/looms/005-simple-triangulations.lisp Tue Mar 06 22:40:20 2018 -0500
@@ -0,0 +1,59 @@
+(in-package :flax.looms.005-simple-triangulations)
+
+;; https://mattdesl.svbtle.com/pen-plotter-1
+
+(defparameter *point-size* 0.004)
+
+(defun convert-point (point)
+ (flax.drawing:circle point *point-size*))
+
+(defun convert-triangle (tri)
+ (destructuring-bind (a b c) tri
+ (flax.drawing:triangle a b c)))
+
+(defun convert (points)
+ (append
+ (map 'list #'convert-point points)
+ (map 'list #'convert-triangle (triangulate points))))
+
+(defun triangulate (points)
+ (mapcar (lambda (indexes)
+ (map 'list (curry #'aref points) indexes))
+ (lofi.tri:triangulate (map 'vector #'coord-to-cons points))))
+
+(defun gauss ()
+ (clamp 0.0 1.0 (random-gaussian 0.5 0.15 #'rand)))
+
+(defun generate-point-uniform ()
+ (coord (rand 1.0) (rand 1.0)))
+
+(defun generate-point-gaussian ()
+ (coord (gauss) (gauss)))
+
+(defun generate-point-gaussian-vertical ()
+ (coord (rand 1.0) (gauss)))
+
+(defun generate-point-gaussian-horizontal ()
+ (coord (gauss) (rand 1.0)))
+
+(defun generate (generator n)
+ (iterate (repeat n)
+ (collect (funcall generator)
+ :result-type 'vector)))
+
+(defun loom (seed points filename filetype width height)
+ (losh::clear-gaussian-spare)
+ (with-seed seed
+ (flax.drawing:with-rendering (canvas filetype filename width height
+ :background (hsv 0.09 0.05 0.975))
+ (destructuring-bind (generator generator-name)
+ (random-elt '((generate-point-uniform "Uniform")
+ (generate-point-gaussian "Gaussian")
+ (generate-point-gaussian-vertical "Vertical Gaussian")
+ (generate-point-gaussian-horizontal "Horizontal Gaussian"))
+ #'rand)
+ (flax.drawing:render canvas (convert (generate generator points)))
+ generator-name))))
+
+
+;; (time (loom nil (* 10 (random 100)) "out" :png 800 800))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/vendor/lofi-tri/lofi.tri.lisp Tue Mar 06 22:40:20 2018 -0500
@@ -0,0 +1,250 @@
+;;;; lofi-tri.lisp
+;;; Code vendored from https://github.com/photex/lofi-tri
+;;; TODO: Implement a divide & conquer algorithm at some point.
+
+(defpackage #:lofi.tri
+ (:use #:cl #:sb-cga)
+ (:export #:circle
+ #:triangle
+ #:random-point
+ #:random-point-array
+ #:sort-by-x
+ #:sort-by-y
+ #:sort-by-z
+ #:distance
+ #:midpoint
+ #:circumcircle
+ #:center
+ #:radius
+ #:verts
+ #:in-circumcircle?
+ #:has-shared-verts?
+ #:triangulate))
+
+(in-package #:lofi.tri)
+
+;;; "lofi-tri" goes here. Hacks and glory await!
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; structs
+
+(defstruct circle
+ (center nil :type vec)
+ (radius 0.0 :type float)
+ (radius-squared 0.0 :type float)
+ (diameter 0.0 :type float))
+
+(defstruct triangle
+ (verts #() :type vector)
+ (circumcircle nil :type circle))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Utilities
+
+(defun random-point (&optional (state *random-state*))
+ "Return an instance of sb-cga:vec initialized with random values."
+ (apply #'vec (loop repeat 3
+ collect (random 1.0 state))))
+
+(defun random-point-array (count &optional (state *random-state*))
+ "Returns an array of <count> random-points."
+ (let ((result (make-array count :fill-pointer 0)))
+ (dotimes (i count)
+ (vector-push (random-point state) result))
+ result))
+
+(defmacro sort-by (point-set index)
+ "Sort the input point set by the value in the specified index."
+ `(sort ,point-set #'< :key (lambda (p) (aref p ,index))))
+
+(defmacro sort-by-x (point-set)
+ "Sort the input point set by the value at 0"
+ `(sort-by ,point-set 0))
+
+(defmacro sort-by-y (point-set)
+ "Sort the input point set by the value at 1"
+ `(sort-by ,point-set 1))
+
+(defmacro sort-by-z (point-set)
+ "Sort the input point set by the value at 2"
+ `(sort-by ,point-set 2))
+
+(defun get-min-max (point-set)
+ "Return the min and max vectors for the given point set. Effectively the bounding box."
+ (let* ((first-point (aref point-set 0))
+ (rest-points (subseq point-set 1))
+ (minx (aref first-point 0)) (maxx (aref first-point 0))
+ (miny (aref first-point 1)) (maxy (aref first-point 1))
+ (minz (aref first-point 2)) (maxz (aref first-point 2)))
+ (loop :for p :across rest-points :do
+ (setf minx (min minx (aref p 0)) maxx (max maxx (aref p 0))
+ miny (min miny (aref p 1)) maxy (max maxy (aref p 1))
+ minz (min minz (aref p 2)) maxz (max maxz (aref p 2))))
+ (values (vec minx miny minz) (vec maxx maxy maxz))))
+
+(defun get-bounding-triangle-points (point-set &optional (fudge-factor 10))
+ (multiple-value-bind (min max) (get-min-max point-set)
+ (let ((dx (* fudge-factor (- (aref max 0) (aref min 0))))
+ (dy (* fudge-factor (- (aref max 1) (aref min 1)))))
+ (make-array 3 :initial-contents
+ (list (sb-cga:vec (- (aref min 0) dx) (- (aref min 1) (* dy 3)) 0.0)
+ (sb-cga:vec (- (aref min 0) dx) (+ (aref max 1) dy) 0.0)
+ (sb-cga:vec (+ (aref max 0) (* dx 3)) (+ (aref max 1) dy) 0.0))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Meat and potatos
+
+(defun distance (v0 v1 &key 3d squared)
+ "Calculate the distance between two vectors in 2D or 3D.
+Will return the square root of the result unless :squared t"
+ (declare (type vec v0 v1))
+ (let* ((diff (vec- v0 v1))
+ (result (apply #'+ (loop for i from 0 upto (if 3d 2 1)
+ collect (expt (aref diff i) 2)))))
+ (if squared
+ result
+ (sqrt result))))
+
+(defun midpoint (v0 v1)
+ "Return a vector representing the midpoint between the two provided vectors."
+ (declare (type vec v0 v1))
+ (vec/ (vec+ v0 v1) 2.0))
+
+(defun circumcircle (v0 v1 v2)
+ "Returns a circle struct representing the circumcircle of the given 3 vertices"
+ (let* ((v1-v0 (vec- v1 v0))
+ (v2-v0 (vec- v2 v0))
+ (v2-v1 (vec- v2 v1))
+ (v1+v0 (vec+ v1 v0))
+ (v2+v0 (vec+ v2 v0))
+ (a (aref v1-v0 0))
+ (b (aref v1-v0 1))
+ (c (aref v2-v0 0))
+ (d (aref v2-v0 1))
+ (e (+ (* a (aref v1+v0 0))
+ (* b (aref v1+v0 1))))
+ (f (+ (* c (aref v2+v0 0))
+ (* d (aref v2+v0 1))))
+ (g (* 2.0 (- (* a (aref v2-v1 1))
+ (* b (aref v2-v1 0)))))
+ (colinear? (< (abs g) +default-epsilon+))
+ (cx 0.0) (cy 0.0) (dx 0.0) (dy 0.0))
+ (if colinear?
+ (let ((minx (min (aref v0 0) (aref v1 0) (aref v2 0)))
+ (miny (min (aref v0 1) (aref v1 1) (aref v2 1)))
+ (maxx (max (aref v0 0) (aref v1 0) (aref v2 0)))
+ (maxy (max (aref v0 1) (aref v1 1) (aref v2 1))))
+ (setf cx (/ (+ minx maxx) 2)
+ cy (/ (+ miny maxy) 2)
+ dx (- cx minx)
+ dy (- cy miny)))
+ ;; else
+ (setf cx (/ (- (* d e) (* b f)) g)
+ cy (/ (- (* a f) (* c e)) g)
+ dx (- cx (aref v0 0))
+ dy (- cy (aref v0 1))))
+ (let* ((radius-squared (+ (* dx dx)
+ (* dy dy)))
+ (radius (sqrt radius-squared)))
+ (make-circle :center (vec cx cy 0.0)
+ :radius radius
+ :radius-squared radius-squared
+ :diameter (* radius 2)))))
+
+(defun new-triangle (vi0 vi1 vi2 points)
+ "Returns a new triangle."
+ (let ((v0 (aref points vi0))
+ (v1 (aref points vi1))
+ (v2 (aref points vi2)))
+ (make-triangle :verts (make-array 3 :initial-contents (list vi0 vi1 vi2))
+ :circumcircle (circumcircle v0 v1 v2))))
+
+(defun in-circumcircle? (tri p)
+ "Does point 'p' sit within the circumcircle of 'tri'?"
+ (declare (type triangle tri) (type vec p))
+ (let* ((circumcircle (slot-value tri 'circumcircle))
+ (center (slot-value circumcircle 'center))
+ (dist-squared (distance center p :squared t)))
+ (<= dist-squared (slot-value circumcircle 'radius-squared))))
+
+(defmacro edge= (a b)
+ `(or (and (= (first ,a) (first ,b))
+ (= (second ,a) (second ,b)))
+ (and (= (first ,a) (second ,b))
+ (= (second ,a) (first ,b)))))
+
+(defun unique-edge? (edges a)
+ (let ((instance-count (length (remove-if-not (lambda (b) (edge= a b)) edges))))
+ (<= instance-count 1)))
+
+(defun has-shared-verts? (a b)
+ (declare (type triangle a b))
+ (let* ((averts (slot-value a 'verts))
+ (bverts (slot-value b 'verts))
+ (av0 (aref averts 0))
+ (av1 (aref averts 1))
+ (av2 (aref averts 2))
+ (bv0 (aref bverts 0))
+ (bv1 (aref bverts 1))
+ (bv2 (aref bverts 2)))
+ (or (= bv0 av0) (= bv0 av1) (= bv0 av2)
+ (= bv1 av0) (= bv1 av1) (= bv1 av2)
+ (= bv2 av0) (= bv2 av1) (= bv2 av2))))
+
+(defun add-vertex (vi triangles points)
+ (let* ((edges ())
+ (unaffected-tris ()))
+ ;; For each triangle in the list we take the edges
+ ;; of any triangle where vert is inside it's circumcircle
+ ;; and append it to the edges list. Otherwise the triangle
+ ;; is collected and stored in unaffected-tris
+ (setf unaffected-tris
+ (loop for tri in triangles
+ if (in-circumcircle? tri (aref points vi))
+ do (let* ((verts (slot-value tri 'verts))
+ (e0 (list (aref verts 0) (aref verts 1)))
+ (e1 (list (aref verts 1) (aref verts 2)))
+ (e2 (list (aref verts 2) (aref verts 0))))
+ (setf edges (append edges (list e0 e1 e2))))
+ else collect tri))
+
+ ;; Remove any edges that are duplicate so that the edge
+ ;; list only contains the boundary edges.
+ (setf edges (remove-if-not (lambda (edge)
+ (unique-edge? edges edge))
+ edges))
+
+ ;; Using the remaining edges and our input vert create
+ ;; new triangles and return them appended to our unaffected-tris list
+ (append unaffected-tris (loop for edge in edges
+ collect (let ((vi0 (first edge))
+ (vi1 (second edge)))
+ (new-triangle vi0 vi1 vi points))))))
+
+(defun triangulate (points)
+ (let* (;; sjl: let the input be something vanilla
+ (ps (map 'vector (lambda (point)
+ (sb-cga:vec (car point) (cdr point) 0.0))
+ points))
+ ;; Add the coords for a large bounding triangle to the point set
+ (st-coords (get-bounding-triangle-points ps))
+ (sti0 (length ps))
+ (sti1 (1+ sti0))
+ (sti2 (1+ sti1))
+ (ps (concatenate 'vector ps st-coords))
+ ;; Create the bounding triangle instance
+ (supertri (new-triangle sti0 sti1 sti2 ps))
+ ;; Initialize our triangle list
+ (triangles (list supertri)))
+
+ ;; For each point in the list we get an updated set
+ ;; of triangles by retesselating using the new point
+ (loop for i below (length ps)
+ do (setf triangles (add-vertex i triangles ps)))
+
+ ;; Remove any triangles that share points with the super triangle
+ (mapcar (lambda (triangle)
+ (slot-value triangle 'verts))
+ (remove-if (lambda (triangle)
+ (has-shared-verts? supertri triangle))
+ triangles))))