# HG changeset patch # User Steve Losh # Date 1518670935 18000 # Node ID 308e324d06da7402e40b0096636c79c8e030bf8c # Parent 2288ce7181a1280e2dfbd116f023db35cdccc48f Add turtle curves diff -r 2288ce7181a1 -r 308e324d06da .lispwords --- a/.lispwords Sat Feb 10 15:43:15 2018 -0500 +++ b/.lispwords Thu Feb 15 00:02:15 2018 -0500 @@ -1,2 +1,3 @@ (2 with-coordinates) (1 with-rendering) +(2 define-l-system) diff -r 2288ce7181a1 -r 308e324d06da flax.asd --- a/flax.asd Sat Feb 10 15:43:15 2018 -0500 +++ b/flax.asd Thu Feb 15 00:02:15 2018 -0500 @@ -25,5 +25,6 @@ :components ((:file "001-triangles") (:file "002-wobbly-lines") - (:file "003-basic-l-systems"))))))) + (:file "003-basic-l-systems") + (:file "004-turtle-curves"))))))) diff -r 2288ce7181a1 -r 308e324d06da package.lisp --- a/package.lisp Sat Feb 10 15:43:15 2018 -0500 +++ b/package.lisp Thu Feb 15 00:02:15 2018 -0500 @@ -27,8 +27,10 @@ :fade :triangle :path + :points :rectangle)) + (defpackage :flax.looms.001-triangles (:use :cl :iterate :losh :flax.base :flax.quickutils :flax.coordinates) @@ -46,4 +48,10 @@ :flax.coordinates) (:export :loom)) +(defpackage :flax.looms.004-turtle-curves + (:use :cl :iterate :losh :flax.base :flax.quickutils + :flax.colors + :flax.coordinates) + (:export :loom)) + diff -r 2288ce7181a1 -r 308e324d06da src/base.lisp --- a/src/base.lisp Sat Feb 10 15:43:15 2018 -0500 +++ b/src/base.lisp Thu Feb 15 00:02:15 2018 -0500 @@ -5,3 +5,4 @@ (defmacro with-seed (seed &body body) `(let ((pcg::*global-generator* (pcg:make-pcg :seed ,seed))) ,@body)) + diff -r 2288ce7181a1 -r 308e324d06da src/looms/002-wobbly-lines.lisp --- a/src/looms/002-wobbly-lines.lisp Sat Feb 10 15:43:15 2018 -0500 +++ b/src/looms/002-wobbly-lines.lisp Thu Feb 15 00:02:15 2018 -0500 @@ -76,4 +76,4 @@ mode)))) -;; (time (loom nil 1000 "out.png" 800 300)) +(time (loom nil 1000 "out.png" 800 300)) diff -r 2288ce7181a1 -r 308e324d06da src/looms/004-turtle-curves.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/looms/004-turtle-curves.lisp Thu Feb 15 00:02:15 2018 -0500 @@ -0,0 +1,190 @@ +(in-package :flax.looms.004-turtle-curves) + +;;;; Turtle Graphics ---------------------------------------------------------- +(defvar *step* 0.1) +(defvar *angle* 1/4tau) +(defvar *starting-angle* (- 1/4tau)) +(defvar *color* nil) + +(defstruct turtle + (x 0.5) + (y 0.5) + (angle *starting-angle*)) + +(define-with-macro turtle x y angle) + + +(defun rot (angle amount) + (mod (+ angle amount) tau)) + +(define-modify-macro rotf (amount) rot) + + +(defgeneric perform-command (turtle command)) + +(defmethod perform-command (turtle (command (eql 'f))) + (with-turtle (turtle) + (list (flax.drawing:path + (list (coord x y) + (progn (perform-command turtle 's) + (coord x y))) + :color *color*)))) + +(defmethod perform-command (turtle (command (eql 'fl))) + (perform-command turtle 'f)) + +(defmethod perform-command (turtle (command (eql 'fr))) + (perform-command turtle 'f)) + +(defmethod perform-command (turtle (command (eql 's))) + (with-turtle (turtle) + (incf x (* *step* (cos angle))) + (incf y (* *step* (sin angle)))) + nil) + +(defmethod perform-command (turtle (command (eql '-))) + (rotf (turtle-angle turtle) *angle*) + nil) + +(defmethod perform-command (turtle (command (eql '+))) + (rotf (turtle-angle turtle) (- *angle*)) + nil) + + +(defun find-bounds (paths) + (iterate (for path :in paths) + (for (p1 p2) = (flax.drawing:points path)) + (maximizing (x p1) :into max-x) + (maximizing (x p2) :into max-x) + (maximizing (y p1) :into max-y) + (maximizing (y p2) :into max-y) + (minimizing (x p1) :into min-x) + (minimizing (x p2) :into min-x) + (minimizing (y p1) :into min-y) + (minimizing (y p2) :into min-y) + (finally (return (list min-x min-y max-x max-y))))) + +(defun scale (paths) + (iterate + (with (min-x min-y max-x max-y) = (find-bounds paths)) + (with factor = (min (/ (- max-x min-x)) + (/ (- max-y min-y)))) + (with x-padding = (/ (- 1.0 (* factor (- max-x min-x))) 2)) + (with y-padding = (/ (- 1.0 (* factor (- max-y min-y))) 2)) + (with offset-x = (+ (- min-x) x-padding)) + (with offset-y = (+ (- min-y) y-padding)) + (for path :in paths) + (for (p1 p2) = (flax.drawing:points path)) + (zapf + (x p1) (* factor (+ offset-x %)) + (y p1) (* factor (+ offset-y %)) + (x p2) (* factor (+ offset-x %)) + (y p2) (* factor (+ offset-y %))))) + +(defun turtle-draw (commands) + (let ((paths (mapcan (curry #'perform-command (make-turtle)) commands))) + (scale paths) + paths)) + + +;;;; L-Systems ---------------------------------------------------------------- +(defun expand (word productions) + (mappend (lambda (letter) + (ensure-list (or (getf productions letter) letter))) + word)) + +(defun run-l-system (axiom productions iterations) + (iterate + (repeat iterations) + (for word :initially axiom :then (expand word productions)) + (finally (return word)))) + + +(defmacro define-l-system (name-and-options axiom &body productions) + (destructuring-bind (name &key (angle 1/4tau)) + (ensure-list name-and-options) + `(defun ,name (iterations) + (values (run-l-system ',(ensure-list axiom) + ',productions + iterations) + ,angle)))) + +(define-l-system quadratic-koch-island-a (f - f - f - f) + f (f - f + f + f f - f - f + f)) + +(define-l-system quadratic-koch-island-b (f - f - f - f) + f (f + f f - f f - f - f + f + f f - f - f + f + f f + f f - f)) + +(define-l-system quadratic-snowflake (- f) + f (f + f - f - f + f)) + +(define-l-system islands-and-lakes (f + f + f + f) + f (f + s - f f + f + f f + f s + f f - s + f f - f - f f - f s - f f f) + s (s s s s s s)) + +(define-l-system unnamed-koch-a (f - f - f - f) + f (f f - f - f - f - f - f + f)) + +(define-l-system unnamed-koch-b (f - f - f - f) + f (f f - f - f - f - f f)) + +(define-l-system unnamed-koch-c (f - f - f - f) + f (f f - f + f - f - f f)) + +(define-l-system unnamed-koch-d (f - f - f - f) + f (f f - f - - f - f)) + +(define-l-system unnamed-koch-e (f - f - f - f) + f (f - f f - - f - f)) + +(define-l-system unnamed-koch-f (f - f - f - f) + f (f - f + f - f - f)) + +(define-l-system dragon-curve fl + fl (fl + fr +) + fr (- fl - fr)) + +(define-l-system (sierpinski-gasket :angle (/ tau 6)) fr + fl (fr + fl + fr) + fr (fl - fr - fl)) + +(define-l-system (hexagonal-gosper-curve :angle (/ tau 6)) fl + fl (fl + fr + + fr - fl - - fl fl - fr +) + fr (- fl + fr fr + + fr + fl - - fl - fr)) + + +;;;; Main --------------------------------------------------------------------- +(defun loom (seed filename width height) + (nest + (with-seed seed) + (destructuring-bind (l-system min-iterations max-iterations) + (random-elt '((quadratic-koch-island-a 2 5) + (quadratic-koch-island-b 2 4) + (quadratic-snowflake 3 7) + (islands-and-lakes 1 4) + (unnamed-koch-a 3 5) + (unnamed-koch-b 3 6) + (unnamed-koch-c 3 6) + (unnamed-koch-d 2 5) + (unnamed-koch-e 5 7) + (unnamed-koch-f 5 7) + (dragon-curve 7 16) + (sierpinski-gasket 4 10) + (hexagonal-gosper-curve 3 6)) + #'rand)) + (let ((*starting-angle* (rand tau)) + (bg (hsv (rand 1.0) (rand 1.0) (random-range 0.0 0.2 #'rand))) + (*color* (hsv (rand 1.0) + (random-range 0.5 1.0 #'rand) + (random-range 0.8 1.0 #'rand))) + (iterations (random-range-inclusive min-iterations + max-iterations + #'rand)))) + (flax.drawing:with-rendering (image filename width height :background bg)) + (multiple-value-bind (shapes *angle*) (funcall l-system iterations)) + (progn (-<> shapes + (turtle-draw <>) + (flax.drawing:render image <>)) + (list l-system iterations)))) + +;; (time (loom nil "out.png" 1000 1000))