过2点与多段线的交点

自贡黄明儒

经过2点如果有构造线，求其与多段线的交点，因为两个实体都存在，用vla-IntersectWith就可以求得交点。
我碰到多次了，只知道2点，但经过2点的构造线XLINE不存在，我只好产生一条构造线XLINE来求交点，完成任务后删除这条构造线XLINE。于是产生了一个想法，是不是仅通过计算就能得到交点呢。
这种想法很久了，今天才完成，以支持明经恢复，欢迎大家测试.

1. ;;1 [功能]两点是否与多段线有交点，延长两点来判断
   
2. 
   
3. ;;;定义三点的行列式,即三点之倍面积
   
4. ;;注p1 p2 p3 逆时针为正。
   
5. (defun det (p1 p2 p3 / x2 y2)
   
6.   (setq        x2 (car p2)
   
7.         y2 (cadr p2)
   
8.   )
   
9.   (- (* (- x2 (car p3)) (- y2 (cadr p1)))
   
10.      (* (- x2 (car p1)) (- y2 (cadr p3)))
    
11.   )
    
12. )
    
13. ;;[功能] 4点求交点(仿vla-IntersectWith）
    
14. ;;acextendnone 0 不延伸
    
15. ;;acextendthisentity 1 延伸基准点
    
16. ;;acextendotherentity 2
    
17. ;;acextendboth 3
    
18. (defun My:4pInters (p1 p2 p3 p4 Flag)
    
19.   (cond        ((= Flag 0) (inters p1 p2 p3 p4 T))
    
20.         ((= Flag 1)
    
21.          (if (= (minusp (det p1 p2 p3)) (minusp (det p1 p2 p4)))
    
22.            (inters p1 p2 p3 p4 T)
    
23.            (inters p1 p2 p3 p4 nil)
    
24.          )
    
25.         )
    
26.         ((= Flag 2)
    
27.          (if (= (minusp (det p3 p4 p1)) (minusp (det p3 p4 p2)))
    
28.            (inters p1 p2 p3 p4 T)
    
29.            (inters p1 p2 p3 p4 nil)
    
30.          )
    
31.         )
    
32.         ((= Flag 3) (inters p1 p2 p3 p4 nil))
    
33.   )
    
34. )
    
35. 
    
36. ;;2 [功能]两点与弧是否有交点
    
37. 
    
38. ;;2点与圆的交点 By Highflybird
    
39. (defun IntersLineCircle        (p1 p2 cp r / p0 d n s)
    
40.   (setq        n  (mapcar '- p2 p1) ;_ 新投影面的法向量
    
41.         P1 (trans p1 0 n) ;_ P1坐标转换到新投影面n
    
42.         cp (trans cp 0 n) ;_ CP坐标转换到新投影面n
    
43.         p0 (list (car p1) (cadr p1) (caddr cp)) ;_ P0在新投影面坐标
    
44.   )
    
45.   (cond
    
46.     ((equal r (setq d (distance cp p0)) 1e-7) ;_ 直线和园相切,考虑计算误差
    
47.      (list (trans p0 n 0))
    
48.     )
    
49.     ((< d r) ;_ 相交
    
50.      (setq s (sqrt (- (* r r) (* d d))))
    
51.      (list
    
52.        (trans (list (car p1) (cadr p1) (- (caddr cp) s)) n 0) ;_ J1坐标
    
53.        (trans (list (car p1) (cadr p1) (+ (caddr cp) s)) n 0) ;_ J2坐标
    
54.      )
    
55.     )
    
56.   )
    
57. )
    
58. ;;2点与弧的交点'((-406.036 286.692 0.0) (416.036 286.692 0.0))
    
59. ;;(setq L '((5033.03 7264.11 0.0) (5652.18 6834.35 0.0)))
    
60. (defun My:2pArcInters (e p1 p2 cp r / L x)
    
61.   (setq L (IntersLineCircle p1 p2 cp r))
    
62.   (if L
    
63.     (setq L (mapcar '(lambda (x)
    
64.                        (if (equal (vlax-curve-getclosestpointto e x) x 1e-2)
    
65.                          x
    
66.                        )
    
67.                      )
    
68.                     L
    
69.             )
    
70.     )
    
71.   )
    
72.   (vl-remove 'nil L)
    
73. )
    
74. 
    
75. ;;3 [功能] 2点与多段线交点
    
76. ;;'((5033.03 7264.11 0.0) (5608.24 6864.85)),三维点表示2点延长线与弧的交点，二维点表示与直线延长交点
    
77. (defun 2PLwpolylineInters (e p3 p4 / A CP EN I L P1 P2 PP R SR Flag)  
    
78.   setq en (entget e))  (setq Flag (= (cdr (assoc 70 en))1));T,表示闭合
    
79.   (setq        en (vl-remove-if-not
    
80.              '(lambda (x)
    
81.                 (or (= (car x) 42) (= (car x) 10))
    
82.               )
    
83.              en
    
84.            )
    
85.   )
    
86.   (if Flag
    
87.     (setq en (append en (List (car en))))
    
88.   )
    
89.   (setq i -1)
    
90.   (while (setq i  (1+ i)
    
91.                p1 (cdar en)
    
92.                en (cdr en)
    
93.                sr (cdar en)
    
94.                en (cdr en)
    
95.                p2 (cdar en)
    
96.          )
    
97.     (if        (equal sr 0)
    
98.       (if (setq a (My:4pInters p1 p2 p3 p4 2))
    
99.         (setq L (append L (list a)))
    
100.       )
     
101.       (progn
     
102.         (setq pp (vlax-curve-getPointAtParam e (+ i 0.5)))
     
103.         (if (minusp (car (trans (mapcar '- pp p2) 0 (mapcar '- p1 p2))))
     
104.           (setq cp (mapcar '- pp (vlax-curve-getsecondderiv e (+ i 0.5))))
     
105.           (setq cp (mapcar '+ pp (vlax-curve-getsecondderiv e (+ i 0.5))))
     
106.         )
     
107.         (setq r (distance p1 cp))
     
108.         (setq L (append L (My:2pArcInters e p3 p4 cp r)))
     
109.       )
     
110.     )
     
111.   )
     
112.   L
     
113. )
     
114. 
     
115. ;;测试
     
116. (defun C:a1 (/ E P3 P4)
     
117.   (setq e (car (entsel)))                                    ;选择一个多段线
     
118.   (setq p3(getpoint) p4(getpoint));选择两点
     
119.   (2PLwpolylineInters e p3 p4)
     
120. )
     
121. ;;(command "line" x)
     

;;1 [功能]两点是否与多段线有交点，延长两点来判断<br /> <br /> ;;;定义三点的行列式,即三点之倍面积<br /> ;;注p1 p2 p3 逆时针为正。<br /> (defun det (p1 p2 p3 / x2 y2)<br />   (setq        x2 (car p2)<br />         y2 (cadr p2)<br />   )<br />   (- (* (- x2 (car p3)) (- y2 (cadr p1)))<br />      (* (- x2 (car p1)) (- y2 (cadr p3)))<br />   )<br /> )<br /> ;;[功能] 4点求交点(仿vla-IntersectWith）<br /> ;;acextendnone 0 不延伸<br /> ;;acextendthisentity 1 延伸基准点<br /> ;;acextendotherentity 2<br /> ;;acextendboth 3<br /> (defun My:4pInters (p1 p2 p3 p4 Flag)<br />   (cond        ((= Flag 0) (inters p1 p2 p3 p4 T))<br />         ((= Flag 1)<br />          (if (= (minusp (det p1 p2 p3)) (minusp (det p1 p2 p4)))<br />            (inters p1 p2 p3 p4 T)<br />            (inters p1 p2 p3 p4 nil)<br />          )<br />         )<br />         ((= Flag 2)<br />          (if (= (minusp (det p3 p4 p1)) (minusp (det p3 p4 p2)))<br />            (inters p1 p2 p3 p4 T)<br />            (inters p1 p2 p3 p4 nil)<br />          )<br />         )<br />         ((= Flag 3) (inters p1 p2 p3 p4 nil))<br />   )<br /> )<br /> <br /> ;;2 [功能]两点与弧是否有交点<br /> <br /> ;;2点与圆的交点 By Highflybird<br /> (defun IntersLineCircle        (p1 p2 cp r / p0 d n s)<br />   (setq        n  (mapcar '- p2 p1) ;_ 新投影面的法向量<br />         P1 (trans p1 0 n) ;_ P1坐标转换到新投影面n<br />         cp (trans cp 0 n) ;_ CP坐标转换到新投影面n<br />         p0 (list (car p1) (cadr p1) (caddr cp)) ;_ P0在新投影面坐标<br />   )<br />   (cond<br />     ((equal r (setq d (distance cp p0)) 1e-7) ;_ 直线和园相切,考虑计算误差<br />      (list (trans p0 n 0))<br />     )<br />     ((< d r) ;_ 相交<br />      (setq s (sqrt (- (* r r) (* d d))))<br />      (list<br />        (trans (list (car p1) (cadr p1) (- (caddr cp) s)) n 0) ;_ J1坐标<br />        (trans (list (car p1) (cadr p1) (+ (caddr cp) s)) n 0) ;_ J2坐标<br />      )<br />     )<br />   )<br /> )<br /> ;;2点与弧的交点'((-406.036 286.692 0.0) (416.036 286.692 0.0))<br /> ;;(setq L '((5033.03 7264.11 0.0) (5652.18 6834.35 0.0)))<br /> (defun My:2pArcInters (e p1 p2 cp r / L x)<br />   (setq L (IntersLineCircle p1 p2 cp r))<br />   (if L<br />     (setq L (mapcar '(lambda (x)<br />                        (if (equal (vlax-curve-getclosestpointto e x) x 1e-2)<br />                          x<br />                        )<br />                      )<br />                     L<br />             )<br />     )<br />   )<br />   (vl-remove 'nil L)<br /> )<br /> <br /> ;;3 [功能] 2点与多段线交点<br /> ;;'((5033.03 7264.11 0.0) (5608.24 6864.85)),三维点表示2点延长线与弧的交点，二维点表示与直线延长交点<br /> (defun 2PLwpolylineInters (e p3 p4 / A CP EN I L P1 P2 PP R SR Flag)  <br />   setq en (entget e))  (setq Flag (= (cdr (assoc 70 en))1));T,表示闭合<br />   (setq        en (vl-remove-if-not<br />              '(lambda (x)<br />                 (or (= (car x) 42) (= (car x) 10))<br />               )<br />              en<br />            )<br />   )<br />   (if Flag<br />     (setq en (append en (List (car en))))<br />   )<br />   (setq i -1)<br />   (while (setq i  (1+ i)<br />                p1 (cdar en)<br />                en (cdr en)<br />                sr (cdar en)<br />                en (cdr en)<br />                p2 (cdar en)<br />          )<br />     (if        (equal sr 0)<br />       (if (setq a (My:4pInters p1 p2 p3 p4 2))<br />         (setq L (append L (list a)))<br />       )<br />       (progn<br />         (setq pp (vlax-curve-getPointAtParam e (+ i 0.5)))<br />         (if (minusp (car (trans (mapcar '- pp p2) 0 (mapcar '- p1 p2))))<br />           (setq cp (mapcar '- pp (vlax-curve-getsecondderiv e (+ i 0.5))))<br />           (setq cp (mapcar '+ pp (vlax-curve-getsecondderiv e (+ i 0.5))))<br />         )<br />         (setq r (distance p1 cp))<br />         (setq L (append L (My:2pArcInters e p3 p4 cp r)))<br />       )<br />     )<br />   )<br />   L<br /> )<br /> <br /> ;;测试<br /> (defun C:a1 (/ E P3 P4)<br />   (setq e (car (entsel)))                                    ;选择一个多段线<br />   (setq p3(getpoint) p4(getpoint));选择两点<br />   (2PLwpolylineInters e p3 p4)<br /> )<br /> ;;(command "line" x)<br />

xyp1964

ddbegg 发表于 2022-4-5 10:43
大师有没有办法把两个方向的交点分开？也就是说能不能求出只延伸一个方向的交点（另一个方向不延伸）

20060510412

最近刚好也有相同的需求，多谢黄大师共享代码。
主要是有点疑问：
在实际应用中，究竟是这种纯计算的方法效率更高，还是使用生成辅助线再删除的效率更高呢？

wzg356

数学几何计算对计算机是小儿科，主要是过程中的表处理/循环带来的效率折减

从过程及效果上讲还是用你最初的土办法“两对象交点”更好

Bao_lai

黄大师好久不见，感谢分享。

xj6019

感谢大佬分享新作

shanquanr

非常感谢分享

czb203

黄大师好久不见，感谢分享。

ddbegg

大师有没有办法把两个方向的交点分开？也就是说能不能求出只延伸一个方向的交点（另一个方向不延伸）

ddbegg

xyp1964 发表于 2022-4-5 13:42

uualice2020

非常感谢分享