1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
|
;; This an adaptation to cl-pdf of the postscript Lindenmayer System generator
;; code posted by Frank Buss in comp.lang.lisp.
;;
;; The original post is here:
;; http://groups.google.de/group/comp.lang.lisp/browse_thread/thread/05631fa93379bca8/248b67466ca2aa7d
;;
;; Frank Buss wrote:
;;
;; I've implemented a Lindenmayer System generator, with postscript output.
;; A L-System is a fractal, which can be used to describe plants. The
;; program implements the commands described here:
;;
;; http://www.biologie.uni-hamburg.de/b-online/e28_3/lsys.html
;;
;; Some example outputs (converted to PDF, because it is shorter)
;;
;; http://www.frank-buss.de/tmp/bush.pdf
;; http://www.frank-buss.de/tmp/snow.pdf
;; http://www.frank-buss.de/tmp/dragon.pdf
;;
;; The code is below. But it is too slow. I think it is the function
;; "starts-with" and the string handling, perhaps it could be faster with
;; lists, because then the substitute step could be implemented faster.
;;
;; How can I profile the program? I know the "time"-macro, but would be
;; nice to have an utility, which writes for every function or every line
;; the time after program termination.
;;
;; And it would be nice to test new rules interactive, without the need to
;; produce a postscript file, first. Is this possible with LTK or some other
;; GUI interface?
;;
;; Another idea: Enhancing it to 3D output and color, like this program:
;; http://home.wanadoo.nl/laurens.lapre/lparser.htm
(defun starts-with (string search start)
"Returns true, if the string 'search' is at 'start' in 'string'."
(let ((string-len (length string))
(search-len (length search)))
(if (> (+ start search-len) string-len)
nil
(equal (subseq string start (+ start search-len)) search))))
(defun search-longest (rules string start)
"Returns the successor and predecessor length, if a predecessor
is found in 'string' at 'start'. Returns the longest match."
(let ((found-successor nil)
(found-predecessor-length 0))
(loop for (predecessor . successor) in rules do
(when (starts-with string predecessor start)
(let ((predecessor-length (length predecessor)))
(when (>= predecessor-length found-predecessor-length)
(setq found-predecessor-length predecessor-length)
(setq found-successor successor)))))
(values found-successor found-predecessor-length)))
(defun apply-rules (rules axiom)
"Returns the next iteration, starting with the string in 'axiom'."
(let ((result ""))
(loop for i from 0 to (1- (length axiom)) do
(multiple-value-bind (successor predecessor-length)
(search-longest rules axiom i)
(if successor
(progn
(setq result (concatenate 'string result successor))
(setq i (1- (+ i predecessor-length))))
(progn
(setq result (concatenate 'string result (subseq axiom i (1+ i))))))))
result))
(defun l-system (rules axiom depth)
"Returns 'depth' iterations, starting with 'axiom' and applying the 'rules'."
(let ((result axiom))
(loop repeat depth do
(setq result (apply-rules rules result)))
result))
(defun forward (point len angle)
"Returns a new point by starting from 'point' and adding the polar coordinates 'len' and 'angles'."
(let ((x (car point))
(y (cdr point))
(rad (* (/ pi 180.0) angle)))
(cons (+ x (* (sin rad) len)) (+ y (* (cos rad) len)))))
(defun do-l-system (commands len angle fun)
"Calls 'fun x0 y0 x1 y1' for every command in the 'commands' string."
(let ((point-stack '())
(angle-stack '())
(current-point '(0e0 . 0e0))
(current-angle 0e0))
(loop for i from 0 to (1- (length commands)) do
(let ((command (elt commands i)))
(cond ((eq command #\f)
(setq current-point (forward current-point len current-angle)))
((eq command #\F)
(let ((next-point (forward current-point len current-angle)))
(funcall fun (car current-point) (cdr current-point) (car next-point) (cdr next-point))
(setq current-point next-point)))
((eq command #\+)
(setq current-angle (+ current-angle angle)))
((eq command #\-)
(setq current-angle (- current-angle angle)))
((eq command #\[)
(push current-point point-stack)
(push current-angle angle-stack))
((eq command #\])
(setq current-point (pop point-stack))
(setq current-angle (pop angle-stack))))))))
(defun pdf-l-system (rules axiom length angle depth &key (x0 0)(y0 0) (file #P"/tmp/l-system.pdf"))
"Calculates and prints a Lindenmayer System as pdf."
(pdf:with-document ()
(pdf:with-page ()
(pdf:translate (+ x0 287) (+ y0 400))
(pdf:set-line-width 0)
(do-l-system (l-system rules axiom depth) length angle
(lambda (x0 y0 x1 y1)
(pdf:move-to x0 y0)
(pdf:line-to x1 y1)))
(pdf:stroke))
(pdf:write-document file)))
;; this one takes longer but adjusts the scaling and centering so that it fits on the page
(defun pdf-l-system-centered (rules axiom angle depth &key (file #P"/tmp/l-system.pdf"))
"Calculates and prints a Lindenmayer System as pdf."
(pdf:with-document ()
(pdf:with-page ()
(pdf:set-line-width 0)
(let ((commands (l-system rules axiom depth))
(min-x 1e30)
(min-y 1e30)
(max-x -1e30)
(max-y -1e30))
(do-l-system commands 1 angle
(lambda (x0 y0 x1 y1)
(when (< x0 min-x) (setq min-x x0))
(when (< y0 min-y) (setq min-y y0))
(when (< x1 min-x) (setq min-x x1))
(when (< y1 min-y) (setq min-y y1))
(when (> x0 max-x) (setq max-x x0))
(when (> y0 max-y) (setq max-y y0))
(when (> x1 max-x) (setq max-x x1))
(when (> y1 max-y) (setq max-y y1))))
(let* ((length (/ 500.0 (max (- max-y min-y) (- max-x min-x))))
(dx (* 0.5 (- 595 (* (+ max-x min-x) length))))
(dy (* 0.5 (- 841 (* (+ max-y min-y) length)))))
(pdf:translate dx dy)
(do-l-system (l-system rules axiom depth) length angle
(lambda (x0 y0 x1 y1)
(pdf:move-to x0 y0)
(pdf:line-to x1 y1)))
(pdf:stroke))))
(pdf:write-document file)))
;;; dragon, needs some minutes to calculate with depth 16
; (pdf-l-system-centered '(("FL"."FL+FR+") ("FR"."-FL-FR")) "FL" 90 16)
;;; snowflake
; (pdf-l-system-centered '(("F"."F+F--F+F")) "F--F--F" 60 7)
;;; bush
; (pdf-l-system-centered '(("F"."FF-[-F+F+F]+[+F-F-F]")) "+F" 23 5)
|
