# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1553731115 14400
# Node ID 0d86e460026d76c0d3a82c922e38e5e7984caa38
# Parent  386728efe61ce516e2112744721ec6b1f7fc7eef
Add more l-systems

diff -r 386728efe61c -r 0d86e460026d src/base.lisp
--- a/src/base.lisp	Sat Apr 14 01:12:37 2018 -0400
+++ b/src/base.lisp	Wed Mar 27 19:58:35 2019 -0400
@@ -7,9 +7,9 @@
 (defmacro with-seed (seed &body body)
   (once-only (seed)
     `(let ((pcg::*global-generator*
-             (pcg:make-pcg :seed (pr (or ,seed (random (expt 2 31))))))
+             (pcg:make-pcg :seed (pr (or ,seed (random (expt 2 31))) 'seed)))
            (chancery:*random* #'rand))
-       (losh::clear-gaussian-spare)
+       (losh.random::clear-gaussian-spare)
        ,@body)))
 
 (defmacro random-or (value random-form)
diff -r 386728efe61c -r 0d86e460026d src/looms/004-turtle-curves.lisp
--- a/src/looms/004-turtle-curves.lisp	Sat Apr 14 01:12:37 2018 -0400
+++ b/src/looms/004-turtle-curves.lisp	Wed Mar 27 19:58:35 2019 -0400
@@ -23,6 +23,9 @@
 
 (defgeneric perform-command (turtle command n))
 
+(defmethod perform-command (turtle command n)
+  nil)
+
 (defmethod perform-command (turtle (command (eql 'f)) n)
   (with-turtle (turtle)
     (list (flax.drawing:path
@@ -31,10 +34,7 @@
                          (vec x y)))
             :color *color*))))
 
-(defmethod perform-command (turtle (command (eql 'l)) n)
-  (perform-command turtle 'f n))
-
-(defmethod perform-command (turtle (command (eql 'r)) n)
+(defmethod perform-command (turtle (command integer) n)
   (perform-command turtle 'f n))
 
 (defmethod perform-command (turtle (command (eql 's)) n)
@@ -44,9 +44,6 @@
       (incf y (* *step* (sin angle)))))
   nil)
 
-(defmethod perform-command (turtle (command (eql 'x)) n)
-  nil)
-
 (defmethod perform-command (turtle (command (eql '-)) n)
   (rotf (turtle-angle turtle) (* n *angle*))
   nil)
@@ -55,6 +52,10 @@
   (rotf (turtle-angle turtle) (* n (- *angle*)))
   nil)
 
+(defmethod perform-command (turtle (command (eql '%)) n)
+  (rotf (turtle-angle turtle) 1/2tau)
+  nil)
+
 (defmethod perform-command (turtle (command (eql '<)) n)
   (do-repeat n
     (with-turtle (turtle)
@@ -69,6 +70,12 @@
           (setf x ox y oy angle oa)))))
   nil)
 
+(defmethod perform-command (turtle (command (eql '[)) n)
+  (perform-command turtle '< n))
+
+(defmethod perform-command (turtle (command (eql '])) n)
+  (perform-command turtle '> n))
+
 
 (defun find-bounds (paths)
   (iterate (for path :in paths)
@@ -124,6 +131,11 @@
     (for word :initially axiom :then (expand word productions))
     (finally (return word))))
 
+(defun run-named-l-system (l-system iterations)
+  (run-l-system (l-system-axiom l-system)
+                (l-system-productions l-system)
+                iterations))
+
 
 (defclass* l-system ()
   ((name)
@@ -177,17 +189,17 @@
 (define-l-system unnamed-koch-f (f - f - f - f)
   f (f - f + f - f - f))
 
-(define-l-system dragon-curve l
-  l (l + r +)
-  r (- l - r))
+(define-l-system dragon-curve 1
+  1 (1 + 2 +)
+  2 (- 1 - 2))
 
-(define-l-system (sierpinski-gasket :angle (/ tau 6)) r
-  l (r + l + r)
-  r (l - r - l))
+(define-l-system (sierpinski-gasket :angle (/ tau 6)) 2
+  1 (2 + 1 + 2)
+  2 (1 - 2 - 1))
 
-(define-l-system (hexagonal-gosper-curve :angle (/ tau 6)) l
-  l (l + r + + r - l - - l l - r +)
-  r (- l + r r + + r + l - - l - r))
+(define-l-system (hexagonal-gosper-curve :angle (/ tau 6)) 1
+  1 (1 + 2 + + 2 - 1 - - 1 1 - 2 +)
+  2 (- 1 + 2 2 + + 2 + 1 - - 1 - 2))
 
 
 (define-l-system (tree-a :angle (radians 25.7)) f
@@ -212,6 +224,65 @@
   f (f f))
 
 
+;;; http://paulbourke.net/fractals/lsys/
+
+(define-l-system (saupe-pine :angle (radians 20)) (v z f f f)
+  v (< + + + w > < - - - w > y v)
+  w (+ x < - w > z)
+  x (- w < + x > z)
+  y (y z)
+  z (< - f f f > < + f f f > f))
+
+(define-l-system (bourke-bush :angle (radians 25.7)) y
+  x (x < - f f f > < + f f f > f x)
+  y (y f x < + y > < - y >))
+
+(define-l-system (bourke-weed :angle (radians 22.5)) f
+  f (f f - < x y > + < x y >)
+  x (+ f y)
+  y (- f x))
+
+(define-l-system (bourke-triangle :angle (radians 120)) (f + f + f)
+  f (f - f + f))
+
+(define-l-system (bourke-pentaplexity :angle (radians 36)) (F + + F + + F + + F + + F)
+  f (f + + f + + f % f - f + + f))
+
+(define-l-system (bourke-mango :angle (radians 60)) (Y - - - Y)
+  x (f - f f - f - - < - - x > f - f f - f - - f - f f - f - -)
+  y (s - f + x + f - s y))
+
+(define-l-system (square-sierpinski :angle (radians 90)) (f + x f + f + x f)
+  x (x f - f + f - x f + f + x f - f + f - x))
+
+(define-l-system (peano-curve :angle (radians 90)) x
+  x (x f y f x + f + y f x f y - f - x f y f x)
+  y (y f x f y - f - x f y f x + f + y f x f y))
+
+(define-l-system (hilbert-curve :angle (radians 90)) x
+  x (- y f + x f x + f y -)
+  y (+ x f - y f y - f x +))
+
+(define-l-system (quadratic-gosper :angle (radians 90)) (- y f)
+  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 -
+     f x + y f + f x f x + y f - f x y f - y f - f x + f x + y f y f -)
+  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 +
+     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))
+
+(define-l-system (lévy-curve :angle (radians 45)) f
+  f (- f + + f -))
+
+
+;;; http://www.kevs3d.co.uk/dev/lsystems/
+
+(define-l-system (penrose :angle (radians 36))
+    ([ 7 ] + + [ 7 ] + + [ 7 ] + + [ 7 ] + + [ 7 ])
+  6 (8 x + + 9 x - - - - 7 x [ - 8 x - - - - 6 x ] + +)
+  7 (+ 8 x - - 9 x [ - - - 6 x - - 7 x ] +)
+  8 (- 6 x + + 7 x [ + + + 8 x + + 9 x ] -)
+  9 (- - 8 x + + + + 6 x [ + 9 x + + + + 7 x ] - - 7 x)
+  x ())
+
 
 ;;;; Mutation -----------------------------------------------------------------
 (defun insert (val target n)
@@ -219,6 +290,8 @@
           (list val)
           (subseq target n)))
 
+(defun remove-nth (list n)
+  (concatenate 'list (subseq list 0 n) (subseq list (1+ n))))
 
 (defun mutation-transpose (result)
   (rotatef (elt result (rand (length result)))
@@ -226,21 +299,33 @@
   result)
 
 (defun mutation-insert (result)
-  (zapf result (insert (random-elt result #'rand)
+  (zapf result (insert (random-elt (union (remove-duplicates result)
+                                          '(f s - + < > %))
+                                   #'rand)
                        %
                        (rand (length result))))
   result)
 
+(defun mutation-remove (result)
+  (remove-nth result (rand (length result))))
+
 (defun mutate-production (result)
   (if (<= (length result) 2)
     result
-    (ecase (rand 2)
+    (ecase (rand 3)
       (0 (mutation-transpose result))
-      (1 (mutation-insert result)))))
+      (1 (mutation-insert result))
+      (2 (mutation-remove result)))))
+
+(defun mutate-productions% (productions)
+  (iterate (for (letter production . nil) :on productions :by #'cddr)
+           (appending (list letter (mutate-production (copy-list production))))))
 
 (defun mutate-productions (productions)
-  (iterate (for (letter production . nil) :on productions :by #'cddr)
-           (appending (list letter (mutate-production (copy-list production))))))
+  (iterate
+    ;; complete no-op mutations are boring
+    (for new = (mutate-productions% productions))
+    (finding new :such-that (not (equal new productions)))))
 
 (defun maybe-mutate-productions (productions)
   (let ((should-mutate (randomp 0.6 #'rand))
@@ -266,17 +351,30 @@
                 (,*dragon-curve* 7 16)
                 (,*sierpinski-gasket* 4 10)
                 (,*hexagonal-gosper-curve* 3 6)
+                (,*bourke-triangle* 4 8)
+                (,*bourke-pentaplexity* 3 5)
+                (,*bourke-mango* 3 25)
+                (,*square-sierpinski* 3 6)
+                (,*peano-curve* 3 5)
+                (,*hilbert-curve* 5 7)
+                (,*quadratic-gosper* 2 3)
+                (,*lévy-curve* 6 14)
+                (,*penrose* 3 7)
                 (,*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)))
+                (,*tree-f* 4 7 ,(- 1/4tau))
+                (,*saupe-pine* 7 12 ,(- 1/4tau))
+                (,*bourke-bush* 5 7 ,(- 1/4tau))
+                (,*bourke-weed* 5 8 ,(- 1/4tau))
+                )
               #'rand))
 
 
 (defun loom (seed filename filetype width height
-             &key l-system iterations starting-angle)
+             &key l-system iterations starting-angle pure)
   (nest
     (with-seed seed)
     (destructuring-bind
@@ -294,7 +392,9 @@
            (axiom (l-system-axiom l-system))
            (*angle* (l-system-recommended-angle l-system))))
     (multiple-value-bind (productions mutagen)
-        (maybe-mutate-productions (l-system-productions l-system)))
+        (if pure
+          (values (l-system-productions l-system) nil)
+          (maybe-mutate-productions (l-system-productions l-system))))
     (flax.drawing:with-rendering
         (canvas filetype filename width height :background bg :padding 0.05))
     (progn
@@ -306,11 +406,3 @@
               iterations
               mutagen))))
 
-
-
-;; (profile (loom 1963517098 "out" :png 800 800
-;;             ;; :l-system *hexagonal-gosper-curve*
-;;             ;; :iterations 5 
-;;             ;; :starting-angle (- 1/4tau)
-;;             ))
-