代码段一:
;;; ========================================================================
;;; 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++> ;
;;; Http://autolisper.googlepages.com ;
;;; Http://qjchen.googlepages.com ;
;;; ========================================================================
(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)
)
;;degreed to radian;;
(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 ori (cadr (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:treeQJCHEN \n")
代码段二:
;;; ========================================================================
;;; 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++> ;
;;; Http://autolisper.googlepages.com ;
;;; Http://qjchen.googlepages.com ;
;;; ========================================================================
(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)
)
;;degreed to radian;;
(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))
ori (cadr (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:treeQJCHEN \n")
代码段三:
;;; ========================================================================
;;; 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++> ;
;;; Http://autolisper.googlepages.com ;
;;; Http://qjchen.googlepages.com ;
;;; ========================================================================
(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)
y (cadr 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:treeQJCHEN \n")
代码段四:
;;; 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 ;
;;; m:the escape radius ;
;;; 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++> ;
;;; Http://autolisper.googlepages.com ;
;;; Http://qjchen.googlepages.com ;
;;; ========================================================================
(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 hsl2 (cadr hsllst))
(setq os (getvar "osmode"))
(setq cmd (getvar "cmdecho"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
(vload)
(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 ;
;;; ========================================================================
(defun vload ()
(VL-LOAD-COM)
(setq acCmColor (vla-GetInterfaceObject (vlax-get-acad-object)
"AutoCAD.AcCmColor.16"
)
)
(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)
(/ (- (cadr TmpRgb) (caddr TmpRgb)) ColDta)
)
((= (cadr TmpRgb) MaxVal)
(+ 2.0 (/ (- (caddr TmpRgb) (car TmpRgb)) ColDta))
)
((= (caddr TmpRgb) MaxVal)
(+ 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:treeQJCHEN \n")
631
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
