fractal_dialog5.lsp

关于分形的lisp程序.是曼氏分形和Julia分形的合集.

;;;============
;;;对话框函数集
;;;============

;;;开启新对话框
(defun NewDCL ()
  ;;(new_dialog "fractal" ID)
  (zoom "I3")
  (zoom "I4")
  (action)                       ;设定各按钮动作
  (put_value allkey)
  (addlist "L2" listL2)          ;推荐值列表
  (set_tile "L2" L2)          
  (if (= R1 "T1")                ;若是Mandelbrot
    (mode_tile "A1" 1)           ;则初始值不可用
    (mode_tile "A1" 0)
  )
  (color_init)                   ;初始化颜色值
)
;;;动作函数
(defun action ()
  (action_tile "accept" "(progn (done_dialog 1) (setq option 1))")
  (action_tile "cancel" "(progn (done_dialog 0) (setq option 0))")
  (action_tile "help" "(fractal_help)")  
  (action_tile "P1" "(done_dialog 3)")
  (action_tile "P2" "(done_dialog 2)")
  (action_tile "P3" "(preview)")
  (action_tile "R1" "(choose  $value)")
  (action_tile "R3" "(setq R3 $value)")
  (action_tile "X0" "(setq X0 $value)")
  (action_tile "Y0" "(setq Y0 $value)")
  (action_tile "X1" "(setq X1 $value)")
  (action_tile "Y1" "(setq Y1 $value)")
  (action_tile "X2" "(setq X2 $value)")
  (action_tile "Y2" "(setq Y2 $value)")
  (action_tile "J1" "(setq J1 $value)")
  (action_tile "J2" "(setq J2 $value)")
  (action_tile "J3" "(setq J3 $value)")
  (action_tile "M1" "(setq M1 $value)")
  (action_tile "M2" "(setq M2 $value)")
  (action_tile "M3" "(setq M3 $value)")
  (action_tile "M4" "(setq M4 $value)")
  (action_tile "G1" "(setq G1 $value)")
  (action_tile "L1" "(progn (setq L1 $value) (set_tile \"S1\" L1) (setq S1 L1))")
  (action_tile "L2" "(list2)")
  (action_tile "D1" "(default)")
  (action_tile "D2" "(restore)")
  (action_tile "D3" "(save_Arguments)")
  (action_tile "I1" "(done_dialog  2)")
  (action_tile "I2" "(ImageButton $x $y)")
  (action_tile "I3" "(ZoomScaled 0.25)")
  (action_tile "I4" "(ZoomScaled -0.5)")
)
;;;取得主对话框的各参数值
(defun get_value ()
  (mapcar 'set alllst  (mapcar 'get_tile allkey))
  (setq R2 (list M1 M2 M3 M4))
)
;;;把各参数值填入主对话框
(defun put_value (keylst)
  (foreach n keylst 
    (set_tile n (eval (read n)))
  )
)

;;;初始化颜色RGB值
(defun color_init (/ col2)
  (setq col2 (apply 'strcat (mapcar (function (lambda (x) (strcat x " "))) col1)))
  (setq col2 (substr col2 1 (1- (strlen col2))))
  (set_tile "C2" col2)
  (start_image "I1")
  (fill_image 0 0 IX1 IY1 icol)
  (end_image)
)
;;;添加列表
(defun AddList (key items)
  (start_list key)
  (mapcar 'add_list items)
  (end_list)
)
;;;帮助函数
(defun fractal_help ( / f f1)
  (setq f1 (findfile "fractal_help.txt"))
  (setq f (open f1 "r"))
  (close f)                                ;关闭文件
  (startapp "notepad" f1)                  ;启动记事本打开数据
)
;;;默认值函数
(defun default ()
  (if (= R1 "T1")
    (setq X1 "-2.25"
	  X2 "0.75"
	  X0 "0"
	  Y0 "0"
    )
    (setq X1 "-1.50"
	  X2 "1.50"
	  X0 "0"
	  Y0 "0.66"
    )
  )
  (setq	Y1 "-1.50"
	Y2 "1.50"
	J1 "255"
	J2 "256 256"
	J3 "20"
	G1 "3"
	M1 "1"
	M2 "0"
	M3 "0"
	M4 "0"
	R3 "T3"
	S1 "2"
	L1 "2"
	L2 "0"
  )
  (put_value allkey)
)
;;;开关状态
(defun key_status (keylst k)
  (foreach n keylst
    (mode_tile n k)
  )
)
(defun choose (s)
  (if (= s "T1") 
    (mode_tile "A1" 1) 
    (mode_tile "A1" 0)
  )
  (setq R1 s)
)
;;;推荐列表函数
(defun list2 (/ L3)
  (setq L3 (atoi $value))
  (setq L3 (nth L3 listL2))
  (setq L3 (vl-string-subst "\" \"" " " L3))
  (setq L3 (read (strcat "(\"" L3 "\")")))
  (setq X0 (car  L3))
  (setq Y0 (cadr L3))
  (set_tile "X0" X0)
  (set_tile "Y0" Y0)
  (setq L2 $value)
)
;;;恢复上次函数
(defun restore (/ catchit)
  (setq catchit (vl-catch-all-apply 'last_time)) 
  (if (vl-catch-all-error-p catchit)
    (alert "读参数文件错误!")
  )
)
(defun last_time (/ saved_file file last_value)
  (setq last_value nil)
  (if 
    (and
      (setq saved_file (vl-registry-read "HKEY_CURRENT_USER\\Fractal"))
      (setq file (open saved_file "r"))
      (while (setq n (read-line file))
        (setq last_value (cons n last_value))
      )
      (setq last_value (reverse last_value))
    )  
    (progn
      (close file)
      (mapcar 'set_tile allkey last_value)	
      (get_value)
      (choose R1)  
      (setq col0 (car last_value))
      (setq col0 (strcat "(" col0 ")"))
      (setq col0 (read col0))
      (setq col1 (mapcar 'itoa col0))
      (setq icol (rgb->index colObj col0))
      (color_init)
    )
    (alert "没有存储上次的!")
  )
)
;;;保存参数函数
(defun save_Arguments (/ last_value saved_file file)
  (setq last_value (mapcar 'eval alllst))
  (if (setq saved_file (getfiled "保存分形参数" "C:\\" "txt" 1))
    (progn 
      (setq file (open saved_file "w"))
      (foreach n last_value
        (princ n file)
        (princ "\n" file)
      )
      (close file)                                ;关闭文件
      (vl-registry-write "HKEY_CURRENT_USER\\Fractal" "" saved_file)
      saved_file
    )
  )
)
;;;画放大缩小按钮函数
(defun zoom (key / x+ y+ cenX cenY rad ang i j)
  (start_image key)
  (setq x+ (dimx_tile key))
  (setq y+ (dimx_tile key))
  (setq cenX (fix (/ x+ 2)))
  (setq cenY (fix (/ y+ 2)))
  (setq rad  (- (min cenx ceny) 2))
  (fill_image 0 0 x+ y+ 7)
  (setq ang (/ PI 0.5 60))
  (setq i 0)
  (repeat 60
    (vector_image
      (fix (+ (* Rad (cos (* ang (- i 0.5)))) cenX))
      (fix (+ (* Rad (sin (* ang (- i 0.5)))) cenY))
      (fix (+ (* Rad (cos (* ang (+ i 0.5)))) cenX))
      (fix (+ (* Rad (sin (* ang (+ i 0.5)))) cenY))
      0
    )
    (setq i (1+ i))
  )
  (vector_image (- cenx rad -2) ceny (+ ceny rad -2) ceny 0)
  (if (= key "I3")
    (vector_image cenx (- ceny rad -2) cenx (+ ceny rad -2) 0)
  )
  (end_image)
)
;;;放大缩小函数
(defun ZoomScaled (n / oldx1 oldx2 oldy1 oldy2 dx dy)
  (and
    X1 Y1 X2 Y2
    (setq oldx1 (atof x1))
    (setq oldx2 (atof x2))
    (setq oldy1 (atof y1))
    (setq oldy2 (atof y2))
    (setq dx (- oldx2 oldx1))
    (setq dy (- oldy2 oldy1)) 
    (set_tile "X1" (rtos (+ oldx1 (* dx n)) 2 20))
    (set_tile "Y1" (rtos (+ oldy1 (* dy n)) 2 20))
    (set_tile "X2" (rtos (- oldx2 (* dx n)) 2 20))
    (set_tile "Y2" (rtos (- oldy2 (* dy n)) 2 20))
    (preview)
  ) 
)
;;;============
;;;点取界限函数
;;;============
(defun getlimits (/ lx1 lx2 ly1 ly2 pt1 pt2 L&B R&U)
  (if
    (and
      (setq sol (read (strcat "(" J2 ")")))                ;分辨率
      (if (null (cadr sol))
	(setq sol (list (car sol) (car sol)))
	(setq sol sol)
      )	
      (= (type (car  sol)) 'INT)
      (> (car  sol) 0)
      (= (type (cadr sol)) 'INT)
      (> (cadr sol) 0)                                     ;分辨率参数有效
      (if (= R1 "T2")	                                   ;类型
        (setq lx1 (* (car  sol) -1.50)
	      lx2 (* (car  sol)  1.50)
	      ly1 (* (cadr sol) -1.50)
	      ly2 (* (cadr sol)  1.50)
	)
        (setq lx1 (* (car  sol) -2.25)
	      lx2 (* (car  sol)  0.75)
	      ly1 (* (cadr sol) -1.50)
	      ly2 (* (cadr sol)  1.50)
	)	
      )
      (null
	(vla-zoomwindow
	  *APP
	  (vlax-3d-point (list lx1 ly1))
	  (vlax-3d-point (list lx2 ly2))
	)
      )
      (null (vla-zoomscaled *APP 0.8 acZoomScaledRelative));放大图形
      (entmake
	(list
	  '(0 . "LWPOLYLINE")
	  '(100 . "AcDbEntity")
	  '(100 . "AcDbPolyline")
	  '(90 . 4)
	  '(62 . 1)
	  (cons 10 (list lx1 ly1))
	  (cons 10 (list lx2 ly1))
	  (cons 10 (list lx2 ly2))
	  (cons 10 (list lx1 ly2))
	  '(70 . 1)
	)
      )                                                    ;画范围框
      (null (initget 33))
      (setq pt1 (getpoint "\n选取第一点:"))
      (null (initget 33))
      (setq pt2 (getpoint "\n选取第二点:"))
      (setq L&B (mapcar '/ pt1 sol))
      (setq R&U (mapcar '/ pt2 sol))
      (null (vla-delete(vlax-ename->vla-object (entlast))));删除范围框
    )
    (progn                                                 ;得到范围参数
      (new_dialog "fractal" ID)
      (NewDCL)                                             
      (set_tile "X1" (rtos (car  L&B) 2 20))
      (set_tile "Y1" (rtos (cadr L&B) 2 20))
      (set_tile "X2" (rtos (car  R&U) 2 20))
      (set_tile "Y2" (rtos (cadr R&U) 2 20))    
    )
    (progn
      (alert "绘制范围或图像像素参数无效!")
      (new_dialog "fractal" ID)
      (NewDCL)
    )
  )
)
;;;============
;;;选取颜色函数
;;;============
(defun pick_color ()
  (if (setq c1 (acad_TrueColorDlg 10))
    (if (setq c0 (cdr (assoc 420 c1)))
      (setq icol (cdr (assoc 62 c1))
	    col0 (Number->RGB C0)
	    col1 (mapcar 'itoa col0)
      )
      (setq icol (cdr (assoc 62 c1))
	    col0 (Index->RGB colObj icol)
	    col1 (mapcar 'itoa col0)
      )
    )
  )
)
;;;============
;;;图像预览函数
;;;============
(defun Preview (/ time)
  (get_value)
  (start_image "I2")
  (fill_image 0 0 IX2 IY2 -2)
  (if (check)
    (progn
      (setq t0 (getvar "TDUSRTIMER"))
      (if (= R1 "T1")
	(Mandelbrot J1 (list IX2 IY2) J3 X0 Y0 X1 Y2 X2 Y1 col0 G1 R2 R3 1 S1)
	(Julia J1 (list IX2 IY2) J3 X0 Y0 X1 Y2 X2 Y1 col0 G1 R2 R3 1 S1)
      )
      (princ "\n预览分形用时")
      (princ (setq time (* (- (getvar "TDUSRTIMER") t0) 86400)))
      (princ "秒\n")
    )
    (alert "参数输入有误!")
  )
  (end_image)
  (get_value)
  (setq option 4)
)
;;;============
;;;参数值的检查
;;;============
(defun check ()
 (and J1 J2 J3 X0 Y0 X1 Y1 X2 Y2 col0 G1
      (setq J1 (abs (fix (atof J1))))     ;迭代次数
      (> J1 1)
      (setq J2 (read (strcat "(" J2 ")")));分辨率
      (if (null (cadr J2))
	(setq J2 (list (car J2) (car J2)))
	(setq J2 J2)
      )
      (= (type (car  J2)) 'INT)           
      (> (car  J2) 0)               
      (= (type (cadr J2)) 'INT)
      (> (cadr J2) 0) 
      (setq J3 (abs (atof J3)))           ;逃逸半径
      (> J3 1)
      (setq X0 (atof X0))                 ;初始值X0
      (setq Y0 (atof Y0))                 ;初始值Y0
      (setq X1 (atof X1))                 ;左下角X1
      (setq X2 (atof X2))                 ;左下角Y1
      (not (equal X1 X2 1e-16))           ;不能相等
      (setq Y1 (atof Y1))                 ;右上角X2
      (setq Y2 (atof Y2))                 ;右上角Y2
      (not (equal Y1 Y2 1e-16))           ;不能相等
      (setq G1 (abs (fix (atof G1))))     ;颜色梯度
      (>= G1 0)
      (setq R2 (list M1 M2 M3 M4))
  )
)
;;;============
;;;图像按钮函数
;;;============
(defun ImageButton ($x $y / minxx maxxx minyy maxyy)
  (setq TX1 (atof X1))
  (setq TX2 (atof X2))
  (setq TY1 (atof Y1))
  (setq TY2 (atof Y2))
  (setq lxx (- TX2 TX1))
  (setq lyy (- TY2 TY1))
  (setq xx1 $X)
  (setq yy1 $y)
  (if (= j 0)
    (setq xx2 xx1 yy2 yy1 j (1+ j))
    (progn
      (setq minxx (min xx1 xx2))
      (setq maxxx (max xx1 xx2))
      (setq minyy (min yy1 yy2))
      (setq maxyy (max yy1 yy2))
      (start_image "I2")
      (vector_image xx1 yy1 xx2 yy1 1)
      (vector_image xx2 yy1 xx2 yy2 1)
      (vector_image xx2 yy2 xx1 yy2 1)
      (vector_image xx1 yy2 xx1 yy1 1)
      (end_image)
      (setq dx1 (+ TX1 (* lxx (/ minxx IX2 1.0))))
      (setq dy1 (+ TY1 (* lyy (/ (- IY2 maxyy) IY2 1.0))))
      (setq dx2 (+ TX1 (* lxx (/ maxxx IX2 1.0))))
      (setq dy2 (+ TY1 (* lyy (/ (- IY2 minyy) IY2 1.0))))
      (setq X1 (rtos dx1 2 20))
      (setq Y1 (rtos dy1 2 20))
      (setq X2 (rtos dx2 2 20))
      (setq Y2 (rtos dy2 2 20))
      (set_tile "X1" X1)
      (set_tile "Y1" Y1)
      (set_tile "X2" X2)
      (set_tile "Y2" Y2)
      (setq j 0)
    )
  )
)