# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1519175543 18000
# Node ID 3e7390e1f6907c7adb050e49c0b7af1d7a50da7c
# Parent  af3a843d3c402df4a9d6051b3e4af6a1fe2a13a9
Add some trees, and mutate the l-systems sometimes

diff -r af3a843d3c40 -r 3e7390e1f690 src/looms/004-turtle-curves.lisp
--- a/src/looms/004-turtle-curves.lisp	Thu Feb 15 00:10:16 2018 -0500
+++ b/src/looms/004-turtle-curves.lisp	Tue Feb 20 20:12:23 2018 -0500
@@ -9,9 +9,10 @@
 (defstruct turtle
   (x 0.5)
   (y 0.5)
-  (angle *starting-angle*))
+  (angle *starting-angle*)
+  (state nil))
 
-(define-with-macro turtle x y angle)
+(define-with-macro turtle x y angle state)
 
 
 (defun rot (angle amount)
@@ -42,6 +43,9 @@
     (incf y (* *step* (sin angle))))
   nil)
 
+(defmethod perform-command (turtle (command (eql 'x)))
+  nil)
+
 (defmethod perform-command (turtle (command (eql '-)))
   (rotf (turtle-angle turtle) *angle*)
   nil)
@@ -50,6 +54,18 @@
   (rotf (turtle-angle turtle) (- *angle*))
   nil)
 
+(defmethod perform-command (turtle (command (eql '<)))
+  (with-turtle (turtle)
+    (push (list x y angle) state))
+  nil)
+
+(defmethod perform-command (turtle (command (eql '>)))
+  (with-turtle (turtle)
+    (when-let ((prev (pop state)))
+      (destructuring-bind (ox oy oa) prev
+          (setf x ox y oy angle oa))))
+  nil)
+
 
 (defun find-bounds (paths)
   (iterate (for path :in paths)
@@ -66,20 +82,19 @@
 
 (defun scale (paths)
   (iterate
+    ;; (with aspect = 1)
     (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 %)))))
+      (x p1) (map-range min-x max-x x-padding (- 1.0 x-padding) %)
+      (y p1) (map-range min-y max-y y-padding (- 1.0 y-padding) %)
+      (x p2) (map-range min-x max-x x-padding (- 1.0 x-padding) %)
+      (y p2) (map-range min-y max-y y-padding (- 1.0 y-padding) %))))
 
 (defun turtle-draw (commands)
   (let ((paths (mapcan (curry #'perform-command (make-turtle)) commands)))
@@ -100,14 +115,26 @@
     (finally (return word))))
 
 
+(defclass* l-system ()
+  ((name)
+   (axiom)
+   (productions)
+   (recommended-angle)))
+
+(defun make-l-system (name axiom productions recommended-angle)
+  (make-instance 'l-system
+    :name name
+    :axiom (ensure-list axiom)
+    :productions productions
+    :recommended-angle recommended-angle))
+
+
 (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))))
+    `(defparameter ,(symb '* name '*)
+       (make-l-system ',name ',axiom ',productions ,angle))))
+
 
 (define-l-system quadratic-koch-island-a (f - f - f - f)
   f (f - f + f + f f - f - f + f))
@@ -153,38 +180,122 @@
   fr (- fl + fr fr + + fr + fl - - fl - fr))
 
 
+(define-l-system (tree-a :angle (radians 25.7)) f
+  f (f < + f > f < - f > f))
+
+(define-l-system (tree-b :angle (radians 20)) f
+  f (f < + f > f < - f > < f >))
+
+(define-l-system (tree-c :angle (radians 22.5)) f
+  f (f f - < - f + f + f > + < + f - f - f >))
+
+(define-l-system (tree-d :angle (radians 20)) x
+  x (f < + x > f < - x > + x)
+  f (f f))
+
+(define-l-system (tree-e :angle (radians 25.7)) x
+  x (f < + x > < - x > f x)
+  f (f f))
+
+(define-l-system (tree-f :angle (radians 22.5)) x
+  x (f - < < x > + x > + f < + f x > - x)
+  f (f f))
+
+
+
+;;;; Mutation -----------------------------------------------------------------
+(defun insert (val target n)
+  (append (subseq target 0 n)
+          (list val)
+          (subseq target n)))
+
+
+(defun mutation-transpose (result)
+  (pr 'transposing result)
+  (rotatef (elt result (rand (length result)))
+           (elt result (rand (length result))))
+  (pr '----------> result)
+  result)
+
+(defun mutation-insert (result)
+  (pr 'inserting result)
+  (zapf result (insert (random-elt result #'rand)
+                       %
+                       (rand (length result))))
+  (pr '--------> result)
+  result)
+
+(defun mutate-production (result)
+  (if (<= (length result) 2)
+    result
+    (ecase (rand 2)
+      (0 (mutation-transpose result))
+      (1 (mutation-insert result)))))
+
+(defun mutate-productions (productions)
+  (iterate (for (letter production . nil) :on productions :by #'cddr)
+           (appending (list letter (mutate-production (copy-list production))))))
+
+
 ;;;; Main ---------------------------------------------------------------------
-(defun loom (seed filename width height)
+(defun select-l-system ()
+  (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)
+                (,*tree-a* 3 7 ,(- 1/4tau))
+                (,*tree-b* 3 7 ,(- 1/4tau))
+                (,*tree-c* 3 5 ,(- 1/4tau))
+                (,*tree-d* 6 7 ,(- 1/4tau))
+                (,*tree-e* 6 8 ,(- 1/4tau))
+                (,*tree-f* 4 7 ,(- 1/4tau)))
+              #'rand))
+
+(defun loom (seed filename width height
+             &optional l-system iterations starting-angle)
   (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))))
+    (destructuring-bind
+        (l-system min-iterations max-iterations &optional starting-angle)
+        (if l-system
+          (list l-system iterations iterations starting-angle)
+          (select-l-system)))
+    (let* ((*starting-angle* (or 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 0.8 #'rand)
+                         (random-range 0.9 1.0 #'rand)))
+           (iterations (random-range-inclusive min-iterations
+                                               max-iterations
+                                               #'rand))
+           (axiom (l-system-axiom l-system))
+           (should-mutate (randomp 0.6 #'rand))
+           (mutation-seed (rand (expt 2 31)))
+           (productions (-<> l-system
+                          l-system-productions
+                          (if should-mutate
+                            (with-seed mutation-seed
+                              (mutate-productions <>))
+                            <>)))
+           (*angle* (l-system-recommended-angle l-system))))
     (flax.drawing:with-rendering (image filename width height :background bg))
-    (multiple-value-bind (shapes *angle*) (funcall l-system iterations))
-    (progn (-<> shapes
+    (progn (-<> (run-l-system axiom productions iterations)
              (turtle-draw <>)
              (flax.drawing:render image <>))
-           (list l-system iterations))))
+           (list (l-system-name l-system)
+                 iterations
+                 (if should-mutate mutation-seed nil)))))
 
+
+
+;; (time (loom nil "out.png" 1000 1000 *tree-f* 7 (- 1/4tau)))
 ;; (time (loom nil "out.png" 1000 1000))