### Author Topic: =={challenge}==Find the maximum inscribed circle  (Read 14489 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: 2334
• 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))
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))
71.     (setq       Lp (list p1)
72.           X1 (car 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.          (lambda (pt)
129.            ;_determine point in curve , use widding number
130.              PI
131.              (abs
132.                  (function +)
133.                  (mapcar (function (lambda (x y / a)
134.                    (rem (- (angle pt x) (angle pt y)) PI)
135.                        )
136.                    )
137.                    list_vert_poly
138.                    (cdr list_vert_poly)
139.                  )
140.                )
141.              )
142.              1e-8
143.            )
144.          )
145.        )
146.        Lp
147.      )
148.     )
149.   )
150. ;; Infittisce la griglia inserendo altri punti
151. ;; nel centro delle diagonali tra i punti interni
152. ;; Insert points (interior) to increase the density of the grid
153.   (defun grid+ (/ G+)
154.     (setq       G+
155.      (mapcar '(lambda (x)
156.           (list (+ (car x) (/ Dx 2)) (+ (cadr x) (/ Dy 2)))
157.         )
158.        list_p_int
159.      )
160.     )
161.     (setq list_p_int (append G+ list_p_int))
162.   )
163. ;; Da una lista di punti restituisce quello pił lontano da un oggetto
164. ;; dati:  - lista dei punti -> list_p_int
165. ;;        - oggetto -> POLY_vl
166. ;; Returns the farthest point from the polyline
167.   (defun Point_center (/ Pa Pvic)
168.     (setq Dist 1e-6)
169.     (foreach Pa list_p_int
170.       (setq Pvic (vlax-curve-getClosestPointTo Poly Pa))
171.       (if       (> (distance Pa Pvic) Dist)
172.         (setq P_center Pa
173.               R0             Dist
174.               Dist     (distance Pa Pvic)
175.         )
176.       )
177.     )
178.   )
179. ;;
180.   (defun LWPoly->List (en acc / a b vetex bu p1 p2 l r ang an1 N)
181.     ;;Acc --- 0 ~ 99
182.     (setq ent (entget en))
183.     (while (setq ent (member (assoc 10 ent) ent))
184.       (setq b   (cons (cdar ent) b)
185.             ent (member (assoc 42 ent) ent)
186.             b   (cons (cdar ent) b)
187.             ent (cdr ent)
188.             vetex       (cons b vetex)
189.             b   nil
190.       )
191.     )
192.     (while vetex
193.       (setq a   (car vetex)
194.             vetex       (cdr vetex)
195.             bu  (car a)
197.       )
198.       (if       l
199.         (setq p2 (car l))
200.         (setq p2 (cadr (last vetex))
201.               l  (cons p2 l)
202.         )
203.       )
204.       (if       (equal bu 0 1e-6)
205.         (setq l (cons p1 l))
206.           (setq ang (* 2 (atan bu))
207.                 r         (/ (distance p1 p2)
208.                        (* 2 (sin ang))
209.                     )
210.                 c         (polar p1
211.                        (+ (angle p1 p2) (- (/ pi 2) ang))
212.                     r
213.                     )
214.                 r         (abs r)
215.                 ang (abs (* ang 2.0))
216.                 N         (abs (fix (/ ang 0.0174532925199433)))
217.                 N         (min N (1+ Acc))
218.           )
219.           (if (= N 0)
220.             (setq l (cons p1 l))
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.   (setq ape (getvar 'aperture))
242.   (setvar 'aperture 10)
243.   (command "_.ucs" "_W")
244.   (if
245.     (and
246.       (princ "\nSelect a Closed LWPolylines")
247.       (setq polys (ssget '((0 . "LWPOLYLINE")(-4 . "&=")(70 . 1))))
248.     )
249.       (setq i -1)
250.       (while (setq poly (ssname polys (setq i (1+ i))))
251.         (setq area (vlax-curve-getArea poly)
252.               len (vlax-curve-getDistAtParam poly (vlax-curve-getEndParam poly))
253.         )
254.         (setq x (vla-copy (vlax-ename->vla-object poly)))
255.         (setq n (vla-get-normal x))
256.         (setq e (vla-get-elevation x))
257.         (vla-put-normal x (vlax-3d-point 0. 0. 1.))
258.         (vla-update x)
259.         (setq p (MaximumInscribedCircle_p (vlax-vla-object->ename x)))
260.         (setq p (list (car p) (cadr p)))
261.         (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))))
262.         (vla-put-normal (vlax-ename->vla-object pl) n)
263.         (vla-update (vlax-ename->vla-object pl))
264.         (setq p (trans (vlax-curve-getendpoint pl) 0 poly))
265.         (setq ci (entmakex (list '(0 . "CIRCLE") '(100 . "AcDbEntity") '(100 . "AcDbCircle") (cons 10 p) (cons 40 (+ dist 1e-3)) '(62 . 2) (assoc 210 (entget poly)))))
266.         (entdel pl)
267.         (entdel (vlax-vla-object->ename x))
268.         (setq ptse1e2 (vl-catch-all-apply 'interse1e2 (list poly ci)))
269.         (command "_.ucs" "_ZA" '(0.0 0.0 0.0) (trans (cdr (assoc 210 (entget poly))) 0 1 t))
270.         (setq pts1 (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (car ptse1e2) (cadr ptse1e2)))
271.         (setq pts2 (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (caddr ptse1e2) (cadddr ptse1e2)))
272.         (setq pts3 (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (car (reverse ptse1e2)) (cadr (reverse ptse1e2))))
273.         (setq ptse1e2 (list pts1 pts2 pts3))
274.         (setq ptsints ptse1e2)
275.         (setq plpts (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= (car x) 10)) (entget poly))))
276.         (setq plpts (mapcar '(lambda ( x ) (list (car x) (cadr x) e)) plpts))
277.         (setq plpts (mapcar '(lambda ( x ) (trans x poly 0)) plpts))
278.         (foreach pt ptsints
279.           (mapcar '(lambda ( x ) (if (equal pt x (/ len 40.0 (sqrt area))) (setq ptl (cons pt ptl)))) plpts)
280.         )
281.         (foreach pt ptl
282.           (setq ptsints (vl-remove-if '(lambda ( x ) (equal x pt (/ len 16.0 (sqrt area)))) ptsints))
283.         )
284.         (if (>= (length ptl) 3)
285.             (entdel ci)
286.             (vl-cmdf "_.circle" "3P" "_end" (trans (car ptl) 0 1) "_end" (trans (cadr ptl) 0 1) "_end" (trans (caddr ptl) 0 1))
287.             )
288.         )
289.         (if (and (= (length ptl) 2) (= (length ptsints) 0))
290.             (entdel ci)
291.             (vl-cmdf "_.circle" "3P" "_end" (trans (car ptl) 0 1) "_end" (trans (cadr ptl) 0 1))
292.             )
293.         )
294.         (if (and (= (length ptl) 2) (= (length ptsints) 1))
295.             (entdel ci)
296.             (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))
297.             )
298.         )
299.         (if (and (= (length ptl) 1) (= (length ptsints) 1))
300.             (entdel ci)
301.             (vl-cmdf "_.circle" "2P" "_end" (trans (car ptl) 0 1) "_tan" (trans (vlax-curve-getclosestpointto poly (car ptsints)) 0 1))
302.             )
303.         )
304.         (if (and (= (length ptl) 1) (= (length ptsints) 2))
305.             (entdel ci)
306.             (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))
307.             )
308.         )
309.         (if (and (null ptl) (>= (length ptsints) 3))
310.             (entdel ci)
311.             (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))
312.             )
313.         )
314.         (if (and (null ptl) (= (length ptsints) 2))
315.             (entdel ci)
316.             (vl-cmdf "_.circle" "2P" "_tan" (trans (vlax-curve-getclosestpointto poly (car ptsints)) 0 1) "_tan" (trans (vlax-curve-getclosestpointto poly (cadr ptsints)) 0 1))
317.             )
318.         )
319.         (command "_.ucs" "_P")
320.         (setq ptl nil)
321.       )
322.       (command "_.ucs" "_P")
323.     )
324.   )
325.   (*error* nil)
326. )
327.

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)

#### ribarm

• Water Moccasin
• Posts: 2334
• 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)

#### ribarm

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

#### 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: 2334
• 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))
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))
64.     (setq Lp (list p1)
65.           X1 (car 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.           (lambda ( pt )
122.             ;_determine point in curve , use widding number
123.               PI
124.               (abs
125.                   (function +)
126.                   (mapcar (function (lambda ( x y )
127.                     (rem (- (angle pt x) (angle pt y)) PI)
128.                         )
129.                     )
130.                     list_vert_poly
131.                     (cdr list_vert_poly)
132.                   )
133.                 )
134.               )
135.               1e-8
136.             )
137.           )
138.         )
139.         Lp
140.       )
141.     )
142.   )
143.   ;|
144. ;; Infittisce la griglia inserendo altri punti
145. ;; nel centro delle diagonali tra i punti interni
146. ;; Insert points (interior) to increase the density of the grid
147.   (defun grid+ (/ G+)
148.     (setq G+
149.      (mapcar '(lambda (x)
150.           (list (+ (car x) (/ Dx 2)) (+ (cadr x) (/ Dy 2)))
151.         )
152.        list_p_int
153.      )
154.     )
155.     (setq list_p_int (append G+ list_p_int))
156.   )
157.   |;
158. ;; Da una lista di punti restituisce quello pił lontano da un oggetto
159. ;; dati:  - lista dei punti -> list_p_int
160. ;;        - oggetto -> POLY_vl
161. ;; Returns the farthest point from the polyline
162.   (defun Point_center (/ Pa Pvic)
163.     (if (null Dist) (setq Dist 1e-6))
164.     (foreach Pa list_p_int
165.       (setq Pvic (vlax-curve-getClosestPointTo Poly Pa))
166.       (if (> (distance Pa Pvic) Dist)
167.         (setq P_center Pa
168.               R0       Dist
169.               Dist     (distance Pa Pvic)
170.         )
171.       )
172.     )
173.   )
174. ;;
175.   (defun LWPoly->List (en acc / a b vetex bu p1 p2 l r ang an1 N)
176.     ;;Acc --- 0 ~ 99
177.     (setq ent (entget en))
178.     (while (setq ent (member (assoc 10 ent) ent))
179.       (setq b   (cons (cdar ent) b)
180.             ent (member (assoc 42 ent) ent)
181.             b   (cons (cdar ent) b)
182.             ent (cdr ent)
183.             vetex       (cons b vetex)
184.             b   nil
185.       )
186.     )
187.     (while vetex
188.       (setq a   (car vetex)
189.             vetex       (cdr vetex)
190.             bu  (car a)
192.       )
193.       (if l
194.         (setq p2 (car l))
195.         (setq p2 (cadr (last vetex))
196.               l  (cons p2 l)
197.         )
198.       )
199.       (if (equal bu 0 1e-6)
200.         (setq l (cons p1 l))
201.           (setq ang (* 2 (atan bu))
202.                 r (/ (distance p1 p2)
203.                      (* 2 (sin ang))
204.                   )
205.                 c (polar p1
206.                     (+ (angle p1 p2) (- (/ pi 2) ang))
207.                     r
208.                   )
209.                 r (abs r)
210.                 ang (abs (* ang 2.0))
211.                 N   (abs (fix (/ ang 0.0174532925199433)))
212.                 N   (min N (1+ Acc))
213.           )
214.           (if (= N 0)
215.             (setq l (cons p1 l))
216.               (setq an1 (/ ang N)
217.                     ang (angle c p2)
218.               )
219.               (if (not (minusp bu))
220.                 (setq an1 (- an1))
221.               )
222.               (repeat (1- N)
223.                 (setq ang (+ ang an1)
224.                       l (cons (polar c ang r) l)
225.                 )
226.               )
227.               (setq l (cons p1 l))
228.             )
229.           )
230.         )
231.       )
232.     )
233.     l
234.   )
235. ;****************************************************************************
236. ;****************************************************************************
237.   (setq osm (getvar 'osmode))
238.   (setq ape (getvar 'aperture))
239.   (setvar 'osmode 0)
240.   (setvar 'aperture 25)
241.   (command "_.ucs" "_W")
242.   (if
243.     (and
244.       (princ "\nSelect closed lwpolyline(s)")
245.       (setq polys (ssget '((0 . "LWPOLYLINE") (-4 . "&=") (70 . 1))))
246.     )
247.       (setq i -1)
248.       (while (setq poly (ssname polys (setq i (1+ i))))
249.         (setq area (vlax-curve-getArea poly)
250.               len (vlax-curve-getDistAtParam poly (vlax-curve-getEndParam poly))
251.         )
252.         (setq x (vla-copy (vlax-ename->vla-object poly)))
253.         (setq n (vla-get-normal x))
254.         (setq e (vla-get-elevation x))
255.         (vla-put-normal x (vlax-3d-point 0.0 0.0 1.0))
256.         (vla-update x)
257.         (setq p (MaximumInscribedCircle_p (vlax-vla-object->ename x) 50 50))
258.         (setq p (list (car p) (cadr p)))
259.         (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))))
260.         (vla-put-normal (vlax-ename->vla-object pl) n)
261.         (vla-update (vlax-ename->vla-object pl))
262.         (setq p (trans (vlax-curve-getendpoint pl) 0 poly))
263.         (setq ci (entmakex (list '(0 . "CIRCLE") '(100 . "AcDbEntity") '(100 . "AcDbCircle") (cons 10 p) (cons 40 (+ dist 5e-5)) '(62 . 2) (assoc 210 (entget poly)))))
264.         (entdel pl)
265.         (setq ptse1e2 (vl-catch-all-apply 'interse1e2 (list poly ci)))
266.         (entdel (vlax-vla-object->ename x))
267.         (command "_.ucs" "_ZA" '(0.0 0.0 0.0) (trans (cdr (assoc 210 (entget poly))) 0 1 t))
268.         (if (= (length ptse1e2) 6)
269.             (setq pts1 (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (car ptse1e2) (cadr ptse1e2)))
270.             (setq pts2 (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (caddr ptse1e2) (cadddr ptse1e2)))
271.             (setq pts3 (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (car (reverse ptse1e2)) (cadr (reverse ptse1e2))))
272.             (setq ptse1e2 (list pts1 pts2 pts3))
273.             (setq ptsints ptse1e2)
274.           )
275.           (setq ptsints ptse1e2)
276.         )
277.         (setq plpts (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= (car x) 10)) (entget poly))))
278.         (setq plpts (mapcar '(lambda ( x ) (list (car x) (cadr x) e)) plpts))
279.         (setq plpts (mapcar '(lambda ( x ) (trans x poly 0)) plpts))
280.         (foreach pt ptsints
281.           (mapcar '(lambda ( x ) (if (equal pt x (/ len 40.0 (sqrt area))) (setq ptl (cons pt ptl)))) plpts)
282.         )
283.         (foreach pt ptl
284.           (setq ptsints (vl-remove-if '(lambda ( x ) (equal x pt (/ len 16.0 (sqrt area)))) ptsints))
285.         )
286.         (setq ptl (acet-list-remove-duplicates ptl 1.0))
287.         (setq ptsints (acet-list-remove-duplicates ptsints 1.0))
288.         (if (>= (length ptl) 3)
289.               (entdel ci)
290.               (vl-cmdf "_.circle" "3P" "_end" (trans (car ptl) 0 1) "_end" (trans (cadr ptl) 0 1) "_end" (trans (caddr ptl) 0 1))
291.             )
292.         )
293.         (if (and (= (length ptl) 2) (= (length ptsints) 0))
294.               (entdel ci)
295.               (if (equal (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (car ptl) (cadr ptl)) p 1e-4)
296.                 (vl-cmdf "_.circle" "2P" "_end" (trans (car ptl) 0 1) "_end" (trans (cadr ptl) 0 1))
297.                 (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))
298.               )
299.             )
300.         )
301.         (if (and (= (length ptl) 2) (= (length ptsints) 1))
302.               (entdel ci)
303.               (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))
304.             )
305.         )
306.         (if (and (= (length ptl) 1) (= (length ptsints) 1))
307.               (entdel ci)
308.               (vl-cmdf "_.circle" "2P" "_end" (trans (car ptl) 0 1) "_tan" (trans (vlax-curve-getclosestpointto poly (car ptsints)) 0 1))
309.             )
310.         )
311.         (if (and (= (length ptl) 1) (= (length ptsints) 2))
312.               (entdel ci)
313.               (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))
314.             )
315.         )
316.         (if (and (null ptl) (>= (length ptsints) 3))
317.               (entdel ci)
318.               (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))
319.             )
320.         )
321.         (if (and (null ptl) (= (length ptsints) 2))
322.               (entdel ci)
323.               (vl-cmdf "_.circle" (trans p poly 1) (trans (vlax-curve-getclosestpointto poly (trans p poly 0)) 0 1))
324.             )
325.         )
326.         (command "_.ucs" "_P")
327.         (setq ptl nil dist nil)
328.       )
329.       (command "_.ucs" "_P")
330.     )
331.   )
332.   (*error* nil)
333. )
334.

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

#### ribarm

• Water Moccasin
• Posts: 2334
• 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)...

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

#### ribarm

• Water Moccasin
• Posts: 2334
• 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)

#### ribarm

• Water Moccasin
• Posts: 2334
• 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))
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))
64.     (setq Lp (list p1)
65.           X1 (car 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.               (setq list_p_int nil)
123.               (foreach Pr Lp
124.                   (setq cont -1)
125.                   (setq attr 0)
126.                   (setq p# nil)
127.                   (setq Pa (nth (setq cont (1+ cont)) list_vert_poly))
128.                   (setq Pa_ Pa)
129.                   (repeat (length list_vert_poly)
130.                       (setq Pb (nth (setq cont (1+ cont)) list_vert_poly))
131.                       (if (= cont (length list_vert_poly)) (setq Pb Pa_))
132.                       (setq P# (inters Pa Pb Pr remote_p))
133.                       (if (/= P# nil) (setq attr (1+ attr)))
134.                       (setq Pa Pb)
135.                   )
136.                   (if (> (rem attr 2) 0) (setq list_p_int (cons Pr list_p_int)))
137.               )
138.               (setq list_p_int (reverse list_p_int))
139.               (if (vl-every '(lambda ( a b ) (equal a b 1e-8)) Lp list_p_int)
140.                   (setq all_ins t)
141.                   (setq all_ins nil)
142.               )
143.               (setq Lp list_p_int)
144.           )
145.       )
146.   )
147. ;; Da una lista di punti restituisce quello pił lontano da un oggetto
148. ;; dati:  - lista dei punti -> list_p_int
149. ;;        - oggetto -> POLY_vl
150. ;; Returns the farthest point from the polyline
151.   (defun Point_center ( / Pa Pvic )
152.     (if (null Dist) (setq Dist 1e-6))
153.     (foreach Pa list_p_int
154.       (setq Pvic (vlax-curve-getClosestPointTo Poly Pa))
155.       (if (> (distance Pa Pvic) Dist)
156.         (setq P_center Pa
157.               R0       Dist
158.               Dist     (distance Pa Pvic)
159.         )
160.       )
161.     )
162.   )
163. ;; LWPolyline to Point List  -  Lee Mac
164. ;; Returns a list of points describing the supplied LWPolyline with each segment derived
165.   (defun LM:LWPoly->List ( ent n / der di1 di2 inc lst par )
166.       (setq par 0)
167.       (repeat (cdr (assoc 90 (entget ent)))
168.           (if
169.               (setq di1 (vlax-curve-getdistatparam ent par)
170.                     di2 (vlax-curve-getdistatparam ent (1+ par))
171.               )
172.                   (setq inc (/ (- di2 di1) n))
173.                   (while (< di1 di2)
174.                       (setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
175.                             di1 (+ di1 inc)
176.                       )
177.                   )
178.                   (if (eq (vlax-curve-isclosed ent) nil)
179.                           (if (equal (vlax-curve-getpointatdist ent di1) (vlax-curve-getendpoint ent) 1e-8)
180.                               (setq lst (cons (vlax-curve-getendpoint ent) lst))
181.                           )
182.                       )
183.                   )
184.               )
185.           )
186.           (setq par (1+ par))
187.       )
188.       (reverse lst)
189.   )
190. ;****************************************************************************
191. ;****************************************************************************
192.   (setq osm (getvar 'osmode))
193.   (setq ape (getvar 'aperture))
194.   (setvar 'osmode 0)
195.   (setvar 'aperture 25)
196.   (command "_.ucs" "_W")
197.   (if
198.     (and
199.       (princ "\nSelect closed lwpolyline(s)")
200.       (setq polys (ssget '((0 . "LWPOLYLINE") (-4 . "&=") (70 . 1))))
201.     )
202.       (setq i -1)
203.       (while (setq poly (ssname polys (setq i (1+ i))))
204.         (setq area (vlax-curve-getArea poly)
205.               len (vlax-curve-getDistAtParam poly (vlax-curve-getEndParam poly))
206.         )
207.         (setq x (vla-copy (vlax-ename->vla-object poly)))
208.         (setq n (vla-get-normal x))
209.         (setq e (vla-get-elevation x))
210.         (vla-put-normal x (vlax-3d-point 0.0 0.0 1.0))
211.         (vla-update x)
212.         (setq p (MaximumInscribedCircle_p (vlax-vla-object->ename x) 48 32))
213.         (setq p (list (car p) (cadr p)))
214.         (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))))
215.         (vla-put-normal (vlax-ename->vla-object pl) n)
216.         (vla-update (vlax-ename->vla-object pl))
217.         (setq p (trans (vlax-curve-getendpoint pl) 0 poly))
218.         (setq ci (entmakex (list '(0 . "CIRCLE") '(100 . "AcDbEntity") '(100 . "AcDbCircle") (cons 10 p) (cons 40 (+ dist 1e-5)) '(62 . 2) (assoc 210 (entget poly)))))
219.         (entdel pl)
220.         (setq ptse1e2 (vl-catch-all-apply 'interse1e2 (list poly ci)))
221.         (entdel (vlax-vla-object->ename x))
222.         (command "_.ucs" "_ZA" '(0.0 0.0 0.0) (trans (cdr (assoc 210 (entget poly))) 0 1 t))
223.         (if (= (length ptse1e2) 6)
224.             (setq pts1 (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (car ptse1e2) (cadr ptse1e2)))
225.             (setq pts2 (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (caddr ptse1e2) (cadddr ptse1e2)))
226.             (setq pts3 (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (car (reverse ptse1e2)) (cadr (reverse ptse1e2))))
227.             (setq ptse1e2 (list pts1 pts2 pts3))
228.             (setq ptsints ptse1e2)
229.           )
230.           (setq ptsints ptse1e2)
231.         )
232.         (setq plpts (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= (car x) 10)) (entget poly))))
233.         (setq plpts (mapcar '(lambda ( x ) (list (car x) (cadr x) e)) plpts))
234.         (setq plpts (mapcar '(lambda ( x ) (trans x poly 0)) plpts))
235.         (foreach pt ptsints
236.           (mapcar '(lambda ( x ) (if (equal pt x (/ len 40.0 (sqrt area))) (setq ptl (cons pt ptl)))) plpts)
237.         )
238.         (foreach pt ptl
239.           (setq ptsints (vl-remove-if '(lambda ( x ) (equal x pt (/ len 16.0 (sqrt area)))) ptsints))
240.         )
241.         (setq ptl (acet-list-remove-duplicates ptl 1.0))
242.         (setq ptsints (acet-list-remove-duplicates ptsints 1.0))
243.         (if (>= (length ptl) 3)
244.               (entdel ci)
245.               (vl-cmdf "_.circle" "3P" "_end" (trans (car ptl) 0 1) "_end" (trans (cadr ptl) 0 1) "_end" (trans (caddr ptl) 0 1))
246.             )
247.         )
248.         (if (and (= (length ptl) 2) (= (length ptsints) 0))
249.               (entdel ci)
250.               (if (equal (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (car ptl) (cadr ptl)) p 1e-4)
251.                 (vl-cmdf "_.circle" "2P" "_end" (trans (car ptl) 0 1) "_end" (trans (cadr ptl) 0 1))
252.                 (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))
253.               )
254.             )
255.         )
256.         (if (and (= (length ptl) 2) (= (length ptsints) 1))
257.               (entdel ci)
258.               (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))
259.             )
260.         )
261.         (if (and (= (length ptl) 1) (= (length ptsints) 1))
262.               (entdel ci)
263.               (vl-cmdf "_.circle" "2P" "_end" (trans (car ptl) 0 1) "_tan" (trans (vlax-curve-getclosestpointto poly (car ptsints)) 0 1))
264.             )
265.         )
266.         (if (and (= (length ptl) 1) (= (length ptsints) 2))
267.               (entdel ci)
268.               (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))
269.             )
270.         )
271.         (if (and (null ptl) (>= (length ptsints) 3))
272.               (entdel ci)
273.               (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))
274.             )
275.         )
276.         (if (and (null ptl) (= (length ptsints) 2))
277.               (entdel ci)
278.               (vl-cmdf "_.circle" (trans p poly 1) (trans (vlax-curve-getclosestpointto poly (trans p poly 0)) 0 1))
279.             )
280.         )
281.         (command "_.ucs" "_P")
282.         (setq ptl nil dist nil)
283.       )
284.       (command "_.ucs" "_P")
285.     )
286.   )
287.   (*error* nil)
288. )
289.
Marko Ribar, d.i.a. (graduated engineer of architecture)