Smallest Circumscribing Circle

October 15, 2011

Lee, is it safe to assume that the diameter of the resulting circle will never be larger than the distance between the two points generated by vla-bounding-box?

October 15, 2011

Lee, is it safe to assume that the diameter of the resulting circle will never be larger than the distance between the two points generated by vla-bounding-box?

Yes, since the circle would enclose the bounding box entirely.

October 16, 2011

The HELL...

Check this *.dwg with my code c:circumpline

I get this error :

; error: bad argument value: does not fit in byte: 666

Command:

And your code Lee works... Seems I ran on some bug in CAD (maybe it's only on my comp)...

M.R.

:twisted::ouch:o:)o:)

circumpline.dwg

October 16, 2011

I think I've found where is error...

its (eval (max num1 num2 num3 ... numn))

my code accepts plines up to 23 points, and polygons up to 22 points... I used combinations between points to calculate maximum distance, and that's exactly the lack of my code... How can I find 2 points with maximum distance between them in polyline with n points without using (eval (max dist1 dist2 ...)) ?

Please, if you know the answer, reply...

M.R.

October 16, 2011

Finally, I've revised my code, and it now works for n points in pline... With help of Lee's subfunction...

;;;"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 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 c:circumpline ( / AA AALST AAMIN CI D1 D2 II K M PL PLELEV PLPTS PLPTSREST PLSS PT PT1 PT2 PT3 PT4 PTT 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 -1)
 (repeat (length plpts)
   (setq k (1+ k))
   (if (= m (- (length plpts) 1)) (setq m 0) (setq m (1+ k)))
   (setq pt1 (nth k plpts))
   (setq pt2 (FurthestFromPoint plpts pt1))
   (setq d1 (distance pt1 pt2))
   (setq pt3 (nth m plpts))
   (setq pt4 (FurthestFromPoint plpts pt3))
   (setq d2 (distance pt3 pt4))
   (if (<= d1 d2) (setq pt pt3) (setq pt pt1))
 )
 (setq ptt (FurthestFromPoint plpts pt))   
 (setq plptsrest (vl-remove pt plpts))
 (setq plptsrest (vl-remove ptt plptsrest))
 (vl-cmdf "_.circle" "2p" pt ptt)
 (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" pt ptt (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.

October 16, 2011

One last thing,

Both and Lee's code and my final code doesn't work on polygons with odd number of sides, for that case you'll have to draw circle manually...

M.R.

October 16, 2011

My final version... It works and for odd sided polygons... Only doesn't work with arcs, all other cases are fulfilled :

;;;"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 FurthestFromPoint ( lst pt / dmax d1 d2 p1 p2 lstn )
   (setq lstn lst)
   (setq d1 (distance pt (car lst))
         p1 (car lst)
   )
   (foreach p (cdr lst)
       (if (< d1 (setq d2 (distance pt p)))
           (setq d1 d2 p1 p)
       )
   )
   (setq dmax (distance pt p1))
   (foreach p lstn
       (if (equal dmax (distance pt p) 1e-4)
           (if (not (equal p1 p 1e-) (setq p2 p))
       )
   )
   (if (and p1 p2)
   (list p1 p2)
   p1
   )
)

(defun c:circumpline ( / AA AALST AAMIN CI D1 D2 II K M PL PLELEV PLPTS PLPTSREST PLSS PT PT1 PT2 PT3 PT4 PTT PTT1 PTT2 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 -1)
 (repeat (length plpts)
   (setq k (1+ k))
   (if (= m (- (length plpts) 1)) (setq m 0) (setq m (1+ k)))
   (setq pt1 (nth k plpts))
   (if (listp (car (FurthestFromPoint plpts pt1))) (setq pt2 (car (FurthestFromPoint plpts pt1))) (setq pt2 (FurthestFromPoint plpts pt1)))
   (setq d1 (distance pt1 pt2))
   (setq pt3 (nth m plpts))
   (if (listp (car (FurthestFromPoint plpts pt3))) (setq pt4 (car (FurthestFromPoint plpts pt3))) (setq pt4 (FurthestFromPoint plpts pt3)))
   (setq d2 (distance pt3 pt4))
   (if (<= d1 d2) (setq pt pt3) (setq pt pt1))
 )
 (if (listp (car (FurthestFromPoint plpts pt))) (progn (setq ptt1 (car (FurthestFromPoint plpts pt))) (setq ptt2 (cadr (FurthestFromPoint plpts pt)))) (setq ptt (FurthestFromPoint plpts pt)))
 (setq plptsrest (vl-remove pt plpts))
 (if ptt (setq plptsrest (vl-remove ptt plptsrest)))
 (if ptt1 (setq plptsrest (vl-remove ptt1 plptsrest)))
 (if ptt2 (setq plptsrest (vl-remove ptt2 plptsrest)))
 (if ptt (vl-cmdf "_.circle" "2p" pt ptt))
 (if (and ptt1 ptt2) (vl-cmdf "_.circle" "3p" pt ptt1 ptt2))
 (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" pt ptt (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.

October 16, 2011

Gosh! I hope I haven't caused any marriage break ups with you guys spending so much time on this.

Don't laugh......Is there anything to be gained by somehow automatically breaking all arcs into multiple very small chords?

October 16, 2011

Don't laugh......Is there anything to be gained by somehow automatically breaking all arcs into multiple very small chords?

Indeed....

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.

October 16, 2011

I wish it could have been this easy:

(defun c:test (/ obj lst pt enc tpts pt_)
  (setq obj (car (entsel "\nSelect Polyline: ")))
  (setq lst (mapcar 'cdr (vl-remove-if-not (function (lambda (j)
         (= (car j) 10))) (entget obj))))
 (while (setq pt (getpoint "\nPick Reference point: "))
   (redraw)
(setq tpts 
   (vl-sort
   (vl-remove (list (car pt)
    (cadr pt)) lst)
 '(lambda (d1 d2)
     (> (distance pt d1)
     (distance pt d2)))))
(grvecs (append '(1)
 (list (list (car pt)(cadr pt))(car tpts)
      1 (car tpts) (cadr tpts)
      1 (cadr tpts)(list (car pt)(cadr pt)))))
    (setq pt_ pt)
)
 (redraw)
 (command "_circle" "3p"  "_non" pt_
        "_non" (car tpts)
        "_non" (cadr tpts))
 (princ)
 )

this is the first draft:

(defun c:test (/ obj lst pt enc tpts)
  (setq obj (car (entsel "\nSelect Polyline: ")))
  (setq lst (mapcar 'cdr (vl-remove-if-not (function (lambda (j)
         (= (car j) 10))) (entget obj)))
      objs (ssadd))
 (while (setq pt (getpoint "\nPick Reference point: "))
    (if enc
  (progn (vla-put-color (vlax-ename->vla-object enc) 251)
    (setq objs (ssadd enc objs))
   )
  )
  (setq tpts 
   (vl-sort
   (vl-remove (list (car pt)
    (cadr pt)) lst)
 '(lambda (d1 d2)
     (> (distance pt d1)
     (distance pt d2)))))

 (command "_circle" "_3P" "_non"  pt
      "_non" (car tpts)
             "_non" (cadr tpts))
 (setq enc (entlast))
    
   )
 (command "_erase" objs "")
 )

but sometimes it fails

Edited October 16, 2011 by pBe

October 16, 2011

Having spent some time studying a new algorithm, attached is my new version.

It hasn't failed (as yet) in my tests for any shape of LWPolyline, with or without arc segments.

A test function is included in the file, type 'test' to run the program.

Lee

MinimumEnclosingCircle.lsp

October 17, 2011

Lee Mac. You have truly nailed it.

I tried it on over 30 profile shapes. It's Perfect.

I can't thank you enough. Really made my day. I am genuinely exited to have this.

Thanks also to pBe and marko_ribar for worthy contributions.

I know I will use this constantly. I am wondering if now the problem is solved, whether it will be of use to anybody but me. I suspect not.

25 years of trial and error I have been doing this. hahahaha

Great Forum!!!!!!

October 17, 2011

Nice code Lee, i never even got past linear polylines

October 17, 2011

Lee, in your subfunction LM:LWPoly->List , what parameters can be changed to obtain more precise segmentation of arcs?

;; LWPolyline to Point List  -  Lee Mac
;; Returns a list of points describing the supplied LWPolyline

(defun LM:LWPoly->List ( ent / der di1 di2 inc lst par rad )
   (setq par 0)
   (repeat (cdr (assoc 90 (entget ent)))
       (if (setq der (vlax-curve-getsecondderiv ent par))
           (if (equal der '(0.0 0.0 0.0) 1e-
               (setq lst (cons (vlax-curve-getpointatparam ent par) lst))
               (if
                   (setq rad (distance '(0.0 0.0) (vlax-curve-getfirstderiv ent par))
                         di1 (vlax-curve-getdistatparam ent par)
                         di2 (vlax-curve-getdistatparam ent (1+ par))
                   )
                   (progn
                       (setq inc (/ (- di2 di1) (1+ (fix (* 25 (/ (- di2 di1) rad (+ pi pi)))))))
                       (while (< di1 di2)
                           (setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
                                 di1 (+ di1 inc)
                           )
                       )
                   )
               )
           )
       )
       (setq par (1+ par))
   )
   lst
)

;; List of 3D Points -> list of 2D Points

;(defun 3DPTL->2DPTL ( lst / lstn )
;    (setq lstn (mapcar (function (lambda ( x ) (list (car x) (cadr x)))) lst))
;    lstn


;; Test Function

(defun c:test ( / en lst lstn pln )
   (while
       (progn (setvar 'ERRNO 0) (setq en (car (entsel "\nSelect LWPolyline: ")))
           (cond
               (   (= 7 (getvar 'ERRNO))
                   (princ "\nMissed, try again.")
               )
               (   (eq 'ENAME (type en))
                   (if (not (eq "LWPOLYLINE" (cdr (assoc 0 (entget en)))))
                       (princ "\nInvalid Object Selected.")
                   )
               )
           )
       )
   )
   (if
       (and en
           (setq lst
               (mapcar
                   (function (lambda ( x ) (trans x 0 en)))
                   (LM:LWPoly->List en)
               )
           )
;           (setq lst
;               (mapcar
;                   (function (lambda ( x ) (append (list 10) x)))
;                   (3DPTL->2DPTL lst)
;               )
;           )
        )
        (progn
          (setvar 'cecolor "3")
          (if (= (cdr (assoc 70 (entget en))) 0)
          (progn
          (vl-cmdf "_.pline")
          (foreach pt lst
            (vl-cmdf pt)
          )
          (vl-cmdf "")
          (setvar 'cecolor "ByLayer")
          )
        (progn
          (vl-cmdf "_.pline")
          (foreach pt lst
            (vl-cmdf pt)
          )
          (vl-cmdf "C")
          (setvar 'cecolor "ByLayer")
          )
       )
    )
    )
;        (progn
;        (setq lstn '())
;     (foreach pt lst
;           (setq lstn (append lstn (append (list pt) (list (cons 40 0.0) (cons 41 0.0) (cons 42 0.0) (cons 91 0.0)))))
;     )
;     (setq pln
;         (append
;                 (list (cons 0 "LWPOLYLINE") (cons 62 3) (assoc 70 (entget en)) (assoc 38 (entget en)))
;         lstn
;                 (list (assoc 210 (entget en)))
;             )
;     )
;         (entmakex pln)
;     )
;     )
    (princ)
)

(vl-load-com) (princ)

BTW., I couldn't do entmakex to create LWPOLYLINE object, I tried what I could, and in the end I did it with (vl-cmdf "_.pline")... What I'm missing - this is unnecessary to answer if you don't want - it works and this way, but please answer on my first question about more dense segmentation if you can...

Thanks, M.R.

October 17, 2011

Lee Mac. You have truly nailed it.
I tried it on over 30 profile shapes. It's Perfect.

I can't thank you enough. Really made my day. I am genuinely exited to have this.

Thanks also to pBe and marko_ribar for worthy contributions.

I know I will use this constantly. I am wondering if now the problem is solved, whether it will be of use to anybody but me. I suspect not.

25 years of trial and error I have been doing this. hahahaha

Great Forum!!!!!!

Excellent to hear Manila Wolf! I'm really glad that my code can save help you in your work - it was an interesting puzzle to solve and I have also learnt a greal deal from the challenge of solving it.

Cheers!

Nice code Lee, i never even got past linear polylines

Thanks pBe

Lee, in your subfunction LM:LWPoly->List , what parameters can be changed to obtain more precise segmentation of arcs?

Hi Marko,

Change the '25' to a larger number:

(setq inc (/ (- di2 di1) (1+ (fix (* [color=red]25[/color] (/ (- di2 di1) rad (+ pi pi)))))))

BTW., I couldn't do entmakex to create LWPOLYLINE object, I tried what I could, and in the end I did it with (vl-cmdf "_.pline")...

Here is an example for you:

;; LWPolyline to Point List  -  Lee Mac
;; Returns a list of points describing the supplied LWPolyline

(defun LM:LWPoly->List ( ent / der di1 di2 inc lst par rad )
   (setq par 0)
   (repeat (cdr (assoc 90 (entget ent)))
       (if (setq der (vlax-curve-getsecondderiv ent par))
           (if (equal der '(0.0 0.0 0.0) 1e-
               (setq lst (cons (vlax-curve-getpointatparam ent par) lst))
               (if
                   (setq rad (distance '(0.0 0.0) (vlax-curve-getfirstderiv ent par))
                         di1 (vlax-curve-getdistatparam ent par)
                         di2 (vlax-curve-getdistatparam ent (1+ par))
                   )
                   (progn
                       (setq inc (/ (- di2 di1) (1+ (fix (* 25 (/ (- di2 di1) rad (+ pi pi)))))))
                       (while (< di1 di2)
                           (setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
                                 di1 (+ di1 inc)
                           )
                       )
                   )
               )
           )
       )
       (setq par (1+ par))
   )
   lst
)

;; Test Function

(defun c:test ( / en lst )
   (while
       (progn (setvar 'ERRNO 0) (setq en (car (entsel "\nSelect LWPolyline: ")))
           (cond
               (   (= 7 (getvar 'ERRNO))
                   (princ "\nMissed, try again.")
               )
               (   (eq 'ENAME (type en))
                   (if (not (eq "LWPOLYLINE" (cdr (assoc 0 (entget en)))))
                       (princ "\nInvalid Object Selected.")
                   )
               )
           )
       )
   )
   (if
       (and en
           (setq lst
               (mapcar
                   (function (lambda ( x ) (trans x 0 en)))
                   (LM:LWPoly->List en)
               )
           )
       )
       (entmakex
           (append
               (list
                   (cons 0 "LWPOLYLINE")
                   (cons 100 "AcDbEntity")
                   (cons 100 "AcDbPolyline")
                   (cons 90 (length lst))
                   (assoc 70 (entget en))
                   (assoc 210 (entget en))
               )
               (mapcar '(lambda ( x ) (cons 10 x)) lst)
           )
       )
   )
   (princ)
)

October 17, 2011

Great Lee, you made my day wonderful...

I've just updated your codes to include option for better precision... I hope you won't be angry for these little corrections to your codes (maybe someone doesn't know how to make them and want better results...)

Minimum enclosing circle.lsp

;; Minimum Enclosing Circle  -  Lee Mac
;; Implements the algorithm by Pr.Chrystal (1885) using the Convex Hull
;; to determine the Minimum Enclosing Circle of a point set.

(defun LM:MinEncCircle ( lst / _sub )

   (defun _sub ( p1 p2 l1 / a1 a2 l2 p3 p4 )
       (setq l2 (LM:RemoveWithFuzz (list p1 p2) l1 1e-
             p3 (car l2)
             a1 (LM:GetInsideAngle p1 p3 p2)
       )
       (foreach p4 (cdr l2)
           (if (< (setq a2 (LM:GetInsideAngle p1 p4 p2)) a1)
               (setq p3 p4 a1 a2)
           )
       )
       (cond
           (   (<= (/ pi 2.0) a1)
               (list (mid p1 p2) (/ (distance p1 p2) 2.0))
           )
           (   (vl-some
                   (function
                       (lambda ( a b c )
                           (if (< (/ pi 2.0) (LM:GetInsideAngle a b c)) (_sub a c l1))
                       )
                   )
                   (list p1 p1 p2) (list p2 p3 p1) (list p3 p2 p3)
               )
           )
           (   (LM:3PCircle p1 p2 p3)   )
       )
   )

   ((lambda ( lst ) (_sub (car lst) (cadr lst) lst)) (LM:ConvexHull lst))
)

;; Remove With Fuzz  -  Lee Mac
;; Removes items from a list which are equal to a supplied tolerance

(defun LM:RemoveWithFuzz ( l1 l2 fz )
   (vl-remove-if
       (function
           (lambda ( a )
               (vl-some
                   (function (lambda ( b ) (equal a b fz)))
                   l1
               )
           )
       )
       l2
   )
)

;; Get Inside Angle  -  Lee Mac
;; Returns the smaller angle subtended by three points with vertex at p2

(defun LM:GetInsideAngle ( p1 p2 p3 )
   (   (lambda ( a ) (min a (- (+ pi pi) a)))
       (rem (+ pi pi (- (angle p2 p1) (angle p2 p3))) (+ pi pi))
   )
)

;; 3-Point Circle  -  Lee Mac
;; Returns the Center and Radius of the Circle defined by
;; the supplied three points.

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

;; Midpoint - Lee Mac
;; Returns the midpoint of two points

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

;; Convex Hull  -  Lee Mac
;; Implements the Graham Scan Algorithm to determine the
;; Convex Hull of a list of points.

(defun LM:ConvexHull ( lst / hul p0 )
   (cond
       (   (< (length lst) 4)
           lst
       )
       (   t
           (setq p0 (car lst))
           (foreach p1 (cdr lst)
               (if (or (< (cadr p1) (cadr p0))
                       (and (equal (cadr p1) (cadr p0) 1e- (< (car p1) (car p0)))
                   )
                   (setq p0 p1)
               )
           )
           (setq lst
               (vl-sort lst
                   (function
                       (lambda ( a b / c d )
                           (if (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-
                               (< (distance p0 a) (distance p0 b))
                               (< c d)
                           )
                       )
                   )
               )
           )
           (setq hul (list (caddr lst) (cadr lst) (car lst)))
           (foreach pt (cdddr lst)
               (setq hul (cons pt hul))
               (while (and (caddr hul) (LM:Clockwise-p (caddr hul) (cadr hul) pt))
                   (setq hul (cons pt (cddr hul)))
               )
           )
           hul
       )
   )
)

;; Clockwise-p  -  Lee Mac
;; Returns T if p1,p2,p3 are clockwise oriented or collinear
                
(defun LM:Clockwise-p ( p1 p2 p3 )
   (<  (-  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
           (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
       )
       1e-8
   )
)

;; LWPolyline to Point List  -  Lee Mac
;; Returns a list of points describing the supplied LWPolyline

(defun LM:LWPoly->List ( ent n / der di1 di2 inc lst par rad )
   (setq par 0)
   (repeat (cdr (assoc 90 (entget ent)))
       (if (setq der (vlax-curve-getsecondderiv ent par))
           (if (equal der '(0.0 0.0 0.0) 1e-
               (setq lst (cons (vlax-curve-getpointatparam ent par) lst))
               (if
                   (setq rad (distance '(0.0 0.0) (vlax-curve-getfirstderiv ent par))
                         di1 (vlax-curve-getdistatparam ent par)
                         di2 (vlax-curve-getdistatparam ent (1+ par))
                   )
                   (progn
                       (setq inc (/ (- di2 di1) (1+ (fix (* n (/ (- di2 di1) rad (+ pi pi)))))))
                       (while (< di1 di2)
                           (setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
                                 di1 (+ di1 inc)
                           )
                       )
                   )
               )
           )
       )
       (setq par (1+ par))
   )
   lst
)


;; Test Function

(defun c:test ( / en lst n )
   (while
       (progn (setvar 'ERRNO 0) (setq en (car (entsel "\nSelect LWPolyline: ")))
           (cond
               (   (= 7 (getvar 'ERRNO))
                   (princ "\nMissed, try again.")
               )
               (   (eq 'ENAME (type en))
                   (if (not (eq "LWPOLYLINE" (cdr (assoc 0 (entget en)))))
                       (princ "\nInvalid Object Selected.")
                   )
               )
           )
       )
   )
   (initget 6)
   (setq n (getint "\nInput number for level of segmetation <25> - larger the number, better segmentation : "))
   (if (null n) (setq n 25))
   (if
       (and en
           (setq lst
               (mapcar
                   (function (lambda ( x ) (trans x 0 en)))
                   (LM:LWPoly->List en n)
               )
           )
           (setq lst (LM:MinEncCircle lst))
       )
       (entmakex
           (list
               (cons 0 "CIRCLE")
               (cons 10 (car  lst))
               (cons 40 (cadr lst))
               (assoc 210 (entget en))
           )
       )
   )
   (princ)
)

(vl-load-com) (princ)

Segmentation of pline with arcs.lsp

;; LWPolyline to Point List  -  Lee Mac
;; Returns a list of points describing the supplied LWPolyline

(defun LM:LWPoly->List ( ent n / der di1 di2 inc lst par rad )
   (setq par 0)
   (repeat (cdr (assoc 90 (entget ent)))
       (if (setq der (vlax-curve-getsecondderiv ent par))
           (if (equal der '(0.0 0.0 0.0) 1e-
               (setq lst (cons (vlax-curve-getpointatparam ent par) lst))
               (if
                   (setq rad (distance '(0.0 0.0) (vlax-curve-getfirstderiv ent par))
                         di1 (vlax-curve-getdistatparam ent par)
                         di2 (vlax-curve-getdistatparam ent (1+ par))
                   )
                   (progn
                       (setq inc (/ (- di2 di1) (1+ (fix (* n (/ (- di2 di1) rad (+ pi pi)))))))
                       (while (< di1 di2)
                           (setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
                                 di1 (+ di1 inc)
                           )
                       )
                   )
               )
           )
       )
       (setq par (1+ par))
   )
   lst
)

;; Test Function

(defun c:test ( / en lst n )
   (while
       (progn (setvar 'ERRNO 0) (setq en (car (entsel "\nSelect LWPolyline: ")))
           (cond
               (   (= 7 (getvar 'ERRNO))
                   (princ "\nMissed, try again.")
               )
               (   (eq 'ENAME (type en))
                   (if (not (eq "LWPOLYLINE" (cdr (assoc 0 (entget en)))))
                       (princ "\nInvalid Object Selected.")
                   )
               )
           )
       )
   )
   (initget 6)
   (setq n (getint "\nInput number for level of segmetation <25> - larger the number, better segmentation : "))
   (if (null n) (setq n 25))
   (if
       (and en
           (setq lst
               (mapcar
                   (function (lambda ( x ) (trans x 0 en)))
                   (LM:LWPoly->List en n)
               )
           )
       )
       (entmakex
           (append
               (list
                   (cons 0 "LWPOLYLINE")
                   (cons 100 "AcDbEntity")
                   (cons 100 "AcDbPolyline")
           (cons 62 3)
                   (cons 90 (length lst))
                   (assoc 70 (entget en))
                   (assoc 210 (entget en))
               )
               (mapcar '(lambda ( x ) (cons 10 x)) lst)
           )
       )
   )
   (princ)
)

(vl-load-com) (princ)

Thank again for your replies Lee...

Sincerely, Marko Ribar (arch.)

Edited October 17, 2011 by marko_ribar

October 18, 2011

Lee, I've tried to additionally improve your routine (now if founded - results are perfect with or without arcs)...

(vl-load-com) (princ)

;;;"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 )
 (if (and e1 e2)
   (setq lst (LM:GetIntersections (vlax-ename->vla-object e1) (vlax-ename->vla-object e2)))
 )
 lst
)

;; Minimum Enclosing Circle  -  Lee Mac
;; Implements the algorithm by Pr.Chrystal (1885) using the Convex Hull
;; to determine the Minimum Enclosing Circle of a point set.

(defun LM:MinEncCircle ( lst / _sub )

   (defun _sub ( p1 p2 l1 / a1 a2 l2 p3 p4 )
       (setq l2 (LM:RemoveWithFuzz (list p1 p2) l1 1e-
             p3 (car l2)
             a1 (LM:GetInsideAngle p1 p3 p2)
       )
       (foreach p4 (cdr l2)
           (if (< (setq a2 (LM:GetInsideAngle p1 p4 p2)) a1)
               (setq p3 p4 a1 a2)
           )
       )
       (cond
           (   (<= (/ pi 2.0) a1)
               (list (mid p1 p2) (/ (distance p1 p2) 2.0))
           )
           (   (vl-some
                   (function
                       (lambda ( a b c )
                           (if (< (/ pi 2.0) (LM:GetInsideAngle a b c)) (_sub a c l1))
                       )
                   )
                   (list p1 p1 p2) (list p2 p3 p1) (list p3 p2 p3)
               )
           )
           (   (LM:3PCircle p1 p2 p3)   )
       )
   )

   ((lambda ( lst ) (_sub (car lst) (cadr lst) lst)) (LM:ConvexHull lst))
)

;; Remove With Fuzz  -  Lee Mac
;; Removes items from a list which are equal to a supplied tolerance

(defun LM:RemoveWithFuzz ( l1 l2 fz )
   (vl-remove-if
       (function
           (lambda ( a )
               (vl-some
                   (function (lambda ( b ) (equal a b fz)))
                   l1
               )
           )
       )
       l2
   )
)

;; Get Inside Angle  -  Lee Mac
;; Returns the smaller angle subtended by three points with vertex at p2

(defun LM:GetInsideAngle ( p1 p2 p3 )
   (   (lambda ( a ) (min a (- (+ pi pi) a)))
       (rem (+ pi pi (- (angle p2 p1) (angle p2 p3))) (+ pi pi))
   )
)

;; 3-Point Circle  -  Lee Mac
;; Returns the Center and Radius of the Circle defined by
;; the supplied three points.

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

;; Midpoint - Lee Mac
;; Returns the midpoint of two points

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

;; Convex Hull  -  Lee Mac
;; Implements the Graham Scan Algorithm to determine the
;; Convex Hull of a list of points.

(defun LM:ConvexHull ( lst / hul p0 )
   (cond
       (   (< (length lst) 4)
           lst
       )
       (   t
           (setq p0 (car lst))
           (foreach p1 (cdr lst)
               (if (or (< (cadr p1) (cadr p0))
                       (and (equal (cadr p1) (cadr p0) 1e- (< (car p1) (car p0)))
                   )
                   (setq p0 p1)
               )
           )
           (setq lst
               (vl-sort lst
                   (function
                       (lambda ( a b / c d )
                           (if (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-
                               (< (distance p0 a) (distance p0 b))
                               (< c d)
                           )
                       )
                   )
               )
           )
           (setq hul (list (caddr lst) (cadr lst) (car lst)))
           (foreach pt (cdddr lst)
               (setq hul (cons pt hul))
               (while (and (caddr hul) (LM:Clockwise-p (caddr hul) (cadr hul) pt))
                   (setq hul (cons pt (cddr hul)))
               )
           )
           hul
       )
   )
)

;; Clockwise-p  -  Lee Mac
;; Returns T if p1,p2,p3 are clockwise oriented or collinear
                
(defun LM:Clockwise-p ( p1 p2 p3 )
   (<  (-  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
           (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
       )
       1e-8
   )
)

;; LWPolyline to Point List  -  Lee Mac
;; Returns a list of points describing the supplied LWPolyline

(defun LM:LWPoly->List ( ent n / der di1 di2 inc lst par rad )
   (setq par 0)
   (repeat (cdr (assoc 90 (entget ent)))
       (if (setq der (vlax-curve-getsecondderiv ent par))
           (if (equal der '(0.0 0.0 0.0) 1e-
               (setq lst (cons (vlax-curve-getpointatparam ent par) lst))
               (if
                   (setq rad (distance '(0.0 0.0) (vlax-curve-getfirstderiv ent par))
                         di1 (vlax-curve-getdistatparam ent par)
                         di2 (vlax-curve-getdistatparam ent (1+ par))
                   )
                   (progn
                       (setq inc (/ (- di2 di1) (1+ (fix (* n (/ (- di2 di1) rad (+ pi pi)))))))
                       (while (< di1 di2)
                           (setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
                                 di1 (+ di1 inc)
                           )
                       )
                   )
               )
           )
       )
       (setq par (1+ par))
   )
   lst
)

(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 NearestFromPoint ( lst pt / d1 d2 p1 p2 )
   (setq lst (vl-remove pt lst))
   (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
)

;; Test Function

(defun c:circumpline ( / APP EN N OSM PT PTA1 PTA11 PTA2 PTA22 PTA3 PTL PTSE1E2ARCS TST X )
   (setq app (getvar 'aperture))
   (setq osm (getvar 'osmode))
   (setvar 'aperture 50)
   (setvar 'osmode 0)
   (while
       (progn (setvar 'ERRNO 0) (setq en (car (entsel "\nSelect LWPolyline: ")))
           (cond
               (   (= 7 (getvar 'ERRNO))
                   (princ "\nMissed, try again.")
               )
               (   (eq 'ENAME (type en))
                   (if (not (eq "LWPOLYLINE" (cdr (assoc 0 (entget en)))))
                       (princ "\nInvalid Object Selected.")
                   )
               )
           )
       )
   )
   (initget 6)
   (alert "\nIf founded circle in current layer color is occasionally perfect \n(may give wrong results if helper circle doesn't intersect with picked pline using intersectwith function)\nYellow circle witch is erased during routine is helper circle that touches arcs but crosses them - it's Lee Mac result of LM:MinEncCircle")
   (setq n (getint "\nInput number for level of segmetation <360> - larger the number (slower), smaller the number (faster) : "))
   (if (null n) (setq n 360))
   (if
       (and en
           (setq lst
               (mapcar
                   (function (lambda ( x ) (trans x 0 en)))
                   (LM:LWPoly->List en n)
               )
           )
           (setq lst (LM:MinEncCircle lst))
       )
       (setq ci 
       (entmakex
           (list
               (cons 0 "CIRCLE")
               (cons 10 (car  lst))
               (cons 40 (cadr lst))
               (cons 62 2)
               (assoc 210 (entget en))
           )
       ))
   )
   (setq ptse1e2 (interse1e2 en ci))
   (setq plpts (mapcar '(lambda (x) (cdr x)) (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget en)) ))
   (foreach pt ptse1e2
       (mapcar '(lambda (x) (if (equal (list (car pt) (cadr pt)) x 1e-6) (progn (setq tst (cons T tst)) (setq ptl (cons pt ptl))  ))) plpts)
   )
   (if (and (= (length tst) 2) (= (length ptse1e2) 4))
       (progn
       (setq ptse1e2arcs (vl-remove (car ptl) ptse1e2))
       (setq ptse1e2arcs (vl-remove (cadr ptl) ptse1e2arcs))
       (entdel ci)
       (if (eq (vl-cmdf "_.circle" "3P" "_end" (car ptl) "_end" (cadr ptl) "_tan" (car ptse1e2arcs)) nil) (entmake ci))
       )
   )
   (if (and (= (length tst) 1) (= (length ptse1e2) 3))
       (progn
       (setq ptse1e2arcs (vl-remove (car ptl) ptse1e2))
       (entdel ci)
       (if (eq (vl-cmdf "_.circle" "2P" "_end" (car ptl) "_tan" (car ptse1e2arcs)) nil) (entmake ci))
       )
   )
   (if (and (= (length tst) 1) (= (length ptse1e2) 5))
       (progn
       (setq ptse1e2arcs (vl-remove (car ptl) ptse1e2))
       (setq pta1 (car ptse1e2arcs))
       (setq pta2 (FurthestFromPoint ptse1e2arcs pta1))        
       (entdel ci)
       (if (eq (vl-cmdf "_.circle" "3P" "_end" (car ptl) "_tan" pta1 "_tan" pta2) nil) (entmake ci))
       )
   )
   (if (and (null tst) (= (length ptse1e2) 6))
       (progn
       (setq ptse1e2arcs ptse1e2)
       (setq pta1 (car ptse1e2arcs))
       (setq pta11 (NearestFromPoint ptse1e2arcs pta1))
       (setq ptse1e2arcs (vl-remove pta11 ptse1e2arcs))
       (setq pta2 (NearestFromPoint ptse1e2arcs pta1))
       (setq pta22 (NearestFromPoint ptse1e2arcs pta2))
       (setq ptse1e2arcs (vl-remove pta22 ptse1e2arcs))
       (setq pta3 (NearestFromPoint ptse1e2arcs pta2))
       (entdel ci)
       (if (eq (vl-cmdf "_.circle" "3P" "_tan" pta1 "_tan" pta2 "_tan" pta3) nil) (entmake ci))
       )
   )
   (if (and (null tst) (= (length ptse1e2) 4))
       (progn
       (setq ptse1e2arcs ptse1e2)
       (setq pta1 (car ptse1e2arcs))
       (setq pta11 (NearestFromPoint ptse1e2arcs pta1))
       (setq ptse1e2arcs (vl-remove pta11 ptse1e2arcs))
       (setq pta2 (NearestFromPoint ptse1e2arcs pta1))
       (entdel ci)
       (if (eq (vl-cmdf "_.circle" "2P" "_tan" pta1 "_tan" pta2) nil) (entmake ci))
       )
   )
   (setvar 'aperture app)
   (setvar 'osmode osm)
   (princ)
)

Regards, M.R.

Edited October 18, 2011 by marko_ribar
code revised

October 18, 2011

There was little my mistake... I apologize - code revised...

M.R.

October 18, 2011

I didn't think it needed any modification

October 18, 2011

Lee, if you want to help, you're always welcome... I think that code can be used to found correct solution (circle must touch arcs in single point)... I have difficulties to accomplish this as it now either gives solution or not at all. I don't know how to exclude (vl-cmdf "_.circle" ... "_tan" pt ...) if it doesn't create perfect solution, and leave your circle now in yellow color... The code is almost perfect, but still I don't quite know how to finish it to be perfect...

M.R.

Smallest Circumscribing Circle

Recommended Posts

pBe

Link to comment

Share on other sites

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Popular Posts

marko_ribar

Posted Images

Lee Mac

Link to comment

Share on other sites

marko_ribar

Link to comment

Share on other sites

marko_ribar

Link to comment

Share on other sites

marko_ribar

Link to comment

Share on other sites

marko_ribar

Link to comment

Share on other sites

marko_ribar

Link to comment

Share on other sites

Manila Wolf

Link to comment

Share on other sites

Lee Mac

Link to comment

Share on other sites

pBe

Link to comment

Share on other sites

Lee Mac

Link to comment

Share on other sites

Manila Wolf

Link to comment

Share on other sites

pBe

Link to comment

Share on other sites

marko_ribar

Link to comment

Share on other sites

Lee Mac

Link to comment

Share on other sites

marko_ribar

Link to comment

Share on other sites

marko_ribar

Link to comment

Share on other sites

marko_ribar

Link to comment

Share on other sites

Lee Mac

Link to comment

Share on other sites

marko_ribar

Link to comment

Share on other sites

Join the conversation

Tutorials

Forums

Activity