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

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

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

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

004 · 发表于 2013-7-18 22:23:13

这是习作，仅供交流，欢迎指正

hotty.zhao · 发表于 2013-10-18 21:53:09

向大师学习

树櫴希德 · 发表于 2014-9-11 09:07:17

有些人过分依赖CASS,这样不好的啊

wmz · 发表于 2014-9-27 13:51:04

本帖最后由 wmz 于 2014-9-27 13:53 编辑

004 发表于 2012-12-16 00:50

Automation 错误。安全数组中的元素太少或总元素数目不是 3 的倍数----用短线法当三角网太多时（7118个三角网）所出现的问题，少的时候没有

This_is丶Stan · 发表于 2015-4-14 13:41:34

楼主在吗？有问题想请教

VBALISPER · 发表于 2015-8-24 13:07:26

相邻边法提示"除数为0",
Automation 错误。安全数组中的元素太少或总元素数目不是 3 的倍数----三角网为几十个时仍提示这个,没再试了

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

向高手学习

shmily1023 · 发表于 2015-9-4 17:37:43

本帖最后由 shmily1023 于 2015-9-4 17:48 编辑

(defun mk2polyline (pts bh elev / LENN MY2DPOLY myms)
;;功能:生成二次拟合的二维多段线
;;参数:pts 点表 bh 闭合否T nil
;;返回:未指定
;;全局变量:elev 高程
;;日期:wkq004@qq.com于2012-12-16
(setq myms (vla-get-ModelSpace
(vla-get-ActiveDocument (vlax-get-acad-object))
)
)
(or (tblsearch "LAYER" "DGX")
(entmake (list '(0 . "LAYER")
'(100
.
"AcDbSymbolTableRecord"
)
'(100
.
"AcDbLayerTableRecord"
)
'(2 . "DGX")
'(70 . 0)
'(62 . 2)
'(6
.
"Continuous"
)
'(290 . 1)
'(370 . -3)
)
)
)
(setvar "CLAYER" "DGX")
(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 100.0)) ;_标高
(if bh
(vla-put-Closed my2dpoly T) ;_闭合
)
(if (> lenn 6)
(vla-put-type my2dpoly acQuadSplinePoly) ;_二次拟合
)
)
)
)
(defun bianpt (a b dgj / ANG AZ BZ DIST DT
ELEV GAOC GCNUM MAXZ MINZ PT PTLST TMP Y
)
(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 (* (+ (fix (/ az dgj)) 1) 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 (fix 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 ptlst)
)
(print "tt2选三角网生等高线")
(defun c:tt2 (/ A ABLST B BB BCLST BH C CALST
DGJ E ELEVG ELEVGLST END FL FUN FX
G I JO LEN LINE LINELST N NN
ONE PTLST QSI SJXDD SS START TI TIME TWO
XH
)
(command ".undo" "end")
(command ".undo" "begin")
(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 (getreal "请输入等高距（米）")) ;_等高距
(setq i -1)
(repeat (sslength ss)
(setq e (ssname ss (setq i (+ 1 i))))
(setq sjxdd (funsjxdd e))
(setq a (car sjxdd))
(setq b (cadr sjxdd))
(setq c (caddr sjxdd))
(setq ablst (bianpt a b dgj))
(setq bclst (bianpt b c dgj))
(setq calst (bianpt c a dgj))
(setq ptlst '())
(setq ptlst (append ptlst ablst bclst calst))
(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" (rtos (* G 100) 2 0) ))
;;创建符号名为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 (atof (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)
)
)
(command ".undo" "end")
(princ)
) ;_程序完毕

(defun mk2polyline (pts bh elev / LENN MY2DPOLY myms) 
  ;;功能:生成二次拟合的二维多段线 
  ;;参数:pts  点表  bh 闭合否T nil 
  ;;返回:未指定 
  ;;全局变量:elev 高程 
  ;;日期:wkq004@qq.com于2012-12-16 
  (setq  myms (vla-get-ModelSpace 
         (vla-get-ActiveDocument (vlax-get-acad-object)) 
       ) 
  ) 
      (or (tblsearch "LAYER" "DGX") 
    (entmake (list '(0 . "LAYER") 
       '(100 
         . 
         "AcDbSymbolTableRecord" 
        ) 
       '(100 
         . 
         "AcDbLayerTableRecord" 
        ) 
       '(2 . "DGX") 
       '(70 . 0) 
       '(62 . 2) 
       '(6 
         . 
         "Continuous" 
        ) 
       '(290 . 1) 
       '(370 . -3) 
       ) 
    ) 
      ) 
      (setvar "CLAYER" "DGX") 
   
  (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 100.0)) ;_标高 
     (if bh 
       (vla-put-Closed my2dpoly T) ;_闭合 
     ) 
     (if (> lenn 6) 
       (vla-put-type my2dpoly acQuadSplinePoly) ;_二次拟合 
     ) 
    ) 
  ) 
) 
 
 
(defun bianpt (a     b     dgj   /     ANG   AZ     BZ   DIST  DT 
         ELEV  GAOC  GCNUM MAXZ  MINZ  PT     PTLST TMP   Y 
        ) 
  (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 (* (+ (fix (/ az dgj)) 1) 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 (fix 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 ptlst) 
) 
 
(print "tt2选三角网生等高线") 
(defun c:tt2 (/      A    ABLST  B     BB    BCLST BH  C     CALST 
        DGJ   E    ELEVG  ELEVGLST    END    FL  FUN   FX 
        G      I    JO  LEN   LINE  LINELST  N     NN 
        ONE   PTLST QSI  SJXDD SS    START TI  TIME  TWO 
        XH 
       ) 
  (command ".undo" "end") 
  (command ".undo" "begin") 
 
 
  (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 (getreal "请输入等高距（米）")) ;_等高距 
      (setq i -1) 
      (repeat (sslength ss) 
  (setq e (ssname ss (setq i (+ 1 i)))) 
  (setq sjxdd (funsjxdd e)) 
  (setq a (car sjxdd)) 
  (setq b (cadr sjxdd)) 
  (setq c (caddr sjxdd)) 
  (setq ablst (bianpt a b dgj)) 
  (setq bclst (bianpt b c dgj)) 
  (setq calst (bianpt c a dgj)) 
  (setq ptlst '()) 
  (setq ptlst (append ptlst ablst bclst calst)) 
  (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" (rtos (* G 100) 2 0) )) 
    ;;创建符号名为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 (atof (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) 
 
    ) 
  ) 
  (command ".undo" "end") 
  (princ) 
) ;_程序完毕

shmily1023 · 发表于 2015-9-4 17:40:36

本帖最后由 shmily1023 于 2015-9-4 17:49 编辑

(read elevg) read不好
（read "G5.50"）返回 G5
(read "G5") 返回 G5
只好用本办法放大100倍

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

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

本帖子中包含更多资源