Segments of polylines

[Artem]

Hi all, long time i faced problem with polylines. One app create bunch of polylines with not 90 deg corners between near parts if i use custom method inside that APP, but nevermind. I am looking for app that can adjust verterxes of polyine in way when polyline become fully orthogonal in current UCS, but keeps the first and last verters untoched (that can break further calculations). Example before/after below:


Honestly i am tired of manally adjusted them every time, by moving each verterx far away then back with orho turned ON to make in 90 deg to previous vertex. 
Thanks for every help

 

[Danielm103]

chat made this, 

(defun orthogonalize-points (pts / dx-in dx-out dy-in dy-out i in-is-h new-x new-y out-is-h p0 p1 p2 result)
  ;; If fewer than 3 points, nothing to do
  (if (< (length pts) 3)
    pts
    (progn
      (setq result pts)

      ;; Iterate interior vertices
      (setq i 1)
      (while (< i (- (length pts) 1))
        (setq p0 (nth (- i 1) result))
        (setq p1 (nth i result))
        (setq p2 (nth (+ i 1) result))
        ;; Incoming vector p0 -> p1
        (setq dx-in (- (car p1) (car p0)))
        (setq dy-in (- (cadr p1) (cadr p0)))

        ;; Outgoing vector p1 -> p2
        (setq dx-out (- (car p2) (car p1)))
        (setq dy-out (- (cadr p2) (cadr p1)))

        ;; Dominant direction tests
        (setq in-is-h  (>= (abs dx-in)  (abs dy-in)))
        (setq out-is-h (>= (abs dx-out) (abs dy-out)))

        ;; Case 1: Proper corner (one horizontal, one vertical)
        (cond
          ((/= in-is-h out-is-h)
           (if in-is-h
             (progn
               ;; incoming horizontal, outgoing vertical
               (setq new-x (car p2))
               (setq new-y (cadr p0))
             )
             (progn
               ;; incoming vertical, outgoing horizontal
               (setq new-x (car p0))
               (setq new-y (cadr p2))
             )
           )
          )

          ;; Case 2: both horizontal
          (in-is-h
           (setq new-x (car p1))
           (setq new-y (cadr p0))
          )

          ;; Case 3: both vertical
          (t
           (setq new-x (car p0))
           (setq new-y (cadr p1))
          )
        )

        ;; Replace interior point
        (setq result
              (subst (list new-x new-y) p1 result))

        (setq i (1+ i))
      )

      result
    )
  )
)

(defun c:ORTHO_PLINE ( / edata ent newpts p pl pts x)

  (setq ent (car (entsel "\nSelect a polyline: ")))
  (if (not ent)
    (progn
      (princ "\nNothing selected.")
      (exit)
    )
  )

  (setq edata (entget ent))

  ;; Ensure LWPOLYLINE
  (if (/= (cdr (assoc 0 edata)) "LWPOLYLINE")
    (progn
      (princ "\nEntity is not a lightweight polyline.")
      (exit)
    )
  )

  ;; Extract vertices (group code 10)
  (setq pts
        (mapcar 'cdr
                (vl-remove-if-not
                  '(lambda (x) (= (car x) 10))
                  edata)))

  ;; Orthogonalize
  (setq newpts (orthogonalize-points pts))

  ;; Create new polyline
  (setq pl
        (entmakex
          (append
            (list
              '(0 . "LWPOLYLINE")
              '(100 . "AcDbEntity")
              '(100 . "AcDbPolyline")
              (cons 90 (length newpts))
              '(70 . 0)
            )
            (mapcar '(lambda (p) (cons 10 p)) newpts)
          )
        )
  )

  (if pl
    (princ "\nOrthogonal polyline created.")
    (princ "\nFailed to create polyline.")
  )

  (princ)
)

 

[Steven P]

A slightly blunter method I use is to line everything up to a grid spacing (in my LISP I define the spacing rather than the drawing.... just in case) which usually works OK for most thing. A lot of what I do is line diagrams and the polylines are never too far out. 

 

 - Get a list of points, use Lee Macs round to closest on each point, entmod the line using original and new points. I'd prefer entmod than making a new line just in case something goes wrong in between deleting the original and creating the new, retains all the original polyline info.

[marko_ribar]

@Danielm103

How can AI be better than human revision?

Here is AI - I've added "red" color...

(defun c:ortho_pline ( / orthogonalize-points edata ent newpts p pl pts x)

  (defun orthogonalize-points (pts / dx-in dx-out dy-in dy-out i in-is-h new-x new-y out-is-h p0 p1 p2 result)
    ;; If fewer than 3 points, nothing to do
    (if (< (length pts) 3)
      pts
      (progn
        (setq result pts)

        ;; Iterate interior vertices
        (setq i 1)
        (while (< i (- (length pts) 1))
          (setq p0 (nth (- i 1) result))
          (setq p1 (nth i result))
          (setq p2 (nth (+ i 1) result))
          ;; Incoming vector p0 -> p1
          (setq dx-in (- (car p1) (car p0)))
          (setq dy-in (- (cadr p1) (cadr p0)))

          ;; Outgoing vector p1 -> p2
          (setq dx-out (- (car p2) (car p1)))
          (setq dy-out (- (cadr p2) (cadr p1)))

          ;; Dominant direction tests
          (setq in-is-h  (>= (abs dx-in)  (abs dy-in)))
          (setq out-is-h (>= (abs dx-out) (abs dy-out)))

          ;; Case 1: Proper corner (one horizontal, one vertical)
          (cond
            ((/= in-is-h out-is-h)
             (if in-is-h
               (progn
                 ;; incoming horizontal, outgoing vertical
                 (setq new-x (car p2))
                 (setq new-y (cadr p0))
               )
               (progn
                 ;; incoming vertical, outgoing horizontal
                 (setq new-x (car p0))
                 (setq new-y (cadr p2))
               )
             )
            )

            ;; Case 2: both horizontal
            (in-is-h
             (setq new-x (car p1))
             (setq new-y (cadr p0))
            )

            ;; Case 3: both vertical
            (t
             (setq new-x (car p0))
             (setq new-y (cadr p1))
            )
          )

          ;; Replace interior point
          (setq result
                (subst (list new-x new-y) p1 result))

          (setq i (1+ i))
        )

        result
      )
    )
  )

  (setq ent (car (entsel "\nSelect a polyline: ")))
  (if (not ent)
    (progn
      (princ "\nNothing selected.")
      (exit)
    )
  )

  (setq edata (entget ent))

  ;; Ensure LWPOLYLINE
  (if (/= (cdr (assoc 0 edata)) "LWPOLYLINE")
    (progn
      (princ "\nEntity is not a lightweight polyline.")
      (exit)
    )
  )

  ;; Extract vertices (group code 10)
  (setq pts
        (mapcar 'cdr
                (vl-remove-if-not
                  '(lambda (x) (= (car x) 10))
                  edata)))

  ;; Orthogonalize
  (setq newpts (orthogonalize-points pts))

  ;; Create new polyline
  (setq pl
        (entmakex
          (append
            (list
              '(0 . "LWPOLYLINE")
              '(100 . "AcDbEntity")
              '(100 . "AcDbPolyline")
              (cons 90 (length newpts))
              '(70 . 0)
            )
            (mapcar '(lambda (p) (cons 10 p)) newpts)
            (list '(62 . 1))
          )
        )
  )

  (if pl
    (princ "\nOrthogonal polyline created.")
    (princ "\nFailed to create polyline.")
  )

  (princ)
)

 

And here is my version - I used "green" color...

(defun c:lw_orth ( / f lw lwx pl )

  (defun f ( l / i p1 p2 r )
    (if (> (length l) 2)
      (progn
        (setq i -1)
        (while (< (setq i (1+ i)) (1- (length l)))
          (if (not p1)
            (setq p1 (nth i l) p2 (nth (1+ i) l))
            (setq p1 p2 p2 (nth (1+ i) l))
          )
          (if (= i 0)
            (setq r (cons (car l) r))
          )
          (if (< (abs (- (car p2) (car p1))) (abs (- (cadr p2) (cadr p1))))
            (setq r (cons (setq p2 (list (car p1) (cadr p2))) r))
            (setq r (cons (setq p2 (list (car p2) (cadr p1))) r))
          )
          (if (= i (- (length l) 2))
            (setq r (cons (last l) r))
          )
        )
        (setq r (reverse r))
        (setq r (apply (function append) (mapcar (function (lambda ( p1 p2 / pp ) (if (setq pp (vl-some (function (lambda ( x ) (if (and (equal (distance p1 p2) (+ (distance p1 x) (distance x p2)) 1e-10) (not (equal x p1 1e-10)) (not (equal x p2 1e-10))) x))) l)) (list p1 pp) (list p1)))) r (append (cdr r) (list (car r))))))
      )
    )
  )

  (if
    (and
      (setq lw (car (entsel "\nPick open polygonal lwpolyline to make its clone orthogonalized...")))
      (= (cdr (assoc 0 (setq lwx (entget lw)))) "LWPOLYLINE")
      (or (= (cdr (assoc 70 lwx)) 0) (= (cdr (assoc 70 lwx)) 128))
      (vl-every (function (lambda ( x ) (= (cdr x) 0.0))) (vl-remove-if (function (lambda ( x ) (/= (car x) 42))) lwx))
    )
    (progn
      (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) lwx)))
      (if (> (length pl) 2)
        (entmake
          (append
            (list
              (cons 0 "LWPOLYLINE")
              (cons 100 "AcDbEntity")
              (cons 100 "AcDbPolyline")
              (cons 90 (length pl))
              (cons 70 (* 128 (getvar (quote plinegen))))
              (cons 38 0.0)
            )
            (mapcar (function (lambda ( x ) (cons 10 x))) (f pl))
            (list
              (cons 62 3)
              (list 210 0.0 0.0 1.0)
            )
          )
        )
        (prompt "\nPicked lwpolyline with insufficient number of vertices...")
      )
    )
    (prompt "\nMissed, or picked entity not open polygonal lwpolyline... Better luck next time...")
  )
  (princ)
)

 

In attached *.DWG you can see that AI version makes mistake with finalizing segment - it isn't always orthogonal...

 

Anyway interesting and fun for coding...

Regards, M.R.

orthogonalize_lwpolyline.dwg

[Danielm103]

Nice!

[Tsuky]

Maybe another function that could help you...
It is essential to set the "RESOL" variable to your resolution wishes before starting the routine, note that this modifies the geometry data of all selected objects.

(defun round_number (xr n / )
  (* (fix (atof (rtos (* xr n) 2 0))) (/ 1.0 n))
)
(defun c:regular_draw ( / js n_count ent dxf_ent dxf_lst)
  (setq js (ssget '((0 . "FACE3D,ARC,ATTDEF,ATTRIB,CIRCLE,ELLIPSE,INSERT,LINE,POLYLINE,LWPOLYLINE,*TEXT,POINT,SHAPE,SOLID,TRACE"))) n_count -1)
  (cond
    (js
      (setvar "cmdecho" 0)
      (command "_.undo" "_group")
      (while (setq ent (ssname js (setq n_count (1+ n_count))))
        (setq dxf_ent (entget ent))
        (cond
          ((eq (cdr (assoc 0 dxf_ent)) "LWPOLYLINE")
            (setq dxf_lst (cdr dxf_ent) dxf_ent (list (car dxf_ent)))
            (while (cdr dxf_lst)
              (if (eq 10 (caar dxf_lst))
                (setq dxf_ent (cons (cons 10 (mapcar '(lambda (x p) (round_number x (/ 1 p))) (cdar dxf_lst) (getvar "SNAPUNIT"))) dxf_ent))
                (setq dxf_ent (cons (car dxf_lst) dxf_ent))
              )
              (setq dxf_lst (cdr dxf_lst))
            )
            (setq dxf_ent (reverse dxf_ent))
          )
          ((eq (cdr (assoc 0 dxf_ent)) "POLYLINE")
            (while (eq (cdr (assoc 0 (setq dxf_ent (entget (entnext (cdar dxf_ent)))))) "VERTEX")
              (setq dxf_ent (subst (cons 10 (mapcar '(lambda (x p) (round_number x (/ 1 p))) (cdr (assoc 10 dxf_ent)) (append (getvar "SNAPUNIT") (list (car (getvar "SNAPUNIT")))))) (assoc 10 dxf_ent) dxf_ent))
              (entmod dxf_ent)
            )
          )
          (T
            (foreach n dxf_ent
              (if (member (car n) '(10 11 12 13 40))
                (if (listp (cdr n))
                  (setq dxf_ent (subst (cons (car n) (mapcar '(lambda (x p) (round_number x (/ 1 p))) (cdr n) (append (getvar "SNAPUNIT") (list (car (getvar "SNAPUNIT")))))) (assoc (car n) dxf_ent) dxf_ent))
                  (setq dxf_ent (subst (cons (car n) (round_number (cdr n) (/ 1 (car (getvar "SNAPUNIT"))))) (assoc (car n) dxf_ent) dxf_ent))
                )
              )
            )
          )
        )
        (entmod dxf_ent)
        (entupd ent)
      )
      (command "_.undo" "_end")
      (setvar "cmdecho" 1)
      (princ (strcat "\n" (itoa n_count) " transformed object(s)."))
    )
    (T (princ "\nNo find valid object."))
  )
  (prin1)
)