Delete unnecessary edges on polylines

[Trap3d]

Hello everyone,

 

I'm dealing with polylines with a lot of unnecessary steps, and normally i need to delete manually these edges.

The goal is to have a lisp code that delete these edges, if the step value is 1.5mm.

I tried PLDiet lisp code but the resulting pline cannot have diagonal lines, only horizontal or vertical.

How can I proceed to solve this issue? Is already any code available for that?

 

Thanks in advance for your tips!

 

(PS: see attached file with an example).

 

Example.dwg

[exceed]

Before writing a routine, you must check that the conditions are logically flawless.

 

From the length between polyline nodes,

we need to distinguish between lines to be taken and lines not to be taken.

 

 

Once the loop is run once, these two white lines in the example must survive.

Since the rule is not grid snap 1.5 because the result's nodes do not fall to 1.5,

deleting the right line must be done by looping once more with the result of the first loop.

The left white line will survive though.

 

Since the general routine makes judgments by comparing the front and back points,

a new routine may be needed to estimate the edges using extension lines at the nodes at both ends.

 

 

Extract the coordinates of each point of the polyline,

first extract the cases where both sides are 1.5 or more from the length of the line segment (points marked with a 1.5 radius circle),

and then draw only one side. After marking the point (marked by x) that is greater than 1.5,

 

 

then draw a line first when there are continuous circles,

draw directly towards the next point x on the circle.

 

 

Now, we need to find the included angle in all coordinates other than 0 90 180 270 and remove that node.

You also need to decide which side of the line to align it with.

 

This is the guessing based on only the nodes,

but if there is a condition that the area should not be modified in a way that makes it smaller,

your example can be valid.

 

In this case, you must add a routine to determine the area of the closed area

and a routine to determine whether a point is inside or outside the closed polyline.

It will become more complicated than guessing based on just the nodes.

Edited September 11, 2023 by exceed

[lrm]

Here's an approach that might have some potential although there are a few coding challenges.

 

Using offset, create an offset shape 1.5 mm outside the original shape.

 

Delete all the fillets and replace them with chamfers. Note that if a fillet arc is not between a vertical and horizontal line then both the arc and the line "inside" should be deleted. 

Chamfer the resulting lines.

Now construct an offset curve of 1.5 inside this shape.

Replace the arcs with fillets and you have the desired end product!

The most challenging coding part of this approach is determining which line segments should be deleted after the initial offset shape (i.e., the inside lines). 

 

 

[BIGAL]

That is a hard shape to change, explode, fillet and erase comes to mind as 1st answer.

 

Ok 2nd answer select pline segments in sequence, no arcs, then make a new pline from new line segments.

 

 

So try this. Just pick segments press enter to stop picking it will close automatically. You must pick in order.

(defun getplineseg (elst / elst ename pt param preparam postparam)
(setq ename (car elst))
(setq pt (cadr elst))
(setq pt (vlax-curve-getClosestPointTo ename pt))
(print (setq param (vlax-curve-getParamAtPoint ename pt)) )
(print (setq preparam (fix param)) )
(print (setq postparam (1+ preparam)) )
(setq pt1 (vlax-curve-getPointAtParam ename preparam)
pt2 (vlax-curve-getPointAtParam ename postparam))
)

(defun c:wow ( / oldsnap ent mp1 mp2 pt1 pt2 mpst)
(setq oldsnap (getvar 'osmode))
(setvar 'osmode 0)
(setvar 'filletrad 0.0)
(setq ent (entsel "\nSelect pline segment: "))
(getplineseg ent)
(command "pline" pt1 pt2 "")
(setq mp1 (mapcar '* (mapcar '+ pt1 pt2) '(0.5 0.5)))
(setq mpst mp1)
(while (setq ent (entsel "\nSelect pline segment: "))
(getplineseg ent)
(command "pline" pt1 pt2 "")
(setq mp2 (mapcar '* (mapcar '+ pt1 pt2) '(0.5 0.5)))
(command "fillet" mp1 mp2)
(setq mp1 mp2)
)
(setq obj (vlax-ename->vla-object  (entlast)))
(vlax-put obj 'Closed -1)
(princ)
)

 

Edited September 11, 2023 by BIGAL

[Trap3d]

Thank you all for your tips! @BIGAL@lrm@exceed

 

@BIGAL your code works Thanks a lot.

 

On most of my drawings i have dozens of edges to manually change.

Your code needs always a manual input. Do you think that with your approach is possible to apply this code to all closed plines on the drawing without manual input?

 

Thanks in advance.

 

[BIGAL]

The shapes maybe to complex to put a rule about what to do. 

 

Is 8 seconds to much out of your day ?

[Trap3d]

Yeah you should be right about that.

 

Well, your code is already a good way to speed things up

[exceed]

 

; DentRepair - 2023.09.15 exceeds
; Dent repairs polyline segments with vertical and horizontal outlines outwards.
; If the length of one line segment is less than a certain value, it adjusted out to a wider side.

(defun c:DentRepair ( / *error* acdoc ss ssl index ent obj clist cllen 
                      isclosed index2 p0 p1 p2 p3 linelength
                      lineangle setlength tempclist1 tempclist2
                      temp1 temp2 temp1obj temp2obj temp1area 
                      temp2area stopper resultent
                    )
  (vl-load-com)

  (defun *error* (msg) 
    (if (/= msg "Function cancelled") 
      (princ (strcat "\nError: " msg))
    )
    (vla-EndUndoMark acdoc)
    (princ)
  )
  
  ;; Group by Number  -  Lee Mac
  ;; Groups a list 'l' into a list of lists, each of max length 'n'
  (defun LM:group<n ( l n )
      (if l (LM:group<n-sub (cons nil l) n n))
  )
  (defun LM:group<n-sub ( l m n )
      (if (and (cdr l) (< 0 n))
          (LM:group<n-sub (cons (cons (cadr l) (car l)) (cddr l)) m (1- n))
          (cons (reverse (car l)) (LM:group<n (cdr l) m))
      )
  )

  ;;---------------------=={ Subst Nth }==----------------------;;
  ;;                                                            ;;
  ;;  Substitutes an item at the nth position in a list.        ;;
  ;;------------------------------------------------------------;;
  ;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
  ;;------------------------------------------------------------;;
  ;;  Arguments:                                                ;;
  ;;  a - item to substitute                                    ;;
  ;;  n - position in list to make the substitution             ;;
  ;;  l - list in which to make the substitution                ;;
  ;;------------------------------------------------------------;;
  ;;  Returns:  Resultant list following the substitution       ;;
  ;;------------------------------------------------------------;;
  
  (defun LM:SubstNth ( a n l )
      (if l
          (if (zerop n)
              (cons a (cdr l))
              (cons (car l) (LM:SubstNth a (1- n) (cdr l)))
          )
      )
  )
  
  ;; Unique  -  Lee Mac
  ;; Returns a list with duplicate elements removed.
  (defun LM:Unique ( l )
    (if l (cons (car l) (LM:Unique (vl-remove (car l) (cdr l)))))
  )
  
  ; degree to radian
  (defun dtr (a) 
    (setq x (* pi (/ a 180.0)))
  )
  
  ; radian to degree
  (defun rtd (a) 
    (setq x (/ (* a 180) pi))
  )
  
  (defun lwpolybylist (lst cls) 
    (entmakex 
      (append 
        (list 
          (cons 0 "LWPOLYLINE")
          (cons 100 "AcDbEntity")
          (cons 100 "AcDbPolyline")
          (cons 90 (length lst))
          (cons 70 cls)
        )
        (mapcar (function (lambda (p) (cons 10 p))) lst)
      )
    )
  )
  (setq acdoc (vla-get-ActiveDocument (vlax-get-ACAD-Object)))
  (vla-StartUndoMark acdoc)
  
  (setq setlength (getreal "\n Input Minimum Segment Value (Space Bar = 1.5): ")) ; can edit this value 
  (if (= setlength nil)
    (setq setlength 1.5)
    (setq setlength (abs setlength))
  )
  
  (setq ss (ssget '((0 . "LWPOLYLINE"))))
  (setq ssl (sslength ss))
  (setq index 0)
  (repeat ssl
    (setq ent (ssname ss index))
    (setq obj (vlax-ename->vla-object ent))
    (setq clist (vlax-safearray->list (vlax-variant-value (vlax-get-property obj 'coordinates))))
    (setq cllen (length clist))
    (setq isclosed (vlax-get-property obj 'closed))
    ;(princ "\n isclosed? ")
    ;(princ isclosed)
    (if (= isclosed :vlax-true)
      (progn
        (setq clist (append clist (list (car clist) (cadr clist))))
      )
      (progn
        (if (and (= (car clist) (nth (- cllen 2) clist)) (= (cadr clist) (nth (- cllen 1) clist)))
          (progn)
          (progn
            (setq clist (append clist (list (car clist) (cadr clist))))
          )
        )
      )
    )
    (setq clist (lm:unique (lm:group<n clist 2)))
    ;(princ "\n clist - ")
    ;(princ clist)
    (setq cllen (length clist))
    (setq index2 0)
    (if (>= cllen 4)
      (progn
        (repeat cllen
          (if (and (/= index2 0) (/= resultent nil))
            (entdel resultent)
          )
          (setq p1 (nth index2 clist))
          (if (= (- cllen 1) index2)
            (setq p2 (nth 0 clist))
            (setq p2 (nth (+ index2 1) clist))
          )
          (if (= index2 0)
            (setq p0 (last clist))
            (setq p0 (nth (- index2 1) clist))
          )
          (if (<= index2 (- cllen 3))
            (setq p3 (nth (+ index2 2) clist))
            (setq p3 (nth (- (+ index2 2) cllen) clist))
          )  
          (setq linelength (distance p1 p2))
          ;(princ "\n linelength - ")
          ;(princ linelength)
          (setq lineangle (rtd (angle p1 p2)))
          ;(princ "\n lineangle - ")
          ;(princ lineangle)
          (setq tempclist1 '())
          (setq tempclist2 '())
          (if (>= linelength setlength)
            (progn
              ;(if (or (= lineangle 0) (= lineangle 90) (= lineangle 180) (= lineangle 270) (= lineangle 360))
              ;  (progn)
              ;  (progn)
              ;)
            )
            (progn
              (cond 
                ((or (= (rtos lineangle 2 0) "0") (= (rtos lineangle 2 0) "180")) ;horizontal line
                  (setq tempclist1 (LM:SubstNth (list (car p1) (cadr p0)) index2 clist))
                  (setq tempclist1 (LM:SubstNth (list (car p2) (cadr p0)) (if (= (- cllen 1) index) 0 (+ index2 1)) tempclist1))
                  (setq tempclist2 (LM:SubstNth (list (car p1) (cadr p3)) index2 clist))
                  (setq tempclist2 (LM:SubstNth (list (car p2) (cadr p3)) (if (= (- cllen 1) index) 0 (+ index2 1)) tempclist2))
                )
                ((or (= (rtos lineangle 2 0) "90") (= (rtos lineangle 2 0) "270") (= (rtos lineangle 2 0) "360")) ;verical line
                  (setq tempclist1 (LM:SubstNth (list (car p0) (cadr p1)) index2 clist))
                  (setq tempclist1 (LM:SubstNth (list (car p0) (cadr p2)) (if (= (- cllen 1) index) 0 (+ index2 1)) tempclist1))
                  (setq tempclist2 (LM:SubstNth (list (car p3) (cadr p1)) index2 clist))
                  (setq tempclist2 (LM:SubstNth (list (car p3) (cadr p2)) (if (= (- cllen 1) index) 0 (+ index2 1)) tempclist2))
                )
                (t
                  (setq tempclist1 clist)
                  (setq tempclist2 clist)
                )
              )
              ;(princ "\n tempclist1 - ")
              ;(princ tempclist1)
              (setq temp1 (lwpolybylist tempclist1 1))
              ;(princ "\n tempclist2 - ")
              ;(princ tempclist2)
              (setq temp2 (lwpolybylist tempclist2 1))
              (setq temp1obj (vlax-ename->vla-object temp1))
              (setq temp2obj (vlax-ename->vla-object temp2))
              (setq temp1area (vla-get-area temp1obj))
              (setq temp2area (vla-get-area temp2obj))
              (if (>= temp1area temp2area)
                (setq clist tempclist1)
                (setq clist tempclist2)
              )
              (entdel temp1)
              (entdel temp2)
            )
          )
          (setq resultent (lwpolybylist clist 1))
          ;(setq stopper (getstring "\n continue ? : "))
          ;(princ "\n index2 - ")
          ;(princ index2)
          ;(princ " / cllen - ")
          ;(princ cllen)
          (setq index2 (+ index2 1))
        )
      )
      (progn
        (princ "\n not enough vertices. (less then 4)")
      )
    )
    ;(setq stopper (getstring "\n continue ? : "))
    (setq index (+ index 1))
  )
  (vla-EndUndoMark acdoc)
  (princ)
)

 

You can start with this.

 

command : DENTREPAIR

 

Below GIF is for example (with pauses to show the calculation step by step)

 

 

+

This isn't a perfect solution.

The steps in this routine are...

 

1. Measure the length of each line segment of the polyline.

2. If it is less than the set value (=1.5),

3. determine whether the line segment is vertical or horizontal,

4. Get the X (for a vertical line) or Y (for a horizontal line) value of both nodes adjacent to the line segment.

5. Replace the values in the original coordinate list

6. After creating each polyline, Compare each area and select the larger one.

7. Repeat this by looping each line segment.

 

It is useful when there is a large fixed outline with small cracks,

but the leakage point of this logic is
if it is sharp, that part can be omitted.

-> sharp means If there is a line segment that protrudes to the outermost edge with a value smaller than the entered value of 1.5

 

This is because the two neighboring points of this sharp point are

located in a direction where the area is smaller than the original outline.

 

In that case, the original point should be included in the comparison to find the one with the largest area among the 3 cases.

If the original wins, this case is difficult, 

picked line segment is not modified, but both neighboring points need to be modified.

 

 

 

It is difficult to solve this problem by simply running a forward loop.

Even after modifying the neighboring points on both sides, need to check whether the rules are correct

retrieve the coordinate list again, and the node numbers may also be messed up.

 

Of course, this may be difficult only for me.

Because there are many smart people. 

 

 

so I created a routine to create a new line above it. not modifying original line.

It would be better to check manually.

Edited September 15, 2023 by exceed

[Trap3d]

Thanks a lot @exceed! Its really what I was looking for.

Sorry for late response, I was on holidays

 

Your code works for most of the cases I have. Only one issue that i found out.

If the first point of the output has different x and y coordinates comparing to the last one, the last segment that joins both points will have diagonal orientation.

There is a way to make sure that all segments in the end are either horizontal or vertical? Usually i have almost an hundred of lines to change.

Thanks in advance

 

(See .dwg bellow with examples of shapes that have one diagonal segment after running de code)

 

 

 

 

example.dwg

[marko_ribar]

See if this topic can help you... It seems that doesn't, but imagine that you had more LWPOLYs and you wanted to join them... Then this would be full hit...

https://www.cadtutor.net/forum/topic/63954-lisp-to-create-a-boundary-around-blocks-that-are-not-touching

[marko_ribar]

@exceed

 

Sorry for stealing your code, I just made quick fix, as OP wasn't satisfied...

 

; DentRepair - 2023.09.15 exceeds
; Dent repairs polyline segments with vertical and horizontal outlines outwards.
; If the length of one line segment is less than a certain value, it adjusted out to a wider side.

(defun c:DentRepair ( / *error* LM:group<n LM:group<n-sub LM:SubstNth LM:Unique dtr rtd collinear-p lwpolybylist
                      acdoc ss index ent obj clist cllen 
                      isclosed index2 p0 p1 p2 p3 linelength
                      lineangle setlength tempclist1 tempclist2
                      temp1 temp2 temp1obj temp2obj temp1area 
                      temp2area stopper resultent clistx ps pe
                    )

  (vl-load-com)

  (defun *error* (msg) 
    (if (/= msg "Function cancelled") 
      (princ (strcat "\nError: " msg))
    )
    (vla-EndUndoMark acdoc)
    (princ)
  )

  ;; Group by Number  -  Lee Mac
  ;; Groups a list 'l' into a list of lists, each of max length 'n'
  (defun LM:group<n ( l n )
    (if l (LM:group<n-sub (cons nil l) n n))
  )

  (defun LM:group<n-sub ( l m n )
    (if (and (cdr l) (< 0 n))
      (LM:group<n-sub (cons (cons (cadr l) (car l)) (cddr l)) m (1- n))
      (cons (reverse (car l)) (LM:group<n (cdr l) m))
    )
  )

  ;;---------------------=={ Subst Nth }==----------------------;;
  ;;                                                            ;;
  ;;  Substitutes an item at the nth position in a list.        ;;
  ;;------------------------------------------------------------;;
  ;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
  ;;------------------------------------------------------------;;
  ;;  Arguments:                                                ;;
  ;;  a - item to substitute                                    ;;
  ;;  n - position in list to make the substitution             ;;
  ;;  l - list in which to make the substitution                ;;
  ;;------------------------------------------------------------;;
  ;;  Returns:  Resultant list following the substitution       ;;
  ;;------------------------------------------------------------;;

  (defun LM:SubstNth ( a n l )
    (if l
      (if (zerop n)
        (cons a (cdr l))
        (cons (car l) (LM:SubstNth a (1- n) (cdr l)))
      )
    )
  )

  ;; Unique  -  Lee Mac
  ;; Returns a list with duplicate elements removed.
  (defun LM:Unique ( l )
    (if l (cons (car l) (LM:Unique (vl-remove (car l) (cdr l)))))
  )

  ; degree to radian
  (defun dtr (a) 
    (setq x (* pi (/ a 180.0)))
  )

  ; radian to degree
  (defun rtd (a) 
    (setq x (/ (* a 180) pi))
  )

  (defun collinear-p ( p1 p p2 )
    (equal (distance p1 p2) (+ (distance p1 p) (distance p p2)) 1e-6)
  )

  (defun lwpolybylist (lst cls) 
    (entmakex 
      (append 
        (list 
          (cons 0 "LWPOLYLINE")
          (cons 100 "AcDbEntity")
          (cons 100 "AcDbPolyline")
          (cons 90 (length lst))
          (cons 70 cls)
        )
        (mapcar (function (lambda (p) (cons 10 p))) lst)
      )
    )
  )

  (setq acdoc (vla-get-ActiveDocument (vlax-get-ACAD-Object)))
  (vla-StartUndoMark acdoc)
  
  (setq setlength (getreal "\n Input Minimum Segment Value (Space Bar = 1.5): ")) ; can edit this value 
  (if (= setlength nil)
    (setq setlength 1.5)
    (setq setlength (abs setlength))
  )
  
  (setq ss (ssget '((0 . "LWPOLYLINE"))))
  (repeat (setq index (sslength ss))
    (setq ent (ssname ss (setq index (1- index))))
    (setq obj nil clist nil cllen nil isclosed nil resultent nil p1 nil p2 nil p0 nil p3 nil linelength nil lineangle nil tempclist1 nil tempclist2 nil temp1 nil temp2 nil temp1area nil temp2area nil temp1obj nil temp2obj nil)
    (setq obj (vlax-ename->vla-object ent))
    (setq clist (vlax-safearray->list (vlax-variant-value (vlax-get-property obj 'coordinates))))
    (setq cllen (length clist))
    (setq isclosed (vlax-get-property obj 'closed))
    ;(princ "\n isclosed? ")
    ;(princ isclosed)
    (if (= isclosed :vlax-false)
      (progn
        (if (and (= (car clist) (nth (- cllen 2) clist)) (= (cadr clist) (nth (- cllen 1) clist)))
          (progn)
          (setq clist (append clist (list (car clist) (cadr clist))))
        )
      )
    )
    (setq clist (lm:unique (lm:group<n clist 2)))
    ;(princ "\n clist - ")
    ;(princ clist)
    (setq cllen (length clist))
    (setq index2 0)
    (if (>= cllen 4)
      (progn
        (repeat cllen
          (if (and (/= index2 0) (/= resultent nil))
            (entdel resultent)
          )
          (setq p1 (nth index2 clist))
          (if (= (- cllen 1) index2)
            (setq p2 (nth 0 clist))
            (setq p2 (nth (+ index2 1) clist))
          )
          (if (= index2 0)
            (setq p0 (last clist))
            (setq p0 (nth (- index2 1) clist))
          )
          (if (<= index2 (- cllen 3))
            (setq p3 (nth (+ index2 2) clist))
            (setq p3 (nth (- (+ index2 2) cllen) clist))
          )  
          (setq linelength (distance p1 p2))
          ;(princ "\n linelength - ")
          ;(princ linelength)
          (setq lineangle (rtd (angle p1 p2)))
          ;(princ "\n lineangle - ")
          ;(princ lineangle)
          (setq tempclist1 '())
          (setq tempclist2 '())
          (if (>= linelength setlength)
            (progn
              ;(if (or (= lineangle 0) (= lineangle 90) (= lineangle 180) (= lineangle 270) (= lineangle 360))
              ;  (progn)
              ;  (progn)
              ;)
            )
            (progn
              (cond 
                ( (or (= (rtos lineangle 2 0) "0") (= (rtos lineangle 2 0) "180") (= (rtos lineangle 2 0) "360")) ;horizontal line
                  (setq tempclist1 (LM:SubstNth (list (car p1) (cadr p0)) index2 clist))
                  (setq tempclist1 (LM:SubstNth (list (car p2) (cadr p0)) (if (= (- cllen 1) index) 0 (+ index2 1)) tempclist1))
                  (setq tempclist2 (LM:SubstNth (list (car p1) (cadr p3)) index2 clist))
                  (setq tempclist2 (LM:SubstNth (list (car p2) (cadr p3)) (if (= (- cllen 1) index) 0 (+ index2 1)) tempclist2))
                )
                ( (or (= (rtos lineangle 2 0) "90") (= (rtos lineangle 2 0) "270")) ;verical line
                  (setq tempclist1 (LM:SubstNth (list (car p0) (cadr p1)) index2 clist))
                  (setq tempclist1 (LM:SubstNth (list (car p0) (cadr p2)) (if (= (- cllen 1) index) 0 (+ index2 1)) tempclist1))
                  (setq tempclist2 (LM:SubstNth (list (car p3) (cadr p1)) index2 clist))
                  (setq tempclist2 (LM:SubstNth (list (car p3) (cadr p2)) (if (= (- cllen 1) index) 0 (+ index2 1)) tempclist2))
                )
                ( t
                  (setq tempclist1 clist)
                  (setq tempclist2 clist)
                )
              )
              ;(princ "\n tempclist1 - ")
              ;(princ tempclist1)
              (setq temp1 (lwpolybylist tempclist1 1))
              ;(princ "\n tempclist2 - ")
              ;(princ tempclist2)
              (setq temp2 (lwpolybylist tempclist2 1))
              (setq temp1obj (vlax-ename->vla-object temp1))
              (setq temp2obj (vlax-ename->vla-object temp2))
              (setq temp1area (vla-get-area temp1obj))
              (setq temp2area (vla-get-area temp2obj))
              (if (>= temp1area temp2area)
                (setq clist tempclist1)
                (setq clist tempclist2)
              )
              (entdel temp1)
              (entdel temp2)
            )
          )
          ;(setq stopper (getstring "\n continue ? : "))
          ;(princ "\n index2 - ")
          ;(princ index2)
          ;(princ " / cllen - ")
          ;(princ cllen)
          (setq index2 (+ index2 1))
        )
      )
      (progn
        (princ "\n not enough vertices. (less then 4)")
      )
    )
    ;(setq stopper (getstring "\n continue ? : "))
    (setq clistx nil)
    (setq clist (LM:Unique clist))
    (if (vl-some '(lambda ( a b ) (not (or (equal (angle a b) (* 0.0 pi) 1e-8) (equal (angle a b) (* 0.5 pi) 1e-8) (equal (angle a b) (* 1.0 pi) 1e-8) (equal (angle a b) (* 1.5 pi) 1e-8) (equal (angle a b) (* 2.0 pi) 1e-8)))) (append clist clist) (append (cdr clist) (list (car clist)) (cdr clist) (list (car clist))))
      (progn
        (setq clistx (vl-remove (last clist) clist))
        (if (vl-some '(lambda ( a b ) (not (or (equal (angle a b) (* 0.0 pi) 1e-8) (equal (angle a b) (* 0.5 pi) 1e-8) (equal (angle a b) (* 1.0 pi) 1e-8) (equal (angle a b) (* 1.5 pi) 1e-8) (equal (angle a b) (* 2.0 pi) 1e-8)))) (append clistx clistx) (append (cdr clistx) (list (car clistx)) (cdr clistx) (list (car clistx))))
          (setq clistx (vl-remove (car clist) clist))
        )
        (setq pe (last clist))
        (setq ps (car clist))
        (cond
          ( (< (abs (- (car pe) (car ps))) setlength)
            (setq clist (LM:SubstNth (list (car (nth 1 clist)) (cadr (nth (1- (length clist)) clist))) 0 clist))
            (setq clist (vl-remove (last clist) clist))
            (setq clist (append clist (list (list (car ps) (cadr pe)))))
          )
          ( (< (abs (- (cadr pe) (cadr ps))) setlength)
            (setq clist (LM:SubstNth (list (cadr (nth 1 clist)) (car (nth (1- (length clist)) clist))) 0 clist))
            (setq clist (vl-remove (last clist) clist))
            (setq clist (append clist (list (list (car pe) (cadr ps)))))
          )
        )
        (setq clistx clist)
        (if (or (< (abs (- (car pe) (car ps))) setlength) (< (abs (- (cadr pe) (cadr ps))) setlength))
          (setq clistx (append (list (list (car (cadr clistx)) (cadr (last clistx)))) (cdr clistx)))
        )
      )
      (setq clistx clist)
    )
    (setq clistx (vl-remove nil (apply 'append (mapcar '(lambda ( a b c ) (if (collinear-p a b c) (list nil) (list b))) (cons (last clistx) (reverse (cdr (reverse clistx)))) clistx (append (cdr clistx) (list (car clistx)))))))
    (if (vl-some '(lambda ( a b ) (not (or (equal (angle a b) (* 0.0 pi) 1e-8) (equal (angle a b) (* 0.5 pi) 1e-8) (equal (angle a b) (* 1.0 pi) 1e-8) (equal (angle a b) (* 1.5 pi) 1e-8) (equal (angle a b) (* 2.0 pi) 1e-8)))) (append clistx clistx) (append (cdr clistx) (list (car clistx)) (cdr clistx) (list (car clistx))))
      (setq clistx (append (list (list (car (last clistx)) (cadr (car clistx)))) clistx))
    )
    (setq resultent (lwpolybylist (LM:Unique clistx) 1))
  )
  (vla-EndUndoMark acdoc)
  (princ)
)

 

HTH.

M.R.

Edited October 1, 2023 by marko_ribar

[marko_ribar]

I am satisfied with my intervention...

OP : You can check it now and tell us is it satisfying your request...

 

HTH.

M.R.

[marko_ribar]

I've put together something similar - it looks for distance, but then just remove segments leaving non orthogonal polyline which is what OP don't want...

But nevertheless here is the code :

 

(defun c:dentrepair-MR ( / *error* makelw unique collinear-p adoc r ss i lw pl data d pll segsv segsh )

  (vl-load-com)

  (defun *error* ( m )
    (if (= 8 (logand 8 (getvar 'undoctl)))
      (vla-endundomark adoc)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (defun makelw ( pl cl )
    (entmake
      (append
        (list
          '(0 . "LWPOLYLINE")
          '(100 . "AcDbEntity")
          '(100 . "AcDbPolyline")
           (cons 90 (length pl))
           (cons 70 cl)
        )
        (mapcar '(lambda ( p ) (cons 10 p)) pl)
          '((210 0.0 0.0 1.0))
      )
    )
  )

  (defun unique ( lst )
    (if lst
      (cons (car lst)
        (unique (vl-remove-if '(lambda ( x ) (equal x (car lst) 1e-6)) (cdr lst)))
      )
    )
  )

  (defun collinear-p ( p1 p p2 )
    (equal (distance p1 p2) (+ (distance p1 p) (distance p p2)) 1e-6)
  )

  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (if (= 8 (logand 8 (getvar 'undoctl)))
    (vla-endundomark adoc)
  )
  (vla-startundomark adoc)
  (initget 4)
  (setq r (getdist "\nPick or specify radius of distance segment line length <1.5> : "))
  (if (not r)
    (setq r 1.5)
  )
  (prompt "\nSelect closed polygonal orthogonal LWPOLYLINE(s)...")
  (if (setq ss (ssget '((0 . "LWPOLYLINE") (-4 . "&") (70 . 1) (-4 . "<not") (-4 . "<>") (42 . 0) (-4 . "not>"))))
    (repeat (setq i (sslength ss))
      (setq lw (ssname ss (setq i (1- i))))
      (vla-getboundingbox (vlax-ename->vla-object lw) 'll 'ur)
      (mapcar 'set '(ll ur) (mapcar 'safearray-value (list ll ur)))
      (if (and (>= r (- (car ur) (car ll))) (>= r (- (cadr ur) (cadr ll))))
        (makelw (list ll (list (car ur) (cadr ll)) ur (list (car ll) (cadr ur))) (1+ (* 128 (getvar 'plinegen))))
        (progn
          (setq pl (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (entget lw))))
          (setq data (mapcar '(lambda ( a b ) (list a b (distance a b) (angle a b))) pl (append (cdr pl) (list (car pl)))))
          (while (setq d (car data))
            (setq data (cdr data))
            (if (>= r (caddr d))
              (cond
                ( (or (equal (cadddr d) (* 0.5 pi) 1e-6) (equal (cadddr d) (* 1.5 pi) 1e-6))
                  (setq segsv (cons (list (car d) (cadr d)) segsv))
                )
                ( (or (equal (cadddr d) (* 0.0 pi) 1e-6) (equal (cadddr d) (* 1.0 pi) 1e-6) (equal (cadddr d) (* 2.0 pi) 1e-6))
                  (setq segsh (cons (list (car d) (cadr d)) segsh))
                )
              )
            )
          )
          (setq data (mapcar '(lambda ( a b ) (list a b)) pl (append (cdr pl) (list (car pl)))))
          (mapcar '(lambda ( a ) (vl-some '(lambda ( b ) (if (equal a b 1e-6) (setq pll (cons (car a) pll) pll (cons (cadr a) pll)))) (append segsv segsh))) data)
          (if pll
            (progn
              (setq pll (unique pll))
              (setq pll (vl-remove nil (apply 'append (mapcar '(lambda ( a b c ) (if (collinear-p a b c) (list nil) (list b))) (cons (last pll) (reverse (cdr (reverse pll)))) pll (append (cdr pll) (list (car pll)))))))
              (makelw (unique pll) (1+ (* 128 (getvar 'plinegen))))
            )
          )
          (setq pll nil)
        )
      )
    )
  )
  (*error* nil)
)

 

HTH.

M.R.

Edited September 29, 2023 by marko_ribar

[marko_ribar]

Here is something OP can accept, but it has lacks... Still another attempt - better more than less...

 

(defun c:dentrepair-MMR ( / *error* makelw unique collinear-p clockwise-p rlw osm cmd adoc r ss i lw ll lr ur ul lwo pl data d dx pll plll segs segsv segsh pre suf )

  (vl-load-com)

  (defun *error* ( m )
    (if osm
      (setvar 'osmode osm)
    )
    (if cmd
      (setvar 'cmdecho cmd)
    )
    (if (= 8 (logand 8 (getvar 'undoctl)))
      (vla-endundomark adoc)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (defun makelw ( pl cl )
    (entmakex
      (append
        (list
          '(0 . "LWPOLYLINE")
          '(100 . "AcDbEntity")
          '(100 . "AcDbPolyline")
           (cons 90 (length pl))
           (cons 70 cl)
        )
        (mapcar '(lambda ( p ) (cons 10 p)) pl)
          '((210 0.0 0.0 1.0))
      )
    )
  )

  (defun unique ( lst )
    (if lst
      (cons (car lst)
        (unique (vl-remove-if '(lambda ( x ) (equal x (car lst) 1e-6)) (cdr lst)))
      )
    )
  )

  (defun collinear-p ( p1 p p2 )
    (equal (distance p1 p2) (+ (distance p1 p) (distance p p2)) 1e-6)
  )

  (defun clockwise-p ( p1 p2 p3 )
    (minusp (- (* (car (mapcar '- p2 p1)) (cadr (mapcar '- p3 p1))) (* (cadr (mapcar '- p2 p1)) (car (mapcar '- p3 p1)))))
  )

  (defun rlw ( lw / e x1 x2 x3 x4 x5 x6 )
    ;; by ElpanovEvgeniy
    (if (= (cdr (assoc 0 (setq e (entget lw)))) "LWPOLYLINE")
      (progn
        (foreach a1 e
          (cond ((= (car a1) 10) (setq x2 (cons a1 x2)))
                ((= (car a1) 40) (setq x4 (cons (cons 41 (cdr a1)) x4)))
                ((= (car a1) 41) (setq x3 (cons (cons 40 (cdr a1)) x3)))
                ((= (car a1) 42) (setq x5 (cons (cons 42 (- (cdr a1))) x5)))
                ((= (car a1) 210) (setq x6 (cons a1 x6)))
                (t (setq x1 (cons a1 x1)))
          )
        )
        (entmod (append (reverse x1)
                  (append (apply 'append
                            (apply 'mapcar
                              (cons 'list
                                (list x2
                                  (cdr (reverse (cons (car x3) (reverse x3))))
                                  (cdr (reverse (cons (car x4) (reverse x4))))
                                  (cdr (reverse (cons (car x5) (reverse x5))))
                                )
                              )
                            )
                          )
                          x6
                  )
                )
        )
        (entupd lw)
      )
    )
  )

  (setq osm (getvar 'osmode))
  (setvar 'osmode 0)
  (setq cmd (getvar 'cmdecho))
  (setvar 'cmdecho 0)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (if (= 8 (logand 8 (getvar 'undoctl)))
    (vla-endundomark adoc)
  )
  (vla-startundomark adoc)
  (initget 4)
  (setq r (getdist "\nPick or specify radius of distance segment line length <1.5> : "))
  (if (not r)
    (setq r 1.5)
  )
  (prompt "\nSelect closed polygonal orthogonal LWPOLYLINE(s)...")
  (if (setq ss (ssget '((0 . "LWPOLYLINE") (-4 . "&") (70 . 1) (-4 . "<not") (-4 . "<>") (42 . 0) (-4 . "not>"))))
    (repeat (setq i (sslength ss))
      (setq lw (ssname ss (setq i (1- i))))
      (setq pl nil pll nil data nil segsv nil segsh nil segs nil)
      (setq lwo (vlax-vla-object->ename (car (vlax-invoke (vlax-ename->vla-object lw) 'offset -1e-3))))
      (if (< (vlax-curve-getarea lwo) (vlax-curve-getarea lw))
        (entdel lwo)
        (progn
          (entdel lwo)
          (rlw lw)
        )
      )
      (vla-getboundingbox (vlax-ename->vla-object lw) 'll 'ur)
      (mapcar 'set '(ll ur) (mapcar 'safearray-value (list ll ur)))
      (setq lr (list (car ur) (cadr ll)) ul (list (car ll) (cadr ur)))
      (if (and (>= r (- (car ur) (car ll))) (>= r (- (cadr ur) (cadr ll))))
        (makelw (list ll lr ur ul) (1+ (* 128 (getvar 'plinegen))))
        (progn
          (setq pl (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (entget lw))))
          (setq data (mapcar '(lambda ( a b ) (list a b (distance a b) (angle a b))) pl (append (cdr pl) (list (car pl)))))
          (while (setq d (car data))
            (setq data (cdr data))
            (if (>= r (caddr d))
              (cond
                ( (or (equal (cadddr d) (* 0.5 pi) 1e-6) (equal (cadddr d) (* 1.5 pi) 1e-6))
                  (setq segsv (cons (list (car d) (cadr d)) segsv))
                )
                ( (or (equal (cadddr d) (* 0.0 pi) 1e-6) (equal (cadddr d) (* 1.0 pi) 1e-6) (equal (cadddr d) (* 2.0 pi) 1e-6))
                  (setq segsh (cons (list (car d) (cadr d)) segsh))
                )
              )
            )
          )
          (setq data (mapcar '(lambda ( a b ) (list a b)) pl (append (cdr pl) (list (car pl)))))
          (setq segs (unique (append segsv segsh)))
          (mapcar '(lambda ( a ) (vl-some '(lambda ( b ) (if (equal a b 1e-6) (setq pll (cons (car a) pll) pll (cons (cadr a) pll)))) segs)) data)
          (if pll
            (progn
              (setq pll (vl-remove-if '(lambda ( x ) (or (null (car x)) (null (cadr x)))) (unique pll)))
              (setq data (mapcar '(lambda ( a b ) (list a b (distance a b) (angle a b))) pll (append (cdr pll) (list (car pll)))))
              (foreach d data
                (if (not (or (equal (cadddr d) (* 0.5 pi) 1e-6) (equal (cadddr d) (* 1.5 pi) 1e-6) (equal (cadddr d) (* 0.0 pi) 1e-6) (equal (cadddr d) (* 1.0 pi) 1e-6) (equal (cadddr d) (* 2.0 pi) 1e-6)))
                  (progn
                    (setq pre (reverse (vl-member-if '(lambda ( x ) (equal x (car d) 1e-6)) (reverse pll))))
                    (setq suf (vl-member-if '(lambda ( x ) (equal x (cadr d) 1e-6)) pll))
                    (setq dx (cons (list (car (car d)) (cadr (cadr d))) dx))
                    (setq dx (cons (list (cadr (cadr d)) (car (car d))) dx))
                    (setq dx (cons (list (cadr (car d)) (car (cadr d))) dx))
                    (setq dx (cons (list (car (cadr d)) (cadr (car d))) dx))
                    (foreach x dx
                      (if (and (clockwise-p (last pre) x (car suf)) (or (equal (angle (last pre) x) (* 0.0 pi) 1e-6) (equal (angle (last pre) x) (* 0.5 pi) 1e-6) (equal (angle (last pre) x) (* 1.0 pi) 1e-6) (equal (angle (last pre) x) (* 1.5 pi) 1e-6) (equal (angle (last pre) x) (* 2.0 pi) 1e-6)) (or (equal (angle x (car suf)) (* 0.0 pi) 1e-6) (equal (angle x (car suf)) (* 0.5 pi) 1e-6) (equal (angle x (car suf)) (* 1.0 pi) 1e-6) (equal (angle x (car suf)) (* 1.5 pi) 1e-6) (equal (angle x (car suf)) (* 2.0 pi) 1e-6)))
                        (setq pll (append pre (list x) suf))
                      )
                    )
                    (setq dx nil)
                  )
                )
              )
              (setq pll (unique pll))
              (setq pll (vl-remove nil (apply 'append (mapcar '(lambda ( a b c ) (if (collinear-p a b c) (list nil) (list b))) (cons (last pll) (reverse (cdr (reverse pll)))) pll (append (cdr pll) (list (car pll)))))))
              (setq lwo (makelw pll (1+ (* 128 (getvar 'plinegen)))))
              (if (> (vlax-curve-getarea lw) (vlax-curve-getarea lwo))
                (entdel lwo)
              )
            )
          )
        )
      )
    )
  )
  (*error* nil)
)

 

HTH.

M.R.

Edited October 1, 2023 by marko_ribar

[Trap3d]

Hello @marko_ribar thanks a lot for your dedication on this topic.

 

I have been testing your codes and @exceedcode as well this week. Exceed code works just as i wanted, but the diagonal line joining the first and the final point still shows only on specific shapes for some reason.

In order hand, your code works fine but sometimes misses some shapes (see example).

I will try to find a code able to replace the diagonal lines for horizontal and/or vertical lines accordingly.

INPUT.dwg