求高手们帮忙修改一下,增加一个容差

ysq101

首先注明:此程序作者BY：LL_sheng

2. ;  2017-10-28更新  BY：LL_sheng
   
3. 
   
4. (defun getcolor(e / c)
   
5.   (if(setq e(entget e)c(assoc 62 e))
   
6.     (cdr c)
   
7.     (cdr(assoc 62(tblsearch"layer"(cdr(assoc 8 e)))))
   
8.     ))
   
9. (defun plinexy(e)
   
10.   (mapcar'cdr(vl-remove-if'(lambda(x)(/=(car x)10))(entget e)))
    
11.   )
    
12. (defun Pldir(pt)
    
13.   (<(apply'+(mapcar'(lambda(x y)(-(*(car x)(cadr y))(*(car y)(cadr x))))(cons(last pt)pt)pt))0))
    
14. (defun c:wt(/ s f i e p pt txt c)
    
15.   (if(and(setq s(ssget'((0 . "lwpolyline")(-4 . "&")(70 . 1))))
    
16. (setq s(vl-remove-if'(lambda(x)(/=(type x)'ename))(mapcar'cadr(ssnamex s)))
    
17.        f(getfiled "" "" "txt" 1))
    
18. (setq txt""f(open f"w")))
    
19.     (progn
    
20.       (foreach e s
    
21. (foreach i(if(pldir(setq p(plinexy e)))(setq p(reverse p))p)
    
22.   (if(not(member i pt))(setq pt(append pt(list i))))
    
23.   (setq txt(strcat(itoa(vl-position i pt))"\n"txt)))
    
24. (setq c(getcolor e)
    
25.       c(cadr(assoc c(append'((1" 0 0 0 0 0 0 276")
    
26.    (2" 0 0 0 0 0 0 260")
    
27.    (3" 0 0 0 0 0 0 400")
    
28.    (4" 0 0 0 1 0 0 384")
    
29.    (5" 0 0 0 3 0 0 384")
    
30.    (6" 0 0 25 0 25 0 260")
    
31.    (7" 0 0 0 2 0 0 384")
    
32.    (8" 0 0 0 0 0 0 384"))
    
33.    (list(list c(strcat" 0 0 0 0 0 0 "(itoa c)))))))
    
34.       txt(strcat"\n"(itoa(length p))c"\n"txt)))
    
35.       (setq txt(strcat"\n"(itoa(length s))"\n"txt)
    
36.     i(length pt));;;;
    
37.       (foreach p(reverse pt)
    
38. (entmakex(mapcar'cons'(0 1 10 40 62)(list"text"(itoa i)p 2 1)));;;;
    
39. (setq i(1- i)txt(strcat(rtos(car p)2 4)" "(rtos(* -1.5557 (cadr p))2 4)"\n"txt)))
    
40.       (write-line(strcat(itoa(length pt))"\n\n"txt)f)
    
41.       (close f))
    
42.     ))

;  2017-10-28更新  BY：LL_sheng<br /> <br /> (defun getcolor(e / c)<br />   (if(setq e(entget e)c(assoc 62 e))<br />     (cdr c)<br />     (cdr(assoc 62(tblsearch"layer"(cdr(assoc 8 e)))))<br />     ))<br /> (defun plinexy(e)<br />   (mapcar'cdr(vl-remove-if'(lambda(x)(/=(car x)10))(entget e)))<br />   )<br /> (defun Pldir(pt)<br />   (<(apply'+(mapcar'(lambda(x y)(-(*(car x)(cadr y))(*(car y)(cadr x))))(cons(last pt)pt)pt))0))<br /> (defun c:wt(/ s f i e p pt txt c)<br />   (if(and(setq s(ssget'((0 . "lwpolyline")(-4 . "&")(70 . 1))))<br /> (setq s(vl-remove-if'(lambda(x)(/=(type x)'ename))(mapcar'cadr(ssnamex s)))<br />        f(getfiled "" "" "txt" 1))<br /> (setq txt""f(open f"w")))<br />     (progn<br />       (foreach e s<br /> (foreach i(if(pldir(setq p(plinexy e)))(setq p(reverse p))p)<br />   (if(not(member i pt))(setq pt(append pt(list i))))<br />   (setq txt(strcat(itoa(vl-position i pt))"\n"txt)))<br /> (setq c(getcolor e)<br />       c(cadr(assoc c(append'((1" 0 0 0 0 0 0 276")<br />    (2" 0 0 0 0 0 0 260")<br />    (3" 0 0 0 0 0 0 400")<br />    (4" 0 0 0 1 0 0 384")<br />    (5" 0 0 0 3 0 0 384")<br />    (6" 0 0 25 0 25 0 260")<br />    (7" 0 0 0 2 0 0 384")<br />    (8" 0 0 0 0 0 0 384"))<br />    (list(list c(strcat" 0 0 0 0 0 0 "(itoa c)))))))<br />       txt(strcat"\n"(itoa(length p))c"\n"txt)))<br />       (setq txt(strcat"\n"(itoa(length s))"\n"txt)<br />     i(length pt));;;;<br />       (foreach p(reverse pt)<br /> (entmakex(mapcar'cons'(0 1 10 40 62)(list"text"(itoa i)p 2 1)));;;;<br /> (setq i(1- i)txt(strcat(rtos(car p)2 4)" "(rtos(* -1.5557 (cadr p))2 4)"\n"txt)))<br />       (write-line(strcat(itoa(length pt))"\n\n"txt)f)<br />       (close f))<br />     ))

帮忙修改一下,判断各  闭合多线段  顶点时,
增加容差   差别0.01MM内  全按相同点排除

跪谢

xyp1964

1. (defun getcolor        (e / c)
   
2.   (if (setq e (entget e)
   
3.             c (assoc 62 e)
   
4.       )
   
5.     (cdr c)
   
6.     (cdr (assoc 62 (tblsearch "layer" (cdr (assoc 8 e)))))
   
7.   )
   
8. )
   
9. (defun PtFuzz (pt)
   
10.   (list        (atof (rtos (car pt) 2 3))
    
11.         (atof (rtos (cadr pt) 2 3))
    
12.   )
    
13. )
    
14. (defun plinexy (e / ptn)
    
15.   (setq ptn (vl-remove-if '(lambda (x) (/= (car x) 10)) (entget e)))
    
16.   (mapcar 'PtFuzz (mapcar 'cdr ptn))
    
17. )
    
18. 
    
19. (defun Pldir (pt)
    
20.   (< (apply '+
    
21.             (mapcar '(lambda (x y) (- (* (car x) (cadr y)) (* (car y) (cadr x))))
    
22.                     (cons (last pt) pt)
    
23.                     pt
    
24.             )
    
25.      )
    
26.      0
    
27.   )
    
28. )
    
29. (defun c:tt (/ s f i e p pt txt c)
    
30.   (princ "\n选择实体: ")
    
31.   (if (setq s (ssget '((0 . "*polyline") (70 . 1))))
    
32.     (progn
    
33.       (setq s        (vl-remove-if
    
34.                   '(lambda (x) (/= (type x) 'ename))
    
35.                   (mapcar 'cadr (ssnamex s))
    
36.                 )
    
37.             f        (getfiled "" "" "txt" 1)
    
38.             txt        ""
    
39.             f        (open f "w")
    
40.       )
    
41.       (foreach e s
    
42.         (foreach i (if (pldir (setq p (plinexy e)))
    
43.                      (setq p (reverse p))
    
44.                      p
    
45.                    )
    
46.           (if (not (member i pt))
    
47.             (setq pt (append pt (list i)))
    
48.           )
    
49.           (setq txt (strcat (itoa (vl-position i pt)) "\n" txt))
    
50.         )
    
51.         (setq c          (getcolor e)
    
52.               c          (cadr
    
53.                     (assoc c
    
54.                            (append '((1 " 0 0 0 0 0 0 276")
    
55.                                      (2 " 0 0 0 0 0 0 260")
    
56.                                      (3 " 0 0 0 0 0 0 400")
    
57.                                      (4 " 0 0 0 1 0 0 384")
    
58.                                      (5 " 0 0 0 3 0 0 384")
    
59.                                      (6 " 0 0 25 0 25 0 260")
    
60.                                      (7 " 0 0 0 2 0 0 384")
    
61.                                      (8 " 0 0 0 0 0 0 384")
    
62.                                     )
    
63.                                    (list (list c (strcat " 0 0 0 0 0 0 " (itoa c))))
    
64.                            )
    
65.                     )
    
66.                   )
    
67.               txt (strcat "\n" (itoa (length p)) c "\n" txt)
    
68.         )
    
69.       )
    
70.       (setq txt        (strcat "\n" (itoa (length s)) "\n" txt)
    
71.             i        (length pt)
    
72.       )
    
73.       (foreach p (reverse pt)
    
74.         (entmakex
    
75.           (mapcar 'cons '(0 1 10 40 62) (list "text" (itoa i) p 2 1))
    
76.         )
    
77.         (setq i          (1- i)
    
78.               txt (strcat (rtos (car p) 2 4)
    
79.                           " "
    
80.                           (rtos (* -1.5557 (cadr p)) 2 4)
    
81.                           "\n"
    
82.                           txt
    
83.                   )
    
84.         )
    
85.       )
    
86.       (write-line (strcat (itoa (length pt)) "\n\n" txt) f)
    
87.       (close f)
    
88.     )
    
89.   )
    
90.   (princ)
    
91. )

(defun getcolor        (e / c)<br />   (if (setq e (entget e)<br />             c (assoc 62 e)<br />       )<br />     (cdr c)<br />     (cdr (assoc 62 (tblsearch "layer" (cdr (assoc 8 e)))))<br />   )<br /> )<br /> (defun PtFuzz (pt)<br />   (list        (atof (rtos (car pt) 2 3))<br />         (atof (rtos (cadr pt) 2 3))<br />   )<br /> )<br /> (defun plinexy (e / ptn)<br />   (setq ptn (vl-remove-if '(lambda (x) (/= (car x) 10)) (entget e)))<br />   (mapcar 'PtFuzz (mapcar 'cdr ptn))<br /> )<br /> <br /> (defun Pldir (pt)<br />   (< (apply '+<br />             (mapcar '(lambda (x y) (- (* (car x) (cadr y)) (* (car y) (cadr x))))<br />                     (cons (last pt) pt)<br />                     pt<br />             )<br />      )<br />      0<br />   )<br /> )<br /> (defun c:tt (/ s f i e p pt txt c)<br />   (princ "\n选择实体: ")<br />   (if (setq s (ssget '((0 . "*polyline") (70 . 1))))<br />     (progn<br />       (setq s        (vl-remove-if<br />                   '(lambda (x) (/= (type x) 'ename))<br />                   (mapcar 'cadr (ssnamex s))<br />                 )<br />             f        (getfiled "" "" "txt" 1)<br />             txt        ""<br />             f        (open f "w")<br />       )<br />       (foreach e s<br />         (foreach i (if (pldir (setq p (plinexy e)))<br />                      (setq p (reverse p))<br />                      p<br />                    )<br />           (if (not (member i pt))<br />             (setq pt (append pt (list i)))<br />           )<br />           (setq txt (strcat (itoa (vl-position i pt)) "\n" txt))<br />         )<br />         (setq c          (getcolor e)<br />               c          (cadr<br />                     (assoc c<br />                            (append '((1 " 0 0 0 0 0 0 276")<br />                                      (2 " 0 0 0 0 0 0 260")<br />                                      (3 " 0 0 0 0 0 0 400")<br />                                      (4 " 0 0 0 1 0 0 384")<br />                                      (5 " 0 0 0 3 0 0 384")<br />                                      (6 " 0 0 25 0 25 0 260")<br />                                      (7 " 0 0 0 2 0 0 384")<br />                                      (8 " 0 0 0 0 0 0 384")<br />                                     )<br />                                    (list (list c (strcat " 0 0 0 0 0 0 " (itoa c))))<br />                            )<br />                     )<br />                   )<br />               txt (strcat "\n" (itoa (length p)) c "\n" txt)<br />         )<br />       )<br />       (setq txt        (strcat "\n" (itoa (length s)) "\n" txt)<br />             i        (length pt)<br />       )<br />       (foreach p (reverse pt)<br />         (entmakex<br />           (mapcar 'cons '(0 1 10 40 62) (list "text" (itoa i) p 2 1))<br />         )<br />         (setq i          (1- i)<br />               txt (strcat (rtos (car p) 2 4)<br />                           " "<br />                           (rtos (* -1.5557 (cadr p)) 2 4)<br />                           "\n"<br />                           txt<br />                   )<br />         )<br />       )<br />       (write-line (strcat (itoa (length pt)) "\n\n" txt) f)<br />       (close f)<br />     )<br />   )<br />   (princ)<br /> )

ysq101

符上图片和在测试文件

vectra

问题在
(if (not (member i pt)) 和
(setq txt (strcat (itoa (vl-position i pt)) "\n" txt))
两句上，member 和vl-position两个函数不支持容差，要解决这个问题恐怕要改写整个数据结构，感觉非常复杂

或者能否对点数据进行一定规则的圆整，使得一定范围内的点合并成一个点，但貌似没有很可靠的算法。

ysq101

vectra 发表于 2017-12-11 21:54
问题在
(if (not (member i pt)) 和
(setq txt (strcat (itoa (vl-position i pt)) "\n" txt))

数据可以  取整的...没多大影响
求帮修改一下

ysq101

xyp1964 发表于 2017-12-12 00:25

院长出手果然牛B。。。。

问题完美解决。。

谢谢大师~~~~

ysq101

xyp1964 发表于 2017-12-12 00:25

院长出手果然牛B。。。。
问题完美解决。。
谢谢大师~~~~

ysq101

xyp1964 发表于 2017-12-11 19:18

今天实测了一下，还是会间歇性出现同样的BUG


按说我改了这个精度参数，X轴座标输出的应该是1位点数才对。
但还是输出了4位小数，
Y轴因为*1.5557的原因。输出4位小数是正常的
(atof (rtos (car pt) 2 1))


可能后面的函数不取用你取整后的 座标点？

ysq101

xyp1964 发表于 2017-12-11 19:18

问题已经解决了。。。竟然是我打包一起的子程序重名了。。。