[求助]根据数据组建三角网程序
本帖最后由 作者 于 2009-4-22 16:35:04 编辑 <br /><br /> <p>十分想了解一下根据地形数据文件组建三角网的VB源代码,不知哪位高人可以指点一下,</p> gzxl 发表于 2012-5-10 14:04能够导出，CASS能识别的，sjw文件最好:D <p>自己顶一下</p> 有那么高手可以提供lisp 代码么？
本帖最后由 gzxl 于 2012-5-10 14:12 编辑
(defun c:test (/ i pl s)
(princ (strcat "\n选择高程点..."))
(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)
)
)
)
(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)))))
bb (list (apply 'mapcar (cons 'min pl)) (apply 'mapcar (cons 'max pl)))
x1 (caar bb)
x2 (caadr bb)
y1 (cadar bb)
y2 (cadadr bb)
)
(setq cp (list (/ (+ x1 x2) 2.0) (/ (+ y1 y2) 2.0))
r (* (distance cp (list x1 y1)) 20)
ma (+ (car cp) r)
mi (- (car cp) r)
sl (list (list ma (cadr cp) 0)
(list mi (+ (cadr cp) r) 0)
(list mi (- (cadr cp) r) 0)
)
al (list (cons x2 (cons cp (cons (* 20 r) sl))))
ma (1- ma)
mi (1+ mi)
)
(repeat (length pl)
(setq p(car pl)
pl (cdr pl)
el nil
)
(while al
(setq tr(car al)
al(cdr al)
)
(cond
((< (car tr) (car p)) (setq tl (cons (cdddr tr) tl)))
((< (distance p (cadr tr)) (caddr tr))
(setq tr (cdddr tr)
a (car tr)
b (cadr tr)
c (caddr tr)
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)
)
)
)
)
(t (setq L (cons tr L)))
)
)
(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))))))
)
(while el
(if (and (= (caar el) (caadr el)) (= (cadar el) (cadadr el)))
(setq el (cddr el))
(setq al (cons (getcircumcircle p (cddar el)) al)
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" "TIN")
(entmake (list '(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(2 . "TIN")
'(70 . 0)
'(62 . 8)
'(6 . "Continuous")
'(290 . 1)
'(370 . -3)
)
)
)
(setvar "CLAYER" "TIN")
(foreach tr tl
(entmake (list (cons 0 "3DFACE")
(cons 10 (car tr))
(cons 11 (car tr))
(cons 12 (cadr tr))
(cons 13 (caddr tr))
)
)
)
)
)
(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))
)
(if (not (zerop (setq ang (- (angle b c) (angle b a)))))
(progn
(setq cp (polar c2 (+ -1.570796326794896 (angle c a) ang) (setq r (/ (distance a c2) (sin ang) 2.0)))
r (abs r)
)
(list (+ (car cp) r) cp r a b c)
)
)
)
本帖最后由 yshf 于 2012-5-11 20:53 编辑
gzxl的程序不错
但应加入对边界上狭长的三角形进行处理。 gzxl 发表于 2012-5-10 14:04 static/image/common/back.gif
谢谢，找了很久了 现在一般测量软件有这样的功能 这个源码好，顶起，但不知和cass生的三角网的差距大吗，各有什么优缺点。 思路好，原理差不多
页:
[1]
2