求大师帮忙看一下 关于PL线 "凹位"的判断

ysq101

如上图...帮忙写个可以判断有这类多线段的LISP    找到后将它们全部改为红色只要有一处凹位就直接改成红色

谢谢大师

yshf

1. ;请试用以下程序(未判断多段线是否是闭合多边形)
   
2. (defun c:test()
   
3.     (vl-load-com)
   
4.     (setq cm (getvar "cmdecho"))
   
5.     (setvar  "cmdecho" 0)
   
6.     (command "_undo" "be")
   
7. 
   
8.     (if (setq ssa (ssget '((0 . "*POLYLINE"))))
   
9.         (progn
   
10.              (setq m (sslength ssa) j 0)
    
11.              (repeat m
    
12.                   (setq obj  (vlax-ename->vla-object (ssname ssa j))
    
13.                         pts  (vlax-get obj "Coordinates")
    
14.                         name (vlax-get obj "ObjectName")
    
15.                         ptb  nil
    
16.                   )
    
17.               
    
18.                   (while pts
    
19.                       (if (= name "AcDb3dPolyline")
    
20.                           (setq ptb (cons (list (car pts) (cadr pts) (caddr pts)) ptb)
    
21.                                 pts (cdr (cdr (cdr pts)))
    
22.                           )
    
23.                           (setq ptb (cons (list (car pts) (cadr pts)) ptb)
    
24.                                 pts (cdr (cdr pts))
    
25.                           )
    
26.                       )
    
27.                   )
    
28.                
    
29.                   (if (equal (car ptb) (last ptb) 1e-3)
    
30.                       (setq ptb (cdr ptb))
    
31.                   )
    
32.                   (setq n (1- (length ptb)) i 0  slcj nil)
    
33. 
    
34.                   (while (<= i n)
    
35.                        (if (= i 0)
    
36.                            (setq p1 (last ptb))
    
37.                            (setq p1 (nth (1- i) ptb))
    
38.                        )
    
39.                        (setq p2 (nth i ptb))
    
40.                        (if (= i n)
    
41.                            (setq p3 (car ptb))
    
42.                            (setq p3 (nth (1+ i) ptb))
    
43.                        )
    
44.                        (setq cj (car (trans (mapcar '- p1 p2) 1 (mapcar '- p3 p2)))
    
45.                              slcj (cons cj slcj)
    
46.                        )
    
47.                      
    
48.                        (if (not (or (vl-every '(lambda(x)(> x 0.0)) slcj)
    
49.                                     (vl-every '(lambda(x)(< x 0.0)) slcj)
    
50.                                 )
    
51.                            )
    
52.                            (progn
    
53.                                (vlax-put obj "color" "1")
    
54.                                (setq i n)
    
55.                            )
    
56.                       )
    
57.                       (setq i (1+ i))
    
58.                    )
    
59.                   
    
60. 
    
61.                   (setq j (1+ j))
    
62.              )
    
63.         )
    
64.     )
    
65. 
    
66.     (command "_undo" "e")
    
67.     (setvar "cmdecho" cm)
    
68.     (princ)
    
69. )

;请试用以下程序(未判断多段线是否是闭合多边形)<br /> (defun c:test()<br />     (vl-load-com)<br />     (setq cm (getvar "cmdecho"))<br />     (setvar  "cmdecho" 0)<br />     (command "_undo" "be")<br /> <br />     (if (setq ssa (ssget '((0 . "*POLYLINE"))))<br />         (progn<br />              (setq m (sslength ssa) j 0)<br />              (repeat m<br />                   (setq obj  (vlax-ename->vla-object (ssname ssa j))<br />                         pts  (vlax-get obj "Coordinates")<br />                         name (vlax-get obj "ObjectName")<br />                         ptb  nil<br />                   )<br />               <br />                   (while pts<br />                       (if (= name "AcDb3dPolyline")<br />                           (setq ptb (cons (list (car pts) (cadr pts) (caddr pts)) ptb)<br />                                 pts (cdr (cdr (cdr pts)))<br />                           )<br />                           (setq ptb (cons (list (car pts) (cadr pts)) ptb)<br />                                 pts (cdr (cdr pts))<br />                           )<br />                       )<br />                   )<br />                <br />                   (if (equal (car ptb) (last ptb) 1e-3)<br />                       (setq ptb (cdr ptb))<br />                   )<br />                   (setq n (1- (length ptb)) i 0  slcj nil)<br /> <br />                   (while (<= i n)<br />                        (if (= i 0)<br />                            (setq p1 (last ptb))<br />                            (setq p1 (nth (1- i) ptb))<br />                        )<br />                        (setq p2 (nth i ptb))<br />                        (if (= i n)<br />                            (setq p3 (car ptb))<br />                            (setq p3 (nth (1+ i) ptb))<br />                        )<br />                        (setq cj (car (trans (mapcar '- p1 p2) 1 (mapcar '- p3 p2)))<br />                              slcj (cons cj slcj)<br />                        )<br />                       <br />                        (if (not (or (vl-every '(lambda(x)(> x 0.0)) slcj)<br />                                     (vl-every '(lambda(x)(< x 0.0)) slcj)<br />                                 )<br />                            )<br />                            (progn<br />                                (vlax-put obj "color" "1")<br />                                (setq i n)<br />                            )<br />                       )<br />                       (setq i (1+ i))<br />                    )<br />                   <br /> <br />                   (setq j (1+ j))<br />              )<br />         )<br />     )<br /> <br />     (command "_undo" "e")<br />     (setvar "cmdecho" cm)<br />     (princ)<br /> )

llsheng_73

对于封闭多段线，只要是凹点，那么该点及相邻两点组成的三角形的方向必然与该多段线整体方向相反

1. (defun plxyz(e fuz / i p pt);多段线节点三维坐标，连续重合点只取一个，根据fuz阀值过滤接近点
   
2.   (setq i(-(vlax-curve-getendparam e)(logand(cdr(assoc 70(entget e)))1)-1))
   
3.   (while(setq i(1- i)p(vlax-curve-getpointatparam e i))
   
4.     (setq pt(if(equal(car pt)p fuz)pt(cons p pt))))
   
5.   )
   
6. (defun 2area(pt)
   
7.   (apply'+(mapcar'(lambda(x y)(-(*(car x)(cadr y))(*(car y)(cadr x))))(cons(last pt)pt)pt)))
   
8. (defun pldir(e / p p1 p2);;e多段线图元或者对象
   
9.   (vla-GetBoundingBox(if(=(type e)'ename)(vlax-ename->vla-object e)e)'p1'p2)
   
10.   (mapcar'set'(p1 p2)(mapcar'vlax-safearray->list(list p1 p2)))
    
11.   (2area(Mapcar'cdr(vl-sort(mapcar'(lambda(x)(setq p(vlax-curve-getclosestpointto e x))
    
12.                                             (cons(vlax-curve-getparamatpoint e p)p))
    
13.                                          (list(list(car p1)(cadr p2))p1(list(car p2)(cadr p1))p2))
    
14.                                   '(lambda(x y)(<(car x)(car y)))))))
    
15. (defun Pitpl(e / a p)
    
16.   (setq p(plxyz e 0)
    
17.         a(pldir e))
    
18.   (vl-some'(lambda(x y z)(<(*(2area(list x y z))a)0))(cons(last p)p)p(cdr(append p(list(car p)))))
    
19.   )
    
20. (defun c:tt(/ s)
    
21.   (if(setq s(ssget'((0 . "lwpolyline")(-4 . "&")(70 . 1))))
    
22.     (foreach x(vl-remove'nil(mapcar'(lambda(x)(if(=(type(cadr x))'ename)(cadr x)))(ssnamex s)))
    
23.       (if(Pitpl x)
    
24.         (entmod(setq x(entget x)x(if(assoc 62 x)(subst'(62 . 1)(assoc 62 x)x)(append x'((62 . 1))))))))))

(defun plxyz(e fuz / i p pt);多段线节点三维坐标，连续重合点只取一个，根据fuz阀值过滤接近点<br />   (setq i(-(vlax-curve-getendparam e)(logand(cdr(assoc 70(entget e)))1)-1))<br />   (while(setq i(1- i)p(vlax-curve-getpointatparam e i))<br />     (setq pt(if(equal(car pt)p fuz)pt(cons p pt))))<br />   )<br /> (defun 2area(pt)<br />   (apply'+(mapcar'(lambda(x y)(-(*(car x)(cadr y))(*(car y)(cadr x))))(cons(last pt)pt)pt)))<br /> (defun pldir(e / p p1 p2);;e多段线图元或者对象<br />   (vla-GetBoundingBox(if(=(type e)'ename)(vlax-ename->vla-object e)e)'p1'p2)<br />   (mapcar'set'(p1 p2)(mapcar'vlax-safearray->list(list p1 p2)))<br />   (2area(Mapcar'cdr(vl-sort(mapcar'(lambda(x)(setq p(vlax-curve-getclosestpointto e x))<br />                                             (cons(vlax-curve-getparamatpoint e p)p))<br />                                          (list(list(car p1)(cadr p2))p1(list(car p2)(cadr p1))p2))<br />                                   '(lambda(x y)(<(car x)(car y)))))))<br /> (defun Pitpl(e / a p)<br />   (setq p(plxyz e 0)<br />         a(pldir e))<br />   (vl-some'(lambda(x y z)(<(*(2area(list x y z))a)0))(cons(last p)p)p(cdr(append p(list(car p)))))<br />   )<br /> (defun c:tt(/ s)<br />   (if(setq s(ssget'((0 . "lwpolyline")(-4 . "&")(70 . 1))))<br />     (foreach x(vl-remove'nil(mapcar'(lambda(x)(if(=(type(cadr x))'ename)(cadr x)))(ssnamex s)))<br />       (if(Pitpl x)<br />         (entmod(setq x(entget x)x(if(assoc 62 x)(subst'(62 . 1)(assoc 62 x)x)(append x'((62 . 1))))))))))

其实还有更简单的办法，凹点内角大于必定大于180,如果用angle来计算两条相邻边的角度后相减来得到内角,实际上是比较烦的。好在(n-1),n,(n+1)这样连续三点的内角可以把(n+1)转换到到n(n-1)直线，根据得到的坐标的来判断是否大于180,当然，这个判断的条件实际上也会因为点的方向不一样而完全相反,

1. (defun plinexy(e)
   
2.   (mapcar'cdr(vl-remove-if'(lambda(x)(/=(car x)10))(entget e))))
   
3. (defun 2area(pt / a)
   
4.   (setq a(apply'+(mapcar'(lambda(x y)(-(*(car x)(cadr y))(*(car y)(cadr x))))(cons(last pt)pt)pt))a(/ a(abs a))))
   
5. (defun pitang(p p1 p2 a);;角p2 p1 p不大于180,a为给定方向
   
6.   (<(*(car(trans(mapcar'- p1 p) 0 (mapcar'- p1 p2)))a)0))
   
7. (defun pitpl(e / p a)
   
8.   (setq p(plinexy e)
   
9. a(2area p)
   
10. p(vl-some'(lambda(x y z)(pitang x y z a))(cons(last p)p)p(cdr(append p(list(car p)))))))
    
11. (defun c:tt(/ s)
    
12.   (if(setq s(ssget'((0 . "lwpolyline")(-4 . "&")(70 . 1))))
    
13.     (foreach x(vl-remove'nil(mapcar'(lambda(x)(if(=(type(cadr x))'ename)(cadr x)))(ssnamex s)))
    
14.       (if(Pitpl x)
    
15. (entmod(setq x(entget x)x(if(assoc 62 x)(subst'(62 . 1)(assoc 62 x)x)(append x'((62 . 1))))))))))

(defun plinexy(e)<br />   (mapcar'cdr(vl-remove-if'(lambda(x)(/=(car x)10))(entget e))))<br /> (defun 2area(pt / a)<br />   (setq a(apply'+(mapcar'(lambda(x y)(-(*(car x)(cadr y))(*(car y)(cadr x))))(cons(last pt)pt)pt))a(/ a(abs a))))<br /> (defun pitang(p p1 p2 a);;角p2 p1 p不大于180,a为给定方向<br />   (<(*(car(trans(mapcar'- p1 p) 0 (mapcar'- p1 p2)))a)0))<br /> (defun pitpl(e / p a)<br />   (setq p(plinexy e)<br /> a(2area p)<br /> p(vl-some'(lambda(x y z)(pitang x y z a))(cons(last p)p)p(cdr(append p(list(car p)))))))<br /> (defun c:tt(/ s)<br />   (if(setq s(ssget'((0 . "lwpolyline")(-4 . "&")(70 . 1))))<br />     (foreach x(vl-remove'nil(mapcar'(lambda(x)(if(=(type(cadr x))'ename)(cadr x)))(ssnamex s)))<br />       (if(Pitpl x)<br /> (entmod(setq x(entget x)x(if(assoc 62 x)(subst'(62 . 1)(assoc 62 x)x)(append x'((62 . 1))))))))))

lijiao

1. (defun c:aopl (/ I SS)
   
2.   (if (setq ss (ssget '((0 . "LWPOLYLINE") (70 . 1))))
   
3.     (progn
   
4.       (setq i -1)
   
5.       (repeat (sslength ss)
   
6.         (ao-p (ssname ss (setq i (1+ i))))
   
7.       )
   
8.     )
   
9.   )
   
10.   (princ)
    
11. )
    
12. (defun ao-p (pl / DATA PTS PTS1 PTS2 Y ZXS ZX)
    
13.   (setq data (entget pl))
    
14.   (setq pts (VL-REMOVE-IF-NOT '(lambda (y) (= (car y) 10)) data))
    
15.   (setq pts (mapcar 'cdr pts))
    
16.   (setq pts1 (cdr (append pts (list (car pts)))))
    
17.   (setq pts2 (cdr (append pts1 (list (car pts1)))))
    
18.   (setq pts (mapcar 'list pts pts1 pts2))
    
19.   (setq        pts (mapcar '(lambda (y)
    
20.                        (cons 'z y)
    
21.                      )
    
22.                     pts
    
23.             )
    
24.   )
    
25.   (setq zxs (mapcar 'shiliang pts))  (setq zx (car zxs))
    
26.   (setq zxs (VL-REMOVE-IF-NOT '(lambda (y) (= y zx)) zxs))
    
27.   (if zxs
    
28.     (progn
    
29.       (if (assoc 62 data)
    
30.         (setq data (subst '(62 . 1) (assoc 62 data) data))
    
31.         (setq data (append data '((62 . 1))))
    
32.       )
    
33.       (entmod data)
    
34.       t
    
35.     )
    
36.   )
    
37. )
    
38. (defun shiliang        (lst / CJ X1 X2 Y1 Y2)
    
39.   (cond
    
40.     ((member (car lst) '(+ -))
    
41.      (apply 'mapcar lst)
    
42.     )
    
43.     ((= (car lst) 'x)
    
44.      (mapcar 'set '(x1 y1) (cadr lst))
    
45.      (mapcar 'set '(x2 y2) (caddr lst))
    
46.      (- (* x1 y2) (* x2 y1))
    
47.     )
    
48.     ((= (car lst) 'z)
    
49.      (setq cj (shiliang
    
50.                 (list 'x
    
51.                       (shiliang (list '- (caddr lst) (cadr lst)))
    
52.                       (shiliang (list '- (cadddr lst) (cadr lst)))
    
53.                 )
    
54.               )
    
55.      )
    
56.      (cond
    
57.        ((equal cj 0.0 0.0001) 0)
    
58.        ((> cj 0.0) 1)
    
59.        ((< cj 0.0) -1)
    
60.      )
    
61.     )
    
62.   )
    
63. )

(defun c:aopl (/ I SS)<br />   (if (setq ss (ssget '((0 . "LWPOLYLINE") (70 . 1))))<br />     (progn<br />       (setq i -1)<br />       (repeat (sslength ss)<br />         (ao-p (ssname ss (setq i (1+ i))))<br />       )<br />     )<br />   )<br />   (princ)<br /> )<br /> (defun ao-p (pl / DATA PTS PTS1 PTS2 Y ZXS ZX)<br />   (setq data (entget pl))<br />   (setq pts (VL-REMOVE-IF-NOT '(lambda (y) (= (car y) 10)) data))<br />   (setq pts (mapcar 'cdr pts))<br />   (setq pts1 (cdr (append pts (list (car pts)))))<br />   (setq pts2 (cdr (append pts1 (list (car pts1)))))<br />   (setq pts (mapcar 'list pts pts1 pts2))<br />   (setq        pts (mapcar '(lambda (y)<br />                        (cons 'z y)<br />                      )<br />                     pts<br />             )<br />   )<br />   (setq zxs (mapcar 'shiliang pts))  (setq zx (car zxs))<br />   (setq zxs (VL-REMOVE-IF-NOT '(lambda (y) (= y zx)) zxs))<br />   (if zxs<br />     (progn<br />       (if (assoc 62 data)<br />         (setq data (subst '(62 . 1) (assoc 62 data) data))<br />         (setq data (append data '((62 . 1))))<br />       )<br />       (entmod data)<br />       t<br />     )<br />   )<br /> )<br /> (defun shiliang        (lst / CJ X1 X2 Y1 Y2)<br />   (cond<br />     ((member (car lst) '(+ -))<br />      (apply 'mapcar lst)<br />     )<br />     ((= (car lst) 'x)<br />      (mapcar 'set '(x1 y1) (cadr lst))<br />      (mapcar 'set '(x2 y2) (caddr lst))<br />      (- (* x1 y2) (* x2 y1))<br />     )<br />     ((= (car lst) 'z)<br />      (setq cj (shiliang<br />                 (list 'x<br />                       (shiliang (list '- (caddr lst) (cadr lst)))<br />                       (shiliang (list '- (cadddr lst) (cadr lst)))<br />                 )<br />               )<br />      )<br />      (cond<br />        ((equal cj 0.0 0.0001) 0)<br />        ((> cj 0.0) 1)<br />        ((< cj 0.0) -1)<br />      )<br />     )<br />   )<br /> )

水吉空

定制开发请去定制区。提问题起码要给个悬赏吧，什么都没有谁给你写？

ysq101

水吉空 发表于 2017-10-19 23:15
定制开发请去定制区。提问题起码要给个悬赏吧，什么都没有谁给你写？

我错了............其实我一开始忘了点悬赏   明经币我还是有很多的太久没写LISP...
现在都像个大傻瓜一样...连LISP不读不懂了

ysq101

yshf 发表于 2017-10-20 10:09

这算法。。。好像是用点来   “硬算”

ysq101

lijiao 发表于 2017-10-20 10:42

实测程序出错了。。。左下角一个没有凹位

自贡黄明儒

llsheng_73 发表于 2017-10-20 11:14
对于封闭多段线，只要是凹点，那么该点及相邻两点组成的三角形的方向必然与该多段线整体方向相反

旋向有正有反就可以判断了吧，是不是不用判断整个旋向？

llsheng_73

自贡黄明儒 发表于 2017-10-20 12:02
旋向有正有反就可以判断了吧，是不是不用判断整个旋向？

整个多段线方向并不需要这条多段的所有点参与计算，实际上只需要取出四个点（其外接正矩形的四个角点到该多段线的最近点）按param排序就行
跟依次取三角形来计算旋向，直到乘积小于0或者所有三角形计算完再看乘积来判断有无凹点，应该区别不大
直接找出大于180的内角更简单也容易理解。。

1. (defun plinexy(e)
   
2.   (mapcar'cdr(vl-remove-if'(lambda(x)(/=(car x)10))(entget e))))
   
3. (defun ptdir(pt / a);;
   
4.   (if(zerop(setq a(apply'+(mapcar'(lambda(x y)(-(*(car x)(cadr y))(*(car y)(cadr x))))(cons(last pt)pt)pt))))
   
5.     0(/ a(abs a))))
   
6. (defun pitang(p p1 p2 a);;角p2 p1 p不大于180,a为给定方向
   
7.   (<(*(car(trans(mapcar'- p1 p) 0 (mapcar'- p1 p2)))a)0))
   
8. (defun pitpl(e / p a);;e是否有凹点
   
9.   (setq p(plinexy e)
   
10. a(ptdir p)
    
11. p(vl-some'(lambda(x y z)(pitang x y z a))(cons(last p)p)p(cdr(append p(list(car p)))))))
    
12. (defun pits(e / p a);;e的所有凹点
    
13.   (setq p(plinexy e)
    
14. a(ptdir p)
    
15. p(vl-remove'nil(mapcar'(lambda(x y z)(if(pitang x y z a)y))(cons(last p)p)p(cdr(append p(list(car p))))))))
    
16. (defun c:tt(/ s);;有凹点的多段线变红
    
17.   (if(setq s(ssget'((0 . "lwpolyline")(-4 . "&")(70 . 1))))
    
18.     (foreach x(vl-remove'nil(mapcar'(lambda(x)(if(=(type(cadr x))'ename)(cadr x)))(ssnamex s)))
    
19.       (if(Pitpl x)
    
20. (entmod(setq x(entget x)x(if(assoc 62 x)(subst'(62 . 1)(assoc 62 x)x)(append x'((62 . 1))))))))))
    
21. (defun c:t1(/ s p);;凹点处画圆
    
22.   (if(setq s(ssget'((0 . "lwpolyline")(-4 . "&")(70 . 1))))
    
23.     (foreach x(vl-remove'nil(mapcar'(lambda(x)(if(=(type(cadr x))'ename)(cadr x)))(ssnamex s)))
    
24.       (foreach i(pits x)
    
25. (entmakex(mapcar'cons'(0 10 40 62)(list"circle"i 1 2)))))))

(defun plinexy(e)<br />   (mapcar'cdr(vl-remove-if'(lambda(x)(/=(car x)10))(entget e))))<br /> (defun ptdir(pt / a);;<br />   (if(zerop(setq a(apply'+(mapcar'(lambda(x y)(-(*(car x)(cadr y))(*(car y)(cadr x))))(cons(last pt)pt)pt))))<br />     0(/ a(abs a))))<br /> (defun pitang(p p1 p2 a);;角p2 p1 p不大于180,a为给定方向<br />   (<(*(car(trans(mapcar'- p1 p) 0 (mapcar'- p1 p2)))a)0))<br /> (defun pitpl(e / p a);;e是否有凹点<br />   (setq p(plinexy e)<br /> a(ptdir p)<br /> p(vl-some'(lambda(x y z)(pitang x y z a))(cons(last p)p)p(cdr(append p(list(car p)))))))<br /> (defun pits(e / p a);;e的所有凹点<br />   (setq p(plinexy e)<br /> a(ptdir p)<br /> p(vl-remove'nil(mapcar'(lambda(x y z)(if(pitang x y z a)y))(cons(last p)p)p(cdr(append p(list(car p))))))))<br /> (defun c:tt(/ s);;有凹点的多段线变红<br />   (if(setq s(ssget'((0 . "lwpolyline")(-4 . "&")(70 . 1))))<br />     (foreach x(vl-remove'nil(mapcar'(lambda(x)(if(=(type(cadr x))'ename)(cadr x)))(ssnamex s)))<br />       (if(Pitpl x)<br /> (entmod(setq x(entget x)x(if(assoc 62 x)(subst'(62 . 1)(assoc 62 x)x)(append x'((62 . 1))))))))))<br /> (defun c:t1(/ s p);;凹点处画圆<br />   (if(setq s(ssget'((0 . "lwpolyline")(-4 . "&")(70 . 1))))<br />     (foreach x(vl-remove'nil(mapcar'(lambda(x)(if(=(type(cadr x))'ename)(cadr x)))(ssnamex s)))<br />       (foreach i(pits x)<br /> (entmakex(mapcar'cons'(0 10 40 62)(list"circle"i 1 2)))))))