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~
;;; 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")