判断点是否在曲线内部

Lisphk · 发表于 2020-12-30 19:31:34

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

; Lee Mac Point Inside Curve
(defun LM:Inside-p
(pt ent / unit v^v _GroupByNum fd1 fd2 par lst nrm obj tmp)
(vl-load-com)
(defun *error* (errmsg)
(if (not
(wcmatch errmsg
"Function cancelled,quit / exit abort,console break"
)
)
(princ (strcat "\nError: " errmsg))
)
(vla-put-color obj acYellow)
(princ)
)
(defun unit (v / d)
(if (not (equal (setq d (distance '(0.0 0.0 0.0) v)) 0.0 1e-8))
(mapcar '(lambda (x) (/ x d)) v)
)
)
(defun v^v (u v)
(list
(- (* (cadr u) (caddr v)) (* (caddr u) (cadr v)))
(- (* (caddr u) (car v)) (* (car u) (caddr v)))
(- (* (car u) (cadr v)) (* (cadr u) (car v)))
)
)
(defun _GroupByNum (l n / r)
(if l
(cons (reverse (repeat n
(setq r (cons (car l) r)
l (cdr l)
)
r
)
)
(_GroupByNum l n)
)
)
)
(if (= (type ent) 'VLA-OBJECT)
(setq obj ent
ent (vlax-vla-object->ename ent)
)
(setq obj (vlax-ename->vla-object ent))
)
(if (vlax-curve-isplanar ent)
(progn
(setq fd1 (vlax-curve-getfirstderiv
ent
(setq par (vlax-curve-getstartparam ent))
)
)
(while (equal fd1
(setq fd2
(vlax-curve-getfirstderiv ent (setq par (+ par 0.001)))
)
1e-3
)
)
(setq nrm (unit (v^v fd1 fd2)))
(setq lst
(_GroupByNum
(vlax-invoke
(setq tmp
(vlax-ename->vla-object
(entmakex
(list
(cons 0 "RAY")
(cons 100 "AcDbEntity")
(cons 100 "AcDbRay")
(cons 10 pt)
(cons 11 (trans '(1. 0. 0.) nrm 0))
)
)
)
)
'IntersectWith
obj
acextendnone
)
3
)
)
(vla-delete tmp)
;; gile:
(and
lst
(not (vlax-curve-getparamatpoint ent pt))
(= 1
(rem
(length
(vl-remove-if
(function
(lambda (p / pa p- p+ p0)
(setq pa (vlax-curve-getparamatpoint ent p))
(and
(setq p-
(cond
((setq p- (vlax-curve-getPointatParam
ent
(- pa 1e-8)
)
)
(trans p- 0 nrm)
)
((trans
(vlax-curve-getPointatParam
ent
(- (vlax-curve-getEndParam ent) 1e-8)
)
0
nrm
)
)
)
)
(setq p+
(cond
((setq p+ (vlax-curve-getPointatParam
ent
(+ pa 1e-8)
)
)
(trans p+ 0 nrm)
)
((trans (vlax-curve-getPointatParam
ent
(+ (vlax-curve-getStartParam ent)
1e-8
)
)
0
nrm
)
)
)
)
(setq p0 (trans pt 0 nrm))
(<= 0 (* (sin (angle p0 p-)) (sin (angle p0 p+))))
;; LM Mod
)
)
)
lst
)
)
2
)
)
)
)
(prompt "\nReference curve isn't planar...")
)
)

; Lee Mac Point Inside Curve 
(defun LM:Inside-p 
       (pt ent / unit v^v _GroupByNum fd1 fd2 par lst nrm obj tmp) 
 
  (vl-load-com) 
 
  (defun *error* (errmsg) 
    (if        (not 
          (wcmatch errmsg 
                   "Function cancelled,quit / exit abort,console break" 
          ) 
        ) 
      (princ (strcat "\nError: " errmsg)) 
    ) 
    (vla-put-color obj acYellow) 
    (princ) 
  ) 
 
  (defun unit (v / d) 
    (if        (not (equal (setq d (distance '(0.0 0.0 0.0) v)) 0.0 1e-8)) 
      (mapcar '(lambda (x) (/ x d)) v) 
    ) 
  ) 
 
  (defun v^v (u v) 
    (list 
      (- (* (cadr u) (caddr v)) (* (caddr u) (cadr v))) 
      (- (* (caddr u) (car v)) (* (car u) (caddr v))) 
      (- (* (car u) (cadr v)) (* (cadr u) (car v))) 
    ) 
  ) 
 
  (defun _GroupByNum (l n / r) 
    (if        l 
      (cons (reverse (repeat n 
                       (setq r (cons (car l) r) 
                             l (cdr l) 
                       ) 
                       r 
                     ) 
            ) 
            (_GroupByNum l n) 
      ) 
    ) 
  ) 
 
  (if (= (type ent) 'VLA-OBJECT) 
    (setq obj ent 
          ent (vlax-vla-object->ename ent) 
    ) 
    (setq obj (vlax-ename->vla-object ent)) 
  ) 
 
  (if (vlax-curve-isplanar ent) 
    (progn 
      (setq fd1        (vlax-curve-getfirstderiv 
                  ent 
                  (setq par (vlax-curve-getstartparam ent)) 
                ) 
      ) 
      (while (equal fd1 
                    (setq fd2 
                           (vlax-curve-getfirstderiv ent (setq par (+ par 0.001))) 
                    ) 
                    1e-3 
             ) 
      ) 
      (setq nrm (unit (v^v fd1 fd2))) 
      (setq lst 
             (_GroupByNum 
               (vlax-invoke 
                 (setq tmp 
                        (vlax-ename->vla-object 
                          (entmakex 
                            (list 
                              (cons 0 "RAY") 
                              (cons 100 "AcDbEntity") 
                              (cons 100 "AcDbRay") 
                              (cons 10 pt) 
                              (cons 11 (trans '(1. 0. 0.) nrm 0)) 
                            ) 
                          ) 
                        ) 
                 ) 
                 'IntersectWith 
                 obj 
                 acextendnone 
               ) 
               3 
             ) 
      ) 
      (vla-delete tmp) 
      ;; gile: 
      (and 
        lst 
        (not (vlax-curve-getparamatpoint ent pt)) 
        (= 1 
           (rem 
             (length 
               (vl-remove-if 
                 (function 
                   (lambda (p / pa p- p+ p0) 
                     (setq pa (vlax-curve-getparamatpoint ent p)) 
                     (and 
                       (setq p- 
                              (cond 
                                ((setq p- (vlax-curve-getPointatParam 
                                            ent 
                                            (- pa 1e-8) 
                                          ) 
                                 ) 
                                 (trans p- 0 nrm) 
                                ) 
                                ((trans 
                                   (vlax-curve-getPointatParam 
                                     ent 
                                     (- (vlax-curve-getEndParam ent) 1e-8) 
                                   ) 
                                   0 
                                   nrm 
                                 ) 
                                ) 
                              ) 
                       ) 
                       (setq p+ 
                              (cond 
                                ((setq p+ (vlax-curve-getPointatParam 
                                            ent 
                                            (+ pa 1e-8) 
                                          ) 
                                 ) 
                                 (trans p+ 0 nrm) 
                                ) 
                                ((trans        (vlax-curve-getPointatParam 
                                          ent 
                                          (+ (vlax-curve-getStartParam ent) 
                                             1e-8 
                                          ) 
                                        ) 
                                        0 
                                        nrm 
                                 ) 
                                ) 
                              ) 
                       ) 
                       (setq p0 (trans pt 0 nrm)) 
                       (<= 0 (* (sin (angle p0 p-)) (sin (angle p0 p+)))) 
                       ;; LM Mod 
                     ) 
                   ) 
                 ) 
                 lst 
               ) 
             ) 
             2 
           ) 
        ) 
      ) 
    ) 
    (prompt "\nReference curve isn't planar...") 
  ) 
)

HLCAD · 发表于 2020-12-31 14:17:51

感谢楼主分享程序！！！

yuanziyou · 发表于 2022-7-4 22:14:21

虽然支持自相交曲线，还是有bug的，有时候会出现未知的错误。如果把63行的0.001及65行1e-3的都改成1e-5应该就没啥bug了（待测试）。另外此版本速度较慢，大量检查时有点卡

hh_lj007 · 发表于 2022-7-5 09:21:27

感谢楼主分享程序！！！

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

[每日一码] 判断点是否在曲线内部

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。