├── .ffignore ├── .hgignore ├── .lispwords ├── LICENSE.markdown ├── Makefile ├── README.markdown ├── flax.asd ├── src ├── base.lisp ├── colors.lisp ├── drawing │ ├── api.lisp │ ├── letters.lisp │ ├── plot.lisp │ ├── png.lisp │ └── svg.lisp ├── looms │ ├── 001-triangles.lisp │ ├── 002-wobbly-lines.lisp │ ├── 003-basic-l-systems.lisp │ ├── 004-turtle-curves.lisp │ ├── 005-simple-triangulations.lisp │ ├── 006-tracing-lines.lisp │ └── 007-stippling.lisp ├── package.lisp └── transform.lisp ├── test └── test.lisp └── vendor └── lofi-tri └── lofi.tri.lisp /.ffignore: -------------------------------------------------------------------------------- 1 | syntax:glob 2 | *.png 3 | *.svg 4 | -------------------------------------------------------------------------------- /.hgignore: -------------------------------------------------------------------------------- 1 | syntax: glob 2 | lisp.prof 3 | *.pnm 4 | *.pgm 5 | scratch.lisp 6 | *.png 7 | *.svg 8 | -------------------------------------------------------------------------------- /.lispwords: -------------------------------------------------------------------------------- 1 | (2 with-coordinates) 2 | (1 with-rendering) 3 | (2 define-l-system) 4 | -------------------------------------------------------------------------------- /LICENSE.markdown: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018 Steve Losh and contributors 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in all 11 | copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 19 | SOFTWARE. 20 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: test 2 | 3 | # Test ------------------------------------------------------------------------ 4 | test: 5 | sbcl --noinform --load test/test.lisp --eval '(quit)' 6 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | Weaving art from seeds. 2 | 3 | -------------------------------------------------------------------------------- /flax.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem :flax 2 | :description "Weaving art from seeds." 3 | 4 | :author "Steve Losh " 5 | :license "MIT" 6 | 7 | :depends-on ( 8 | 9 | :sb-cga ; for lofi-tri only 10 | :cl-pcg 11 | :cl-svg 12 | :cl-vectors 13 | :chancery 14 | :iterate 15 | :losh 16 | :zpng 17 | :3d-vectors 18 | :3d-matrices 19 | 20 | ) 21 | 22 | :serial t 23 | :components 24 | ((:module "vendor" :serial t 25 | :components ((:module "lofi-tri" 26 | :components ((:file "lofi.tri"))))) 27 | (:module "src" :serial t 28 | :components 29 | ((:file "package") 30 | (:file "base") 31 | (:file "colors") 32 | (:file "transform") 33 | (:module "drawing" :serial t 34 | :components ((:file "letters") 35 | (:file "api") 36 | (:file "png") 37 | (:file "svg") 38 | (:file "plot"))) 39 | (:module "looms" :serial nil 40 | :components 41 | ((:file "001-triangles") 42 | (:file "002-wobbly-lines") 43 | (:file "003-basic-l-systems") 44 | (:file "004-turtle-curves") 45 | (:file "005-simple-triangulations") 46 | (:file "006-tracing-lines") 47 | (:file "007-stippling"))))))) 48 | 49 | -------------------------------------------------------------------------------- /src/base.lisp: -------------------------------------------------------------------------------- 1 | (in-package :flax.base) 2 | 3 | ;;;; Randomness --------------------------------------------------------------- 4 | (defun rand (bound) 5 | (pcg:pcg-random t bound)) 6 | 7 | (defmacro with-seed (seed &body body) 8 | (once-only (seed) 9 | `(let ((pcg::*global-generator* 10 | (pcg:make-pcg :seed (pr (or ,seed (random (expt 2 31))) 'seed))) 11 | (chancery:*random* #'rand)) 12 | (losh.random::clear-gaussian-spare) 13 | ,@body))) 14 | 15 | (defmacro random-or (value random-form) 16 | (once-only (value random-form) 17 | `(or ,value ,random-form))) 18 | 19 | (defmacro randomly-initialize (bindings &body body) 20 | `(let ,(iterate (for (symbol init-form) :in bindings) 21 | (collect `(,symbol (random-or ,symbol ,init-form)))) 22 | ,@body)) 23 | 24 | 25 | ;;;; Math --------------------------------------------------------------------- 26 | (defun round-to (number precision) 27 | "Round `number` to the given `precision`. 28 | 29 | Examples: 30 | 31 | (round-to 13 10) ; => 10 32 | (round-to 15 10) ; => 20 33 | (round-to 44 25) ; => 50 34 | (round-to 457/87 1/2) ; => 11/2 35 | 36 | " 37 | (* precision (round number precision))) 38 | 39 | 40 | ;;;; Utils -------------------------------------------------------------------- 41 | (defun map-curried (function param sequence) 42 | (loop :for x :in sequence 43 | :do (funcall function param x))) 44 | 45 | (defun mapcar-curried (function param sequence) 46 | (loop :for x :in sequence 47 | :collect (funcall function param x))) 48 | -------------------------------------------------------------------------------- /src/colors.lisp: -------------------------------------------------------------------------------- 1 | (in-package :flax.colors) 2 | 3 | (declaim (inline color make-color)) 4 | 5 | (deftype color-float () 6 | '(double-float 0.0d0 1.0d0)) 7 | 8 | (defstruct (color (:conc-name "") 9 | (:constructor make-color (r g b))) 10 | (r 0.0d0 :type color-float) 11 | (g 0.0d0 :type color-float) 12 | (b 0.0d0 :type color-float)) 13 | 14 | (define-with-macro color r g b) 15 | 16 | (defun rgb (r g b) 17 | (make-color (coerce r 'double-float) 18 | (coerce g 'double-float) 19 | (coerce b 'double-float))) 20 | 21 | (defun-inline hsv-to-rgb (h s v) 22 | (declare (optimize speed) 23 | (type color-float h s v)) 24 | ;; https://en.wikipedia.org/wiki/HSL_and_HSV#From_HSV 25 | ;; look i don't know either mate i just transcribed the fuckin thing 26 | (let* ((h (* h 360.0d0)) ; convert 0-1 to 0-360 27 | (h% (/ h 60.0d0)) 28 | (c (* v s)) 29 | (x (* c (- 1.0d0 (abs (1- (mod h% 2)))))) 30 | (m (- v c))) 31 | (multiple-value-bind (r g b) 32 | (cond 33 | ((<= h% 1.0d0) (values c x 0.0d0)) 34 | ((<= h% 2.0d0) (values x c 0.0d0)) 35 | ((<= h% 3.0d0) (values 0.0d0 c x)) 36 | ((<= h% 4.0d0) (values 0.0d0 x c)) 37 | ((<= h% 5.0d0) (values x 0.0d0 c)) 38 | ((<= h% 6.0d0) (values c 0.0d0 x)) 39 | (t (values 0.0d0 0.0d0 0.0d0))) 40 | (values (+ r m) 41 | (+ g m) 42 | (+ b m))))) 43 | 44 | (defun hsv (h s v) 45 | (multiple-value-call #'make-color 46 | (hsv-to-rgb (coerce h 'double-float) 47 | (coerce s 'double-float) 48 | (coerce v 'double-float)))) 49 | 50 | -------------------------------------------------------------------------------- /src/drawing/api.lisp: -------------------------------------------------------------------------------- 1 | (in-package :flax.drawing) 2 | 3 | ;;;; Parameters --------------------------------------------------------------- 4 | (defparameter *black* (rgb 0 0 0)) 5 | (defparameter *white* (rgb 1 1 1)) 6 | 7 | 8 | ;;;; Canvas ------------------------------------------------------------------- 9 | (defclass* canvas () 10 | ((width :type (integer 1)) 11 | (height :type (integer 1)) 12 | (padding :type (single-float 0.0 0.5) :initform 0.03) 13 | (output-transformation :type mat3))) 14 | 15 | (defun recompute-output-transformation (canvas) 16 | (setf (output-transformation canvas) 17 | (transformation 18 | (place (vec 0 0) 19 | (vec (coerce (width canvas) 'single-float) 20 | (coerce (height canvas) 'single-float)) 21 | :padding (padding canvas))))) 22 | 23 | (defmethod initialize-instance :after ((canvas canvas) &key) 24 | (recompute-output-transformation canvas)) 25 | 26 | (define-with-macro canvas width height) 27 | 28 | (defgeneric make-canvas (type &key &allow-other-keys)) 29 | 30 | 31 | ;;;; Utils -------------------------------------------------------------------- 32 | (defun-inline homogenize (v) 33 | (vec3 (vx v) (vy v) 1)) 34 | 35 | (defun convert-coordinate (canvas coordinate) 36 | (let ((c (m* (output-transformation canvas) coordinate))) 37 | (values (vx3 c) (vy3 c)))) 38 | 39 | (defun convert-magnitude (canvas magnitude) 40 | (ntransform magnitude (output-transformation canvas))) 41 | 42 | 43 | (defmacro with-coordinate (canvas-symbol binding &body body) 44 | (ecase (length binding) 45 | (2 (destructuring-bind (magnitude-symbol value) binding 46 | `(let ((,magnitude-symbol (convert-magnitude ,canvas-symbol ,value))) 47 | ,@body))) 48 | (3 (destructuring-bind (x-symbol y-symbol value) binding 49 | `(multiple-value-bind (,x-symbol ,y-symbol) 50 | (convert-coordinate ,canvas-symbol ,value) 51 | ,@body))))) 52 | 53 | (defmacro with-coordinates (canvas bindings &body body) 54 | (once-only (canvas) 55 | `(nest 56 | ,@(mapcar (lambda (binding) 57 | `(with-coordinate ,canvas ,binding)) 58 | bindings) 59 | (progn ,@body)))) 60 | 61 | 62 | (defun coord-to-string (c) 63 | (format nil "(~A, ~A)" (vx c) (vy c))) 64 | 65 | (defun coord-to-pair (canvas c) 66 | (with-coordinates canvas ((x y c)) 67 | (cons x y))) 68 | 69 | (defun coords-to-pairs (canvas cs) 70 | (loop :for c :in cs :collect (coord-to-pair canvas c))) 71 | 72 | 73 | ;;;; Drawables ---------------------------------------------------------------- 74 | (defclass* drawable () 75 | ((opacity :type (double-float 0.0d0 1.0d0)) 76 | (color :type color))) 77 | 78 | (defgeneric draw (canvas drawing-object)) 79 | 80 | 81 | ;;;; Paths -------------------------------------------------------------------- 82 | (defclass* path (drawable) 83 | ((points :type list))) 84 | 85 | (defun normalize-point (point) 86 | (if (listp point) 87 | point 88 | (list point))) 89 | 90 | (defun normalize-points (points) 91 | (mapcar #'normalize-point points)) 92 | 93 | (defun path (points &key (opacity 1.0d0) (color *black*)) 94 | (make-instance 'path 95 | :points (mapcar-curried #'mapcar #'homogenize (normalize-points points)) 96 | :color color 97 | :opacity (coerce opacity 'double-float))) 98 | 99 | (defmethod print-object ((o path) s) 100 | (print-unreadable-object (o s :type t :identity nil) 101 | (format s "~{~A~^ -> ~}" 102 | (mapcar (compose #'coord-to-string #'first) (points o))))) 103 | 104 | (defmethod ntransform ((path path) transformation) 105 | (dolist (ps (points path)) 106 | (dolist (p ps) 107 | (ntransform p transformation))) 108 | path) 109 | 110 | 111 | ;;;; Triangles ---------------------------------------------------------------- 112 | (defclass* triangle (drawable) 113 | ((a :type vec3) 114 | (b :type vec3) 115 | (c :type vec3))) 116 | 117 | (defun triangle (a b c &key (opacity 1.0d0) (color *black*)) 118 | (make-instance 'triangle :a (homogenize a) :b (homogenize b) :c (homogenize c) 119 | :color color 120 | :opacity (coerce opacity 'double-float))) 121 | 122 | (defmethod print-object ((o triangle) s) 123 | (print-unreadable-object (o s :type t :identity nil) 124 | (format s "(~D, ~D) (~D, ~D) (~D, ~D)" 125 | (vx (a o)) 126 | (vy (a o)) 127 | (vx (b o)) 128 | (vy (b o)) 129 | (vx (c o)) 130 | (vy (c o))))) 131 | 132 | (defmethod ntransform ((triangle triangle) transformation) 133 | (ntransform (a triangle) transformation) 134 | (ntransform (b triangle) transformation) 135 | (ntransform (c triangle) transformation) 136 | triangle) 137 | 138 | 139 | ;;;; Rectangles --------------------------------------------------------------- 140 | (defclass* rectangle (drawable) 141 | ((a :type vec3) 142 | (b :type vec3) 143 | (round-corners :type float :initform 0.0))) 144 | 145 | (defun rectangle (a b &key (opacity 1.0d0) (color *black*) round-corners) 146 | (make-instance 'rectangle :a (homogenize a) :b (homogenize b) 147 | :color color 148 | :opacity (coerce opacity 'double-float) 149 | :round-corners (or round-corners 0.0))) 150 | 151 | (defmethod print-object ((o rectangle) s) 152 | (print-unreadable-object (o s :type t :identity nil) 153 | (format s "(~D, ~D) (~D, ~D)" 154 | (vx (a o)) 155 | (vy (a o)) 156 | (vx (b o)) 157 | (vy (b o))))) 158 | 159 | (defun compute-corner-rounding (canvas rect) 160 | (if-let ((rounding (round-corners rect))) 161 | (with-canvas (canvas) 162 | (* rounding 163 | (* (- 1.0 (* 2 (padding canvas))) 164 | (min height width)))) 165 | 0)) 166 | 167 | (defmethod ntransform ((rectangle rectangle) transformation) 168 | (ntransform (a rectangle) transformation) 169 | (ntransform (b rectangle) transformation) 170 | (zapf (round-corners rectangle) (ntransform % transformation)) 171 | rectangle) 172 | 173 | 174 | ;;;; Circles ------------------------------------------------------------------ 175 | (defclass* circle (drawable) 176 | ((center :type vec3) 177 | (radius :type single-float))) 178 | 179 | (defun circle (center radius &key (opacity 1.0d0) (color *black*)) 180 | (make-instance 'circle :center (homogenize center) :radius radius 181 | :color color 182 | :opacity (coerce opacity 'double-float))) 183 | 184 | (defmethod print-object ((o circle) s) 185 | (print-unreadable-object (o s :type t :identity nil) 186 | (format s "(~D, ~D) radius ~D" 187 | (vx (center o)) 188 | (vy (center o)) 189 | (radius o)))) 190 | 191 | (defmethod ntransform ((circle circle) transformation) 192 | (ntransform (center circle) transformation) 193 | ;; For non-aspect-ratio-preserving transformations, we want to keep circles 194 | ;; as circles, but ensure they fit within the new bounding box. So we take 195 | ;; the smaller of the two possible radius transformations. 196 | (let ((a (vec 0 0 1)) 197 | (b (vec 1 1 1))) 198 | (ntransform a transformation) 199 | (ntransform b transformation) 200 | (let ((c (v- a b))) 201 | (mulf (radius circle) (min (abs (vx c)) (abs (vy c)))))) 202 | circle) 203 | 204 | 205 | ;;;; Points ------------------------------------------------------------------- 206 | (defclass* point (drawable) 207 | ((location :type vec3))) 208 | 209 | (defun point (location &key (opacity 1.0d0) (color *black*)) 210 | (make-instance 'point :location (homogenize location) 211 | :color color 212 | :opacity (coerce opacity 'double-float))) 213 | 214 | (defmethod print-object ((o point) s) 215 | (print-unreadable-object (o s :type t :identity nil) 216 | (format s "(~D, ~D)" 217 | (vx (location o)) 218 | (vy (location o))))) 219 | 220 | (defmethod ntransform ((point point) transformation) 221 | (ntransform (location point) transformation) 222 | point) 223 | 224 | 225 | ;;;; Glyph -------------------------------------------------------------------- 226 | (defclass* glyph (drawable) 227 | ((pos :type vec3) 228 | (width :type single-float) 229 | (ch :type character) 230 | (paths :type list))) 231 | 232 | (defun glyph (position width character &key (opacity 1.0d0) (color *black*)) 233 | (make-instance 'glyph 234 | :pos (homogenize position) 235 | :width (coerce width 'single-float) 236 | :ch character 237 | :color color 238 | :opacity (coerce opacity 'double-float))) 239 | 240 | (defun recompute-glyph-paths (glyph) 241 | (let ((paths (letter-paths (ch glyph))) 242 | (size (* 2 (width glyph)))) 243 | (ntransform paths (transformation 244 | (scale size size) 245 | (translate (vx (pos glyph)) 246 | (vy (pos glyph))))) 247 | (setf (paths glyph) paths))) 248 | 249 | (defmethod initialize-instance :after ((glyph glyph) &key) 250 | (recompute-glyph-paths glyph)) 251 | 252 | (defmethod print-object ((o glyph) s) 253 | (print-unreadable-object (o s :type t :identity nil) 254 | (format s "~A ~A" (ch o) (pos o)))) 255 | 256 | (defmethod ntransform ((glyph glyph) transformation) 257 | (ntransform (pos glyph) transformation) 258 | (ntransformf (width glyph) transformation) 259 | (ntransformf (paths glyph) transformation) 260 | ;; (recompute-glyph-paths glyph) 261 | glyph) 262 | 263 | (defmethod draw (canvas (glyph glyph)) 264 | (map-curried #'draw canvas (paths glyph))) 265 | 266 | 267 | ;;;; Text --------------------------------------------------------------------- 268 | (defclass* text (drawable) 269 | ((pos :type vec3) 270 | (letter-width :type single-float) 271 | (letter-spacing :type single-float) 272 | (content :type string) 273 | (glyphs :type list))) 274 | 275 | (defun rebuild-glyphs (text) 276 | (setf (glyphs text) 277 | (iterate 278 | (with pos = (pos text)) 279 | (with y = (vy (pos text))) 280 | (with space = (+ (letter-width text) (letter-spacing text))) 281 | (with scale = (/ (letter-width text) 0.5)) 282 | (for ch :in-string (content text)) 283 | (for pch :previous ch) 284 | (for x :from (vx pos) :by space) 285 | (incf x (* (kern pch ch) scale)) 286 | (collect (glyph (vec x y) (letter-width text) ch 287 | :opacity (opacity text) 288 | :color (color text)))))) 289 | 290 | (defun text (position letter-width content &key (letter-spacing 0.0) (opacity 1.0d0) (color *black*)) 291 | (make-instance 'text 292 | :pos (homogenize position) 293 | :letter-width (coerce letter-width 'single-float) 294 | :letter-spacing (coerce letter-spacing 'single-float) 295 | :content content 296 | :color color 297 | :opacity (coerce opacity 'double-float))) 298 | 299 | (defmethod initialize-instance :after ((text text) &key) 300 | (rebuild-glyphs text)) 301 | 302 | 303 | (defmethod print-object ((o text) s) 304 | (print-unreadable-object (o s :type t :identity nil) 305 | (format s "~S ~A" 306 | (content o) 307 | (pos o)))) 308 | 309 | (defmethod draw (canvas (text text)) 310 | (map-curried #'draw canvas (glyphs text))) 311 | 312 | (defmethod ntransform ((text text) transformation) 313 | (ntransform (pos text) transformation) 314 | (ntransformf (letter-width text) transformation) 315 | (rebuild-glyphs text) 316 | text) 317 | 318 | 319 | ;;;; Rendering ---------------------------------------------------------------- 320 | (defgeneric render-object (canvas object)) 321 | 322 | (defun render (canvas objects) 323 | (map-curried #'render-object canvas objects)) 324 | 325 | 326 | ;;;; File Writing ------------------------------------------------------------- 327 | (defgeneric write-file (canvas filename)) 328 | 329 | 330 | ;;;; File Extensions ---------------------------------------------------------- 331 | (defgeneric file-extension (type)) 332 | 333 | (defmethod file-extension (type) 334 | (string-downcase (symbol-name type))) 335 | 336 | 337 | ;;;; Toplevel ----------------------------------------------------------------- 338 | (defun full-filename (filename canvas-type) 339 | (format nil "~A.~A" filename (file-extension canvas-type))) 340 | 341 | (defmacro with-rendering 342 | ((canvas-symbol canvas-type filename width height &key 343 | (padding 0.03) 344 | (background '(rgb 1 1 1))) 345 | &body body) 346 | (once-only (canvas-type) 347 | `(progn 348 | #+sbcl (sb-ext:gc :full t) 349 | (let ((,canvas-symbol (make-canvas ,canvas-type 350 | :height ,height 351 | :width ,width 352 | :padding ,padding 353 | :background ,background))) 354 | (multiple-value-prog1 ,@body 355 | (write-file ,canvas-symbol (full-filename ,filename ,canvas-type))))))) 356 | 357 | 358 | ;;;; Usage -------------------------------------------------------------------- 359 | 360 | ;;;; Implementations ---------------------------------------------------------- 361 | ;;; To implement a new type of canvas, you'll need to: 362 | ;;; 363 | ;;; * Add a new subclass of canvas. 364 | ;;; * Implement make-canvas. 365 | ;;; * Implement all the drawing methods for the various shapes. 366 | ;;; * Implement render-object (which should call draw and maybe do other stuff). 367 | ;;; * Implement write-file. 368 | -------------------------------------------------------------------------------- /src/drawing/letters.lisp: -------------------------------------------------------------------------------- 1 | (in-package :flax.drawing) 2 | 3 | (defgeneric letter-paths (character)) 4 | 5 | (defmethod letter-paths ((character (eql #\Space))) 6 | (list)) 7 | 8 | (defmethod letter-paths ((character (eql #\+))) 9 | ;; p₁ 10 | ;; | 11 | ;; | 12 | ;; p₃ ----+---- p₄ 13 | ;; | 14 | ;; | 15 | ;; p₂ 16 | (let ((p1 (vec 0.25 0.35)) 17 | (p2 (vec 0.25 0.75)) 18 | (p3 (vec 0.05 0.55)) 19 | (p4 (vec 0.45 0.55))) 20 | (list (path (list p1 p2)) 21 | (path (list p3 p4))))) 22 | 23 | (defmethod letter-paths ((character (eql #\-))) 24 | (let ((p1 (vec 0.05 0.55)) 25 | (p2 (vec 0.45 0.55))) 26 | (list (path (list p1 p2))))) 27 | 28 | (defmethod letter-paths ((character (eql #\L))) 29 | ;; p₁ 30 | ;; | 31 | ;; | 32 | ;; | 33 | ;; | 34 | ;; p₂|______ p₃ 35 | (let ((p1 (vec 0.05 0.10)) 36 | (p2 (vec 0.05 1.00)) 37 | (p3 (vec 0.45 1.00))) 38 | (list (path (list p1 p2 p3))))) 39 | 40 | (defmethod letter-paths ((character (eql #\R))) 41 | ;; p₁___ p₃ 42 | ;; | \ 43 | ;; p₆|___/ p₄ 44 | ;; | \ 45 | ;; | \ 46 | ;; p₂| \ p₅ 47 | (let ((p1 (vec 0.05 0.10)) 48 | (p2 (vec 0.05 1.00)) 49 | (p3 (vec 0.25 0.10)) 50 | (p4 (vec 0.25 0.55)) 51 | (p5 (vec 0.45 1.00)) 52 | (p6 (vec 0.05 0.55))) 53 | (list (path (list p1 p2)) 54 | (path (list p1 p3 55 | (list p4 56 | (vec 0.45 0.10) 57 | (vec 0.45 0.55)) 58 | p5)) 59 | (path (list p4 p6))))) 60 | 61 | (defmethod letter-paths ((character (eql #\→))) 62 | (let ((p1 (vec 0.05 0.55)) 63 | (p2 (vec 0.45 0.55)) 64 | (p3 (vec 0.30 0.45)) 65 | (p4 (vec 0.30 0.65))) 66 | (list (path (list p1 p2)) 67 | (path (list p3 p2 p4))))) 68 | 69 | (defmethod letter-paths ((character (eql #\())) 70 | (let ((p1 (vec 0.40 0.10)) 71 | (p2 (vec 0.40 1.00))) 72 | (list (path (list p1 73 | (list p2 74 | (vec 0.05 0.25) 75 | (vec 0.05 0.85))))))) 76 | 77 | (defmethod letter-paths ((character (eql #\)))) 78 | (let ((p1 (vec 0.10 0.10)) 79 | (p2 (vec 0.10 1.00))) 80 | (list (path (list p1 81 | (list p2 82 | (vec 0.45 0.25) 83 | (vec 0.45 0.85))))))) 84 | 85 | 86 | (defgeneric kern (a b)) 87 | 88 | (defmethod kern ((a character) (b character)) 89 | 0.0) 90 | 91 | (defmethod kern ((a null) b) 92 | 0.0) 93 | 94 | (defmethod kern ((a (eql #\L)) (b (eql #\+))) -0.15) 95 | (defmethod kern ((a (eql #\L)) (b (eql #\-))) -0.15) 96 | (defmethod kern ((a (eql #\L)) (b (eql #\→))) -0.15) 97 | (defmethod kern ((a (eql #\L)) (b (eql #\())) -0.07) 98 | (defmethod kern ((a (eql #\R)) (b (eql #\→))) -0.05) 99 | (defmethod kern ((a (eql #\R)) (b (eql #\L))) 0.05) 100 | (defmethod kern ((a (eql #\→)) (b (eql #\L))) 0.05) 101 | (defmethod kern ((a (eql #\→)) (b (eql #\R))) 0.05) 102 | (defmethod kern ((a (eql #\()) (b (eql #\-))) -0.05) 103 | (defmethod kern ((a (eql #\()) (b (eql #\+))) -0.05) 104 | (defmethod kern ((a (eql #\-)) (b (eql #\)))) -0.05) 105 | (defmethod kern ((a (eql #\+)) (b (eql #\)))) -0.05) 106 | 107 | -------------------------------------------------------------------------------- /src/drawing/plot.lisp: -------------------------------------------------------------------------------- 1 | (in-package :flax.drawing) 2 | 3 | ;;; A plot is an SVG without the square background. 4 | ;;; TODO: shell out to svgsort automatically? 5 | 6 | 7 | (defclass* plot-canvas (svg-canvas) ()) 8 | 9 | (defmethod make-canvas ((type (eql :plot)) &key height width padding) 10 | (let ((scene (svg:make-svg-toplevel 'svg:svg-1.1-toplevel 11 | :height height :width width))) 12 | (make-instance 'plot-canvas 13 | :height height 14 | :width width 15 | :scene scene 16 | :padding padding))) 17 | 18 | (defmethod file-extension ((type (eql :plot))) 19 | "svg") 20 | 21 | 22 | (defmethod draw ((canvas plot-canvas) (p point)) 23 | (svg:draw (scene canvas) 24 | (:path :d (make-svg-path-data canvas (list (list (location p) 25 | (location p)))) 26 | :stroke-linecap "round" 27 | :fill "none" 28 | :stroke (web-color (color p)) 29 | :stroke-width 1 30 | :stroke-opacity (opacity p)))) 31 | 32 | -------------------------------------------------------------------------------- /src/drawing/png.lisp: -------------------------------------------------------------------------------- 1 | (in-package :flax.drawing) 2 | 3 | ;;;; Utils -------------------------------------------------------------------- 4 | (deftype image () 5 | '(simple-array (double-float 0.0d0 1.0d0) (* * 3))) 6 | 7 | (deftype index () 8 | `(integer 0 (,array-dimension-limit))) 9 | 10 | (deftype row-buffer () 11 | '(simple-array (integer 0 255) (*))) 12 | 13 | 14 | (defun make-image (width height color) 15 | (let ((image (make-array (list height width 3) 16 | :element-type 'double-float 17 | :initial-element 1.0d0))) 18 | (with-color (color r g b) 19 | (dotimes (row height) 20 | (dotimes (col width) 21 | (setf (aref image row col 0) r 22 | (aref image row col 1) g 23 | (aref image row col 2) b)))) 24 | image)) 25 | 26 | (defun-inline normalize-alpha (alpha) 27 | (declare (optimize speed) 28 | (type fixnum alpha)) 29 | (/ (min 255 (abs alpha)) 255.0d0)) 30 | 31 | (defun put-pixel (image color opacity x y alpha) 32 | (declare (optimize speed) 33 | (type image image) 34 | (type color color) 35 | (type index x y) 36 | (type (double-float 0.0d0 1.0d0) opacity) 37 | (type fixnum alpha)) 38 | (let ((pixel-alpha (* opacity (normalize-alpha alpha)))) 39 | (zapf (aref image y x 0) (lerp % (flax.colors::r color) pixel-alpha) 40 | (aref image y x 1) (lerp % (flax.colors::g color) pixel-alpha) 41 | (aref image y x 2) (lerp % (flax.colors::b color) pixel-alpha)) 42 | (values))) 43 | 44 | 45 | ;;;; Canvas ------------------------------------------------------------------- 46 | (defclass* png-canvas (canvas) 47 | (image state)) 48 | 49 | (defmethod make-canvas ((type (eql :png)) &key height width background padding) 50 | (make-instance 'png-canvas 51 | :height height 52 | :width width 53 | :image (make-image width height background) 54 | :padding padding)) 55 | 56 | 57 | ;;;; Rectangles --------------------------------------------------------------- 58 | (defmethod draw ((canvas png-canvas) (rect rectangle)) 59 | (with-coordinates canvas 60 | ((ax ay (a rect)) 61 | (bx by (b rect)) 62 | (r (round-corners rect))) 63 | (_ (paths:make-rectangle-path ax ay bx by :round r) 64 | (vectors:update-state (state canvas) _)))) 65 | 66 | 67 | ;;;; Circles ------------------------------------------------------------------ 68 | (defmethod draw ((canvas png-canvas) (circ circle)) 69 | (with-coordinates canvas 70 | ((x y (center circ)) 71 | (r (radius circ))) 72 | (_ (paths:make-circle-path x y r) 73 | (vectors:update-state (state canvas) _)))) 74 | 75 | 76 | ;;;; Points ------------------------------------------------------------------- 77 | (defmethod draw ((canvas png-canvas) (p point)) 78 | (with-coordinates canvas 79 | ((x y (location p))) 80 | (_ (paths:make-circle-path x y 2) 81 | (vectors:update-state (state canvas) _)))) 82 | 83 | 84 | ;;;; Paths -------------------------------------------------------------------- 85 | (defun pair-to-vec (pair) 86 | (vec (car pair) (cdr pair))) 87 | 88 | (defun vec-to-pair (vec) 89 | (cons (vx vec) (vy vec))) 90 | 91 | (defun reflect-control (control loc) 92 | (let* ((l (pair-to-vec loc)) 93 | (c (pair-to-vec control)) 94 | (cv (v- c l))) 95 | (vec-to-pair (v+ l (v- cv))))) 96 | 97 | (defun fill-missing-control-points (points) 98 | (iterate 99 | ;; Unfortunately cl-vectors doesn't seem to have anything like the nice 100 | ;; convenient omit-the-starting-control-point-for-a-smooth-curve feature of 101 | ;; SVG, so we'll have to implement it ourselves. 102 | (with previous-ctrl2) 103 | (for point :in points) 104 | (for (p ctrl1 ctrl2) = point) 105 | (for previous-p :previous p) 106 | (cond 107 | (ctrl2 (collect point)) 108 | (ctrl1 (psetf ctrl1 (reflect-control previous-ctrl2 previous-p) 109 | ctrl2 ctrl1) 110 | (collect (list p ctrl1 ctrl2))) 111 | (t (collect point))) 112 | (setf previous-ctrl2 ctrl2))) 113 | 114 | (defun convert-point (canvas point) 115 | (destructuring-bind (x . y) (coord-to-pair canvas point) 116 | (paths:make-point x y))) 117 | 118 | (defun convert-points (canvas points) 119 | (mapcar-curried #'convert-point canvas points)) 120 | 121 | (defun make-vector-path (points) 122 | (destructuring-bind (first-point &rest remaining-points) points 123 | (let ((p (paths:create-path :open-polyline))) 124 | (paths:path-reset p (first first-point)) 125 | (dolist (next-point remaining-points) 126 | (destructuring-bind (loc &rest control-points) next-point 127 | (paths:path-extend p (paths:make-bezier-curve control-points) loc))) 128 | p))) 129 | 130 | (defmethod draw ((canvas png-canvas) (p path)) 131 | (_ (points p) 132 | (mapcar-curried #'convert-points canvas _) 133 | fill-missing-control-points 134 | make-vector-path 135 | (paths:stroke-path _ 1) 136 | (vectors:update-state (state canvas) _))) 137 | 138 | 139 | ;;;; Triangles ---------------------------------------------------------------- 140 | (defmethod draw ((canvas png-canvas) (tri triangle)) 141 | (with-coordinates canvas 142 | ((ax ay (a tri)) 143 | (bx by (b tri)) 144 | (cx cy (c tri))) 145 | (_ (list (cons ax ay) 146 | (cons bx by) 147 | (cons cx cy) 148 | (cons ax ay)) 149 | paths:make-simple-path 150 | (paths:stroke-path _ 1) 151 | (vectors:update-state (state canvas) _)))) 152 | 153 | 154 | ;;;; Rendering ---------------------------------------------------------------- 155 | (defmethod render-object ((canvas png-canvas) object) 156 | (setf (state canvas) (aa:make-state)) 157 | (draw canvas object) 158 | (aa:cells-sweep/rectangle 159 | (state canvas) 0 0 (width canvas) (height canvas) 160 | (curry #'put-pixel (image canvas) (color object) (opacity object)))) 161 | 162 | 163 | ;;;; Files -------------------------------------------------------------------- 164 | (defun-inline prepare-sample (value) 165 | (declare (optimize speed) 166 | (type (double-float 0.0d0 1.0d0) value)) 167 | (round (* 255.0d0 value))) 168 | 169 | (defun fill-row (image row buffer) 170 | (declare (optimize speed) 171 | (type image image) 172 | (type index row) 173 | (type row-buffer buffer)) 174 | (iterate 175 | (declare (iterate:declare-variables)) 176 | (with width = (length buffer)) 177 | (for (the fixnum i) :from (* row width)) 178 | (for (the fixnum j) :from 0 :below width) 179 | (setf (aref buffer j) 180 | (prepare-sample (row-major-aref image i))))) 181 | 182 | (defmethod write-file ((canvas png-canvas) filename) 183 | (let ((width (width canvas)) 184 | (height (height canvas)) 185 | (image (image canvas))) 186 | (let ((png (make-instance 'zpng:pixel-streamed-png 187 | :color-type :truecolor 188 | :width width 189 | :height height)) 190 | (buffer (make-array (* width 3) :element-type '(integer 0 255)))) 191 | (with-open-file (stream filename 192 | :direction :output 193 | :if-exists :supersede 194 | :if-does-not-exist :create 195 | :element-type '(unsigned-byte 8)) 196 | (zpng:start-png png stream) 197 | (dotimes (row height) 198 | (fill-row image row buffer) 199 | (zpng:write-row buffer png)) 200 | (zpng:finish-png png))))) 201 | 202 | 203 | ;; todo fix this 204 | (defun fade (canvas color alpha) 205 | (declare (optimize speed) 206 | (type color color) 207 | (type (double-float 0.0d0 1.0d0) alpha)) 208 | (nest (let ((image (image canvas))) 209 | (declare (type image image))) 210 | (with-color (color r g b)) 211 | (dotimes (row (array-dimension image 0))) 212 | (dotimes (col (array-dimension image 1))) 213 | (zapf (aref image row col 0) (lerp % r alpha) 214 | (aref image row col 1) (lerp % g alpha) 215 | (aref image row col 2) (lerp % b alpha)))) 216 | -------------------------------------------------------------------------------- /src/drawing/svg.lisp: -------------------------------------------------------------------------------- 1 | (in-package :flax.drawing) 2 | 3 | ;;;; Utils -------------------------------------------------------------------- 4 | (defun web-color (color) 5 | (with-color (color r g b) 6 | (format nil "#~2,'0X~2,'0X~2,'0X" 7 | (round (map-range 0 1 0 255 r)) 8 | (round (map-range 0 1 0 255 g)) 9 | (round (map-range 0 1 0 255 b))))) 10 | 11 | 12 | ;;;; Canvas ------------------------------------------------------------------- 13 | (defclass* svg-canvas (canvas) 14 | (scene)) 15 | 16 | (defmethod make-canvas ((type (eql :svg)) &key height width background padding) 17 | (let ((scene (svg:make-svg-toplevel 'svg:svg-1.1-toplevel 18 | :height height :width width))) 19 | (svg:draw scene (:rect :x 0 :y 0 :width width :height height 20 | :fill (web-color background))) 21 | (make-instance 'svg-canvas 22 | :height height 23 | :width width 24 | :scene scene 25 | :padding padding))) 26 | 27 | 28 | ;;;; Rectangles --------------------------------------------------------------- 29 | (defmethod draw ((canvas svg-canvas) (rect rectangle)) 30 | (with-coordinates canvas 31 | ((ax ay (a rect)) 32 | (bx by (b rect)) 33 | (r (round-corners rect))) 34 | (svg:draw (scene canvas) (:rect 35 | :x (min ax bx) 36 | :y (min ay by) 37 | :rx r 38 | :ry r 39 | :width (abs (- ax bx)) 40 | :height (abs (- ay by)) 41 | :fill (web-color (color rect)) 42 | :fill-opacity (opacity rect))))) 43 | 44 | 45 | ;;;; Circles ------------------------------------------------------------------ 46 | (defmethod draw ((canvas svg-canvas) (circ circle)) 47 | (with-coordinates canvas 48 | ((x y (center circ)) 49 | (r (radius circ))) 50 | (svg:draw (scene canvas) (:circle :cx x :cy y :r r 51 | :fill (web-color (color circ)) 52 | :fill-opacity (opacity circ))))) 53 | 54 | 55 | ;;;; Points ------------------------------------------------------------------- 56 | (defmethod draw ((canvas svg-canvas) (p point)) 57 | (with-coordinates canvas 58 | ((x y (location p))) 59 | (svg:draw (scene canvas) (:circle :cx x :cy y :r 2.0 60 | :fill (web-color (color p)) 61 | :fill-opacity (opacity p))))) 62 | 63 | 64 | ;;;; Paths -------------------------------------------------------------------- 65 | (defun points-to-pairs (canvas points) 66 | (loop :for ps :in points :collect (coords-to-pairs canvas ps))) 67 | 68 | (defun process-path-point (path point &optional first) 69 | (destructuring-bind (loc &optional ctrl1 ctrl2) point 70 | (cond 71 | (first (svg:with-path path 72 | (svg:move-to (car loc) (cdr loc)))) 73 | (ctrl2 (svg:with-path path 74 | (svg:curve-to (car ctrl1) (cdr ctrl1) 75 | (car ctrl2) (cdr ctrl2) 76 | (car loc) (cdr loc)))) 77 | (ctrl1 (svg:with-path path 78 | (svg:smooth-curve-to (car ctrl1) (cdr ctrl1) 79 | (car loc) (cdr loc)))) 80 | (t (svg:with-path path 81 | (svg:line-to (car loc) (cdr loc))))))) 82 | 83 | (defun make-svg-path-data (canvas points) 84 | (destructuring-bind (first-point &rest remaining-points) 85 | (points-to-pairs canvas points) 86 | (let ((p (svg:make-path))) 87 | (process-path-point p first-point t) 88 | (loop :for next-point :in remaining-points 89 | :do (process-path-point p next-point)) 90 | p))) 91 | 92 | (defmethod draw ((canvas svg-canvas) (path path)) 93 | (svg:draw (scene canvas) 94 | (:path :d (make-svg-path-data canvas (points path)) 95 | :fill "none" 96 | :stroke (web-color (color path)) 97 | :stroke-width 1 98 | :stroke-opacity (opacity path)))) 99 | 100 | 101 | ;;;; Triangles ---------------------------------------------------------------- 102 | (defmethod draw ((canvas svg-canvas) (tri triangle)) 103 | (with-coordinates canvas 104 | ((ax ay (a tri)) 105 | (bx by (b tri)) 106 | (cx cy (c tri))) 107 | (svg:draw (scene canvas) (:polygon 108 | :points (svg::points (list (list ax ay) 109 | (list bx by) 110 | (list cx cy))) 111 | :fill "none" 112 | :stroke-width 1 113 | :stroke-opacity (opacity tri) 114 | :stroke (web-color (color tri)))))) 115 | 116 | 117 | ;;;; Rendering ---------------------------------------------------------------- 118 | (defmethod render-object ((canvas svg-canvas) object) 119 | (draw canvas object)) 120 | 121 | 122 | ;;;; Files -------------------------------------------------------------------- 123 | (defmethod write-file ((canvas svg-canvas) filename) 124 | (with-open-file (stream filename 125 | :direction :output 126 | :if-exists :supersede 127 | :if-does-not-exist :create) 128 | (svg:stream-out stream (scene canvas)))) 129 | 130 | -------------------------------------------------------------------------------- /src/looms/001-triangles.lisp: -------------------------------------------------------------------------------- 1 | (in-package :flax.looms.001-triangles) 2 | 3 | ;;;; Triangle Subdivision 4 | ;;; 5 | ;;; Based on http://www.tylerlhobbs.com/writings/triangle-subdivision 6 | 7 | 8 | ;;;; Utils -------------------------------------------------------------------- 9 | (defun round-to (number divisor) 10 | (* divisor (round number divisor))) 11 | 12 | 13 | ;;;; Elements ----------------------------------------------------------------- 14 | (defstruct (triangle (:conc-name nil)) 15 | (a (vec 0 0) :type vec2) 16 | (b (vec 0 0) :type vec2) 17 | (c (vec 0 0) :type vec2)) 18 | 19 | (define-with-macro triangle a b c) 20 | 21 | (defun triangle (a b c) 22 | (make-triangle :a a :b b :c c)) 23 | 24 | 25 | ;;;; Element Conversion ------------------------------------------------------- 26 | (defun convert-triangle (triangle) 27 | (with-triangle (triangle) 28 | (flax.drawing:triangle a b c))) 29 | 30 | (defun convert (universe) 31 | (mapcar #'convert-triangle universe)) 32 | 33 | 34 | ;;;; Generation --------------------------------------------------------------- 35 | (defun initial-triangles () 36 | (list (triangle (vec 0 1) 37 | (vec 1 1) 38 | (vec 0 0)) 39 | (triangle (vec 1 0) 40 | (vec 1 1) 41 | (vec 0 0)))) 42 | 43 | 44 | (defun split-triangle-evenly (triangle) 45 | (with-triangle (triangle) 46 | (let* ((n 1/2) 47 | (p (vec2 (lerp (vx b) (vx c) n) 48 | (lerp (vy b) (vy c) n)))) 49 | (list (triangle p b a) 50 | (triangle p a c))))) 51 | 52 | (defun generate-universe-even (depth &aux (triangles (initial-triangles))) 53 | (do-repeat depth 54 | (zapf triangles (alexandria:mappend #'split-triangle-evenly %))) 55 | triangles) 56 | 57 | 58 | (defun find-longest-side (triangle) 59 | (with-triangle (triangle) 60 | (let* ((ab (vdistance a b)) 61 | (bc (vdistance b c)) 62 | (ca (vdistance c a)) 63 | (longest (max ab bc ca))) 64 | (cond 65 | ((= longest ab) (list c a b)) 66 | ((= longest bc) (list a c b)) 67 | ((= longest ca) (list b c a)) 68 | (t (error "what?")))))) 69 | 70 | (defun split-triangle-self-balancing (triangle) 71 | (destructuring-bind (a b c) (find-longest-side triangle) 72 | (let ((p (_ (random-gaussian 0.5 0.1 #'rand) 73 | (clamp 0.3 0.7 _) 74 | (round-to _ 1/100) 75 | (vlerp b c _)))) 76 | (list (triangle p b a) 77 | (triangle p a c))))) 78 | 79 | (defun generate-universe-balancing (depth) 80 | (gathering 81 | (labels ((should-stop-p (iteration) 82 | (or (= depth iteration) 83 | (and (> iteration 6) 84 | (randomp (map-range 0 depth 85 | 0.0 0.05 86 | iteration) 87 | #'rand)))) 88 | (recur (triangle &optional (iteration 0)) 89 | (if (should-stop-p iteration) 90 | (gather triangle) 91 | (map nil (rcurry #'recur (1+ iteration)) 92 | (split-triangle-self-balancing triangle))))) 93 | (map nil #'recur (initial-triangles))))) 94 | 95 | 96 | ;;;; Main --------------------------------------------------------------------- 97 | (defun loom (seed filename filetype width height &key depth) 98 | (nest 99 | (with-seed seed) 100 | (randomly-initialize ((depth (random-range-inclusive 14 19 #'rand)))) 101 | (flax.drawing:with-rendering (canvas filetype filename width height)) 102 | (progn 103 | (_ (generate-universe-balancing depth) 104 | convert 105 | (flax.drawing:render canvas _)) 106 | (values depth)))) 107 | 108 | 109 | ;; (declaim (optimize (speed 1))) 110 | 111 | ;; (time (loom nil "out" :png 800 800 :depth 16)) 112 | -------------------------------------------------------------------------------- /src/looms/002-wobbly-lines.lisp: -------------------------------------------------------------------------------- 1 | (in-package :flax.looms.002-wobbly-lines) 2 | 3 | ;;;; Data --------------------------------------------------------------------- 4 | (defvar *brush* nil) 5 | (defvar *hue* nil) 6 | (defvar *hue-increment* nil) 7 | (defparameter *swing* 0.03) 8 | (defparameter *background* (hsv 0 0 0.05)) 9 | 10 | 11 | ;;;; Elements ----------------------------------------------------------------- 12 | (defstruct (line (:conc-name nil) 13 | (:constructor line (points))) 14 | (points (error "Required") :type vector)) 15 | 16 | (define-with-macro line points) 17 | 18 | ;;;; Element Conversion ------------------------------------------------------- 19 | (defun convert (line opacity) 20 | (list (flax.drawing::path (coerce (points line) 'list) 21 | :color (hsv *hue* 0.9 1) 22 | :opacity opacity))) 23 | 24 | 25 | ;;;; Generation --------------------------------------------------------------- 26 | (defun initial (segments) 27 | (line 28 | (iterate 29 | (for x :from 0.0 :to (+ 1.0 least-positive-single-float) :by (/ 1.0 segments)) 30 | (collect (vec x 0.5) :result-type 'vector)))) 31 | 32 | 33 | ;;;; Tick --------------------------------------------------------------------- 34 | (defun perturb-point (point) 35 | (incf (vy point) (random-range-inclusive (- *swing*) *swing* #'rand))) 36 | 37 | (defun perturb-line (line) 38 | (map nil #'perturb-point (points line))) 39 | 40 | (defun smooth-line (line) 41 | (iterate 42 | (with points = (points line)) 43 | (with final = (1- (length points))) 44 | (for p :in-vector points :with-index i) 45 | (for y = (vy p)) 46 | (for l = (or (unless (zerop i) (vy (aref points (1- i)))) y)) 47 | (for r = (or (unless (= final i) (vy (aref points (1+ i)))) y)) 48 | (zapf (vy p) (/ (+ % % l r) 4.0)))) 49 | 50 | (defun tick (line) 51 | (perturb-line line) 52 | (smooth-line line) 53 | (zapf *hue* (mod (+ % *hue-increment*) 1.0d0))) 54 | 55 | 56 | ;;;; Main --------------------------------------------------------------------- 57 | (defun loom (seed filename filetype width height &key mode ticks verbose) 58 | (nest 59 | (with-seed seed) 60 | (flax.drawing:with-rendering (canvas filetype filename width height 61 | :padding 0.0 62 | :background *background*)) 63 | (randomly-initialize 64 | ((ticks (round-to (random-range 3000 8000 #'rand) 1000)) 65 | (mode (random-elt '(:opaque :transparent :fade) #'rand)))) 66 | (let ((line (initial 300)) 67 | (*hue* (random-range 0.0d0 1.0d0 #'rand)) 68 | (*hue-increment* (/ (random-range 0.15d0 0.3d0 #'rand) ticks)))) 69 | (progn 70 | (dotimes (tick ticks) 71 | (when (and verbose 72 | (dividesp tick (/ (expt 10 (floor (log (1- ticks) 10))) 2))) 73 | (print tick)) 74 | (when (and (eq filetype :png) (eq mode :fade) (dividesp tick 10)) 75 | (flax.drawing:fade canvas *background* 0.04d0)) 76 | (flax.drawing:render canvas (convert line (if (eq mode :transparent) 77 | (/ 95.0d0 ticks) 78 | 1.0d0))) 79 | (tick line)) 80 | (values mode ticks)))) 81 | 82 | 83 | ;; (time (loom 133 "out" :svg 800 300)) 84 | -------------------------------------------------------------------------------- /src/looms/003-basic-l-systems.lisp: -------------------------------------------------------------------------------- 1 | (in-package :flax.looms.003-basic-l-systems) 2 | 3 | ;;;; L-Systems ---------------------------------------------------------------- 4 | (defclass lsystem () 5 | ((axiom :type list :accessor axiom :initarg :axiom) 6 | (productions :type hash-table :accessor productions :initarg :productions))) 7 | 8 | (defun make-lsystem (axiom productions) 9 | (make-instance 'lsystem 10 | :axiom (ensure-list axiom) 11 | :productions (iterate (with result = (make-hash-table)) 12 | (for (symbol . word) :in productions) 13 | (setf (gethash symbol result) 14 | (ensure-list word)) 15 | (finally (return result))))) 16 | 17 | (defun run-lsystem (lsystem axiom iterations mutate callback) 18 | (recursively ((word (or axiom (axiom lsystem))) 19 | (iteration 0)) 20 | (when callback 21 | (funcall callback iteration word)) 22 | (if (= iterations iteration) 23 | word 24 | (recur (funcall mutate (alexandria:mappend 25 | (rcurry #'gethash (productions lsystem)) word)) 26 | (1+ iteration))))) 27 | 28 | (defmacro define-lsystem (name axiom &rest productions) 29 | (let ((var (symb '* name '*))) 30 | `(progn 31 | (defparameter ,var (make-lsystem ',axiom ',productions)) 32 | (defun ,name (iterations &key mutate callback axiom) 33 | (run-lsystem ,var axiom iterations mutate callback))))) 34 | 35 | 36 | (define-lsystem anabaena-catenula ar 37 | (ar . (al br)) 38 | (al . (bl ar)) 39 | (br . ar) 40 | (bl . al)) 41 | 42 | 43 | (defun cull (word) 44 | (iterate 45 | (with chance = (map-range 0 150 46 | 0 0.8 47 | (length word))) 48 | (for symbol :in word) 49 | (if-first-time 50 | (collect symbol) 51 | (unless (randomp chance #'rand) 52 | (collect symbol))))) 53 | 54 | 55 | ;;;; Drawing ------------------------------------------------------------------ 56 | (defparameter *cell-unit* 0.007) 57 | (defparameter *aspect-ratio* 9/8) 58 | (defparameter *cell-width* (* *cell-unit* *aspect-ratio*)) 59 | (defparameter *cell-height* (* *cell-unit* (/ *aspect-ratio*))) 60 | (defparameter *horizontal-padding* (/ *cell-width* 2)) 61 | (defparameter *vertical-padding* (/ *cell-height* 1.5)) 62 | (defparameter *brush* (rgb 1.000 0.920 0.850)) 63 | (defparameter *background* (rgb 0.337 0.196 0.063)) 64 | 65 | (defun symbol-width (symbol) 66 | (ecase symbol 67 | ((al ar) (* 2 *cell-width*)) 68 | ((bl br) *cell-width*))) 69 | 70 | (defun word-width (word) 71 | (+ (reduce #'+ word :key #'symbol-width) 72 | (* (1- (length word)) *horizontal-padding*))) 73 | 74 | (defun convert-symbol (symbol x y) 75 | (flax.drawing:rectangle 76 | (vec x y) 77 | (vec (+ x (symbol-width symbol)) 78 | (+ y *cell-height*)) 79 | :color *brush* 80 | :round-corners (/ *cell-unit* 2))) 81 | 82 | (defun convert (word iteration) 83 | (let ((y (* iteration (+ *cell-height* *vertical-padding*))) 84 | (width (word-width word))) 85 | (iterate 86 | (with x = (- 0.5 (/ width 2))) 87 | (for symbol :in word) 88 | (collect (convert-symbol symbol x y)) 89 | (incf x (+ (symbol-width symbol) *horizontal-padding*))))) 90 | 91 | 92 | (defun maximum-words () 93 | (truncate 1.0 (+ *cell-height* *vertical-padding*))) 94 | 95 | 96 | ;;;; Main --------------------------------------------------------------------- 97 | (defun random-anabaena-catenula-axiom (length) 98 | (gimme length (random-elt '(ar al br bl) #'rand))) 99 | 100 | (defun loom (seed filename filetype width height) 101 | (nest 102 | (with-seed seed) 103 | (flax.drawing:with-rendering 104 | (canvas filetype filename width height :background *background*)) 105 | (anabaena-catenula (maximum-words) 106 | :axiom (random-anabaena-catenula-axiom 107 | (random-range-inclusive 1 6 #'rand)) 108 | :mutate #'cull 109 | :callback (lambda (iteration word) 110 | (flax.drawing:render canvas (convert word iteration)))))) 111 | 112 | 113 | 114 | ;; (time (loom nil "out" :svg 800 800)) 115 | -------------------------------------------------------------------------------- /src/looms/004-turtle-curves.lisp: -------------------------------------------------------------------------------- 1 | (in-package :flax.looms.004-turtle-curves) 2 | 3 | ;;;; Turtle Graphics ---------------------------------------------------------- 4 | (defvar *step* 0.1) 5 | (defvar *angle* 1/4tau) 6 | (defvar *starting-angle* (- 1/4tau)) 7 | (defvar *color* nil) 8 | 9 | (defstruct turtle 10 | (x 0.5) 11 | (y 0.5) 12 | (angle *starting-angle*) 13 | (state nil)) 14 | 15 | (define-with-macro (turtle :conc-name turtle-) x y angle state) 16 | 17 | 18 | (defun rot (angle amount) 19 | (mod (+ angle amount) tau)) 20 | 21 | (define-modify-macro rotf (amount) rot) 22 | 23 | 24 | (defgeneric perform-command (turtle command n)) 25 | 26 | (defmethod perform-command (turtle command n) 27 | nil) 28 | 29 | (defmethod perform-command (turtle (command (eql 'f)) n) 30 | (with-turtle (turtle) 31 | (list (flax.drawing:path 32 | (list (vec x y) 33 | (progn (perform-command turtle 's n) 34 | (vec x y))) 35 | :color *color*)))) 36 | 37 | (defmethod perform-command (turtle (command integer) n) 38 | (perform-command turtle 'f n)) 39 | 40 | (defmethod perform-command (turtle (command (eql 's)) n) 41 | (do-repeat n 42 | (with-turtle (turtle) 43 | (incf x (* *step* (cos angle))) 44 | (incf y (* *step* (sin angle))))) 45 | nil) 46 | 47 | (defmethod perform-command (turtle (command (eql '-)) n) 48 | (rotf (turtle-angle turtle) (* n *angle*)) 49 | nil) 50 | 51 | (defmethod perform-command (turtle (command (eql '+)) n) 52 | (rotf (turtle-angle turtle) (* n (- *angle*))) 53 | nil) 54 | 55 | (defmethod perform-command (turtle (command (eql '%)) n) 56 | (rotf (turtle-angle turtle) 1/2tau) 57 | nil) 58 | 59 | (defmethod perform-command (turtle (command (eql '<)) n) 60 | (do-repeat n 61 | (with-turtle (turtle) 62 | (push (list x y angle) state))) 63 | nil) 64 | 65 | (defmethod perform-command (turtle (command (eql '>)) n) 66 | (do-repeat n 67 | (with-turtle (turtle) 68 | (when-let ((prev (pop state))) 69 | (destructuring-bind (ox oy oa) prev 70 | (setf x ox y oy angle oa))))) 71 | nil) 72 | 73 | (defmethod perform-command (turtle (command (eql '[)) n) 74 | (perform-command turtle '< n)) 75 | 76 | (defmethod perform-command (turtle (command (eql '])) n) 77 | (perform-command turtle '> n)) 78 | 79 | 80 | (defun find-bounds (paths) 81 | (iterate (for path :in paths) 82 | (for ((p1) (p2)) = (flax.drawing:points path)) 83 | (maximizing (vx p1) :into max-x) 84 | (maximizing (vx p2) :into max-x) 85 | (maximizing (vy p1) :into max-y) 86 | (maximizing (vy p2) :into max-y) 87 | (minimizing (vx p1) :into min-x) 88 | (minimizing (vx p2) :into min-x) 89 | (minimizing (vy p1) :into min-y) 90 | (minimizing (vy p2) :into min-y) 91 | (finally (return (values min-x min-y max-x max-y))))) 92 | 93 | (defun transform-to-fit (paths) 94 | (multiple-value-bind (min-x min-y max-x max-y) (find-bounds paths) 95 | (let* ((x-span (- max-x min-x)) 96 | (y-span (- max-y min-y)) 97 | (factor (min (/ x-span) (/ y-span))) 98 | (x-padding (/ (- 1.0 (* factor x-span)) 2.0)) 99 | (y-padding (/ (- 1.0 (* factor y-span)) 2.0)) 100 | (transform (transformation 101 | (translate (- min-x) (- min-y)) 102 | (scale factor factor) 103 | (translate x-padding y-padding)))) 104 | (ntransform paths transform)))) 105 | 106 | 107 | (defun encode (commands) 108 | (iterate 109 | (with n = 1) 110 | (for (command . next) :on commands) 111 | (if (eq command (car next)) 112 | (incf n) 113 | (progn (collect (cons command n)) 114 | (setf n 1))))) 115 | 116 | (defun turtle-draw (commands) 117 | (iterate (with turtle = (make-turtle)) 118 | (for (command . n) :in (encode commands)) 119 | (appending (perform-command turtle command n)))) 120 | 121 | 122 | ;;;; L-Systems ---------------------------------------------------------------- 123 | (defun expand (word productions) 124 | (alexandria:mappend (lambda (letter) 125 | (ensure-list (or (getf productions letter) letter))) 126 | word)) 127 | 128 | (defun run-l-system (axiom productions iterations) 129 | (iterate 130 | (repeat iterations) 131 | (for word :initially axiom :then (expand word productions)) 132 | (finally (return word)))) 133 | 134 | (defun run-named-l-system (l-system iterations) 135 | (run-l-system (axiom l-system) 136 | (productions l-system) 137 | iterations)) 138 | 139 | 140 | (defclass* l-system () 141 | ((name) 142 | (axiom) 143 | (productions) 144 | (recommended-angle))) 145 | 146 | (defun make-l-system (name axiom productions recommended-angle) 147 | (make-instance 'l-system 148 | :name name 149 | :axiom (ensure-list axiom) 150 | :productions productions 151 | :recommended-angle recommended-angle)) 152 | 153 | 154 | (defmacro define-l-system (name-and-options axiom &body productions) 155 | (destructuring-bind (name &key (angle 1/4tau)) 156 | (ensure-list name-and-options) 157 | `(defparameter ,(symb '* name '*) 158 | (make-l-system ',name ',axiom ',productions ,angle)))) 159 | 160 | 161 | (define-l-system quadratic-koch-island-a (f - f - f - f) 162 | f (f - f + f + f f - f - f + f)) 163 | 164 | (define-l-system quadratic-koch-island-b (f - f - f - f) 165 | f (f + f f - f f - f - f + f + f f - f - f + f + f f + f f - f)) 166 | 167 | (define-l-system quadratic-snowflake (- f) 168 | f (f + f - f - f + f)) 169 | 170 | (define-l-system islands-and-lakes (f + f + f + f) 171 | f (f + s - f f + f + f f + f s + f f - s + f f - f - f f - f s - f f f) 172 | s (s s s s s s)) 173 | 174 | (define-l-system unnamed-koch-a (f - f - f - f) 175 | f (f f - f - f - f - f - f + f)) 176 | 177 | (define-l-system unnamed-koch-b (f - f - f - f) 178 | f (f f - f - f - f - f f)) 179 | 180 | (define-l-system unnamed-koch-c (f - f - f - f) 181 | f (f f - f + f - f - f f)) 182 | 183 | (define-l-system unnamed-koch-d (f - f - f - f) 184 | f (f f - f - - f - f)) 185 | 186 | (define-l-system unnamed-koch-e (f - f - f - f) 187 | f (f - f f - - f - f)) 188 | 189 | (define-l-system unnamed-koch-f (f - f - f - f) 190 | f (f - f + f - f - f)) 191 | 192 | (define-l-system dragon-curve 1 193 | 1 (1 + 2 +) 194 | 2 (- 1 - 2)) 195 | 196 | (define-l-system (sierpinski-gasket :angle (/ tau 6)) 2 197 | 1 (2 + 1 + 2) 198 | 2 (1 - 2 - 1)) 199 | 200 | (define-l-system (hexagonal-gosper-curve :angle (/ tau 6)) 1 201 | 1 (1 + 2 + + 2 - 1 - - 1 1 - 2 +) 202 | 2 (- 1 + 2 2 + + 2 + 1 - - 1 - 2)) 203 | 204 | 205 | (define-l-system (tree-a :angle (radians 25.7)) f 206 | f (f < + f > f < - f > f)) 207 | 208 | (define-l-system (tree-b :angle (radians 20)) f 209 | f (f < + f > f < - f > < f >)) 210 | 211 | (define-l-system (tree-c :angle (radians 22.5)) f 212 | f (f f - < - f + f + f > + < + f - f - f >)) 213 | 214 | (define-l-system (tree-d :angle (radians 20)) x 215 | x (f < + x > f < - x > + x) 216 | f (f f)) 217 | 218 | (define-l-system (tree-e :angle (radians 25.7)) x 219 | x (f < + x > < - x > f x) 220 | f (f f)) 221 | 222 | (define-l-system (tree-f :angle (radians 22.5)) x 223 | x (f - < < x > + x > + f < + f x > - x) 224 | f (f f)) 225 | 226 | 227 | ;;; http://paulbourke.net/fractals/lsys/ 228 | 229 | (define-l-system (saupe-pine :angle (radians 20)) (v z f f f) 230 | v (< + + + w > < - - - w > y v) 231 | w (+ x < - w > z) 232 | x (- w < + x > z) 233 | y (y z) 234 | z (< - f f f > < + f f f > f)) 235 | 236 | (define-l-system (bourke-bush :angle (radians 25.7)) y 237 | x (x < - f f f > < + f f f > f x) 238 | y (y f x < + y > < - y >)) 239 | 240 | (define-l-system (bourke-weed :angle (radians 22.5)) f 241 | f (f f - < x y > + < x y >) 242 | x (+ f y) 243 | y (- f x)) 244 | 245 | (define-l-system (bourke-triangle :angle (radians 120)) (f + f + f) 246 | f (f - f + f)) 247 | 248 | (define-l-system (bourke-pentaplexity :angle (radians 36)) (F + + F + + F + + F + + F) 249 | f (f + + f + + f % f - f + + f)) 250 | 251 | (define-l-system (bourke-mango :angle (radians 60)) (Y - - - Y) 252 | x (f - f f - f - - < - - x > f - f f - f - - f - f f - f - -) 253 | y (s - f + x + f - s y)) 254 | 255 | (define-l-system (square-sierpinski :angle (radians 90)) (f + x f + f + x f) 256 | x (x f - f + f - x f + f + x f - f + f - x)) 257 | 258 | (define-l-system (peano-curve :angle (radians 90)) x 259 | x (x f y f x + f + y f x f y - f - x f y f x) 260 | y (y f x f y - f - x f y f x + f + y f x f y)) 261 | 262 | (define-l-system (hilbert-curve :angle (radians 90)) x 263 | x (- y f + x f x + f y -) 264 | y (+ x f - y f y - f x +)) 265 | 266 | (define-l-system (quadratic-gosper :angle (radians 90)) (- y f) 267 | x (x f x - y f - y f + f x + f x - y f - y f f x + y f + f x f x y f - 268 | f x + y f + f x f x + y f - f x y f - y f - f x + f x + y f y f -) 269 | y (+ f x f x - y f - y f + f x + f x y f + f x - y f y f - f x - y f + 270 | f x y f y f - f x - y f f x + f x + y f - y f - f x + f x + y f y)) 271 | 272 | (define-l-system (lévy-curve :angle (radians 45)) f 273 | f (- f + + f -)) 274 | 275 | 276 | ;;; http://www.kevs3d.co.uk/dev/lsystems/ 277 | 278 | (define-l-system (penrose :angle (radians 36)) 279 | ([ 7 ] + + [ 7 ] + + [ 7 ] + + [ 7 ] + + [ 7 ]) 280 | 6 (8 x + + 9 x - - - - 7 x [ - 8 x - - - - 6 x ] + +) 281 | 7 (+ 8 x - - 9 x [ - - - 6 x - - 7 x ] +) 282 | 8 (- 6 x + + 7 x [ + + + 8 x + + 9 x ] -) 283 | 9 (- - 8 x + + + + 6 x [ + 9 x + + + + 7 x ] - - 7 x) 284 | x ()) 285 | 286 | 287 | ;;;; Mutation ----------------------------------------------------------------- 288 | (defun insert (val target n) 289 | (append (subseq target 0 n) 290 | (list val) 291 | (subseq target n))) 292 | 293 | (defun remove-nth (list n) 294 | (concatenate 'list (subseq list 0 n) (subseq list (1+ n)))) 295 | 296 | (defun mutation-transpose (result) 297 | (rotatef (elt result (rand (length result))) 298 | (elt result (rand (length result)))) 299 | result) 300 | 301 | (defun mutation-insert (result) 302 | (zapf result (insert (random-elt (union (remove-duplicates result) 303 | '(f s - + < > %)) 304 | #'rand) 305 | % 306 | (rand (length result)))) 307 | result) 308 | 309 | (defun mutation-remove (result) 310 | (remove-nth result (rand (length result)))) 311 | 312 | (defun mutate-production (result) 313 | (if (<= (length result) 2) 314 | result 315 | (ecase (rand 3) 316 | (0 (mutation-transpose result)) 317 | (1 (mutation-insert result)) 318 | (2 (mutation-remove result))))) 319 | 320 | (defun mutate-productions% (productions) 321 | (iterate (for (letter production . nil) :on productions :by #'cddr) 322 | (appending (list letter (mutate-production (copy-list production)))))) 323 | 324 | (defun mutate-productions (productions) 325 | (iterate 326 | ;; complete no-op mutations are boring 327 | (for new = (mutate-productions% productions)) 328 | (finding new :such-that (not (equal new productions))))) 329 | 330 | (defun maybe-mutate-productions (productions) 331 | (let ((should-mutate (randomp 0.6 #'rand)) 332 | (mutation-seed (rand (expt 2 31)))) 333 | (if should-mutate 334 | (with-seed mutation-seed 335 | (values (mutate-productions productions) mutation-seed)) 336 | productions))) 337 | 338 | 339 | ;;;; Main --------------------------------------------------------------------- 340 | (defun select-l-system () 341 | (random-elt `((,*quadratic-koch-island-a* 2 5) 342 | (,*quadratic-koch-island-b* 2 4) 343 | (,*quadratic-snowflake* 3 7) 344 | (,*islands-and-lakes* 1 4) 345 | (,*unnamed-koch-a* 3 5) 346 | (,*unnamed-koch-b* 3 6) 347 | (,*unnamed-koch-c* 3 6) 348 | (,*unnamed-koch-d* 2 5) 349 | (,*unnamed-koch-e* 5 7) 350 | (,*unnamed-koch-f* 5 7) 351 | (,*dragon-curve* 7 16) 352 | (,*sierpinski-gasket* 4 10) 353 | (,*hexagonal-gosper-curve* 3 6) 354 | (,*bourke-triangle* 4 8) 355 | (,*bourke-pentaplexity* 3 5) 356 | (,*bourke-mango* 3 25) 357 | (,*square-sierpinski* 3 6) 358 | (,*peano-curve* 3 5) 359 | (,*hilbert-curve* 5 7) 360 | (,*quadratic-gosper* 2 3) 361 | (,*lévy-curve* 6 14) 362 | (,*penrose* 3 7) 363 | (,*tree-a* 3 7 ,(- 1/4tau)) 364 | (,*tree-b* 3 7 ,(- 1/4tau)) 365 | (,*tree-c* 3 5 ,(- 1/4tau)) 366 | (,*tree-d* 6 7 ,(- 1/4tau)) 367 | (,*tree-e* 6 8 ,(- 1/4tau)) 368 | (,*tree-f* 4 7 ,(- 1/4tau)) 369 | (,*saupe-pine* 7 12 ,(- 1/4tau)) 370 | (,*bourke-bush* 5 7 ,(- 1/4tau)) 371 | (,*bourke-weed* 5 8 ,(- 1/4tau)) 372 | ) 373 | #'rand)) 374 | 375 | 376 | (defun loom (seed filename filetype width height 377 | &key l-system iterations starting-angle pure) 378 | (nest 379 | (with-seed seed) 380 | (destructuring-bind 381 | (random-l-system min-iterations max-iterations &optional random-starting-angle) 382 | (select-l-system)) 383 | (randomly-initialize 384 | ((starting-angle (random-or random-starting-angle (rand tau))) 385 | (iterations (random-range-inclusive min-iterations max-iterations #'rand)) 386 | (l-system random-l-system))) 387 | (let* ((*starting-angle* starting-angle) 388 | (bg (hsv (rand 1.0) (rand 1.0) (random-range 0.0 0.2 #'rand))) 389 | (*color* (hsv (rand 1.0) 390 | (random-range 0.5 0.8 #'rand) 391 | (random-range 0.9 1.0 #'rand))) 392 | (axiom (axiom l-system)) 393 | (*angle* (recommended-angle l-system)))) 394 | (multiple-value-bind (productions mutagen) 395 | (if pure 396 | (values (productions l-system) nil) 397 | (maybe-mutate-productions (productions l-system)))) 398 | (flax.drawing:with-rendering 399 | (canvas filetype filename width height :background bg :padding 0.05)) 400 | (progn 401 | (_ (run-l-system axiom productions iterations) 402 | turtle-draw 403 | transform-to-fit 404 | (flax.drawing:render canvas _)) 405 | (values (name l-system) 406 | iterations 407 | mutagen)))) 408 | 409 | ;; (time (loom 1 "out" :svg 500 500)) 410 | -------------------------------------------------------------------------------- /src/looms/005-simple-triangulations.lisp: -------------------------------------------------------------------------------- 1 | (in-package :flax.looms.005-simple-triangulations) 2 | 3 | ;; https://mattdesl.svbtle.com/pen-plotter-1 4 | 5 | (defparameter *point-size* 0.003) 6 | 7 | (defun convert-point (point) 8 | (flax.drawing:circle point (random-gaussian *point-size* 9 | (* 0.15 *point-size*) 10 | #'rand))) 11 | 12 | (defun convert-triangle (ratio tri) 13 | (when (randomp ratio #'rand) 14 | (list (apply #'flax.drawing:triangle tri)))) 15 | 16 | (defun convert (points ratio) 17 | (append 18 | (map 'list #'convert-point points) 19 | (mapcan (curry #'convert-triangle ratio) (triangulate points)))) 20 | 21 | (defun triangulate (points) 22 | (mapcar (lambda (indexes) 23 | (map 'list (curry #'aref points) indexes)) 24 | (lofi.tri:triangulate (map 'vector (lambda (p) 25 | (cons (vx p) (vy p))) 26 | points)))) 27 | 28 | (defun gauss () 29 | (clamp 0.0 1.0 (random-gaussian 0.5 0.15 #'rand))) 30 | 31 | (defun generate-point-uniform () 32 | (vec2 (rand 1.0) (rand 1.0))) 33 | 34 | (defun generate-point-gaussian () 35 | (vec2 (gauss) (gauss))) 36 | 37 | (defun generate-point-gaussian-vertical () 38 | (vec2 (rand 1.0) (gauss))) 39 | 40 | (defun generate-point-gaussian-horizontal () 41 | (vec2 (gauss) (rand 1.0))) 42 | 43 | (defun generate (generator n) 44 | (iterate (repeat n) 45 | (collect (funcall generator) 46 | :result-type 'vector))) 47 | 48 | (defun select-generator () 49 | (random-elt '((generate-point-uniform "Uniform") 50 | (generate-point-gaussian "Gaussian") 51 | (generate-point-gaussian-vertical "Vertical Gaussian") 52 | (generate-point-gaussian-horizontal "Horizontal Gaussian")) 53 | #'rand)) 54 | 55 | (defun loom (seed filename filetype width height &key ratio points) 56 | (nest 57 | (with-seed seed) 58 | (flax.drawing:with-rendering (canvas filetype filename width height 59 | :background (hsv 0.09 0.05 0.975))) 60 | (destructuring-bind (generator generator-name) (select-generator)) 61 | (randomly-initialize 62 | ((ratio (if (randomp 0.5 #'rand) 63 | 1 64 | (random-range 0.05 0.2 #'rand))) 65 | (points (round-to (random-range-inclusive 100 1000 #'rand) 10)))) 66 | (progn 67 | (_ (generate generator points) 68 | (convert _ ratio) 69 | (flax.drawing:render canvas _)) 70 | (values generator-name points ratio)))) 71 | 72 | 73 | ;; (time (loom 55 "out" :svg 800 800 )) 74 | -------------------------------------------------------------------------------- /src/looms/006-tracing-lines.lisp: -------------------------------------------------------------------------------- 1 | (in-package :flax.looms.006-tracing-lines) 2 | 3 | ;;;; Config ------------------------------------------------------------------- 4 | (defparameter *spread-y* 0.0020) 5 | 6 | 7 | ;;;; Convert ------------------------------------------------------------------ 8 | (defun convert-point (point x y) 9 | (vec x (+ y point))) 10 | 11 | (defun convert-line (line y) 12 | (flax.drawing:path 13 | (iterate (for point :in-vector line) 14 | (for x :from 0.0 :by (/ (1- (length line)))) 15 | (collect (convert-point point x y))) 16 | :color (hsv 0 0 1))) 17 | 18 | (defun convert-lines (lines) 19 | (iterate (for line :in lines) 20 | (for y :from 0.0 :by (/ (length lines))) 21 | (collect (convert-line line y)))) 22 | 23 | 24 | ;;;; Generate ----------------------------------------------------------------- 25 | (defun make-initial-line (points) 26 | (make-array points :initial-element 0.0)) 27 | 28 | (defun perturb (point) 29 | (random-around point *spread-y* #'rand)) 30 | 31 | (defun wrapping-aref (array i) 32 | (aref array (mod i (length array)))) 33 | 34 | (defun average (sequence) 35 | (iterate (for x :in-whatever sequence) 36 | (averaging x))) 37 | 38 | (defun next-line (line) 39 | (iterate (for i :index-of-vector line) 40 | (collect (random-gaussian 41 | (average (subseq line 42 | (max 0 (- i 2)) 43 | (min (1- (length line)) (+ i 1)))) 44 | *spread-y* #'rand) 45 | :result-type 'vector))) 46 | 47 | (defun generate-lines (points lines) 48 | (iterate 49 | (repeat lines) 50 | (for line :first (make-initial-line points) :then (next-line line)) 51 | (collect line))) 52 | 53 | 54 | ;;;; Main --------------------------------------------------------------------- 55 | (defun loom (seed filename filetype width height &key lines points) 56 | (nest 57 | (with-seed seed) 58 | (flax.drawing:with-rendering (canvas filetype filename width height 59 | :background (hsv 0 0 0.05))) 60 | (randomly-initialize 61 | ((points (round-to (random-range 100 150 #'rand) 10)) 62 | (lines (round-to (random-range 80 140 #'rand) 10)))) 63 | (let ((*spread-y* (/ 0.15 lines)))) 64 | (progn 65 | (_ (generate-lines points lines) 66 | convert-lines 67 | (flax.drawing:render canvas _)) 68 | (values lines points)))) 69 | 70 | ;; (time (loom 4 "out" :svg 800 800)) 71 | -------------------------------------------------------------------------------- /src/looms/007-stippling.lisp: -------------------------------------------------------------------------------- 1 | (in-package :flax.looms.007-stipple) 2 | 3 | 4 | ;;;; Convert ------------------------------------------------------------------ 5 | (defun convert (points) 6 | (mapcar #'flax.drawing:point points)) 7 | 8 | 9 | ;;;; Shapes ------------------------------------------------------------------- 10 | (defstruct (rectangle (:conc-name nil)) a b) 11 | (defstruct (circle (:conc-name nil)) center radius) 12 | 13 | 14 | (define-with-macro rectangle a b) 15 | (define-with-macro circle center radius) 16 | 17 | 18 | (defun random-coord () 19 | (vec (rand 1.0) (rand 1.0))) 20 | 21 | (defun gen-rectangle () 22 | (make-rectangle :a (random-coord) :b (random-coord))) 23 | 24 | (defun gen-circle () 25 | (make-circle :center (random-coord) 26 | :radius (random-range 0.01 0.2 #'rand))) 27 | 28 | (chancery:define-rule (gen-shape :distribution :weighted) 29 | (1 gen-rectangle) 30 | (1 gen-circle)) 31 | 32 | (defun gen (shapes) 33 | (gimme shapes (gen-shape))) 34 | 35 | 36 | 37 | ;;;; Bounds ------------------------------------------------------------------- 38 | (defgeneric bounding-box (shape)) 39 | 40 | (defmethod bounding-box ((shape rectangle)) 41 | (cons (a shape) (b shape))) 42 | 43 | (defmethod bounding-box ((shape circle)) 44 | (with-circle (shape c r) 45 | (let ((x (vx c)) 46 | (y (vy c))) 47 | (cons (vec (- x r) (- y r)) 48 | (vec (+ x r) (+ y r)))))) 49 | 50 | (defun random-point-in-bounding-box (bounding-box) 51 | (destructuring-bind (a . b) bounding-box 52 | (let ((x1 (min (vx a) (vx b))) 53 | (x2 (max (vx a) (vx b))) 54 | (y1 (min (vy a) (vy b))) 55 | (y2 (max (vy a) (vy b)))) 56 | (vec (random-range-inclusive x1 x2 #'rand) 57 | (random-range-inclusive y1 y2 #'rand))))) 58 | 59 | 60 | ;;;; Area --------------------------------------------------------------------- 61 | (defgeneric area (shape)) 62 | 63 | (defmethod area ((shape rectangle)) 64 | (with-rectangle (shape) 65 | (* (abs (- (vx a) (vx b))) 66 | (abs (- (vy a) (vy b)))))) 67 | 68 | (defmethod area ((shape circle)) 69 | (* 1/2tau (square (radius shape)))) 70 | 71 | 72 | ;;;; Containment -------------------------------------------------------------- 73 | (defgeneric containsp (shape point) 74 | (:documentation 75 | "Return whether `shape` contains `point`. 76 | 77 | `point` is assumed to lie somewhere inside `shape`'s bounding box. 78 | 79 | ")) 80 | 81 | (defmethod containsp ((shape rectangle) point) 82 | t) 83 | 84 | (defmethod containsp ((shape circle) point) 85 | (<= (vdistance point (center shape)) 86 | (radius shape))) 87 | 88 | (defun canvas-contains-p (point) 89 | (and (<= 0 (vx point) 1) 90 | (<= 0 (vy point) 1))) 91 | 92 | (defun random-point-in-shape (shape) 93 | (iterate 94 | (with bb = (bounding-box shape)) 95 | (for p = (random-point-in-bounding-box bb)) 96 | (finding p :such-that (and (canvas-contains-p p) 97 | (containsp shape p))))) 98 | 99 | 100 | ;;;; Stipple ------------------------------------------------------------------ 101 | (defun perturb-ratio (ratio) 102 | (* ratio (clamp 0 10 (random-gaussian 1.0 20/100 #'rand)))) 103 | 104 | (defun stipple-shape (shape ratio) 105 | (gimme (round (* (perturb-ratio ratio) 106 | (area shape))) 107 | (random-point-in-shape shape))) 108 | 109 | (defun stipple (shapes ratio) 110 | (mapcan (rcurry #'stipple-shape ratio) shapes)) 111 | 112 | 113 | ;;;; Main --------------------------------------------------------------------- 114 | (defun loom (seed filename filetype width height &key shapes ratio) 115 | (nest 116 | (with-seed seed) 117 | (flax.drawing:with-rendering (canvas filetype filename width height 118 | :background (hsv 0.09 0.05 0.975))) 119 | (randomly-initialize 120 | ((shapes (clamp 1 100 (random-gaussian-integer 6 2 #'rand))))) 121 | (progn 122 | (_ (gen shapes) 123 | (stipple _ (/ (or ratio 100000) shapes)) 124 | convert 125 | (flax.drawing:render canvas _)) 126 | (values shapes)))) 127 | 128 | ;; (time (loom 11 "out" :svg 800 800)) 129 | ;; (time (loom 112 "out" :png 800 800 :ratio 4000000)) 130 | -------------------------------------------------------------------------------- /src/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :flax.base 2 | (:use :cl :iterate :losh 3 | :3d-vectors 4 | :3d-matrices) 5 | (:export 6 | :rand 7 | :with-seed 8 | :random-or 9 | :randomly-initialize 10 | :round-to 11 | :map-curried 12 | :mapcar-curried)) 13 | 14 | (defpackage :flax.colors 15 | (:use :cl :iterate :losh :flax.base) 16 | (:export 17 | :color 18 | :with-color 19 | :hsv 20 | :rgb)) 21 | 22 | (defpackage :flax.transform 23 | (:use :cl :iterate :losh :flax.base 24 | :3d-vectors 25 | :3d-matrices) 26 | (:export 27 | :transformation 28 | :scale 29 | :rotate 30 | :place 31 | :translate 32 | :ntransform 33 | :ntransformf)) 34 | 35 | (defpackage :flax.drawing 36 | (:use :cl :iterate :losh :flax.base 37 | :flax.colors 38 | :flax.transform 39 | :3d-vectors 40 | :3d-matrices) 41 | (:export 42 | :with-rendering 43 | :render 44 | :fade 45 | :triangle 46 | :path 47 | :points 48 | :rectangle 49 | :point 50 | :circle 51 | :text 52 | :glyph)) 53 | 54 | 55 | (defpackage :flax.looms.001-triangles 56 | (:use :cl :iterate :losh :flax.base 57 | :3d-vectors) 58 | (:export :loom)) 59 | 60 | (defpackage :flax.looms.002-wobbly-lines 61 | (:use :cl :iterate :losh :flax.base 62 | :flax.colors 63 | :3d-vectors) 64 | (:export :loom)) 65 | 66 | (defpackage :flax.looms.003-basic-l-systems 67 | (:use :cl :iterate :losh :flax.base 68 | :flax.colors 69 | :3d-vectors) 70 | (:export :loom)) 71 | 72 | (defpackage :flax.looms.004-turtle-curves 73 | (:use :cl :iterate :losh :flax.base 74 | :flax.colors 75 | :flax.transform 76 | :3d-vectors) 77 | (:export :loom)) 78 | 79 | (defpackage :flax.looms.005-simple-triangulations 80 | (:use :cl :iterate :losh :flax.base 81 | :flax.colors 82 | :3d-vectors) 83 | (:export :loom)) 84 | 85 | (defpackage :flax.looms.006-tracing-lines 86 | (:use :cl :iterate :losh :flax.base 87 | :flax.colors 88 | :3d-vectors) 89 | (:export :loom)) 90 | 91 | (defpackage :flax.looms.007-stipple 92 | (:use :cl :iterate :losh :flax.base 93 | :flax.colors 94 | :3d-vectors) 95 | (:export :loom)) 96 | 97 | 98 | (defpackage :flax.scratch 99 | (:use :cl :iterate :losh :flax.base 100 | :flax.colors 101 | :flax.transform 102 | :3d-vectors) 103 | (:export)) 104 | -------------------------------------------------------------------------------- /src/transform.lisp: -------------------------------------------------------------------------------- 1 | (in-package :flax.transform) 2 | 3 | (defun id () 4 | (meye 3)) 5 | 6 | (defun scale (m x y) 7 | (m* (mat x 0 0 8 | 0 y 0 9 | 0 0 1) 10 | m)) 11 | 12 | (defun rotate (m angle) 13 | (m* (mat (cos angle) (sin angle) 0 14 | (- (sin angle)) (cos angle) 0 15 | 0 0 1) 16 | m)) 17 | 18 | (defun translate (m x y) 19 | (m* (mat 1 0 x 20 | 0 1 y 21 | 0 0 1) 22 | m)) 23 | 24 | (defun place (m corner1 corner2 &key (padding 0.0)) 25 | (let* ((fw (abs (- (vx corner1) (vx corner2)))) 26 | (fh (abs (- (vy corner1) (vy corner2)))) 27 | (pw (* padding fw)) 28 | (ph (* padding fh)) 29 | (w (- fw pw pw)) 30 | (h (- fh ph ph)) 31 | (x (+ (min (vx corner1) (vx corner2)) pw)) 32 | (y (+ (min (vy corner1) (vy corner2)) ph))) 33 | (translate (scale m w h) x y))) 34 | 35 | 36 | (defmacro transformation (&rest transforms) 37 | `(_ (id) 38 | ,@(iterate (for (name . body) :in transforms) 39 | (collect `(,name _ ,@body))))) 40 | 41 | 42 | (defgeneric ntransform (object transformation)) 43 | 44 | (defmethod ntransform ((vector vec3) transformation) 45 | (nm* transformation vector) 46 | vector) 47 | 48 | (defmethod ntransform ((magnitude float) transformation) 49 | (with-fast-matref (m transformation 3) 50 | (let* ((a (m 0 0)) 51 | (b (m 0 1)) 52 | (c (m 1 0)) 53 | (d (m 1 1)) 54 | (scale (sqrt (/ (+ (square (+ a b)) 55 | (square (+ c d))) 56 | 2.0)))) 57 | (* magnitude scale)))) 58 | 59 | (defmethod ntransform ((sequence sequence) transformation) 60 | (map-into sequence (rcurry #'ntransform transformation) sequence)) 61 | 62 | 63 | (defmacro ntransformf (place transformation) 64 | ;; im lazy 65 | `(setf ,place (ntransform ,place ,transformation))) 66 | -------------------------------------------------------------------------------- /test/test.lisp: -------------------------------------------------------------------------------- 1 | (ql:quickload '(:flax :losh)) 2 | 3 | (defun check (interactive loom) 4 | (terpri) 5 | (losh:pr 'checking loom) 6 | (mapcar (lambda (output) 7 | (funcall loom nil "out" output 500 500) 8 | (losh:pr output 'OK)) 9 | '(:png :plot :svg)) 10 | (when interactive 11 | (break "Finished run of loom ~A" loom))) 12 | 13 | (defun check-all (&key interactive) 14 | (check interactive #'flax.looms.001-triangles:loom) 15 | (check interactive #'flax.looms.002-wobbly-lines:loom) 16 | (check interactive #'flax.looms.003-basic-l-systems:loom) 17 | (check interactive #'flax.looms.004-turtle-curves:loom) 18 | (check interactive #'flax.looms.005-simple-triangulations:loom) 19 | (check interactive #'flax.looms.006-tracing-lines:loom) 20 | (check interactive #'flax.looms.007-stipple:loom) 21 | (losh:pr 'ok)) 22 | 23 | (check-all) 24 | -------------------------------------------------------------------------------- /vendor/lofi-tri/lofi.tri.lisp: -------------------------------------------------------------------------------- 1 | ;;;; lofi-tri.lisp 2 | ;;; Code vendored from https://github.com/photex/lofi-tri 3 | ;;; TODO: Implement a divide & conquer algorithm at some point. 4 | 5 | (defpackage #:lofi.tri 6 | (:use #:cl #:sb-cga) 7 | (:export #:circle 8 | #:triangle 9 | #:random-point 10 | #:random-point-array 11 | #:sort-by-x 12 | #:sort-by-y 13 | #:sort-by-z 14 | #:distance 15 | #:midpoint 16 | #:circumcircle 17 | #:center 18 | #:radius 19 | #:verts 20 | #:in-circumcircle? 21 | #:has-shared-verts? 22 | #:triangulate)) 23 | 24 | (in-package #:lofi.tri) 25 | 26 | ;;; "lofi-tri" goes here. Hacks and glory await! 27 | 28 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 29 | ;; structs 30 | 31 | (defstruct circle 32 | (center nil :type vec) 33 | (radius 0.0 :type float) 34 | (radius-squared 0.0 :type float) 35 | (diameter 0.0 :type float)) 36 | 37 | (defstruct triangle 38 | (verts #() :type vector) 39 | (circumcircle nil :type circle)) 40 | 41 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 42 | ;; Utilities 43 | 44 | (defun random-point (&optional (state *random-state*)) 45 | "Return an instance of sb-cga:vec initialized with random values." 46 | (apply #'vec (loop repeat 3 47 | collect (random 1.0 state)))) 48 | 49 | (defun random-point-array (count &optional (state *random-state*)) 50 | "Returns an array of random-points." 51 | (let ((result (make-array count :fill-pointer 0))) 52 | (dotimes (i count) 53 | (vector-push (random-point state) result)) 54 | result)) 55 | 56 | (defmacro sort-by (point-set index) 57 | "Sort the input point set by the value in the specified index." 58 | `(sort ,point-set #'< :key (lambda (p) (aref p ,index)))) 59 | 60 | (defmacro sort-by-x (point-set) 61 | "Sort the input point set by the value at 0" 62 | `(sort-by ,point-set 0)) 63 | 64 | (defmacro sort-by-y (point-set) 65 | "Sort the input point set by the value at 1" 66 | `(sort-by ,point-set 1)) 67 | 68 | (defmacro sort-by-z (point-set) 69 | "Sort the input point set by the value at 2" 70 | `(sort-by ,point-set 2)) 71 | 72 | (defun get-min-max (point-set) 73 | "Return the min and max vectors for the given point set. Effectively the bounding box." 74 | (let* ((first-point (aref point-set 0)) 75 | (rest-points (subseq point-set 1)) 76 | (minx (aref first-point 0)) (maxx (aref first-point 0)) 77 | (miny (aref first-point 1)) (maxy (aref first-point 1)) 78 | (minz (aref first-point 2)) (maxz (aref first-point 2))) 79 | (loop :for p :across rest-points :do 80 | (setf minx (min minx (aref p 0)) maxx (max maxx (aref p 0)) 81 | miny (min miny (aref p 1)) maxy (max maxy (aref p 1)) 82 | minz (min minz (aref p 2)) maxz (max maxz (aref p 2)))) 83 | (values (vec minx miny minz) (vec maxx maxy maxz)))) 84 | 85 | (defun get-bounding-triangle-points (point-set &optional (fudge-factor 10)) 86 | (multiple-value-bind (min max) (get-min-max point-set) 87 | (let ((dx (* fudge-factor (- (aref max 0) (aref min 0)))) 88 | (dy (* fudge-factor (- (aref max 1) (aref min 1))))) 89 | (make-array 3 :initial-contents 90 | (list (sb-cga:vec (- (aref min 0) dx) (- (aref min 1) (* dy 3)) 0.0) 91 | (sb-cga:vec (- (aref min 0) dx) (+ (aref max 1) dy) 0.0) 92 | (sb-cga:vec (+ (aref max 0) (* dx 3)) (+ (aref max 1) dy) 0.0)))))) 93 | 94 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 95 | ;; Meat and potatos 96 | 97 | (defun distance (v0 v1 &key 3d squared) 98 | "Calculate the distance between two vectors in 2D or 3D. 99 | Will return the square root of the result unless :squared t" 100 | (declare (type vec v0 v1)) 101 | (let* ((diff (vec- v0 v1)) 102 | (result (apply #'+ (loop for i from 0 upto (if 3d 2 1) 103 | collect (expt (aref diff i) 2))))) 104 | (if squared 105 | result 106 | (sqrt result)))) 107 | 108 | (defun midpoint (v0 v1) 109 | "Return a vector representing the midpoint between the two provided vectors." 110 | (declare (type vec v0 v1)) 111 | (vec/ (vec+ v0 v1) 2.0)) 112 | 113 | (defun circumcircle (v0 v1 v2) 114 | "Returns a circle struct representing the circumcircle of the given 3 vertices" 115 | (let* ((v1-v0 (vec- v1 v0)) 116 | (v2-v0 (vec- v2 v0)) 117 | (v2-v1 (vec- v2 v1)) 118 | (v1+v0 (vec+ v1 v0)) 119 | (v2+v0 (vec+ v2 v0)) 120 | (a (aref v1-v0 0)) 121 | (b (aref v1-v0 1)) 122 | (c (aref v2-v0 0)) 123 | (d (aref v2-v0 1)) 124 | (e (+ (* a (aref v1+v0 0)) 125 | (* b (aref v1+v0 1)))) 126 | (f (+ (* c (aref v2+v0 0)) 127 | (* d (aref v2+v0 1)))) 128 | (g (* 2.0 (- (* a (aref v2-v1 1)) 129 | (* b (aref v2-v1 0))))) 130 | (colinear? (< (abs g) +default-epsilon+)) 131 | (cx 0.0) (cy 0.0) (dx 0.0) (dy 0.0)) 132 | (if colinear? 133 | (let ((minx (min (aref v0 0) (aref v1 0) (aref v2 0))) 134 | (miny (min (aref v0 1) (aref v1 1) (aref v2 1))) 135 | (maxx (max (aref v0 0) (aref v1 0) (aref v2 0))) 136 | (maxy (max (aref v0 1) (aref v1 1) (aref v2 1)))) 137 | (setf cx (/ (+ minx maxx) 2) 138 | cy (/ (+ miny maxy) 2) 139 | dx (- cx minx) 140 | dy (- cy miny))) 141 | ;; else 142 | (setf cx (/ (- (* d e) (* b f)) g) 143 | cy (/ (- (* a f) (* c e)) g) 144 | dx (- cx (aref v0 0)) 145 | dy (- cy (aref v0 1)))) 146 | (let* ((radius-squared (+ (* dx dx) 147 | (* dy dy))) 148 | (radius (sqrt radius-squared))) 149 | (make-circle :center (vec cx cy 0.0) 150 | :radius radius 151 | :radius-squared radius-squared 152 | :diameter (* radius 2))))) 153 | 154 | (defun new-triangle (vi0 vi1 vi2 points) 155 | "Returns a new triangle." 156 | (let ((v0 (aref points vi0)) 157 | (v1 (aref points vi1)) 158 | (v2 (aref points vi2))) 159 | (make-triangle :verts (make-array 3 :initial-contents (list vi0 vi1 vi2)) 160 | :circumcircle (circumcircle v0 v1 v2)))) 161 | 162 | (defun in-circumcircle? (tri p) 163 | "Does point 'p' sit within the circumcircle of 'tri'?" 164 | (declare (type triangle tri) (type vec p)) 165 | (let* ((circumcircle (slot-value tri 'circumcircle)) 166 | (center (slot-value circumcircle 'center)) 167 | (dist-squared (distance center p :squared t))) 168 | (<= dist-squared (slot-value circumcircle 'radius-squared)))) 169 | 170 | (defmacro edge= (a b) 171 | `(or (and (= (first ,a) (first ,b)) 172 | (= (second ,a) (second ,b))) 173 | (and (= (first ,a) (second ,b)) 174 | (= (second ,a) (first ,b))))) 175 | 176 | (defun unique-edge? (edges a) 177 | (let ((instance-count (length (remove-if-not (lambda (b) (edge= a b)) edges)))) 178 | (<= instance-count 1))) 179 | 180 | (defun has-shared-verts? (a b) 181 | (declare (type triangle a b)) 182 | (let* ((averts (slot-value a 'verts)) 183 | (bverts (slot-value b 'verts)) 184 | (av0 (aref averts 0)) 185 | (av1 (aref averts 1)) 186 | (av2 (aref averts 2)) 187 | (bv0 (aref bverts 0)) 188 | (bv1 (aref bverts 1)) 189 | (bv2 (aref bverts 2))) 190 | (or (= bv0 av0) (= bv0 av1) (= bv0 av2) 191 | (= bv1 av0) (= bv1 av1) (= bv1 av2) 192 | (= bv2 av0) (= bv2 av1) (= bv2 av2)))) 193 | 194 | (defun add-vertex (vi triangles points) 195 | (let* ((edges ()) 196 | (unaffected-tris ())) 197 | ;; For each triangle in the list we take the edges 198 | ;; of any triangle where vert is inside it's circumcircle 199 | ;; and append it to the edges list. Otherwise the triangle 200 | ;; is collected and stored in unaffected-tris 201 | (setf unaffected-tris 202 | (loop for tri in triangles 203 | if (in-circumcircle? tri (aref points vi)) 204 | do (let* ((verts (slot-value tri 'verts)) 205 | (e0 (list (aref verts 0) (aref verts 1))) 206 | (e1 (list (aref verts 1) (aref verts 2))) 207 | (e2 (list (aref verts 2) (aref verts 0)))) 208 | (setf edges (append edges (list e0 e1 e2)))) 209 | else collect tri)) 210 | 211 | ;; Remove any edges that are duplicate so that the edge 212 | ;; list only contains the boundary edges. 213 | (setf edges (remove-if-not (lambda (edge) 214 | (unique-edge? edges edge)) 215 | edges)) 216 | 217 | ;; Using the remaining edges and our input vert create 218 | ;; new triangles and return them appended to our unaffected-tris list 219 | (append unaffected-tris (loop for edge in edges 220 | collect (let ((vi0 (first edge)) 221 | (vi1 (second edge))) 222 | (new-triangle vi0 vi1 vi points)))))) 223 | 224 | (defun triangulate (points) 225 | (let* (;; sjl: let the input be something vanilla 226 | (ps (map 'vector (lambda (point) 227 | (sb-cga:vec (car point) (cdr point) 0.0)) 228 | points)) 229 | ;; Add the coords for a large bounding triangle to the point set 230 | (st-coords (get-bounding-triangle-points ps)) 231 | (sti0 (length ps)) 232 | (sti1 (1+ sti0)) 233 | (sti2 (1+ sti1)) 234 | (ps (concatenate 'vector ps st-coords)) 235 | ;; Create the bounding triangle instance 236 | (supertri (new-triangle sti0 sti1 sti2 ps)) 237 | ;; Initialize our triangle list 238 | (triangles (list supertri))) 239 | 240 | ;; For each point in the list we get an updated set 241 | ;; of triangles by retesselating using the new point 242 | (loop for i below (length ps) 243 | do (setf triangles (add-vertex i triangles ps))) 244 | 245 | ;; Remove any triangles that share points with the super triangle 246 | (mapcar (lambda (triangle) 247 | (slot-value triangle 'verts)) 248 | (remove-if (lambda (triangle) 249 | (has-shared-verts? supertri triangle)) 250 | triangles)))) 251 | --------------------------------------------------------------------------------