牛顿分形的LISP程序

牛顿分形简介:
在复数域上使用牛顿迭代生成分形图像,函数公式F(z) = z^3 – 1在复数域上面有三个根,一个是1,另外两个分别是复数-0.5+0.866i 与 -0.5 – 0.866i根据计算出来根的值不同转换为RGB三种不同的颜色,根据迭代次数的多少设置颜色值的大小,即颜色强度。
Newton's Fractal
下面是用LISP代码的实现。

  1. ;;;************
  2. ;;;牛顿迭代分形
  3. ;;;************
  4. (defun C:Nt (/ con eps  OLDCMD oldsnap t0  gg ita)
  5.   (vl-load-com)
  6.   (setq *APP (vlax-get-acad-object))
  7.   (setq	colObj (vla-getinterfaceobject *APP "AutoCAD.AcCmColor.16"))
  8.   (setq OLDCMD (getvar "CMDECHO"))
  9.   (setq oldsnap (getvar "OSMODE"))
  10.   (princ "n请选择三种不同的颜色:")
  11.   (princ "n选择颜色1:n")
  12.   (setq c1 (acad_truecolordlg 1))
  13.   (princ "n选择颜色2:n")
  14.   (setq c2 (acad_truecolordlg 3))
  15.   (princ "n选择颜色3:n")
  16.   (setq c3 (acad_truecolordlg 5))
  17.   (setq gg (getint "n输入颜色梯度:"))
  18.   (setq sol (getint "n输入分辨率:"))
  19.   (setq EPS (getreal "n输入迭代误差:"))     ;迭代误差
  20.   (setq ita (getint "n最大迭代次数:"))
  21.   (if (and c1 c2 c3 gg sol EPS ita)
  22.     (progn   
  23.       (setvar "CMDECHO" 0)
  24.       (setvar "OSMODE" 0)
  25.       (setq t0 (getvar "TDUSRTIMER"))
  26.       (NewTon_fractal sol sol EPS c1 c2 c3 gg ita)
  27.       (princ "n画牛顿分形用时")
  28.       (princ (* (- (getvar "TDUSRTIMER") t0) 86400))
  29.       (princ "秒")
  30.       ;;(command ".ZOOM" '(39 39) '(361 361))
  31.       (command ".ZOOM" "E")
  32.       (setvar "OSMODE" oldsnap)
  33.       (setvar "CMDECHO" OLDCMD)
  34.     )
  35.     (alert "n你没有输入有效选择!")
  36.   )
  37.   (gc)
  38.   (princ)
  39. )
  40. (defun trans->RGB (color / ccc) 
  41.   (if (setq ccc (cdr (assoc 420 color)))
  42.     (Number->RGB ccc)
  43.     (Index->RGB colObj (cdr (assoc 62 color)))
  44.   )
  45. )
  46. (defun NewTon_fractal(solx soly EPS c1 c2 c3 grad ita /
  47. 		      col1 col2 col3 hsl1 hsl2 hsl3 con xx yy nx ny
  48. 		      cm newx newy x y k)
  49.   (setq col1 (trans->RGB c1))  
  50.   (setq HSL1 (RGB->HSL (car col1) (cadr col1) (caddr col1)))
  51.   (setq col2 (trans->RGB c2))  
  52.   (setq HSL2 (RGB->HSL (car col2) (cadr col2) (caddr col2)))
  53.   (setq col3 (trans->RGB c3))  
  54.   (setq HSL3 (RGB->HSL (car col3) (cadr col3) (caddr col3)))
  55.   (setq CON (/ (sqrt 3.0) 2))
  56.   (setq xx (/ solX 4.0))
  57.   (setq yy (/ solY 4.0))
  58.   (setq nx (/ solx -2))
  59.   (repeat solx
  60.     (setq ny (/ soly -2))
  61.     (repeat soly
  62.       (setq x (/ nx xx))
  63.       (setq y (/ ny yy))
  64.       (setq k 0)
  65.       (while (and (< k ita) (/= (dist x y) 0))
  66. 	(setq cm   (* 3 (dist x y) (dist x y))
  67. 	      newx (+ (* 2 x (/ 1.0 3)) (/ (- (* x x) (* y y)) cm))
  68.               newy (- (* 2 y (/ 1.0 3)) (/ (* 2 x y) cm))
  69.               x    newx
  70. 	      y    newy
  71. 	)
  72. 	(cond
  73. 	  ( (< (dist (1- x) y) EPS)
  74. 	    (putcolor hsl1 nx ny k)
  75. 	    (setq k ita)
  76. 	  )
  77.           ( (< (dist (+ x 0.5) (- y con)) EPS)
  78.             (putcolor hsl2 nx ny k)
  79. 	    (setq k ita)
  80.           )
  81.           ( (< (dist (+ x 0.5) (+ y con)) EPS)
  82. 	    (putcolor hsl3 nx ny k)
  83. 	    (setq k ita)
  84.           )
  85.         )	   
  86. 	(setq k (1+ k))
  87.       )
  88.       (setq ny (1+ ny))
  89.     )
  90.     (setq nx (1+ nx))
  91.   )
  92. )
  93. ;;距离平方函数
  94. (defun dist (a b)
  95.   (+ (* a a) (* b b))
  96. )
  97. (defun putcolor	(HSL nx ny k / nH ncolor)
  98.   (setq nH (rem (+ (car HSL) (* grad k)) 361))
  99.   (setq ncolor (hsl->rgb nH (cadr hsl) (caddr hsl)))
  100.   (setq ncolor (rgb->number ncolor))
  101.   (putpixel nx ny ncolor)
  102. )
  103. ;;;==========================
  104. ;;;用entmake方法画像素点函数 
  105. ;;;==========================
  106. (defun putpixel (a b c)
  107.   (entmake
  108.     (list
  109.       '(0 . "LWPOLYLINE")    
  110.       '(100 . "AcDbEntity")
  111.       '(100 . "AcDbPolyline")
  112.       '(90 . 2)
  113.       '(43 . 1.0)
  114.       (cons 420 c)
  115.       (cons 10 (list a b))
  116.       (cons 10 (list (1+ a) b))
  117.     )
  118.   )
  119. )
  120. ;;画像素点函数
  121. (defun putpixel2 (a b c)
  122.   (entmake
  123.     (list
  124.       '(0 . "LWPOLYLINE")    
  125.       '(100 . "AcDbEntity")
  126.       '(100 . "AcDbPolyline")
  127.       '(90 . 2)
  128.       '(43 . 1.0)
  129.       (cons 62 c)
  130.       (cons 10 (list a b))
  131.       (cons 10 (list (1+ a) b))
  132.     )
  133.   )
  134. )
  135. (defun putpixel1 (a b c)
  136.   (entmake
  137.     (list
  138.       '(0 . "POINT")
  139.       (cons 10 (list a b 0))
  140.       (cons 62 c)
  141.     )
  142.   )
  143. )
  144.  
  145. ;;;===============
  146. ;;;HSL值转RGB值   
  147. ;;;返回RGB值的列表
  148. ;;;===============
  149. ;;;Hue转RGB       
  150. (defun Hue->rgb (v1 v2 vHue / vH)
  151.   (cond
  152.     ((< vHue 0) (setq vH (1+ vHue)))
  153.     ((> vHue 1) (setq vH (1- vHue)))
  154.     (t (setq vH vHue))
  155.   )
  156.   (cond
  157.     ((< (* 6 vH) 1) (+ v1 (* (- v2 v1) 6 vH)))
  158.     ((< (* 2 vH) 1) v2)
  159.     ((< (* 3 vH) 2) (+ v1 (* (- v2 v1) 6 (- 0.66666667 vH))))
  160.     (t v1)
  161.   ) 
  162. )
  163. (defun Hsl->rgb (Hue Saturation Light / h s l r g b var2 var1)
  164.   (setq h (/ Hue 360.0)
  165. 	s (/ Saturation 100.0)
  166. 	l (/ Light 100.0)
  167.   )
  168.   (if (= s 0)
  169.     (setq r (* l 255)
  170. 	  g (* l 255)
  171. 	  b (* l 255)
  172.     )
  173.     (setq var2 (if (< l 0.5)
  174. 		 (* l (1+ s))
  175. 		 (+ l s (* s l -1))
  176. 	       )
  177.           var1 (- (* 2 l) var2)
  178.           r (* 255 (Hue->RGB var1 var2 (+ h 0.33333333)))
  179.           g (* 255 (Hue->RGB var1 var2 h))
  180.           b (* 255 (Hue->RGB var1 var2 (- h 0.33333333)))
  181.     )
  182.   )
  183.   (list (fix r) (fix g) (fix b))
  184. )
  185. ;;;===============
  186. ;;;RGB值转HSL值   
  187. ;;;返回HSL值的列表
  188. ;;;===============
  189. (defun RGB->HSL(R G B / var_R var_G var_B var_min var_max
  190. 		        del_max del_R del_G del_B H L S)
  191.   (setq var_R (/ R 255.0))
  192.   (setq var_G (/ G 255.0))
  193.   (setq var_B (/ B 255.0))
  194.   (setq var_min (min var_R var_G var_B))
  195.   (setq var_max (max var_R var_G var_B))
  196.   (setq del_max (- var_max var_min))
  197.   (setq L (/ (+ var_max var_min) 2))
  198.   (if (= del_max 0)
  199.     (setq H 0 S 0)
  200.     (progn 
  201.       (setq S (if (< L 0.5)
  202.                 (/ del_max (+ var_max var_min))
  203.                 (/ del_max (- 2 var_max var_min))
  204.               )
  205. 	    del_R (/ (+ (/ (- var_max var_R) 6)  (/ del_Max 2 )) del_max)
  206. 	    del_G (/ (+ (/ (- var_max var_G) 6)  (/ del_Max 2 )) del_max)
  207. 	    del_B (/ (+ (/ (- var_max var_B) 6)  (/ del_Max 2 )) del_max)
  208.       )
  209.       (cond
  210. 	( (= var_R var_max)
  211. 	  (setq H (- del_B del_G))
  212. 	)
  213. 	( (= var_G var_max)
  214. 	  (setq H (+ (/ 1.0 3) del_R (- del_B)))
  215. 	)
  216.         ( (= var_B var_max)
  217. 	  (setq H (+ (/ 2.0 3) del_G (- del_R)))
  218. 	)
  219.       )
  220.       (cond
  221. 	( (< H 0) (setq  H (1+ H)))
  222. 	( (> H 1) (setq  H (1- H)))
  223.       )
  224.     )
  225.   )
  226.   (setq h (* 360 H)
  227. 	S (* 100 S)
  228. 	l (* 100 l) 
  229.   )
  230.   (list (fix H) (fix S) (fix L))
  231. )
  232. ;;;===============
  233. ;;;把truecolordlg 
  234. ;;;420构成的数值返
  235. ;;;回RGB列表.     
  236. ;;;===============
  237. (defun Number->RGB (C)
  238.   (list (lsh C -16)
  239.         (lsh (lsh C 16) -24)
  240.         (lsh (lsh C 24) -24)
  241.   )
  242. )
  243. ;;;===============
  244. ;;;把truecolordlg 
  245. ;;;420构成的数值返
  246. ;;;回RGB列表.     
  247. ;;;===============
  248. (defun RGB->Number (lst)
  249.   (+ (lsh (car lst) 16) (lsh (cadr lst) 8) (caddr lst))
  250. )
  251. ;;;===============
  252. ;;;RGB转化成索引号
  253. ;;;===============
  254. (defun RGB->Index (colorObj colRGB / )
  255.   (vla-setRGB colorobj (car colRGB) (cadr colRGB) (caddr colRGB)) 
  256.   (vla-get-ColorIndex colorobj)
  257. )
  258. ;;;===============
  259. ;;;索引号转化成RGB
  260. ;;;===============
  261. (defun Index->RGB (colorobj ci / )
  262.   (vla-put-ColorIndex  colorobj ci)
  263.   (list (vla-get-red   colorobj)
  264.         (vla-get-green colorobj)
  265.         (vla-get-blue  colorobj)
  266.   )
  267. )

发表回复

您的电子邮箱地址不会被公开。 必填项已用*标注