Improving On L-Systems

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