--- 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))