# HG changeset patch # User Steve Losh # Date 1520394020 18000 # Node ID 148a6a1cc9eb925e54e57a3ccbf86f3d79c033d3 # Parent 23a4ab452609ae8fbf140318d8e8ddeab33b4ff2 Add simple triangulations diff -r 23a4ab452609 -r 148a6a1cc9eb flax.asd --- 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"))))))) diff -r 23a4ab452609 -r 148a6a1cc9eb package.lisp --- 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)) + diff -r 23a4ab452609 -r 148a6a1cc9eb src/coordinates.lisp --- 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))) diff -r 23a4ab452609 -r 148a6a1cc9eb src/drawing/api.lisp --- 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)) diff -r 23a4ab452609 -r 148a6a1cc9eb src/drawing/png.lisp --- 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) <>)))) diff -r 23a4ab452609 -r 148a6a1cc9eb src/drawing/svg.lisp --- 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)))))) diff -r 23a4ab452609 -r 148a6a1cc9eb src/looms/003-basic-l-systems.lisp --- 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)) diff -r 23a4ab452609 -r 148a6a1cc9eb src/looms/005-simple-triangulations.lisp --- /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)) diff -r 23a4ab452609 -r 148a6a1cc9eb vendor/lofi-tri/lofi.tri.lisp --- /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 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))))