Author Topic: =={challenge}==Find the maximum inscribed circle  (Read 12883 times)

0 Members and 1 Guest are viewing this topic.

chlh_jd

  • Guest
Re: =={challenge}==Find the maximum inscribed circle
« Reply #60 on: August 03, 2012, 03:15:12 AM »
The points inside are not calculated correctly.
Thank you for test , I'll check it .

chlh_jd

  • Guest
Re: =={challenge}==Find the maximum inscribed circle
« Reply #61 on: August 03, 2012, 05:26:23 AM »
The points inside are not calculated correctly.
Change the widding number's rounding accuracy 1e-4 into 1e-3 or 1e-2 will correct this problem .
Code: [Select]
;;
;; This method suggest by Lee Mac from http://en.wikipedia.org/wiki/Winding_number
;; function : determin the point position with the closed curve by widding-number method
;; l  ---- point set of a Closed Curve , First item must same as Last item .
;; pt ---- a given point to determin position with the Closed Curve
;; return a num
;;           ----  -1  pt out of curve
;;           ----   0  pt at curve
;;           ----   1  pt in curve
;; by GSLS(SS) 2012-08-02
;; Edited : Change widding number's Acc 1e-4 into 1e-2 ,
;;          for checking point in or out it's a integer
(defun Point-in-ClosedCurve-p (l pt / ang p1 p2 n r at)
  (setq ang 0.0
at  nil
  )
  (while (and (cadr l) (not at))
    (setq p1 (car l)
  p2 (cadr l)
  l  (cdr l)
    )
    (if (equal p1 p2 1e-6)
      (setq an1 0.0)
      (setq an1
     ((lambda (/ a b c d e f g)
(setq b (distance p1 pt)
      c (distance p2 pt)
      a (distance p1 p2)
      d (- (* (- (car p1) (car pt)) (- (cadr p2) (cadr pt)))
   (* (- (car p2) (car pt)) (- (cadr p1) (cadr pt)))
)
)
(if (and (equal d 0.0 1e-4) (setq at T))
  pi
  (progn
    (setq
      e (+ (* b b) (* c c) (* -1 a a))
      f (abs ((lambda (x)
(cond ((equal x 0.0 1e-6)(* pi 0.5))
      ((equal x 1.0 1e-6)0.0)
      ((atan (/ (sqrt (- 1 (* x x)))
x
     )
       ))
))
       (/ e 2. b c)
     )
)
      g (if (> d 0)  1  -1)
    )
    (if (< e 0)
      (* g (- pi f))
      (* g f)
    )
  )
)
      )
     )
      )
    )
    (setq ang (+ ang an1))
  )
  ;;deal widding number 
  (if at
    0
    (progn
      (setq n (/ ang 2. pi))
      (if (and (> n 0) (equal (1+ (fix n)) n 1e-2))
;_Change Acc 1e-4 to 1e-2 for correct 2012-8-3
  (setq n (1+ (fix n)))
  (if (and (< n 0) (equal (1- (fix n)) n 1e-2))
    ;_Change Acc 1e-4 to 1e-2 for correct 2012-8-3
    (setq n (1- (fix n)))
    (setq n (fix n))
  )
)
      (if (= (rem n 2) 0)
-1
1
      )
    )
  )
)

change test function for check Point_inter result .
Code: [Select]
;;; maximum circle inscribed in a closed polyline
;;; Gian Paolo Cattaneo

(defun C:TesT (/ POLY    POLY_vl   Dx        Dy
       Lp List_vert_poly      list_p_int
       P_center dist    step1     step2     t1
       t2
      )
  (prompt "\nSelect Polyline: ")
  (if (setq POLY (ssname (ssget ":S" '((0 . "LWPOLYLINE"))) 0))
    (progn
      (setq i  1
    t1 (getvar "MilliSecs")
      )
      (setq step1 40) ;--> grid_1
      (setq step2 20) ;--> grid_2
      (setq list_vert_poly (LWPoly->List POLY 99))
      (grid_1)     
      (Point_int)     
      (foreach a list_p_int
(entmake (list (cons 0 "POINT")
       (cons 10 a))
)
)
      (grid+)
      (Point_center)
      (repeat 2
(grid_2)
(Point_center)
      )
      (entmake
(list
  (cons 0 "CIRCLE")
  (cons 10 P_center)
  (cons 40 dist)
)
      )
      (setq t2 (getvar "MilliSecs"))
      (princ (strcat "time = " (rtos (- t2 t1) 2 0) " MilliSecs"))
      (princ)
    )
  )
)

chlh_jd

  • Guest
Re: =={challenge}==Find the maximum inscribed circle
« Reply #62 on: August 05, 2012, 08:03:12 AM »
New version for Point-in-ClosedCurve , it run quickest .
Code: [Select]
(defun Point-in-ClosedCurve-p (l pt / ang p1 p2 n r at)
  (setq ang 0.0)
  (while (and (cadr l) (not at))
    (setq p1 (car l)
  p2 (cadr l)
  l  (cdr l)
  an1 (- (angle pt p2) (angle pt p1))
    )   
    (if (< an1 (- pi))
      (setq an1 (+ an1 pi pi))
      (if (> an1 pi)
(setq an1 (- an1 pi pi))
      )
    )
    (if (equal (abs an1) pi 1e-14)
      (setq at T)
    )
    (setq ang (+ ang an1))
  )
  ;;deal widding number 
  (if at
    0
    (progn
      (setq n (/ ang 2. pi))
      (if (and (> n 0) (equal (1+ (fix n)) n 1e-2))
 ;_Change Acc 1e-4 to 1e-2 for correct 2012-8-3
(setq n (1+ (fix n)))
(if (and (< n 0) (equal (1- (fix n)) n 1e-2))
 ;_Change Acc 1e-4 to 1e-2 for correct 2012-8-3
  (setq n (1- (fix n)))
  (setq n (fix n))
)
      )
      (if (= (rem n 2) 0)
-1
1
      )
    )
  )
)


chlh_jd

  • Guest
Re: =={challenge}==Find the maximum inscribed circle
« Reply #63 on: August 05, 2012, 11:20:23 AM »
Use GP's method :
Some change will improve the speed and accuracy .
1. To suit for any complex tubular closed curve ,  Use the ratio of circumference and area to optimize the number of grids in  the step 1 ;
Code: [Select]
(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     
2.  Force step2 into 10 , because  10 equal grid is enough to make the radius improve the accuracy of a rating
3.  change the 'Grid_2' routine's area
Code: [Select]
;;old grid_2 area
+ + + + +
+ + + + +
+ + o + +
+ + + + +
+ + + + +
;;new grid_2 area
+ + +
+ o +
+ + +
4. Use radius accuracy to control the loop , 'While' method replace  'Repeat' method .
  In most cases, will improve the speed .
5.  Limits the number of the while loop, to adapt to the rectangle .

Codes Following
Code: [Select]
;;; 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  R0  area len i
      )
  (gc)
  (prompt "\nSelect Polyline: ")
  (if (setq POLY (ssname (ssget ":S" '((0 . "LWPOLYLINE"))) 0))
    (progn
      (setq i  1
    t1 (getvar "MilliSecs")
      )
      (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)
      (Point_int)     
      (grid+)
      (Point_center)
      (setq i 0)
      (while (and (> (- Dist R0) 1e-8)(< i 10))
(grid_2)
(Point_center)
(setq i (1+ i))
      )
      (entmake
(list
  (cons 0 "CIRCLE")
  (cons 10 P_center)
  (cons 40 dist)
)
      )
      (setq t2 (getvar "MilliSecs"))
      (princ (strcat "time = " (rtos (- t2 t1) 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 (/ n Pr cont attr p# Pa Pa_ Pb)
  (setq list_p_int nil)
  (foreach Pr Lp
    (if (> (Point-in-ClosedCurve-p list_vert_poly Pr) 0)
      (setq list_p_int (cons Pr list_p_int))
    )
  )
)
;; 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))
  )
)
      )
    )
  )
  l
)
;;
;; This method suggest by Lee Mac from http://en.wikipedia.org/wiki/Winding_number
;; function : determin the point position with the closed curve by widding-number method
;; l  ---- point set of a Closed Curve , First item must same as Last item .
;; pt ---- a given point to determin position with the Closed Curve
;; return a num
;;           ----  -1  pt out of curve
;;           ----   0  pt at curve
;;           ----   1  pt in curve
;; by GSLS(SS) 2012-08-02
;; Edited : Change widding number's Acc 1e-4 into 1e-2 ,
;;          for checking point in or out it's a integer
;; Edited 2012-8-5
;;         Improved vector angle calculation , only use angle function .
;;         
(defun Point-in-ClosedCurve-p (l pt / ang p1 p2 n r at)
  (setq ang 0.0)
  (while (and (cadr l) (not at))
    (setq p1  (car l)
  p2  (cadr l)
  l   (cdr l)
  an1 (- (angle pt p2) (angle pt p1))
    )
    (if (< an1 (- pi))
      (setq an1 (+ an1 pi pi))
      (if (> an1 pi)
(setq an1 (- an1 pi pi))
      )
    )
    (if (equal (abs an1) pi 1e-14);_If it's just used to solve the maximum radius of the circle,
                                 ;_here's  precision 1e-14 can be set lower , such as 1e-1 ,
                                 ;_this will exclude the point of the curve edge .
                                 ;_but for ultra-narrow four-point rectangle will generate an error .
      (setq at T)
    )
    (setq ang (+ ang an1))
  )
  ;;deal widding number 
  (if at
    0
    (progn
      (setq n (/ ang 2. pi))
      (if (and (> n 0) (equal (1+ (fix n)) n 1e-2))
(setq n (1+ (fix n)))
(if (and (< n 0) (equal (1- (fix n)) n 1e-2))
  (setq n (1- (fix n)))
  (setq n (fix n))
)
      )
      (if (= (rem n 2) 0)
-1
1
      )
    )
  )
)
Any suggestions are welcome .
« Last Edit: August 05, 2012, 11:25:29 AM by chlh_jd »

chlh_jd

  • Guest
Re: =={challenge}==Find the maximum inscribed circle
« Reply #64 on: August 05, 2012, 01:42:01 PM »
improve the routine for determining point in curve , Saving most of his time .
the (grid+) step can be omitted .
Code: [Select]
;;; 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))
  )
)
      )
    )
  )
  l
)
« Last Edit: August 05, 2012, 01:55:30 PM by chlh_jd »

GP

  • Newt
  • Posts: 82
  • Vercelli, Italy
Re: =={challenge}==Find the maximum inscribed circle
« Reply #65 on: August 05, 2012, 03:39:31 PM »
fixed a bug:

;;; writed by Gian Paolo Cattaneo GSLS(SS)

:-)

chlh_jd

  • Guest
Re: =={challenge}==Find the maximum inscribed circle
« Reply #66 on: August 06, 2012, 07:44:44 AM »
fixed a bug:

;;; writed by Gian Paolo Cattaneo GSLS(SS)

:-)
I just state fact , you are always so humble  :-)

ribarm

  • Water Moccasin
  • Posts: 2126
  • Marko Ribar, architect
Re: =={challenge}==Find the maximum inscribed circle
« Reply #67 on: May 03, 2014, 04:40:36 AM »
I've decided to revive this topic... Thanks to GSLS(SS) and Gian P., I've written this extension... It should create maximum inscribed circles and also in 3D... Please, test the code - I've had many small fine tunings until I finally settled to this version... If circle with current color is drawn than in most cases the result is exact circle - if circle is yellow, then it's not precise...

HTH, M.R. (Hope I saved some time for those that code...)

Code - Auto/Visual Lisp: [Select]
  1. (defun c:ipls ( / *error* 2d-lw-pt GetIntersections GroupByNum interse1e2 MaximumInscribedCircle_p LWPoly->List grid_1 grid_2 Point_int grid+ Point_center adoc area len ape polys poly pl x e n i lst p dist ci ptse1e2 pts1 pts2 pts3 ptsints plpts ptl )
  2.  
  3.  
  4.   (defun *error* ( msg )
  5.     (if ape (setvar 'aperture ape))
  6.     (vla-endundomark adoc)
  7.     (if msg (prompt msg))
  8.     (princ)
  9.   )
  10.  
  11.   (defun 2d-lw-pt ( lst )
  12.     (if lst
  13.       (cons (list (car lst) (cadr lst)) (2d-lw-pt (cddr lst)))
  14.     ) ;_  if
  15.   )
  16.  
  17.   (defun GetIntersections ( obj1 obj2 )
  18.     (GroupByNum (vlax-invoke obj1 'IntersectWith obj2 acExtendNone) 3)
  19.   )
  20.  
  21.   (defun GroupByNum ( l n / r)
  22.     (if l
  23.       (cons
  24.         (reverse (repeat n (setq r (cons (car l) r) l (cdr l)) r))
  25.         (GroupByNum l n)
  26.       )
  27.     )
  28.   )
  29.  
  30.   (defun interse1e2 ( e1 e2 / lst )
  31.     (if (and e1 e2)
  32.       (setq lst (GetIntersections (vlax-ename->vla-object e1) (vlax-ename->vla-object e2)))
  33.     )
  34.     lst
  35.   )
  36.  
  37. ;****************************************************************************
  38. ;  Ritorna il centro del massimo cerchio inscritto in una polilinea          
  39. ;  Returns the center point of the maximum inscribed circle in a polyline    
  40. ;                    Author: Gian Paolo Cattaneo
  41. ;  edited by GSLS(SS) 2012-8-5
  42. ;****************************************************************************                            
  43.   (defun MaximumInscribedCircle_p ( poly / list_vert_poly step1 step2 i r0 P_center )
  44.  
  45.       (setq step1 (max 10 (fix (/ len 0.4 (sqrt area))))) ;_--> grid_1      
  46.       (setq step2 10) ;_--> grid_2
  47.       (setq list_vert_poly (LWPoly->List POLY 10))      
  48.       (grid_1)
  49.       (Point_int)
  50.       (Point_center)
  51.       (setq i 0)
  52.       (while (and (> (- Dist R0) 1e-8) (< i 10))
  53.         (grid_2)
  54.         (Point_center)
  55.         (setq i (1+ i))
  56.       )
  57.       P_center
  58.   )
  59.  
  60. ;; Restituisce una griglia di punti all'interno del getboundingbox della poly selezionata
  61. ;; Returns a grid of points within the BoundingBox of the selected poly
  62.   (defun grid_1 (/ p1 p2 X1 Y1 l1)
  63.     (vla-getboundingbox (vlax-ename->vla-object POLY) 'p1 'p2)
  64.     (setq       p1 (vlax-safearray->list p1)
  65.           p2 (vlax-safearray->list p2)
  66.           p1 (list (car p1) (cadr p1))
  67.           p2 (list (car p2) (cadr p2))
  68.     )
  69.     (setq Dx (/ (- (car p2) (car p1)) step1))
  70.     (setq Dy (/ (- (cadr p2) (cadr p1)) step1))
  71.     (setq       Lp (list p1)
  72.           X1 (car p1)
  73.           Y1 (cadr p1)
  74.     )
  75.     (repeat step1
  76.       (setq Lp (cons (list (setq X1 (+ X1 Dx)) Y1) Lp))
  77.     )
  78.     (setq Lp (list Lp))
  79.     (repeat step1
  80.       (setq Lp (cons (mapcar (function (lambda (x)
  81.                  (list (car x) (+ (cadr x) Dy))
  82.                )
  83.            )
  84.            (car lp)
  85.          )
  86.          Lp
  87.          )
  88.       )
  89.     )
  90.     (setq Lp (apply (function append) Lp))
  91.   )
  92. ;; Restituisce una griglia di punti intorno al punto centrale (provvisorio)
  93. ;; Returns a grid of points around the center point (provisional)
  94.   (defun grid_2 (/ X1 Y1 P1)
  95.     (setq       list_p_int nil
  96.           X1       (- (car P_center) Dx)
  97.           Y1       (- (cadr P_center) Dy)
  98.           P1       (list X1 Y1)
  99.           Dx       (/ (* 2 Dx) step2)
  100.           Dy       (/ (* 2 Dy) step2)
  101.     )
  102.     (setq list_p_int (list P1))
  103.     (repeat step2
  104.       (setq list_p_int (cons (list (setq X1 (+ X1 Dx)) Y1) list_p_int))
  105.     )
  106.     (setq list_p_int (list list_p_int))
  107.     (repeat step2
  108.       (setq list_p_int
  109.        (cons (mapcar (function (lambda (x)
  110.                (list (car x) (+ (cadr x) Dy))
  111.              )
  112.          )
  113.          (car list_p_int)
  114.        )
  115.        list_p_int
  116.        )
  117.       )
  118.     )
  119.     (setq list_p_int (apply (function append) list_p_int))
  120.   )
  121. ;; restituisce la lista dei punti interni ad un poligono
  122. ;; dati:  - lista coordinate dei punti -> Lp
  123. ;;        - lista coordinate vertici poligono -> list_vert_poly
  124. ;; Returns the list of points inside the polyline
  125.   (defun Point_int ()
  126.     (setq       list_p_int
  127.      (vl-remove-if-not
  128.        (function
  129.          (lambda (pt)
  130.            ;_determine point in curve , use widding number
  131.            (equal
  132.              PI
  133.              (abs
  134.                (apply
  135.                  (function +)
  136.                  (mapcar (function (lambda (x y / a)
  137.                    (rem (- (angle pt x) (angle pt y)) PI)
  138.                        )
  139.                    )
  140.                    list_vert_poly
  141.                    (cdr list_vert_poly)
  142.                  )
  143.                )
  144.              )
  145.              1e-8
  146.            )
  147.          )
  148.        )
  149.        Lp
  150.      )
  151.     )
  152.   )
  153. ;; Infittisce la griglia inserendo altri punti
  154. ;; nel centro delle diagonali tra i punti interni
  155. ;; Insert points (interior) to increase the density of the grid
  156.   (defun grid+ (/ G+)
  157.     (setq       G+
  158.      (mapcar '(lambda (x)
  159.           (list (+ (car x) (/ Dx 2)) (+ (cadr x) (/ Dy 2)))
  160.         )
  161.        list_p_int
  162.      )
  163.     )
  164.     (setq list_p_int (append G+ list_p_int))
  165.   )
  166. ;; Da una lista di punti restituisce quello pił lontano da un oggetto
  167. ;; dati:  - lista dei punti -> list_p_int
  168. ;;        - oggetto -> POLY_vl
  169. ;; Returns the farthest point from the polyline
  170.   (defun Point_center (/ Pa Pvic)
  171.     (setq Dist 1e-6)
  172.     (foreach Pa list_p_int
  173.       (setq Pvic (vlax-curve-getClosestPointTo Poly Pa))
  174.       (if       (> (distance Pa Pvic) Dist)
  175.         (setq P_center Pa
  176.               R0             Dist
  177.               Dist     (distance Pa Pvic)
  178.         )
  179.       )
  180.     )
  181.   )
  182. ;;
  183.   (defun LWPoly->List (en acc / a b vetex bu p1 p2 l r ang an1 N)
  184.     ;;Acc --- 0 ~ 99
  185.     (setq ent (entget en))
  186.     (while (setq ent (member (assoc 10 ent) ent))
  187.       (setq b   (cons (cdar ent) b)
  188.             ent (member (assoc 42 ent) ent)
  189.             b   (cons (cdar ent) b)
  190.             ent (cdr ent)
  191.             vetex       (cons b vetex)
  192.             b   nil
  193.       )
  194.     )
  195.     (while vetex
  196.       (setq a   (car vetex)
  197.             vetex       (cdr vetex)
  198.             bu  (car a)
  199.             p1  (cadr a)
  200.       )
  201.       (if       l
  202.         (setq p2 (car l))
  203.         (setq p2 (cadr (last vetex))
  204.               l  (cons p2 l)
  205.         )
  206.       )
  207.       (if       (equal bu 0 1e-6)
  208.         (setq l (cons p1 l))
  209.         (progn
  210.           (setq ang (* 2 (atan bu))
  211.                 r         (/ (distance p1 p2)
  212.                        (* 2 (sin ang))
  213.                     )
  214.                 c         (polar p1
  215.                        (+ (angle p1 p2) (- (/ pi 2) ang))
  216.                     r
  217.                     )
  218.                 r         (abs r)
  219.                 ang (abs (* ang 2.0))
  220.                 N         (abs (fix (/ ang 0.0174532925199433)))
  221.                 N         (min N (1+ Acc))
  222.           )
  223.           (if (= N 0)
  224.             (setq l (cons p1 l))
  225.             (progn
  226.               (setq an1 (/ ang N)
  227.               ang (angle c p2)
  228.               )
  229.               (if       (not (minusp bu))
  230.                 (setq an1 (- an1))
  231.               )
  232.               (repeat (1- N)
  233.                 (setq ang       (+ ang an1)
  234.                 l       (cons (polar c ang r) l)
  235.                 )
  236.               )
  237.               (setq l (cons p1 l))
  238.             )
  239.           )
  240.         )
  241.       )
  242.     )
  243.     l
  244.   )
  245.  
  246.   (setq ape (getvar 'aperture))
  247.   (setvar 'aperture 10)
  248.   (command "_.ucs" "_W")
  249.   (if
  250.     (and
  251.       (princ "\nSelect a Closed LWPolylines")
  252.       (setq polys (ssget '((0 . "LWPOLYLINE")(-4 . "&=")(70 . 1))))
  253.     )
  254.     (progn
  255.       (setq i -1)
  256.       (while (setq poly (ssname polys (setq i (1+ i))))
  257.         (setq area (vlax-curve-getArea poly)
  258.               len (vlax-curve-getDistAtParam poly (vlax-curve-getEndParam poly))
  259.         )
  260.         (setq x (vla-copy (vlax-ename->vla-object poly)))
  261.         (setq n (vla-get-normal x))
  262.         (setq e (vla-get-elevation x))
  263.         (vla-put-normal x (vlax-3d-point 0. 0. 1.))
  264.         (vla-update x)
  265.         (setq p (MaximumInscribedCircle_p (vlax-vla-object->ename x)))
  266.         (setq p (list (car p) (cadr p)))
  267.         (setq pl (entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 2) '(70 . 0) (cons 38 e) (assoc 10 (entget (vlax-vla-object->ename x))) (cons 10 p) '(210 0.0 0.0 1.0))))
  268.         (vla-put-normal (vlax-ename->vla-object pl) n)
  269.         (vla-update (vlax-ename->vla-object pl))
  270.         (setq p (trans (vlax-curve-getendpoint pl) 0 poly))
  271.         (setq ci (entmakex (list '(0 . "CIRCLE") '(100 . "AcDbEntity") '(100 . "AcDbCircle") (cons 10 p) (cons 40 (+ dist 1e-3)) '(62 . 2) (assoc 210 (entget poly)))))
  272.         (entdel pl)
  273.         (entdel (vlax-vla-object->ename x))
  274.         (setq ptse1e2 (vl-catch-all-apply 'interse1e2 (list poly ci)))
  275.         (command "_.ucs" "_ZA" '(0.0 0.0 0.0) (trans (cdr (assoc 210 (entget poly))) 0 1 t))
  276.         (setq pts1 (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (car ptse1e2) (cadr ptse1e2)))
  277.         (setq pts2 (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (caddr ptse1e2) (cadddr ptse1e2)))
  278.         (setq pts3 (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (car (reverse ptse1e2)) (cadr (reverse ptse1e2))))
  279.         (setq ptse1e2 (list pts1 pts2 pts3))
  280.         (setq ptsints ptse1e2)
  281.         (setq plpts (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= (car x) 10)) (entget poly))))
  282.         (setq plpts (mapcar '(lambda ( x ) (list (car x) (cadr x) e)) plpts))
  283.         (setq plpts (mapcar '(lambda ( x ) (trans x poly 0)) plpts))
  284.         (foreach pt ptsints
  285.           (mapcar '(lambda ( x ) (if (equal pt x (/ len 40.0 (sqrt area))) (setq ptl (cons pt ptl)))) plpts)
  286.         )
  287.         (foreach pt ptl
  288.           (setq ptsints (vl-remove-if '(lambda ( x ) (equal x pt (/ len 16.0 (sqrt area)))) ptsints))
  289.         )
  290.         (if (>= (length ptl) 3)
  291.             (progn
  292.             (entdel ci)
  293.             (vl-cmdf "_.circle" "3P" "_end" (trans (car ptl) 0 1) "_end" (trans (cadr ptl) 0 1) "_end" (trans (caddr ptl) 0 1))
  294.             )
  295.         )
  296.         (if (and (= (length ptl) 2) (= (length ptsints) 0))
  297.             (progn
  298.             (entdel ci)
  299.             (vl-cmdf "_.circle" "3P" "_end" (trans (car ptl) 0 1) "_end" (trans (cadr ptl) 0 1))
  300.             )
  301.         )
  302.         (if (and (= (length ptl) 2) (= (length ptsints) 1))
  303.             (progn
  304.             (entdel ci)
  305.             (vl-cmdf "_.circle" "3P" "_end" (trans (car ptl) 0 1) "_end" (trans (cadr ptl) 0 1) "_tan" (trans (vlax-curve-getclosestpointto poly (car ptsints)) 0 1))
  306.             )
  307.         )
  308.         (if (and (= (length ptl) 1) (= (length ptsints) 1))
  309.             (progn
  310.             (entdel ci)
  311.             (vl-cmdf "_.circle" "2P" "_end" (trans (car ptl) 0 1) "_tan" (trans (vlax-curve-getclosestpointto poly (car ptsints)) 0 1))
  312.             )
  313.         )
  314.         (if (and (= (length ptl) 1) (= (length ptsints) 2))
  315.             (progn
  316.             (entdel ci)
  317.             (vl-cmdf "_.circle" "3P" "_end" (trans (car ptl) 0 1) "_tan" (trans (vlax-curve-getclosestpointto poly (car ptsints)) 0 1) "_tan" (trans (vlax-curve-getclosestpointto poly (cadr ptsints)) 0 1))
  318.             )
  319.         )
  320.         (if (and (null ptl) (>= (length ptsints) 3))
  321.             (progn
  322.             (entdel ci)
  323.             (vl-cmdf "_.circle" "3P" "_tan" (trans (vlax-curve-getclosestpointto poly (car ptsints)) 0 1) "_tan" (trans (vlax-curve-getclosestpointto poly (cadr ptsints)) 0 1) "_tan" (trans (vlax-curve-getclosestpointto poly (caddr ptsints)) 0 1))
  324.             )
  325.         )
  326.         (if (and (null ptl) (= (length ptsints) 2))
  327.             (progn
  328.             (entdel ci)
  329.             (vl-cmdf "_.circle" "2P" "_tan" (trans (vlax-curve-getclosestpointto poly (car ptsints)) 0 1) "_tan" (trans (vlax-curve-getclosestpointto poly (cadr ptsints)) 0 1))
  330.             )
  331.         )
  332.         (command "_.ucs" "_P")
  333.         (setq ptl nil)
  334.       )
  335.       (command "_.ucs" "_P")
  336.     )
  337.   )
  338.   (*error* nil)
  339. )
  340.  

Regards, and many thanks to GP & GSLS(SS)...
« Last Edit: May 03, 2014, 08:02:51 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2126
  • Marko Ribar, architect
Re: =={challenge}==Find the maximum inscribed circle
« Reply #68 on: May 03, 2014, 05:05:46 AM »
In fact I've already founded example LWPOLYLINE where it fails... See attachment - so center point is wrong - algorithm by GSLS(SS) needs to be improved...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2126
  • Marko Ribar, architect
Re: =={challenge}==Find the maximum inscribed circle
« Reply #69 on: May 03, 2014, 07:32:42 AM »
I've implemented both algorithms and GP's and GSLS(SS)'s into single one... Posted LWPOLYLINE was solved, but I suppose both algorithms have their lacks in finding center point... So if GSLS(SS)'s fails then GP's is processed and if it also fails, then probably manual approach is desirable... Please inform me for any failures with this final version...

M.R.

Code - Auto/Visual Lisp: [Select]
  1. (defun c:ipls ( / *error* 2d-lw-pt GetIntersections GroupByNum interse1e2 MaximumInscribedCircle_p LWPoly->List grid_1 grid_2 Point_int grid+ Point_center MaximumInscribedCircle_p_GP Vert_poly_GP grid_1_GP grid_2_GP inside_p_GP grid+_GP center_p_GP adoc area len ape polys poly pl x e n i lst p dist ci ptse1e2 pts1 pts2 pts3 ptsints plpts ptl )
  2.  
  3.  
  4.   (defun *error* ( msg )
  5.     (if ape (setvar 'aperture ape))
  6.     (vla-endundomark adoc)
  7.     (if msg (prompt msg))
  8.     (princ)
  9.   )
  10.  
  11.   (defun 2d-lw-pt ( lst )
  12.     (if lst
  13.       (cons (list (car lst) (cadr lst)) (2d-lw-pt (cddr lst)))
  14.     ) ;_  if
  15.   )
  16.  
  17.   (defun GetIntersections ( obj1 obj2 )
  18.     (GroupByNum (vlax-invoke obj1 'IntersectWith obj2 acExtendNone) 3)
  19.   )
  20.  
  21.   (defun GroupByNum ( l n / r)
  22.     (if l
  23.       (cons
  24.         (reverse (repeat n (setq r (cons (car l) r) l (cdr l)) r))
  25.         (GroupByNum l n)
  26.       )
  27.     )
  28.   )
  29.  
  30.   (defun interse1e2 ( e1 e2 / lst )
  31.     (if (and e1 e2)
  32.       (setq lst (GetIntersections (vlax-ename->vla-object e1) (vlax-ename->vla-object e2)))
  33.     )
  34.     lst
  35.   )
  36.  
  37. ;****************************************************************************
  38. ;  Ritorna il centro del massimo cerchio inscritto in una polilinea          
  39. ;  Returns the center point of the maximum inscribed circle in a polyline    
  40. ;                    Author: Gian Paolo Cattaneo                            
  41.   (defun MaximumInscribedCircle_p_GP
  42.          ( obj gr1 gr2 rep_gr2 / POLY POLY_vl Dx Dy Lp ;List_vert_poly
  43.                                  list_p_int P_center step1 step2 pc pc_d)
  44.  
  45.       (setq step1 gr1) ;--> grid_1
  46.       (setq step2 gr2) ;--> grid_2
  47.       (setq POLY_vl obj)
  48.       (setq list_vert_poly (Vert_poly_GP))
  49.       (grid_1_GP)  
  50.       (inside_p_GP)
  51.       (grid+_GP)
  52.       (center_p_GP)
  53.       (repeat rep_gr2
  54.           (grid_2_GP)
  55.           (center_p_GP)
  56.       )
  57.       (setq dist pc_d);distanza dal poligono
  58.       pc
  59.   )
  60.  
  61. ; restituisce la lista dei vertici di una polilinea
  62. ; Returns a list of polyline vertices
  63.   (defun Vert_poly_GP (/ n_par pt Lv ) ;elev)
  64.       (setq n_par (fix (vlax-curve-getendparam POLY_vl)))
  65.       (repeat n_par
  66.           (setq pt (vlax-curve-getpointatparam POLY_vl (setq n_par (1- n_par))))
  67.           (setq Lv (cons pt Lv))
  68.           (if (= 1 (length Lv)) (setq elev (last pt)))
  69.           (if (/= (last pt) elev)
  70.               (progn
  71.                   (alert
  72.                       (strcat
  73.                           "Invalid Object Selected."
  74.                           "\nThe z coordinate must be the same for all vertices."
  75.                       )
  76.                   )
  77.                   (exit)
  78.               )
  79.           )
  80.       )
  81.       Lv
  82.   )
  83.  
  84. ; Restituisce una griglia di punti all'interno del getboundingbox della poly selezionata
  85. ; Returns a grid of points inside the BoundingBox of the selected poly
  86.   (defun grid_1_GP (/ P1_ P2_ n P> )
  87.       (vla-getboundingbox POLY_vl 'p1 'p2)
  88.       (setq P1_ (vlax-safearray->list p1))
  89.       (setq P2_ (vlax-safearray->list p2))
  90.       (setq P1_ (list (car P1_) (cadr P1_)))
  91.       (setq P2_ (list (car P2_) (cadr P2_)))
  92.       (setq Dx (/ (- (car P2_) (car P1_)) step1))
  93.       (setq Dy (/ (- (cadr P2_) (cadr P1_)) step1))
  94.       (setq n 0)
  95.       (setq P> P1_)
  96.       (setq Lp (list P1_))
  97.       (repeat (* (1+ step1) step1)
  98.           (setq P> (list (+ (car P>) Dx) (cadr P>)))
  99.           (setq Lp (cons P> Lp))
  100.           (setq n (1+ n))
  101.           (if (= n step1)
  102.               (progn
  103.                   (setq n 0)
  104.                   (setq P1_ (list (car P1_) (+ (cadr P1_) Dy)))
  105.                   (setq P> P1_)
  106.                   (setq Lp (cons P> Lp))
  107.               )
  108.           )
  109.       )
  110.       (setq Lp (cdr Lp))
  111.   )
  112.  
  113. ; Restituisce una griglia di punti intorno al punto centrale (provvisorio)
  114. ; Returns a grid of points around the center point (provisional)
  115.   (defun grid_2_GP (/ P1_ P> n)
  116.       (setq list_p_int nil)
  117.       (setq P1_ (list (- (car P_center) Dx) (- (cadr P_center) Dy)))
  118.       (setq Dx (/ (* 2 Dx) step2))
  119.       (setq Dy (/ (* 2 Dy) step2))
  120.       (setq n 0)
  121.       (setq P> P1_)
  122.       (setq list_p_int (list P1_))  
  123.       (repeat (* (1+ step2) step2)
  124.           (setq P> (list (+ (car P>) Dx) (cadr P>)))
  125.           (setq list_p_int (cons P> list_p_int))
  126.           (setq n (1+ n))
  127.           (if (= n step2)
  128.               (progn
  129.                   (setq n 0)
  130.                   (setq P1_ (list (car P1_) (+ (cadr P1_) Dy)))
  131.                   (setq P> P1_)
  132.                   (setq list_p_int (cons P> list_p_int))
  133.               )
  134.           )
  135.       )
  136.   )
  137.  
  138. ; restituisce la lista dei punti interni ad un poligono
  139. ; dati:  - lista coordinate dei punti -> Lp
  140. ;        - lista coordinate vertici poligono -> list_vert_poly
  141. ; Returns the list of points inside the polyline
  142.   (defun inside_p_GP (/ remote_p n Pr cont attr p# Pa Pa_ Pb)
  143.       (setq remote_p (list (car (getvar "extmax")) (* 1.1 (cadr (getvar "extmax")))))    
  144.       (setq list_p_int nil)
  145.       (foreach Pr Lp   
  146.           (setq cont -1)
  147.           (setq attr 0)
  148.           (setq p# nil)
  149.           (setq Pa (nth (setq cont (1+ cont)) list_vert_poly))
  150.           (setq Pa_ Pa)
  151.           (repeat (length list_vert_poly)
  152.               (setq Pb (nth (setq cont (1+ cont)) list_vert_poly))
  153.               (if (= cont (length list_vert_poly)) (setq Pb Pa_))
  154.               (setq P# (inters Pa Pb Pr remote_p))
  155.               (if (/= P# nil) (setq attr (1+ attr)))
  156.               (setq Pa Pb)
  157.           )
  158.           (if (> (rem attr 2) 0) (setq list_p_int (cons Pr list_p_int)))             
  159.       )
  160.   )
  161.  
  162. ; Infittisce la griglia inserendo altri punti
  163. ; nel centro delle diagonali tra i punti interni
  164. ; Increases the grid density
  165.   (defun grid+_GP (/ G+)
  166.       (setq G+
  167.           (mapcar '(lambda ( x ) (list (+ (car x) (/ Dx 2)) (+ (cadr x) (/ Dy 2)))) list_p_int)
  168.       )
  169.       (setq list_p_int (append G+ list_p_int))
  170.   )
  171.  
  172. ; Da una lista di punti restituisce quello pił lontano da un oggetto
  173. ; dati:  - lista dei punti -> list_p_int
  174. ;        - oggetto -> POLY_vl
  175. ; Returns the farthest point from the polyline
  176.   (defun center_p_GP (/ Pa n Pvic Dist)
  177.       (setq Dist 1e-6)
  178.       (setq P_center nil)
  179.       (foreach Pa list_p_int
  180.       (setq Pvic (vlax-curve-getClosestPointTo POLY_vl Pa))
  181.           (if (> (distance Pa Pvic) Dist)
  182.               (progn
  183.                   (setq P_center Pa)
  184.                   (setq Dist (distance Pa Pvic))
  185.               )
  186.           )
  187.       )
  188.       (setq pc P_center) ;punto centro cerchio
  189.       (setq pc_d Dist)   ;distanza dal poligono
  190.   )
  191.  
  192. ;****************************************************************************  
  193.  
  194. ;****************************************************************************
  195. ;  Ritorna il centro del massimo cerchio inscritto in una polilinea          
  196. ;  Returns the center point of the maximum inscribed circle in a polyline    
  197. ;                    Author: Gian Paolo Cattaneo
  198. ;  edited by GSLS(SS) 2012-8-5
  199. ;****************************************************************************                            
  200.   (defun MaximumInscribedCircle_p ( poly / list_vert_poly step1 step2 i r0 P_center )
  201.  
  202.       (setq step1 (max 10 (fix (/ len 0.4 (sqrt area))))) ;_--> grid_1      
  203.       (setq step2 10) ;_--> grid_2
  204.       (setq list_vert_poly (LWPoly->List POLY 10))      
  205.       (grid_1)
  206.       (Point_int)
  207.       (Point_center)
  208.       (setq i 0)
  209.       (while (and (> (- Dist R0) 1e-8) (< i 10))
  210.         (grid_2)
  211.         (Point_center)
  212.         (setq i (1+ i))
  213.       )
  214.       P_center
  215.   )
  216.  
  217. ;; Restituisce una griglia di punti all'interno del getboundingbox della poly selezionata
  218. ;; Returns a grid of points within the BoundingBox of the selected poly
  219.   (defun grid_1 (/ p1 p2 X1 Y1 l1)
  220.     (vla-getboundingbox (vlax-ename->vla-object POLY) 'p1 'p2)
  221.     (setq       p1 (vlax-safearray->list p1)
  222.           p2 (vlax-safearray->list p2)
  223.           p1 (list (car p1) (cadr p1))
  224.           p2 (list (car p2) (cadr p2))
  225.     )
  226.     (setq Dx (/ (- (car p2) (car p1)) step1))
  227.     (setq Dy (/ (- (cadr p2) (cadr p1)) step1))
  228.     (setq       Lp (list p1)
  229.           X1 (car p1)
  230.           Y1 (cadr p1)
  231.     )
  232.     (repeat step1
  233.       (setq Lp (cons (list (setq X1 (+ X1 Dx)) Y1) Lp))
  234.     )
  235.     (setq Lp (list Lp))
  236.     (repeat step1
  237.       (setq Lp (cons (mapcar (function (lambda (x)
  238.                  (list (car x) (+ (cadr x) Dy))
  239.                )
  240.            )
  241.            (car lp)
  242.          )
  243.          Lp
  244.          )
  245.       )
  246.     )
  247.     (setq Lp (apply (function append) Lp))
  248.   )
  249. ;; Restituisce una griglia di punti intorno al punto centrale (provvisorio)
  250. ;; Returns a grid of points around the center point (provisional)
  251.   (defun grid_2 (/ X1 Y1 P1)
  252.     (setq       list_p_int nil
  253.           X1       (- (car P_center) Dx)
  254.           Y1       (- (cadr P_center) Dy)
  255.           P1       (list X1 Y1)
  256.           Dx       (/ (* 2 Dx) step2)
  257.           Dy       (/ (* 2 Dy) step2)
  258.     )
  259.     (setq list_p_int (list P1))
  260.     (repeat step2
  261.       (setq list_p_int (cons (list (setq X1 (+ X1 Dx)) Y1) list_p_int))
  262.     )
  263.     (setq list_p_int (list list_p_int))
  264.     (repeat step2
  265.       (setq list_p_int
  266.        (cons (mapcar (function (lambda (x)
  267.                (list (car x) (+ (cadr x) Dy))
  268.              )
  269.          )
  270.          (car list_p_int)
  271.        )
  272.        list_p_int
  273.        )
  274.       )
  275.     )
  276.     (setq list_p_int (apply (function append) list_p_int))
  277.   )
  278. ;; restituisce la lista dei punti interni ad un poligono
  279. ;; dati:  - lista coordinate dei punti -> Lp
  280. ;;        - lista coordinate vertici poligono -> list_vert_poly
  281. ;; Returns the list of points inside the polyline
  282.   (defun Point_int ()
  283.     (setq       list_p_int
  284.      (vl-remove-if-not
  285.        (function
  286.          (lambda (pt)
  287.            ;_determine point in curve , use widding number
  288.            (equal
  289.              PI
  290.              (abs
  291.                (apply
  292.                  (function +)
  293.                  (mapcar (function (lambda (x y / a)
  294.                    (rem (- (angle pt x) (angle pt y)) PI)
  295.                        )
  296.                    )
  297.                    list_vert_poly
  298.                    (cdr list_vert_poly)
  299.                  )
  300.                )
  301.              )
  302.              1e-8
  303.            )
  304.          )
  305.        )
  306.        Lp
  307.      )
  308.     )
  309.   )
  310. ;; Infittisce la griglia inserendo altri punti
  311. ;; nel centro delle diagonali tra i punti interni
  312. ;; Insert points (interior) to increase the density of the grid
  313.   (defun grid+ (/ G+)
  314.     (setq       G+
  315.      (mapcar '(lambda (x)
  316.           (list (+ (car x) (/ Dx 2)) (+ (cadr x) (/ Dy 2)))
  317.         )
  318.        list_p_int
  319.      )
  320.     )
  321.     (setq list_p_int (append G+ list_p_int))
  322.   )
  323. ;; Da una lista di punti restituisce quello pił lontano da un oggetto
  324. ;; dati:  - lista dei punti -> list_p_int
  325. ;;        - oggetto -> POLY_vl
  326. ;; Returns the farthest point from the polyline
  327.   (defun Point_center (/ Pa Pvic)
  328.     (setq Dist 1e-6)
  329.     (foreach Pa list_p_int
  330.       (setq Pvic (vlax-curve-getClosestPointTo Poly Pa))
  331.       (if       (> (distance Pa Pvic) Dist)
  332.         (setq P_center Pa
  333.               R0             Dist
  334.               Dist     (distance Pa Pvic)
  335.         )
  336.       )
  337.     )
  338.   )
  339. ;;
  340.   (defun LWPoly->List (en acc / a b vetex bu p1 p2 l r ang an1 N)
  341.     ;;Acc --- 0 ~ 99
  342.     (setq ent (entget en))
  343.     (while (setq ent (member (assoc 10 ent) ent))
  344.       (setq b   (cons (cdar ent) b)
  345.             ent (member (assoc 42 ent) ent)
  346.             b   (cons (cdar ent) b)
  347.             ent (cdr ent)
  348.             vetex       (cons b vetex)
  349.             b   nil
  350.       )
  351.     )
  352.     (while vetex
  353.       (setq a   (car vetex)
  354.             vetex       (cdr vetex)
  355.             bu  (car a)
  356.             p1  (cadr a)
  357.       )
  358.       (if       l
  359.         (setq p2 (car l))
  360.         (setq p2 (cadr (last vetex))
  361.               l  (cons p2 l)
  362.         )
  363.       )
  364.       (if       (equal bu 0 1e-6)
  365.         (setq l (cons p1 l))
  366.         (progn
  367.           (setq ang (* 2 (atan bu))
  368.                 r         (/ (distance p1 p2)
  369.                        (* 2 (sin ang))
  370.                     )
  371.                 c         (polar p1
  372.                        (+ (angle p1 p2) (- (/ pi 2) ang))
  373.                     r
  374.                     )
  375.                 r         (abs r)
  376.                 ang (abs (* ang 2.0))
  377.                 N         (abs (fix (/ ang 0.0174532925199433)))
  378.                 N         (min N (1+ Acc))
  379.           )
  380.           (if (= N 0)
  381.             (setq l (cons p1 l))
  382.             (progn
  383.               (setq an1 (/ ang N)
  384.               ang (angle c p2)
  385.               )
  386.               (if       (not (minusp bu))
  387.                 (setq an1 (- an1))
  388.               )
  389.               (repeat (1- N)
  390.                 (setq ang       (+ ang an1)
  391.                 l       (cons (polar c ang r) l)
  392.                 )
  393.               )
  394.               (setq l (cons p1 l))
  395.             )
  396.           )
  397.         )
  398.       )
  399.     )
  400.     l
  401.   )
  402.  
  403.   (setq ape (getvar 'aperture))
  404.   (setvar 'aperture 10)
  405.   (command "_.ucs" "_W")
  406.   (if
  407.     (and
  408.       (princ "\nSelect a Closed LWPolylines")
  409.       (setq polys (ssget '((0 . "LWPOLYLINE") (-4 . "&=") (70 . 1))))
  410.     )
  411.     (progn
  412.       (setq i -1)
  413.       (while (setq poly (ssname polys (setq i (1+ i))))
  414.         (setq area (vlax-curve-getArea poly)
  415.               len (vlax-curve-getDistAtParam poly (vlax-curve-getEndParam poly))
  416.         )
  417.         (setq x (vla-copy (vlax-ename->vla-object poly)))
  418.         (setq n (vla-get-normal x))
  419.         (setq e (vla-get-elevation x))
  420.         (vla-put-normal x (vlax-3d-point 0. 0. 1.))
  421.         (vla-update x)
  422.         (setq p (MaximumInscribedCircle_p (vlax-vla-object->ename x)))
  423.         (setq p (list (car p) (cadr p)))
  424.         (setq pl (entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 2) '(70 . 0) (cons 38 e) (assoc 10 (entget (vlax-vla-object->ename x))) (cons 10 p) '(210 0.0 0.0 1.0))))
  425.         (vla-put-normal (vlax-ename->vla-object pl) n)
  426.         (vla-update (vlax-ename->vla-object pl))
  427.         (setq p (trans (vlax-curve-getendpoint pl) 0 poly))
  428.         (setq ci (entmakex (list '(0 . "CIRCLE") '(100 . "AcDbEntity") '(100 . "AcDbCircle") (cons 10 p) (cons 40 (+ dist 1e-2)) '(62 . 2) (assoc 210 (entget poly)))))
  429.         (entdel pl)
  430.         (setq ptse1e2 (vl-catch-all-apply 'interse1e2 (list poly ci)))
  431.         (if (/= (length ptse1e2) 6)
  432.           (progn
  433.             (entdel ci)
  434.             (setq p (MaximumInscribedCircle_p_GP x 250 25 5))
  435.             (setq p (list (car p) (cadr p)))
  436.             (setq pl (entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 2) '(70 . 0) (cons 38 e) (assoc 10 (entget (vlax-vla-object->ename x))) (cons 10 p) '(210 0.0 0.0 1.0))))
  437.             (vla-put-normal (vlax-ename->vla-object pl) n)
  438.             (vla-update (vlax-ename->vla-object pl))
  439.             (setq p (trans (vlax-curve-getendpoint pl) 0 poly))
  440.             (setq ci (entmakex (list '(0 . "CIRCLE") '(100 . "AcDbEntity") '(100 . "AcDbCircle") (cons 10 p) (cons 40 (+ dist 1e-2)) '(62 . 2) (assoc 210 (entget poly)))))
  441.             (entdel pl)
  442.             (setq ptse1e2 (vl-catch-all-apply 'interse1e2 (list poly ci)))
  443.           )
  444.         )
  445.         (entdel (vlax-vla-object->ename x))
  446.         (command "_.ucs" "_ZA" '(0.0 0.0 0.0) (trans (cdr (assoc 210 (entget poly))) 0 1 t))
  447.         (setq pts1 (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (car ptse1e2) (cadr ptse1e2)))
  448.         (setq pts2 (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (caddr ptse1e2) (cadddr ptse1e2)))
  449.         (setq pts3 (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (car (reverse ptse1e2)) (cadr (reverse ptse1e2))))
  450.         (setq ptse1e2 (list pts1 pts2 pts3))
  451.         (setq ptsints ptse1e2)
  452.         (setq plpts (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= (car x) 10)) (entget poly))))
  453.         (setq plpts (mapcar '(lambda ( x ) (list (car x) (cadr x) e)) plpts))
  454.         (setq plpts (mapcar '(lambda ( x ) (trans x poly 0)) plpts))
  455.         (foreach pt ptsints
  456.           (mapcar '(lambda ( x ) (if (equal pt x (/ len 40.0 (sqrt area))) (setq ptl (cons pt ptl)))) plpts)
  457.         )
  458.         (foreach pt ptl
  459.           (setq ptsints (vl-remove-if '(lambda ( x ) (equal x pt (/ len 16.0 (sqrt area)))) ptsints))
  460.         )
  461.         (if (>= (length ptl) 3)
  462.             (progn
  463.             (entdel ci)
  464.             (vl-cmdf "_.circle" "3P" "_end" (trans (car ptl) 0 1) "_end" (trans (cadr ptl) 0 1) "_end" (trans (caddr ptl) 0 1))
  465.             )
  466.         )
  467.         (if (and (= (length ptl) 2) (= (length ptsints) 0))
  468.             (progn
  469.             (entdel ci)
  470.             (vl-cmdf "_.circle" "3P" "_end" (trans (car ptl) 0 1) "_end" (trans (cadr ptl) 0 1))
  471.             )
  472.         )
  473.         (if (and (= (length ptl) 2) (= (length ptsints) 1))
  474.             (progn
  475.             (entdel ci)
  476.             (vl-cmdf "_.circle" "3P" "_end" (trans (car ptl) 0 1) "_end" (trans (cadr ptl) 0 1) "_tan" (trans (vlax-curve-getclosestpointto poly (car ptsints)) 0 1))
  477.             )
  478.         )
  479.         (if (and (= (length ptl) 1) (= (length ptsints) 1))
  480.             (progn
  481.             (entdel ci)
  482.             (vl-cmdf "_.circle" "2P" "_end" (trans (car ptl) 0 1) "_tan" (trans (vlax-curve-getclosestpointto poly (car ptsints)) 0 1))
  483.             )
  484.         )
  485.         (if (and (= (length ptl) 1) (= (length ptsints) 2))
  486.             (progn
  487.             (entdel ci)
  488.             (vl-cmdf "_.circle" "3P" "_end" (trans (car ptl) 0 1) "_tan" (trans (vlax-curve-getclosestpointto poly (car ptsints)) 0 1) "_tan" (trans (vlax-curve-getclosestpointto poly (cadr ptsints)) 0 1))
  489.             )
  490.         )
  491.         (if (and (null ptl) (>= (length ptsints) 3))
  492.             (progn
  493.             (entdel ci)
  494.             (vl-cmdf "_.circle" "3P" "_tan" (trans (vlax-curve-getclosestpointto poly (car ptsints)) 0 1) "_tan" (trans (vlax-curve-getclosestpointto poly (cadr ptsints)) 0 1) "_tan" (trans (vlax-curve-getclosestpointto poly (caddr ptsints)) 0 1))
  495.             )
  496.         )
  497.         (if (and (null ptl) (= (length ptsints) 2))
  498.             (progn
  499.             (entdel ci)
  500.             (vl-cmdf "_.circle" "2P" "_tan" (trans (vlax-curve-getclosestpointto poly (car ptsints)) 0 1) "_tan" (trans (vlax-curve-getclosestpointto poly (cadr ptsints)) 0 1))
  501.             )
  502.         )
  503.         (command "_.ucs" "_P")
  504.         (setq ptl nil)
  505.       )
  506.       (command "_.ucs" "_P")
  507.     )
  508.   )
  509.   (*error* nil)
  510. )
  511.  
« Last Edit: May 03, 2014, 01:16:27 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

chlh_jd

  • Guest
Re: =={challenge}==Find the maximum inscribed circle
« Reply #70 on: May 03, 2014, 11:40:38 AM »
Ribarm , you are always welcome .
Even now , I have not use this program before writting .
I'll test yours , after some time later .

ribarm

  • Water Moccasin
  • Posts: 2126
  • Marko Ribar, architect
Re: =={challenge}==Find the maximum inscribed circle
« Reply #71 on: May 05, 2014, 08:18:59 AM »
I've done some modifications again... Now I've shortened complete code to only GSLS(SS) variant... It should be fast if found 6 intersections with polyline and little larger circle... If not then it will proceed to process little slower - higher precision search with the same sub-functions, but with larger arguments supplied... Have checked for various cases with various lwpolylines and had no problems... My posted DWG was solved, and in situation where GP's variant searched wrong, now GSLS(SS) code was correct... This was lwpolyline Evgeniy posted as picture showing the problem - how would you determine direction of polyline (large arc above trimmed rectangle)... So here is my I hope last final version...

[EDIT : I've put slower search algorithm into comments - commented out complete paragraph - it should work now fast enough...]

[EDIT : I've removed slower search algorithm and put grid1=50 and grid2=50 - it should be fast enough...]

Also made small modifications to sub-functions... Evgeniy's example lwpolyline is still with some approximately solution...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:ipls ( / *error* GetIntersections GroupByNum interse1e2 MaximumInscribedCircle_p LWPoly->List grid_1 grid_2 Point_int grid+ Point_center adoc area len osm ape polys poly pl x e n i lst p dist ci ptse1e2 pts1 pts2 pts3 ptsints plpts ptl )
  2.  
  3.  
  4.   (defun *error* ( msg )
  5.     (if osm (setvar 'osmode osm))
  6.     (if ape (setvar 'aperture ape))
  7.     (vla-endundomark adoc)
  8.     (if msg (prompt msg))
  9.     (princ)
  10.   )
  11.  
  12.   (defun GetIntersections ( obj1 obj2 )
  13.     (GroupByNum (vlax-invoke obj1 'IntersectWith obj2 acExtendNone) 3)
  14.   )
  15.  
  16.   (defun GroupByNum ( l n / r)
  17.     (if l
  18.       (cons
  19.         (reverse (repeat n (setq r (cons (car l) r) l (cdr l)) r))
  20.         (GroupByNum l n)
  21.       )
  22.     )
  23.   )
  24.  
  25.   (defun interse1e2 ( e1 e2 / lst )
  26.     (if (and e1 e2)
  27.       (setq lst (GetIntersections (vlax-ename->vla-object e1) (vlax-ename->vla-object e2)))
  28.     )
  29.     lst
  30.   )
  31.  
  32. ;****************************************************************************
  33. ;  Ritorna il centro del massimo cerchio inscritto in una polilinea          
  34. ;  Returns the center point of the maximum inscribed circle in a polyline    
  35. ;                    Author: Gian Paolo Cattaneo
  36. ;  edited by GSLS(SS) 2012-8-5
  37. ;****************************************************************************                            
  38.   (defun MaximumInscribedCircle_p ( poly step1 step2 / list_vert_poly step1 step2 r0 P_center )
  39.  
  40.       (setq step1 step1) ;_--> grid_1
  41.       (setq step2 step2) ;_--> grid_2
  42.       (setq list_vert_poly (LWPoly->List POLY 10))      
  43.       (grid_1)
  44.       (Point_int)
  45.       (Point_center)
  46.       (while (> (- Dist R0) 1e-12)
  47.         (grid_2)
  48.         (Point_center)
  49.       )
  50.       P_center
  51.   )
  52.  
  53. ;; Restituisce una griglia di punti all'interno del getboundingbox della poly selezionata
  54. ;; Returns a grid of points within the BoundingBox of the selected poly
  55.   (defun grid_1 (/ p1 p2 X1 Y1 l1)
  56.     (vla-getboundingbox (vlax-ename->vla-object POLY) 'p1 'p2)
  57.     (setq p1 (vlax-safearray->list p1)
  58.           p2 (vlax-safearray->list p2)
  59.           p1 (list (car p1) (cadr p1))
  60.           p2 (list (car p2) (cadr p2))
  61.     )
  62.     (setq Dx (/ (- (car p2) (car p1)) step1))
  63.     (setq Dy (/ (- (cadr p2) (cadr p1)) step1))
  64.     (setq Lp (list p1)
  65.           X1 (car p1)
  66.           Y1 (cadr p1)
  67.     )
  68.     (repeat step1
  69.       (setq Lp (cons (list (setq X1 (+ X1 Dx)) Y1) Lp))
  70.     )
  71.     (setq Lp (list Lp))
  72.     (repeat step1
  73.       (setq Lp (cons (mapcar (function (lambda (x)
  74.                           (list (car x) (+ (cadr x) Dy))
  75.                           )
  76.                         )
  77.                         (car lp)
  78.                       )
  79.                       Lp
  80.                )
  81.       )
  82.     )
  83.     (setq Lp (apply (function append) Lp))
  84.   )
  85. ;; Restituisce una griglia di punti intorno al punto centrale (provvisorio)
  86. ;; Returns a grid of points around the center point (provisional)
  87.   (defun grid_2 (/ X1 Y1 P1)
  88.     (setq list_p_int nil
  89.           X1       (- (car P_center) (* 1.0 Dx))
  90.           Y1       (- (cadr P_center) (* 1.0 Dy))
  91.           P1       (list X1 Y1)
  92.           Dx       (/ (* 2.0 Dx) step2)
  93.           Dy       (/ (* 2.0 Dy) step2)
  94.     )
  95.     (setq list_p_int (list P1))
  96.     (repeat step2
  97.       (setq list_p_int (cons (list (setq X1 (+ X1 Dx)) Y1) list_p_int))
  98.     )
  99.     (setq list_p_int (list list_p_int))
  100.     (repeat step2
  101.       (setq list_p_int
  102.         (cons (mapcar (function (lambda (x)
  103.                 (list (car x) (+ (cadr x) Dy))
  104.                   )
  105.                 )
  106.                 (car list_p_int)
  107.               )
  108.               list_p_int
  109.         )
  110.       )
  111.     )
  112.     (setq list_p_int (apply (function append) list_p_int))
  113.   )
  114. ;; restituisce la lista dei punti interni ad un poligono
  115. ;; dati:  - lista coordinate dei punti -> Lp
  116. ;;        - lista coordinate vertici poligono -> list_vert_poly
  117. ;; Returns the list of points inside the polyline
  118.   (defun Point_int ()
  119.     (setq list_p_int
  120.       (vl-remove-if-not
  121.         (function
  122.           (lambda ( pt )
  123.             ;_determine point in curve , use widding number
  124.             (equal
  125.               PI
  126.               (abs
  127.                 (apply
  128.                   (function +)
  129.                   (mapcar (function (lambda ( x y )
  130.                     (rem (- (angle pt x) (angle pt y)) PI)
  131.                         )
  132.                     )
  133.                     list_vert_poly
  134.                     (cdr list_vert_poly)
  135.                   )
  136.                 )
  137.               )
  138.               1e-8
  139.             )
  140.           )
  141.         )
  142.         Lp
  143.       )
  144.     )
  145.   )
  146.   ;|
  147. ;; Infittisce la griglia inserendo altri punti
  148. ;; nel centro delle diagonali tra i punti interni
  149. ;; Insert points (interior) to increase the density of the grid
  150.   (defun grid+ (/ G+)
  151.     (setq G+
  152.      (mapcar '(lambda (x)
  153.           (list (+ (car x) (/ Dx 2)) (+ (cadr x) (/ Dy 2)))
  154.         )
  155.        list_p_int
  156.      )
  157.     )
  158.     (setq list_p_int (append G+ list_p_int))
  159.   )
  160.   |;
  161. ;; Da una lista di punti restituisce quello pił lontano da un oggetto
  162. ;; dati:  - lista dei punti -> list_p_int
  163. ;;        - oggetto -> POLY_vl
  164. ;; Returns the farthest point from the polyline
  165.   (defun Point_center (/ Pa Pvic)
  166.     (if (null Dist) (setq Dist 1e-6))
  167.     (foreach Pa list_p_int
  168.       (setq Pvic (vlax-curve-getClosestPointTo Poly Pa))
  169.       (if (> (distance Pa Pvic) Dist)
  170.         (setq P_center Pa
  171.               R0       Dist
  172.               Dist     (distance Pa Pvic)
  173.         )
  174.       )
  175.     )
  176.   )
  177. ;;
  178.   (defun LWPoly->List (en acc / a b vetex bu p1 p2 l r ang an1 N)
  179.     ;;Acc --- 0 ~ 99
  180.     (setq ent (entget en))
  181.     (while (setq ent (member (assoc 10 ent) ent))
  182.       (setq b   (cons (cdar ent) b)
  183.             ent (member (assoc 42 ent) ent)
  184.             b   (cons (cdar ent) b)
  185.             ent (cdr ent)
  186.             vetex       (cons b vetex)
  187.             b   nil
  188.       )
  189.     )
  190.     (while vetex
  191.       (setq a   (car vetex)
  192.             vetex       (cdr vetex)
  193.             bu  (car a)
  194.             p1  (cadr a)
  195.       )
  196.       (if l
  197.         (setq p2 (car l))
  198.         (setq p2 (cadr (last vetex))
  199.               l  (cons p2 l)
  200.         )
  201.       )
  202.       (if (equal bu 0 1e-6)
  203.         (setq l (cons p1 l))
  204.         (progn
  205.           (setq ang (* 2 (atan bu))
  206.                 r (/ (distance p1 p2)
  207.                      (* 2 (sin ang))
  208.                   )
  209.                 c (polar p1
  210.                     (+ (angle p1 p2) (- (/ pi 2) ang))
  211.                     r
  212.                   )
  213.                 r (abs r)
  214.                 ang (abs (* ang 2.0))
  215.                 N   (abs (fix (/ ang 0.0174532925199433)))
  216.                 N   (min N (1+ Acc))
  217.           )
  218.           (if (= N 0)
  219.             (setq l (cons p1 l))
  220.             (progn
  221.               (setq an1 (/ ang N)
  222.                     ang (angle c p2)
  223.               )
  224.               (if (not (minusp bu))
  225.                 (setq an1 (- an1))
  226.               )
  227.               (repeat (1- N)
  228.                 (setq ang (+ ang an1)
  229.                       l (cons (polar c ang r) l)
  230.                 )
  231.               )
  232.               (setq l (cons p1 l))
  233.             )
  234.           )
  235.         )
  236.       )
  237.     )
  238.     l
  239.   )
  240. ;****************************************************************************
  241. ;****************************************************************************
  242.   (setq osm (getvar 'osmode))
  243.   (setq ape (getvar 'aperture))
  244.   (setvar 'osmode 0)
  245.   (setvar 'aperture 25)
  246.   (command "_.ucs" "_W")
  247.   (if
  248.     (and
  249.       (princ "\nSelect closed lwpolyline(s)")
  250.       (setq polys (ssget '((0 . "LWPOLYLINE") (-4 . "&=") (70 . 1))))
  251.     )
  252.     (progn
  253.       (setq i -1)
  254.       (while (setq poly (ssname polys (setq i (1+ i))))
  255.         (setq area (vlax-curve-getArea poly)
  256.               len (vlax-curve-getDistAtParam poly (vlax-curve-getEndParam poly))
  257.         )
  258.         (setq x (vla-copy (vlax-ename->vla-object poly)))
  259.         (setq n (vla-get-normal x))
  260.         (setq e (vla-get-elevation x))
  261.         (vla-put-normal x (vlax-3d-point 0.0 0.0 1.0))
  262.         (vla-update x)
  263.         (setq p (MaximumInscribedCircle_p (vlax-vla-object->ename x) 50 50))
  264.         (setq p (list (car p) (cadr p)))
  265.         (setq pl (entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 2) '(70 . 0) (cons 38 e) (assoc 10 (entget (vlax-vla-object->ename x))) (cons 10 p) '(210 0.0 0.0 1.0))))
  266.         (vla-put-normal (vlax-ename->vla-object pl) n)
  267.         (vla-update (vlax-ename->vla-object pl))
  268.         (setq p (trans (vlax-curve-getendpoint pl) 0 poly))
  269.         (setq ci (entmakex (list '(0 . "CIRCLE") '(100 . "AcDbEntity") '(100 . "AcDbCircle") (cons 10 p) (cons 40 (+ dist 5e-5)) '(62 . 2) (assoc 210 (entget poly)))))
  270.         (entdel pl)
  271.         (setq ptse1e2 (vl-catch-all-apply 'interse1e2 (list poly ci)))
  272.         (entdel (vlax-vla-object->ename x))
  273.         (command "_.ucs" "_ZA" '(0.0 0.0 0.0) (trans (cdr (assoc 210 (entget poly))) 0 1 t))
  274.         (if (= (length ptse1e2) 6)
  275.           (progn
  276.             (setq pts1 (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (car ptse1e2) (cadr ptse1e2)))
  277.             (setq pts2 (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (caddr ptse1e2) (cadddr ptse1e2)))
  278.             (setq pts3 (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (car (reverse ptse1e2)) (cadr (reverse ptse1e2))))
  279.             (setq ptse1e2 (list pts1 pts2 pts3))
  280.             (setq ptsints ptse1e2)
  281.           )
  282.           (setq ptsints ptse1e2)
  283.         )
  284.         (setq plpts (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= (car x) 10)) (entget poly))))
  285.         (setq plpts (mapcar '(lambda ( x ) (list (car x) (cadr x) e)) plpts))
  286.         (setq plpts (mapcar '(lambda ( x ) (trans x poly 0)) plpts))
  287.         (foreach pt ptsints
  288.           (mapcar '(lambda ( x ) (if (equal pt x (/ len 40.0 (sqrt area))) (setq ptl (cons pt ptl)))) plpts)
  289.         )
  290.         (foreach pt ptl
  291.           (setq ptsints (vl-remove-if '(lambda ( x ) (equal x pt (/ len 16.0 (sqrt area)))) ptsints))
  292.         )
  293.         (setq ptl (acet-list-remove-duplicates ptl 1.0))
  294.         (setq ptsints (acet-list-remove-duplicates ptsints 1.0))
  295.         (if (>= (length ptl) 3)
  296.             (progn
  297.               (entdel ci)
  298.               (vl-cmdf "_.circle" "3P" "_end" (trans (car ptl) 0 1) "_end" (trans (cadr ptl) 0 1) "_end" (trans (caddr ptl) 0 1))
  299.             )
  300.         )
  301.         (if (and (= (length ptl) 2) (= (length ptsints) 0))
  302.             (progn
  303.               (entdel ci)
  304.               (if (equal (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (car ptl) (cadr ptl)) p 1e-4)
  305.                 (vl-cmdf "_.circle" "2P" "_end" (trans (car ptl) 0 1) "_end" (trans (cadr ptl) 0 1))
  306.                 (vl-cmdf "_.circle" "3P" "_end" (trans (car ptl) 0 1) "_end" (trans (cadr ptl) 0 1) "_tan" (trans (vlax-curve-getpointatparam poly (+ (min (vlax-curve-getparamatpoint poly (car ptl)) (vlax-curve-getparamatpoint poly (cadr ptl))) (/ (abs (- (vlax-curve-getparamatpoint poly (car ptl)) (vlax-curve-getparamatpoint poly (cadr ptl)))) 2.0))) 0 1))
  307.               )
  308.             )
  309.         )
  310.         (if (and (= (length ptl) 2) (= (length ptsints) 1))
  311.             (progn
  312.               (entdel ci)
  313.               (vl-cmdf "_.circle" "3P" "_end" (trans (car ptl) 0 1) "_end" (trans (cadr ptl) 0 1) "_tan" (trans (vlax-curve-getclosestpointto poly (car ptsints)) 0 1))
  314.             )
  315.         )
  316.         (if (and (= (length ptl) 1) (= (length ptsints) 1))
  317.             (progn
  318.               (entdel ci)
  319.               (vl-cmdf "_.circle" "2P" "_end" (trans (car ptl) 0 1) "_tan" (trans (vlax-curve-getclosestpointto poly (car ptsints)) 0 1))
  320.             )
  321.         )
  322.         (if (and (= (length ptl) 1) (= (length ptsints) 2))
  323.             (progn
  324.               (entdel ci)
  325.               (vl-cmdf "_.circle" "3P" "_end" (trans (car ptl) 0 1) "_tan" (trans (vlax-curve-getclosestpointto poly (car ptsints)) 0 1) "_tan" (trans (vlax-curve-getclosestpointto poly (cadr ptsints)) 0 1))
  326.             )
  327.         )
  328.         (if (and (null ptl) (>= (length ptsints) 3))
  329.             (progn
  330.               (entdel ci)
  331.               (vl-cmdf "_.circle" "3P" "_tan" (trans (vlax-curve-getclosestpointto poly (car ptsints)) 0 1) "_tan" (trans (vlax-curve-getclosestpointto poly (cadr ptsints)) 0 1) "_tan" (trans (vlax-curve-getclosestpointto poly (caddr ptsints)) 0 1))
  332.             )
  333.         )
  334.         (if (and (null ptl) (= (length ptsints) 2))
  335.             (progn
  336.               (entdel ci)
  337.               (vl-cmdf "_.circle" (trans p poly 1) (trans (vlax-curve-getclosestpointto poly (trans p poly 0)) 0 1))
  338.             )
  339.         )
  340.         (command "_.ucs" "_P")
  341.         (setq ptl nil dist nil)
  342.       )
  343.       (command "_.ucs" "_P")
  344.     )
  345.   )
  346.   (*error* nil)
  347. )
  348.  

Regards, M.R.
« Last Edit: May 07, 2014, 10:38:54 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2126
  • Marko Ribar, architect
Re: =={challenge}==Find the maximum inscribed circle
« Reply #72 on: May 05, 2014, 03:18:16 PM »
I have updated my version of Lee Mac's Smallest Circumscribed Circle (Minimum Enclosing Circle)...

You can download from this link :
http://www.cadtutor.net/forum/showthread.php?63541-Smallest-Circumscribing-Circle/page5&p=#49

M.R.
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2126
  • Marko Ribar, architect
Re: =={challenge}==Find the maximum inscribed circle
« Reply #73 on: May 06, 2014, 05:52:47 AM »
I have updated and optimized my last posted code... HTH, M.R.

Regards...
 :-)
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2126
  • Marko Ribar, architect
Re: =={challenge}==Find the maximum inscribed circle
« Reply #74 on: May 25, 2014, 04:52:50 AM »
I was absent for a while, and I decided to post GP's variant which I thought it was better - I use this code now...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:ipls ( / *error* GetIntersections GroupByNum interse1e2 MaximumInscribedCircle_p LM:LWPoly->List grid_1 grid_2 inside_p Point_center adoc area len osm ape polys poly pl x e n i lst p dist ci ptse1e2 pts1 pts2 pts3 ptsints plpts ptl )
  2.  
  3.  
  4.   (defun *error* ( msg )
  5.     (if osm (setvar 'osmode osm))
  6.     (if ape (setvar 'aperture ape))
  7.     (vla-endundomark adoc)
  8.     (if msg (prompt msg))
  9.     (princ)
  10.   )
  11.  
  12.   (defun GetIntersections ( obj1 obj2 )
  13.     (GroupByNum (vlax-invoke obj1 'IntersectWith obj2 acExtendNone) 3)
  14.   )
  15.  
  16.   (defun GroupByNum ( l n / r)
  17.     (if l
  18.       (cons
  19.         (reverse (repeat n (setq r (cons (car l) r) l (cdr l)) r))
  20.         (GroupByNum l n)
  21.       )
  22.     )
  23.   )
  24.  
  25.   (defun interse1e2 ( e1 e2 / lst )
  26.     (if (and e1 e2)
  27.       (setq lst (GetIntersections (vlax-ename->vla-object e1) (vlax-ename->vla-object e2)))
  28.     )
  29.     lst
  30.   )
  31.  
  32. ;****************************************************************************
  33. ;  Ritorna il centro del massimo cerchio inscritto in una polilinea          
  34. ;  Returns the center point of the maximum inscribed circle in a polyline    
  35. ;                    Author: Gian Paolo Cattaneo
  36. ;****************************************************************************
  37.   (defun MaximumInscribedCircle_p ( poly step1 step2 / list_vert_poly step1 step2 all_ins r0 P_center )
  38.  
  39.       (setq step1 step1) ;_--> grid_1
  40.       (setq step2 step2) ;_--> grid_2
  41.       (setq list_vert_poly (LM:LWPoly->List POLY 25))      
  42.       (grid_1)
  43.       (inside_p)
  44.       (Point_center)
  45.       (while (> (- Dist R0) 4e-13)
  46.         (grid_2)
  47.         (inside_p)
  48.         (Point_center)
  49.       )
  50.       P_center
  51.   )
  52.  
  53. ;; Restituisce una griglia di punti all'interno del getboundingbox della poly selezionata
  54. ;; Returns a grid of points within the BoundingBox of the selected poly
  55.   (defun grid_1 ( / p1 p2 X1 Y1 l1 )
  56.     (vla-getboundingbox (vlax-ename->vla-object POLY) 'p1 'p2)
  57.     (setq p1 (vlax-safearray->list p1)
  58.           p2 (vlax-safearray->list p2)
  59.           p1 (list (car p1) (cadr p1))
  60.           p2 (list (car p2) (cadr p2))
  61.     )
  62.     (setq Dx (/ (- (car p2) (car p1)) step1))
  63.     (setq Dy (/ (- (cadr p2) (cadr p1)) step1))
  64.     (setq Lp (list p1)
  65.           X1 (car p1)
  66.           Y1 (cadr p1)
  67.     )
  68.     (repeat step1
  69.       (setq Lp (cons (list (setq X1 (+ X1 Dx)) Y1) Lp))
  70.     )
  71.     (setq Lp (list Lp))
  72.     (repeat step1
  73.       (setq Lp (cons (mapcar (function (lambda (x)
  74.                           (list (car x) (+ (cadr x) Dy))
  75.                           )
  76.                         )
  77.                         (car lp)
  78.                       )
  79.                       Lp
  80.                )
  81.       )
  82.     )
  83.     (setq Lp (apply (function append) Lp))
  84.   )
  85. ;; Restituisce una griglia di punti intorno al punto centrale (provvisorio)
  86. ;; Returns a grid of points around the center point (provisional)
  87.   (defun grid_2 ( / X1 Y1 P1 )
  88.     (setq list_p_int nil
  89.           X1       (- (car P_center) (* 1.0 Dx (/ step1 4.0)))
  90.           Y1       (- (cadr P_center) (* 1.0 Dy (/ step1 4.0)))
  91.           P1       (list X1 Y1)
  92.           Dx       (/ (* 2.0 Dx (/ step1 4.0)) step2)
  93.           Dy       (/ (* 2.0 Dy (/ step1 4.0)) step2)
  94.     )
  95.     (setq list_p_int (list P1))
  96.     (repeat step2
  97.       (setq list_p_int (cons (list (setq X1 (+ X1 Dx)) Y1) list_p_int))
  98.     )
  99.     (setq list_p_int (list list_p_int))
  100.     (repeat step2
  101.       (setq list_p_int
  102.         (cons (mapcar (function (lambda (x)
  103.                 (list (car x) (+ (cadr x) Dy))
  104.                   )
  105.                 )
  106.                 (car list_p_int)
  107.               )
  108.               list_p_int
  109.         )
  110.       )
  111.     )
  112.     (setq list_p_int (apply (function append) list_p_int))
  113.     (setq step1 step2)
  114.   )
  115. ; restituisce la lista dei punti interni ad un poligono
  116. ; dati:  - lista coordinate dei punti -> Lp
  117. ;        - lista coordinate vertici poligono -> list_vert_poly
  118. ; Returns the list of points inside the polyline
  119.   (defun inside_p ( / remote_p n Pr cont attr p# Pa Pa_ Pb )
  120.       (setq remote_p (list (* 1.1 (car (getvar "extmax"))) (* 1.1 (cadr (getvar "extmax")))))
  121.       (if (not all_ins)
  122.           (progn
  123.               (setq list_p_int nil)
  124.               (foreach Pr Lp   
  125.                   (setq cont -1)
  126.                   (setq attr 0)
  127.                   (setq p# nil)
  128.                   (setq Pa (nth (setq cont (1+ cont)) list_vert_poly))
  129.                   (setq Pa_ Pa)
  130.                   (repeat (length list_vert_poly)
  131.                       (setq Pb (nth (setq cont (1+ cont)) list_vert_poly))
  132.                       (if (= cont (length list_vert_poly)) (setq Pb Pa_))
  133.                       (setq P# (inters Pa Pb Pr remote_p))
  134.                       (if (/= P# nil) (setq attr (1+ attr)))
  135.                       (setq Pa Pb)
  136.                   )
  137.                   (if (> (rem attr 2) 0) (setq list_p_int (cons Pr list_p_int)))             
  138.               )
  139.               (setq list_p_int (reverse list_p_int))
  140.               (if (vl-every '(lambda ( a b ) (equal a b 1e-8)) Lp list_p_int)
  141.                   (setq all_ins t)
  142.                   (setq all_ins nil)
  143.               )
  144.               (setq Lp list_p_int)
  145.           )
  146.       )
  147.   )
  148. ;; Da una lista di punti restituisce quello pił lontano da un oggetto
  149. ;; dati:  - lista dei punti -> list_p_int
  150. ;;        - oggetto -> POLY_vl
  151. ;; Returns the farthest point from the polyline
  152.   (defun Point_center ( / Pa Pvic )
  153.     (if (null Dist) (setq Dist 1e-6))
  154.     (foreach Pa list_p_int
  155.       (setq Pvic (vlax-curve-getClosestPointTo Poly Pa))
  156.       (if (> (distance Pa Pvic) Dist)
  157.         (setq P_center Pa
  158.               R0       Dist
  159.               Dist     (distance Pa Pvic)
  160.         )
  161.       )
  162.     )
  163.   )
  164. ;; LWPolyline to Point List  -  Lee Mac
  165. ;; Returns a list of points describing the supplied LWPolyline with each segment derived
  166.   (defun LM:LWPoly->List ( ent n / der di1 di2 inc lst par )
  167.       (vl-load-com)
  168.       (setq par 0)
  169.       (repeat (cdr (assoc 90 (entget ent)))
  170.           (if
  171.               (setq di1 (vlax-curve-getdistatparam ent par)
  172.                     di2 (vlax-curve-getdistatparam ent (1+ par))
  173.               )
  174.               (progn
  175.                   (setq inc (/ (- di2 di1) n))
  176.                   (while (< di1 di2)
  177.                       (setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
  178.                             di1 (+ di1 inc)
  179.                       )
  180.                   )
  181.                   (if (eq (vlax-curve-isclosed ent) nil)
  182.                       (progn
  183.                           (if (equal (vlax-curve-getpointatdist ent di1) (vlax-curve-getendpoint ent) 1e-8)
  184.                               (setq lst (cons (vlax-curve-getendpoint ent) lst))
  185.                           )
  186.                       )
  187.                   )
  188.               )
  189.           )
  190.           (setq par (1+ par))
  191.       )
  192.       (reverse lst)
  193.   )
  194. ;****************************************************************************
  195. ;****************************************************************************
  196.   (setq osm (getvar 'osmode))
  197.   (setq ape (getvar 'aperture))
  198.   (setvar 'osmode 0)
  199.   (setvar 'aperture 25)
  200.   (command "_.ucs" "_W")
  201.   (if
  202.     (and
  203.       (princ "\nSelect closed lwpolyline(s)")
  204.       (setq polys (ssget '((0 . "LWPOLYLINE") (-4 . "&=") (70 . 1))))
  205.     )
  206.     (progn
  207.       (setq i -1)
  208.       (while (setq poly (ssname polys (setq i (1+ i))))
  209.         (setq area (vlax-curve-getArea poly)
  210.               len (vlax-curve-getDistAtParam poly (vlax-curve-getEndParam poly))
  211.         )
  212.         (setq x (vla-copy (vlax-ename->vla-object poly)))
  213.         (setq n (vla-get-normal x))
  214.         (setq e (vla-get-elevation x))
  215.         (vla-put-normal x (vlax-3d-point 0.0 0.0 1.0))
  216.         (vla-update x)
  217.         (setq p (MaximumInscribedCircle_p (vlax-vla-object->ename x) 48 32))
  218.         (setq p (list (car p) (cadr p)))
  219.         (setq pl (entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 2) '(70 . 0) (cons 38 e) (assoc 10 (entget (vlax-vla-object->ename x))) (cons 10 p) '(210 0.0 0.0 1.0))))
  220.         (vla-put-normal (vlax-ename->vla-object pl) n)
  221.         (vla-update (vlax-ename->vla-object pl))
  222.         (setq p (trans (vlax-curve-getendpoint pl) 0 poly))
  223.         (setq ci (entmakex (list '(0 . "CIRCLE") '(100 . "AcDbEntity") '(100 . "AcDbCircle") (cons 10 p) (cons 40 (+ dist 1e-5)) '(62 . 2) (assoc 210 (entget poly)))))
  224.         (entdel pl)
  225.         (setq ptse1e2 (vl-catch-all-apply 'interse1e2 (list poly ci)))
  226.         (entdel (vlax-vla-object->ename x))
  227.         (command "_.ucs" "_ZA" '(0.0 0.0 0.0) (trans (cdr (assoc 210 (entget poly))) 0 1 t))
  228.         (if (= (length ptse1e2) 6)
  229.           (progn
  230.             (setq pts1 (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (car ptse1e2) (cadr ptse1e2)))
  231.             (setq pts2 (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (caddr ptse1e2) (cadddr ptse1e2)))
  232.             (setq pts3 (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (car (reverse ptse1e2)) (cadr (reverse ptse1e2))))
  233.             (setq ptse1e2 (list pts1 pts2 pts3))
  234.             (setq ptsints ptse1e2)
  235.           )
  236.           (setq ptsints ptse1e2)
  237.         )
  238.         (setq plpts (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= (car x) 10)) (entget poly))))
  239.         (setq plpts (mapcar '(lambda ( x ) (list (car x) (cadr x) e)) plpts))
  240.         (setq plpts (mapcar '(lambda ( x ) (trans x poly 0)) plpts))
  241.         (foreach pt ptsints
  242.           (mapcar '(lambda ( x ) (if (equal pt x (/ len 40.0 (sqrt area))) (setq ptl (cons pt ptl)))) plpts)
  243.         )
  244.         (foreach pt ptl
  245.           (setq ptsints (vl-remove-if '(lambda ( x ) (equal x pt (/ len 16.0 (sqrt area)))) ptsints))
  246.         )
  247.         (setq ptl (acet-list-remove-duplicates ptl 1.0))
  248.         (setq ptsints (acet-list-remove-duplicates ptsints 1.0))
  249.         (if (>= (length ptl) 3)
  250.             (progn
  251.               (entdel ci)
  252.               (vl-cmdf "_.circle" "3P" "_end" (trans (car ptl) 0 1) "_end" (trans (cadr ptl) 0 1) "_end" (trans (caddr ptl) 0 1))
  253.             )
  254.         )
  255.         (if (and (= (length ptl) 2) (= (length ptsints) 0))
  256.             (progn
  257.               (entdel ci)
  258.               (if (equal (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (car ptl) (cadr ptl)) p 1e-4)
  259.                 (vl-cmdf "_.circle" "2P" "_end" (trans (car ptl) 0 1) "_end" (trans (cadr ptl) 0 1))
  260.                 (vl-cmdf "_.circle" "3P" "_end" (trans (car ptl) 0 1) "_end" (trans (cadr ptl) 0 1) "_tan" (trans (vlax-curve-getpointatparam poly (+ (min (vlax-curve-getparamatpoint poly (car ptl)) (vlax-curve-getparamatpoint poly (cadr ptl))) (/ (abs (- (vlax-curve-getparamatpoint poly (car ptl)) (vlax-curve-getparamatpoint poly (cadr ptl)))) 2.0))) 0 1))
  261.               )
  262.             )
  263.         )
  264.         (if (and (= (length ptl) 2) (= (length ptsints) 1))
  265.             (progn
  266.               (entdel ci)
  267.               (vl-cmdf "_.circle" "3P" "_end" (trans (car ptl) 0 1) "_end" (trans (cadr ptl) 0 1) "_tan" (trans (vlax-curve-getclosestpointto poly (car ptsints)) 0 1))
  268.             )
  269.         )
  270.         (if (and (= (length ptl) 1) (= (length ptsints) 1))
  271.             (progn
  272.               (entdel ci)
  273.               (vl-cmdf "_.circle" "2P" "_end" (trans (car ptl) 0 1) "_tan" (trans (vlax-curve-getclosestpointto poly (car ptsints)) 0 1))
  274.             )
  275.         )
  276.         (if (and (= (length ptl) 1) (= (length ptsints) 2))
  277.             (progn
  278.               (entdel ci)
  279.               (vl-cmdf "_.circle" "3P" "_end" (trans (car ptl) 0 1) "_tan" (trans (vlax-curve-getclosestpointto poly (car ptsints)) 0 1) "_tan" (trans (vlax-curve-getclosestpointto poly (cadr ptsints)) 0 1))
  280.             )
  281.         )
  282.         (if (and (null ptl) (>= (length ptsints) 3))
  283.             (progn
  284.               (entdel ci)
  285.               (vl-cmdf "_.circle" "3P" "_tan" (trans (vlax-curve-getclosestpointto poly (car ptsints)) 0 1) "_tan" (trans (vlax-curve-getclosestpointto poly (cadr ptsints)) 0 1) "_tan" (trans (vlax-curve-getclosestpointto poly (caddr ptsints)) 0 1))
  286.             )
  287.         )
  288.         (if (and (null ptl) (= (length ptsints) 2))
  289.             (progn
  290.               (entdel ci)
  291.               (vl-cmdf "_.circle" (trans p poly 1) (trans (vlax-curve-getclosestpointto poly (trans p poly 0)) 0 1))
  292.             )
  293.         )
  294.         (command "_.ucs" "_P")
  295.         (setq ptl nil dist nil)
  296.       )
  297.       (command "_.ucs" "_P")
  298.     )
  299.   )
  300.   (*error* nil)
  301. )
  302.  
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube