Принадлежность точки криволинейному контуру (Страница 2 из 2)

;|Принадлежность точки Point контуру,
  образованному объектом obj
  Допустимуе объекты Polyline, Spline, Arc, Circle, Ellipse
  Опубликовано
  https://www.caduser.ru/forum/topic36191.html
  Аргументы
  Point - точка в МСК (Point in WCS)
  Obj   - объект (Ename or Vla-object)
  Возвращает (Return)
  T - точка в или на контуре (Point in Boundary)
  Nil - нет (not)
  |;
(defun In_Figure_Obj ( Point Obj / Boundary )
;|
******************************************************************************
*                                                                            *
*   Special thanks for ideas and codes of programs                           *
*   Joe Burke TraceObject  (http://www.theswamp.org/index.php?topic=13842.0) *
*                                                                            *
*   Особая благодарность за идеи и коды программ:                            *
*   Joe Burke TraceObject  http://www.theswamp.org/index.php?topic=13842.0   *
*                                                                            *
******************************************************************************
|;
(defun TraceObject (obj / typlst typ TracePline TraceACE TraceLine
                         TraceSpline TraceType1Pline
                          TraceType23Pline)
    (defun ZClosed (lst)
    (if (and (vlax-curve-isClosed obj)
         (not(equal (car lst)(last lst) 1e-6)))
      (append lst (list (car lst)))
      lst))
  ;; Argument: vla-object, a heavy or lightweight pline.
  ;; Returns: WCS point list if successful.
(defun TracePline (obj / param endparam anginc tparam pt blg
                           ptlst delta inc arcparam flag)
    (setq param (vlax-curve-getStartParam obj)
          endparam (vlax-curve-getEndParam obj)
          anginc (* pi (/ 0.5 180.0))
    )
    ;; Check to see if the pline contains arcs.
    ;; If not, get the point list from the coordinates property.
    ;; If so, do the other stuff.
    ;; Don't modify the param var here.
    (setq tparam param)
      (while (<= param endparam)
        (setq pt (vlax-curve-getPointAtParam obj param))
        ;Avoid duplicate points between start and end.
        (if (not (equal pt (car ptlst) 1e-12))
          (setq ptlst (cons pt ptlst))
        )
        ;A closed pline returns an error (invalid index)
        ;when asking for the bulge of the end param.
        (if
          (and
            (/= param endparam)
            (setq blg (abs (vlax-invoke obj 'GetBulge param)))
            (/= 0 blg)
          )
          (progn
            (setq delta (* 4 (atan blg)) ;included angle
                  inc (/ 1.0 (1+ (fix (/ delta anginc))))
                  arcparam (+ param inc)
            )
            (while (< arcparam (1+ param))
              (setq pt (vlax-curve-getPointAtParam obj arcparam)
                    ptlst (cons pt ptlst)
                    arcparam (+ inc arcparam)
              )
            )
          )
        )
        (setq param (1+ param))
      )
    (if
      (and
        (apply 'and ptlst)
        (> (length ptlst) 1)
      )
     (ZClosed (reverse ptlst))
    )
  ) ;end
  ;; Argument: vla-object, an arc, circle or ellipse.
  ;; Returns: WCS point list if successful.
  (defun TraceACE (obj / startparam endparam anginc
                         delta div inc pt ptlst)
    ;start and end angles
    ;circles don't have StartAngle and EndAngle properties.
    (setq startparam (vlax-curve-getStartParam obj)
          endparam (vlax-curve-getEndParam obj)
          anginc (* pi (/ 5.0 180.0))
    )
    (if (equal endparam (* pi 2) 1e-12)
      (setq delta endparam)
      (setq delta (NormalAngle (- endparam startparam)))
    )
    ;Divide delta (included angle) into an equal number of parts.
    (setq div (1+ (fix (/ delta anginc)))
          inc (/ delta div)
    )
    ;Or statement allows the last point on an open ellipse
    ;rather than using (<= startparam endparam) which sometimes
    ;fails to return the last point. Not sure why.
    (while
      (or
        (< startparam endparam)
        (equal startparam endparam 1e-12)
      )
      (setq pt (vlax-curve-getPointAtParam obj startparam)
            ptlst (cons pt ptlst)
            startparam (+ inc startparam)
      )
    )
    (reverse ptlst)
  ) ;end
  ;; Added because these trace functions are used with
  ;; other functions which may need this for convenience.
  (defun TraceLine (obj)
      (list
        (vlax-get obj 'StartPoint)
        (vlax-get obj 'EndPoint)
      )
  ) ;end
  ;; Note regarding the trailing part of a spline which was broken with
  ;; the break command. It's start param is not zero.
  ;; 0.0174533 one degree in radians
  ;; 0.00872665 half degree
  ;; 0.00436332 quarter degree
  ;; 0.00218166 1/8
  (defun TraceSpline (obj / startparam endparam ncpts inc param
                            fd ptlst pt1 pt2 ang1 ang2 a)
    (setq startparam (vlax-curve-getStartParam obj)
          endparam (vlax-curve-getEndParam obj)
          ncpts (vlax-get obj 'NumberOfControlPoints)
          inc (/ (- endparam startparam) (* ncpts 10))
          param (+ inc startparam)
          fd (vlax-curve-getfirstderiv obj param)
          ptlst (cons (vlax-curve-getStartPoint obj) ptlst)
    )
    (while (< param endparam)
      (setq pt1 (vlax-curve-getPointAtParam obj param)
;_           ang1 (angle pt1 (mapcar '+ pt1 fd))
            ang1 fd
            param (+ param inc)
            pt2 (vlax-curve-getPointAtParam obj param)
            fd (vlax-curve-getfirstderiv obj param)
;_            ang2 (angle pt2 (mapcar '+ pt2 fd))
            ang2 fd
;_            a (abs (@delta ang1 ang2))
            a (abs (3d_angw1w2 ang1 ang2))
      )
      (setq ptlst (cons pt1 ptlst))
;;;      (if (> a 0.00218166)
;;;        (setq ptlst (cons pt1 ptlst))
;;;      )
    )
    ;add last point and check for duplicates
    (if
      (not
        (equal
          (setq pt1 (vlax-curve-getEndPoint obj)) (car ptlst) 1e-8))
      (setq ptlst (cons pt1 ptlst))
    )
    (reverse ptlst)
  ) ;end
  ;; Explode curve fit pline and gather point list from arcs.
  ;; Checking for locked layers is the responsibility of the calling function.
  ;; This sub-function deletes objects.
  (defun TraceType1Pline (obj / ptlst objlst lst)
    (setq ptlst (list (vlax-curve-getStartPoint obj))
          objlst (vlax-invoke obj 'Explode)
    )
    (foreach x objlst
      (setq lst (TraceACE x))
      (if (not (equal (car lst) (last ptlst) 1e-8))
        (setq lst (reverse lst))
      )
      (setq ptlst (append ptlst (cdr lst)))
      (vla-delete x)
    )
    (ZClosed  ptlst)
  ) ;end
  ;; Explode quadratic and cubic plines and gather point list from lines.
  ;; Produces an exact trace.
  ;; This sub-function deletes objects.
  (defun TraceType23Pline (obj / objlst ptlst lastpt)
    (setq objlst (vlax-invoke obj 'Explode)
          lastpt (vlax-get (last objlst) 'EndPoint)
    )
    (foreach x objlst
      (setq ptlst (cons (vlax-get x 'StartPoint) ptlst))
      (vla-delete x)
    )
   (ZClosed (reverse (cons lastpt ptlst)))
  ) ;end
  (defun Trace3DPline (obj / coord ptlst)
    (setq coord (vlax-get obj 'Coordinates))
    (repeat (/ (length coord) 3)
      (setq ptlst (cons (list (car coord) (cadr coord)(caddr coord)) ptlst))
      (setq coord (cdddr coord))
    )
    ;ZZeroList not needed here.
    (ZClosed (reverse ptlst))
  ) ;end
  ;;;; end sub-functions ;;;;
  ;;;; primary function ;;;;
  (setq typlst '("AcDb2dPolyline" "AcDbPolyline" "AcDb3dPolyline"
                 "AcDbCircle" "AcDbArc" "AcDbEllipse"
                 "AcDbSpline" "AcDbLine"))
  (or
    (eq (type obj) 'VLA-OBJECT)
    (setq obj (vlax-ename->vla-object obj))
  )
  (setq typ (vlax-get obj 'ObjectName))
  (if (vl-position typ typlst)
    (cond
       ((or (eq typ "AcDb2dPolyline") (eq typ "AcDbPolyline"))
          (cond
            ((or
               (not (vlax-property-available-p obj 'Type))
               (= 0 (vlax-get obj 'Type))
              )
              (TracePline obj)
            )
            ((or (= 3 (vlax-get obj 'Type)) (= 2 (vlax-get obj 'Type)))
              (TraceType23Pline obj)
            )
            ((= 1 (vlax-get obj 'Type))
              (TraceType1Pline obj)
            )
          )
       )
       ((eq typ "AcDbLine")
         (TraceLine obj)
       )
       ((or (eq typ "AcDbCircle") (eq typ "AcDbArc") (eq typ "AcDbEllipse"))
         (TraceACE obj)
       )
       ((eq typ "AcDbSpline")
         (TraceSpline obj)
       )
       ((eq typ "AcDb3dPolyline")
         (Trace3DPline obj)
       )
    )
  )
)
;====================
  ;* алгоритм взят на http://algolist.manual.ru/maths/geom/belong/poly2d.php
;* На основе vk_IsPointInside
;* Опубликовано  https://www.caduser.ru/forum/topic36191.html
;* Boundary - список нормализованных [т.е. только либо (X Y) либо (X Y Z)] точек
(defun In_Figure (Point Boundary / FarPoint Check)
  ;_Проверяет Boundary на условие car и last одна и та же точка
  (if (not (equal (car Boundary)(last Boundary) 1e-6))
    (setq Boundary (append Boundary (list(car Boundary)))))
  (setq FarPoint (cons (+ (apply 'max (mapcar 'car Boundary)) 1.0)
                       (cdr Point)
                 ) ;_ end of cons
  ) ;_ end of setq
  (or
    (not
      (zerop
        (rem
          (length
            (vl-remove
              nil
              (mapcar
                (function (lambda (p1 p2) (inters Point FarPoint p1 p2))
                ) ;_ end of function
                Boundary
                (cdr Boundary)
              ) ;_ end of mapcar
            ) ;_ end of vl-remove
          ) ;_ end of length
          2
        ) ;_ end of rem
      ) ;_ end of zerop
    ) ;_ end of not
    (vl-some (function (lambda (x) x))
             (mapcar
               (function (lambda (p1 p2)
                           (or Check
                               (if (equal (+ (distance Point p1)
                                             (distance Point p2)
                                             ) ;_ end of +
                                          (distance p1 p2)
                                          1e-3) ;_ end of equal
                                 (setq Check T) nil)
                               )
                         ) ;_ end of lambda
               ) ;_ end of function
               Boundary
               (cdr Boundary)
             ) ;_ end of mapcar
    ) ;_ end of vl-some
  ) ;_ end of or
)
(defun TraceToLWPlinePoint ( obj )(mapcar '(lambda(x)(trans x  0 (ucszdir)))(TraceObject obj)))
(defun ucszdir ()(trans '(0 0 1) 1 0 T))
(defun convPtTo2d (pt)(list (car pt)(cadr pt)))
(defun getNorm ( obj )(vlax-safearray->list(vlax-variant-value(vla-get-Normal obj))))
(vl-load-com)
 (if (= (type obj) 'ENAME)(setq obj (vlax-ename->vla-object obj)))
  (setq Boundary (TraceToLWPlinePoint obj )
            Boundary (mapcar 'convPtTo2d  Boundary)
            )
  (setq Point (trans Point  0 (ucszdir))
    Point (convPtTo2d Point))
  (In_Figure Point Boundary)
  )

 ;Использование
 ;Usage
(defun C:TEST ( / ss ent obj Point)
  (vl-load-com)
  (if (and
    (princ "\nУкажите контур:")
    (setq ss (ssget "_:S:E:L" '((0 . "CIRCLE,ARC,*POLYLINE,SPLINE,ELLIPSE"))))
    (setq ent (ssname ss 0))
    (setq obj (vlax-ename->vla-object ent))
    )
    (progn
      (while (setq Point (getpoint "\nТочка <выход>:"))
         (setq Point (trans Point  1 0))
         (if (In_Figure_Obj Point Obj)
           (princ " --> в контуре")
           (princ " --> мимо")
           )
        )
      )
    )
  )