[wkq004]由三角网生等高线-我的Alisp之路

004 · 发表于 2012-12-10 00:33

[wkq004]由三角网生等高线-我的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)
) ;_程序完毕

;|功能:由三角网生等高线 
日期: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) 
) ;_程序完毕

╰☆珊瑚玉ヤ · 发表于 2013-7-17 12:46

004 发表于 2013-4-11 11:33
发个关于动态生等高线的，还没弄完，先给大家看看吧，请高手提供，不用command trim的裁切算法。
要求参看 ...

大侠，试用该插件，到第二步总是失败
命令: tt1
选择高程点...
选择对象: 指定对角点: 找到 464 个
已滤除 232 个。
选择对象:
0.1720 secs.
nil nil
命令: tt2
选择对象: 指定对角点: 找到 917 个
已滤除 467 个。
选择对象:
AAAAAAAAAAAAA; 错误: 参数类型错误: consp <Selection set: 7d>
不解

xyz002 · 发表于 2015-9-1 16:03

向高手学习

zs2002zs · 发表于 2016-2-26 14:59

三角网编辑主要是能加特征线，这样三角网才会合理，不然会很失真。不知楼主在这方面怎么处理的。

树櫴希德 · 发表于 2017-9-25 22:16

gzxl 发表于 2012-12-11 10:38
前段时间在theswamp看到这么个思路:

(1) 用LWPOLYLINE全部将每个三角网的等值点勾绘出

说的对啊

004 · 发表于 2012-12-16 01:00

本帖最后由 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));_获取时间
i 1
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)
)
)
)

(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));_获取时间 
            i  1 
            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) 
    ) 
  ) 
)

gzxl · 发表于 2012-12-10 06:42

选择三角网
选择对象: 指定对角点: 找到 11904 个
选择对象:
程序运行用时16.3600 secs.

xiabin68 · 发表于 2012-12-10 09:02

南方都有这个功能了，，，，

gzxl · 发表于 2012-12-11 10:38

前段时间在theswamp看到这么个思路:

(1) 用LWPOLYLINE全部将每个三角网的等值点勾绘出
(2) 再用加强的PEDIT连接
(3) 线型转换处理

速度超快的,10000个三角网形成等值线10秒不到
不知这种方法行否？

回复三楼的
南方有此功能只是代表你会使用

004 · 发表于 2012-12-11 14:58

gzxl 发表于 2012-12-11 10:38
前段时间在theswamp看到这么个思路:

(1) 用LWPOLYLINE全部将每个三角网的等值点勾绘出

这个方法好,我想试试用生成lwpolyline短线的点表直接组织点集,估计会更快点,但对大量点表的穷举判断也是很耗时的,等会我先写出来再让大侠们优化.

gzxl · 发表于 2012-12-11 22:48

004 发表于 2012-12-11 14:58
这个方法好,我想试试用生成lwpolyline短线的点表直接组织点集,估计会更快点,但对大量点表的穷举判断也是很 ...

肯定快很多的，你试试

004 · 发表于 2012-12-13 00:32

今天写不完了,先贴出来松口气,,顺便问大侠个问题:我用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)
) ;_程序完毕

;|功能:由三角网生等高线 
日期: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) 
) ;_程序完毕

zyhandw · 发表于 2012-12-13 11:31

感谢楼主的分享，向高手学习下

NetBee · 发表于 2012-12-15 09:16

本帖最后由 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)
;;
)

004 · 发表于 2012-12-16 00:38

NetBee 发表于 2012-12-15 09:16
将这些所有变量定义为局部变量。程序完成后自动释放。如变量v1 v2 v3

我可能没说清楚，我现在是用相同的办法赋空值的(foreach a lst (set (read a) nil)),,大侠还有更好的办法不？

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

[wkq004]由三角网生等高线-我的Alisp之路

相关帖子

评分