判断：一个点在封闭曲线内

自贡黄明儒 · 发表于 2024-3-28 08:30:15

本帖最后由自贡黄明儒于 2024-3-28 08:34 编辑

判断：一个点在封闭曲线内
在acad中，使用bloy,效果不错，基本上是万能的。不仅仅是封闭曲线，任何选择集都可以。
但在bcad中就不行了。我按照老迈的办法，使用(command "_.boundary" "a" "i" "y" "b" "n" ss "" "" "non" p "")
效果不好，改为caoyin版主的办法，效果也不好

(defun HH_PtInCurve
(PT CURVE / GetInters OBJ MINPT MAXPT E PS LST X Y)
(defun GetInters (OBJ1 OBJ2 / PS LST)
(setq PS (vla-intersectwith OBJ1 OBJ2 0)
PS (vl-catch-all-apply
'vlax-safearray->list
(list (vlax-variant-value PS))
)
)
(if (and PS (not (vl-catch-all-error-p PS)))
(while (setq LST (cons (list (car PS) (cadr PS)) LST)
PS (cdddr PS)
)
)
)
LST
)
(if (equal (vlax-curve-getClosestPointTo CURVE PT) PT 1E-6)
0
(progn
(setq OBJ (vlax-ename->vla-object CURVE))
(vla-getboundingbox OBJ 'MINPT 'MAXPT)
(mapcar '(lambda (X) (set X (vlax-safearray->list (eval X))))
'(MINPT MAXPT)
)
(entmake
(list '(0 . "LINE")
(list 10 (car MINPT) (cadr PT))
(list 11 (car MAXPT) (cadr PT))
'(60 . 1)
)
)
(setq E (entlast)
LST1 (GetInters OBJ (vlax-ename->vla-object E))
)
(entdel E)
(if LST1
(setq LST1 (vl-remove-if
'(lambda (X / PP A)
(setq PP (vlax-curve-getParamAtPoint CURVE X)
A (angle '(0 0)
(vlax-curve-getFirstDeriv CURVE PP)
)
)
(or (equal A 0 1E-6)
(equal A PI 1E-6)
(equal A (* PI 2) 1E-6)
(equal (fix PP) PP 1E-6)
)
)
LST1
)
)
)
(entmake
(list '(0 . "LINE")
(list 10 (car PT) (cadr MAXPT))
(list 11 (car PT) (cadr MINPT))
'(60 . 0)
)
)
(setq E (entlast)
LST2 (GetInters OBJ (vlax-ename->vla-object E))
)
(entdel E)
(if LST2
(setq LST2 (vl-remove-if
'(lambda (X / PP A)
(setq X (vlax-curve-getClosestPointTo CURVE X)
PP (vlax-curve-getParamAtPoint CURVE X)
A (angle (vlax-curve-getFirstDeriv CURVE PP)
'(0 0)
)
)
(or (equal A (/ PI 2) 1E-6)
(equal A (* PI 1.5) 1E-6)
(equal (fix PP) PP 1E-6)
)
)
LST2
)
)
)
(and
LST1
LST2
(progn (setq X (vl-sort-i (mapcar 'car (cons PT LST1)) '<)
Y (length (member 0 X))
)
(and (zerop (rem Y 2)) (= (rem (- (length X) Y) 2) 1))
)
(progn (setq X (vl-sort-i (mapcar 'cadr (cons PT LST2)) '<)
Y (length (member 0 X))
)
(and (zerop (rem Y 2)) (= (rem (- (length X) Y) 2) 1))
)
)
)
)
)

(defun HH_PtInCurve 
   (PT CURVE / GetInters OBJ MINPT MAXPT E PS LST X Y) 
    (defun GetInters (OBJ1 OBJ2 / PS LST) 
      (setq PS (vla-intersectwith OBJ1 OBJ2 0) 
      PS (vl-catch-all-apply 
     'vlax-safearray->list 
     (list (vlax-variant-value PS)) 
         ) 
      ) 
      (if (and PS (not (vl-catch-all-error-p PS))) 
  (while (setq LST (cons (list (car PS) (cadr PS)) LST) 
         PS   (cdddr PS) 
         ) 
  ) 
      ) 
      LST 
    ) 
    (if  (equal (vlax-curve-getClosestPointTo CURVE PT) PT 1E-6) 
      0 
      (progn 
  (setq OBJ (vlax-ename->vla-object CURVE)) 
  (vla-getboundingbox OBJ 'MINPT 'MAXPT) 
  (mapcar  '(lambda (X) (set X (vlax-safearray->list (eval X)))) 
    '(MINPT MAXPT) 
  ) 
  (entmake 
    (list  '(0 . "LINE") 
    (list 10 (car MINPT) (cadr PT)) 
    (list 11 (car MAXPT) (cadr PT)) 
    '(60 . 1) 
    ) 
  ) 
  (setq E     (entlast) 
        LST1 (GetInters OBJ (vlax-ename->vla-object E)) 
  ) 
  (entdel E) 
  (if LST1 
    (setq  LST1 (vl-remove-if 
           '(lambda  (X / PP A) 
        (setq  PP (vlax-curve-getParamAtPoint CURVE X) 
        A  (angle '(0 0) 
            (vlax-curve-getFirstDeriv CURVE PP) 
           ) 
        ) 
        (or (equal A 0 1E-6) 
            (equal A PI 1E-6) 
            (equal A (* PI 2) 1E-6) 
            (equal (fix PP) PP 1E-6) 
        ) 
      ) 
           LST1 
         ) 
    ) 
  ) 
  (entmake 
    (list  '(0 . "LINE") 
    (list 10 (car PT) (cadr MAXPT)) 
    (list 11 (car PT) (cadr MINPT)) 
    '(60 . 0) 
    ) 
  ) 
  (setq E     (entlast) 
        LST2 (GetInters OBJ (vlax-ename->vla-object E)) 
  ) 
  (entdel E) 
  (if LST2 
    (setq  LST2 (vl-remove-if 
           '(lambda  (X / PP A) 
        (setq  X  (vlax-curve-getClosestPointTo CURVE X) 
        PP (vlax-curve-getParamAtPoint CURVE X) 
        A  (angle (vlax-curve-getFirstDeriv CURVE PP) 
            '(0 0) 
           ) 
        ) 
        (or (equal A (/ PI 2) 1E-6) 
            (equal A (* PI 1.5) 1E-6) 
            (equal (fix PP) PP 1E-6) 
        ) 
      ) 
           LST2 
         ) 
    ) 
  ) 
  (and 
    LST1 
    LST2 
    (progn (setq X (vl-sort-i (mapcar 'car (cons PT LST1)) '<) 
           Y (length (member 0 X)) 
     ) 
     (and (zerop (rem Y 2)) (= (rem (- (length X) Y) 2) 1)) 
    ) 
    (progn (setq X (vl-sort-i (mapcar 'cadr (cons PT LST2)) '<) 
           Y (length (member 0 X)) 
     ) 
     (and (zerop (rem Y 2)) (= (rem (- (length X) Y) 2) 1)) 
    ) 
  ) 
      ) 
    ) 
  )

找度娘，搜到结果如下
;;;1，如果该直线与封闭图形无交点或只有一个交点（切点），则此点在封闭图形外面；
;;;2，如果该直线与封闭图形有2个交点，且此点在这两个交点之间，则此点在封闭图形
;;;里面；在这两个交点之外，则此点在封闭图形外面；
;;;3，如果该直线与封闭图形有多个交点（不含切点），此点在这些交点之间时，此点
;;;任一侧的交点数为奇数则此点在封闭图形里面；此点任一侧的交点数为偶数则此点
;;;在封闭图形外面；此点不在这些交点之间时此点在封闭图形外面

动手写一个，效果好像还可以，如下

;;(MakeXray (setq p(getpoint)) '(0 1))
;;'(-1 0) 向左 '(0 1)向上 '(1 0)向右 '(0 -1)向下
(defun MakeXray (p vector)
(entmakeX
(list
'(0 . "RAY")
'(100 . "AcDbEntity")
'(100 . "AcDbRay")
(cons 10 p)
(cons 11 vector)
)
)
)
;;偶数判断
;;(IsEven 2)=>T
(defun IsEven (x)
(/= 1 (logand x 1))
)
;;向左产生一条射线ray
;; (setq ray (MakeXray p '(-1 0)))
(defun HH_PtInCurve (p curve ray / A B FLAG IN L PTS)
(setq Flag T)
(setq in nil)
(setq L '(((-1 0) (1 0)) ((0 1) (0 -1))))
;;射线移位
(entmod (append (entget ray) (list (cons 10 p))))
;;旋转射线
(while (and (setq a (car L)) Flag)
(setq L (cdr L))
(setq b (car a))
(setq a (cadr a))
(entmod (append (entget ray) (list (cons 11 b))))
(setq pts (HH:TwoEntsInters ray curve 0))
(cond ((not pts) (setq Flag nil))
((IsEven (length pts)) (setq Flag nil)) ;不严谨
(T
(entmod (append (entget ray) (list (cons 11 a))))
(setq pts (HH:TwoEntsInters ray curve 0))
(cond
((not pts) (setq Flag nil))
((IsEven (length pts)) (setq Flag nil)) ;不严谨
(T (setq in T))
)
)
)
)
in
)
;;判断准则
;;1 如果所有端点首尾相连，则直接联接成多段线
;;2 如果只有一个端点是孤立的，则奇怪，可掉这条线
;;3 如果有两个端点孤立：是同一条线，奇怪，可去掉；如果是不同的线，可直接联接成多段线
;;4 如果大于两个端点孤立的，则相互延伸剪切，然后组成多段线。从一条线端点到另一条线最近的距离开始
;;0 [功能] 两对象交点
;;[功能] 两对象交点列表
;;acextendnone 0 不延伸
;;acextendthisentity 1 延伸基准对象
;;acextendotherentity 2
;;acextendboth 3
;;示例(HH:TwoEntsInters (car(entsel)) (car(entsel)) acextendboth)
(defun HH:TwoEntsInters (e1 e2 Flag / PTL PTS)
(if (equal 'ENAME (type e1))
(setq e1 (vlax-ename->vla-object e1))
)
(if (equal 'ENAME (type e2))
(setq e2 (vlax-ename->vla-object e2))
)
(setq pts (vlax-invoke e1 'Intersectwith e2 Flag))
(while pts
(setq ptl (cons (list (car pts) (cadr pts)) ptl))
(setq pts (cdddr pts))
)
ptl
)

;;(MakeXray (setq p(getpoint)) '(0 1)) 
;;'(-1 0) 向左  '(0 1)向上 '(1 0)向右 '(0 -1)向下 
(defun MakeXray  (p vector) 
  (entmakeX 
    (list 
      '(0 . "RAY") 
      '(100 . "AcDbEntity") 
      '(100 . "AcDbRay") 
      (cons 10 p) 
      (cons 11 vector) 
    ) 
  ) 
) 
 
;;偶数判断 
;;(IsEven 2)=>T 
(defun IsEven (x) 
  (/= 1 (logand x 1)) 
) 
 
;;向左产生一条射线ray 
;; (setq ray (MakeXray p '(-1 0))) 
(defun HH_PtInCurve (p curve ray / A B FLAG IN L PTS) 
  (setq Flag T) 
  (setq in nil) 
  (setq L '(((-1 0) (1 0)) ((0 1) (0 -1)))) 
  ;;射线移位 
  (entmod (append (entget ray) (list (cons 10 p)))) 
  ;;旋转射线 
  (while (and (setq a (car L)) Flag) 
    (setq L (cdr L)) 
    (setq b (car a)) 
    (setq a (cadr a)) 
    (entmod (append (entget ray) (list (cons 11 b)))) 
    (setq pts (HH:TwoEntsInters ray curve 0)) 
    (cond ((not pts) (setq Flag nil)) 
    ((IsEven (length pts)) (setq Flag nil)) ;不严谨 
    (T 
     (entmod (append (entget ray) (list (cons 11 a)))) 
     (setq pts (HH:TwoEntsInters ray curve 0)) 
     (cond 
       ((not pts) (setq Flag nil)) 
       ((IsEven (length pts)) (setq Flag nil)) ;不严谨 
       (T (setq in T)) 
     ) 
    ) 
    ) 
  ) 
  in 
) 
 
;;判断准则 
;;1 如果所有端点首尾相连，则直接联接成多段线 
;;2 如果只有一个端点是孤立的，则奇怪，可掉这条线 
;;3 如果有两个端点孤立：是同一条线，奇怪，可去掉；如果是不同的线，可直接联接成多段线 
;;4 如果大于两个端点孤立的，则相互延伸剪切，然后组成多段线。从一条线端点到另一条线最近的距离开始 
;;0 [功能] 两对象交点 
;;[功能] 两对象交点列表 
;;acextendnone 0 不延伸 
;;acextendthisentity 1 延伸基准对象 
;;acextendotherentity 2 
;;acextendboth 3 
;;示例(HH:TwoEntsInters (car(entsel)) (car(entsel)) acextendboth) 
(defun HH:TwoEntsInters        (e1 e2 Flag / PTL PTS) 
  (if (equal 'ENAME (type e1)) 
    (setq e1 (vlax-ename->vla-object e1)) 
  ) 
  (if (equal 'ENAME (type e2)) 
    (setq e2 (vlax-ename->vla-object e2)) 
  ) 
  (setq pts (vlax-invoke e1 'Intersectwith e2 Flag)) 
  (while pts 
    (setq ptl (cons (list (car pts) (cadr pts)) ptl)) 
    (setq pts (cdddr pts)) 
  ) 
  ptl 
)

;;;;;测试
(defun C:t1 (/ CURVE P RAY)
  (setq ray (MakeXray '(0 0) '(-1 0)))
  (setq curve (car (entsel "\n封闭曲线")))
  (setq p (getpoint "\n点"))
  (if (HH_PtInCurve p curve ray)
(alert "点在曲线内")
(alert "外")
  )
  (entdel ray)
  (princ)
)

Andyhon · 发表于 2024-3-29 16:36:31

(defun PtInPoly (/ clst apt delta ints oLine oPline pl pline someAngle)
  (vl-load-com)
  (cond
((setq pline (car (entsel "\nPolyline: ")))
   ;; NO error checking .. assume a lwpoly is selected!
   (setq oPline (vlax-ename->vla-object pline)
         ;; pick point to investigate
         aPt    (getpoint "\nPick point: ")
         ;; initialize starting angle for "ray"
         someAngle 0.0
         ;; set delta angle for rotation of "ray"
         delta    (/ (* 2 pi) 8)
   )
   (cond
   ;; start by making a "ray" shooting out from aPt
   ;; (should use vla-add but what the heck)
   ;; (should also use a real RAY and manipulate
   ;;  unit vector .. but what the heck)
   ((entmake (list '(0 . "LINE") (cons 10 aPt)
                     (cons 11 (polar aPt 0.0 100.0))
               )
      )
      (setq oline (vlax-ename->vla-object (entlast)))
      (repeat 8
      (cond
         ;; get intersection points with pline and "ray"
         ((setq ints (vla-intersectwith oPline oLine acExtendNone))
         ;; should be using vlax-...-u-bounds and all that to check
         ;; safearray (but what the heck, this is quicker to write)
         (if (not (vl-catch-all-error-p (setq ints (vl-catch-all-apply
                                 'vlax-safearray->list
                                 (list (vlax-variant-value ints)))
                     )
                  )
               )
            ;; just put nil for uneven number of hits and T for even
            (setq clst (cons (not (zerop (rem (length ints) 2.0))) clst))
         )
         )
      )
      ;; pause to see the "ray" move around
      (while (not (grread nil 10)))
      ;; move endpoint of "ray"
      (vla-put-endpoint oLine (vlax-3D-point
            (polar aPt (setq someAngle (+ delta someAngle)) 100.0)
         )
      )
      )
      (vla-delete oLine)
      (vlax-release-object oLine)
      (vlax-release-object oPline)
   )
   )
)
  )
  ;; .. and a lazy decoding of result:
  (cond ((not (member 'nil clst))(princ "Inside"))
      ((not (member 'T clst))(princ "Outside"))
      ((princ "Probably on an edge or vertex")))
  (terpri)
  clst
)

info from:
https://www.theswamp.org/index.php?topic=1890.0

自贡黄明儒 · 发表于 2024-3-28 10:38:58

4条ray,交点出现一奇一偶，或者一偶一奇，概率相当小了

(defun HH_PtInCurve (p curve ray / A B FLAG IN L PTS)
(setq Flag T)
(setq in nil)
(setq L '(((-1 0) (1 0)) ((0 1) (0 -1))))
;;射线移位
(entmod (append (entget ray) (list (cons 10 p))))
;;旋转射线
(while (and (setq a (car L)) Flag)
(setq L (cdr L))
(setq b (car a))
(setq a (cadr a))
(entmod (append (entget ray) (list (cons 11 b))))
(setq pts (HH:TwoEntsInters ray curve 0))
(cond ((not pts) (setq Flag nil))
((IsEven (length pts))
(entmod (append (entget ray) (list (cons 11 a))))
(setq pts (HH:TwoEntsInters ray curve 0))
(cond
((not pts) (setq Flag nil))
((IsEven (length pts)) (setq Flag nil)) ;2次偶数，判断点在曲线外，这比较合理
;;一偶一奇，不好判断，让程序继续运行，从另外两个方向判断
;;如果还是出现一偶一奇，in仍为nil,表示点在封闭曲线外
)
)
(T
(entmod (append (entget ray) (list (cons 11 a))))
(setq pts (HH:TwoEntsInters ray curve 0))
(cond
((not pts) (setq Flag nil))
((IsEven (length pts)))
;;一奇一偶，不好判断，让程序继续运行，从另外两个方向判断
;;如果还是出现一奇一偶，in仍为nil,表示点在封闭曲线外
(T (setq in T));至少2次奇数，判断点在封闭曲线内，这比较合理
)
)
)
)
in
)

(defun HH_PtInCurve (p curve ray / A B FLAG IN L PTS) 
  (setq Flag T) 
  (setq in nil) 
  (setq L '(((-1 0) (1 0)) ((0 1) (0 -1)))) 
  ;;射线移位 
  (entmod (append (entget ray) (list (cons 10 p)))) 
  ;;旋转射线 
  (while (and (setq a (car L)) Flag) 
    (setq L (cdr L)) 
    (setq b (car a)) 
    (setq a (cadr a)) 
    (entmod (append (entget ray) (list (cons 11 b)))) 
    (setq pts (HH:TwoEntsInters ray curve 0)) 
    (cond ((not pts) (setq Flag nil)) 
          ((IsEven (length pts)) 
            (entmod (append (entget ray) (list (cons 11 a)))) 
            (setq pts (HH:TwoEntsInters ray curve 0)) 
            (cond 
              ((not pts) (setq Flag nil)) 
              ((IsEven (length pts)) (setq Flag nil)) ;2次偶数，判断点在曲线外，这比较合理 
              ;;一偶一奇，不好判断，让程序继续运行，从另外两个方向判断 
              ;;如果还是出现一偶一奇，in仍为nil,表示点在封闭曲线外 
            ) 
          ) 
          (T 
           (entmod (append (entget ray) (list (cons 11 a)))) 
           (setq pts (HH:TwoEntsInters ray curve 0)) 
           (cond 
             ((not pts) (setq Flag nil)) 
             ((IsEven (length pts))) 
             ;;一奇一偶，不好判断，让程序继续运行，从另外两个方向判断 
             ;;如果还是出现一奇一偶，in仍为nil,表示点在封闭曲线外 
             (T (setq in T));至少2次奇数，判断点在封闭曲线内，这比较合理 
           ) 
          ) 
    ) 
  ) 
  in 
)

自贡黄明儒 · 发表于 2024-3-29 11:37:40

dtucad 发表于 2024-3-28 23:22
黄总666 以前有个射线法好像不够精确

多旋转一下射线，应该更可靠。从我使用来看，旋转4次，就足够了。

天天问 · 发表于 2024-3-28 09:36:44

多谢大佬示范

loveu515 · 发表于 2024-3-28 11:23:35

感谢分享

Noangler · 发表于 2024-3-28 15:10:33

谢谢分享，赞一个！

hubeiwdlue · 发表于 2024-3-28 15:14:51

赞一个！！学习学习。

xiaolong1487 · 发表于 2024-3-28 20:54:25

谢谢分享，学习了

tigcat · 发表于 2024-3-28 20:55:58

谢谢黄总分享代码,黄老的cad国产了?

dtucad · 发表于 2024-3-28 23:22:16

本帖最后由 dtucad 于 2024-3-28 23:31 编辑

黄总666 以前有个射线法好像不够精确

账号		自动登录	找回密码
密码			注册

[讨论] 判断：一个点在封闭曲线内

评分

点评