【拓扑处理】多边形（面）延伸到多边形

Lispboy

处理两个封闭的多边形，延伸其中的一个贴合到另外一个

1. (defun c:xdtb_polygonextend (/ #constantwidth data data1 data2 e e1 e2 info int1 int2 ints inx1 inx2
   
2.                              ln1 ln2 oninx1 oninx2 p1 p2 pmid1 pmid2 pt pts sub1 sub2 tf x xl1 xl2 y
   
3.                             )
   
4.   (defun _near (pt ints)
   
5.     (setq pts (mapcar '(lambda (x) (list (distance x pt) x)) ints)
   
6.           pts (vl-sort pts '(lambda (x y) (< (car x) (car y))))
   
7.     )
   
8.     (last (car pts))
   
9.   )
   
10.   (defun _select (info / tf e1 p1 inx1 oninx1 ln1)
    
11.     (setq tf t)
    
12.     (while (and tf
    
13.                 (setq e1 (xdrx_entsel
    
14.                            (xdrx_prompt "\n拾取延伸边" info "(直线段)<退出>:" t)
    
15.                            '((0 . "*polyline") (-4 . "&=") (70 . 1))
    
16.                          )
    
17.                 )
    
18.            )
    
19.       (setq p1 (trans (cadr e1) 1 0))
    
20.       (setq e1 (car e1))
    
21.       (setq inx1 (xdrx_getpropertyvalue e1 "nearindex" p1))
    
22.       (setq oninx1 (xdrx_polyline_onsegat e1 p1))
    
23.       (setq p1 (xdrx_polyline_getpointat e1 inx1))
    
24.       (if (setq ln1 (xdrx_polyline_getlinesegat e1 oninx1 t))
    
25.         (setq tf nil)
    
26.         (xdrx_prompt "\n没有选中直线段，重试...")
    
27.       )
    
28.     )
    
29.     (if e1
    
30.       (list e1 p1 inx1 oninx1 ln1)
    
31.     )
    
32.   )
    
33.   (xdrx_begin)
    
34.   (if (and (apply 'and
    
35.                   (mapcar 'set '(e1 p1 inx1 oninx1 ln1) (_select 1))
    
36.            )
    
37.            (apply 'and
    
38.                   (mapcar 'set '(e2 p2 inx2 oninx2 ln2) (_select 2))
    
39.            )
    
40.            (equal e1 e2)
    
41.            (setq e (xdrx_entsel
    
42.                      "\n拾取目标多段线<退出>:"
    
43.                      '((0 . "*polyline") (-4 . "&=") (70 . 1))
    
44.                    )
    
45.            )
    
46.            (setq pt (trans (cadr e) 1 0))
    
47.            (setq e (car e))
    
48.            (setq pmid1 (xdrx_curve_getclosestpoint e1 pt))
    
49.            (setq pmid2 (XD:Curve:OppositePt e1 pmid1))
    
50.            (setq int1 (xdrx_get_inters ln1 e 1))
    
51.            (setq int2 (xdrx_get_inters ln2 e 1))
    
52.            (setq int1 (_near p1 int1))
    
53.            (setq int2 (_near p2 int2))
    
54.            (setq sub1 (xd::curve:getsub e int1 int2 pt))
    
55.            (setq sub2 (xd::curve:getsub e1 p1 p2 pmid2))
    
56.            (setq data1 (xdrx_getpropertyvalue sub1 "get"))
    
57.            (setq data2 (xdrx_getpropertyvalue sub2 "get"))
    
58.            (setq xl1 (xdge::constructor "kline3d" ln1))
    
59.            (setq xl2 (xdge::constructor "kline3d" ln2))
    
60.       )
    
61.     (progn (cond ((or (equal (xdge::getpropertyvalue xl1 "distanceto" (caar data1))
    
62.                              (xdge::getpropertyvalue xl1 "distanceto" (caar data2))
    
63.                              1e-3
    
64.                       )
    
65.                       (equal (xdge::getpropertyvalue xl2 "distanceto" (caar data1))
    
66.                              (xdge::getpropertyvalue xl2 "distanceto" (caar data2))
    
67.                              1e-3
    
68.                       )
    
69.                   )
    
70.                   (setq data (mapcar 'append
    
71.                                      data1
    
72.                                      (mapcar 'cdr (mapcar 'reverse (mapcar 'cdr data2)))
    
73.                              )
    
74.                   )
    
75.                  )
    
76.                  ((or (equal (xdge::getpropertyvalue xl1 "distanceto" (caar data1))
    
77.                              (xdge::getpropertyvalue xl1 "distanceto" (last (car data2)))
    
78.                              1e-3
    
79.                       )
    
80.                       (equal (xdge::getpropertyvalue xl2 "distanceto" (caar data1))
    
81.                              (xdge::getpropertyvalue xl2 "distanceto" (last (car data2)))
    
82.                              1e-3
    
83.                       )
    
84.                   )
    
85.                   (setq data (mapcar 'append
    
86.                                      data1
    
87.                                      (mapcar 'reverse
    
88.                                              (mapcar 'cdr (mapcar 'reverse (mapcar 'cdr data2)))
    
89.                                      )
    
90.                              )
    
91.                   )
    
92.                  )
    
93.            )
    
94.            (xdrx_getpropertyvalue e1 "constantwidth")
    
95.            (xdrx_setpropertyvalue
    
96.              e1 "set" data "closed" t "constantwidth" #constantwidth
    
97.             )
    
98.     )
    
99.   )
    
100.   (xdrx_end)
     
101.   (princ)
     
102. )
     

(defun c:xdtb_polygonextend (/ #constantwidth data data1 data2 e e1 e2 info int1 int2 ints inx1 inx2<br />                              ln1 ln2 oninx1 oninx2 p1 p2 pmid1 pmid2 pt pts sub1 sub2 tf x xl1 xl2 y<br />                             )<br />   (defun _near (pt ints)<br />     (setq pts (mapcar '(lambda (x) (list (distance x pt) x)) ints)<br />           pts (vl-sort pts '(lambda (x y) (< (car x) (car y))))<br />     )<br />     (last (car pts))<br />   )<br />   (defun _select (info / tf e1 p1 inx1 oninx1 ln1)<br />     (setq tf t)<br />     (while (and tf<br />                 (setq e1 (xdrx_entsel<br />                            (xdrx_prompt "\n拾取延伸边" info "(直线段)<退出>:" t)<br />                            '((0 . "*polyline") (-4 . "&=") (70 . 1))<br />                          )<br />                 )<br />            )<br />       (setq p1 (trans (cadr e1) 1 0))<br />       (setq e1 (car e1))<br />       (setq inx1 (xdrx_getpropertyvalue e1 "nearindex" p1))<br />       (setq oninx1 (xdrx_polyline_onsegat e1 p1))<br />       (setq p1 (xdrx_polyline_getpointat e1 inx1))<br />       (if (setq ln1 (xdrx_polyline_getlinesegat e1 oninx1 t))<br />         (setq tf nil)<br />         (xdrx_prompt "\n没有选中直线段，重试...")<br />       )<br />     )<br />     (if e1<br />       (list e1 p1 inx1 oninx1 ln1)<br />     )<br />   )<br />   (xdrx_begin)<br />   (if (and (apply 'and<br />                   (mapcar 'set '(e1 p1 inx1 oninx1 ln1) (_select 1))<br />            )<br />            (apply 'and<br />                   (mapcar 'set '(e2 p2 inx2 oninx2 ln2) (_select 2))<br />            )<br />            (equal e1 e2)<br />            (setq e (xdrx_entsel<br />                      "\n拾取目标多段线<退出>:"<br />                      '((0 . "*polyline") (-4 . "&=") (70 . 1))<br />                    )<br />            )<br />            (setq pt (trans (cadr e) 1 0))<br />            (setq e (car e))<br />            (setq pmid1 (xdrx_curve_getclosestpoint e1 pt))<br />            (setq pmid2 (XD:Curve:OppositePt e1 pmid1))<br />            (setq int1 (xdrx_get_inters ln1 e 1))<br />            (setq int2 (xdrx_get_inters ln2 e 1))<br />            (setq int1 (_near p1 int1))<br />            (setq int2 (_near p2 int2))<br />            (setq sub1 (xd::curve:getsub e int1 int2 pt))<br />            (setq sub2 (xd::curve:getsub e1 p1 p2 pmid2))<br />            (setq data1 (xdrx_getpropertyvalue sub1 "get"))<br />            (setq data2 (xdrx_getpropertyvalue sub2 "get"))<br />            (setq xl1 (xdge::constructor "kline3d" ln1))<br />            (setq xl2 (xdge::constructor "kline3d" ln2))<br />       )<br />     (progn (cond ((or (equal (xdge::getpropertyvalue xl1 "distanceto" (caar data1))<br />                              (xdge::getpropertyvalue xl1 "distanceto" (caar data2))<br />                              1e-3<br />                       )<br />                       (equal (xdge::getpropertyvalue xl2 "distanceto" (caar data1))<br />                              (xdge::getpropertyvalue xl2 "distanceto" (caar data2))<br />                              1e-3<br />                       )<br />                   )<br />                   (setq data (mapcar 'append<br />                                      data1<br />                                      (mapcar 'cdr (mapcar 'reverse (mapcar 'cdr data2)))<br />                              )<br />                   )<br />                  )<br />                  ((or (equal (xdge::getpropertyvalue xl1 "distanceto" (caar data1))<br />                              (xdge::getpropertyvalue xl1 "distanceto" (last (car data2)))<br />                              1e-3<br />                       )<br />                       (equal (xdge::getpropertyvalue xl2 "distanceto" (caar data1))<br />                              (xdge::getpropertyvalue xl2 "distanceto" (last (car data2)))<br />                              1e-3<br />                       )<br />                   )<br />                   (setq data (mapcar 'append<br />                                      data1<br />                                      (mapcar 'reverse<br />                                              (mapcar 'cdr (mapcar 'reverse (mapcar 'cdr data2)))<br />                                      )<br />                              )<br />                   )<br />                  )<br />            )<br />            (xdrx_getpropertyvalue e1 "constantwidth")<br />            (xdrx_setpropertyvalue<br />              e1 "set" data "closed" t "constantwidth" #constantwidth<br />             )<br />     )<br />   )<br />   (xdrx_end)<br />   (princ)<br /> )<br />

zhuzhi1631

功能很强大 ，收藏

stareeww

功能很强大 ，收藏