明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
楼主: 004

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

    [复制链接]
发表于 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>
不解
回复 支持 1 反对 0

使用道具 举报

 楼主| 发表于 2013-7-18 22:23 来自手机 | 显示全部楼层
这是习作,仅供交流,欢迎指正
发表于 2013-10-18 21:53 | 显示全部楼层
向大师学习
发表于 2014-9-11 09:07 | 显示全部楼层
有些人过分依赖CASS,这样不好的啊
发表于 2014-9-27 13:51 | 显示全部楼层
本帖最后由 wmz 于 2014-9-27 13:53 编辑
004 发表于 2012-12-16 00:50

Automation 错误。 安全数组中的元素太少或总元素数目不是 3 的倍数----用短线法当三角网太多时(7118个三角网)所出现的问题,少的时候没有
发表于 2015-4-14 13:41 | 显示全部楼层
楼主在吗?有问题想请教
发表于 2015-8-24 13:07 | 显示全部楼层
相邻边法提示"除数为0",
Automation 错误。 安全数组中的元素太少或总元素数目不是 3 的倍数----三角网为几十个时仍提示这个,没再试了
发表于 2015-9-1 16:03 | 显示全部楼层
向高手学习
回复 支持 0 反对 1

使用道具 举报

发表于 2015-9-4 17:37 | 显示全部楼层
本帖最后由 shmily1023 于 2015-9-4 17:48 编辑
  1. (defun mk2polyline (pts bh elev / LENN MY2DPOLY myms)
  2.   ;;功能:生成二次拟合的二维多段线
  3.   ;;参数:pts  点表  bh 闭合否T nil
  4.   ;;返回:未指定
  5.   ;;全局变量:elev 高程
  6.   ;;日期:wkq004@qq.com于2012-12-16
  7.   (setq  myms (vla-get-ModelSpace
  8.          (vla-get-ActiveDocument (vlax-get-acad-object))
  9.        )
  10.   )
  11.       (or (tblsearch "LAYER" "DGX")
  12.     (entmake (list '(0 . "LAYER")
  13.        '(100
  14.          .
  15.          "AcDbSymbolTableRecord"
  16.         )
  17.        '(100
  18.          .
  19.          "AcDbLayerTableRecord"
  20.         )
  21.        '(2 . "DGX")
  22.        '(70 . 0)
  23.        '(62 . 2)
  24.        '(6
  25.          .
  26.          "Continuous"
  27.         )
  28.        '(290 . 1)
  29.        '(370 . -3)
  30.        )
  31.     )
  32.       )
  33.       (setvar "CLAYER" "DGX")
  34.   
  35.   (setq
  36.     pts  (apply 'append
  37.          (mapcar '(lambda (x) (append x (list 0))) pts)
  38.   )
  39.   )
  40.   (setq lenn (length pts))
  41.   (if (>= lenn 6)
  42.     ;;有遇到两点相同的一段线,以为是闭合去掉一点后,就创建不了线而出错.
  43.     (progn (setq
  44.        pts (vlax-safearray-fill
  45.        (vlax-make-safearray
  46.          vlax-vbDouble
  47.          (cons 0 (1- lenn))
  48.        )
  49.        pts
  50.      )
  51.      )
  52.      (setq
  53.        my2dpoly (vla-AddPolyline myms (vlax-make-variant pts))
  54.      )
  55. <font color="red">     (vla-put-Elevation my2dpoly (/ elev 100.0)) ;_标高</font>
  56.      (if bh
  57.        (vla-put-Closed my2dpoly T) ;_闭合
  58.      )
  59.      (if (> lenn 6)
  60.        (vla-put-type my2dpoly acQuadSplinePoly) ;_二次拟合
  61.      )
  62.     )
  63.   )
  64. )


  65. (defun bianpt (a     b     dgj   /     ANG   AZ     BZ   DIST  DT
  66.          ELEV  GAOC  GCNUM MAXZ  MINZ  PT     PTLST TMP   Y
  67.         )
  68.   (setq y t) ;_等高线是否经过
  69.   (setq az (caddr a))
  70.   (setq bz (caddr b))
  71.   (if (= bz az)
  72.     ;;判断两点之间是否有指定等高距的等高线穿过
  73.     (setq y nil)
  74.     (progn (if (< (- bz az) 0)
  75.        ;;使bz>az
  76.        (setq tmp az
  77.        az  bz
  78.        bz  tmp
  79.        tmp a
  80.        a   b
  81.        b   tmp
  82.        )
  83.      )
  84.      (if (< (- bz az) dgj)
  85.        (if (< (- bz (rem bz dgj)) az)
  86.          (setq y nil)
  87.        )
  88.      )
  89.     )
  90.   )
  91.   (if y
  92.     ;;计算此边所有等高线的穿过点
  93.     (progn (setq a (list (car a) (cadr a) 0))
  94.      (setq dist (distance a (list (car b) (cadr b))))
  95.      (setq gaoc (- bz az))
  96.      (setq ang (angle a b))
  97.      (setq minz (* (+ (fix (/ az dgj)) 1) dgj)) ;_最小Z
  98.      (setq maxz (* (fix (/ bz dgj)) dgj)) ;_最大Z
  99.      (setq gcnum (/ (- maxz minz) dgj)) ;_高差算出等高线数量        
  100.      (setq elev minz) ;_从最小的高程画起
  101.      (setq dt (* dist (/ (- elev az) gaoc)))
  102.      (setq pt (polar a ang dt))
  103.      (setq pt (list (car pt) (cadr pt)))
  104.      (setq ptlst (append ptlst (list (list elev pt))))
  105.      (setq dt (* dist (/ dgj gaoc)))
  106.    <font color="red">  (repeat (fix gcnum)</font>
  107.        (setq elev (+ elev dgj))
  108.        (setq pt (polar pt ang dt))
  109.        (setq pt (list (car pt) (cadr pt)))
  110.        (setq ptlst (append ptlst (list (list elev pt))))
  111.      )
  112.     )
  113.   )
  114.   (setq ptlst ptlst)
  115. )

  116. (print "tt2选三角网生等高线")
  117. (defun c:tt2 (/      A    ABLST  B     BB    BCLST BH  C     CALST
  118.         DGJ   E    ELEVG  ELEVGLST    END    FL  FUN   FX
  119.         G      I    JO  LEN   LINE  LINELST  N     NN
  120.         ONE   PTLST QSI  SJXDD SS    START TI  TIME  TWO
  121.         XH
  122.        )
  123.   (command ".undo" "end")
  124.   (command ".undo" "begin")


  125.   (if (setq ss (ssget '((0 . "POLYLINE") (8 . "SJW"))))
  126.     (progn
  127.       (setq ti (car (_VL-TIMES))) ;_获得程序开始时间
  128.       (foreach elevg elevglst
  129.   (set (read elevg) nil)
  130.   )
  131.       (setq elevglst nil)
  132.       (setq dgj (getreal "请输入等高距(米)")) ;_等高距
  133.       (setq i -1)
  134.       (repeat (sslength ss)
  135.   (setq e (ssname ss (setq i (+ 1 i))))
  136.   (setq sjxdd (funsjxdd e))
  137.   (setq a (car sjxdd))
  138.   (setq b (cadr sjxdd))
  139.   (setq c (caddr sjxdd))
  140.   (setq ablst (bianpt a b dgj))
  141.   (setq bclst (bianpt b c dgj))
  142.   (setq calst (bianpt c a dgj))
  143.   (setq ptlst '())
  144.   (setq ptlst (append ptlst ablst bclst calst))
  145.   (while ptlst
  146.     ;;将此三角形三边等高线的穿过点整理成小短线,并加入同高名变量表
  147.     (setq bb (rem (length ptlst) 2))
  148.     (setq one (car ptlst))
  149.     (setq G (car one))
  150.     (setq ptlst (cdr ptlst))
  151.     (setq two (assoc G ptlst))
  152.     (setq ptlst (vl-remove two ptlst))
  153.     (setq one (cadr one))
  154.     (setq two (cadr two))
  155.   <font color="red">  (setq elevg (strcat "G" (rtos (* G 100) 2 0) ))</font>
  156.     ;;创建符号名为elevg的表,或在elevg表的尾部加上此段线
  157.     (if (member elevg elevglst)
  158.       (set (read elevg)
  159.      (append (eval (read elevg))
  160.        (list (list one two) (list two one))
  161.      )
  162.       )
  163.       (progn
  164.         (set (read elevg) (list (list one two) (list two one)))
  165.         (setq elevglst (append elevglst (list elevg))) ;_将此高加入等值线变量名表
  166.       )
  167.     )

  168.   )
  169.       )
  170.       ;;依次取出等值线变量名表
  171.       (foreach elevg elevglst
  172.   (setq g (atof (substr elevg 2))) ;_高程值
  173.   (setq linelst (eval (read elevg))) ;_等值短线表
  174.   (setq len (length linelst))
  175.   (setq a nil)
  176.   (setq b nil)
  177.   ;;短线按x坐标排序,x相同,用y坐标排
  178.   (setq nn (vl-sort-i linelst
  179.           (function (lambda (a b)
  180.           (setq ax (caar a))
  181.           (setq ay (cadar a))
  182.           (setq bx (caar b))
  183.           (setq by (cadar b))
  184.           (if (equal ax bx 0.001)
  185.             (if (equal ay by 0.001)
  186.               T
  187.               (if  (< ay by)
  188.                 T
  189.                 nil
  190.               )
  191.             )
  192.             (if (< ax bx)
  193.               T
  194.               nil
  195.             )
  196.           )
  197.               )
  198.           )
  199.      )
  200.   )
  201.   (setq ptlst '())
  202.   (setq qsi 0)
  203.   ;;同一高程的等高线有三种情况的组合,
  204.   ;;1.单条2.闭合,3.多条
  205.   (while (setq n (nth qsi nn))
  206.     (setq i qsi)
  207.     (setq line (nth n linelst))
  208.     (setq ptlst line)
  209.     (setq jo (rem n 2))
  210.     (setq nn (subst -1 n nn))
  211.     (setq  nn (subst -1
  212.         (if (= 0 jo)
  213.           (1+ n)
  214.           (1- n)
  215.         )
  216.         nn
  217.        )
  218.     )
  219.     (setq start (car line))
  220.     (setq end (cadr line))
  221.     (while (= -1 (nth i nn)) (setq i (1+ i)))
  222.     (setq xh T)
  223.     ;;确定搜索方向
  224.     (setq  fx 1
  225.     fun >
  226.     )
  227.     (while (and xh (setq n (nth i nn)))
  228.       (setq two (nth n linelst))
  229.       (if  (equal end (car two) 0.001)
  230.         (progn (setq n (nth i nn))
  231.          (setq nn (subst -1 n nn))
  232.          (setq jo   (rem n 2)
  233.          nn   (subst  -1
  234.           (if (= 0 jo)
  235.             (1+ n)
  236.             (1- n)
  237.           )
  238.           nn
  239.          )
  240.          ptlst (append ptlst (list (cadr two)))
  241.          start (car two)
  242.          end   (cadr two)
  243.          )
  244.          (if (> (car end) (car start))
  245.            (setq fx  1
  246.            fun >
  247.            )
  248.            (setq fx  -1
  249.            fun <
  250.            )
  251.          )
  252.         )
  253.         (if (fun (car end) (caar two))
  254.     (setq i (+ i fx))
  255.     (setq xh nil)
  256.         )
  257.       )
  258.       (while (and (/= -1 i) (= -1 (nth i nn))) (setq i (+ i fx)))
  259.       (if  (= i -1)
  260.         (setq xh nil)
  261.       )
  262.     )
  263.     (if ptlst
  264.       (progn (if (equal (car ptlst) (last ptlst) 0.001)
  265.          ;;判断闭合
  266.          (setq bh   T
  267.          ptlst (cdr ptlst)
  268.          )
  269.          (setq bh nil)
  270.        )
  271.        (mk2polyline ptlst bh g)
  272.        (setq ptlst '())
  273.       )
  274.     )
  275.     (setq i qsi)
  276.     (while (= -1 (nth i nn)) (setq i (1+ i)))
  277.     (setq qsi i)
  278.   )
  279.       )
  280.       ;;清空定义的序列变量
  281.       (foreach elevg elevglst (set (read elevg) nil))
  282.       (setq elevglst nil)
  283.       (setq time (strcat "\n "
  284.        (rtos (/ (- (car (_VL-TIMES)) ti) 1000.) 2 4)
  285.        " secs."
  286.      )
  287.       ) ;_计算程序耗时
  288.       (princ time)

  289.     )
  290.   )
  291.   (command ".undo" "end")
  292.   (princ)
  293. ) ;_程序完毕

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
发表于 2015-9-4 17:40 | 显示全部楼层
本帖最后由 shmily1023 于 2015-9-4 17:49 编辑

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



您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-3-29 07:18 , Processed in 0.176214 second(s), 17 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表