Visual LISP 编程应用实例集
一、 计算类程序
1.计算阶剩值n! (注意：采用了递归方式)
(defun jsen (n)
(if (= n 0) 1 (* n (jsen (1- n)))));
2.迭代计算（
）
(defun ddai (x)
(setq x1 0 x2 x e 1.0e-5 i 0)
(while (> (abs (- x2 x1)) e) (setq x1 x2) (setq x2 (expt (+ x1 1) (/ 1 3.0))) (setq i (1+ i)));while
(print "x=") (princ x2) (print "i=") (princ i)
(princ));end
3.一元二次方程求解(
)
(defun px2 (a b c)
(setq d (- (expt b 2.0) (* 4 a c)))
(cond ((< d 0) (prompt "\nNo root!"))
((= d 0) (progn (setq x (/ b (* -2.0 a))) (prompt "\nOne root! x=") (princ x)))
((> d 0) (progn (setq x1 (/ (- (sqrt d) b) (* 2.0 a)) x2 (/ (+ (sqrt d) b) (* -2.0 a)))
(prompt "\nTwo root! x1=") (princ x1) (prompt " x2=") (princ x2))));cond
(princ));end
4.成绩分析统计
注意：使用该程序前须将全班成绩输入一个数据文件中保存，格式为（78 89 67 ….）
(defun sjfx (fname)
(setq f (open fname "r")) (setq lb nil) (while (setq sd (read-line f)) (setq lb (append lb (read sd))))
(close f) (setq xsum 0) (foreach x lb (setq xsum (+ x xsum))) (setq n (length lb) xb 0)
(setq xbar (/ xsum (* 1.0 n))) (foreach x lb (setq xb (+ xb (* (- x xbar) (- x xbar)))))
(setq xbzc (sqrt (/ xb (* 1.0 n)))) (repeat 18 (terpri))
(prompt "************ 统计结果 ******************") (terpri)
(prompt (strcat " 全班总平均分数 X=" (rtos xbar 2 3))) (terpri)
(prompt (strcat " 标准差 δ=" (rtos xbzc 2 3))) (terpri)
(prompt (strcat " Total number: N=" (rtos n 2 0))) (terpri)
(prompt "****************************************") (terpri)
(princ));end
二、数据检索类
1.根据计算模数检索标准模数值(假定mc为1~10之间的任意值，以实参代入)
(defun jsm (mc)
(setq ml '(1 1.25 1.5 2 2.5 3 4 5 6 8 10)) (setq m 0 n 0)
(while (< m mc) (setq m (nth n ml) n (1+ n)));while
(prompt (strcat "\nm=" (rtos m 2 1)))
(princ));end
2.检索一类数据文件（一类数据文件必须存在，且数据格式必须统一）
(defun js1 (fname kd / ft nt j x)
(setq f (open fname "r")) (setq ft (read (read-line f)) nt (read (read-line f)))
(while (/= kd (car nt)) (setq nt (read (read-line f)))) ;while
(setq j -1) (repeat (length nt) (setq j (1+ j) x (nth j ft)) (set x (nth j nt)))；reapeat
(close f) nt);end
3.检索二类数据文件（二类数据文件必须存在，且数据格式必须统一）
(defun js2 (fname kd / ft nt j x)
(setq f (open fname "r")) (setq ft (read (read-line f)) nt (read (read-line f)))
(while (or (<= kd (car nt)) (> kd (cadr nt))) (setq nt (read (read-line f))));while
(setq j -1) (repeat (length nt) (setq j (1+ j) x (nth j ft)) (set x (nth j nt)));repeat
(close f) nt);end
三、 参数化绘图类
1.绘制正弦曲线函数y=sinx (注意：计算数据存放在表变量lpt中)
(defun ds (/ x0 xe x y pt)
(setq bp (getpoint "\n给出基点:"))
(command "ucs" "o" bp) (setq scx 10 scy 20) (setq x0 0 xe (* pi 2) x 0 y 0) (setq step (/ xe 180.0))
(while (<= x0 (* scx xe)) (setq y (* scy (sin x))) (setq lpt (append lpt (list (list x0 y))))
(setq x0 (+ x0 (* scx step)) x (+ x step)));while
(setq lpt (append lpt (list (list (* scx xe) 0))))
(command "leader" (list (+ (* scx xe) 10) 0) "0,0" "" "" "n")
(command "leader" (list 0 (+ scy 10)) "0,0" "" "" "n")
(command "pline") (foreach pt lpt (command pt)) (command "")
(princ));end
2.装有键的轴或孔的图形绘制（注：平键数据存于二类数据文件jc.dat中）
(defun jcz (d flag / x1 x2 x cp pt1 pt2 pt3 pt4 t1)
(if (not js2) (load "d:/cad_1/js2")) (js2 "d:/cad_1/jc.dat" d)
(initget 6) (setq cp (getpoint "\nCenter point:")) (command "ucs" "o" cp)
(setq x1 (expt (* 0.5 d) 2.0) x2 (expt (* 0.5 b) 2.0)) (setq x (sqrt (- x1 x2)))
(if (= flag 1) (setq t1 tz) (setq t1 (* -1 tk)))
(setq pt1 (list x (* 0.5 b)) pt2 (list (- (* 0.5 d) t1) (* 0.5 b))
pt3 (polar pt2 (* 1.5 pi) b) pt4 (polar pt1 (* 1.5 pi) b))
(command "pline" pt1 "a" "ce" "0,0" pt4 "l" pt3 pt2 pt1 "")
(if (= flag 1) (command "hatch" "u" 45 4 "" "l" "")) (command "layer" "s" "center" "" "" "")
(command "line" (polar '(0 0) pi (+ 3 (* 0.5 d))) (polar '(0 0) 0 (+ 3 (* 0.5 d))) "")
(command "line" (polar '(0 0) (* 0.5 pi) (+ 3 (* 0.5 d))) (polar '(0 0) (* 1.5 pi) (+ 3 (* 0.5 d))) "")
(command "layer" "s" 0 "" "" "") (princ));end
3.绘制阴阳图形
(defun yinyang (r)
(setq bp (getpoint "\nEnter center point:")) (command "color" 2) (command "circle" bp r)
(command "pline" (polar bp (* 0.5 pi) r) "a" bp (polar bp (* 1.5 pi) r) "")
(command "bhatch" "p" "s" (polar bp (* 0.5 pi) (* 0.5 r)) "") (command "color" 1)
(command "bhatch" "p" "s" (polar bp (* 1.5 pi) (* 0.5 r)) "")
);end
4.绘制一个五角星图案
(defun star_5 (r)
(command "color" 1) (setq cp (getpoint "\nCenter point:"))
(setq pt1 (polar cp (* 0.017453 18) r) pt2 (polar cp (* 0.017453 54) r) p2 (polar cp (* 0.5 pi) r))
(setq p1 (inters cp pt2 pt1 (polar pt1 pi r)) p3 (polar cp (* 0.017453 126) (distance cp p1)))
(command "pline" cp p1 p2 p3 cp p2 "") (setq s (ssadd (entlast)))
(command "bhatch" "p" "s" (polar cp (* 0.017453 70) (* 0.2 r)) "") (setq s (ssadd (entlast) s))
(command "color" 2) (command "bhatch" "p" "s" (polar cp (* 0.017453 95) (* 0.2 r)) "")
(setq s (ssadd (entlast) s))
(command "array" s "" "p" cp 5 "" "")
(princ));end
5.绘制图框(n=0,1~5)
(defun tk (n)
(setq lpt '(1189 841 594 420 297 210 148))
(setq l (nth n lpt) b (nth (+ n 1) lpt))
(if (< n 3) (setq c 10) (setq c 5))
(command "rectangle" '(0 0) (list l b))
(command "rectangle" (list 25 c) (list (- l c) (- b c)))
);end
6.绘制参数曲线x=sin2a, y=sin5a [0~2pi]（注意：采用了递归方式）
(defun draw_xy ()
(setq bp (getpoint "\nEnter base point:"))
(command "ucs" "o" bp)
(command "pline" (draw_xy_aux 0)));main
;--------------------------------------------------
(defun draw_xy_aux (a)
(cond ((> a (* 2 pi)) (command "0,0" "" "ucs" "w"))
(t (command (list (sin (* 2.0 a)) (sin (* 5.0 a))))
(draw_xy_aux (+ a 0.05))));cond
);end
7.绘制参数曲线x=sin5a.cosa, y=sin5a.sin4a（注意：采用了数据文件读、写方式）
(defun qx_xy ()
(setq f (open "qx.dat" "w")) (setq a 0)
(while (< a (* 2 pi)) (setq x (* (sin (* 5 a)) (cos a)) y (* (sin (* 5 a)) (sin (* 4 a))))
(princ x f) (princ "," f) (princ y f) (princ "\n" f) (setq a (+ a 0.05)));while
(princ "0,0" f) (close f)
(draw_qx) (princ));main
;-------------------------------------------------
(defun draw_qx ()
(setq bp (getpoint "\nEnter base point:"))
(command "ucs" "o" bp "pline")
(setq f (open "qx.dat" "r"))
(while (setq pt (read-line f)) (command pt))
(close f)
(command "" "ucs" "w")
(princ)
);end
8.绘制由方程y=cos(0.9x)产生的图形（注：计算数据存放于表变量lpt中）
(defun c:spr (/ cp lpt x)
(setq cp (getpoint "\nCenter point:"))
(setq x 0 lpt nil)
(repeat (fix (1+ (/ (* 20 pi) 0.2)))
(setq lpt (append lpt (list (polar cp x (cos (* 0.9 x))))))
(setq x (+ x 0.2)));repeat
(setq lpt (append lpt (list (polar cp (* 20 pi) 1) "")))
(command "pline")
(foreach pt lpt (command pt))
(princ)
);end
四、 对话框编程实例
1．定制对话框
zdbx:dialog{label="带圆正多边形";
:row{:boxed_column{
:edit_box{label="边数";key="number";value=6;}
:edit_box{label="半径";key="rad";value=20;}}
:boxed_column{
:radio_button{label="内接圆";key="nq";}
:radio_button{label="外切圆";key="wq";}}
}
ok_cancel;}
2．程序驱动
(defun dbx ()
(setq id (load_dialog "e:/jscad/zdbx"))
(if (< id 0) (exit))
(if (not (new_dialog "zdbx" id)) (exit))
(action_tile "number" "(set_tile $key $value)")
(action_tile "rad" "(set_tile $key $value)")
(action_tile "nq" "(setq fg 1)")
(action_tile "wq" "(setq fg 0)")
(action_tile "accept" "(qsj) (done_dialog)")
(action_tile "cancel" "(setq what -1) (done_dialog)")
(start_dialog)
(unload_dialog id)
(if (> what 0) (draw_zdbx n r flag))
);end
;----------------------------
(defun draw_zdbx (n r flag)
(setq bp (getpoint "\nBase point:"))
(command "circle" bp r)
(command "polygon" n bp flag r)
)
;---------------------------
(defun qsj ()
(setq n (atoi (get_tile "number")))
(setq r (atof (get_tile "rad")))
(if (= fg 1) (setq flag "i") (setq flag "c"))
(setq what 1)
);end
五．局部菜单设计编程实例
//***MENUGROUP=用户菜单
***POP1
[用户菜单]
[--]
[->平键联接]
[圆头平键]^c^c(if (not aj) (load "d:/cad_1/aj")) (aj)
[半圆头键]^c^c(if (not bj) (load "d:/cad_1/bj")) (bj)
[方型平键]^c^c(if (not cj) (load "d:/cad_1/cj")) (cj)
[键槽轴面]^c^c(if (not jcz) (load "d:/cad_1/jcz")) (jcz 1)
[<-键槽孔面]^c^c(if (not jcz) (load "d:/cad_1/jcz")) (jcz 0)
[~--]
[->图纸幅面]
[A0幅面]^c^crectangle 0,0 1189,841 rectangle 25,10 1179,831
[A1幅面]^c^crectangle 0,0 841,594 rectangle 25,10 831,584
[A2幅面]^c^crectangle 0,0 594,420 rectangle 25,10 584,410
[A3幅面]^c^crectangle 0,0 420,297 rectangle 25,10 410,287
[A4幅面]^c^crectangle 0,0 297,210 rectangle 25,5 287,205
[<-A5幅面]^c^crectangle 0,0 210,147 rectangle 25,5 200,142
[~--]
[标题栏]^C^C(command "insert" "d:/cad_1/btl" pause "" "" pause)
[粗糙度]^C^C(command "insert" "d:/cad_1/czd1" pause "" "" pause)
[基准符号]^c^c(command "insert" "d:/cad_1/jzfh" pause "" "" pause)
[清屏幕]^c^c(if (not cls) (load "d:/cad_1/cls")) cls;
[--]
[圆多边形]^C^C(if (not dbx) (load "e:/jscad/zdbx")) (dbx)
[--]
----------------------------------------------------------------------------------------------------------------
(说明：该程序仅用于《CAD软件二次开发》课程学习参考和上机训练，不得随意传抄)