308e324d06da

Add turtle curves
[view raw] [browse files]
author Steve Losh <steve@stevelosh.com>
date Thu, 15 Feb 2018 00:02:15 -0500
parents 2288ce7181a1
children af3a843d3c40
branches/tags (none)
files .lispwords flax.asd package.lisp src/base.lisp src/looms/002-wobbly-lines.lisp src/looms/004-turtle-curves.lisp

Changes

--- 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)
--- 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")))))))
 
--- 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))
 
+
--- 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))
+
--- 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))
--- /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))