[求助]根据数据组建三角网程序

一头牛 · 发表于 2009-4-22 15:57:00

本帖最后由作者于 2009-4-22 16:35:04 编辑

十分想了解一下根据地形数据文件组建三角网的VB源代码,不知哪位高人可以指点一下,

838510233 · 发表于 2021-4-20 11:29:55

gzxl 发表于 2012-5-10 14:04

能够导出，CASS能识别的，sjw文件最好:D

一头牛 · 发表于 2009-5-3 09:35:00

自己顶一下

pslstar · 发表于 2012-2-6 06:05:40

skg123 · 发表于 2012-5-1 19:52:58

有那么高手可以提供lisp 代码么？

gzxl · 发表于 2012-5-10 14:04:05

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

(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)) 
                i  1 
                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:51:57

本帖最后由 yshf 于 2012-5-11 20:53 编辑

gzxl的程序不错

但应加入对边界上狭长的三角形进行处理。

skg123 · 发表于 2012-5-11 22:15:57

gzxl 发表于 2012-5-10 14:04

谢谢，找了很久了

461045462 · 发表于 2012-5-12 09:29:54

现在一般测量软件有这样的功能

004 · 发表于 2012-10-27 23:43:12

这个源码好，顶起，但不知和cass生的三角网的差距大吗，各有什么优缺点。

yjc · 发表于 2012-12-30 23:50:57

思路好，原理差不多

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

[求助]根据数据组建三角网程序

相关帖子

本帖子中包含更多资源

评分