分形图形(树，图案)及螺旋型星云线的绘制

snoopychen · 发表于 2006-7-23 12:42:21

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

最近喜欢上了分形和递归,网上也有好些分形的LISP, 如LIVER兄就写过分形与递归的好文章,
还有好些画树的LSP.
感觉LISP应该很适合来做分形的,于是看了一些书
发现递归还没有怎么学会,不过分形中除了递归算法,还有LS文法算法,迭代函数系统算法,逃逸时间算法
分形演化算法等有趣的东西. 个人觉得要实现更漂亮的实体涂色等等说不定用opengl之类会好些
于是先拣了一种比较适合用cad还画线的LS文法学习,发现还挺有趣的,于是按照
孙博文撰写的《分析算法与程序设计－Visual C++实现》书里的文法思想撰写了如下画树的小程序
还没有考虑多参数文法以及随机文法.
仅为消遣,见笑了,有兴趣的话改改pattern,可以得到其他类型的树

[iframe h=500 w=600]http://qjchen.googlepages.com/tree1.png[/iframe]

;;; ========================================================================
;;; 功能：按照LS文法绘制分形树 ;
;;; 命令 :tree ;
;;; 平台: Acad14以上 ;
;;; 限制：还没有考虑多参数和随机性 ;
;;; 说明: pattern 是树基本构形的定义，你可以自己修改 ;
;;; "F" 代表树在某方向生长 ;
;;; "+" 代表逆时针一个角度生长 ;
;;; "-" 代表顺时钟一个角度生长 ;
;;; "[" 和 "]" 是对应的，表明做完[]内操作后笔回到起点 . ; ;
;;; 代替(repeat 4)中的4到更大的数值，可以获得更茂盛的树叶不过速度变慢;
;;; 比如模式F[-F]F[+F]F 代表 ;
;;; ;
;;; ;
;;; \ | ;
;;; \ | ;
;;; \ | ;
;;; \| ;
;;; | / ;
;;; | / ;
;;; | / ;
;;; |/ ;
;;; | ;
;;; | ;
;;; | ;
;;; | ;
;;; ;
;;; 代码思想来自孙博文撰写的《分析算法与程序设计－Visual C++实现》 ;
;;; 2006.07.23 ;
;;; [url]Http://autolisper.googlepages.com[/url] ;
;;; [url]Http://qjchen.googlepages.com[/url] ;
;;; ========================================================================
(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:tree?QJCHEN \n")

;;; ======================================================================== 
;;; 功能：按照LS文法绘制分形树                                             ; 
;;; 命令 :tree                                                             ; 
;;; 平台: Acad14以上                                                       ; 
;;; 限制：还没有考虑多参数和随机性                                         ; 
;;; 说明: pattern 是树基本构形的定义，你可以自己修改                       ; 
;;;       "F" 代表树在某方向生长                                           ; 
;;;       "+" 代表逆时针一个角度生长                                       ; 
;;;       "-" 代表顺时钟一个角度生长                                       ; 
;;;       "[" 和 "]" 是对应的，表明做完[]内操作后笔回到起点 .              ;                                  ; 
;;;       代替(repeat 4)中的4到更大的数值，可以获得更茂盛的树叶不过速度变慢; 
;;;       比如模式F[-F]F[+F]F 代表                                         ; 
;;;                                                                        ; 
;;;                                                                        ; 
;;;                       \   |                                            ; 
;;;                        \  |                                            ; 
;;;                         \ |                                            ; 
;;;                          \|                                            ; 
;;;                           |   /                                        ; 
;;;                           |  /                                         ; 
;;;                           | /                                          ; 
;;;                           |/                                           ; 
;;;                           |                                            ; 
;;;                           |                                            ; 
;;;                           |                                            ; 
;;;                           |                                            ; 
;;;                                                                        ; 
;;; 代码思想来自孙博文撰写的《分析算法与程序设计－Visual C++实现》         ; 
;;; 2006.07.23                                                             ; 
;;; [url]Http://autolisper.googlepages.com[/url]                                      ; 
;;; [url]Http://qjchen.googlepages.com[/url]                                          ; 
;;; ======================================================================== 
(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:tree?QJCHEN \n")

lidejun_55 · 发表于 2006-7-23 13:46:48

非常不错，画了一个

snoopychen · 发表于 2006-7-23 18:21:42

经过一个下午的修改，改成了多参数类型的LS文法，不过这个似乎不大好理解，只能先照着写了
这种多参数的相对更象树了，这个叫多参数1，等晚上再进一步改成多参数2

[iframe h=500 w=600]http://autolisper.googlepages.com/tree2.png[/iframe]

;;; ========================================================================
;;; 功能：按照LS文法绘制分形树之多参数制作 ;
;;; 命令 :tree ;
;;; 平台: Acad14以上 ;
;;; 限制：还没有考虑多参数和随机性 ;
;;; 说明: 多参数的含义一时无法说明，其中ang是基本角度，而omega是基本构形 ;
;;; P1a和P1等五对参数轮番对换迭代，P1a->P1, P2a->P2,... ;
;;; 代码思想来自孙博文撰写的《分析算法与程序设计－Visual C++实现》 ;
;;; 2006.07.23 ;
;;; Scut QJCHEN ;
;;; [url]Http://autolisper.googlepages.com[/url] ;
;;; [url]Http://qjchen.googlepages.com[/url] ;
;;; ========================================================================
(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:tree?QJCHEN \n")

;;; ======================================================================== 
;;; 功能：按照LS文法绘制分形树之多参数制作                                 ; 
;;; 命令 :tree                                                             ; 
;;; 平台: Acad14以上                                                       ; 
;;; 限制：还没有考虑多参数和随机性                                         ; 
;;; 说明: 多参数的含义一时无法说明，其中ang是基本角度，而omega是基本构形   ; 
;;;       P1a和P1等五对参数轮番对换迭代，P1a->P1, P2a->P2,...              ; 
;;; 代码思想来自孙博文撰写的《分析算法与程序设计－Visual C++实现》         ; 
;;; 2006.07.23                                                             ; 
;;; Scut QJCHEN                                                            ; 
;;; [url]Http://autolisper.googlepages.com[/url]                                      ; 
;;; [url]Http://qjchen.googlepages.com[/url]                                          ; 
;;; ======================================================================== 
(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:tree?QJCHEN \n")

eachy · 发表于 2006-7-23 19:45:15

http://www.cgn.net.cn/wsdj/z5.htm
[iframe h=600 w=100%]http://www.cgn.net.cn/wsdj/z5.htm[/iframe]

snoopychen · 发表于 2006-7-23 22:04:11

eachy版主的是专业理论：）
这个LS文法就是5.6的L系统
IFS好像也很有趣，就是不知道用acad的点系统看起来会不会漂亮，实现起来倒是挺简单的，那个复平面的JULIA集的IFS算法应该也挺有趣，分形确实是比较有趣的东西。正在下emule的分形电影。

雨箭风刀 · 发表于 2006-7-24 00:19:33

[iframe h=600 w=100%]http://www.sogoll.com/Article/xuekebolan/shuxue/Article_3137.html[/iframe]

[iframe h=600 w=100%]http://www.whsss.com/Article/Print.asp?ArticleID=3092[/iframe]

它山之石 · 发表于 2006-7-24 09:54:30

前段时间也喜欢了一阵分形艺术
没搞出来什么名堂
后来兴趣转移了

一个分形艺术的网站
http://www.fractal.net.cn/

下面这个是别人写的一个画树的

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

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

snoopychen · 发表于 2006-7-24 17:38:31

谢谢两位
刀兄提到的布朗运动可用在分形演化算法中，刚刚还不知道这个布朗运动怎么来模拟，就学到一招了。

它山之石兄的这个画树程序是用递归的，我老是学不会递归，有空多跟大家学习：）网站中的分形颜色很漂亮。

下面的代码是用IFS算法绘制分形图形的。
发现cad中的点在这种分形图形中，却不如位图的象素好看，觉得很是郁闷，不知道在cad中怎么来模拟象素点，用point好像太离散，用solid又好像太耗时。

代码中用了entmake的方法来画点，其实假如想有效果的话，可以改用注释中的command，可以看到一种显影的效果。

效果

;;; ======================================================================
;;; 功能：采用IFS迭代函数系统算法进行分形图形的绘制 ;
;;; 命令: tree(由于和前面的LS算法中采用了同样的子程序名，若出错请新建文件 ;
;;; 平台：acad14及以上版本 ;
;;; 说明：采用了IFS算法，其中，基本样式定义里面，以第一个为例 ;
;;; (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)) ;
;;; 有三个元素（可以是更多或更少） ;
;;; 每个最后的0.333 0.333 0.334是概率,rndlst是其叠加(0.333 0.666 1) ;
;;; 而其余6个是参数a b c d e f ;
;;; 它们参与放射变换 : ;
;;; x'=ax+by+e ;
;;; y'=cx+dy+f ;
;;; 先建立随机数（用的是Smadsen的函数)，判断其在rndlst的哪个区域 ;
;;; 决定用哪个abcdef，按照计算的x‘和y’画点，然后循环 ;
;;; 2006.07.24 ;
;;; 代码思想来自孙博文撰写的《分析算法与程序设计－Visual C++实现》 ;
;;; 2006.07.23 ;
;;; 华南理工大学建筑学院 QJCHEN ;
;;; [url]Http://autolisper.googlepages.com[/url] ;
;;; [url]Http://qjchen.googlepages.com[/url] ;
;;; ========================================================================
(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:tree?QJCHEN \n")

;;; ====================================================================== 
;;; 功能：采用IFS迭代函数系统算法进行分形图形的绘制                        ; 
;;; 命令: tree(由于和前面的LS算法中采用了同样的子程序名，若出错请新建文件  ; 
;;; 平台：acad14及以上版本                                                 ; 
;;; 说明：采用了IFS算法，其中，基本样式定义里面，以第一个为例              ; 
;;;         (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))                   ; 
;;;        有三个元素（可以是更多或更少）                                  ; 
;;;        每个最后的0.333 0.333 0.334是概率,rndlst是其叠加(0.333 0.666 1) ; 
;;;        而其余6个是参数a b c d e f                                      ; 
;;;        它们参与放射变换 :                                              ; 
;;;         x'=ax+by+e                                                     ; 
;;;         y'=cx+dy+f                                                     ; 
;;;        先建立随机数（用的是Smadsen的函数)，判断其在rndlst的哪个区域    ; 
;;;        决定用哪个abcdef，按照计算的x‘和y’画点，然后循环                ; 
;;; 2006.07.24                                                             ; 
;;; 代码思想来自孙博文撰写的《分析算法与程序设计－Visual C++实现》         ; 
;;; 2006.07.23                                                             ; 
;;; 华南理工大学建筑学院 QJCHEN                                            ; 
;;; [url]Http://autolisper.googlepages.com[/url]                                      ; 
;;; [url]Http://qjchen.googlepages.com[/url]                                          ; 
;;; ======================================================================== 
(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:tree?QJCHEN \n")

[iframe h=500 w=600]http://autolisper.googlepages.com/tree3.png[/iframe]

它山之石 · 发表于 2006-7-26 12:08:01

看了在http://www.theswamp.org/index.php?topic=11255.new#new 上的图片
真的是非常漂亮

可惜现在晓东看不到贴图，
转贴网站居然也看不到
大家没有眼福了呀

snoopychen · 发表于 2006-7-26 17:27:48

谢谢石兄，您的那个fractal好像有一个AFRACT没有定义，运行不了啊，theswamp的贴图功能挺好的
乱七八糟的完成了下面这个Julia集的绘制，没有想到绘制一个400*400的图形，cad会这么的辛苦，可能Lisp的计算效率确实不高，也可能我用的solid比较怪异，但无论如何，实现了在cad中绘制Julia集的一个目标。
请注意，计算时间很久。

;;; 注意: 本程序非常耗时和耗CPU,在我的P4 2.8C机器上完成一次需要150秒左右 ;
;;; 请小心使用,反正画出来的图形也不是很精致,请自己选择决定使用与否 ;
;;; ========================================================================
;;; 功能：采用Julia复数集的逃逸时间算法进行分形图形的绘制 ;
;;; 命令: tree(由于和前面的LS算法中采用了同样的子程序名，若出错请新建文件 ;
;;; 平台：acad2004及以上版本 ;
;;; 说明：采用了JULIA集的复数算法 ;
;;; 变化pattern中的第五第六个数,可以得到不同的图形 ;
;;; 建议第一个颜色用浅色,比如(151,148,244), 而第二个用深色(45,27,34) ;
;;; 参数: k:判断逃逸与否的迭代次数 ;
;;; m:逃逸半径 ;
;;; mx,my: 图形的宽和高 ;
;;; xs,xl,ys,yl: 复数C的最大最小值 ;
;;; p,q:复数的初值 ;
;;; 代码思想来自孙博文撰写的《分析算法与程序设计－Visual C++实现》 ;
;;; 华南理工大学建筑学院 QJCHEN ;
;;; [url]Http://autolisper.googlepages.com[/url] ;
;;; [url]Http://qjchen.googlepages.com[/url] ;
;;; ========================================================================
(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 [url]www.theswamp.org[/url] ;
;;; 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")

;;; 注意: 本程序非常耗时和耗CPU,在我的P4 2.8C机器上完成一次需要150秒左右   ; 
;;;       请小心使用,反正画出来的图形也不是很精致,请自己选择决定使用与否   ; 
;;; ======================================================================== 
;;; 功能：采用Julia复数集的逃逸时间算法进行分形图形的绘制                  ; 
;;; 命令: tree(由于和前面的LS算法中采用了同样的子程序名，若出错请新建文件  ; 
;;; 平台：acad2004及以上版本                                               ; 
;;; 说明：采用了JULIA集的复数算法                                          ; 
;;;       变化pattern中的第五第六个数,可以得到不同的图形                   ; 
;;;       建议第一个颜色用浅色,比如(151,148,244), 而第二个用深色(45,27,34) ; 
;;; 参数:  k:判断逃逸与否的迭代次数                                        ; 
;;;        m:逃逸半径                                                      ; 
;;;        mx,my: 图形的宽和高                                             ; 
;;;        xs,xl,ys,yl: 复数C的最大最小值                                  ; 
;;;        p,q:复数的初值                                                  ; 
;;; 代码思想来自孙博文撰写的《分析算法与程序设计－Visual C++实现》         ; 
;;; 华南理工大学建筑学院 QJCHEN                                            ; 
;;; [url]Http://autolisper.googlepages.com[/url]                                      ; 
;;; [url]Http://qjchen.googlepages.com[/url]                                          ; 
;;; ======================================================================== 
(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 [url]www.theswamp.org[/url]                       ; 
;;;   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")

两个图片：

[iframe h=500 w=600]http://autolisper.googlepages.com/tree4.png[/iframe]
[iframe h=500 w=600]http://autolisper.googlepages.com/tree5.png[/iframe]

lidejun_55 · 发表于 2006-7-27 00:32:34

; 错误: no function definition: ACAD_TRUECOLORDLG
请将这个补上

snoopychen · 发表于 2006-10-26 17:01:11

还记得小时候玩过的一种玩具么？一个塑料板上有带内齿轮大圆形，一系列上面带有孔的小齿轮，把铅笔套在小齿轮的孔上，让小齿轮沿着大内齿轮滚动，于是，笔画出了一道漂亮的曲线。不大记得这种玩具叫什么名字了，好像叫“万花筒”？，今天才知道这种玩具的英文名叫“spirograph”，于是找了一下资料，发现外国的品种要多一些。如图所示。
[iframe h=300 w=400]http://qjchen.googlepages.com/spirograph.JPG[/iframe]

由于小时候挺喜欢这种玩具也很喜欢几何，而在学习Lisp之初，就用Lisp编了如下一段简单的小程序，最近整理东西的时候才发现，贴贴让大家娱乐一下：）

这种曲线应该和机械的有点关系，假如一个圆沿着一条直线走的话，那么圆内（不一定是圆周）某一点形成的轨迹应该叫滚轮线，似乎和悬链线及最速降线有点关系，而圆沿着一个圆周走，照查询的资料应该叫spirograph－螺旋型星云线，而若其沿着一个封闭的曲线走，应该更复杂一下，反正是按照一种等距离量测的方法在走动。

本程序简单利用参数方程的方法构建，纯属娱乐，毫无作用，见笑了：）

原理
[iframe h=500 w=600]http://qjchen.googlepages.com/HELISCOPE1.png[/iframe]

;;; ========================================================================
;;; The following code are writen by qjchen ;
;;; 华南理工大学建筑学院 ;
;;; [url]Http://qjchen.googlepages.com[/url] ;
;;; ========================================================================
(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)
origny (cadr 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 code are writen by qjchen                                ; 
;;; 华南理工大学 建筑学院                                                  ; 
;;; [url]Http://qjchen.googlepages.com[/url]                                          ; 
;;; ======================================================================== 
(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) 
        origny (cadr 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 
)

效果
[iframe h=500 w=600]http://qjchen.googlepages.com/HELISCOPE.png[/iframe]

修改一下，改成变颜色和画圆，得到如下的结果和图形

;;; ========================================================================
;;; The following code are writen by qjchen ;
;;; 华南理工大学建筑学院 ;
;;; [url]Http://qjchen.googlepages.com[/url] ;
;;; ========================================================================
(defun c:test1 (/ lst r1 r2 r3 rad color alpha beta orign orignx orignyp1
p2 rep add)
(setq lst (getpattern1)
r1 (nth 0 lst)
r2 (nth 1 lst)
r3 (nth 2 lst)
rad (nth 3 lst)
rep (nth 4 lst)
add (nth 5 lst)
alpha 0
beta 0
orign (getpoint "\n the original point:")
orignx (car orign)
origny (cadr 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 40 rad)
(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
)

;;; ======================================================================== 
;;; The following code are writen by qjchen                                ; 
;;; 华南理工大学 建筑学院                                                  ; 
;;; [url]Http://qjchen.googlepages.com[/url]                                          ; 
;;; ======================================================================== 
 
(defun c:test1 (/ lst r1 r2 r3 rad color alpha beta orign orignx orignyp1 
             p2 rep add) 
  (setq lst    (getpattern1) 
        r1     (nth 0 lst) 
        r2     (nth 1 lst) 
        r3     (nth 2 lst) 
        rad    (nth 3 lst) 
        rep    (nth 4 lst) 
        add    (nth 5 lst) 
        alpha  0 
        beta   0 
        orign  (getpoint "\n the original point:") 
        orignx (car orign) 
        origny (cadr 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 40 rad)         
                   (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 
)

效果：

[iframe h=500 w=600]http://qjchen.googlepages.com/HELISCOPE3.png[/iframe]

aeo · 发表于 2006-10-26 20:32:40

我想在哪里看过
http://140.137.123.37/classes/ca ... Lisp/FractalLsp.htm

还有一个也是lisp,但不是autocad的lisp
http://coding.derkeiler.com/Arch ... p/2004-08/1920.html
样子图例
http://www.biologie.uni-hamburg.de/b-online/e28_3/lsys.html

fsxm · 发表于 2006-11-29 22:08:08

snoopychen 真是超级的厉害啊！这么神奇的东东也做的出来~
刚不久看了一个分形的书，感觉到了分形的魅力实在是太强了！
我好想好想学习啊！实中对逃逸时间算法不很了解
帮忙请你详尽解释一下：逃逸时间算法，是什么原理呢？
非常感谢！
依样画葫芦搞了个mandelbrot集的生成
：由于没有用真TRUECOLOR可能效果不太好~请多指教
不过看看样子也罢了！~

(defun z* (a b)
(list (- (* (car a) (car b)) (* (cadr a) (cadr b)))
(+ (* (car a) (cadr b)) (* (cadr a) (car b)))
)
)
(defun z+ (a b) (mapcar '+ a b))
(defun c:tt ()
(setq minx -2.5
miny -1.5
maxx 1.5
maxy 1.5
nx 400
ny 300
)
(setq dax (/ (- maxx minx) nx)
day (/ (- maxy miny) ny)
)
(setq xi 0)
(repeat nx
(setq x (+ minx (* xi dax)))
(setq xi (1+ xi))
(setq yi 0)
(repeat ny
(setq y (+ miny (* yi day)))
(setq yi (1+ yi))
(setq z '(0.0 0.0))
(setq col 0)
(while (and (< col 255)
(< (distance z '(0 0)) 1000)
)
(setq col (1+ col))
(setq z (z+ (z* z z) (list x y)))
)
(entmake (list '(0 . "point")
(cons 62 col)
(list 10 x y)
)
)
)
)
)

(defun z* (a b) 
  (list        (- (* (car a) (car b)) (* (cadr a) (cadr b))) 
        (+ (* (car a) (cadr b)) (* (cadr a) (car b))) 
  ) 
) 
(defun z+ (a b) (mapcar '+ a b)) 
(defun c:tt () 
  (setq        minx -2.5 
        miny -1.5 
        maxx 1.5 
        maxy 1.5 
        nx   400 
        ny   300 
  ) 
  (setq        dax (/ (- maxx minx) nx) 
        day (/ (- maxy miny) ny) 
  ) 
  (setq xi 0) 
  (repeat nx 
    (setq x (+ minx (* xi dax))) 
    (setq xi (1+ xi)) 
    (setq yi 0) 
    (repeat ny 
      (setq y (+ miny (* yi day))) 
      (setq yi (1+ yi)) 
      (setq z '(0.0 0.0)) 
      (setq col 0) 
      (while (and (< col 255) 
                  (< (distance z '(0 0)) 1000) 
             ) 
        (setq col (1+ col)) 
        (setq z (z+ (z* z z) (list x y))) 
      ) 
      (entmake (list '(0 . "point") 
                     (cons 62 col) 
                     (list 10 x y) 
               ) 
      ) 
    ) 
  ) 
)

snoopychen · 发表于 2006-12-5 08:30:04

谢谢fsxm分享，从你一直以来的程序我也学到了很多：）

其实对于逃逸时间算法，我也没有太懂，应该就是某些复数，经过一些迭代的算法之后，有些可以收敛，有些不能收敛。根据是否收敛，判断其是否属于分形中的点与否。

感觉AUTOCAD对于线，点来做分形还挺好，希望有空也再学点OPENGL等来使效果更好一些。

账号		自动登录	找回密码
密码			立即注册

分形图形(树，图案)及螺旋型星云线的绘制

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子