[函数] 判断点在封闭曲线内，跟随黄总的步伐

admin1

1. 
   
2. 
   
3. ;测试
   
4. (defun c:tt (/ en pt pts)
   
5.         (and
   
6.                 (setq pt (getpoint))
   
7.                 (setq en (car (entsel "\n选闭合曲线")))
   
8.                 (setq pts (mapcar '(lambda (x) (trans (cdr x) 0 1)) (vl-remove-if-not '(lambda (x) (= 10 (car x))) (entget en))))
   
9.                 (princ "\n第一种（不支持弧线）：")
   
10.                 (princ (JudPtinPts pt pts 1e-6))
    
11.                 (princ "\n第二种（支持弧线）：")
    
12.                 (princ (JudPtinCurr pt en 1e-6))
    
13.         )
    
14.         (princ)
    
15. )
    
16. 
    
17. 
    
18. 
    
19. 
    
20. 
    
21. 
    
22. 
    
23. 
    
24. ;第一种
    
25. ;判断点是否在非自交多边形内，使用射线交叉法，从要测试的点向任意方向引一条射线，统计射线与多边形边界的交点数量。如果交点数目是奇数，则点位于多边形内部；如果是偶数，则点位于多边形外部。如果交点为多边形顶点可能无法正确判断，此时旋转射线重新判断。
    
26. ;参数：pt判断的点、pts多边形点表、fz误差
    
27. ;返回：1在内部、0在线上、-1在外部
    
28. (defun JudPtinPts (pt pts fz / box d i inter k line lines lines-tmp memberfz ray)
    
29.   (defun MemberFz (pt lst fz);带误差的member
    
30.     (vl-some (function (lambda(x) (equal pt x fz))) lst)
    
31.   )
    
32.   
    
33.   (setq lines (mapcar (function list) pts (append (cdr pts) (list (car pts)))))
    
34.   (if (vl-some ;判断点在线上
    
35.         (function (lambda (x / ang1 ang2 p1 p2)
    
36.                     (setq p1 (car x))
    
37.                     (setq p2 (cadr x))
    
38.                     (or
    
39.                       (or
    
40.                         (equal pt p1 fz)
    
41.                         (equal pt p2 fz)
    
42.                       )
    
43.                       (and
    
44.                         (setq ang1 (angle p1 pt))
    
45.                         (setq ang2 (angle pt p2))
    
46.                         (or (equal ang1 ang2 1e-6)
    
47.                           (equal (abs (- ang1 ang2)) (* pi 2) 1e-6)
    
48.                         )
    
49.                       )
    
50.                     )
    
51.                   )
    
52.         )
    
53.         lines
    
54.       )
    
55.     0;在线上
    
56.     (progn;判断交点数量
    
57.       (setq box (mapcar (function (lambda (a b) (apply (function mapcar) (cons a b)))) '(min max) (list pts pts)))
    
58.       (setq d (+ (apply 'distance box) (distance pt (car pts))))
    
59.       (setq ray (list pt (polar pt 0 d)));虚拟一条足够长的射线
    
60.       (setq lines-tmp lines)
    
61.       (setq i 0 k 0)
    
62.       (while (and lines-tmp (< k 360))
    
63.         (setq line (car lines-tmp))
    
64.         (setq lines-tmp (cdr lines-tmp))
    
65.         (if (setq inter (apply 'inters (append ray line)));有交点
    
66.           (if (not (MemberFz inter pts fz));且交点不为顶点
    
67.             (setq i (1+ i));交点数量
    
68.             (setq i 0;归零
    
69.               k (1+ k)
    
70.               ray (list pt (polar pt (* (/ pi 180) k) d));射线旋转1°
    
71.               lines-tmp lines;重新判断
    
72.             )
    
73.           )
    
74.         )
    
75.       )
    
76.       (cond
    
77.         ((zerop (rem i 2)) -1);偶数个交点，在线外
    
78.         (t 1);奇数，在线内
    
79.       )
    
80.     )
    
81.   )
    
82. )
    
83. 
    
84. 
    
85. 
    
86. 
    
87. 
    
88. 
    
89. 
    
90. 
    
91. 
    
92. 
    
93. 
    
94. 
    
95. 
    
96. 
    
97. ;第二种
    
98. ;判断点是否在封闭曲线内，生成图元射线找与封闭曲线交点(判断原理同上)，支持多段线、圆、椭圆、样条曲线等封闭曲线
    
99. ;参数：pt判断的点、e曲线图元名、fz误差
    
100. ;返回：1在内部、0在线上、-1在外部
     
101. (defun JudPtinCurr (pt e fz / *error* ang cp ed getinter i islock isvertex its k la layobj list->3pair loop mkray obj-cur obj-ray ray vlay)
     
102.   ;错误处理
     
103.   (defun *error* (msg)
     
104.     (if (not (vlax-erased-p obj-ray))
     
105.       (vla-Delete obj-ray)
     
106.     )
     
107.     (princ msg)
     
108.   )
     
109.   ;表转3D点表
     
110.   (defun list->3pair (old / new)
     
111.     (while (setq new (cons (list (car old) (cadr old) (caddr old)) new) old (cdddr old)))
     
112.     (reverse new)
     
113.   )
     
114.   ;找2个对象的交点 不延长 返回：交点列表
     
115.   (defun getinter (obj1 obj2 / inter iplist re)
     
116.     (if (not (vl-catch-all-error-p
     
117.                (setq iplist (vl-catch-all-apply 'vlax-safearray->list
     
118.                               (list (vlax-variant-value (vla-intersectwith obj1 obj2 acextendnone)))
     
119.                             ))))
     
120.       (list->3pair iplist)
     
121.     )
     
122.   )
     
123.   ;判断交点是否为曲线顶点或在射线角度上的切点
     
124.   (defun IsVertex (obj pt ang / ang-de de n name)
     
125.     (if (and
     
126.           (setq name (vla-get-ObjectName obj))
     
127.           (setq n (vlax-curve-getParamAtPoint obj pt))
     
128.         )
     
129.       (if (and
     
130.             (or
     
131.               (= name "AcDbPolyline")
     
132.               (= name "AcDb2dPolyline")
     
133.               (= name "AcDb3dPolyline")
     
134.               (= name "AcDbSpline")
     
135.             )
     
136.             (equal (fix n) n 1e-8)
     
137.           )
     
138.         t ;为顶点
     
139.         (and ang
     
140.           (setq de (vlax-curve-getFirstDeriv obj n))
     
141.           (setq ang-de (angle '(0 0 0) de))
     
142.           (or ;为切点
     
143.             (equal ang-de ang 1e-8)
     
144.             (equal ang-de (+ pi ang) 1e-8)
     
145.             (equal ang-de (+ (* pi 2) ang) 1e-8)
     
146.           )
     
147.         )
     
148.       )
     
149.     )
     
150.   )
     
151.   ;生成射线 返回图元名
     
152.   (defun MKRay (p1 p2)
     
153.     (entmakeX
     
154.       (list
     
155.         '(0 . "RAY")
     
156.         '(100 . "AcDbEntity")
     
157.         '(100 . "AcDbRay")
     
158.         (cons 10 p1)
     
159.         (cons 11 (mapcar '- p2 p1))
     
160.       )
     
161.     )
     
162.   )
     
163.   
     
164.   (setq obj-cur (vlax-ename->vla-object e))
     
165.   (if (and
     
166.         (setq cp (vlax-curve-getClosestPointTo obj-cur pt))
     
167.         (equal cp pt fz)
     
168.       )
     
169.     0;在线上
     
170.     (progn
     
171.       (if (and ;解锁当前图层
     
172.             (setq la (getvar "CLAYER"))
     
173.             (setq layobj (vla-get-Layers (vla-get-activedocument (vlax-get-acad-object))))
     
174.             (setq vlay (vla-item layobj la))
     
175.           )
     
176.         (if (= (vla-get-lock vlay) :vlax-true)
     
177.           (progn
     
178.             (vla-put-lock vlay :vlax-false)
     
179.             (setq islock t)
     
180.           )
     
181.         )
     
182.       )
     
183.       (setq ang 0)
     
184.       (setq pt (trans pt 1 0))
     
185.       (setq ray (MKRay pt (polar pt ang 10)))
     
186.       (setq ed (entget ray))
     
187.       (setq obj-ray (vlax-ename->vla-object ray))
     
188.       (setq k 0 loop t)
     
189.       (while (and loop (< k 360))
     
190.         (if (setq its (getinter obj-cur obj-ray));有交点
     
191.           (progn
     
192.             (if (vl-every (function (lambda(p) (not (IsVertex obj-cur p ang)))) its)
     
193.               (setq i (length its);交点数量
     
194.                 loop nil
     
195.               )
     
196.               (progn;交点为顶点或切点
     
197.                 (setq k (1+ k) ang (* (/ pi 180) k))
     
198.                 (entmod (subst (cons 11 (mapcar '- (polar pt ang 10) pt)) (assoc 11 ed) ed));射线旋转1°
     
199.               )
     
200.             )
     
201.           )
     
202.           (setq loop nil)
     
203.         )
     
204.       )
     
205.       (if (not (vlax-erased-p obj-ray))
     
206.         (vla-Delete obj-ray)
     
207.       )
     
208.       (if islock ;恢复锁定
     
209.         (vla-put-lock vlay :vlax-true)
     
210.       )
     
211.       (cond
     
212.         ((or (not i)(zerop (rem i 2))) -1);偶数个交点，在线外
     
213.         (t 1);奇数，在线内
     
214.       )
     
215.     )
     
216.   )
     
217. )
     
218. 
     

复制代码