convert polyline line segments to arc segments?

mid-awe · ‎09-11-2015

hi all,

Can anyone help with a lisp that will convert polyline line segments to arc segments? I find myself hovering my mouse over polyline segment midpoints many times daily just to convert the line segment to an arc segment. It started me thinking that it would make sense to convert all the line segments to arc segments at once, rather than one at a time.

I found some similar lisps but they all require a buldge to be provided by the user. I would prefer an automatic ".01" or some other very small number used so that the buldge is not noticed visually but the segment would be an arc none the less.

Thank you for any help / suggestions.

marko_ribar · ‎09-11-2015

Something like this...

(Make sure LWPOLY polygon is placed between X axis - Y values (+ positive bulges) (- negative bulges) )

(defun c:lwstraight2arced ( / nthmassocsubst lw enx vs gr enxb p b i )

  (defun nthmassocsubst ( n key value lst / k slst p j plst m tst pslst )
    (setq k (length (setq slst (member (assoc key lst) lst))))
    (setq p (- (length lst) k))
    (setq j -1)
    (repeat p
      (setq plst (cons (nth (setq j (1+ j)) lst) plst))
    )
    (setq plst (reverse plst))
    (setq j -1)
    (setq m -1)
    (repeat k
      (setq j (1+ j))
      (if (equal (assoc key (member (nth j slst) slst)) (nth j slst) 1e-6)
        (setq m (1+ m))
      )
      (if (and (not tst) (= n m))
        (setq pslst (cons (cons key value) pslst) tst t)
        (setq pslst (cons (nth j slst) pslst))
      )
    )
    (setq pslst (reverse pslst))
    (append plst pslst)
  )

  (setq lw (car (entsel "\nPick LWPOLYLINE straight polygon...")))
  (setq enx (entget lw))
  (setq vs (getvar 'viewsize))
  (while (= 5 (car (setq gr (grread t))))
    (setq enxb (acet-list-m-assoc 42 enx))
    (setq p (cadr gr))
    (setq b (/ (cadr p) vs))
    (setq i -1)
    (foreach dxf42 enxb
      (setq enx (nthmassocsubst (setq i (1+ i)) 42 b enx))
    )
    (entupd (cdr (assoc -1 (entmod enx))))
  )
  (princ)
)

HTH, M.R.

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

Anonymous · ‎09-11-2015

Look for LW_ARC on this page:

http://elpanov.com/index.php?id=35

There are many useful routines by Elpanov Evgeniy here as well.

mid-awe · ‎09-11-2015

Thank you, works well.

mid-awe · ‎09-11-2015

Thank you

mid-awe · ‎09-11-2015

This is a perfect solution for my needs. Hard to imagine this is from '06 🙂

Perfect; thank you again.

ВeekeeCZ · ‎09-11-2015

Better then a mouse hoovering is using CTRL key. Set GRIPMULTIFUNCTIONAL 1 or 3, personally recommend 1). Then click on a middle grip and hit CTRL twice. Very easy, very fast.

mid-awe · ‎09-12-2015

Great tip. Thank you.

marko_ribar · ‎09-13-2015

And now to get some kudos...

Evgeniy's codes that work in 3D space with any 3D orientation and UCS/View...

(defun C:LW_ARC ( / v^v unit _ilp doc i lw p1 p2 p3 gr )
                ;|
*****************************************************************************************

by ElpanovEvgeniy

?????? ????????? ???????? ????????? ??????? ?????????

??????? ????????????
http://www.caduser.ru/cgi-bin/f1/board.cgi?t=20707ki

???? ????????   19.09.2005
????????? ???????? 04.06.2006
*****************************************************************************************

Replacement of a linear segment of a polyline with an arc segment

For the first time it is published
http://www.caduser.ru/cgi-bin/f1/board.cgi?t=20707ki

Date of creation   19.09.2005
Last edition       04.06.2006
*****************************************************************************************


(C:LW_ARC)

*****************************************************************************************
|;

  (defun v^v ( u v )
    (mapcar '(lambda ( s1 s2 a b ) (+ ((eval s1) (* (nth a u) (nth b v))) ((eval s2) (* (nth a v) (nth b u))))) '(+ - +) '(- + -) '(1 0 0) '(2 2 1))
  )

  (defun unit ( v )
    (mapcar '(lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v))) v)
  )

  (defun _ilp ( p1 p2 o nor / p1p p2p op tp pp p )
    (if (not (equal (v^v nor (unit (mapcar '- p2 p1))) '(0.0 0.0 0.0) 1e-7))
      (progn
        (setq p1p (trans p1 0 (v^v nor (unit (mapcar '- p2 p1))))
              p2p (trans p2 0 (v^v nor (unit (mapcar '- p2 p1))))
              op  (trans o 0 (v^v nor (unit (mapcar '- p2 p1))))
              op  (list (car op) (cadr op) (caddr p1p))
              tp  (polar op (+ (* 0.5 pi) (angle '(0.0 0.0 0.0) (trans nor 0 (v^v nor (unit (mapcar '- p2 p1)))))) 1.0)
        )
        (if (inters p1p p2p op tp nil)
          (progn
            (setq p (trans (inters p1p p2p op tp nil) (v^v nor (unit (mapcar '- p2 p1))) 0))
            p
          )
          nil
        )
      )
      (progn
        (setq pp (list (car (trans p1 0 nor)) (cadr (trans p1 0 nor)) (caddr (trans o 0 nor))))
        (setq p (trans pp nor 0))
        p
      )
    )
  )

  (vl-load-com)
  (or doc (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))))
  (if (and (setq lw (entsel "\n Select segment in a LWPOLYLINE. "))
          (= (cdr (assoc 0 (entget (car lw)))) "LWPOLYLINE")
      ) ;_  and
    (progn
      (setq i (fix (vlax-curve-getParamAtPoint
                  (car lw)
                  (vlax-curve-getClosestPointToProjection (car lw) (trans (cadr lw) 1 0) '(0.0 0.0 1.0))
                  ) ;_  vlax-curve-getParamAtPoint
              ) ;_  fix
           p1 (vlax-curve-getPointAtParam (car lw) i)
           p3 (vlax-curve-getPointAtParam (car lw) (1+ i))
           lw (car lw)
      ) ;_  setq
      (princ "\n Set visually curvature of a segment. ")
      (vla-StartUndoMark doc)
      (while (and (setq gr (grread t)) (= (car gr) 5))
        (setq p2 (_ilp (trans (cadr gr) 1 0) (mapcar '+ (trans (cadr gr) 1 0) '(0.0 0.0 1.0)) p1 (cdr (assoc 210 (entget lw)))))
        (vla-SetBulge
          (vlax-ename->vla-object lw)
          i
          ((lambda (a) (/ (sin a) (cos a)))
           (/ (- (angle (trans p2 0 lw) (trans p3 0 lw)) (angle (trans p1 0 lw) (trans p2 0 lw))) 2.0)
          )
        ) ;_  vla-SetBulge
      ) ;_  while
      (vla-EndUndoMark doc)
    ) ;_  progn
    (princ "\n Nothing selected or picked object not a LWPOLYLINE. ")
  ) ;_  if
  (princ)
) ;_  defun

(defun C:LW_ARC- ( / doc lw )
                 ;|
*****************************************************************************************

by ElpanovEvgeniy

?????? ???????? ???????? ????????? ???????? ?????????

??????? ????????????
http://www.caduser.ru/cgi-bin/f1/board.cgi?t=20707ki

???? ????????   19.09.2005
????????? ???????? 04.06.2006
*****************************************************************************************

Replacement of a arc segment of a polyline with an linear segment

For the first time it is published
http://www.caduser.ru/cgi-bin/f1/board.cgi?t=20707ki

Date of creation   19.09.2005
Last edition       04.06.2006
*****************************************************************************************


(C:LW_ARC-)

*****************************************************************************************
|;
  (vl-load-com)
  (or doc (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))))
  (if (and (setq lw (entsel "\n Select arc segment in a LWPOLYLINE. "))
          (= (cdr (assoc 0 (entget (car lw)))) "LWPOLYLINE")
      ) ;_  and
    (progn
      (vla-StartUndoMark doc)
      (vla-SetBulge
        (vlax-ename->vla-object (car lw))
        (fix (vlax-curve-getParamAtPoint
             (car lw)
             (vlax-curve-getClosestPointToProjection (car lw) (trans (cadr lw) 1 0) '(0.0 0.0 1.0))
             ) ;_  vlax-curve-getParamAtPoint
        ) ;_  fix
        0.0
      ) ;_  vla-SetBulge
      (vla-EndUndoMark doc)
    ) ;_  progn
    (princ "\n Nothing selected or object not a LWPOLYLINE. ")
  ) ;_  if
  (princ)
) ;_  defun

And here is my version improved for operations on all segments at once... Also any 3D orientation UCS/View...

(defun c:lwsegs2arced ( / massoclst nthmassocsubst v^v unit _ilp doc lw enx gr enxb p1 p2 p3 b i n )

  (vl-load-com)

  (defun massoclst ( key lst )
    (if (assoc key lst) (cons (assoc key lst) (massoclst key (cdr (member (assoc key lst) lst)))))
  )

  (defun nthmassocsubst ( n key value lst / k slst p j plst m tst pslst )
    (setq k (length (setq slst (member (assoc key lst) lst))))
    (setq p (- (length lst) k))
    (setq j -1)
    (repeat p
      (setq plst (cons (nth (setq j (1+ j)) lst) plst))
    )
    (setq plst (reverse plst))
    (setq j -1)
    (setq m -1)
    (repeat k
      (setq j (1+ j))
      (if (equal (assoc key (member (nth j slst) slst)) (nth j slst) 1e-6)
        (setq m (1+ m))
      )
      (if (and (not tst) (= n m))
        (setq pslst (cons (cons key value) pslst) tst t)
        (setq pslst (cons (nth j slst) pslst))
      )
    )
    (setq pslst (reverse pslst))
    (append plst pslst)
  )

  (defun v^v ( u v )
    (mapcar '(lambda ( s1 s2 a b ) (+ ((eval s1) (* (nth a u) (nth b v))) ((eval s2) (* (nth a v) (nth b u))))) '(+ - +) '(- + -) '(1 0 0) '(2 2 1))
  )

  (defun unit ( v )
    (mapcar '(lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v))) v)
  )

  (defun _ilp ( p1 p2 o nor / p1p p2p op tp pp p )
    (if (not (equal (v^v nor (unit (mapcar '- p2 p1))) '(0.0 0.0 0.0) 1e-7))
      (progn
        (setq p1p (trans p1 0 (v^v nor (unit (mapcar '- p2 p1))))
              p2p (trans p2 0 (v^v nor (unit (mapcar '- p2 p1))))
              op  (trans o 0 (v^v nor (unit (mapcar '- p2 p1))))
              op  (list (car op) (cadr op) (caddr p1p))
              tp  (polar op (+ (* 0.5 pi) (angle '(0.0 0.0 0.0) (trans nor 0 (v^v nor (unit (mapcar '- p2 p1)))))) 1.0)
        )
        (if (inters p1p p2p op tp nil)
          (progn
            (setq p (trans (inters p1p p2p op tp nil) (v^v nor (unit (mapcar '- p2 p1))) 0))
            p
          )
          nil
        )
      )
      (progn
        (setq pp (list (car (trans p1 0 nor)) (cadr (trans p1 0 nor)) (caddr (trans o 0 nor))))
        (setq p (trans pp nor 0))
        p
      )
    )
  )

  (or doc (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))))
  (vla-startundomark doc)
  (if (and (setq lw (entsel "\nPick LWPOLYLINE..."))
          (= (cdr (assoc 0 (setq enx (entget (car lw))))) "LWPOLYLINE")
      )
    (progn
      (setq i (fix (vlax-curve-getParamAtPoint
                  (car lw)
                  (vlax-curve-getClosestPointToProjection (car lw) (trans (cadr lw) 1 0) '(0.0 0.0 1.0))
                  ) ;_  vlax-curve-getParamAtPoint
              ) ;_  fix
           p1 (vlax-curve-getPointAtParam (car lw) i)
           p3 (vlax-curve-getPointAtParam (car lw) (1+ i))
           lw (car lw)
      )
      (setq enxb (massoclst 42 enx))
      (while (= 5 (car (setq gr (grread t))))
        (setq p2 (_ilp (trans (cadr gr) 1 0) (mapcar '+ (trans (cadr gr) 1 0) '(0.0 0.0 1.0)) p1 (cdr (assoc 210 (entget lw)))))
        (setq b ((lambda (a) (/ (sin a) (cos a)))
                (/ (- (angle (trans p2 0 lw) (trans p3 0 lw)) (angle (trans p1 0 lw) (trans p2 0 lw))) 2.0)
               )
        )
        (setq n -1)
        (foreach dxf42 enxb
          (setq n (1+ n))
          (if (= n i)
            (setq enx (nthmassocsubst n 42 b enx))
            (setq enx (nthmassocsubst n 42 (+ (cdr dxf42) b) enx))
          )
        )
        (entupd (cdr (assoc -1 (entmod enx))))
      )
    )
    (prompt "\n Nothing selected or picked object not a LWPOLYLINE ")
  )
  (vla-endundomark doc)
  (princ)
)

Regards, all the best and happy coding...

M.R.

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

eakos1 · ‎06-09-2023

Hello,

I'm doing something similar, converting lines into ARC's in a outline. I've created an own code but to make the running faster I need to reduce the number of vertexes.

I call at first the overkill command then the PLDiet.lisp to reduce the number of the vertexes. Overkill is needed because sometimes without it the PLD destroying the shape. I want to implement this as a SUBrutine in my file.

I've changed the PLD into a SUBrutine in a simple file - it works perfect.

(defun C:Test_PLD (/ ss x e)
  (vl-load-com)
  (setq ss nil)

  (princ "\nPick a LWPOLYLINE")
  (while (= ss nil)
    (setq ss (ssget ":S" '((0 . "LWPOLYLINE"))))
  )					;while


;;;  (setq disttemp 5)			; Maximum distance between non-collinear vertices to straighten
;;;  (setq cidtemp 10)			; Maximum change in direction to straighten
;;;  (setq plsel ss)			; selection set
;;;  (setq arctemp "R")			; selection set

  (setq e (ssname ss 0))
  (command  "-overkill" e "" "p" "b" "no" "" "tolerance" 10 "")
;;;  (command  "-overkill" e "" "tolerance" 10 "" "p" "b" "no" "")
  
  (setq x (DtR 5) )
  (RDI:PLD 10.0 x "S" ss)

)					;defun


------------------------------------------
------------------------------------------


;;;  PLDIET.lsp [command name: PLD]
;;;  To put lightweight PolyLines on a DIET (remove excess vertices); usually
;;;    used for contours with too many too-closely-spaced vertices.
;;;  Concept from PVD routine [posted on AutoCAD Customization Discussion
;;;    Group by oompa_l, July 2009] by Brian Hailey, added to by CAB, and
;;;    WEED and WEED2 routines by Skyler Mills at Cadalyst CAD Tips [older
;;;    routines for "heavy" Polylines that won't work on newer lightweight ones];
;;;    simplified in entity data list processing, and enhanced in other ways [error
;;;    handling, default values, join collinear segments beyond max. distance,
;;;    limit to current space/tab, account for change in direction across 0 degrees,
;;;    option to keep or eliminate arc segments] by Kent Cooper, August 2009.
;;;  Last edited 28 August 2013

;;; input variables
;;; disttemp - Maximum distance between non-collinear vertices to straighten
;;; cidtemp  - Maximum change in direction to straighten
;;; plsel    - selection set, only LWPOLYLINE !
;;; arctemp  - Retain or Straighten arc segments [R/S]



(defun RDI:PLD
  (disttemp cidtemp arctemp plsel / *error* cmde disttemp cidtemp arctemp plinc plsel pl
  pldata ucschanged front 10to42 vinc verts vert1 vert2 vert3)
;
  (defun *error* (errmsg)
    (if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
      (princ (strcat "\nError: " errmsg))
    ); end if
    (if ucschanged (command "_.ucs" "_prev"))
      ; ^ i.e. don't go back unless routine reached UCS change but didn't change back
    (command "_.undo" "_end")
    (setvar 'cmdecho cmde)
  ); end defun - *error*
;
  (setq cmde (getvar 'cmdecho))
  (setvar 'cmdecho 0)
  (command "_.undo" "_begin")

  (setq plinc 0)

  
;;;  (setq
;;;    disttemp
;;;      (getdist
;;;        (strcat
;;;          "\nMaximum distance between non-collinear vertices to straighten"
;;;          (if *distmax* (strcat " <" (rtos *distmax* 2 2) ">") ""); default only if not first use
;;;          ": "
;;;        ); end strcat
;;;      ); end getdist & disttemp
;;;    
;;;    *distmax*
;;;      (cond
;;;        (disttemp); user entered number or picked distance
;;;        (*distmax*); otherwise, user hit Enter - keep value
;;;      ); end cond & *distmax*
;;;    
;;;    cidtemp
;;;      (getangle
;;;        (strcat
;;;          "\nMaximum change in direction to straighten"
;;;          (strcat ; offer prior choice if not first use; otherwise 15 degrees
;;;            " <"
;;;            (if *cidmax* (angtos *cidmax*) (angtos (/ pi 12)))
;;;            ">"
;;;          ); end strcat
;;;          ": "
;;;        ); end strcat
;;;      ); end getdist & cidtemp
;;;    
;;;    *cidmax*
;;;      (cond
;;;        (cidtemp); user entered number or picked angle
;;;        (*cidmax*); Enter with prior value set - use that
;;;        ((/ pi 12)); otherwise [Enter on first use] - 15 degrees
;;;      ); end cond & *cidmax*
;;;    
;;;    plinc 0 ; incrementer through selection set of Polylines
;;;  ); end setq

  
  
;;;  (initget "Retain Straighten")
;;;  (setq
;;;    arctemp
;;;      (getkword
;;;        (strcat
;;;          "\nRetain or Straighten arc segments [R/S] <"
;;;          (if *arcstr* (substr *arcstr* 1 1) "S"); at first use, S default; otherwise, prior choice
;;;          ">: "
;;;        ); end strcat
;;;      ); end getkword
;;;    
;;;    *arcstr*
;;;      (cond
;;;        (arctemp); if User typed something, use it
;;;        (*arcstr*); if Enter and there's a prior choice, keep that
;;;        ("Straighten"); otherwise [Enter on first use], Straighten
;;;      ); end cond & *arcstr*
;;;  ); end setq



  
;
;;;  (prompt "\nSelect LWPolylines to put on a diet, or press Enter to select all: ")
;;;  (cond
;;;    ((setq plsel (ssget '((0 . "LWPOLYLINE"))))); user-selected Polylines
;;;    ((setq plsel (ssget "X" (list '(0 . "LWPOLYLINE") (cons 410 (getvar 'ctab))))))
;;;      ; all Polylines [in current space/tab only]
;;;  ); end cond
;





  
  (repeat (sslength plsel)
    (setq pl (ssname plsel plinc))
    (while
      (equal (vlax-curve-getStartPoint pl) (vlax-curve-getPointAtParam pl 1) 1e-6)
        ; to correct for possibility that more than one vertices at beginning coincide,
        ; in which case Pline does not define a CS under UCS OBject, causing error
      (command "_.pedit" pl "_edit" "_straighten" "" "" "_go" "_exit" "")
    ); while
    (setq pldata (entget pl))
    (if (/= (cdr (last pldata)) (trans '(0 0 1) 1 0)); extr. direction not parallel current CS
        ; for correct angle & distance calculations [projected onto current construction
        ; plane], since 10-code entries for LWPolylines are only 2D points:
      (progn
        (command "_.ucs" "_new" "_object" pl) ; set UCS to match object
        (setq ucschanged T) ; marker for *error* to reset UCS if routine doesn't
      ); end progn
    ); end if
    (setq
      front ; list of "front end" [pre-vertices] entries, minus entity names & handle
        (vl-remove-if
          '(lambda (x)
            (member (car x) '(-1 330 5 10 40 41 42 210))
          ); end lambda
          pldata
        ); end removal & front
      10to42 ; list of all code 10, 40, 41, 42 entries only
        (vl-remove-if-not
          '(lambda (x)
            (member (car x) '(10 40 41 42))
          ); end lambda
          pldata
        ); end removal & 10to42
      vinc (/ (length 10to42) 4); incrementer for vertices within each Polyline
      verts nil ; eliminate from previous Polyline [if any]
    ); end setq
    (if (= *arcstr* "Straighten")
      (progn
        (setq bulges ; find any bulge factors
          (vl-remove-if-not
            '(lambda (x)
              (and
                (= (car x) 42)
                (/= (cdr x) 0.0)
              ); end and
            ); end lambda
            10to42
          ); end removal & bulges
        ); end setq
        (foreach x bulges (setq 10to42 (subst '(42 . 0.0) x 10to42)))
          ; straighten all arc segments to line segments
      ); end progn
    ); end if
    (repeat vinc
      (setq
        verts ; sub-group list: separate list of four entries for each vertex
          (cons
            (list
              (nth (- (* vinc 4) 4) 10to42)
              (nth (- (* vinc 4) 3) 10to42)
              (nth (- (* vinc 4) 2) 10to42)
              (nth (1- (* vinc 4)) 10to42)
            ); end list
            verts
          ); end cons & verts
        vinc (1- vinc) ; will be 0 at end
      ); end setq
    ); end repeat
    (while (nth (+ vinc 2) verts); still at least 2 more vertices
      (if
        (or ; only possible if chose to Retain arc segments
          (/= (cdr (assoc 42 (nth vinc verts))) 0.0); next segment is arc
          (/= (cdr (assoc 42 (nth (1+ vinc) verts))) 0.0); following segment is arc
        ); end or
        (setq vinc (1+ vinc)); then - don't straighten from here; move to next
        (progn ; else - analyze from current vertex
          (setq
            vert1 (cdar (nth vinc verts)) ; point-list location of current vertex
            vert2 (cdar (nth (1+ vinc) verts)); of next one
            vert3 (cdar (nth (+ vinc 2) verts)); of one after that
            ang1 (angle vert1 vert2)
            ang2 (angle vert2 vert3)
          ); end setq
          (if
            (or
              (equal ang1 ang2 0.0001); collinear, ignoring distance
              (and
                (<= (distance vert1 vert3) *distmax*)
                  ; straightens if direct distance from current vertex to two vertices later is
                  ; less than or equal to maximum; if preferred to compare distance along
                  ; Polyline through intermediate vertex, replace above line with this:
                  ; (<= (+ (distance vert1 vert2) (distance vert2 vert3)) *distmax*)
                (<=
                  (if (> (abs (- ang1 ang2)) pi); if difference > 180 degrees
                    (+ (min ang1 ang2) (- (* pi 2) (max ang1 ang2)))
                      ; then - compensate for change in direction crossing 0 degrees
                    (abs (- ang1 ang2)); else - size of difference
                  ); end if
		  
                  *cidmax*
                ); end <=
              ); end and
            ); end or
            (setq verts (vl-remove (nth (1+ vinc) verts) verts))
              ; then - remove next vertext, stay at current vertex for next comparison
            (setq vinc (1+ vinc)); else - leave next vertex, move to it as new base
          ); end if - distance & change in direction analysis
        ); end progn - line segments
      ); end if - arc segment check
    ); end while - working through vertices
    (setq
      front (subst (cons 90 (length verts)) (assoc 90 front) front)
        ; update quantity of vertices for front end
      10to42 nil ; clear original set
    ); end setq
    (foreach x verts (setq 10to42 (append 10to42 x)))
      ; un-group four-list vertex sub-lists back to one list of all 10, 40, 41, 42 entries
    (setq pldata (append front 10to42 (list (last pldata))))
      ; put front end, vertex entries and extrusion direction back together
    (entmake pldata)
    (entdel pl); remove original
    (setq plinc (1+ plinc)); go on to next Polyline
    (if ucschanged
      (progn
        (command "_.ucs" "_prev")
        (setq ucschanged nil) ; eliminate UCS reset in *error* since routine did it already
      ); end progn
    ); end if - UCS reset
  ); end repeat - stepping through set of Polylines
  
  (command "_.undo" "_end")
  (setvar 'cmdecho cmde)
  (princ)
); end defun - PLD
(prompt "\nType PLD to put PolyLines on a Diet.")

But if I want to use it in my program I get an error message: error: bad argument value: AcDbCurve 43

I cannot figure out why. Do someone has any idea ?

;;; This program goes thrugh a LWPOLYLINE and changes cearten 2 neabor lines into ARC
;;; So it will be more smooth
;;; If the program create an ARC makes it bold, so it good visible where was active

;;; Created by: Ákos Erdélyi
;;; v00: 2023.06.09.

;;; v001: overkill added
;;; v002: PLD as SUBrutine added



(defun C:Poly_curveing
		       (/	ss	; selection set
			i		; counter, position in the POLYLINE
			n		; length of the POLYLINE
			n1		; length of the modified POLYLINE
			e		; name of the POLYLINE
			p-0		; actual point in the POLYLINE
			p-1		; previous point
			p-2		; second points back
			p-3		; therard points back
			bulge-0	bulge-1	; bulge
			bulge-2	bulge-3	; bulge
			angle_1	angle_2	; angle between the line segments
			bulge		; bulge for the new ARC
			alfa		; 
			min_angle	; The min. angle between two lines when the program works
			max_angle	; The max. angle between two lines when the program works
			max_length      ; maximal segment length where the program perform the change
			w		; width of the bold segments
			a		; value for the length of the polyline 3 or 4
			x		; 
		       )
  (vl-load-com)
  (setq	i 4
	n 0
	min_angle 0.3
	max_angle 19
	max_length 25
	w 0.75
  )
  (setq ss nil)

  (princ "\nPick a LWPOLYLINE")
  (while (= ss nil)
    (setq ss (ssget ":S" '((0 . "LWPOLYLINE"))))
  )					;while

;;;  (setq disttemp 10)			; Maximum distance between non-collinear vertices to straighten
;;;  (setq cidtemp 5)			; Maximum change in direction to straighten
;;;  (setq plsel ss)			; selection set
;;;  (setq arctemp "R")			; selection set

  

  (setq e (ssname ss 0))
;;;  (command  "-overkill" e "" "tolerance" 10 "")
  (command  "-overkill" e "" "p" "b" "no" "" "tolerance" 10 "")
  (setq x (DtR 5) )
  (RDI:PLD 10.0 x "S" ss)
  (setq n (+ (fix (vlax-curve-getEndParam e)) 1))

  ;; Checking if the POLYLINE is closed or not
  ;; If it is open somehow a should be 3
  ;; If it is closed a should be 4 otherwise error: invalid index
  (if (vlax-curve-isClosed e)
    (setq a 4)
    (setq a 3)
  )					;if

  ;; 6 is the min. number when it makes sense to run this program
  (if (< n 6)
    (progn
      (alert "The POLYLINE is too short!")
      (exit)
    )					;progn
  )					;if

  
  (repeat (- n a)

    (setq p-0 (vlax-curve-getpointatparam e (- i 1)))
    (setq p-1 (vlax-curve-getpointatparam e (- i 2)))
    (setq p-2 (vlax-curve-getpointatparam e (- i 3)))
    (setq p-3 (vlax-curve-getpointatparam e (- i 4)))

    (setq bulge-0 (vla-getbulge (vlax-ename->vla-object e) (- i 1)))
    (setq bulge-1 (vla-getbulge (vlax-ename->vla-object e) (- i 2)))
    (setq bulge-2 (vla-getbulge (vlax-ename->vla-object e) (- i 3)))
    (setq bulge-3 (vla-getbulge (vlax-ename->vla-object e) (- i 4)))


    (if	(and (= bulge-3 0) (= bulge-2 0) (= bulge-1 0))
      (progn
	(setq angle_1 (- 180 (RtD (LM:GetInsideAngle p-1 p-2 p-3))))
	(setq angle_2 (- 180 (RtD (LM:GetInsideAngle p-0 p-1 p-2))))

	(if (and (> angle_1 min_angle)
		 (> angle_2 min_angle)
		 (< angle_1 max_angle)
		 (< angle_2 max_angle)
		 (< (distance p-3 p-2) max_length)
		 (< (distance p-2 p-1) max_length)
	    )
	  (progn
	    (setq bulge (LM:3p->bulge p-3 p-2 p-1))
	    (vtx-del e p-2)
	    (setq i (- i 1))
	    (vla-setbulge (vlax-ename->vla-object e) (- i 3) bulge)
	    (change_width e p-3 w)
	  )
	  ;; progn
	)
	;; if
      )					; progn
    )					; if
    (setq i (+ i 1))


  )					;repeat

  
  (setq n1 (+ (fix (vlax-curve-getEndParam e)) 1))
  (princ (strcat "\nNumber of segments in the POLYLINE: " (itoa n)))
  (terpri)
  (princ (strcat "\nNumber of segments in the modified POLYLINE: " (itoa n1)))


  (princ)
)					;defun


----------------------------------------
----------------------------------------
;;; SUB programs
----------------------------------------
----------------------------------------

;; 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))
  )
)

-----------------------------

;; converts radians to degrees
(defun RtD (r) (* 180.0 (/ r pi)))

;; converts degrees to radians
(defun DtR (d) (* pi (/ d 180.0)))

-----------------------------

;;; This rutine delets one vertex from the LWPOLYLINE

(defun vtx-del (ent pt / bulges coords idx param)
  (vl-load-com)
  (defun removenth (n lst / i rtn)
    (reverse
      (progn
	(setq i -1)
	(foreach x lst
	  (if (/= n (setq i (1+ i)))
	    (setq rtn (cons x rtn))
	  )
	)
	rtn
      )
    )
  )

  (setq ent (vlax-ename->vla-object ent))

  (setq param (atoi (rtos (vlax-curve-getparamatpoint ent pt) 2 0)))
  (setq	coords (vlax-get ent 'coordinates)
	idx    -1
	bulges nil
  )
  (repeat (/ (length coords) 2)
    (setq bulges (cons (vla-getbulge ent (setq idx (1+ idx))) bulges))
  )
  (setq bulges (removenth param (reverse bulges)))
  (repeat 2
    (setq coords (removenth (* 2 param) coords))
  )
  (vlax-put ent 'coordinates coords)
  (setq idx -1)
  (foreach bulge bulges
    (vla-setbulge ent (setq idx (1+ idx)) bulge)
  )
  (princ)
)					; defun

-----------------------------

;; 3-Points to Bulge  -  Lee Mac
(defun LM:3p->bulge (p1 p2 p3)
  ((lambda (a) (/ (sin a) (cos a)))
    (/ (+ (- pi (angle p2 p1)) (angle p2 p3)) 2)
  )
)

-----------------------------
-----------------------------

;;; Change the width of a given segment in the polyline - Ákos Erdélyi
;;; poly_name - entity name of LWPOLYLINE
;;; point     - the begining point of line which has to be make bold
;;; w         - width which will set up in polyline

(defun change_width (poly_name point w / number_of_vertex)
  (setq number_of_vertex (vlax-curve-getParamAtPoint e point))
  (vla-setwidth
    (vlax-ename->vla-object e)
    number_of_vertex
    w
    w
  )
)					;defun

-----------------------------

;;;  PLDIET.lsp [command name: PLD]
;;;  To put lightweight PolyLines on a DIET (remove excess vertices); usually
;;;    used for contours with too many too-closely-spaced vertices.
;;;  Concept from PVD routine [posted on AutoCAD Customization Discussion
;;;    Group by oompa_l, July 2009] by Brian Hailey, added to by CAB, and
;;;    WEED and WEED2 routines by Skyler Mills at Cadalyst CAD Tips [older
;;;    routines for "heavy" Polylines that won't work on newer lightweight ones];
;;;    simplified in entity data list processing, and enhanced in other ways [error
;;;    handling, default values, join collinear segments beyond max. distance,
;;;    limit to current space/tab, account for change in direction across 0 degrees,
;;;    option to keep or eliminate arc segments] by Kent Cooper, August 2009.
;;;  Last edited 28 August 2013

;;; input variables
;;; disttemp - Maximum distance between non-collinear vertices to straighten
;;; cidtemp  - Maximum change in direction to straighten
;;; plsel    - selection set, only LWPOLYLINE !
;;; arctemp  - Retain or Straighten arc segments [R/S]



(defun RDI:PLD
  (disttemp cidtemp arctemp plsel / *error* cmde disttemp cidtemp arctemp plinc plsel pl
  pldata ucschanged front 10to42 vinc verts vert1 vert2 vert3)
;
  (defun *error* (errmsg)
    (if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
      (princ (strcat "\nError: " errmsg))
    ); end if
    (if ucschanged (command "_.ucs" "_prev"))
      ; ^ i.e. don't go back unless routine reached UCS change but didn't change back
    (command "_.undo" "_end")
    (setvar 'cmdecho cmde)
  ); end defun - *error*
;
  (setq cmde (getvar 'cmdecho))
  (setvar 'cmdecho 0)
  (command "_.undo" "_begin")

  (setq plinc 0)

  
;;;  (setq
;;;    disttemp
;;;      (getdist
;;;        (strcat
;;;          "\nMaximum distance between non-collinear vertices to straighten"
;;;          (if *distmax* (strcat " <" (rtos *distmax* 2 2) ">") ""); default only if not first use
;;;          ": "
;;;        ); end strcat
;;;      ); end getdist & disttemp
;;;    
;;;    *distmax*
;;;      (cond
;;;        (disttemp); user entered number or picked distance
;;;        (*distmax*); otherwise, user hit Enter - keep value
;;;      ); end cond & *distmax*
;;;    
;;;    cidtemp
;;;      (getangle
;;;        (strcat
;;;          "\nMaximum change in direction to straighten"
;;;          (strcat ; offer prior choice if not first use; otherwise 15 degrees
;;;            " <"
;;;            (if *cidmax* (angtos *cidmax*) (angtos (/ pi 12)))
;;;            ">"
;;;          ); end strcat
;;;          ": "
;;;        ); end strcat
;;;      ); end getdist & cidtemp
;;;    
;;;    *cidmax*
;;;      (cond
;;;        (cidtemp); user entered number or picked angle
;;;        (*cidmax*); Enter with prior value set - use that
;;;        ((/ pi 12)); otherwise [Enter on first use] - 15 degrees
;;;      ); end cond & *cidmax*
;;;    
;;;    plinc 0 ; incrementer through selection set of Polylines
;;;  ); end setq

  
  
;;;  (initget "Retain Straighten")
;;;  (setq
;;;    arctemp
;;;      (getkword
;;;        (strcat
;;;          "\nRetain or Straighten arc segments [R/S] <"
;;;          (if *arcstr* (substr *arcstr* 1 1) "S"); at first use, S default; otherwise, prior choice
;;;          ">: "
;;;        ); end strcat
;;;      ); end getkword
;;;    
;;;    *arcstr*
;;;      (cond
;;;        (arctemp); if User typed something, use it
;;;        (*arcstr*); if Enter and there's a prior choice, keep that
;;;        ("Straighten"); otherwise [Enter on first use], Straighten
;;;      ); end cond & *arcstr*
;;;  ); end setq



  
;
;;;  (prompt "\nSelect LWPolylines to put on a diet, or press Enter to select all: ")
;;;  (cond
;;;    ((setq plsel (ssget '((0 . "LWPOLYLINE"))))); user-selected Polylines
;;;    ((setq plsel (ssget "X" (list '(0 . "LWPOLYLINE") (cons 410 (getvar 'ctab))))))
;;;      ; all Polylines [in current space/tab only]
;;;  ); end cond
;





  
  (repeat (sslength plsel)
    (setq pl (ssname plsel plinc))
    (while
      (equal (vlax-curve-getStartPoint pl) (vlax-curve-getPointAtParam pl 1) 1e-6)
        ; to correct for possibility that more than one vertices at beginning coincide,
        ; in which case Pline does not define a CS under UCS OBject, causing error
      (command "_.pedit" pl "_edit" "_straighten" "" "" "_go" "_exit" "")
    ); while
    (setq pldata (entget pl))
    (if (/= (cdr (last pldata)) (trans '(0 0 1) 1 0)); extr. direction not parallel current CS
        ; for correct angle & distance calculations [projected onto current construction
        ; plane], since 10-code entries for LWPolylines are only 2D points:
      (progn
        (command "_.ucs" "_new" "_object" pl) ; set UCS to match object
        (setq ucschanged T) ; marker for *error* to reset UCS if routine doesn't
      ); end progn
    ); end if
    (setq
      front ; list of "front end" [pre-vertices] entries, minus entity names & handle
        (vl-remove-if
          '(lambda (x)
            (member (car x) '(-1 330 5 10 40 41 42 210))
          ); end lambda
          pldata
        ); end removal & front
      10to42 ; list of all code 10, 40, 41, 42 entries only
        (vl-remove-if-not
          '(lambda (x)
            (member (car x) '(10 40 41 42))
          ); end lambda
          pldata
        ); end removal & 10to42
      vinc (/ (length 10to42) 4); incrementer for vertices within each Polyline
      verts nil ; eliminate from previous Polyline [if any]
    ); end setq
    (if (= *arcstr* "Straighten")
      (progn
        (setq bulges ; find any bulge factors
          (vl-remove-if-not
            '(lambda (x)
              (and
                (= (car x) 42)
                (/= (cdr x) 0.0)
              ); end and
            ); end lambda
            10to42
          ); end removal & bulges
        ); end setq
        (foreach x bulges (setq 10to42 (subst '(42 . 0.0) x 10to42)))
          ; straighten all arc segments to line segments
      ); end progn
    ); end if
    (repeat vinc
      (setq
        verts ; sub-group list: separate list of four entries for each vertex
          (cons
            (list
              (nth (- (* vinc 4) 4) 10to42)
              (nth (- (* vinc 4) 3) 10to42)
              (nth (- (* vinc 4) 2) 10to42)
              (nth (1- (* vinc 4)) 10to42)
            ); end list
            verts
          ); end cons & verts
        vinc (1- vinc) ; will be 0 at end
      ); end setq
    ); end repeat
    (while (nth (+ vinc 2) verts); still at least 2 more vertices
      (if
        (or ; only possible if chose to Retain arc segments
          (/= (cdr (assoc 42 (nth vinc verts))) 0.0); next segment is arc
          (/= (cdr (assoc 42 (nth (1+ vinc) verts))) 0.0); following segment is arc
        ); end or
        (setq vinc (1+ vinc)); then - don't straighten from here; move to next
        (progn ; else - analyze from current vertex
          (setq
            vert1 (cdar (nth vinc verts)) ; point-list location of current vertex
            vert2 (cdar (nth (1+ vinc) verts)); of next one
            vert3 (cdar (nth (+ vinc 2) verts)); of one after that
            ang1 (angle vert1 vert2)
            ang2 (angle vert2 vert3)
          ); end setq
          (if
            (or
              (equal ang1 ang2 0.0001); collinear, ignoring distance
              (and
                (<= (distance vert1 vert3) *distmax*)
                  ; straightens if direct distance from current vertex to two vertices later is
                  ; less than or equal to maximum; if preferred to compare distance along
                  ; Polyline through intermediate vertex, replace above line with this:
                  ; (<= (+ (distance vert1 vert2) (distance vert2 vert3)) *distmax*)
                (<=
                  (if (> (abs (- ang1 ang2)) pi); if difference > 180 degrees
                    (+ (min ang1 ang2) (- (* pi 2) (max ang1 ang2)))
                      ; then - compensate for change in direction crossing 0 degrees
                    (abs (- ang1 ang2)); else - size of difference
                  ); end if
		  
                  *cidmax*
                ); end <=
              ); end and
            ); end or
            (setq verts (vl-remove (nth (1+ vinc) verts) verts))
              ; then - remove next vertext, stay at current vertex for next comparison
            (setq vinc (1+ vinc)); else - leave next vertex, move to it as new base
          ); end if - distance & change in direction analysis
        ); end progn - line segments
      ); end if - arc segment check
    ); end while - working through vertices
    (setq
      front (subst (cons 90 (length verts)) (assoc 90 front) front)
        ; update quantity of vertices for front end
      10to42 nil ; clear original set
    ); end setq
    (foreach x verts (setq 10to42 (append 10to42 x)))
      ; un-group four-list vertex sub-lists back to one list of all 10, 40, 41, 42 entries
    (setq pldata (append front 10to42 (list (last pldata))))
      ; put front end, vertex entries and extrusion direction back together
    (entmake pldata)
    (entdel pl); remove original
    (setq plinc (1+ plinc)); go on to next Polyline
    (if ucschanged
      (progn
        (command "_.ucs" "_prev")
        (setq ucschanged nil) ; eliminate UCS reset in *error* since routine did it already
      ); end progn
    ); end if - UCS reset
  ); end repeat - stepping through set of Polylines
  
  (command "_.undo" "_end")
  (setvar 'cmdecho cmde)
  (princ)
); end defun - PLD
(prompt "\nType PLD to put PolyLines on a Diet.")


-----------------------------

marko_ribar · ‎06-10-2023

Maybe this code can help you, but I don't know what you are looking for - I read the topic only briefly...

Here is the link : https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/lisp-to-join-multiple-lines-together...

HTH.

M.R.

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

marko_ribar · ‎06-10-2023

It seems that it stucks with my code, but with yours I had no problems at all... I am checking it on BricsCAD V23... I formated your code to be little prettier and I am attaching it again - I've added some lines into it at start and at the end for width...

HTH.

M.R.

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

eakos1 · ‎06-11-2023

Thanks for the correction. In the main time I also realized what was the problem. This PLD program creates a new polyline - it get a new name, I thought it just changes it. That's why my program give an error.

My goal is not only reduce the number of the vertexes, but make more smooth the outline with curves.

We made this until now manually.

Maybe the parameters could be optimized but it is already working.

eakos1 · ‎06-21-2023

I've just finished my program. I post it here, maybe someone can use it too.

marko_ribar · ‎06-21-2023

@eakos1 wrote:
I've just finished my program. I post it here, maybe someone can use it too.

Thanks, what I did lastly is implementation of DCL into LSP with DCL to be more flexible while usage...

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

Robin-ARCA · ‎03-13-2024

wish to change many overlapping polylines to arc at once. could it be solved? please

laurens146 · ‎02-18-2025

Why do all these routines use LWPOLYLINES when the initial poster asked about regular polylines?
How do I even convert to LWPolylines and then back?

cadffm · ‎02-18-2025

Hi,

>>"when the initial poster asked about regular polylines"

1. Where do you read about "regular polylines"? (and what are "regular" polylines?)

Note, In PropertiesPalette, "Polyline" s are LWpolylines

2. because of your question, I guess you are talking about 2D-Polylines, but also I can't read about 2D-Polylines above.

3. LWPolylines are set as default polyline type since 28 YEARS, so they are in fact thre "regular polylines" in DXF/DWG world (since format R14)

>>"How do I even convert to LWPolylines and then back?"

[F1] Convertpoly

Sebastian

laurens146 · ‎02-18-2025

So after some trial and error I managed to get Chatgpt to make the lisp attached.

It turns the first segment of every selected polyline (NOT LWpolyline) into an arc with a minimal radius (=50x segment length)

I needed this to be able to get the desired "complex chain" object when importinhg from DWG to Microstation.

Without the polylines having at least one arc they are imported as "line string" instead of "complex chain" and a client only wanted "complex chains".

laurens146 · ‎02-18-2025

When I used the lisp provided that claims to work for multiple polylines at once above I got an error stating my selected (regular, 2D) polylines weren't "lwpolylines".
To be fair I've used Autocad for 7 years and I haven't really ever dealt with anything called lwpolylines just polylines and 3d polylines.

So I don't know why that lisp didn't work.

Regardless I have what I needed thanks to the contributors if anyone has use for the code I made you're welcome. (it's the same as the lisp file I posted earlier)

(defun c:polyseg2arc ( / ss i pl enx n p1 p3 len radius bulge enxb doc)
(vl-load-com)

(defun massoclst (key lst)
(if (assoc key lst) (cons (assoc key lst) (massoclst key (cdr (member (assoc key lst) lst))))))

(defun nthmassocsubst (n key value lst / k slst p j plst m tst pslst)
(setq k (length (setq slst (member (assoc key lst) lst))))
(setq p (- (length lst) k))
(setq j -1)
(setq plst nil)
(repeat p (setq plst (cons (nth (setq j (1+ j)) lst) plst)))
(setq plst (reverse plst))
(setq j -1 m -1 pslst nil tst nil)
(repeat k
(setq j (1+ j))
(if (equal (assoc key (member (nth j slst) slst)) (nth j slst) 1e-6)
(setq m (1+ m)))
(if (and (not tst) (= n m))
(setq pslst (cons (cons key value) pslst) tst t)
(setq pslst (cons (nth j slst) pslst))))
(setq pslst (reverse pslst))
(append plst pslst))

(setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
(vla-StartUndoMark doc)

(if (setq ss (ssget '((0 . "LWPOLYLINE")))) ; Select multiple polylines
(repeat (setq i (sslength ss))
(setq pl (ssname ss (setq i (1- i))))
(setq enx (entget pl))

(setq n 0) ; Always modify the first segment

(setq p1 (vlax-curve-getPointAtParam pl n))
(setq p3 (vlax-curve-getPointAtParam pl (1+ n)))
(setq len (distance p1 p3)) ; Length of the segment
(setq radius (* len 50)) ; Set radius = 50 times segment length
(setq bulge (/ len (* 4 radius))) ; Calculate bulge value

(setq enxb (massoclst 42 enx))
(setq enx (nthmassocsubst n 42 bulge enx))

(entmod enx)
(entupd pl)))

(vla-EndUndoMark doc)
(princ "\nArc added to one segment per polyline.")
(princ))

Community

convert polyline line segments to arc segments?

convert polyline line segments to arc segments?

convert polyline line segments to arc segments?