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

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

本帖最后由 004 于 2012-12-16 00:55 编辑

这个三角网我写了4个版本的

1.相邻边法，2.ssget法（用坐标构造的选择集好像不可靠，未写完放弃了）3.三角形编号法4.短线相接法。感谢gzxl大侠的指引。1，3,4都能运行，短线相接法的速度快了好多（60个三角网0.5秒），基本满足了我的要求，但总觉得啰嗦，还请大侠们优化，连夜贴出代码就是想得到大侠们的指点。请不吝赐教。

;|功能:由三角网生等高线-相邻边法
日期:wkq004@qq.com于2012-12-9|;
(vl-load-com)
(setq myms (vla-get-ModelSpace
(vla-get-ActiveDocument (vlax-get-acad-object))
)
)
(defun mk2polyline (pts bh /)
;;功能:生成二次拟合的二维多段线
;;参数:pts 点表 bh 闭合否T nil
;;返回:未指定
;;全局变量:elev 高程
;;日期:wkq004@qq.com于2012-12-9
(setq pts (apply 'append pts))
(setq pts
(vlax-safearray-fill
(vlax-make-safearray vlax-vbDouble (cons 0 (1- (length pts))))
pts
)
)
(setq my2dpoly (vla-AddPolyline myms (vlax-make-variant pts)))
(vla-put-Elevation my2dpoly elev) ;_标高
(if bh
(vla-put-Closed my2dpoly T) ;_闭合
)
(vla-put-type my2dpoly acQuadSplinePoly) ;_二次拟合
)
(defun chuan (a b / az bz)
;;等高线是否穿过此边
(setq az (caddr a))
(setq bz (caddr b))
(if (< (* (- az elev) (- bz elev)) 0)
T ;_返回穿过边
nil
)
)
(defun funbian (a b /)
;;坐标排序,按x从小到大排,如相等就按y从小到大排
(if (< (car a) (car b))
(list a b)
(if (= (car a) (car b))
(if (< (cadr a) (cadr b))
(list a b)
(list b a)
)
(list b a)
)
)
)
(defun nbian (n xlb / comeN)
;;求相邻三角形的编号
(setq xlb (cdr xlb))
(if (= n (car xlb))
(if (setq comeN (caddr xlb))
(list comeN (cadddr xlb))
)
(list (car xlb) (cadr xlb))
)
)
(defun funptxlb (xlb / A AZ B BZ DIST DT GAO GAOC PT)
;;;计算边与等高线相交的控制点坐标.
;;;返回坐标点
(setq a (car xlb))
(setq b (cadr xlb))
(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 qpt (ee /)
;;求三角网顶点坐标
(setq e (entnext ee))
(cdr (assoc '10 (entget e)))
)
(defun c:tt (/ DGJ ELEV MAXZ MINZ PTLST SJXELST SJXLBLST SJXNLST SJXNNN
sjxlbnn sjxlbn SS
)
;;;作者:wkq004@qq.com 2012.11.16
;;;功能:由三角网生等高线
(command ".undo" "end")
(command ".undo" "begin")
(defun qssjx (i / A AZ B BZ C CZ E PT XH XLB1 XLB2 NGOBIAN)
;;搜索起始三角形
;;全局变量 (ELEV SJXELST SJXNLST qsi qsbian)
(setq xh 1)
(while (and xh (setq e (nth i sjxelst)))
(setq a (qpt e))
(setq b (qpt e))
(setq c (qpt e))
(setq az (caddr a)) ;_顶点z坐标
(setq bz (caddr b))
(setq cz (caddr c))
(setq xlb1 '())
(setq xlb2 '())
(if (< (* (- az elev) (- bz elev)) 0)
(if (< (* (- cz elev) (- az elev)) 0)
(setq xlb1 (funbian a b)
xlb2 (funbian c a)
)
(setq xlb1 (funbian a b)
xlb2 (funbian b c)
)
)
(if (< (* (- cz elev) (- az elev)) 0)
(setq xlb1 (funbian c a)
xlb2 (funbian b c)
)
)
)
(if xlb1 ;_只要有一边穿过肯定是还有一边也能穿过.
(progn (funptxlb xlb1)
(funptxlb xlb2)
(setq sjxnlst (subst -1 i sjxnlst)) ;_将处理后的三角形编号改为-1
(setq qsbian (assoc xlb1 sjxlblst)) ;_起始边
(setq qsi i) ;_起始边
(setq xh nil)
(setq ngobian (list i xlb2)) ;_n三角形的离开边
)
(progn (setq sjxnlst (subst -1 i sjxnlst))
(while (= -1 (nth (setq i (+ i 1)) sjxnlst))) ;_用边编号找起始边能快一半
)
)
)
ngobian ;_返回
)
(defun funxlbsjx (lst / A AB B BC C CA E GONUM go NUMLST PT)
;;;进入三角形cn
;;;进入边xlb
;;;相邻边三角形
(setq cn (car lst))
(setq cnum (cadr lst))
(setq e (nth cn sjxelst))
(setq a (qpt e))
(setq b (qpt e))
(setq c (qpt e))
(cond ((= cnum 1)
(if (chuan b c)
(setq go (funbian b c))
(setq go (funbian c a))
)
)
((= cnum 2)
(if (chuan c a)
(setq go (funbian c a))
(setq go (funbian a b))
)
)
((= cnum 3)
(if (chuan a b)
(setq go (funbian a b))
(setq go (funbian b c))
)
)
)
(setq sjxnlst (subst -1 cn sjxnlst))
(funptxlb go)
(list cn go)
)
(defun sdgx (/ BH COMEN COMENUM ELEV FX GCNUM GO I LST N NGO QSBIAN
SJXN XH XH2 XLB XLBLST lst
)
;;生等高线
;;全局变量:等高距 dgj minz maxz
(setq dgj 1) ;_等高距
(setq minz (* (+ 1 (fix (/ minz dgj))) dgj)) ;_最小Z
(setq maxz (* (fix (/ maxz dgj)) dgj)) ;_最大Z
(setq gcnum (/ (- maxz minz) dgj)) ;_高差算出等高线数量
(setq elev minz) ;_从最小的高程画起
(repeat gcnum ;_等高线数量
;;(maxz minz sjxelst sjxlblst sjxnlst sjxnnn)
(setq ptlst '())
(setq sjxnlst sjxnnn) ;_本条等高线的三角形编号表
(setq i -1)
(setq xh T) ;_切换高程
(setq xh2 T) ;_同一高程的新线
(while (progn (while xh2
(setq sjxn (nth (setq i (+ 1 i)) sjxnlst))
(cond ((not sjxn) (setq xh nil) (setq xh2 nil))
((/= -1 sjxn) (setq xh T) (setq xh2 nil))
)
)
xh
)
(setq xh2 T)
;;调用起始三角形返回编号和离开边
(setq ngo (qssjx i))
(setq fx 0)
(while ngo
(setq n (car ngo)) ;_离开三角形的编号
(setq go (cadr ngo)) ;_离开的边
(setq xlblst (assoc go sjxlblst))
(if (setq lst (nbian n xlblst)) ;_进入三角形的编号
(if (= (car lst) qsi)
(progn (setq ngo nil)
(mk2polyline ptlst T)
(setq ptlst '())
)
(setq ngo (funxlbsjx lst))
)
(if (= fx 0) ;_如闭合为nil说明在起点处开始的不用反向直接生线
(setq ngo (list qsi (car qsbian))
ptlst (reverse ptlst)
fx 1
) ;_起始边的邻边
(progn (setq ngo nil)
(mk2polyline ptlst nil)
(setq ptlst '())
)
)
)
)
)
(setq elev (+ elev dgj))
)
)
(defun sjzl (/ E EL EMAIN EXDATA EXPTLST I PTA PTB PTC PTZ)
;;数据整理(sjxelst sjxnlst sjxddlst ddsjxlst bxllst sjxsblst /)
;;全局变量 maxz minz sjxelst sjxlblst sjxnlst sjxnnn
(setq sjxnlst '() ;_三角形编号表
sjxelst '() ;_三角形与编号对应的图元表
sjxlblst '() ;_三角形邻边表
i -1
minz 9999
maxz -9999
sjxnnn (repeat (sslength ss)
(setq i (+ 1 i))
(setq sjxnlst (append sjxnlst (list i)))
) ;_三角形原始编号表
i -1
)
(repeat (sslength ss)
(setq e (ssname ss (setq i (+ 1 i))))
(setq sjxelst (append sjxelst (list e)))
(defun funqpt (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 pta (funqpt e))
(setq ptb (funqpt e))
(setq ptc (funqpt e))
(defun funxl (a b i n / ab findab)
(setq ab (funbian a b))
(setq findab (assoc ab sjxlblst))
(if findab
(setq sjxlblst
(subst (append findab (list i n)) findab sjxlblst)
)
(setq sjxlblst (append sjxlblst (list (list ab i n))))
)
)
(funxl pta ptb i 1) ;_点a 点b 三角形编号边编号
(funxl ptb ptc i 2)
(funxl ptc pta i 3)
)
)
(if (setq ss (ssget '((0 . "OLYLINE") (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|; 
(vl-load-com) 
(setq myms (vla-get-ModelSpace 
      (vla-get-ActiveDocument (vlax-get-acad-object)) 
    ) 
) 
(defun mk2polyline (pts bh /) 
  ;;功能:生成二次拟合的二维多段线 
  ;;参数:pts  点表  bh 闭合否T nil 
  ;;返回:未指定 
  ;;全局变量:elev 高程 
  ;;日期:wkq004@qq.com于2012-12-9 
  (setq pts (apply 'append pts)) 
  (setq pts 
  (vlax-safearray-fill 
    (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length pts)))) 
    pts 
  ) 
  ) 
  (setq my2dpoly (vla-AddPolyline myms (vlax-make-variant pts))) 
  (vla-put-Elevation my2dpoly elev) ;_标高 
  (if bh 
    (vla-put-Closed my2dpoly T) ;_闭合 
  ) 
  (vla-put-type my2dpoly acQuadSplinePoly) ;_二次拟合 
) 
(defun chuan (a b / az bz) 
  ;;等高线是否穿过此边 
  (setq az (caddr a)) 
  (setq bz (caddr b)) 
  (if (< (* (- az elev) (- bz elev)) 0) 
    T ;_返回穿过边 
    nil 
  ) 
) 
(defun funbian (a b /) 
  ;;坐标排序,按x从小到大排,如相等就按y从小到大排 
  (if (< (car a) (car b)) 
    (list a b) 
    (if (= (car a) (car b)) 
      (if (< (cadr a) (cadr b)) 
 (list a b) 
 (list b a) 
      ) 
      (list b a) 
    ) 
  ) 
) 
(defun nbian (n xlb / comeN) 
  ;;求相邻三角形的编号 
  (setq xlb (cdr xlb)) 
  (if (= n (car xlb)) 
    (if (setq comeN (caddr xlb)) 
      (list comeN (cadddr xlb)) 
    ) 
    (list (car xlb) (cadr xlb)) 
  ) 
) 
(defun funptxlb (xlb / A AZ B BZ DIST DT GAO GAOC PT) 
;;;计算边与等高线相交的控制点坐标. 
;;;返回坐标点 
  (setq a (car xlb)) 
  (setq b (cadr xlb)) 
  (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 qpt (ee /) 
  ;;求三角网顶点坐标 
  (setq e (entnext ee)) 
  (cdr (assoc '10 (entget e))) 
) 
(defun c:tt (/ DGJ ELEV MAXZ MINZ PTLST SJXELST SJXLBLST SJXNLST SJXNNN 
      sjxlbnn sjxlbn SS 
     ) 
;;;作者:wkq004@qq.com  2012.11.16 
;;;功能:由三角网生等高线 
  (command ".undo" "end") 
  (command ".undo" "begin") 
  (defun qssjx (i / A AZ B BZ C CZ E PT XH XLB1 XLB2 NGOBIAN) 
    ;;搜索起始三角形 
    ;;全局变量 (ELEV SJXELST SJXNLST qsi qsbian) 
    (setq xh 1) 
    (while (and xh (setq e (nth i sjxelst))) 
      (setq a (qpt e)) 
      (setq b (qpt e)) 
      (setq c (qpt e)) 
      (setq az (caddr a)) ;_顶点z坐标 
      (setq bz (caddr b)) 
      (setq cz (caddr c)) 
      (setq xlb1 '()) 
      (setq xlb2 '()) 
      (if (< (* (- az elev) (- bz elev)) 0) 
 (if (< (* (- cz elev) (- az elev)) 0) 
   (setq xlb1 (funbian a b) 
  xlb2 (funbian c a) 
   ) 
   (setq xlb1 (funbian a b) 
  xlb2 (funbian b c) 
   ) 
 ) 
 (if (< (* (- cz elev) (- az elev)) 0) 
   (setq xlb1 (funbian c a) 
  xlb2 (funbian b c) 
   ) 
 ) 
      ) 
      (if xlb1 ;_只要有一边穿过肯定是还有一边也能穿过. 
 (progn (funptxlb xlb1) 
        (funptxlb xlb2) 
        (setq sjxnlst (subst -1 i sjxnlst)) ;_将处理后的三角形编号改为-1 
        (setq qsbian (assoc xlb1 sjxlblst)) ;_起始边 
        (setq qsi i) ;_起始边 
        (setq xh nil) 
        (setq ngobian (list i xlb2)) ;_n三角形的离开边 
 ) 
 (progn (setq sjxnlst (subst -1 i sjxnlst)) 
        (while (= -1 (nth (setq i (+ i 1)) sjxnlst))) ;_用边编号找起始边能快一半 
 ) 
      ) 
    ) 
    ngobian ;_返回 
  ) 
  (defun funxlbsjx (lst / A AB B BC C CA E GONUM go NUMLST PT) 
;;;进入三角形cn 
;;;进入边xlb 
;;;相邻边三角形 
    (setq cn (car lst)) 
    (setq cnum (cadr lst)) 
    (setq e (nth cn sjxelst)) 
    (setq a (qpt e)) 
    (setq b (qpt e)) 
    (setq c (qpt e)) 
    (cond ((= cnum 1) 
    (if (chuan b c) 
      (setq go (funbian b c)) 
      (setq go (funbian c a)) 
    ) 
   ) 
   ((= cnum 2) 
    (if (chuan c a) 
      (setq go (funbian c a)) 
      (setq go (funbian a b)) 
    ) 
   ) 
   ((= cnum 3) 
    (if (chuan a b) 
      (setq go (funbian a b)) 
      (setq go (funbian b c)) 
    ) 
   ) 
    ) 
    (setq sjxnlst (subst -1 cn sjxnlst)) 
    (funptxlb go) 
    (list cn go) 
  ) 
  (defun sdgx (/ BH COMEN COMENUM ELEV FX GCNUM GO I LST N NGO QSBIAN 
        SJXN XH XH2 XLB XLBLST lst 
       ) 
    ;;生等高线 
    ;;全局变量:等高距 dgj minz maxz 
    (setq dgj 1) ;_等高距 
    (setq minz (* (+ 1 (fix (/ minz dgj))) dgj)) ;_最小Z 
    (setq maxz (* (fix (/ maxz dgj)) dgj)) ;_最大Z 
    (setq gcnum (/ (- maxz minz) dgj)) ;_高差算出等高线数量 
    (setq elev minz) ;_从最小的高程画起 
    (repeat gcnum ;_等高线数量 
      ;;(maxz minz sjxelst sjxlblst sjxnlst sjxnnn) 
      (setq ptlst '()) 
      (setq sjxnlst sjxnnn) ;_本条等高线的三角形编号表 
      (setq i -1) 
      (setq xh T) ;_切换高程 
      (setq xh2 T) ;_同一高程的新线 
      (while (progn (while xh2 
        (setq sjxn (nth (setq i (+ 1 i)) sjxnlst)) 
        (cond ((not sjxn) (setq xh nil) (setq xh2 nil)) 
       ((/= -1 sjxn) (setq xh T) (setq xh2 nil)) 
        ) 
      ) 
      xh 
      ) 
 (setq xh2 T) 
 ;;调用起始三角形返回编号和离开边 
 (setq ngo (qssjx i)) 
 (setq fx 0) 
 (while ngo 
   (setq n (car ngo)) ;_离开三角形的编号 
   (setq go (cadr ngo)) ;_离开的边 
   (setq xlblst (assoc go sjxlblst)) 
   (if (setq lst (nbian n xlblst)) ;_进入三角形的编号 
     (if (= (car lst) qsi) 
       (progn (setq ngo nil) 
       (mk2polyline ptlst T) 
       (setq ptlst '()) 
       ) 
       (setq ngo (funxlbsjx lst)) 
     ) 
     (if (= fx 0) ;_如闭合为nil说明在起点处开始的不用反向直接生线 
       (setq ngo   (list qsi (car qsbian)) 
      ptlst (reverse ptlst) 
      fx   1 
       ) ;_起始边的邻边 
       (progn (setq ngo nil) 
       (mk2polyline ptlst nil) 
       (setq ptlst '()) 
       ) 
     ) 
   ) 
 ) 
      ) 
      (setq elev (+ elev dgj)) 
    ) 
  ) 
  (defun sjzl (/ E EL EMAIN EXDATA EXPTLST I PTA PTB PTC PTZ) 
    ;;数据整理(sjxelst sjxnlst sjxddlst ddsjxlst bxllst sjxsblst /) 
    ;;全局变量 maxz minz sjxelst sjxlblst sjxnlst sjxnnn 
    (setq sjxnlst  '() ;_三角形编号表 
   sjxelst  '() ;_三角形与编号对应的图元表 
   sjxlblst '() ;_三角形邻边表 
   i    -1 
   minz    9999 
   maxz    -9999 
   sjxnnn   (repeat (sslength ss) 
       (setq i (+ 1 i)) 
       (setq sjxnlst (append sjxnlst (list i))) 
     ) ;_三角形原始编号表 
   i    -1 
    ) 
    (repeat (sslength ss) 
      (setq e (ssname ss (setq i (+ 1 i)))) 
      (setq sjxelst (append sjxelst (list e))) 
      (defun funqpt (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 pta (funqpt e)) 
      (setq ptb (funqpt e)) 
      (setq ptc (funqpt e)) 
      (defun funxl (a b i n / ab findab) 
 (setq ab (funbian a b)) 
 (setq findab (assoc ab sjxlblst)) 
 (if findab 
   (setq sjxlblst 
   (subst (append findab (list i n)) findab sjxlblst) 
   ) 
   (setq sjxlblst (append sjxlblst (list (list ab i n)))) 
 ) 
      ) 
      (funxl pta ptb i 1) ;_点a 点b 三角形编号  边编号 
      (funxl ptb ptc i 2) 
      (funxl ptc pta i 3) 
    ) 
  ) 
  (if (setq ss (ssget '((0 . "<img src="static/image/smiley/default/titter.gif" smilieid="9" border="0" alt="" />OLYLINE") (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 · 发表于 2012-12-16 00:50:43

;|功能:由三角网生等高线-短线连接法（较快）
日期:wkq004@qq.com于2012-12-16
|;
(vl-load-com)
(defun mk2polyline (pts bh elev / lenn pts my2dpoly)
;;功能:生成二次拟合的二维多段线
;;参数:pts 点表 bh 闭合否T nil
;;返回:未指定
;;全局变量:elev 高程
;;日期:wkq004@qq.com于2012-12-16
(setq
pts (apply 'append (mapcar '(lambda (x) (append x (list 0))) pts))
)
(setq lenn (length pts))
(if (>= lenn 6)
;;有遇到两点相同的一段线,以为是闭合去掉一点后,就创建不了线而出错.
(progn (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 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))) ;_获得程序开始时间
(foreach elevg elevglst (set (read elevg) nil))
(setq elevglst nil)
(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 (= bz az)
;;判断两点之间是否有指定等高距的等高线穿过
(setq y nil)
(progn (if (< (- bz az) 0)
;;使bz>az
(setq tmp az
az bz
bz tmp
tmp a
a b
b tmp
)
)
(if (< (- bz az) dgj)
(if (< (- bz (rem bz dgj)) az)
(setq y nil)
)
)
)
)
(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 ptlst '())
(setq ablst (bianpt a b))
(setq bclst (bianpt b c))
(setq calst (bianpt c a))
(while ptlst
;;将此三角形三边等高线的穿过点整理成小短线,并加入同高名变量表
(setq bb (rem (length ptlst) 2))
(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 (member elevg elevglst)
(set (read elevg)
(append (eval (read elevg))
(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 a nil)
(setq b nil)
;;短线按x坐标排序,x相同,用y坐标排
(setq nn (vl-sort-i linelst
(function (lambda (a b)
(setq ax (caar a))
(setq ay (cadar a))
(setq bx (caar b))
(setq by (cadar b))
(if (equal ax bx 0.001)
(if (equal ay by 0.001)
T
(if (< ay by)
T
nil
)
)
(if (< ax bx)
T
nil
)
)
)
)
)
)
(setq ptlst '())
(setq qsi 0)
;;同一高程的等高线有三种情况的组合,
;;1.单条2.闭合,3.多条
(while (setq n (nth qsi nn))
(setq i qsi)
(setq line (nth n linelst))
(setq ptlst line)
(setq jo (rem n 2))
(setq nn (subst -1 n nn))
(setq nn (subst -1
(if (= 0 jo)
(1+ n)
(1- n)
)
nn
)
)
(setq start (car line))
(setq end (cadr line))
(while (= -1 (nth i nn)) (setq i (1+ i)))
(setq xh T)
;;确定搜索方向
(setq fx 1
fun >
)
(while (and xh (setq n (nth i nn)))
(setq two (nth n linelst))
(if (equal end (car two) 0.001)
(progn (setq n (nth i nn))
(setq nn (subst -1 n nn))
(setq jo (rem n 2)
nn (subst -1
(if (= 0 jo)
(1+ n)
(1- n)
)
nn
)
ptlst (append ptlst (list (cadr two)))
start (car two)
end (cadr two)
)
(if (> (car end) (car start))
(setq fx 1
fun >
)
(setq fx -1
fun <
)
)
)
(if (fun (car end) (caar two))
(setq i (+ i fx))
(setq xh nil)
)
)
(while (and (/= -1 i) (= -1 (nth i nn))) (setq i (+ i fx)))
(if (= i -1)
(setq xh nil)
)
)
(if ptlst
(progn (if (equal (car ptlst) (last ptlst) 0.001)
;;判断闭合
(setq bh T
ptlst (cdr ptlst)
)
(setq bh nil)
)
(mk2polyline ptlst bh g)
(setq ptlst '())
)
)
(setq i qsi)
(while (= -1 (nth i nn)) (setq i (1+ i)))
(setq qsi i)
)
)
;;清空定义的序列变量
(foreach elevg elevglst (set (read elevg) nil))
(setq elevglst nil)
(setq time (strcat "\n "
(rtos (/ (- (car (_VL-TIMES)) ti) 1000.) 2 4)
" secs."
)
) ;_计算程序耗时
(princ time)
(setq fl (open "d:\\111.txt" "a"))
(print time fl)
)
)
(command ".undo" "end")
(princ)
) ;_程序完毕

;|功能:由三角网生等高线-短线连接法（较快） 
日期:wkq004@qq.com于2012-12-16 
|; 
(vl-load-com) 
(defun mk2polyline (pts bh elev / lenn pts my2dpoly) 
  ;;功能:生成二次拟合的二维多段线 
  ;;参数:pts  点表  bh 闭合否T nil 
  ;;返回:未指定 
  ;;全局变量:elev 高程 
  ;;日期:wkq004@qq.com于2012-12-16 
  (setq 
    pts        (apply 'append (mapcar '(lambda (x) (append x (list 0))) pts)) 
  ) 
  (setq lenn (length pts)) 
  (if (>= lenn 6) 
    ;;有遇到两点相同的一段线,以为是闭合去掉一点后,就创建不了线而出错. 
    (progn (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 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))) ;_获得程序开始时间 
      (foreach elevg elevglst (set (read elevg) nil)) 
      (setq elevglst nil) 
      (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 (= bz az) 
            ;;判断两点之间是否有指定等高距的等高线穿过 
            (setq y nil) 
            (progn (if (< (- bz az) 0) 
                     ;;使bz>az 
                     (setq tmp az 
                           az  bz 
                           bz  tmp 
                           tmp a 
                           a   b 
                           b   tmp 
                     ) 
                   ) 
                   (if (< (- bz az) dgj) 
                     (if (< (- bz (rem bz dgj)) az) 
                       (setq y nil) 
                     ) 
                   ) 
            ) 
          ) 
          (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 ptlst '()) 
        (setq ablst (bianpt a b)) 
        (setq bclst (bianpt b c)) 
        (setq calst (bianpt c a)) 
        (while ptlst 
          ;;将此三角形三边等高线的穿过点整理成小短线,并加入同高名变量表 
          (setq bb (rem (length ptlst) 2)) 
          (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 (member elevg elevglst) 
            (set (read elevg) 
                 (append (eval (read elevg)) 
                         (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 a nil) 
        (setq b nil) 
        ;;短线按x坐标排序,x相同,用y坐标排 
        (setq nn (vl-sort-i linelst 
                            (function (lambda (a b) 
                                        (setq ax (caar a)) 
                                        (setq ay (cadar a)) 
                                        (setq bx (caar b)) 
                                        (setq by (cadar b)) 
                                        (if (equal ax bx 0.001) 
                                          (if (equal ay by 0.001) 
                                            T 
                                            (if        (< ay by) 
                                              T 
                                              nil 
                                            ) 
                                          ) 
                                          (if (< ax bx) 
                                            T 
                                            nil 
                                          ) 
                                        ) 
                                      ) 
                            ) 
                 ) 
        ) 
        (setq ptlst '()) 
        (setq qsi 0) 
        ;;同一高程的等高线有三种情况的组合, 
        ;;1.单条2.闭合,3.多条 
        (while (setq n (nth qsi nn)) 
          (setq i qsi) 
          (setq line (nth n linelst)) 
          (setq ptlst line) 
          (setq jo (rem n 2)) 
          (setq nn (subst -1 n nn)) 
          (setq        nn (subst -1 
                          (if (= 0 jo) 
                            (1+ n) 
                            (1- n) 
                          ) 
                          nn 
                   ) 
          ) 
          (setq start (car line)) 
          (setq end (cadr line)) 
          (while (= -1 (nth i nn)) (setq i (1+ i))) 
          (setq xh T) 
          ;;确定搜索方向 
          (setq        fx 1 
                fun > 
          ) 
          (while (and xh (setq n (nth i nn))) 
            (setq two (nth n linelst)) 
            (if        (equal end (car two) 0.001) 
              (progn (setq n (nth i nn)) 
                     (setq nn (subst -1 n nn)) 
                     (setq jo         (rem n 2) 
                           nn         (subst        -1 
                                        (if (= 0 jo) 
                                          (1+ n) 
                                          (1- n) 
                                        ) 
                                        nn 
                                 ) 
                           ptlst (append ptlst (list (cadr two))) 
                           start (car two) 
                           end         (cadr two) 
                     ) 
                     (if (> (car end) (car start)) 
                       (setq fx        1 
                             fun > 
                       ) 
                       (setq fx        -1 
                             fun < 
                       ) 
                     ) 
              ) 
              (if (fun (car end) (caar two)) 
                (setq i (+ i fx)) 
                (setq xh nil) 
              ) 
            ) 
            (while (and (/= -1 i) (= -1 (nth i nn))) (setq i (+ i fx))) 
            (if        (= i -1) 
              (setq xh nil) 
            ) 
          ) 
          (if ptlst 
            (progn (if (equal (car ptlst) (last ptlst) 0.001) 
                     ;;判断闭合 
                     (setq bh         T 
                           ptlst (cdr ptlst) 
                     ) 
                     (setq bh nil) 
                   ) 
                   (mk2polyline ptlst bh g) 
                   (setq ptlst '()) 
            ) 
          ) 
          (setq i qsi) 
          (while (= -1 (nth i nn)) (setq i (1+ i))) 
          (setq qsi i) 
        ) 
      ) 
      ;;清空定义的序列变量 
      (foreach elevg elevglst (set (read elevg) nil)) 
      (setq elevglst nil) 
      (setq time (strcat "\n " 
                         (rtos (/ (- (car (_VL-TIMES)) ti) 1000.) 2 4) 
                         " secs." 
                 ) 
      ) ;_计算程序耗时 
      (princ time) 
      (setq fl (open "d:\\111.txt" "a")) 
      (print time fl) 
    ) 
  ) 
  (command ".undo" "end") 
  (princ) 
) ;_程序完毕

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

本帖最后由 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-16 04:08:50

004 发表于 2012-12-16 00:49
这个三角网我写了4个版本的1.相邻边法，2.ssget法（用坐标构造的选择集好像不可靠，未写完放弃了）3. ...

我可不是大侠,学lisp时间不长

真够服你很有钻研精神

最后一个是外接圆吧

gzxl · 发表于 2013-1-15 21:38:06

这个真的要顶起来，给我写我一个都写不出来,何况是四个思路

pslstar · 发表于 2013-2-3 21:05:05

好厉害啊，学习了

mycad · 发表于 2013-3-18 12:02:07

顶一下，希望楼主再写个读三角网文件的等高线生成程序！

004 · 发表于 2013-4-11 11:33:35

本帖最后由 004 于 2013-4-11 11:36 编辑

发个关于动态生等高线的，还没弄完，先给大家看看吧，请高手提供，不用command trim的裁切算法。
要求参看http://bbs.mjtd.com/thread-100359-1-1.html

461045462 · 发表于 2013-4-11 12:34:55

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

谢谢分享！
收藏了。学习学习
谢谢

陈亚娣 · 发表于 2013-7-14 18:57:15

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

楼主，你好！1米的等高距可以画出来，如果改到0.5的等高距就不行了！
“; 错误: 参数类型错误: fixnump: 5.0”
是怎么回事呢？

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

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

评分

本帖子中包含更多资源