Smallest Circumscribing Circle

[Manila Wolf]

Just wondering if anybody knows of a lisp that will draw a circumscribing circle around an irregular shaped closed polyline or region. The circle to be the smallest diameter that the shape will fit inside of.

 

Something like the attached drawing.

 

I can draw by trial and error using the circle command (2 points or 3 points), but it would be nice to automate this. I am quite lazy!

 

The reason I am looking for this, is because with the design of dies for aluminium extrusions, a common measurement for evaluating tolerances of extrusions and a check on the extruders capacity to create an extrusion, is the circumscribing circle diameter (CCD) of a profile.

SmallestBoundingCircle.dwg

[pBe]

Welcome to the forum Manila Wolf

 

I think its quite easy

 

vla-get-boundingbox is all you need

 

[Manila Wolf]

Hi pBe, thanks for the response.

 

Firstly, let me state that I am not au fait with lisp programming.

I am being cheeky, asking if anybody can help and point me to something that I can copy.

 

Does bounding box give the extremes of a rectangle only? If it does it will not work in all cases. I think it would work for the sample drawing I attached, but not for all shapes.

 

Thanks for the welcome.

 

MW

[pBe]

try this test

 

(defun c:test (/ ent mn mx)
 (vl-load-com)
 (if (setq ent (car (entsel "\n  >>  Select Object  >> ")))
   (progn
     (vla-getboundingbox (vlax-ename->vla-object ent) 'mn 'mx)
(vl-cmdf "._circle" "2P" "_non" (vlax-safearray->list mn) "_non" (vlax-safearray->list mx))))
 (princ))

 

Post a sample of those you mentioned

[Manila Wolf]

Thanks PBe,

Your lisp does work for the example I previously attached.

 

I tried it on the example now attached here, but this does not now give the desired result.

SmallestBoundingCircle1.dwg

[pBe]

what would you like the result to look like?

 

EDIT:

Ohh.. I see what you mean now. i'm throwing in the towel on this one.

It appears that it deals with geometric formulas

 

 

I'm sure David B/ Lee etal can handle this

[Manila Wolf]

I thought it was not so easy.

Thanks very much for your time and kind responses though.

 

For reference, the now attached drawing would be the desired result for the previous attachment.

 

Ok, home time for me now. 7-43pm here in Manila.

 

Cheers and Thanks again.

 

MW

SmallestBoundingCircle2.dwg

[pBe]

No worries MW. I'm sure we'll work out a soluton

 

Cheers

[Lee Mac]

It would also depend upon whether you require the part to be centralised within the circumscribing circle; the bounding box method will centralise the object, but a smaller circle can be obtained for some parts if the part is located off centre.

 

For the off-centre circle, you could find the convex hull of the points that make up the polyline object, then construct a circumscribed circle from this convex polygon; or simply follow the algorithms for the famous smallest circle problem.

 

[marko_ribar]

Try this :

 

;;;"By Lee Mac, sourced from www.lee-mac.com/groupbynum.html";;;
(defun LM:GetIntersections ( obj1 obj2 )
 (LM:GroupByNum (vlax-invoke obj1 'IntersectWith obj2 acExtendNone) 3)
)

(defun LM:GroupByNum ( l n / r)
 (if l
   (cons
     (reverse (repeat n (setq r (cons (car l) r) l (cdr l)) r))
     (LM:GroupByNum l n)
   )
 )
)

(defun interse1e2 ( e1 e2 / lst ) (vl-load-com)
 (if (and e1 e2)
   (setq lst (LM:GetIntersections (vlax-ename->vla-object e1) (vlax-ename->vla-object e2)))
 )
 lst
)

(defun c:circumpline ( / AA AALST AAMIN CI D DLST DMAX I II J JJ K M MM N NN PL PLELEV PLPTS PLPTSREST PLSS SSCI SSCIREST SSN X )
 (prompt "\nPick pline with only line segments for circumscription with circle")
 (while (null plss)
   (setq plss (ssget "_+.:E:S" '((0 . "LWPOLYLINE")) ))
 )
 (setq pl (ssname plss 0))
 (setq plelev (cdr (assoc 38 (entget pl))))
 (setq plpts (mapcar '(lambda (x) (cdr x)) (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget pl)) ))
 (setq k (length plpts))
 (setq n -1)
 (setq dlst '())
 (repeat (- k 1)
   (setq n (1+ n))
   (setq m n)
   (repeat (- k n 1)
     (setq m (1+ m))
     (setq d (distance (nth n plpts) (nth m plpts)))
     (setq dlst (cons d dlst))
   )
 )
 (setq dlst (reverse dlst))
 (setq dmax (eval (cons 'max dlst)))
 (setq j -1)
 (repeat (length dlst)
   (setq j (1+ j))
   (if (= dmax (nth j dlst)) (setq jj j))
 )
 (setq k (length plpts))
 (setq n -1)
 (setq i -1)
 (repeat (- k 1)
   (setq n (1+ n))
   (setq m n)
   (repeat (- k n 1)
     (setq m (1+ m))
     (setq i (1+ i))
     (if (= i jj) (progn (setq nn n) (setq mm m)))
   )
 )
 (setq plptsrest (vl-remove (nth nn plpts) plpts))
 (setq plptsrest (vl-remove (nth mm plpts) plptsrest))
 (vl-cmdf "_.circle" "2p" (nth nn plpts) (nth mm plpts))
 (setq ci (entlast))
 (if (/= (length (interse1e2 pl ci)) 2) 
   (progn
   (entdel ci)
   (setq ii -1) 
   (setq ssci (ssadd))
   (repeat (length plptsrest)
     (setq ii (1+ ii))
     (vl-cmdf "_.circle" "3p" (nth nn plpts) (nth mm plpts) (nth ii plptsrest))
     (setq ci (entlast))
     (if (/= (length (interse1e2 pl ci)) 3) (entdel ci) (ssadd ci ssci))
   )
   )
 )
 (if (not (vl-catch-all-error-p (vl-catch-all-apply 'sslength (list ssci))))
   (progn
     (if (> (sslength ssci) 1)
       (progn
       (setq ssn -1)
       (repeat (sslength ssci)
         (setq ssn (1+ ssn))
         (setq ci (ssname ssci ssn))
         (vl-cmdf "_.area" "o" ci "")
         (setq aa (getvar 'area))
         (setq aalst (cons aa aalst))
       )
       (setq aalst (reverse aalst))
       (setq aamin (eval (cons 'min aalst)))
       (setq ssn -1)
       (repeat (sslength ssci)
         (setq ssn (1+ ssn))
         (if (= aamin (nth ssn aalst)) (setq ci (ssname ssci ssn)))
       )
       (setq sscirest (ssdel ci ssci))
       (vl-cmdf "_.erase" sscirest "")
       )
     )
   )
 )
(princ)
)

Regards, M.R.

Edited October 14, 2011 by marko_ribar
Added "By Lee Mac, sourced from www.lee-mac.com/groupbynum.html"

[Lee Mac]

Why remove my name from the GroupByNum function?

[marko_ribar]

Sorry, Lee I thought that this will confuse someone that is looking into subfunctions... Someone already asked what is LM: in front of function name, and to avoid explanations I removed it and make it shorter and without titles... You see that you can track what you wrote, no need for confusion... But if you insist, I can put it back...

 

M.R.

[Lee Mac]

Sorry, Lee I thought that this will confuse someone that is looking into subfunctions... Someone already asked what is LM: in front of function name, and to avoid explanations I removed it and make it shorter and without titles... You see that you can track what you wrote, no need for confusion... But if you insist, I can put it back...

 

If you aren't going to include the header, even just a note similar to: "By Lee Mac, sourced from www.lee-mac.com/groupbynum.html" would be better etiquette than to remove all accreditation competely.

 

I don't see there is any need to remove the "LM:".

Edited October 14, 2011 by Lee Mac

[Lee Mac]

This code uses a variation of the algorithm used by Highflyingbird here:

 

 

;; Minimum Enclosing Circle  -  Lee Mac  -  www.lee-mac.com
;; Creates the minimum circle required to enclose an LWPolyline

(defun c:MinCir ( / bul d1 dis en enx inc lst p1 p2 )
   (while
       (progn (setvar 'ERRNO 0) (setq en (car (entsel "\nSelect Polyline: ")))
           (cond
               (   (= 7 (getvar 'ERRNO))
                   (princ "\nMissed, try again.")
               )
               (   (eq 'ENAME (type en))
                   (if (not (eq "LWPOLYLINE" (cdr (assoc 0 (entget en)))))
                       (princ "\nInvalid Object.")
                   )
               )
           )
       )
   )
   (if
       (and en
           (progn
               (setq enx (entget en))
               (while (setq p1 (cdr (assoc 10 enx)))
                   (setq lst (cons p1 lst)
                         bul (assoc 42 enx)
                         enx (cdr (member bul enx))
                   )
                   (if
                       (and
                           (setq p2 (cdr (assoc 10 enx)))
                           (not (equal 0.0 (setq bul (abs (cdr bul))) 1e-)
                       )
                       (progn
                           (setq inc (fix (* 20 bul))
                                 d1  (vlax-curve-getdistatpoint en p1)
                                 dis (/ (- (vlax-curve-getdistatpoint en p2) d1) (1+ inc))
                           )
                           (repeat inc
                               (setq lst (cons (vlax-curve-getpointatdist en (setq d1 (+ d1 dis))) lst))
                           )
                       )
                   )
               )
               (setq lst (MinEnCircle lst))
           )
       )
       (entmakex
           (list
               (cons 0 "CIRCLE")
               (cons 10 (car  lst))
               (cons 40 (cadr lst))
           )
       )
   )
   (princ)
)

;; Minimum Enclosing Circle  -  Lee Mac  -  www.lee-mac.com
;; Developed based on the algorithm found at:
;; http://www.theswamp.org/index.php?topic=10561.msg394732#msg394732

(defun MinEnCircle ( lst / a b )
   (cond
       (   (null lst)
           nil
       )
       (   (null (cdr lst))
           (list (car lst) 0.0)
       )
       (   (null (cddr lst))
           (list (apply 'mid lst) (/ (apply 'distance lst) 2.0))
       )
       (   (null (cdddr lst))
           (cdr (apply 'Min3PCircle lst))
       )
       (   (setq a (Min3PCircle (car lst) (cadr lst) (caddr lst))
                 b (FurthestFromPoint lst (cadr a))
           )
           (while (not (InsideCircle-p b (cadr a) (caddr a)))
               (setq a (apply 'Min4PCircle (cons b (car a)))
                     b (FurthestFromPoint lst (cadr a))
               )
           )
           (cdr a)
       )
   )
)

(defun FurthestFromPoint ( lst pt / d1 d2 p1 p2 )
   (setq d1 (distance pt (car lst))
         p1 (car lst)
   )
   (foreach p2 (cdr lst)
       (if (< d1 (setq d2 (distance pt p2)))
           (setq d1 d2 p1 p2)
       )
   )
   p1
)                

(defun Min4PCircle ( p1 p2 p3 p4 / a b c d r )
   (foreach b
       (list
           (Min3PCircle p1 p2 p3)
           (Min3PCircle p1 p2 p4)
           (Min3PCircle p1 p3 p4)
       )
       (setq c (cadr  b)
             d (caddr b)
       )
       (if
           (or (not a)
               (and c d (< d r)
                   (InsideCircle-p p1 c d)
                   (InsideCircle-p p2 c d)
                   (InsideCircle-p p3 c d)
                   (InsideCircle-p p4 c d)
               )
           )
           (setq a b r d)
       )
   )
   a
)

(defun Min3PCircle ( p1 p2 p3 / c r )
   (cons (list p1 p2 p3)
       (if
           (or
               (InsideCircle-p p1 (setq c (mid p2 p3)) (setq r (/ (distance p2 p3) 2.0)))
               (InsideCircle-p p2 (setq c (mid p1 p3)) (setq r (/ (distance p1 p3) 2.0)))
               (InsideCircle-p p3 (setq c (mid p1 p2)) (setq r (/ (distance p1 p2) 2.0)))
           )
           (list c r)
           (3PCircle p1 p2 p3)
       )
   )
)

(defun 3PCircle ( p1 p2 p3 / cn m1 m2 )
   (setq m1 (mid p1 p2)
         m2 (mid p2 p3)
   )
   (if
       (setq cn
           (inters
               m1 (polar m1 (+ (angle p1 p2) (/ pi 2.)) 1.0)
               m2 (polar m2 (+ (angle p2 p3) (/ pi 2.)) 1.0)
               nil
           )
       )
       (list cn (distance cn p1))
   )
)

(defun InsideCircle-p ( pt cn rd )
   (<= (distance pt cn) rd)
)

(defun mid ( a b )
   (mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) a b)
)

(vl-load-com) (princ)

[marko_ribar]

Neither your, nor mine code works on plines with arcs, or plines-polygons...

At least, to make myself satisfied, my code don't take in consideration these examples and doesn't give any result, but your code is calculating and eventually never completes calculations - you have to terminate CAD...

 

Updated my code with Lee Mac info...

 

M.R.

Edited October 14, 2011 by marko_ribar

[Lee Mac]

At least, to make myself satisfied, my code don't take in consideration these examples and doesn't give any result, but your code is calculating and eventually never completes calculations - you have to terminate CAD...

 

Sometimes mine works, sometimes it doesn't - I may have to reconsider the algorithm.

[Manila Wolf]

marko_ribar and Lee Mac,

Sincere thanks for your contributions.

 

I see those pesky arcs and fillet radii are causing the headaches!

 

To confirm: - The shape does not have to be centralised. The target is indeed the smallest diameter possible even if the profile is off centre.

[marko_ribar]

I've changed my code finally - it includes n-polygons and plines based on them... Still, I can't do it with my knowledge to include arcs in considerations - POLYLINE must have STRAIGHT SEGMENTS, and must lay on elevation 0.0

 

;;;"By Lee Mac, sourced from www.lee-mac.com/groupbynum.html";;;
(defun LM:GetIntersections ( obj1 obj2 )
 (LM:GroupByNum (vlax-invoke obj1 'IntersectWith obj2 acExtendNone) 3)
)

(defun LM:GroupByNum ( l n / r)
 (if l
   (cons
     (reverse (repeat n (setq r (cons (car l) r) l (cdr l)) r))
     (LM:GroupByNum l n)
   )
 )
)

(defun interse1e2 ( e1 e2 / lst ) (vl-load-com)
 (if (and e1 e2)
   (setq lst (LM:GetIntersections (vlax-ename->vla-object e1) (vlax-ename->vla-object e2)))
 )
 lst
)

(defun c:circumpline ( / AA AALST AAMIN CI D DLST DMAX I II J JJ K M MM N NN PL PLELEV PLPTS PLPTSREST PLSS SSCI SSCIREST SSN TST X )
 (prompt "\nPick pline with only line segments for circumscription with circle")
 (while (null plss)
   (setq plss (ssget "_+.:E:S" '((0 . "LWPOLYLINE")) ))
 )
 (setq pl (ssname plss 0))
 (setq plelev (cdr (assoc 38 (entget pl))))
 (if (/= plelev 0.0) (progn (alert "\nPicked polyline has different elevation than 0.0... \nAborting - pick right pline after restarting routine") (exit)))
 (setq plpts (mapcar '(lambda (x) (cdr x)) (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget pl)) ))
 (setq k (length plpts))
 (setq n -1)
 (setq dlst '())
 (repeat (- k 1)
   (setq n (1+ n))
   (setq m n)
   (repeat (- k n 1)
     (setq m (1+ m))
     (setq d (distance (nth n plpts) (nth m plpts)))
     (setq dlst (cons d dlst))
   )
 )
 (setq dlst (reverse dlst))
 (setq dmax (eval (cons 'max dlst)))
 (setq j -1)
 (repeat (length dlst)
   (setq j (1+ j))
   (if (= dmax (nth j dlst)) (setq jj j))
 )
 (setq k (length plpts))
 (setq n -1)
 (setq i -1)
 (repeat (- k 1)
   (setq n (1+ n))
   (setq m n)
   (repeat (- k n 1)
     (setq m (1+ m))
     (setq i (1+ i))
     (if (= i jj) (progn (setq nn n) (setq mm m)))
   )
 )
 (setq plptsrest (vl-remove (nth nn plpts) plpts))
 (setq plptsrest (vl-remove (nth mm plpts) plptsrest))
 (vl-cmdf "_.circle" "2p" (nth nn plpts) (nth mm plpts))
 (setq ci (entlast))
 (foreach pt (interse1e2 pl ci)
   (mapcar '(lambda (x) (if (equal (list (car pt) (cadr pt)) x 1e-6) (setq tst (cons T tst))  )) plpts)
 ) 
 (if (and (/= (length tst) (length (interse1e2 pl ci))) (/= (length (interse1e2 pl ci)) 2)) 
   (progn
   (entdel ci)
   (setq ii -1) 
   (setq ssci (ssadd))
   (repeat (length plptsrest)
     (setq ii (1+ ii))
     (vl-cmdf "_.circle" "3p" (nth nn plpts) (nth mm plpts) (nth ii plptsrest))
     (setq ci (entlast))
     (if (/= (length (interse1e2 pl ci)) 3) (entdel ci) (ssadd ci ssci))
   )
   )
 )
 (if (not (vl-catch-all-error-p (vl-catch-all-apply 'sslength (list ssci))))
   (progn
     (if (> (sslength ssci) 1)
       (progn
       (setq ssn -1)
       (repeat (sslength ssci)
         (setq ssn (1+ ssn))
         (setq ci (ssname ssci ssn))
         (vl-cmdf "_.area" "o" ci "")
         (setq aa (getvar 'area))
         (setq aalst (cons aa aalst))
       )
       (setq aalst (reverse aalst))
       (setq aamin (eval (cons 'min aalst)))
       (setq ssn -1)
       (repeat (sslength ssci)
         (setq ssn (1+ ssn))
         (if (= aamin (nth ssn aalst)) (setq ci (ssname ssci ssn)))
       )
       (setq sscirest (ssdel ci ssci))
       (vl-cmdf "_.erase" sscirest "")
       )
     )
   )
 )
(princ)
)

 

M.R.

[pBe]

Thought about creating points based on "smallest circle problem" link posted by Lee or similar algorithm , but problem i see with that as you guys probably know and noticed by now are arc segments.

 

I'll keep digging

[Lee Mac]

Thought about creating points based on "smallest circle problem" link posted by Lee or similar algorithm , but problem i see with that as you guys probably know and noticed by now are arc segments.

 

If you can construct a bullet-proof algorithm for calculating the 'Minimum Enclosing Circle' (MEC) (various methods: use of Convex hull / Megiddo's Algorithm etc.), for any set of points, then you are done.

 

The arc segments can be included by using the curve functions to add the necessary additional points to the list of points for the MEC algorithm, as I have in my calling function.

 

The difficult part is writing a concrete algorithm for any point set.

Edited October 15, 2011 by Lee Mac