### Author Topic: Draw Fractal tree and SpiroGraph flower  (Read 28379 times)

0 Members and 1 Guest are viewing this topic.

#### qjchen

• Bull Frog
• Posts: 285
• Best wishes to all
##### Draw Fractal tree and SpiroGraph flower
« on: July 23, 2006, 12:39:11 AM »
A funny draw fractal tree code, there are 6 pattern already defined inside, you
can change as you like:)
Code: [Select]
;;; ========================================================================
;;; Some of the following code are writen by CHEN QING JUN                 ;
;;; Civil engineering Department, South China University of Technology     ;
;;; Purpose: To draw tree according to the fractal theory, just for fun    ;
;;; The command name :tree                                                 ;
;;; The platform: Acad14 and after                                         ;
;;; Version: 0.1                                                           ;
;;; Limitation: no random pattern is concerned                             ;
;;; Method: use the LS gramma to define the tree                           ;
;;;     the pattern is the tree grow basic define pattern,you can change   ;
;;;         as you like                                                    ;
;;;     "F" means grow with defined length,(in code len)                   ;
;;;     "+" means it turn counter-clockwise angle (in code:ang)            ;
;;;     "-" means it turn direction (clockwise angle)                      ;
;;;     "[" and "]" is corresponding, which means the branch will go back  ;
;;;               to the the start point.                                  ;
;;;     substitute the "4" (repeat 4) to 5 or 6 tree grow more, and        ;
;;;                the speed slow down also                                ;
;;;     then the F[-F]F[+F]F mean:                                         ;
;;;                                                                        ;
;;;                                                                        ;
;;;                       \   |                                            ;
;;;                        \  |                                            ;
;;;                         \ |                                            ;
;;;                          \|                                            ;
;;;                           |   /                                        ;
;;;                           |  /                                         ;
;;;                           | /                                          ;
;;;                           |/                                           ;
;;;                           |                                            ;
;;;                           |                                            ;
;;;                           |                                            ;
;;;                           |                                            ;
;;; 2006.07.23                                                             ;
;;; The codes idea camed from The book wrote by Sun Bo Wen                 ;
;;; <Fractal algorithm and Realization in Visual C++>                      ;
;;; ========================================================================
(defun c:tree (/ os ang len ori oriang pattern finalpattern)
(setq os (getvar "osmode"))
(setvar "osmode" 0)
(setq ang (dtor 25.0)
len 100
ori (getpoint "\n The start point")
oriang (dtor 90.0)
pattern (getpattern)
finalpattern "F"
)
(repeat 4
(setq finalpattern (my-subst pattern "F" finalpattern))
)
(drawfinalpattern finalpattern ori oriang)
(COMMAND "ZOOM" "E" "zoom" ".9x")
(setvar "osmode" os)
)
(defun dtor (x)
(* (/ x 180) pi)
)
;;;get tree pattern;;
(defun getpattern (/ kword pattern)
(initget "1 2 3 4 5 6")
(setq kword (getkword "\n please select the tree type: 1/2/3/4/5/6:"))
(cond
((= kword "1")
(setq pattern "F[+F]F[-F+F]")
)
((= kword "2")
(setq pattern "F[-F]F[+F]F")
)
((= kword "3")
(setq pattern "FF+[+F-F-F]-[-F+F+F]")
)
((= kword "4")
(setq pattern "F[-F][+F]F")
)
((= kword "5")
(setq pattern "F[+F]F[-F]+F")
)
((= kword "6")
(setq pattern "F[-F][+F][--F]F[++F]F")
)
)
pattern
)
;;;;draw finalpattern
(defun drawfinalpattern (finalpattern ori oriang / i slen x ori1 templst)
(setq i 1
slen (strlen finalpattern)
)
(repeat slen
(setq x (substr finalpattern i 1))
(cond
((= x "F")
(setq ori1 (polar ori oriang len))
(make_line ori ori1)
(setq ori ori1)
)
((= x "[")
(setq templst (append
templst
(list (list oriang ori))
)
)
)
((= x "]")
(setq oriang (car (last templst)))
(setq templst (1ton_1 templst))
)
((= x "+")
(setq oriang (+ oriang ang))
)
((= x "-")
(setq oriang (- oriang ang))
)
)
(setq i (1+ i))
)
)
;;;to substitute every one item(strlen=1) to new item
(defun my-subst (new old str / slen i res)
(setq i 1
res ""
)
(if (setq slen (strlen str))
(repeat slen
(setq stri (substr str i 1)
i (1+ i)
)
(if (= old stri)
(setq res (strcat res new))
(setq res (strcat res stri))
)
)
)
res
)
;;xoutside function to entmake line
(defun make_Line (l10 l11)
(ENTMAKE (LIST (CONS 0 "LINE") (cons 62 80) (cons 10 l10) (cons 11 l11)))
)
;; get the 1 to (n-1) element of a list
(defun 1ton_1 (lst)
(reverse (cdr (reverse lst)))
)
(princ "\n")
(prompt "\n use LS gramma to draw tree, command:treeQJCHEN \n")
« Last Edit: October 22, 2006, 08:31:39 PM by yuanqiu »
http://qjchen.mjtd.com
My blog http://chenqj.blogspot.com (Chinese, can be translate into English)

#### It's Alive!

• Needs a day job
• Posts: 7054
• AKA Daniel
##### Re: use LS gramma to Draw Fractal tree
« Reply #1 on: July 23, 2006, 12:50:38 AM »
hung piao liang

Dan

#### qjchen

• Bull Frog
• Posts: 285
• Best wishes to all
##### Re: use LS gramma to Draw Fractal tree
« Reply #2 on: July 23, 2006, 06:15:41 AM »
thank you:),Dan

after work this afternoon, get the multi-param LS gramma to draw the other type of trees
Code: [Select]
;;; ========================================================================
;;; Some of the following code are writen by CHEN QING JUN                 ;
;;; Civil engineering Department, South China University of Technology     ;
;;; Purpose: To draw tree according to the fractal theory, just for fun    ;
;;; The command name :tree                                                 ;
;;; The platform: Acad14 and after                                         ;
;;; Version: 0.2                                                           ;
;;; Limitation: no random pattern is concerned                             ;
;;; Method: use the LS gramma to define the tree (multi-param)             ;
;;;      omega:the original configuration                                  ;
;;;      ang  :the original angle                                          ;
;;;      P1a and P1, P2a and P2,... five pair rule, P1a->P1, and so on     ;
;;;      It is hard to image this gramma, but maybe something in it        ;
;;; 2006.07.23                                                             ;
;;; The codes idea camed from The book wrote by Sun Bo Wen                 ;
;;; <Fractal algorithm and Realization in Visual C++>                      ;
;;; ========================================================================
(defun c:tree (/ os plst ang omega P1a P1 P2a P2 P3a P3 P4a P4 P5a P5 color
len ori oriang
)
(setq os (getvar "osmode"))
(setvar "osmode" 0)
(setq plst (getpattern)
ang (dtor (nth 0 plst))
omega (nth 1 plst)
P1a (nth 2 plst)
P1 (nth 3 plst)
P2a (nth 4 plst)
P2 (nth 5 plst)
P3a (nth 6 plst)
P3 (nth 7 plst)
P4a (nth 8 plst)
P4 (nth 9 plst)
P5a (nth 10 plst)
P5 (nth 11 plst)
len 100
ori (getpoint "\n The start point")
oriang (dtor 90.0)
color 84
)
(repeat (nth 12 plst)
(if P1a
(setq omega (my-subst P1 P1A omega))
)
(if P2a
(setq omega (my-subst P2 P2A omega))
)
(if P3a
(setq omega (my-subst P3 P3A omega))
)
(if P4a
(setq omega (my-subst P4 P4A omega))
)
(if P5a
(setq omega (my-subst P5 P5A omega))
)
)
(drawomega omega ori oriang)
(COMMAND "ZOOM" "E" "zoom" ".9x")
(setvar "osmode" os)
)
(defun dtor (x)
(* (/ x 180) pi)
)
;;;get tree pattern;;
(defun getpattern (/ kword pattern pattern1)
(initget "1 2 3 4 5 6 7")
(setq kword (getkword "\n please select the tree type: 1/2/3/4/5/6/7:"))
(cond
((= kword "1")
(setq res (list 20.0 "X" "F" "FF" "X" "F[+X]F[-X]+X" nil nil nil nil
nil nil 6
)
)
)
((= kword "2")
(setq res (list 30.0 "Z" "X" "X[-FFF][+FFF]FX" "Z" "ZFX[+Z][-Z]" nil
nil nil nil nil nil 6
)
)
)
((= kword "3")
(setq res (list 22.5 "F" "F" "FF-[XY]+[XY]" "X" "+FY" "Y" "-FX" nil
nil nil nil 4
)
)
)
((= kword "4")
(setq res (list 5.0 "G" "G" "GFX[+++++GFG][-----GFG]" "X" "F-XF" nil
nil nil nil nil nil 4
)
)
)
((= kword "5")
(setq res (list 25.7 "X" "F" "FF" "X" "F[+X][-X]FX" nil nil nil nil
nil nil 7
)
)
)
((= kword "6")
(setq res (list 45.0 "FX" "F" "" "X" "-FX++FX-" nil nil nil nil nil
nil 10
)
)
)
((= kword "7")
(setq res (list 30.0 "G" "G" "[+FGF][-FGF]XG" "X" "XFX" nil nil nil
nil nil nil 6
)
)
)
)
res
)
;;;;draw finalomega
(defun drawomega (omega ori oriang / i slen x ori1 templst)
(setq i 1
slen (strlen omega)
)
(repeat slen
(setq x (substr omega i 1))
(cond
((= x "F")
(setq ori1 (polar ori oriang len))
(make_line ori ori1 color)
(setq ori ori1)
)
((= x "[")
(setq templst (append
templst
(list (list oriang ori))
)
color 80
)
)
((= x "]")
(setq oriang (car (last templst))
templst (1ton_1 templst)
color 84
)
)
((= x "+")
(setq oriang (+ oriang ang))
)
((= x "-")
(setq oriang (- oriang ang))
)
)
(setq i (1+ i))
)
)
;;;to substitute every one item(strlen=1) to new item
(defun my-subst (new old str / slen i res)
(setq i 1
res ""
)
(if (setq slen (strlen str))
(repeat slen
(setq stri (substr str i 1)
i (1+ i)
)
(if (= old stri)
(setq res (strcat res new))
(setq res (strcat res stri))
)
)
)
res
)
;;xoutside function to entmake line
(defun make_Line (l10 l11 color)
(ENTMAKE (LIST (CONS 0 "LINE") (cons 62 color) (cons 10 l10)
(cons 11 l11)
)
)
)
;; get the 1 to (n-1) element of a list
(defun 1ton_1 (lst)
(reverse (cdr (reverse lst)))
)
(princ "\n")
(prompt "\n use LS gramma to draw tree, command:treeQJCHEN \n")

http://qjchen.mjtd.com
My blog http://chenqj.blogspot.com (Chinese, can be translate into English)

#### M-dub

• Guest
##### Re: use LS gramma to Draw Fractal tree
« Reply #3 on: July 23, 2006, 09:20:10 AM »
:kewl:

I'm going to have to try that!

#### Bob Wahr

• Guest
##### Re: use LS gramma to Draw Fractal tree
« Reply #4 on: July 23, 2006, 09:43:53 AM »
Wow!  That is very nice.

#### Sdoman

• Guest
##### Re: use LS gramma to Draw Fractal tree
« Reply #5 on: July 23, 2006, 07:32:27 PM »
Super Cool! Interesting project too.

#### MP

• Seagull
• Posts: 17750
• Have thousands of dwgs to process? Contact me.
##### Re: use LS gramma to Draw Fractal tree
« Reply #6 on: July 23, 2006, 07:52:25 PM »
Too cool (fast too)!
Engineering Technologist • CAD Automation Practitioner
Automation ▸ Design ▸ Drafting ▸ Document Control ▸ Client

#### qjchen

• Bull Frog
• Posts: 285
• Best wishes to all
##### Re: use LS gramma to Draw Fractal tree
« Reply #7 on: July 24, 2006, 05:33:17 AM »
Thank you all:)

The next code is generate according to the IFS theory, they are draw by point
but it is not so beautiful as the pixel software, I am not sure how to improve the
effect, solid seems too slow.

the rountine use 20000 point to draw a picture, you can increase it to get better
effect, but more slowly.
I use entmake to draw point, but if you change to the command method, you will find

the process is more funny,

I use Mr Smadsen's random rountine to generate the random number, thank him:)
why wont Lisp afford us a random function, it look strange.

The scale and the color of the following picture is not just as same with the program

Code: [Select]
;;; ========================================================================
;;; Some of the following code are writen by CHEN QING JUN                 ;
;;; Civil engineering Department, South China University of Technology     ;
;;; Purpose: To draw IFS fractal pattern, just for fun                     ;
;;; The command name :tree                                                 ;
;;; The platform: Acad14 and after                                         ;
;;; Version: 0.1                                                           ;
;;; Method: use the IFS method to construt the drawing                     ;
;;;         in the pattern define,just like the first pattern:             ;
;;;         (list (list 0.5 0.0 0.0 0.5 0.0 0.0 0.333)                     ;
;;;               (list 0.5 0.0 0.0 0.5 0.5 0.0 0.333)                     ;
;;;           (list 0.5 0.0 0.0 0.5 0.25 0.5 0.334))                   ;
;;;         there are 3 elements, (it can be different, 2,4,5,6 or bigger  ;
;;;         at each end ,0.333 0.333 0.334 represent the probability,      ;
;;;              then I construct a rndlst (0.333 0.666 1)                 ;
;;;         while the other 6 parameters are for a b c d e f               ;
;;;         which is for transformation:                                   ;
;;;         x'=ax+by+e                                                     ;
;;;         y'=cx+dy+f                                                     ;
;;;         so generate a random number (here I use Smadsen's function)    ;
;;;         judge this num in which district of the rndlst                 ;
;;;         then judge which a b c d e f should be used.                   ;
;;;         according to new x, draw point, then repeat                    ;
;;; 2006.07.24                                                             ;
;;; The codes idea camed from The book wrote by Sun Bo Wen                 ;
;;; <Fractal algorithm and Realization in Visual C++>                      ;
;;; ========================================================================
(defun c:tree (/ os plst iteration ori orix oriy color rndlst position
neworix neworiy
)
(setq os (getvar "osmode"))
(setq cmd (getvar "cmdecho"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
(setq plst (getpattern)
iteration 20000
ori (getpoint "\n The start point")
x (car ori)
orix 0.0
oriy 0.0
color 80

)
;(if (= k nil) (setq k 10) (setq k (+ k 10)) )
(setq rndlst (getrndlst plst))
(repeat iteration
(setq a (rng))
(setq position (my-position a rndlst))
(setq newx (+ (* orix (nth 0 (nth position plst)))
(* oriy (nth 1 (nth position plst)))
(nth 4 (nth position plst))
)
)
(setq newy (+ (* orix (nth 2 (nth position plst)))
(* oriy (nth 3 (nth position plst)))
(nth 5 (nth position plst))
)
)
(setq orix newx
oriy newy
)
;(setq color (+ (* (fix (* (+ 1.4 oriy) 3)) 10)) 20)
;(setq color (+ (* position 2) 100))
(make_point (list (+ orix x) (+ oriy y) 0.0) color)
;(command "color" k)
;(command "point" (list (+ orix x) (+ oriy y) 0.0))
)
(COMMAND "ZOOM" "E" "zoom" ".9x")
(setvar "osmode" os)
(setvar "cmdecho" cmd)
)
;;;get tree pattern;;
(defun getpattern (/ kword pattern pattern1)
(initget "1 2 3 4 5 6 7 8 9 10")
(setq kword (getkword "\n please select the tree type: 1/2/3/4/5/6/7/8/9/10:"))
(cond
((= kword "1")
(setq res (list (list 0.5 0.0 0.0 0.5 0.0 0.0 0.333)
(list 0.5 0.0 0.0 0.5 0.5 0.0 0.333)
(list 0.5 0.0 0.0 0.5 0.25 0.5 0.334)
)
)
)
((= kword "2")
(setq res (list (list 0.5 -0.5 0.5 0.5 0.0 0.0 0.5)
(list 0.5 0.5 -0.5 0.5 0.5 0.5 0.5)
)
)
)
((= kword "3")
(setq res (list (list -0.04 0 -0.19 -0.47 -0.12 0.3 0.25)
(list 0.65 0.0 0.0 0.56 0.06 1.56 0.25)
(list 0.41 0.46 -0.39 0.61 0.46 0.4 0.25)
(list 0.52 -0.35 0.25 0.74 -0.48 0.38 0.25)
)
)
)
((= kword "4")
(setq res (list (list 0.6 0 0 0.6 0.18 0.36 0.25)
(list 0.6 0 0 0.6 0.18 0.120 0.25)
(list 0.4 0.3 -0.3 0.4 0.27 0.36 0.25)
(list 0.4 -0.3 0.3 0.4 0.27 0.09 0.25)
)
)
)
((= kword "5")
(setq res (list
(list 0.787879 -0.424242 0.242424 0.859848 1.758647 1.408065 0.9)
(list -0.121212 0.257576 0.05303 0.05303 -6.721654 1.377236 0.05)
(list 0.181818 -0.136364 0.090909 0.181818 6.086107 1.568035 0.05)

)
)
)
((= kword "6")
(setq res (list
(list 0.745455 -0.45901 0.406061 0.887121 1.460279 0.691072 0.912675)
(list -0.424242 -0.065152 -0.175758 -0.218182 3.809567 6.741476 0.087325)
)
)
)
((= kword "7")
(setq res (list (list 0 0 0 0.25 0 -0.14 0.02)
(list 0.85 0.02 -0.02 0.83 0 1 0.84)
(list 0.09 -0.28 0.3 0.11 0 0.6 0.07)
(list -0.09 0.25 0.3 0.09 0 0.7 0.07)
)
)
)
((= kword "8")
(setq res (list (list 0.05 0 0 0.6 0 0 0.1)
(list 0.05 0 0 -0.5 0 1.0 0.1)
(list 0.46 0.32 -0.386 0.383 0 0.6 0.2)
(list 0.47 -0.154 0.171 0.423 0 1.0 0.2)
(list 0.43 0.275 -0.26 0.476 0 1.0 0.2)
(list 0.421 -0.357 0.354 0.307 0 0.7 0.2)
)
)
)
((= kword "9")
(setq res (list (list 0 0 0 0.16 0 0 0.01)
(list 0.85 0.04 -0.04 0.85 0 1.6 0.85)
(list 0.2 -0.26 0.23 0.22 0 1.6 0.07)
(list -0.15 0.28 0.26 0.24 0 0.44 0.07)
)
)
)
((= kword "10")
(setq res (list (list 0.8 0.0 0.0 -0.8 0.0 0.0 0.5)
(list 0.4 -0.2 0.2 0.4 1.1 0.0 0.5)
)
)
)
)
res
)
;;xoutside function to entmake line
(defun make_point (l10 color)
(ENTMAKE (LIST (CONS 0 "POINT") (cons 62 color) (cons 10 l10)))
)
;; random number
(defun rng (/ modulus multiplier increment random)
(if (not seed)
(setq seed (getvar "DATE"))
)
(setq modulus 4294967296.0
multiplier 1664525
increment 1
seed (rem (+ (* multiplier seed) increment) modulus)
random (/ seed modulus)
)
)
;; judge the position
(defun my-position (x lst / i lenlst x res k)
(setq i 0
k 0
lenlst (length lst)
)
(repeat lenlst
(if (and
(= k 0)
(<= x (nth i lst))
)
(setq res i
k 1
)
)
(setq i (1+ i))
)
res
)
;; get the accumulate list
(defun getrndlst (lst / rndlst a x rndlst1)
(foreach x plst
(setq rndlst (append
rndlst
(list (last x))
)
)
)
(setq a 0)
(foreach x rndlst
(setq a (+ a x))
(setq rndlst1 (append
rndlst1
(list a)
)
)
)
rndlst1
)
(princ "\n")
(prompt "\n use LS gramma to draw tree, command:treeQJCHEN \n")

« Last Edit: July 24, 2006, 05:34:37 AM by yuanqiu »
http://qjchen.mjtd.com
My blog http://chenqj.blogspot.com (Chinese, can be translate into English)

#### CAB

• Global Moderator
• Seagull
• Posts: 10395
##### Re: use LS gramma to Draw Fractal tree
« Reply #8 on: July 24, 2006, 08:38:21 AM »
Very interesting my friend.

Thanks for sharing.
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970

#### StoneDWG

• Guest
##### Re: use LS gramma to Draw Fractal tree
« Reply #9 on: July 26, 2006, 12:02:31 AM »
fractal Art
it's funny

Thanks for sharing

Code: [Select]

;;--------------------------------------------------------------------------;
;;                             FRACTAL                                      ;
;;--------------------------------------------------------------------------;
;; Function Fractal by others, wish I could remember who did it to give
;;      them the credit.

(defun Fractal (P1 P2 / P3 A DISTS)
(setq DISTS (distance P1 P2)
A     (angle P1 P2))
(command "._ucsicon" "OFF"
"._zoom" "W" "-1.03,-1.1875" "1.03,2.15")
(if (< DISTS EPSILON)
(command "._line" P1 P2 nil)
(progn
(setq P3 (polar P1 (angle P1 P2) (* DISTS 0.5)))
(command "._line" P1 P3 nil)
(Fractal P3 (polar P3 (+ (angle P1 P2) AFRACT) (* DISTS 0.5 )))
(Fractal P3 (polar P3 (- (angle P1 P2) AFRACT) (* DISTS 0.5 )))
(Fractal P1 P3)
)
)
)

(setvar "Cmdecho" 0)
(setvar "Blipmode" 0)

;;--------------------------------------------------------------------------;
;;                             DrawTree                                     ;
;;--------------------------------------------------------------------------;
(defun DrawTree ()
(command "._color" "3")
(Fractal '(0 2) '(0 0))
(command "._line" '(0 0) '(0 1) nil
"._color" "bylayer")
)

« Last Edit: July 26, 2006, 12:17:07 AM by StoneDWG »

#### qjchen

• Bull Frog
• Posts: 285
• Best wishes to all
##### Re: use LS gramma to Draw Fractal tree
« Reply #10 on: July 26, 2006, 04:37:07 AM »
Thank you, CAB, I have learned a lot from you~:)
Thank you, Stonedwg, my friend. it seems that "AFRACT" is not defined, it cant be run.

Now I use the Julia algorithm in Fractal Theory to draw the pattern.
The effect is as the picture.

But Now I find I get trouble in it.
First, It seems that the calculation effect of the Lisp is not so good, compare to C or Fortran, it seems slow, is it the self disadvantige of Lisp, can it be improved?
Second, I use (entmake_solid) to draw a square solid, it seems that I use the bitmap in vector software, somewhat strange, but when I use the point to draw, it is not so good.
Nevertheless, I just feel release one thing, when start a work, if couldnt finish, it like burden. No matter it is beautiful or not, it can draw at least.

The algorithm is rather simple, but I learn to use true color in Acad again, thanks menzi for his getRGB function, thanks.

Can I ask a question, could it possible to read BMP picture's information and use cad point to draw the picture  in ACAD with Lisp?
I search, get find Reini Urban's standard library can do the binary file operation, but it is in arx or fas, I am not sure whether Lisp can do it, thank you~

Code: [Select]
;;; Note: the program will use lot of cpu times and time                   ;
;;; In my own P4 2.8C computer, it need about 130 seconds to draw a pattern;
;;; Be careful to use                                                      ;
;;; It is suggested that the first color would be a light color, such as   ;
;;; (151,148,244), while the second color would be a dark color, such as   ;
;;; (45,27,34) or so on                                                    ;
;;; ========================================================================
;;; Some of the following code are writen by CHEN QING JUN                 ;
;;; Civil engineering Department, South China University of Technology     ;
;;; Purpose: To draw Julia Fractal pattern in ACAD, just for fun           ;
;;; Note : k:the iteration times to see whether the r escape               ;
;;;        mx,my: the picture's width and height                           ;
;;;        xs,xl,ys,yl: the complex number C's min and max value           ;
;;;        p,q:The complex number C's initial value                        ;
;;; 2006.07.24                                                             ;
;;; The codes idea camed from The book wrote by Sun Bo Wen                 ;
;;; <Fractal algorithm and Realization in Visual C++>                      ;
;;; ========================================================================
(defun c:tree (/ hsllst hsl1 hsl2 os cmd plst k m mx my p q xs xl ys yl
color xb yb i j x0 y0 l index xk yk r tempa
)
(startTimer)
(setq hsllst (gethsl))
(setq hsl1 (car hsllst))
(setq os (getvar "osmode"))
(setq cmd (getvar "cmdecho"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
(setq plst (getpattern)
k 20
m 200
mx 400
my 400
xs (nth 0 plst)
xl (nth 1 plst)
ys (nth 2 plst)
yl (nth 3 plst)
p (nth 4 plst)
q (nth 5 plst)
order (nth 6 plst)
color 16
xb (/ (- xl xs) mx)
yb (/ (- yl ys) my)
i 0
)

(repeat mx
(setq j 0)
(repeat my
(setq x0 (+ xs (* i xb))
y0 (+ ys (* j yb))
l 0
index 0
)
(while (and
(= index 0)
(<= l k)
)

(setq xk (- (+ (* x0 x0) p) (* y0 y0)))
(setq yk (+ q (* 2 x0 y0)))
(setq r (+ (* xk xk) (* yk yk)))
(setq x0 xk
y0 yk
)
(cond
((> r m)
(setq index 1)
(make_solid (list i j 0.0) 0.5 color)
;(make_point (list i j 0.0) 5)
(setq interhsl (list (interpolate (nth 0 hsl1) (nth 0 hsl2) l k)
(interpolate (nth 1 hsl1) (nth 1 hsl2) l k)
(interpolate (nth 2 hsl1) (nth 2 hsl2) l k)
)
)

(myputcolor interhsl)
)
((= l k)
(setq index 1)
(make_solid (list i j 0.0) 0.5 color)

;(make_point (list i j 0.0) 5)
(setq tempa (* (/ r m) 100))
;     (setq interhsl (list (* tempa 128)
;   (+ (* tempb 10) 90)
;   57
;     )
;     )
(setq interhsl (list (* tempa 360)
90
57
)
)
(myputcolor interhsl)
)
)
(setq l (1+ l))
)
(setq j (1+ j))
)
(setq i (1+ i))
)
(COMMAND "ZOOM" "E" "zoom" ".9x")
(setvar "osmode" os)
(setvar "cmdecho" cmd)
(endTimer (vl-symbol-name 'c:tree))
)
;;; ========================================================================
;;; Belong to this program, to get the pattern                             ;
;;; ========================================================================
(defun getpattern (/ kword pattern pattern1)
(initget "1 2 3 4")
(setq kword (getkword "\n please select the tree type: 1/2/3/4:"))
(cond
((= kword "1")
(setq res (list -1.5 1.5 -1.5 1.5 -0.46 0.57 2))
)
((= kword "2")
(setq res (list -1.5 1.5 -1.5 1.5 -0.199 -0.66 2))
)
((= kword "3")
(setq res (list -1.5 1.5 -1.5 1.5 -0.615 -0.43 2))
)
((= kword "4")
(setq res (list -1.5 1.5 -1.5 1.5 -0.77 0.08 2))
)
)
res
)
;;; ========================================================================
;;; Belong to this program, to get hsl color                               ;
;;; ========================================================================
(defun gethsl(/ color1 rcolor1 rgb1 hsl1 color2 rcolor2 rgb2 hsl2)
(setq color1 (acad_truecolordlg (cons 420 2594)))
(setq rcolor1 (cdr (assoc 420 (cdr color1))))
(setq rgb1 (megetrgb rcolor1))
(setq hsl1 (MeCalcHslModel rgb1))
(setq color2 (acad_truecolordlg (cons 420 12594)))
(setq rcolor2 (cdr (assoc 420 (cdr color2))))
(setq rgb2 (megetrgb rcolor2))
(setq hsl2 (MeCalcHslModel rgb2))
(list hsl1 hsl2)
)
;;; ========================================================================
;;; Belong to this program, to get accmcolor                               ;
;;; ========================================================================
)
)
(vla-put-colorMethod acCmColor acColorMethodByRGB)
(vla-put-colorIndex acCmColor 7)
(vla-put-entityColor acCmColor -1073741824)
)
;;; ========================================================================
;;; Function MeGetRGB                                                      ;
;;; Get the RGB value of Acad                                              ;
;;; Copyright:2000 MENZI ENGINEERING GmbH, Switzerland                     ;
;;; ========================================================================
(defun MeGetRGB (Val)
(list (lsh Val -16) (lsh (lsh Val 16) -24) (lsh (lsh Val 24) -24))
)
(defun MeCalcHslModel (Rgb / ColDta ColHue ColLum ColSat MaxVal MinVal
TmpRgb
)
(setq TmpRgb (mapcar
'/
Rgb
'(255.0 255.0 255.0)
)
MaxVal (apply
'max
TmpRgb
)
MinVal (apply
'min
TmpRgb
)
ColDta (- MaxVal MinVal)
ColLum (/ (+ MaxVal MinVal) 2.0)
ColSat 0.0
ColHue 0.0
)
(if (/= MaxVal MinVal)
(setq ColSat (if (<= ColLum 0.5)
(/ ColDta (+ MaxVal MinVal))
(/ ColDta (- 2.0 MaxVal MinVal))
)
ColHue (cond
((= (car TmpRgb) MaxVal)
)
(+ 2.0 (/ (- (caddr TmpRgb) (car TmpRgb)) ColDta))
)
(+ 4.0 (/ (- (car TmpRgb) (cadr TmpRgb)) ColDta))
)
)
ColHue (* ColHue 60.0)
ColHue (if (minusp ColHue)
(+ ColHue 360.0)
ColHue
)
)
)
(list (if (> ColSat 0.0)
(fix ColHue)
nil
) (fix (* ColSat 100.0)) (fix (* ColLum 100.0))
)
)
;;; ========================================================================
;;; the following code are writen by CHEN QING JUN                         ;
;;; Civil engineering Department, South China University of Technology     ;
;;; Purpose: To convert ACADs' hsl value to rgb value                      ;
;;; Note : in acad ,h max=360, s max=100 , l max=100, RGB max=255          ;
;;;        This transform function is calculated by the website easyrgb    ;
;;; Function name: hsl2rgb                                                 ;
;;; use: (hsl2rgb '(170 60 60))=> (91 214 193)                             ;
;;; 2006.03.01                                                             ;
;;; ========================================================================
(defun hsl2rgb (hsllist / h s l r g b var2 var1)
(setq h (/ (nth 0 hsllist) 360.0)
s (/ (nth 1 hsllist) 100.0)
l (/ (nth 2 hsllist) 100.0)
)
(cond
((= s 0)
(setq r (* l 255)
g (* l 255)
b (* l 255)
)
)
((/= s 0)
(cond
((< l 0.5)
(setq var2 (* l (1+ s)))
)
(t
(setq var2 (- (+ l s) (* s l)))
)
)
(setq var1 (- (* 2 l) var2))
(setq r (* 255 (func var1 var2 (+ h 0.33333))))
(setq g (* 255 (func var1 var2 h)))
(setq b (* 255 (func var1 var2 (- h 0.33333))))
)
)
(list (fix r) (fix g) (fix b))
)
(defun func (v1 v2 vh / result)
(if (< vh 0)
(setq vh (1+ vh))
)
(if (> vh 1)
(setq vh (- vh 1))
)
(cond
((< (* 6 vh) 1)
(setq result (+ v1 (* 6 vh (- v2 v1))))
)
((< (* 2 vh) 1)
(setq result v2)
)
((< vh 0.66667)
(setq result (+ v1 (* 6 (- v2 v1) (- 0.666667 vh))))
)
(t
(setq result v1)
)
)
result
)
;;; ========================================================================
;;; to put hsl truecolor to the last object                                ;
;;; ========================================================================
(defun myputcolor (lst / a)
(setq a (vlax-ename->vla-object (entlast)))
(setq interrgb (hsl2rgb lst))
(vla-SetRGB acCmColor (nth 0 interrgb) (nth 1 interrgb) (nth 2 interrgb))
(vla-put-trueColor a acCmColor)
)

;;; ========================================================================
;;; Function make_point                                                    ;
;;; Entmake a point                                                        ;
;;; ========================================================================

(defun make_point (l10 color)
(ENTMAKE (LIST (CONS 0 "POINT") (cons 62 color) (cons 10 l10)))
)
;;; ========================================================================
;;; Function make_solid                                                    ;
;;; Entmake a solid according the center point and 0.5 width  and color    ;
;;; ========================================================================
(defun make_solid (p r color)
(entmake (list (cons 0 "SOLID") ;***
(cons 6 "BYLAYER") ;***
(cons 8 "0") ;***
(cons 10 (polar (polar p 0 r) (* pi 0.5) r)) ;***
(cons 11 (polar (polar p pi r) (* pi 0.5) r)) ;***
(cons 12 (polar (polar p 0 r) (* pi 1.5) r)) ;***
(cons 13 (polar (polar p pi r) (* pi 1.5) r)) ;***
(cons 39 0.0) (cons 62 color) (cons 210 (list 0.0 0.0 1.0))
)
)
)
;;; ========================================================================
;;; Function interpolate                                                   ;
;;; linear interpolation, a b is the two end number,                       ;
;;;        c is mean distance to a, d is distance mean from a to b         ;
;;;        so the result should be a+[b-a]*c/d                             ;
;;; ========================================================================
(defun interpolate (a b c d / e)
(setq a (itor a)
b (itor b)
c (itor c)
d (itor d)
)
(setq e (- a (* c (/ (- a b) d))))
(setq e (fix e))
e
)
;;; ========================================================================
;;; Function itor                                                          ;
;;; integer to real                                                        ;
;;; ========================================================================
(defun itor (a)
(atof (itoa a))
)
;;; ========================================================================
;;; Function [n,m]                                                         ;
;;; To Get a element of a two dimension list n for row ,m for column       ;
;;; n,m start from 0                                                       ;
;;; ========================================================================
(defun [n,m] (a n m / i)
(setq i (nth m (nth n a)))
i
)
;;; ========================================================================
;;;   The following code taken from www.theswamp.org                       ;
;;;   To calculate the time that the program run                           ;
;;; ========================================================================
(defun startTimer ()
(setq time (getvar "DATE"))
)
(defun endTimer (func)
(setq time (- (getvar "DATE") time)
seconds (* 86400.0 (- time (fix time)))
)
(gc)
(outPut seconds func)
)
(defun outPut (secs def)
(princ "\nPurging...")
(command "PURGE" "Layers" "*" "N")
(gc)
(princ (strcat "\nTimed " def ": " (rtos secs 2 6)))
(princ)
)
(princ "\n")
(prompt "\n use Julia Fractal Algorithm to draw pattern, command:treeQJCHEN \n")

« Last Edit: July 26, 2006, 04:38:29 AM by yuanqiu »
http://qjchen.mjtd.com
My blog http://chenqj.blogspot.com (Chinese, can be translate into English)

#### Kerry

• Mesozoic relic
• Seagull
• Posts: 11654
• class keyThumper<T>:ILazy<T>
##### Re: use LS gramma to Draw Fractal tree
« Reply #11 on: July 26, 2006, 04:39:18 AM »
MOST Excellent !!
Perfection is not optional.
Everything will work just as you expect it to, unless your expectations are incorrect.
Discipline: None at all.

--> Donate to theSwamp<--

#### GDF

• Water Moccasin
• Posts: 2058
##### Re: use LS gramma to Draw Fractal tree
« Reply #12 on: July 26, 2006, 10:58:27 AM »
Why is there never enough time to do it right, but always enough time to do it over?

#### qjchen

• Bull Frog
• Posts: 285
• Best wishes to all
##### Re: use LS gramma to Draw Fractal tree
« Reply #13 on: October 22, 2006, 10:09:12 AM »
When I was a young boy, I like one toy.

A toy with a big inside gear, a series of small gear, there are some hole inside the small gear, then put one pen inside the small gear and let it rolling along the big one inside, then the pen draw beautiful pattern.

because I like it very much, so when my early learning on Lisp, I write the following code, though it is very simple, but it make some beautiful pattern:) , I hope you also like it.

Though it is not tree at all, but maybe it looks like flower:)
Code: [Select]
;;; ========================================================================
;;; The following code are writen by CHEN QING JUN                         ;
;;; Civil engineering Department, South China University of Technology     ;
;;; Purpose: To draw some regular pattern, just for fun                    ;
;;;          something like one toy we play, put a pen in one hole that    ;
;;;          inside a small gear, that moving the pen to let the small gear;
;;;          rolling along a big gear, then the pen draw beautiful pattern ;
;;;          I call this "kaleidoscope"                                    ;
;;; The platform: Acad14 and after                                         ;
;;; Method: use the parameter to define the x y cordinate,just so          ;
;;; 2002.07.23                                                             ;
;;; Http://chenqj.blogspot.com                                             ;
;;; ========================================================================
(defun c:test (/ lst r1 r2 r3 r4 color alpha beta orign orignx orignyp1 p2)
(setq lst (getpattern)
r1 (nth 0 lst)
r2 (nth 1 lst)
r3 (nth 2 lst)
r4 (- r1 r2)
color (nth 3 lst)
alpha 0
beta 0
orign (getpoint "\n the original point:")
orignx (car orign)
)
(command "color" color "")
(while (< beta 314)
(setq alpha (* -1 (* beta (/ r2 (+ r4 r2)))))
(setq p1 (list (+ orignx (* r4 (cos alpha)) (* r3 (cos beta)))
(+ origny (* r4 (sin alpha)) (* r3 (sin beta)))
0
)
)
(setq beta (+ beta 0.05))
(setq alpha (* -1 (* beta (/ r2 (+ r4 r2)))))
(setq p2 (list (+ orignx (* r4 (cos alpha)) (* r3 (cos beta)))
(+ origny (* r4 (sin alpha)) (* r3 (sin beta)))
0
)
)
(command "line" p1 p2 "")
)
)
(defun getpattern (/ kword pattern pattern1)
(initget "1 2 3 4 5 6 7 8 9 10")
(setq kword (getkword "\n please select the type: 1/2/3/4/5/6/7/8/9/10:"))
(cond
((= kword "1")
(setq res (list 20.0 14.3 7 1))
)
((= kword "2")
(setq res (list 20.0 14.3 15 2))
)
((= kword "3")
(setq res (list 20.0 10.3 5 3))
)
((= kword "4")
(setq res (list 20.0 12 8 4))
)
((= kword "5")
(setq res (list 20.0 9 1 5))
)
((= kword "6")
(setq res (list 20.0 9 5 131))
)
((= kword "7")
(setq res (list 20.0 9 7 30))
)
((= kword "8")
(setq res (list 20.0 8 5 220))
)
((= kword "9")
(setq res (list 20.0 5.2 4.2 170))
)
((= kword "10")
(setq res (list 20.0 5.2 2.2 140))
)
)
res
)

the following two picture
1) is some pattern that draw by the code
2) the principle that was used

and when change the code for a little, it can draw the following picture
Code: [Select]
;;; ========================================================================
;;; The following code are writen by CHEN QING JUN                         ;
;;; Civil engineering Department, South China University of Technology     ;
;;; Purpose: To draw some regular pattern, just for fun                    ;
;;;          something like one toy we play, put a pen in one hole that    ;
;;;          inside a small gear, that moving the pen to let the small gear;
;;;          rolling along a big gear, then the pen draw beautiful pattern ;
;;;          I call this "kaleidoscope1"                                   ;
;;; The platform: Acad14 and after                                         ;
;;; Method: use the parameter to define the x y cordinate,just so          ;
;;; 2002.07.24                                                             ;
;;; Http://chenqj.blogspot.com                                             ;
;;; ========================================================================

(defun c:test1 (/ lst r1 r2 r3 rad color alpha beta orign orignx orignyp1
(setq lst    (getpattern1)
r1     (nth 0 lst)
r2     (nth 1 lst)
r3     (nth 2 lst)
rep    (nth 4 lst)
alpha  0
beta   0
orign  (getpoint "\n the original point:")
orignx (car orign)
)
(entmake (list (cons 0 "CIRCLE")
(cons 6 "BYLAYER")
(cons 8 "0")
(cons 10 orign)
(cons 40 r1)
(cons 62 8)
)
)
(setq i 1)
(setq color 10)
(command "color" color "")
(while (< beta rep)
(if (> beta (* add i))
(progn
(setq i (+ i 1))
(setq color (+ color 10))
(command "color" color "")
)
)
(setq alpha (* -1 (* beta (/ r2 (+ r1 r2)))))
(setq x1 (+ orignx (* r1 (cos alpha)) (* r3 (cos beta))))
(setq y1 (+ origny (* r1 (sin alpha)) (* r3 (sin beta))))
(setq p1 (list x1 y1 0.0))
(setq beta (+ beta 0.05))
(entmake (list (cons 0 "CIRCLE")
(cons 6 "BYLAYER")
(cons 8 "0")
(cons 10 p1)
(cons 62 color)
)
)

)
)
(defun getpattern1 (/ kword pattern pattern1)
(initget "1 2")
(setq kword (getkword "\n please select the type: 1/2:"))
(cond
((= kword "1")
(setq res (list 20.0 14.3 7 0.2 75.2 3.14))
)
((= kword "2")
(setq res (list 20.0 15 15 1 44 2.14))
)
)
res
)

http://qjchen.mjtd.com
My blog http://chenqj.blogspot.com (Chinese, can be translate into English)

#### MP

• Seagull
• Posts: 17750
• Have thousands of dwgs to process? Contact me.
##### Re: use LS gramma to Draw Fractal tree
« Reply #14 on: October 22, 2006, 01:20:41 PM »
Very nice Chen, may you never lose the boy inside the man.

Engineering Technologist • CAD Automation Practitioner
Automation ▸ Design ▸ Drafting ▸ Document Control ▸ Client