The simplest implementation of L-Systems requires term-rewriting, and maybe turtle graphics. We already have arbitrary computation on the execution end, but what if we could add computation on the term rewriting phase? We can get a lot more flexibility without adding an infinite number of rules.
Also the last L-System post has had its code fixed.
We can start by copying the old L-System code over to a new file(Or not, if you don’t care). But we should probably address some issues that were there before. Namely that we can do a lot better for ourselves by declaring accessor functions such as rule-name, rule-replacement and rule-execution to allow us to change the representation if we want.(I learned it from Peter Norvig and he seems to have done alright with it)
(defun define-rule(name execution replacement)
(push `(,name . (,execution . ,replacement)) *rules*))
(defun rule-name(item)
(if (listp item)
(car item)
item))
(defun rule-execution(item)
(cadr (assoc (rule-name item) *rules*)))
(defun rule-replacement(item)
(caddr (assoc (rule-name item) *rules*)))
And we need to change run-replacements and execute-rules to handle argument lists in the input tape.
(defun run-replacements(state)
(loop for i in state
for (_name . (_execution . replacement)) = (or (assoc (rule-name i) *rules* ) i)
do(print i)
when (functionp replacement)
appending (apply replacement (cdr i))
else appending replacement))
(defun execute-rules(state)
(loop for i in state
for (_name . (execution . _replacement)) = (assoc (rule-name i) *rules*)
when(listp i)
do(apply execution (cdr i))
else
do(funcall execution)))
So let’s try a modification of the Barnsley fern rule as listed on wikipedia. In this we add a rule called A that takes two parameters and generates a certain number of tokens based on that input, as well as a call to itself.
(define-rule 'X (lambda()) '(F + #\[ #\[ X #\] - X #\] - F #\[ - F X #\] + X ))
(define-rule 'F (lambda()(forward *forward-amount* t)) '(F F))
(define-rule #\[ (lambda() (push-turtle)) '(#\[))
(define-rule #\] (lambda() (pop-turtle)) '(#\]))
(define-rule '+ (lambda() (turn (deg2rad 25.0))) '(+))
(define-rule '- (lambda() (turn (deg2rad -25.0))) '(-))
(define-rule 'A (lambda(_a _b))
(lambda(x y) (append (make-list x :initial-element 'X) '(- #\[)
`((A ,(max (1- x) 0) ,(max (1- y) 0)))
'(#\])
(make-list y :initial-element 'X))))
And then we run (iterate-n-then-execute 5 '((A 3 3))) to get
The next step to replicating concepts from L-Lisp is the environmentally sensitive L-Systems(necessary to have procedurally generated ivy cover a wall with L-Systems, for example).
Source Listing
(require :img-genner)
(defparameter *image* (img-genner:make-image 640 480))
;; The turtle's stack
(defparameter *stack* nil)
(defparameter *lines* nil)
(defparameter *turtle-x* 320.0)
(defparameter *turtle-y* 0.0)
(defparameter *turtle-angle* (coerce (/ pi 2) 'single-float))
(defun reset-turtle()
(loop for i from 0 below (array-total-size *image*)
do(setf (row-major-aref *image* i) 0))
(setf *stack* nil *lines* nil *turtle-x* 320.0 *turtle-y* 0.0
*turtle-angle* (coerce (/ pi 2) 'single-float)))
(defun deg2rad(n)
(* n (/ (coerce pi 'single-float) 180)))
(defun turn(d)
(incf *turtle-angle* d))
(defun forward(amount line)
(let ((sx *turtle-x*) (sy *turtle-y*))
(setf *turtle-x* (+ *turtle-x* (* amount (cos *turtle-angle*)))
*turtle-y* (+ *turtle-y* (* amount (sin *turtle-angle*))))
(when line
(push (list sx sy *turtle-x* *turtle-y*) *lines*))
)
)
(defun push-turtle()
(push (list *turtle-x* *turtle-y* *turtle-angle*) *stack*))
(defun pop-turtle()
(destructuring-bind (x y a) (pop *stack*)
(setf *turtle-x* x *turtle-y* y *turtle-angle* a)))
(defun stroke-drawing(stroker)
(loop for (x1 y1 x2 y2) in *lines*
do(stroke-line *image* x1 y1 x2 y2 stroker)
))
(defparameter *rules* nil)
(defparameter *forward-amount* 10.0)
(defun define-rule(name execution replacement)
(push `(,name . (,execution . ,replacement)) *rules*))
(defun rule-name(item)
(if (listp item)
(car item)
item))
(defun rule-execution(item)
(cadr (assoc (rule-name item) *rules*)))
(defun rule-replacement(item)
(caddr (assoc (rule-name item) *rules*)))
(defun run-replacements(state)
(loop for i in state
for (_name . (_execution . replacement)) = (or (assoc (rule-name i) *rules* ) i)
when (functionp replacement)
appending (apply replacement (cdr i))
else appending replacement))
(defun execute-rules(state)
(loop for i in state
for (_name . (execution . _replacement)) = (assoc (rule-name i) *rules*)
when(listp i)
do(apply execution (cdr i))
else
do(funcall execution)))
(define-rule 'X (lambda()) '(F + #\[ #\[ X #\] - X #\] - F #\[ - F X #\] + X ))
(define-rule 'F (lambda()(forward *forward-amount* t)) '(F F))
(define-rule #\[ (lambda() (push-turtle)) '(#\[))
(define-rule #\] (lambda() (pop-turtle)) '(#\]))
(define-rule '+ (lambda() (turn (deg2rad 25.0))) '(+))
(define-rule '- (lambda() (turn (deg2rad -25.0))) '(-))
(define-rule 'A (lambda(_a _b))
(lambda(x y) (append (make-list x :initial-element 'X) '(- #\[)
`((A ,(max (1- x) 0) ,(max (1- y) 0)))
'(#\])
(make-list y :initial-element 'X))))
(defparameter ffmpeg (uiop:launch-program "ffmpeg -r 20 -f png_pipe -i - -y -vf \"minterpolate='me=umh:search_param=32:fps=30'\" -b:v 3M -preset placebo L-system.webm" :input :stream))
(defun finish()
(uiop:close-streams ffmpeg)
(uiop:wait-process ffmpeg))
(defun iterate-n-then-execute(n tape)
(loop repeat n
with stroker = (img-genner:static-color-stroker (img-genner:rgb 255 0 0))
for state = tape then (run-replacements state)
do(reset-turtle)
finally(progn
(execute-rules state)
(loop for (sx sy ex ey) in (reverse *lines*)
do(img-genner:stroke-line *image* sx sy ex ey stroker)
do(img-genner:stroke-line *image* (1+ sx) sy (1+ ex) ey stroker)
do(img-genner:save-image *image* (uiop:process-info-input ffmpeg))))))
Leave a Reply
Only people in my network can comment.