[wkq004]由三角网生等高线-我的Alisp之路
由三角网生等高线-我的Alisp之路知道明经通道是2003的事.当时学校开设了CAD课程,同学在宿舍告诉我明经通道上有cad学习资料的一幕,到现在我还记忆犹新.我学的是测绘,毕业后一直从事外业.当时用的绘图软件主要是MS,MS几乎通过点鼠标完成所有工作.用cad只是转个文档格式,画接合表,点之记之类的.但我还是喜欢cad的命令栏,可以输一些"高深"的命令,达到目的.所以在工作的间隙我会试用cad的功能,翻看cad帮助.到2005年有幸看到一本cad的教材,上面有cad的定制,alisp入门,和dcl对话框,当时特别新奇,就抽空翻完了此书,当时的项目不太需要电脑,20人4台电脑,根本没有时间练习.在2005年年底去买书,可选择性太少,仅找到一本lisp教材,是张帆前辈的<AutoCAD2002开发教程>,就一直带在身边抽空看,看着很吃力,到现在看我还是觉得那本书不适合入门.有一天在看GPS基站,就静下心来反复读,看明白了DCL部分,让我兴奋了一把.有时也会去逛逛论坛,晓东的测绘板块较丰富,发过一些帖子.直到2008才有时间好好看alisp,在西安的汉唐书城买到一本李学志的<Visual LISP程序设计>,这本书很适合当时的我,就认认真真的一口气学完了,算是alisp入了门,同时也开始疯狂的上网看帖,加QQ群,加的第一个是由zml84创建的 摆渡者LISP 群很活跃,得到了zml84简洁给力的指点,和xyp1964不少的调侃和偷笑(表情),当时活跃的不少群友已成为了高手.从此以后就不时的写一些工作中能用到的小程序,挖掘一些能用程序实现的工序.曾经很疯狂的看测绘方面的帖子,差不多读遍了晓东和明经上所有的测绘贴.由于水平有限,没好意思跟贴,当最近觉得顶贴也是一种支持时,才开始跟帖,以至于2006年注册的号到今年才有第一贴.
我才疏学浅,很仰望各位大侠,请不吝赐教!我感激不尽!
下帖功能已实现,求更快算法.
;|功能:由三角网生等高线
日期:wkq004@qq.com于2012-12-9
参考:明经通道yfy2003[测绘]不规则点建立TIN和等高线的方法！
http://bbs.mjtd.com/thread-15199-1-1.html
算法描述:
基于三角形搜索的等高线绘制算法如下：
对于记录了三角形表的TIN，按记录的三角形顺序搜索。其基本过程如下：
1）对给定的等高线高程h，与所有网点高程zi（i=1,2,?，n），进行比较，
若zi=h，则将zi加上（或减）一个微小正数ε> 0（如ε=10-4），
以使程序设计简单而又不影响等高线的精度。
2）设立三角形标志数组，其初始值为零，每一元素与一个三角形对应，
凡处理过的三角形将标志置为1，以后不再处理，直至等高线高程改变。
3）按顺序判断每一个三角形的三边中的两条边是否有等高线穿过。
若三角形一边的两端点为P1（x1，y1，z1），P2（x2，y2，z2）则
(z1-h)(z2-h)<0表明该边有等高线点；
(z1-h)(z2-h)>0表明该边无等高线点。
直至搜索到等高线与网边的第一个交点，称该点为搜索起点，
也是当前三角形的等高线进入边、线性内插该点的平面坐标（x，y）：
4）搜索该等高线在该三角形的离去边，也就是相邻三角形的进人边，并内插其平面坐标。
搜索与内插方法与上面的搜索起点相同，不同的只是仅对该三角形的另两边作处理。
5）进入相邻三角形，重复第（4）步，直至离去边没有相邻三角形（此时等高线为开曲线）
或相邻三角形即搜索起点所在的三角形（此时等高线为闭曲线）时为止。
6）对于开曲线，将已搜索到的等高线点顺序倒过来，并回到搜索起点向另一方向搜索，
直至到达边界（即离去边没有相邻三角形）。
7）当一条等高线全部跟踪完后，将其光滑输出，方法与前面所述矩形格网等高线的绘制相同。
然后继续三角形的搜索，直至全部三角形处理完，再改变等高线高程，
重复以上过程，直到完成全部等高线的绘制为止。|;
(vl-load-com)
(setq myms (vla-get-ModelSpace
(vla-get-ActiveDocument (vlax-get-acad-object))
)
)
(defun mk2polyline (pts bh / lenn pts my2dpoly)
;;功能:生成二次拟合的二维多段线
;;参数:pts点表bh 闭合否T nil
;;返回:未指定
;;全局变量:elev 高程
;;日期:wkq004@qq.com于2012-12-9
(setq pts (apply 'append pts))
(setq lenn (length pts))
(setq pts (vlax-safearray-fill
(vlax-make-safearray vlax-vbDouble (cons 0 (1- lenn)))
pts
)
)
(setq my2dpoly (vla-AddPolyline myms (vlax-make-variant pts)))
(vla-put-Elevation my2dpoly elev) ;_标高
(if bh
(vla-put-Closed my2dpoly T) ;_闭合
)
(if (> lenn 6)
(vla-put-type my2dpoly acQuadSplinePoly) ;_二次拟合
)
)
(defun funptxlb (xlb2 / A AZ B BZ DIST DT GAO GAOC PT)
;;功能:计算边与等高线相交的控制点坐标.
;;参数:xlb2 三角形的进入边(点1 点2)
;;返回:未指定
;;全局变量:ptlst 同一条线的点集
;;日期:wkq004@qq.com于2012-12-9
(setq a (car xlb2))
(setq b (cadr xlb2))
(setq az (caddr a))
(setq bz (caddr b))
(setq a (list (car a) (cadr a) 0))
(setq dist (distance a (list (car b) (cadr b))))
(setq gaoc (abs (- az bz)))
(setq gao (abs (- az elev)))
(setq dt (* dist (/ gao gaoc)))
(setq pt (polar a (angle a b) dt))
(setq ptlst (append ptlst (list pt)))
)
(defun c:tt (/ DGJ ELEV MAXZ MINZ PTLST SJXELST SJXLBLST SJXNLST SJXNNN
sjxlbnn sjxlbn SS
)
;;功能:由三角网生等高线
;;参数:xlb2 三角形的进入边(点1 点2)
;;返回:未指定
;;全局变量:ptlst 同一条线的点集
;;日期:wkq004@qq.com于2012-12-9
(command ".undo" "end")
(command ".undo" "begin")
(defun sdgx (/ ABBC ELEV GCNUM I)
;;生等高线
;;全局变量:等高距 dgj 等高线最小值minz 等高线最大值maxz
(defun chuan (i3 / A AZ B BZ C CZ E JG1 JG2)
;;功能:搜索三角形是否有给定高程的等高线穿过
;;参数:i3 三角形的编号
;;返回:穿过:返回穿过边的两点表 不穿过:返回nil
;;全局变量:elev高程 sjxsdlst存放三角形三点的表
;;日期:wkq004@qq.com于2012-12-9
(setq e (nth i3 sjxsdlst))
(setq a (car e))
(setq b (cadr e))
(setq c (caddr e))
(setq az (caddr a)) ;_顶点z坐标
(setq bz (caddr b))
(setq cz (caddr c))
(if (< (* (- az elev) (- bz elev)) 0)
(if (< (* (- cz elev) (- az elev)) 0)
(list (list a b) (list c a))
(list (list a b) (list b c))
)
(if (< (* (- cz elev) (- az elev)) 0)
(list (list c a) (list b c))
nil
)
)
)
(defun funxlb (aa / ab cd)
;;功能:判断经过的三角形是否为将要连接
;;参数:由等高线穿过的两边组成的表
;;返回:是将要连接的返回离开边,否则返回原进入边
;;全局变量:sjxnlst三角形编号表 sjxsdlst存放三角形三点的表
;;日期:wkq004@qq.com于2012-12-9
(setq ab (car aa))
(setq cd (cadr aa))
(cond ((or (equal xlb ab 0.001)
(equal xlb (list (cadr ab) (car ab)) 0.001)
)
(setq sjxnlst (subst -1 (nth io sjxnlst) sjxnlst))
(funptxlb cd)
(setq io qsi)
cd
)
((or (equal xlb cd 0.001)
(equal xlb (list (cadr cd) (car cd)) 0.001)
)
(setq sjxnlst (subst -1 (nth io sjxnlst) sjxnlst))
(funptxlb ab)
(setq io qsi)
ab
)
(T xlb)
)
)
(setq dgj 1) ;_等高距
(setq minz (* (+ 1 (fix (/ minz dgj))) dgj)) ;_最小Z
(setq maxz (* (fix (/ maxz dgj)) dgj)) ;_最大Z
(setq gcnum (+ 1 (/ (- maxz minz) dgj))) ;_高差算出等高线数量
(setq elev minz) ;_从最小的高程画起
(repeat gcnum ;_等高线数量
;;(maxz minz sjxelst sjxlblst sjxnlst sjxnnn)
(setq qsi 0)
(setq io 0)
(setq ptlst '())
(setq sjxnlst sjxnnn) ;_本条等高线的三角形编号表
(setq len (length sjxnlst))
(while (< io len)
;;寻找每条线的起始三角形
(if (setq abbc (chuan io))
(progn
(setq sjxnlst (subst -1 (nth io sjxnlst) sjxnlst))
(setq qsi io)
(setq qsbian (car abbc))
(setq xlb (cadr abbc))
(funptxlb qsbian)
(funptxlb xlb)
;;寻找相邻三角形
(while (or (while (= -1 (nth (setq io (+ io 1)) sjxnlst)))
(< io len)
)
(if (setq abbc (chuan io))
(setq xlb (funxlb abbc))
(setq sjxnlst (subst -1 (nth io sjxnlst) sjxnlst))
)
)
;;第一个方向搜索完后判断等高线是否闭合
(if (equal (car ptlst) (last ptlst) 0.001)
(progn (setq ptlst (cdr ptlst))
(mk2polyline ptlst T) ;_闭合
(setq ptlst '())
)
;;不闭合就对点表反向用起始边从另一个方向搜索,直到所有三角形搜索完毕
;;生成不闭合的等高线.
(progn
(setq io qsi)
(while (= -1 (nth (setq io (+ io 1)) sjxnlst)))
(setq qsi (1- io))
(if (< io len)
(progn
(setq ptlst (reverse ptlst))
(setq xlb qsbian)
(setq io qsi)
(while
(or (while (= -1 (nth (setq io (+ io 1)) sjxnlst)))
(< io len)
)
(if (setq abbc (chuan io))
(setq xlb (funxlb abbc))
(setq
sjxnlst (subst -1 (nth io sjxnlst) sjxnlst)
)
)
)
)
)
(mk2polyline ptlst nil) ;_不闭合
(setq ptlst '())
)
)
(setq io qsi)
(while (= -1 (nth (setq io (+ io 1)) sjxnlst)))
)
(progn (setq sjxnlst (subst -1 (nth io sjxnlst) sjxnlst))
(setq io (+ io 1))
)
)
)
;;高程累加一个等高距
(setq elev (+ elev dgj))
)
)
(defun sjzl (/ E EL EMAIN EXDATA EXPTLST I A B C PTZ)
;;数据整理(sjxelst sjxnlst sjxddlst ddsjxlst bxllst sjxsblst /)
;;全局变量 maxz minz sjxelst sjxlblst sjxnlst sjxnnn
(setq sjxnlst'() ;_三角形编号表
sjxsdlst '() ;_三角形与编号对应的三角形三点表
i -1
minz 9999
maxz -9999
sjxnnn '()
sjxnnn (repeat (sslength ss)
(setq sjxnnn (append sjxnnn (list (setq i (+ 1 i)))))
) ;_三角形原始编号表
i -1
)
(repeat (sslength ss)
(setq e (ssname ss (setq i (+ 1 i))))
(defun qpt (ee / el pt ptz)
;;求三角形的顶点坐标
(setq e (entnext ee))
(setq el (entget e))
(setq pt (cdr (assoc '10 el)))
(setq ptz (caddr pt))
(if (< ptz minz)
(setq minz ptz)
(if (> ptz maxz)
(setq maxz ptz)
)
)
pt ;_返回
)
(setq a (qpt e))
(setq b (qpt e))
(setq c (qpt e))
(setq sjxsdlst (append sjxsdlst (list (list a b c))))
)
)
(if (setq ss (ssget '((0 . "POLYLINE") (8 . "SJW"))))
(progn (setq ti (car (_VL-TIMES))) ;_获得程序开始时间
(sjzl)
(sdgx)
(setq time (strcat "\n "
(rtos (/ (- (car (_VL-TIMES)) ti) 1000.) 2 4)
" secs."
)
) ;_计算程序耗时
(setq fl (open "d:\\111.txt" "a"))
(print time fl)
)
)
(command ".undo" "end")
(princ)
) ;_程序完毕
004 发表于 2013-4-11 11:33 static/image/common/back.gif
发个关于动态生等高线的，还没弄完，先给大家看看吧，请高手提供，不用command trim的裁切算法。
要求参看 ...
大侠，试用该插件，到第二步总是失败
命令: tt1
选择高程点...
选择对象: 指定对角点: 找到 464 个
已滤除 232 个。
选择对象:
0.1720 secs.
nil nil
命令: tt2
选择对象: 指定对角点: 找到 917 个
已滤除 467 个。
选择对象:
AAAAAAAAAAAAA; 错误: 参数类型错误: consp <Selection set: 7d>
不解 向高手学习 三角网编辑主要是能加特征线，这样三角网才会合理，不然会很失真。不知楼主在这方面怎么处理的。 gzxl 发表于 2012-12-11 10:38
前段时间在theswamp看到这么个思路:
(1) 用LWPOLYLINE全部将每个三角网的等值点勾绘出
说的对啊 本帖最后由 004 于 2012-12-16 01:01 编辑
再贴个再论坛上找到的生三角网的程序，很快，最后一个子程序的算法，看了几遍都晕，还望大侠指点。
(defun c:tt (/ i pl s)
;;;-------------------------------------------------------------------
;;;来自:明经通道网站 作者:雷锋
;;;功能:用高程点生成三角网
;;;参数:pl 点集
;;;分类:专业程序-测绘-高程点-三角网-TIN
(princ (strcat "\n选择高程点..."))
(setq lstlst '())
(setq delsl (ssadd))
(if (setq i 0
s (ssget '((8 . "GCD") (0 . "INSERT") (2 . "GC200")))
)
(progn (repeat (sslength s)
(setq pl (cons (cdr (assoc 10 (entget (ssname s i)))) pl)
i(1+ i)
)
)
(triangulate pl)
)
)
(print lstlst)
)
(defun triangulate (pl / a b c i i1 i2 bb sl al el tl L ma mi ti tr x1
x2 y1 y2 p r cp)
(if pl
(progn
(setq ti (car (_VL-TIMES));_获取时间
i1
i1 (/ (length pl) 100.)
i2 0
pl (vl-sort pl (function (lambda (a b) (< (car a) (car b)))));_将点集按x坐标从小到大排序
bb (list (apply 'mapcar (cons 'min pl));_取得点集X的最小坐标Y的最小坐标
(apply 'mapcar (cons 'max pl));_取得点集X的最大坐标Y的最大坐标
)
x1 (caar bb);_x方向最小值
x2 (caadr bb);_x方向最大值
y1 (cadar bb);_y方向最小值
y2 (cadadr bb);_y方向最大值
)
(command "rectang" (car bb) (cadr bb))
(command "text" (car bb) "" "" "x1 y1")
(command "text" (cadr bb) "" "" "x2 y2")
(setq cp (list (/ (+ x1 x2) 2.0) (/ (+ y1 y2) 2.0));_点集的中心点平面坐标
r(* (distance cp (list x1 y1)) 20);_搜索半径,中心点到左下角点的20倍
ma (+ (car cp) r);_x最大设为中心点x加r
mi (- (car cp) r);_x最小设为中心点x减r
sl (list (list ma (cadr cp) 0);_初始化 x最大 y中心 0
(list mi (+ (cadr cp) r) 0);_初始化x最小 y最大 0
(list mi (- (cadr cp) r) 0);_初始化x最小 y最小 0
)
al (list (cons x2 (cons cp (cons (* 20 r) sl))));_((x大 (中心点) r*20 (x最大y中心 0) (x最小 y最大 0) (x最小 y最小 0)))
ma (1- ma);_ ((2.55524e+007 (2.55523e+007 4.29672e+006) 13900.2 (2.5553e+007 4.29672e+006 0) (2.55516e+007 4.29742e+006 0) (2.55516e+007 4.29603e+006 0)))
mi (1+ mi)
)
;;; (command "circle" cp 2)
;;; (command "circle" cp r)
;;; (command "pline" (car sl) "h" 2 0 (cadr sl) (caddr sl) "")
;;; (command "text" cp "" "" "cp")
;;;
;;; (command "text" (car sl) "" "" "sl-1")
;;; (ssadd (entlast) delsl)
;;; (command "text" (cadr sl) "" "" "sl-2")
;;; (ssadd (entlast) delsl)
;;; (command "text" (caddr sl) "" "" "sl-3")
;;; (ssadd (entlast) delsl)
;;; (command "pline" (car sl) (cadr sl) (caddr sl) (car sl) "")
(repeat (length pl)
(setq p (car pl);_点集中的第一个点
pl (cdr pl)
el nil
)
(while al
(setq tr (car al);_(x大 (中心点) r*20 (x最大y中心 0) (x最小 y最大 0) (x最小 y最小 0))
al (cdr al);_((中心点) r*20 (x最大y中心 0) (x最小 y最大 0) (x最小 y最小 0))
)
(cond ((< (car tr) (car p)) (setq tl (cons (cdddr tr) tl)));_x大小于p的x
((< (distance p (cadr tr)) (caddr tr))
;;p到中心点cp的距离小于r*20
(setq tr (cdddr tr);_((x最大y中心 0) (x最小 y最大 0) (x最小 y最小 0))
a(car tr);_(x最大y中心 0)
b(cadr tr);_(x最小 y最大 0)
c(caddr tr);_(x最小 y最小 0)
el (cons
(list (+ (car a) (car b)) (+ (cadr a) (cadr b)) a b)
(cons (list (+ (car b) (car c))
(+ (cadr b) (cadr c))
b
c
)
(cons (list (+ (car c) (car a))
(+ (cadr c) (cadr a))
c
a
)
el
)
)
);_((ax+bx ay+by a b) (bx+cx by+cy b c) (cx+ax cy+ay c a))
)
)
(t (setq L (cons tr L)))
)
;;; (command "text" a "" "" "a")
;;; (command "text" b "" "" "b")
;;; (command "text" c "" "" "c")
;;; (command "pline" a "h" 2 0 b c a"")
)
(setq al L
L nil
el (vl-sort el
(function (lambda (a b)
(if (= (car a) (car b))
(<= (cadr a) (cadr b))
(< (car a) (car b))
)
)
)
);_用x的和排序,相等的再用y排
)
(while el
(if (and (= (caar el) (caadr el)) (= (cadar el) (cadadr el)))
(setq el (cddr el));_如ax+bx=bx+cx 且ay+by=by+cy
(setq al (cons (getcircumcircle p (cddar el)) al);_传入p 和 a b
el (cdr el)
)
)
)
(if (and (< (setq i (1- i)) 1) (< i2 100))
(progn (setvar "MODEMACRO"
(strcat "◎正在连三角网"
(itoa (setq i2 (1+ i2)))
" % "
(substr "..." 1 (- 100 i2))
)
)
(setq i i1)
)
)
)
(foreach tr al (setq tl (cons (cdddr tr) tl)))
(setq tl
(vl-remove-if-not
(function (lambda (a)
(and (< mi (caadr a) ma) (< mi (caaddr a) ma))
)
)
tl
)
)
(or (tblsearch "LAYER" "SJW")
(entmake (list '(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(2 . "SJW")
'(70 . 0)
'(62 . 8)
'(6 . "Continuous")
'(290 . 1)
'(370 . -3)
)
)
)
(setvar "CLAYER" "SJW")
(foreach tr tl
(entmake '((0 . "POLYLINE")
(8 . "SJW")
(100 . "AcDb3dPolyline")
(70 . 9)
(62 . 5)
)
)
(setq a (car tr))
(setq b (cadr tr))
(setq c (caddr tr))
(entmake
(list '(0 . "VERTEX") (cons 10 (car tr)) '(70 . 32))
)
(entmake
(list '(0 . "VERTEX") (cons 10 (cadr tr)) '(70 . 32))
)
(entmake
(list '(0 . "VERTEX") (cons 10 (caddr tr)) '(70 . 32))
)
(entmake (list '(0 . "SEQEND")))
)
)
)
(setvar "MODEMACRO" "")
(princ (strcat "\n "
(rtos (/ (- (car (_VL-TIMES)) ti) 1000.) 2 4)
" secs."
)
)
(princ)
)
;;这段麻烦哪位高人详细讲解下算法,我看了几遍还是晕.
(defun getcircumcircle (a el / b c c2 cp r ang)
(setq b(car el)
c(cadr el)
c2 (list (car c) (cadr c))
)
;;;(command "pline" a "h" 2 0 b c "")
(if (not (zerop (setq ang (- (angle b c) (angle b a))))) ;_a b c不在同一方向的直线上
(progn (setq cp (polar c2
(+ -1.570796326794896 (angle c a) ang)
(setq r (/ (distance a c2) (sin ang) 2.0))
)
r(abs r)
)
;;; (command "circle" cp r)
(list (+ (car cp) r) cp r a b c)
)
)
)
选择三角网
选择对象: 指定对角点: 找到 11904 个
选择对象:
程序运行用时16.3600 secs.
南方都有这个功能了，，，， 前段时间在theswamp看到这么个思路:
(1) 用LWPOLYLINE全部将每个三角网的等值点勾绘出
(2) 再用加强的PEDIT连接
(3) 线型转换处理
速度超快的,10000个三角网形成等值线10秒不到
不知这种方法行否？
回复三楼的
南方有此功能只是代表你会使用 gzxl 发表于 2012-12-11 10:38 static/image/common/back.gif
前段时间在theswamp看到这么个思路:
(1) 用LWPOLYLINE全部将每个三角网的等值点勾绘出
这个方法好,我想试试用生成lwpolyline短线的点表直接组织点集,估计会更快点,但对大量点表的穷举判断也是很耗时的,等会我先写出来再让大侠们优化. 004 发表于 2012-12-11 14:58 static/image/common/back.gif
这个方法好,我想试试用生成lwpolyline短线的点表直接组织点集,估计会更快点,但对大量点表的穷举判断也是很 ...
肯定快很多的，你试试 今天写不完了,先贴出来松口气,,顺便问大侠个问题:我用lst= ("1" "2" "3" ...)表中的名字创建了多个变量,程序运行结束后我怎么释放这些变量名呢??(foreach a lst (set (read a) a) )
;|功能:由三角网生等高线
日期:wkq004@qq.com于2012-12-9
算法描述:
基于三角形搜索的等高线绘制算法如下：
|;
(vl-load-com)
(defun mk2polyline (pts bh / lenn pts my2dpoly)
;;功能:生成二次拟合的二维多段线
;;参数:pts点表bh 闭合否T nil
;;返回:未指定
;;全局变量:elev 高程
;;日期:wkq004@qq.com于2012-12-9
(setq pts (apply 'append pts))
(setq lenn (length pts))
(setq pts (vlax-safearray-fill
(vlax-make-safearray vlax-vbDouble (cons 0 (1- lenn)))
pts
)
)
(setq my2dpoly (vla-AddPolyline myms (vlax-make-variant pts)))
(vla-put-Elevation my2dpoly elev) ;_标高
(if bh
(vla-put-Closed my2dpoly T) ;_闭合
)
(if (> lenn 6)
(vla-put-type my2dpoly acQuadSplinePoly) ;_二次拟合
)
)
(defun c:tt (/ A ABLST B BCLST C CALST DGJ E ELEVG ELEVGLST END FL FUN
FX G I JO LEN LINE LINELST N NN ONE PTLST QSI SS START TI
TIME TWO XH Y
)
(command ".undo" "end")
(command ".undo" "begin")
(setq myms (vla-get-ModelSpace
(vla-get-ActiveDocument (vlax-get-acad-object))
)
)
(if (setq ss (ssget '((0 . "POLYLINE") (8 . "SJW"))))
(progn
(setq ti (car (_VL-TIMES))) ;_获得程序开始时间
(setq dgj 1) ;_等高距
(setq i -1)
(repeat (sslength ss)
(setq e (ssname ss (setq i (+ 1 i))))
(defun qpt (ee / el pt ptz)
;;求三角形的顶点坐标
(setq e (entnext ee))
(setq el (entget e))
(setq pt (cdr (assoc '10 el)))
)
(setq a (qpt e))
(setq b (qpt e))
(setq c (qpt e))
(defun bianpt (a b / ANG AZ BZ DIST DT ELEV GAOC GCNUM MAXZ MINZ
PT TMP
)
(setq y t) ;_等高线是否经过
(setq az (caddr a))
(setq bz (caddr b))
(if (< az bz)
()
(if (= az bz)
(setq y nil) ;_同高无等高线经过
(setq tmp az
az bz
bz tmp
tmp a
a b
b tmp
)
)
)
(if y
(progn (setq a (list (car a) (cadr a) 0))
(setq dist (distance a (list (car b) (cadr b))))
(setq gaoc (- bz az))
(setq ang (angle a b))
(setq minz (* (+ 1 (fix (/ az dgj))) dgj)) ;_最小Z
(setq maxz (* (fix (/ bz dgj)) dgj)) ;_最大Z
(setq gcnum (/ (- maxz minz) dgj)) ;_高差算出等高线数量
(setq elev minz) ;_从最小的高程画起
(setq dt (* dist (/ (- elev az) gaoc)))
(setq pt (polar a ang dt))
(setq pt (list (car pt) (cadr pt)))
(setq ptlst (append ptlst (list (list elev pt))))
(setq dt (* dist (/ dgj gaoc)))
(repeat gcnum
(setq elev (+ elev dgj))
(setq pt (polar pt ang dt))
(setq pt (list (car pt) (cadr pt)))
(setq ptlst (append ptlst (list (list elev pt))))
)
)
)
)
(setq ablst (bianpt a b))
(setq bclst (bianpt b c))
(setq calst (bianpt c a))
(while ptlst
(setq one (car ptlst))
(setq g (car one))
(setq ptlst (cdr ptlst))
(setq two (assoc g ptlst))
(setq ptlst (vl-remove two ptlst))
(setq one (cadr one))
(setq two (cadr two))
(setq elevg (strcat "g" (itoa g)))
;;创建符号名为elevg的表,或在elevg表的尾部加上此段线
(if (setq linelst (eval (read elevg)))
(set (read elevg)
(append linelst (list (list one two) (list two one)))
)
(progn
(set (read elevg) (list (list one two) (list two one)))
(setq elevglst (append elevglst (list elevg))) ;_将此高加入等值线变量名表
)
)
)
)
;;依次取出等值线变量名表
(foreach elevg elevglst
(setq g (atoi (substr elevg 2))) ;_高程值
(setq linelst (eval (read elevg))) ;_等值短线表
(setq len (length linelst))
(setq nn (vl-sort-i linelst
'(lambda (a b) (equal (caar a) (caar b)))
)
)
(setq qsi 0)
(while (< qsi len)
(setq i qsi)
(setq n (nth i nn))
(setq line (nth n linelst))
(setq ptlst line)
(setq jo (rem i 2))
(setq nn (subst -1 i nn))
(setq nn (subst -1
(if (= 0 jo)
(1+ i)
(1- i)
)
nn
)
)
(setq start (car line))
(setq end (cadr line))
(if (< (car start) (car end))
(setq fx 1
fun <
)
(setq fx -1
fun >
)
)
(while (and xh (setq n (nth i nn)))
(setq two (nth n linelst))
(if ((eval fun) (car end) (caar two))
()
(if (equal end (car two))
(progn (setq nn (subst -1 i nn)
ptlst (append ptlst (list (cadr two)))
end (cadr two)
jo (rem i 2)
nn (subst -1
(if (= 0 jo)
(1+ i)
(1- i)
)
nn
)
)
(if (< (caar two) (car end))
(setq fx 1
fun <
)
(setq fx -1
fun >
)
)
)
(progn
;;生线
(mk2polyline ptlst
(equal (car ptlst) (last ptlst) 0.001)
)
(setq ptlst '())
(setq xh nil)
;;设定
)
)
)
(while (= -1 (setq i (+ i fx))))
)
(setq i qsi)
(while (= -1 (setq i (1+ i))))
(setq qsi i)
)
)
(setq time (strcat "\n "
(rtos (/ (- (car (_VL-TIMES)) ti) 1000.) 2 4)
" secs."
)
) ;_计算程序耗时
(setq fl (open "d:\\111.txt" "a"))
(print time fl)
)
)
(command ".undo" "end")
(princ)
) ;_程序完毕 感谢楼主的分享，向高手学习下 本帖最后由 NetBee 于 2012-12-15 09:17 编辑
今天写不完了,先贴出来松口气,,顺便问大侠个问题:我用lst= ("1" "2" "3" ...)表中的名字创建了多个变量,程序运行结束后我怎么释放这些变量名呢??(foreach a lst (set (read a) a) )
将这些所有变量定义为局部变量。程序完成后自动释放。如变量v1 v2 v3
(defun c:test(/ v1 v2 v3)
;;
)
NetBee 发表于 2012-12-15 09:16 static/image/common/back.gif
将这些所有变量定义为局部变量。程序完成后自动释放。如变量v1 v2 v3
我可能没说清楚，我现在是用相同的办法赋空值的(foreach a lst (set (read a) nil)),,大侠还有更好的办法不？