图形工具(生成和创建图形) - 多段线内做最大内接圆-高飞鸟 - 《技术博客》

;; maximum circle inscribed in a closed polyline
;;; writed by Gian Paolo Cattaneo
;;; edited by GSLS(SS) 2012-8-5
(defun C:TesT (/        POLY         POLY_vl  Dx           Dy            Lp
               List_vert_poly         list_p_int           P_center dist
               step1        step2         t1          t2        t3  t4    R0            area
               len        i         
              )
  (gc)
  (prompt "\nSelect Polyline: ")
  (if (setq POLY (ssname (ssget ":S" '((0 . "LWPOLYLINE"))) 0))
    (progn
      (setq i 1)
      (setq area (vlax-curve-getArea poly)
            len         (vlax-curve-getDistAtParam
                   poly
                   (vlax-curve-getEndParam poly)
                 )
      )
      (setq step1 (max 10 (fix (/ len 0.4 (sqrt area))))) ;_--> grid_1      
      (setq step2 10) ;_--> grid_2
      (setq list_vert_poly (LWPoly->List POLY 10))      
      (grid_1)
      (setq t1 (getvar "MilliSecs"))
      (Point_int)
      (setq t2 (getvar "MilliSecs"))
      ;|
      (foreach a list_p_int
        (entmake (list (cons 0 "POINT")
                       (cons 10 a)
                       (cons 62 3))))|;
      ;_(grid+)
      (Point_center)
      (setq t3 (getvar "MilliSecs"))
      (setq i 0)
      (while (and (> (- Dist R0) 1e-8) (< i 10))
        (grid_2)
        (Point_center)
        (setq i (1+ i))
      )
      (setq t4 (getvar "MilliSecs"))
      (entmake
        (list
          (cons 0 "CIRCLE")
          (cons 10 P_center)
          (cons 40 dist)
        )
      )
      (princ
        (strcat "\ntime1 = " (rtos (- t2 t1) 2 0) " MilliSecs")
      )
      (princ
        (strcat "\ntime2 = " (rtos (- t3 t2) 2 0) " MilliSecs")
      )
      (princ
        (strcat "\ntime3 = " (rtos (- t4 t3) 2 0) " MilliSecs")
      )
      (princ)
    )
  )
)
;; Restituisce una griglia di punti all'interno del getboundingbox della poly selezionata
;; Returns a grid of points within the BoundingBox of the selected poly
(defun grid_1 (/ p1 p2 X1 Y1 l1)
  (vla-getboundingbox (vlax-ename->vla-object POLY) 'p1 'p2)
  (setq        p1 (vlax-safearray->list p1)
        p2 (vlax-safearray->list p2)
        p1 (list (car p1) (cadr p1))
        p2 (list (car p2) (cadr p2))
  )
  (setq Dx (/ (- (car p2) (car p1)) step1))
  (setq Dy (/ (- (cadr p2) (cadr p1)) step1))
  (setq        Lp (list p1)
        X1 (car p1)
        Y1 (cadr p1)
  )
  (repeat step1
    (setq Lp (cons (list (setq X1 (+ X1 Dx)) Y1) Lp))
  )
  (setq Lp (list Lp))
  (repeat step1
    (setq Lp (cons (mapcar (function (lambda (x)
                                       (list (car x) (+ (cadr x) Dy))
                                     )
                           )
                           (car lp)
                   )
                   Lp
             )
    )
  )
  (setq Lp (apply (function append) Lp))
)
;; Restituisce una griglia di punti intorno al punto centrale (provvisorio)
;; Returns a grid of points around the center point (provisional)
(defun grid_2 (/ X1 Y1 P1)
  (setq        list_p_int nil
        X1           (- (car P_center) Dx)
        Y1           (- (cadr P_center) Dy)
        P1           (list X1 Y1)
        Dx           (/ (* 2 Dx) step2)
        Dy           (/ (* 2 Dy) step2)
  )
  (setq list_p_int (list P1))
  (repeat step2
    (setq list_p_int (cons (list (setq X1 (+ X1 Dx)) Y1) list_p_int))
  )
  (setq list_p_int (list list_p_int))
  (repeat step2
    (setq list_p_int
           (cons (mapcar (function (lambda (x)
                                     (list (car x) (+ (cadr x) Dy))
                                   )
                         )
                         (car list_p_int)
                 )
                 list_p_int
           )
    )
  )
  (setq list_p_int (apply (function append) list_p_int))
)
;; restituisce la lista dei punti interni ad un poligono
;; dati:  - lista coordinate dei punti -> Lp
;;        - lista coordinate vertici poligono -> list_vert_poly
;; Returns the list of points inside the polyline
(defun Point_int ()
  (setq        list_p_int
         (vl-remove-if-not 
           (function
             (lambda (pt)
               ;_determine point in curve , use widding number
               (equal
                 PI
                 (abs
                   (apply
                     (function +)
                     (mapcar (function (lambda (x y / a)
                                         (rem (- (angle pt x) (angle pt y)) PI)
                                       )
                             )
                             list_vert_poly
                             (cdr list_vert_poly)
                     )
                   )
                 )
                 1e-8
               )
             )
           )
           Lp
         )
  )
)
;; Infittisce la griglia inserendo altri punti
;; nel centro delle diagonali tra i punti interni
;; Insert points (interior) to increase the density of the grid
(defun grid+ (/ G+)
  (setq        G+
         (mapcar '(lambda (x)
                    (list (+ (car x) (/ Dx 2)) (+ (cadr x) (/ Dy 2)))
                  )
                 list_p_int
         )
  )
  (setq list_p_int (append G+ list_p_int))
)
;; Da una lista di punti restituisce quello più lontano da un oggetto
;; dati:  - lista dei punti -> list_p_int
;;        - oggetto -> POLY_vl
;; Returns the farthest point from the polyline
(defun Point_center (/ Pa Pvic)
  (foreach Pa list_p_int
    (setq Pvic (vlax-curve-getClosestPointTo Poly Pa))
    (if        (> (distance Pa Pvic) Dist)
      (setq P_center Pa
            R0             Dist
            Dist     (distance Pa Pvic)
      )
    )
  )
)
;;
(defun LWPoly->List (en acc / a b vetex bu p1 p2 l r ang an1 N)
  ;;Acc --- 0 ~ 99
  (setq ent (entget en))
  (while (setq ent (member (assoc 10 ent) ent))
    (setq b        (cons (cdar ent) b)
          ent        (member (assoc 42 ent) ent)
          b        (cons (cdar ent) b)
          ent        (cdr ent)
          vetex        (cons b vetex)
          b        nil
    )
  )
  (while vetex
    (setq a        (car vetex)
          vetex        (cdr vetex)
          bu        (car a)
          p1        (cadr a)
    )
    (if        l
      (setq p2 (car l))
      (setq p2 (cadr (last vetex))
            l  (cons p2 l)
      )
    )
    (if        (equal bu 0 1e-6)
      (setq l (cons p1 l))
      (progn
        (setq ang (* 2 (atan bu))
              r          (/ (distance p1 p2)
                     (* 2 (sin ang))
                  )
              c          (polar p1
                         (+ (angle p1 p2) (- (/ pi 2) ang))
                         r
                  )
              r          (abs r)
              ang (abs (* ang 2.0))
              N          (abs (fix (/ ang 0.0174532925199433)))
              N          (min N (1+ Acc))
        )
        (if (= N 0)
          (setq l (cons p1 l))
          (progn
            (setq an1 (/ ang N)
                  ang (angle c p2)
            )
            (if        (not (minusp bu))
              (setq an1 (- an1))
            )
            (repeat (1- N)
              (setq ang        (+ ang an1)
                    l        (cons (polar c ang r) l)
              )
            )
            (setq l (cons p1 l))
          )
        )
      )
    )
  )
)