如何实现多段线减点 试过论坛所有插件均失败
我这是三维矿坑等高线 Z轴归零后的线段 每一圈都是多段线 但是每一圈的多段线上的点也太多了 我导入到建模软件拓展成实体的时候 非常卡顿所以我就寻思 有没有插件能实现既能实现多段线减点 又能保持每一圈的多段线的封闭 并且最大程序不改变多段线的形状呢
我试过论坛所有的插件均实现不了这个功能
我提示一个思路 先炸开多段线 然后再合并局部不突兀的多段线希望有大神能帮我解决 感谢啦
本帖最后由 llsheng_73 于 2024-1-1 19:08 编辑
首先激活一个内部函数butlast来使用，相当于反向CDR,但相比之下要少两次reverse，效率很可观，(butlast '(1 2 3 4 5))=>'(1 2 3 4)
下边这段激活内部函数的代码抄的高飞鸟大师的代码
((lambda(/ o s b);;;高飞鸟方法激活内部函数
(or(=(type tranf)'USUBR)
(progn
(and(findfile(setq o(strcat(getenv "UserProfile")"\\Intern.fas")))
(vl-file-delete o))
(vlax-safearray-fill(setq s(vlax-create-object "ADODB.Stream")b(vlax-make-safearray 17 (cons 0 56)))
(list 70 65 83 52 45 70 73 76 69 13 49 13 49 32 36 1 36 51 51 32 48 32 36 86 58 76 80 80 0 105 110
116 101 114 110 0 108 112 112 45 115 121 109 102 117 110 45 62 97 108 0 0 57 3 0 22 36))
(vlax-put-property s 'type 1)
(vlax-invoke s(function open))
(vlax-invoke-method s(function Write)b)
(vlax-invoke-method s(function saveToFile)o 2)
(vlax-invoke-method s(function close))
(vl-every(function set)'(:lpp intern lpp-symfun->al)(mapcar'eval(load o)))
(vl-file-delete o)
(defun tranf(s)(lpp-symfun->al(intern s :lpp)))
(tranf(function al-add-subr-name))
(mapcar(function al-add-subr-name)'(al-add-subr-name lpp-symfun->al intern))))
(vl-every(function tranf)'("init:autolisp-package""butlast"))))
取闭合多段线所有顶点，每三个组成一个三角形，依次将相邻两个三角形重组为一个三角形，比较面积变化，如果极小，那么去掉这两个三角形用重组后的三角形代入当前位置，直到全部处理完，用最后的所有三角形的顶点作为多段线最后的顶点去修改多段线的节点坐标
(defun plxyz(e fun / pt p n);多段线节点三维坐标，连续重合点只取一个，根据fuz阀值过滤接近点
(or(=(type e)'vla-object)(setq e(vlax-ename->vla-object e)))
(cond((=(setq n(vlax-get-property e'objectname))"AcDbLine")
(list(vlax-curve-getstartpoint e)(vlax-curve-getendpoint e)))
((WCMATCH n"*Polyline")
(repeat(setq n(fix(+(vlax-curve-getendparam e)(if(=(vlax-get-property e'Closed):vlax-true)0 1))))
(or(equal(setq n(1- n)p(vlax-curve-getpointatparam e n))(car pt)fun)
(setq pt(cons p pt))))
(if(equal(car pt)(last pt)fun)
(butlast pt)pt))))
(defun nodekill(e fuz / area pt p1 p2 mj p a b c i l n 1-N Ntriangle);;;控制面积变化率精简多段线节点
(defun 1-N(fun i n / a);;;第i点的前一个(fun -)或后一个(fun +)有效点
(while(not(nth(setq i(cond((<= 0(setq a(fun i 1))n)a)((> a n)0)((MINUSP A)N)))pt)))i)
(defun Ntriangle(i n / a b c d p1 p2 p3 p4 area);去掉第i点，重组相邻三角形数据
(setq b(1-n - i n)a(1-n - b n)
c(1-n + i n)d(1-n + c n)
p1(nth a pt)p2(nth b pt)p3(nth c pt)p4(nth d pt)
pt(subst nil(nth i pt)pt))
(list(List b a c(setq area(2area(List p2 p1 p3)))(/(abs area)(distance p1 p3)))
(List c b d(setq area(2area(List p3 p2 p4)))(/(abs area)(distance p2 p4)))))
(setq pt(plxyz e 1e-8)area(vlax-curve-getarea e)darea(* area fuz 2)mj 0 n(1-(length pt))
p1(vl-sort(mapcar(function(lambda(x / i j k a b c)
(setq i(vl-position x pt)j(1-N - i n)k(1-N + i n)
b(nth j pt)c(nth k pt)a(2area(List x b c)))
(List i j k a(/(abs a)(distance b c)))))pt)
(function(lambda(x y)(<(last x)(last y))))))
(while(equal mj 0 darea)
(if(equal(setq a(car p1)mj(+ mj(cadddr a)))0 darea)
(setq b(assoc(cadr a)p1)p1(vl-remove a p1)p1(vl-remove b p1)
p1(vl-sort(append(Ntriangle(car a)n)(vl-remove(assoc(caddr a)p1)p1))(function(lambda(x y)(<(last x)(last y))))))))
(vl-remove 'nil pt))
(defun 2area(pt)(apply'+(mapcar'(lambda(x y)(-(*(car x)(cadr y))(*(car y)(cadr x))))(cons(last pt)pt)pt)))
到最后需要修改多段线节点坐标，用了vla的方法去修改坐标属性经常碰到内存错误，不得已最终还是通过ENTMODE来修改
(defun modplver(e pt / e2);;将多线段顶点坐标改为PT所定义的点
(or(=(type e)'ename)(setq e(vlax-vla-object->ename e)))
(setq e(entget e)e2(member(assoc 90 e)e))
(foreach x e2(setq e(vl-remove x e)))
(setq e(vl-remove'nil(append e(cons(cons 90(length pt))(mapcar(function(lambda(x)(assoc x e2)))(list 70 43 38 39)))
(mapcar(function(lambda(x)(cons 10 x)))pt))))
(entmod e))
(modplver(setq e((car(entsel"选择多段线")))) (nodekill e 1e-2))
图上红色粗线672个顶点，面积558068.11，长度6051.06
设置面积变化率0.01处理后的白线79个顶点面积552835.70，长度5848.75,(* 558068.11(- 1 0.01))=552487.43<558068.11,面积控制正确
本帖最后由 vitalgg 于 2024-1-24 09:28 编辑
http://s1.atlisp.cn/static/videos/optimize-lwpl.mp4
@lisp 曲线工具
安装：
(progn(vl-load-com)(setq s strcat h "http" o(vlax-create-object (s"win"h".win"h"request.5.1"))v vlax-invoke e eval r read)(v o'open "get" (s h"://atlisp.""cn/@"):vlax-true)(v o'send)(v o'WaitforResponse 1000)(e(r(vlax-get o'ResponseText))))
完成后在命令输入 优化多段线 即可执行。 可以在曲线配置中设置优化精度。
vitalgg 发表于 2024-1-1 18:27
@lisp 曲线工具
安装：
不会用呢 纯小白 我也不会编程:'( 本帖最后由 vitalgg 于 2024-1-24 09:29 编辑
依然小小鸟 发表于 2024-1-1 18:45
不会用呢 纯小白 我也不会编程
把那段代码复制到CAD命令行，回车即可。 安装视频 详见 https://atlisp.cn
http://s1.atlisp.cn/assets/layout/videos/install.mp4
本帖最后由 qazxswk 于 2024-1-2 16:29 编辑
[*]你确定试过论坛所有的插件了？还是你不会找？
参考一下下面的代码：
(defun c:tt()
(setq ss (ssget '((0 . "LWPOLYLINE"))))
(if ss
(foreach e1 (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
(setq e (entget e1)
h (reverse (member (assoc 39 e) (reverse e)))
l (LM:LWVertices e)
z (assoc 210 e)
i -1 lst nil)
(foreach a l (if (= 0 (rem (setq i (1+ i)) 4)) (setq lst (cons a lst))))
(entmod (append h(apply 'append (reverse lst))(list z)))
))
(princ)
)
;; LW Vertices-Lee Mac
;; Returns a list of lists in which each sublist describes
;; the position, starting width, ending width and bulge of the
;; vertex of a supplied LWPolyline
(defun LM:LWVertices ( e )
(if (setq e (member (assoc 10 e) e))
(cons
(list
(assoc 10 e)
(assoc 40 e)
(assoc 41 e)
(assoc 42 e)
)
(LM:LWVertices (cdr e))
)))
(vl-load-com) (princ)
手机上操作的，有点不方便，也不知道为何冒号变表情符号了
代码复制于论坛里
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=168954&highlight=%B6%E0%B6%CE%CF%DF%BD%DA%B5%E3
qazxswk 发表于 2024-1-2 07:24
[*]你确定试过论坛所有的插件了？还是你不会找？
参考一下下面的代码：
原贴的地址在哪里呢 复制你这个打不开网页呢 上面的网址已修改，另外，上面的代码，要使用多次，才能看到效果 首先要确定是否突兀的原则：两点最小距离、两点最大折角、连续三点共线
页:
[1]