Author Topic: === {Challenge} === - Convert PELLIPSE to ELLIPSE  (Read 3971 times)

0 Members and 1 Guest are viewing this topic.

ribarm

  • Gator
  • Posts: 3180
  • Marko Ribar, architect
=== {Challenge} === - Convert PELLIPSE to ELLIPSE
« on: October 11, 2014, 04:52:54 AM »
This one it heavy for my standards, so I've named it Challenge...

First of all, I want to thank to Mr. Gilles Chanteau for his wonderful subfunction and give him kudos and my big gratitude for all of his work and this routine as an author...

Code: [Select]
;; EllipseToPolyline
;; Returns a polyline (vla-object) which is an approximation of the ellipse (or elliptical arc)
;;
;; Argument : an ellipse (vla-object)

(defun EllipseToPolyline (el    /     *acdoc*     cl    norm  cen
                          elv   pt0   pt1   pt2   pt3   pt4   ac0
                          ac4   a04   a02   a24   bsc0  bsc2  bsc3
                          bsc4  plst  blst  spt   spa   fspa  srat
                          ept   epa   fepa  erat  n
                         )
  (vl-load-com)
  (setq cl      (equal (ang<2pi (vla-get-StartAngle el))
                       (ang<2pi (vla-get-EndAngle el))
                       1e-6
                )
        *acdoc* (vla-get-activedocument (vlax-get-acad-object))
        norm    (vlax-get el 'Normal)
        cen     (trans (vlax-get el 'Center) 0 norm)
        elv     (caddr cen)
        cen     (3dTo2dPt cen)
        pt0     (mapcar '+ (trans (vlax-get el 'MajorAxis) 0 norm) cen)
        ac0     (angle cen pt0)
        pt4     (mapcar '+ cen (trans (vlax-get el 'MinorAxis) 0 norm))
        pt2     (3dTo2dPt
                  (trans (vlax-curve-getPointAtparam el (/ pi 4.)) 0 norm)
                )
        ac4     (angle cen pt4)
        a04     (angle pt0 pt4)
        a02     (angle pt0 pt2)
        a24     (angle pt2 pt4)
        bsc0    (/ (ang<2pi (- a02 ac4)) 2.)
        bsc2    (/ (ang<2pi (- a04 a02)) 2.)
        bsc3    (/ (ang<2pi (- a24 a04)) 2.)
        bsc4    (/ (ang<2pi (- (+ ac0 pi) a24)) 2.)
        pt1     (inters pt0
                        (polar pt0 (+ ac0 (/ pi 2.) bsc0) 1.)
                        pt2
                        (polar pt2 (+ a02 bsc2) 1.)
                        nil
                )
        pt3     (inters pt2
                        (polar pt2 (+ a04 bsc3) 1.)
                        pt4
                        (polar pt4 (+ a24 bsc4) 1.)
                        nil
                )
        plst    (list pt4 pt3 pt2 pt1 pt0)
        blst    (mapcar '(lambda (b) (tan (/ b 2.)))
                        (list bsc4 bsc3 bsc2 bsc0)
                )
  )
  (foreach b blst
    (setq blst (cons b blst))
  )
  (foreach b blst
    (setq blst (cons b blst))
  )
  (foreach p (cdr plst)
    (setq ang  (angle cen p)
          plst (cons
                 (polar cen (+ ang (* 2 (- ac4 ang))) (distance cen p))
                 plst
               )
    )
  )
  (foreach p (cdr plst)
    (setq ang  (angle cen p)
          plst (cons
                 (polar cen (+ ang (* 2 (- ac0 ang))) (distance cen p))
                 plst
               )
    )
  )
  (setq vlaLayout (vla-ObjectIdToObject *acdoc* (vla-get-OwnerId el)))
  (setq pl
         (vlax-invoke
           vlaLayout
           'AddLightWeightPolyline
           (apply 'append
                  (setq plst
                         (reverse (if cl
                                    (cdr plst)
                                    plst
                                  )
                         )
                  )
           )
         )
  )
  (vlax-put pl 'Normal norm)
  (vla-put-Elevation pl elv)
  (mapcar '(lambda (i v) (vla-SetBulge pl i v))
          '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16)
          blst
  )
  (if cl
    (vla-put-Closed pl :vlax-true)
    (progn
      (setq spt  (vlax-curve-getClosestPointTo pl (vlax-get el 'Startpoint))
            spa  (vlax-curve-getParamAtPoint pl spt)
            fspa (fix spa)
            ept  (vlax-curve-getClosestPointTo pl (vlax-get el 'Endpoint))
            epa  (vlax-curve-getParamAtPoint pl ept)
            fepa (fix epa)
            n    0
      )
      (cond
        ((equal spt (trans pt0 norm 0) 1e-9)
         (if (= epa fepa)
           (setq plst (sublist plst 0 (1+ fepa))
                 blst (sublist blst 0 (1+ fepa))
           )
           (setq erat (/ (- (vlax-curve-getDistAtParam pl epa)
                            (vlax-curve-getDistAtParam pl fepa)
                         )
                         (- (vlax-curve-getDistAtParam pl (rem (1+ fepa) 17))
                            (vlax-curve-getDistAtParam pl fepa)
                         )
                      )
                 plst (append (sublist plst 0 (1+ fepa))
                              (list (3dTo2dPt (trans ept 0 norm)))
                      )
                 blst (append (sublist blst 0 (1+ fepa))
                              (list (k*bulge (nth fepa blst) erat))
                      )
           )
         )
        )
        ((equal ept (trans pt0 norm 0) 1e-9)
         (if (= spa fspa)
           (setq plst (sublist plst fspa nil)
                 blst (sublist blst fspa nil)
           )
           (setq srat (/ (- (vlax-curve-getDistAtParam pl (rem (1+ fspa) 17))
                            (vlax-curve-getDistAtParam pl spa)
                         )
                         (- (vlax-curve-getDistAtParam pl (rem (1+ fspa) 17))
                            (vlax-curve-getDistAtParam pl fspa)
                         )
                      )
                 plst (cons (3dTo2dPt (trans spt 0 norm))
                            (sublist plst (1+ fspa) nil)
                      )
                 blst (cons (k*bulge (nth fspa blst) srat)
                            (sublist blst (1+ fspa) nil)
                      )
           )
         )
        )
        (T
         (setq srat (/ (- (vlax-curve-getDistAtParam pl (rem (1+ fspa) 17))
                          (vlax-curve-getDistAtParam pl spa)
                       )
                       (- (vlax-curve-getDistAtParam pl (rem (1+ fspa) 17))
                          (vlax-curve-getDistAtParam pl fspa)
                       )
                    )
               erat (/ (- (vlax-curve-getDistAtParam pl epa)
                          (vlax-curve-getDistAtParam pl fepa)
                       )
                       (- (vlax-curve-getDistAtParam pl (rem (1+ fepa) 17))
                          (vlax-curve-getDistAtParam pl fepa)
                       )
                    )
         )
         (if (< epa spa)
           (setq plst (append
                        (if (= spa fspa)
                          (sublist plst fspa nil)
                          (cons (3dTo2dPt (trans spt 0 norm))
                                (sublist plst (1+ fspa) nil)
                          )
                        )
                        (cdr (sublist plst 0 (1+ fepa)))
                        (if (/= epa fepa)
                          (list (3dTo2dPt (trans ept 0 norm)))
                        )
                      )
                 blst (append
                        (if (= spa fspa)
                          (sublist blst fspa nil)
                          (cons
                            (k*bulge (nth fspa blst) srat)
                            (sublist blst (1+ fspa) nil)
                          )
                        )
                        (sublist blst 0 fepa)
                        (if (= epa fepa)
                          (list (nth fepa blst))
                          (list (k*bulge (nth fepa blst) erat))
                        )
                      )
           )
           (setq plst (append
                        (if (= spa fspa)
                          (sublist plst fspa (1+ (- fepa fspa)))
                          (cons (3dTo2dPt (trans spt 0 norm))
                                (sublist plst (1+ fspa) (- fepa fspa))
                          )
                        )
                        (list (3dTo2dPt (trans ept 0 norm)))
                      )
                 blst (append
                        (if (= spa fspa)
                          (sublist blst fspa (- fepa fspa))
                          (cons
                            (k*bulge (nth fspa blst) srat)
                            (sublist blst (1+ fspa) (- fepa fspa))
                          )
                        )
                        (if (= epa fepa)
                          (list (nth fepa blst))
                          (list (k*bulge (nth fepa blst) erat))
                        )
                      )
           )
         )
        )
      )
      (vlax-put pl 'Coordinates (apply 'append plst))
      (foreach b blst
        (vla-SetBulge pl n b)
        (setq n (1+ n))
      )
    )
  )
  pl
)

;; Ang<2pi
;; Returns the angle expression betweem 0 and 2*pi
(defun ang<2pi (ang)
  (if (and (<= 0 ang) (< ang (* 2 pi)))
    ang
    (ang<2pi (rem (+ ang (* 2 pi)) (* 2 pi)))
  )
)

;; 3dTo2dPt
;; Returns the 2d point (x y) of a 3d point (x y z)
(defun 3dTo2dPt (pt) (list (car pt) (cadr pt)))

;; Tan
;; Returns the angle tangent
(defun tan (a) (/ (sin a) (cos a)))

;; SUBLIST
;; Returns a sub list
;;
;; Arguments
;; lst : a list
;; start : start index (first item = 0)
;; leng : the sub list length (number of items) or nil
(defun sublist (lst start leng / n r)
  (if (or (not leng) (< (- (length lst) start) leng))
    (setq leng (- (length lst) start))
  )
  (setq n (+ start leng))
  (while (< start n)
    (setq r (cons (nth (setq n (1- n)) lst) r))
  )
)

;; K*BULGE
;; Returns the proportinal bulge to the référence bulge
;; Arguments :
;; b : the bulge
;; k : the proportion ratio (between angles or arcs length)
(defun k*bulge (b k / a)
  (setq a (atan b))
  (/ (sin (* k a)) (cos (* k a)))
)

;; EL2PL
;; Converts ellipses and elliptcal arcs into polylines
(defun c:el2pl (/ *error* fra acdoc ss lwa lw ell lwd)

  (vl-load-com)

  (defun *error* (msg)
    (if msg
      (prompt msg)
    )
    (vla-endUndoMark acdoc)
    (princ)
  )

  (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (if (ssget "_:L" '((0 . "ELLIPSE")))
    (progn
      (vla-StartUndoMark acdoc)
      (vlax-for e (setq ss (vla-get-ActiveSelectionSet acdoc))
        (setq lwa (EllipseToPolyline e))
        (setq lw (vlax-vla-object->ename lwa))
        (setq ell (vlax-vla-object->ename e))
        (entupd (cdr (assoc -1 (entmod (subst (assoc 8 (entget ell)) (assoc 8 (entget lw)) (entget lw))))))
        (setq lwd (entget lw))
        (entupd (cdr (assoc -1 (entmod (vl-remove nil (append lwd (list (if (assoc 62 (entget ell)) (assoc 62 (entget ell))) (if (assoc 420 (entget ell)) (assoc 420 (entget ell))))))))))
        (vla-delete e)
      )
      (vla-delete ss)
    )
  )
  (*error* nil)
)

;; PELL
;; Draws an ellipse or an elliptical arc approximation (polyline) on the fly
(defun c:pell (/ *error* ec pe old ent lwa lw lwd)

  (vl-load-com)

  (defun *error* (msg)
    (if msg
      (prompt msg)
    )
    (setvar 'cmdecho ec)
    (setvar 'pellipse pe)
    (princ)
  )

  (setq ec  (getvar 'cmdecho)
        pe  (getvar 'pellipse)
        old (entlast)
  )
  (setvar 'cmdecho 1)
  (setvar 'pellipse 0)
  (command "_.ellipse")
  (while (/= 0 (getvar 'cmdactive))
    (command pause)
  )
  (if (not (eq old (setq ent (entlast))))
    (progn
      (setq lwa (EllipseToPolyline (vlax-ename->vla-object ent)))
      (setq lw (vlax-vla-object->ename lwa))
      (entupd (cdr (assoc -1 (entmod (subst (assoc 8 (entget ent)) (assoc 8 (entget lw)) (entget lw))))))
      (setq lwd (entget lw))
      (entupd (cdr (assoc -1 (entmod (vl-remove nil (append lwd (list (if (assoc 62 (entget ent)) (assoc 62 (entget ent))) (if (assoc 420 (entget ent)) (assoc 420 (entget ent))))))))))
      (entdel ent)
    )
  )
  (*error* nil)
)

Somewhere on the www., I've also found routine for converting circles to lwpolylines that may be of interest...

Code: [Select]
(defun c:ci2lw ( / ss i ent dxf_ent pt_cen radius fst_pt opp_pt new_ep )
  (princ "\nSelect a circles to be converted into a donuts - LWPOLYLINES...")
  (while (null (setq ss (ssget "_:L" '((0 . "CIRCLE")))))
    (princ "\nEmpty sel.set... Try again...")
  )
  (princ "\nThickness of donut <")
  (princ (getvar "PLINEWID"))
  (princ ">: ")
  (initget 68)
  (setq new_ep (getdist))
  (if new_ep (setvar "PLINEWID" new_ep))
  (repeat (setq i (sslength ss))
    (setq
      ent (ssname ss (setq i (1- i)))
      dxf_ent (entget ent)
      pt_cen (cdr (assoc 10 dxf_ent))
      radius (cdr (assoc 40 dxf_ent))
      fst_pt (polar pt_cen 0.0 radius)
      opp_pt (polar pt_cen pi radius)
    )
    (entmake
      (vl-remove nil
        (list
          '(0 . "LWPOLYLINE")
          '(100 . "AcDbEntity")
          (assoc 67 dxf_ent)
          (assoc 410 dxf_ent)
          (assoc 8 dxf_ent)
          (if (assoc 6 dxf_ent) (assoc 6 dxf_ent) '(6 . "BYLAYER"))
          (if (assoc 62 dxf_ent) (assoc 62 dxf_ent) '(62 . 256))
          (if (assoc 420 dxf_ent) (assoc 420 dxf_ent))
          (if (assoc 370 dxf_ent) (assoc 370 dxf_ent) '(370 . -3))
          (if (assoc 48 dxf_ent) (assoc 48 dxf_ent) '(48 . 1.0))
          '(100 . "AcDbPolyline")
          '(90 . 2)
          '(70 . 1)
          (cons 43 (getvar "PLINEWID"))
          (cons 38 (caddr pt_cen))
          (if (assoc 39 dxf_ent) (assoc 39 dxf_ent) '(39 . 0.0))
          (cons 10 (list (car fst_pt) (cadr fst_pt)))
          '(40 . 0.0)
          '(41 . 0.0)
          '(42 . 1.0)
          (cons 10 (list (car opp_pt) (cadr opp_pt)))
          '(40 . 0.0)
          '(41 . 0.0)
          '(42 . 1.0)
          (assoc 210 dxf_ent)
        )
      )
    )
    (entdel ent)
  )
  (princ)
)

(defun c:lwc ( / cmd ent dxf_ent pt_cen radius fst_pt opp_pt new_ep )
  (setq cmd (getvar 'cmdecho))
  (setvar 'cmdecho 1)
  (command "_.CIRCLE")
  (while (> (getvar 'cmdactive) 0) (command "\\"))
  (setq
    ent (entlast)
    dxf_ent (entget ent)
    pt_cen (cdr (assoc 10 dxf_ent))
    radius (cdr (assoc 40 dxf_ent))
    fst_pt (polar pt_cen 0.0 radius)
    opp_pt (polar pt_cen pi radius)
  )
  (entmake
    (vl-remove nil
      (list
        '(0 . "LWPOLYLINE")
        '(100 . "AcDbEntity")
        (assoc 67 dxf_ent)
        (assoc 410 dxf_ent)
        (assoc 8 dxf_ent)
        (if (assoc 6 dxf_ent) (assoc 6 dxf_ent) '(6 . "BYLAYER"))
        (if (assoc 62 dxf_ent) (assoc 62 dxf_ent) '(62 . 256))
        (if (assoc 420 dxf_ent) (assoc 420 dxf_ent))
        (if (assoc 370 dxf_ent) (assoc 370 dxf_ent) '(370 . -3))
        (if (assoc 48 dxf_ent) (assoc 48 dxf_ent) '(48 . 1.0))
        '(100 . "AcDbPolyline")
        '(90 . 2)
        '(70 . 1)
        (cons 43 (getvar "PLINEWID"))
        (cons 38 (caddr pt_cen))
        (if (assoc 39 dxf_ent) (assoc 39 dxf_ent) '(39 . 0.0))
        (cons 10 (list (car fst_pt) (cadr fst_pt)))
        '(40 . 0.0)
        '(41 . 0.0)
        '(42 . 1.0)
        (cons 10 (list (car opp_pt) (cadr opp_pt)))
        '(40 . 0.0)
        '(41 . 0.0)
        '(42 . 1.0)
        (assoc 210 dxf_ent)
      )
    )
  )
  (entdel ent)
  (setvar 'cmdecho cmd)
  (princ)
)

And according to routines for converting circles to lwpolylines, I wrote this shot version that does just opposite - lw2ci.lsp

Code: [Select]
(defun c:lw2ci ( / ss i lw c r ci )
  (setq ss (ssget "_:L" '((0 . "LWPOLYLINE") (-4 . "&=") (70 . 1) (90 . 2) (-4 . "<or") (42 . 1.0) (42 . -1.0) (-4 . "or>"))))
  (repeat (setq i (sslength ss))
    (setq lw (ssname ss (setq i (1- i))))
    (setq lw (entget lw))
    (setq c (mapcar '+ (cdr (assoc 10 lw)) (mapcar '/ (mapcar '- (cdr (assoc 10 (reverse lw))) (cdr (assoc 10 lw))) '(2.0 2.0 2.0))))
    (setq r (distance c (cdr (assoc 10 lw))))
    (setq c (list (car c) (cadr c) (cdr (assoc 38 lw))))
    (setq ci (entmakex (vl-remove nil (list '(0 . "CIRCLE") '(100 . "AcDbEntity") '(100 . "AcDbCircle") (assoc 8 lw) (if (assoc 62 lw) (assoc 62 lw)) (if (assoc 420 lw) (assoc 420 lw)) (cons 10 c) (cons 40 r) (assoc 210 lw)))))
    (if ci (entdel (cdr (assoc -1 lw))))
  )
  (princ)
)

So my question and challenge : Can Gilles's routines LWPOLYLINES be converted back to corresponding ELLIPSES or ELLIPTIC ARCS... (If someone knows this, will he/she be willing to share this achievement with us?)
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

irneb

  • Water Moccasin
  • Posts: 1794
  • ACad R9-2016, Revit Arch 6-2016
Re: === {Challenge} === - Convert PELLIPSE to ELLIPSE
« Reply #1 on: October 11, 2014, 05:49:50 AM »
Just a guess here ... what's needed to draw an ellipse? Centre point, long-axis radius vector, short-axis radius vector.

Now, how would you go about finding those from a polyline? Tip: Think ITO opposite sides of the polyline, finding longest and shortest opposing points. If you know the polyline was made through such code (or using the pellipse sysvar) then you know that the polyline's vectors would start and end on these points too - thus it becomes a lot simpler.

For elliptical arcs it might be a lot more complicated and need some math to interpolate the ellipse's formula from the points on the PL "curve".
« Last Edit: October 11, 2014, 05:54:56 AM by irneb »
Common sense - the curse in disguise. Because if you have it, you have to live with those that don't.

Lee Mac

  • Seagull
  • Posts: 12892
  • London, England
Re: === {Challenge} === - Convert PELLIPSE to ELLIPSE
« Reply #2 on: October 11, 2014, 07:23:06 AM »
You could take 5 arbitrary points around the polyline and then use this (related Swamp thread here).

Attached is a first draft of this method.

Lee
« Last Edit: October 11, 2014, 08:28:25 AM by Lee Mac »

ribarm

  • Gator
  • Posts: 3180
  • Marko Ribar, architect
Re: === {Challenge} === - Convert PELLIPSE to ELLIPSE
« Reply #3 on: October 11, 2014, 10:43:58 AM »
Thanks, Lee... I had some trouble finding all components correctly, ellipse center among others... But finally, I did it... It should work in any UCS and with elliptical arcs...

Code: [Select]
;; Polyline Ellipse to Ellipse  -  Lee Mac
;; Prompts the user for a selection of polylines approximating ellipses (PELLIPSEs)
;; and attempts to convert each polyline to an appropriate ellipse, retaining all properties.

(defun c:pl2ell ( / dis ell ent enx idx inc lst sel pst pen el e p ) (vl-load-com)
    (if (setq sel (ssget "_:L" '((0 . "*POLYLINE") (-4 . "<NOT") (-4 . "&") (70 . 88) (-4 . "NOT>"))))
        (repeat (setq idx (sslength sel))
            (setq ent (ssname sel (setq idx (1- idx)))
                  inc (/ (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent)) 5)
                  enx (entget ent)
                  dis 0.0
                  lst nil
                  pst (vlax-curve-getstartpoint ent)
                  pen (vlax-curve-getendpoint ent)
            )
            (repeat 5
                (setq lst (cons (trans (vlax-curve-getpointatdist ent dis) 0 ent) lst)
                      dis (+ dis inc)
                )
            )
            (if (and (setq ell (apply 'LM:5p-ellipse (cons ent (cons (caddar lst) lst))))
                    (setq el
                        (entmakex
                            (append
                               '(
                                    (000 . "ELLIPSE")
                                    (100 . "AcDbEntity")
                                    (100 . "AcDbEllipse")
                                )
                                (LM:defaultprops enx) ell
                                (list (assoc 210 enx))
                            )
                        )
                    )
                )
                (entdel ent)
            )
            (if (not (equal pst pen 1e-6))
              (progn
                (setq e (entlast))
                (command "_.ZOOM" "_OB" el "")
                (command "_.LINE" "_non" (trans pst 0 1) "_non" (trans pen 0 1) "")
                (command "_.UCS" "_M" "_non" (trans pst 0 1))
                (command "_.UCS" "_ZA" "" (cdr (assoc 210 enx)))
                (command "_.TRIM" "_L" "" (trans (vlax-curve-getclosestpointto e (trans (cadr lst) (cdr (assoc 210 enx)) 0)) 0 1) "")
                (setq p (vlax-curve-getpointatparam e (+ (vlax-curve-getstartparam e) (/ (- (vlax-curve-getendparam e) (vlax-curve-getstartparam e)) 2.0))))
                (command "_.UNDO" "")
                (command "_.TRIM" "_L" "" (trans p 0 1) "")
                (command "_.UCS" "_P")
                (command "_.UCS" "_P")
                (command "_.ZOOM" "_P")
                (entdel (entlast))
              )
            )
        )
    )
    (princ)
)

;; Default Properties  -  Lee Mac
;; Returns a list of DXF properties for the supplied DXF data,
;; substituting default values for absent DXF groups
 
(defun LM:defaultprops ( enx )
    (vl-remove nil
        (mapcar '(lambda ( x ) (cond ((assoc (car x) enx)) ((not (assoc (car x) enx)) nil) ( x )))
           '(
                (006 . "BYLAYER")
                (008 . "0")
                (039 . 0.0)
                (048 . 1.0)
                (062 . 256)
                (370 . -1)
                (420 . 16777215)
            )
        )
    )
)
;; 5-Point Ellipse  -  Lee Mac
;; Args: p1,p2,p3,p4,p5 - UCS points defining Ellipse
;; Returns a list of: ((10 <WCS Center>) (11 <WCS Major Axis Endpoint from Center>) (40 . <Minor/Major Ratio>))
;; Version 1.1 - 2013-11-28

(defun LM:5P-Ellipse ( ent elev p1 p2 p3 p4 p5 / a av b c cf cx cy d e f i m1 m2 rl v x )
    (setq m1
        (trp
            (mapcar
                (function
                    (lambda ( p )
                        (list
                            (* (car  p) (car  p))
                            (* (car  p) (cadr p))
                            (* (cadr p) (cadr p))
                            (car  p)
                            (cadr p)
                            1.0
                        )
                    )
                )
                (list p1 p2 p3 p4 p5)
            )
        )
    )
    (setq i -1.0)
    (repeat 6
        (setq cf (cons (* (setq i (- i)) (detm (trp (append (reverse m2) (cdr m1))))) cf)
              m2 (cons (car m1) m2)
              m1 (cdr m1)
        )
    )
    (mapcar 'set '(f e d c b a) cf) ;; Coefficients of Conic equation ax^2 + bxy + cy^2 + dx + ey + f = 0
    (if (< 0 (setq x (- (* 4.0 a c) (* b b))))
        (progn
            (if (equal 0.0 b 1e-8) ;; Ellipse parallel to coordinate axes
                (setq av '((1.0 0.0) (0.0 1.0))) ;; Axis vectors
                (setq av
                    (mapcar
                        (function
                            (lambda ( v / d )
                                (setq v (list (/ b 2.0) (- v a)) ;; Eigenvectors
                                      d (distance '(0.0 0.0) v)
                                )
                                (mapcar '/ v (list d d))
                            )
                        )
                        (quad 1.0 (- (+ a c)) (- (* a c) (* 0.25 b b))) ;; Eigenvalues
                    )
                )
            )
            (setq cx (/ (- (* b e) (* 2.0 c d)) x) ;; Ellipse Center
                  cy (/ (- (* b d) (* 2.0 a e)) x)
            )
            ;; For radii, solve intersection of axis vectors with Conic Equation:
            ;; ax^2 + bxy + cy^2 + dx + ey + f = 0  }
            ;; x = cx + vx(t)                       }- solve for t
            ;; y = cy + vy(t)                       }
            (setq rl
                (mapcar
                    (function
                        (lambda ( v / vv vx vy )
                            (setq vv (mapcar '* v v)
                                  vx (car  v)
                                  vy (cadr v)
                            )
                            (apply 'max
                                (quad
                                    (+ (* a (car vv)) (* b vx vy) (* c (cadr vv)))
                                    (+ (* 2.0 a cx vx) (* b (+ (* cx vy) (* cy vx))) (* c 2.0 cy vy) (* d vx) (* e vy))
                                    (+ (* a cx cx) (* b cx cy) (* c cy cy) (* d cx) (* e cy) f)
                                )
                            )
                        )
                    )
                    av
                )
            )
            (if (apply '> rl)
                (setq rl (reverse rl)
                      av (reverse av)
                )
            )
            (list
                (cons 10 (trans (list cx cy elev) ent 0)) ;; WCS Ellipse Center
                (cons 11 (trans (mapcar '(lambda ( v ) (* v (cadr rl))) (cadr av)) ent 0)) ;; WCS Major Axis Endpoint from Center
                (cons 40 (apply '/ rl)) ;; minor/major ratio
            )
        )
    )
)

;; Matrix Determinant (Upper Triangular Form)  -  ElpanovEvgeniy
;; Args: m - nxn matrix

(defun detm ( m / d )
    (cond
        (   (null m) 1)
        (   (and (zerop (caar m))
                 (setq d (car (vl-member-if-not (function (lambda ( a ) (zerop (car a)))) (cdr m))))
            )
            (detm (cons (mapcar '+ (car m) d) (cdr m)))
        )
        (   (zerop (caar m)) 0)
        (   (*  (caar m)
                (detm
                    (mapcar
                        (function
                            (lambda ( a / d ) (setq d (/ (car a) (float (caar m))))
                                (mapcar
                                    (function
                                        (lambda ( b c ) (- b (* c d)))
                                    )
                                    (cdr a) (cdar m)
                                )
                            )
                        )
                        (cdr m)
                    )
                )
            )
        )
    )
)

;; Matrix Transpose  -  Doug Wilson
;; Args: m - nxn matrix

(defun trp ( m )
    (apply 'mapcar (cons 'list m))
)

;; Quadratic Solution  -  Lee Mac
;; Args: a,b,c - coefficients of ax^2 + bx + c = 0

(defun quad ( a b c / d r )
    (if (<= 0 (setq d (- (* b b) (* 4.0 a c))))
        (progn
            (setq r (sqrt d))
            (list (/ (+ (- b) r) (* 2.0 a)) (/ (- (- b) r) (* 2.0 a)))
        )
    )
)

Regards, Marko R.

[EDIT:] Added new code, after I saw Lee's answer...[/EDIT]

Code: [Select]
;; Polyline Ellipse to Ellipse  -  Lee Mac
;; Prompts the user for a selection of polylines approximating ellipses (PELLIPSEs)
;; and attempts to convert each polyline to an appropriate ellipse, retaining all properties.

(defun c:pl2ell ( / dis ell ent enx idx inc lst ocs sel ) (vl-load-com)
    (if (setq sel (ssget "_:L" '((0 . "*POLYLINE") (-4 . "<NOT") (-4 . "&") (70 . 88) (-4 . "NOT>"))))
        (repeat (setq idx (sslength sel))
            (setq ent (ssname sel (setq idx (1- idx)))
                  inc (/ (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent)) 5)
                  enx (entget ent)
                  ocs (assoc 210 enx)
                  dis 0.0
                  lst nil
            )
            (repeat 5
                (setq lst (cons (trans (vlax-curve-getpointatdist ent dis) 0 ent) lst)
                      dis (+ dis inc)
                )
            )
            (if (and (setq ell (apply 'LM:5p-ellipse (cons ent (cons (caddar lst) lst))))
                    (entmakex
                        (append
                           '(
                                (000 . "ELLIPSE")
                                (100 . "AcDbEntity")
                                (100 . "AcDbEllipse")
                            )
                            (LM:defaultprops enx) ell
                            (if (not (vlax-curve-isclosed ent))
                                (list
                                    (cons 41 (LM:point->param (cons ocs ell) (vlax-curve-getstartpoint ent)))
                                    (cons 42 (LM:point->param (cons ocs ell) (vlax-curve-getendpoint   ent)))
                                )
                            )
                            (list ocs)
                        )
                    )
                )
                (entdel ent)
            )
        )
    )
    (princ)
)

;; Default Properties  -  Lee Mac
;; Returns a list of DXF properties for the supplied DXF data,
;; substituting default values for absent DXF groups
 
(defun LM:defaultprops ( enx )
    (vl-remove nil
        (mapcar '(lambda ( x ) (cond ((assoc (car x) enx)) ((not (assoc (car x) enx)) nil) ( x )))
           '(
                (006 . "BYLAYER")
                (008 . "0")
                (039 . 0.0)
                (048 . 1.0)
                (062 . 256)
                (370 . -1)
                (420 . 16777215)
            )
        )
    )
)

;; 5-Point Ellipse  -  Lee Mac
;; Args: p1,p2,p3,p4,p5 - UCS points defining Ellipse
;; Returns a list of: ((10 <WCS Center>) (11 <WCS Major Axis Endpoint from Center>) (40 . <Minor/Major Ratio>))
;; Version 1.1 - 2013-11-28

(defun LM:5P-Ellipse ( ent elev p1 p2 p3 p4 p5 / a av b c cf cx cy d e f i m1 m2 rl v x )
    (setq m1
        (trp
            (mapcar
                (function
                    (lambda ( p )
                        (list
                            (* (car  p) (car  p))
                            (* (car  p) (cadr p))
                            (* (cadr p) (cadr p))
                            (car  p)
                            (cadr p)
                            1.0
                        )
                    )
                )
                (list p1 p2 p3 p4 p5)
            )
        )
    )
    (setq i -1.0)
    (repeat 6
        (setq cf (cons (* (setq i (- i)) (detm (trp (append (reverse m2) (cdr m1))))) cf)
              m2 (cons (car m1) m2)
              m1 (cdr m1)
        )
    )
    (mapcar 'set '(f e d c b a) cf) ;; Coefficients of Conic equation ax^2 + bxy + cy^2 + dx + ey + f = 0
    (if (< 0 (setq x (- (* 4.0 a c) (* b b))))
        (progn
            (if (equal 0.0 b 1e-8) ;; Ellipse parallel to coordinate axes
                (setq av '((1.0 0.0) (0.0 1.0))) ;; Axis vectors
                (setq av
                    (mapcar
                        (function
                            (lambda ( v / d )
                                (setq v (list (/ b 2.0) (- v a)) ;; Eigenvectors
                                      d (distance '(0.0 0.0) v)
                                )
                                (mapcar '/ v (list d d))
                            )
                        )
                        (quad 1.0 (- (+ a c)) (- (* a c) (* 0.25 b b))) ;; Eigenvalues
                    )
                )
            )
            (setq cx (/ (- (* b e) (* 2.0 c d)) x) ;; Ellipse Center
                  cy (/ (- (* b d) (* 2.0 a e)) x)
            )
            ;; For radii, solve intersection of axis vectors with Conic Equation:
            ;; ax^2 + bxy + cy^2 + dx + ey + f = 0  }
            ;; x = cx + vx(t)                       }- solve for t
            ;; y = cy + vy(t)                       }
            (setq rl
                (mapcar
                    (function
                        (lambda ( v / vv vx vy )
                            (setq vv (mapcar '* v v)
                                  vx (car  v)
                                  vy (cadr v)
                            )
                            (apply 'max
                                (quad
                                    (+ (* a (car vv)) (* b vx vy) (* c (cadr vv)))
                                    (+ (* 2.0 a cx vx) (* b (+ (* cx vy) (* cy vx))) (* c 2.0 cy vy) (* d vx) (* e vy))
                                    (+ (* a cx cx) (* b cx cy) (* c cy cy) (* d cx) (* e cy) f)
                                )
                            )
                        )
                    )
                    av
                )
            )
            (if (apply '> rl)
                (setq rl (reverse rl)
                      av (reverse av)
                )
            )
            (list
                (cons 10 (trans (list cx cy elev) ent 0)) ;; WCS Ellipse Center
                (cons 11 (trans (mapcar '(lambda ( v ) (* v (cadr rl))) (cadr av)) ent 0)) ;; WCS Major Axis Endpoint from Center
                (cons 40 (apply '/ rl)) ;; minor/major ratio
            )
        )
    )
)

;; Matrix Determinant (Upper Triangular Form)  -  ElpanovEvgeniy
;; Args: m - nxn matrix

(defun detm ( m / d )
    (cond
        (   (null m) 1)
        (   (and (zerop (caar m))
                 (setq d (car (vl-member-if-not (function (lambda ( a ) (zerop (car a)))) (cdr m))))
            )
            (detm (cons (mapcar '+ (car m) d) (cdr m)))
        )
        (   (zerop (caar m)) 0)
        (   (*  (caar m)
                (detm
                    (mapcar
                        (function
                            (lambda ( a / d ) (setq d (/ (car a) (float (caar m))))
                                (mapcar
                                    (function
                                        (lambda ( b c ) (- b (* c d)))
                                    )
                                    (cdr a) (cdar m)
                                )
                            )
                        )
                        (cdr m)
                    )
                )
            )
        )
    )
)

;; Matrix Transpose  -  Doug Wilson
;; Args: m - nxn matrix

(defun trp ( m )
    (apply 'mapcar (cons 'list m))
)

;; Quadratic Solution  -  Lee Mac
;; Args: a,b,c - coefficients of ax^2 + bx + c = 0

(defun quad ( a b c / d r )
    (if (<= 0 (setq d (- (* b b) (* 4.0 a c))))
        (progn
            (setq r (sqrt d))
            (list (/ (+ (- b) r) (* 2.0 a)) (/ (- (- b) r) (* 2.0 a)))
        )
    )
)

;; Point -> Ellipse Parameter  -  Lee Mac
;; Returns the ellipse parameter for the given point
;; dxf  -  Ellipse DXF data (DXF groups 10, 11, 40, 210)
;; pnt  -  WCS Point on Ellipse
;; Uses relationship: ratio*tan(param) = tan(angle)

(defun LM:point->param ( dxf pnt / ang ocs )
    (setq ocs (cdr (assoc 210 dxf))
          ang (- (angle (trans (cdr (assoc 10 dxf)) 0 ocs) (trans pnt 0 ocs))
                 (angle '(0.0 0.0) (trans (cdr (assoc 11 dxf)) 0 ocs))
              )
    )
    (atan (sin ang) (* (cdr (assoc 40 dxf)) (cos ang)))
)
« Last Edit: October 12, 2014, 05:06:44 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

Lee Mac

  • Seagull
  • Posts: 12892
  • London, England
Re: === {Challenge} === - Convert PELLIPSE to ELLIPSE
« Reply #4 on: October 11, 2014, 11:53:18 AM »
The following code (also attached for convenience) should account for elliptical arcs  :-)

Code: [Select]
;; Polyline Ellipse to Ellipse  -  Lee Mac
;; Prompts the user for a selection of polylines approximating ellipses (PELLIPSEs)
;; and attempts to convert each polyline to an appropriate ellipse, retaining all properties.

(defun c:pe2e ( / dis ell ent enx idx inc lst ocs sel )
    (if (setq sel (ssget "_:L" '((0 . "POLYLINE") (-4 . "<NOT") (-4 . "&") (70 . 88) (-4 . "NOT>"))))
        (repeat (setq idx (sslength sel))
            (setq ent (ssname sel (setq idx (1- idx)))
                  inc (/ (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent)) 5)
                  enx (entget ent)
                  ocs (assoc 210 enx)
                  dis 0.0
                  lst nil
            )
            (repeat 5
                (setq lst (cons (trans (vlax-curve-getpointatdist ent dis) 0 1) lst)
                      dis (+ dis inc)
                )
            )
            (if (and (setq ell (apply 'LM:5p-ellipse lst))
                    (entmakex
                        (append
                           '(
                                (000 . "ELLIPSE")
                                (100 . "AcDbEntity")
                                (100 . "AcDbEllipse")
                            )
                            (LM:defaultprops enx) ell
                            (if (not (vlax-curve-isclosed ent))
                                (list
                                    (cons 41 (LM:point->param (cons ocs ell) (vlax-curve-getstartpoint ent)))
                                    (cons 42 (LM:point->param (cons ocs ell) (vlax-curve-getendpoint   ent)))
                                )
                            )
                            (list ocs)
                        )
                    )
                )
                (entdel ent)
            )
        )
    )
    (princ)
)

;; Default Properties  -  Lee Mac
;; Returns a list of DXF properties for the supplied DXF data,
;; substituting default values for absent DXF groups
 
(defun LM:defaultprops ( enx )
    (mapcar '(lambda ( x ) (cond ((assoc (car x) enx)) ( x )))
       '(
            (006 . "BYLAYER")
            (008 . "0")
            (039 . 0.0)
            (048 . 1.0)
            (062 . 256)
            (370 . -1)
        )
    )
)

;; 5-Point Ellipse  -  Lee Mac
;; Args: p1,p2,p3,p4,p5 - UCS points defining Ellipse
;; Returns a list of: ((10 <WCS Center>) (11 <WCS Major Axis Endpoint from Center>) (40 . <Minor/Major Ratio>))
;; Version 1.1 - 2013-11-28

(defun LM:5P-Ellipse ( p1 p2 p3 p4 p5 / a av b c cf cx cy d e f i m1 m2 rl v x )
    (setq m1
        (trp
            (mapcar
                (function
                    (lambda ( p )
                        (list
                            (* (car  p) (car  p))
                            (* (car  p) (cadr p))
                            (* (cadr p) (cadr p))
                            (car  p)
                            (cadr p)
                            1.0
                        )
                    )
                )
                (list p1 p2 p3 p4 p5)
            )
        )
    )
    (setq i -1.0)
    (repeat 6
        (setq cf (cons (* (setq i (- i)) (detm (trp (append (reverse m2) (cdr m1))))) cf)
              m2 (cons (car m1) m2)
              m1 (cdr m1)
        )
    )
    (mapcar 'set '(f e d c b a) cf) ;; Coefficients of Conic equation ax^2 + bxy + cy^2 + dx + ey + f = 0
    (if (< 0 (setq x (- (* 4.0 a c) (* b b))))
        (progn
            (if (equal 0.0 b 1e-8) ;; Ellipse parallel to coordinate axes
                (setq av '((1.0 0.0) (0.0 1.0))) ;; Axis vectors
                (setq av
                    (mapcar
                        (function
                            (lambda ( v / d )
                                (setq v (list (/ b 2.0) (- v a)) ;; Eigenvectors
                                      d (distance '(0.0 0.0) v)
                                )
                                (mapcar '/ v (list d d))
                            )
                        )
                        (quad 1.0 (- (+ a c)) (- (* a c) (* 0.25 b b))) ;; Eigenvalues
                    )
                )
            )
            (setq cx (/ (- (* b e) (* 2.0 c d)) x) ;; Ellipse Center
                  cy (/ (- (* b d) (* 2.0 a e)) x)
            )
            ;; For radii, solve intersection of axis vectors with Conic Equation:
            ;; ax^2 + bxy + cy^2 + dx + ey + f = 0  }
            ;; x = cx + vx(t)                       }- solve for t
            ;; y = cy + vy(t)                       }
            (setq rl
                (mapcar
                    (function
                        (lambda ( v / vv vx vy )
                            (setq vv (mapcar '* v v)
                                  vx (car  v)
                                  vy (cadr v)
                            )
                            (apply 'max
                                (quad
                                    (+ (* a (car vv)) (* b vx vy) (* c (cadr vv)))
                                    (+ (* 2.0 a cx vx) (* b (+ (* cx vy) (* cy vx))) (* c 2.0 cy vy) (* d vx) (* e vy))
                                    (+ (* a cx cx) (* b cx cy) (* c cy cy) (* d cx) (* e cy) f)
                                )
                            )
                        )
                    )
                    av
                )
            )
            (if (apply '> rl)
                (setq rl (reverse rl)
                      av (reverse av)
                )
            )
            (list
                (cons 10 (trans (list cx cy) 1 0)) ;; WCS Ellipse Center
                (cons 11 (trans (mapcar '(lambda ( v ) (* v (cadr rl))) (cadr av)) 1 0)) ;; WCS Major Axis Endpoint from Center
                (cons 40 (apply '/ rl)) ;; minor/major ratio
            )
        )
    )
)

;; Matrix Determinant (Upper Triangular Form)  -  ElpanovEvgeniy
;; Args: m - nxn matrix

(defun detm ( m / d )
    (cond
        (   (null m) 1)
        (   (and (zerop (caar m))
                 (setq d (car (vl-member-if-not (function (lambda ( a ) (zerop (car a)))) (cdr m))))
            )
            (detm (cons (mapcar '+ (car m) d) (cdr m)))
        )
        (   (zerop (caar m)) 0)
        (   (*  (caar m)
                (detm
                    (mapcar
                        (function
                            (lambda ( a / d ) (setq d (/ (car a) (float (caar m))))
                                (mapcar
                                    (function
                                        (lambda ( b c ) (- b (* c d)))
                                    )
                                    (cdr a) (cdar m)
                                )
                            )
                        )
                        (cdr m)
                    )
                )
            )
        )
    )
)

;; Matrix Transpose  -  Doug Wilson
;; Args: m - nxn matrix

(defun trp ( m )
    (apply 'mapcar (cons 'list m))
)

;; Quadratic Solution  -  Lee Mac
;; Args: a,b,c - coefficients of ax^2 + bx + c = 0

(defun quad ( a b c / d r )
    (if (<= 0 (setq d (- (* b b) (* 4.0 a c))))
        (progn
            (setq r (sqrt d))
            (list (/ (+ (- b) r) (* 2.0 a)) (/ (- (- b) r) (* 2.0 a)))
        )
    )
)

;; Point -> Ellipse Parameter  -  Lee Mac
;; Returns the ellipse parameter for the given point
;; dxf  -  Ellipse DXF data (DXF groups 10, 11, 40, 210)
;; pnt  -  WCS Point on Ellipse
;; Uses relationship: ratio*tan(param) = tan(angle)

(defun LM:point->param ( dxf pnt / ang ocs )
    (setq ocs (cdr (assoc 210 dxf))
          ang (- (angle (trans (cdr (assoc 10 dxf)) 0 ocs) (trans pnt 0 ocs))
                 (angle '(0.0 0.0) (trans (cdr (assoc 11 dxf)) 0 ocs))
              )
    )
    (atan (sin ang) (* (cdr (assoc 40 dxf)) (cos ang)))
)

(vl-load-com) (princ)
« Last Edit: October 11, 2014, 12:06:25 PM by Lee Mac »

chlh_jd

  • Guest
Re: === {Challenge} === - Convert PELLIPSE to ELLIPSE
« Reply #5 on: October 13, 2014, 11:31:51 PM »
The following code (also attached for convenience) should account for elliptical arcs  :-)
...
Great Lee  :-)

It also can be solved by Least Square Method , see   here
« Last Edit: October 13, 2014, 11:35:38 PM by chlh_jd »

Lee Mac

  • Seagull
  • Posts: 12892
  • London, England
Re: === {Challenge} === - Convert PELLIPSE to ELLIPSE
« Reply #6 on: October 14, 2014, 12:23:06 PM »
The following code (also attached for convenience) should account for elliptical arcs  :-)
...
Great Lee  :-)

It also can be solved by Least Square Method , see   here


Thanks chlh_jd  :-)