To Find Self Intersection of LWPOLYLINE

[MehtaRajesh]

Hi,

I am posting useful function to find Self Intersection for selected LWPOLYLINE.
You might be having other options, but I find this one as a quickest and Simple


(defun IsSelfIntersect (l / vcnt vcnt1 crossresult pt1 pt2 pt3 pt4)
(setq vcnt 0)
(setq crossresult F)
(repeat (1- (length l))
 (setq pt1 (nth vcnt l))
   (setq pt2 (nth (1+ vcnt) l))
   (setq vcnt1 vcnt)
 (setq isdone "T")
 (while isdone
  (if (and (nth (+ 2 vcnt) l) (nth (+ 3 vcnt) l))
  (progn
   (setq pt3 (nth (+ 2 vcnt) l))
   (setq pt4 (nth (+ 3 vcnt) l))
       (if (inters pt1 pt2 pt3 pt4)
   (progn
      (setq crossresult T)
   );progn
   );if
  );progn
  (progn
   (setq isdone nil)
  );progn
  );if
    (setq vcnt (1+ vcnt))
 );while
   (setq vcnt (1+ vcnt1)) 
);repeat
crossresult
);defun

Below Function to get the Coordinate list of LWPOLYLINE

(defun lwptslw (lst / pair rtn)
  (while (setq pair (assoc 10 lst))
    (setq rtn (cons (cdr pair) rtn)
   lst (cdr (member pair lst))
    )
  )
  (reverse rtn)
)

USAGE:
Command: (IsSelfIntersect (LWPTSLW (ENTGET (CAR (ENTSEL "\nSelect Lwpolyline to find Self Intersectioni")))))

Regards,
Rajesh

[marko_ribar]

Hi there...

I took some spare time to prettify @john.uhden latest code for which I think it's the best up to now... I hope this helps @АлексЮстасу ...

(defun c:selfinters3 ( / *error* selfsinfo isoobjs unisoobjs unique selfinters3 cmd lw ti mult sp selfs )

  (or (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil))) (vl-load-com))

  (defun *error* ( m selfs sp )
    (if (= 8 (logand 8 (getvar (quote undoctl))))
      (if command-s
        (command-s "_.undo" "_e")
        (vl-cmdf "_.undo" "_e")
      )
    )
    (if cmd
      (setvar (quote cmdecho) cmd)
    )
    (if m
      (progn
        (prompt "\n")
        (if selfs
          (selfsinfo selfs sp)
        )
        (prompt "\n")
        (prompt m)
        (princ)
      )
      (progn
        (prompt "\n")
        (if selfs
          (selfsinfo selfs sp)
        )
        (prompt "\n")
        (princ)
      )
    )
  )

  (defun selfsinfo ( selfs sp )
    (setq selfs (mapcar (function (lambda ( x ) (mapcar (function +) sp x))) (unique selfs 1e-12)))
    (setq selfs (mapcar (function (lambda ( x ) (mapcar (function (lambda ( y ) (* y 1e+6))) x))) (unique selfs 1e-12)))
    (princ
      (strcat "("
        (vl-string-right-trim " "
          (apply (function strcat)
            (mapcar
              (function
                (lambda ( x )
                  (strcat "("
                    (vl-string-right-trim " "
                      (apply (function strcat)
                        (mapcar
                          (function
                            (lambda ( y )
                              (strcat (rtos y 2 16) " ")
                            )
                          )
                          x
                        )
                      )
                    )
                    ") "
                  )
                )
              )
              selfs
            )
          )
        )
        ")"
      )
    )
  )

  (defun isoobjs ( s / ss i e enx rtn )
    (setq ss (ssget "_X"))
    (repeat (setq i (sslength ss))
      (setq e (ssname ss (setq i (1- i))))
      (if (and (not (ssmemb e s)) (not (vl-position (cons 60 1) (setq enx (entget e)))))
        (progn
          (entupd (cdr (assoc -1 (entmod (append enx (list (cons 60 1)))))))
          (setq rtn (cons e rtn))
        )
      )
    )
    rtn
  )

  (defun unisoobjs ( lst )
    (if lst
      (foreach e lst
        (entupd (cdr (assoc -1 (entmod (subst (cons 60 0) (cons 60 1) (entget e))))))
      )
    )
  )

  (defun unique ( lst fuzz / a ll )
    (while (setq a (car lst))
      (if (vl-some (function (lambda ( x ) (equal x a fuzz))) (cdr lst))
        (setq ll (cons a ll) lst (vl-remove-if (function (lambda ( x ) (equal x a fuzz))) (cdr lst)))
        (setq ll (cons a ll) lst (cdr lst))
      )
    )
    (reverse ll)
  )

  (defun selfinters3 ( e sp mult / @2d @fence obj item flat ints isolst ssci selfs -obj -item -flat filter ss -ints -selfs )
    ;; John F. Uhden (11-22-2024 through 01-01-2025)
    ;; Function finds all self intersections of a LWPolyline,
    ;;   including intersections between vertices and at vertices
    ;;   where parameters are not consecutive.
    ;; Returns T for any self-intersections or nil if none.
    ;; This version neither copies nor explodes a copy of the polyline.
    ;;   Nor does it use distances anlong the polyline path.
    ;; This version uses a square fence to ssget the polyline at all intersections
    ;;   and ssnamex to determine the number of spokes coming out of each point.
    ;;   More than 2 spokes means a self intersection.
    ;; This version places a red circle at each intersection
    ;;   and a slightly larger green circle at each self intersection.
    ;;   Feel free to remove or rem out the lines containing (entmakex ...).

    (defun @2d ( p ) (mapcar (function *) p (list 1.0 1.0)))

    (defun @fence ( p w )
      ;; where w is actually half width
      (list
        (mapcar (function +) p (list w w)) ;; upper right
        (mapcar (function +) p (list (- w) w)) ;; upper left
        (mapcar (function -) p (list w w)) ;; lower left
        (mapcar (function +) p (list w (- w))) ;; lower right
        (mapcar (function +) p (list w w)) ;; upper right (beginning but not closed)
      )
    )

    (setq isolst (isoobjs (ssadd e)))
    (vla-zoomextents (vlax-get-acad-object))
    (setq obj (vlax-ename->vla-object e))
    (setq flat (vlax-invoke obj (quote intersectwith) obj acextendnone)) ;; flat list
    (while flat
      (repeat 3 (setq item (cons (car flat) item) flat (cdr flat)))
      (setq ints (cons (@2d (reverse item)) ints) item nil)
    )
    (setq ints (reverse ints))
    (setq filter (list (cons 0 "LWPOLYLINE")))
    (setq ssci (ssadd))
    (foreach p ints
      (entmakex (list (cons 0 "CIRCLE") (cons 10 p) (cons 40 (* mult 1e-6 0.2)) (cons 62 1)))
      (ssadd (entlast) ssci)
      (and
        (setq ss (ssget "_F" (@fence p (* mult 1e-6 0.1)) filter))
        (> (length (mapcar (function cadr) (cdddr (last (ssnamex ss 0))))) 2)
        (setq selfs (cons p selfs))
        (entmakex (list (cons 0 "CIRCLE") (cons 10 p) (cons 40 (* mult 1e-6 0.3)) (cons 62 3)))
        (ssadd (entlast) ssci)
      )
    )
    (unisoobjs isolst)
    (vla-zoomprevious (vlax-get-acad-object))
    (list selfs ssci)
  )

  (setq cmd (getvar (quote cmdecho)))
  (setvar (quote cmdecho) 0)
  (if (= 8 (logand 8 (getvar (quote undoctl))))
    (vl-cmdf "_.undo" "_e")
  )
  (vl-cmdf "_.undo" "_be")
  (if (setq lw (car (entsel "\nPick LWPOLYLINE to find self-intersecting points...")))
    (if (= (cdr (assoc 0 (entget lw))) "LWPOLYLINE")
      (progn
        (initget 6)
        (setq mult (cond ( (getdist "\nPick or specify multiplication factor for circles size <1.0> : ") ) ( 1.0 )))
        (setq ti (car (_vl-times)))
        (vl-cmdf "_.scale" lw "" "_non" (list 0.0 0.0 0.0) 1e-6)
        (vl-cmdf "_.move" lw "" "_non" (setq sp (vlax-curve-getstartpoint lw)) "_non" (list 0.0 0.0 0.0))
        (setq selfs (selfinters3 lw sp mult))
        (vl-cmdf "_.move" lw "" "_non" (list 0.0 0.0 0.0) "_non" sp)
        (vl-cmdf "_.move" (cadr selfs) "" "_non" (list 0.0 0.0 0.0) "_non" sp)
        (vl-cmdf "_.scale" lw "" "_non" (list 0.0 0.0 0.0) 1e+6)
        (vl-cmdf "_.scale" (cadr selfs) "" "_non" (list 0.0 0.0 0.0) 1e+6)
        (prompt "\nElapsed time : ") (princ (rtos (- (car (_vl-times)) ti) 2 16)) (prompt " milliseconds...")
      )
      (prompt "\nPicked wrong entity type... Picked entity must be LWPOLYLINE... Better luck next time...")
    )
    (prompt "\nMissed... Better luck next time...")
  )
  (*error* nil (setq selfs (car selfs)) sp)
)

Regards, M.R.

[john.uhden]

@marko_ribar ,

I am severely impressed by your thoroughness in warding off errors and transformation to reduce huge coordinates to a size that's manageable.

The only disagreement I have with your work is that I thought the mission was to create a function that could be used on a selection set of polylines when added to superior code.

Being a civil I rarely have to deal with any UCS other than World, which means I'm pretty ignorant in the subject of transformation.

Could you please add transformation to my function so as to please @MehtaRajesh and @АлексЮстасу ?

I think the method is to scale down and move each polyline to 0,0 WCS, then perform selfinters3 which should be embellished to scale and move the polylines (with circles if desired) back to their original position and size.

Also, contrary to @АлексЮстасу , I think the function should return a list of self-intersecting polyines with self-intersection points in the format ((ename sip sip sip)(ename sip sip) etc.) so that each polyline might be corrected by subsequent code.

Hmm, come to think of it, I think the symbol names self and selfs should be renamed to sip and sips.

[marko_ribar]

@john.uhden 

I've cobbled something based on story you replied...

Here is the code :

(defun c:selfinters3-multi ( / *error* selfsinfo isoobjs unisoobjs unique selfinters3 cmd ss i lw ti mult sp selfs )

  (or (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil))) (vl-load-com))

  (defun *error* ( m selfs sp )
    (if (= 8 (logand 8 (getvar (quote undoctl))))
      (if command-s
        (command-s "_.undo" "_e")
        (vl-cmdf "_.undo" "_e")
      )
    )
    (if cmd
      (setvar (quote cmdecho) cmd)
    )
    (if m
      (progn
        (prompt "\n")
        (foreach self selfs
          (selfsinfo (car self) (cadr self) sp)
        )
        (prompt "\n")
        (prompt m)
        (princ)
      )
      (progn
        (prompt "\n")
        (foreach self selfs
          (selfsinfo (car self) (cadr self) sp)
        )
        (prompt "\n")
        (princ)
      )
    )
  )

  (defun selfsinfo ( selfs lw sp )
    (setq selfs (mapcar (function (lambda ( x ) (mapcar (function +) sp x))) (unique selfs 1e-12)))
    (setq selfs (mapcar (function (lambda ( x ) (mapcar (function (lambda ( y ) (* y 1e+6))) x))) (unique selfs 1e-12)))
    (princ
      (strcat "\n(" (vl-princ-to-string lw) " " (vl-prin1-to-string (cdr (assoc 5 (entget lw)))) " "
        (strcat "("
          (vl-string-right-trim " "
            (apply (function strcat)
              (mapcar
                (function
                  (lambda ( x )
                    (strcat "("
                      (vl-string-right-trim " "
                        (apply (function strcat)
                          (mapcar
                            (function
                              (lambda ( y )
                                (strcat (rtos y 2 16) " ")
                              )
                            )
                            x
                          )
                        )
                      )
                      ") "
                    )
                  )
                )
                selfs
              )
            )
          )
          ")"
        )
        ")"
      )
    )
  )

  (defun isoobjs ( s / ss i e enx rtn )
    (setq ss (ssget "_X"))
    (repeat (setq i (sslength ss))
      (setq e (ssname ss (setq i (1- i))))
      (if (and (not (ssmemb e s)) (not (vl-position (cons 60 1) (setq enx (entget e)))))
        (progn
          (entupd (cdr (assoc -1 (entmod (append enx (list (cons 60 1)))))))
          (setq rtn (cons e rtn))
        )
      )
    )
    rtn
  )

  (defun unisoobjs ( lst )
    (if lst
      (foreach e lst
        (entupd (cdr (assoc -1 (entmod (subst (cons 60 0) (cons 60 1) (entget e))))))
      )
    )
  )

  (defun unique ( lst fuzz / a ll )
    (while (setq a (car lst))
      (if (vl-some (function (lambda ( x ) (equal x a fuzz))) (cdr lst))
        (setq ll (cons a ll) lst (vl-remove-if (function (lambda ( x ) (equal x a fuzz))) (cdr lst)))
        (setq ll (cons a ll) lst (cdr lst))
      )
    )
    (reverse ll)
  )

  (defun selfinters3 ( e sp mult / @2d @fence obj item flat ints isolst ssci selfs -obj -item -flat filter ss -ints -selfs )
    ;; John F. Uhden (11-22-2024 through 01-01-2025)
    ;; Function finds all self intersections of a LWPolyline,
    ;;   including intersections between vertices and at vertices
    ;;   where parameters are not consecutive.
    ;; Returns T for any self-intersections or nil if none.
    ;; This version neither copies nor explodes a copy of the polyline.
    ;;   Nor does it use distances anlong the polyline path.
    ;; This version uses a square fence to ssget the polyline at all intersections
    ;;   and ssnamex to determine the number of spokes coming out of each point.
    ;;   More than 2 spokes means a self intersection.
    ;; This version places a red circle at each intersection
    ;;   and a slightly larger green circle at each self intersection.
    ;;   Feel free to remove or rem out the lines containing (entmakex ...).

    (defun @2d ( p ) (mapcar (function *) p (list 1.0 1.0)))

    (defun @fence ( p w )
      ;; where w is actually half width
      (list
        (mapcar (function +) p (list w w)) ;; upper right
        (mapcar (function +) p (list (- w) w)) ;; upper left
        (mapcar (function -) p (list w w)) ;; lower left
        (mapcar (function +) p (list w (- w))) ;; lower right
        (mapcar (function +) p (list w w)) ;; upper right (beginning but not closed)
      )
    )

    (setq isolst (isoobjs (ssadd e)))
    (vla-zoomextents (vlax-get-acad-object))
    (setq obj (vlax-ename->vla-object e))
    (setq flat (vlax-invoke obj (quote intersectwith) obj acextendnone)) ;; flat list
    (while flat
      (repeat 3 (setq item (cons (car flat) item) flat (cdr flat)))
      (setq ints (cons (@2d (reverse item)) ints) item nil)
    )
    (setq ints (reverse ints))
    (setq filter (list (cons 0 "LWPOLYLINE")))
    (setq ssci (ssadd))
    (foreach p ints
      (entmakex (list (cons 0 "CIRCLE") (cons 10 p) (cons 40 (* mult 1e-6 0.2)) (cons 62 1)))
      (ssadd (entlast) ssci)
      (and
        (setq ss (ssget "_F" (@fence p (* mult 1e-6 0.1)) filter))
        (> (length (mapcar (function cadr) (cdddr (last (ssnamex ss 0))))) 2)
        (setq selfs (cons p selfs))
        (entmakex (list (cons 0 "CIRCLE") (cons 10 p) (cons 40 (* mult 1e-6 0.3)) (cons 62 3)))
        (ssadd (entlast) ssci)
      )
    )
    (unisoobjs isolst)
    (vla-zoomprevious (vlax-get-acad-object))
    (list selfs e ssci)
  )

  (setq cmd (getvar (quote cmdecho)))
  (setvar (quote cmdecho) 0)
  (if (= 8 (logand 8 (getvar (quote undoctl))))
    (vl-cmdf "_.undo" "_e")
  )
  (vl-cmdf "_.undo" "_be")
  (prompt "\nSelect LWPOLYLINE entities to find their self-intersecting points...")
  (if
    (and
      (setq ss (ssget (list (cons 0 "LWPOLYLINE"))))
      (not (initget 6))
      (setq mult (cond ( (getdist "\nPick or specify multiplication factor for circles size <1.0> : ") ) ( 1.0 )))
    )
    (progn
      (setq ti (car (_vl-times)))
      (repeat (setq i (sslength ss))
        (setq lw (ssname ss (setq i (1- i))))
        (vl-cmdf "_.scale" lw "" "_non" (list 0.0 0.0 0.0) 1e-6)
        (vl-cmdf "_.move" lw "" "_non" (setq sp (vlax-curve-getstartpoint lw)) "_non" (list 0.0 0.0 0.0))
        (setq selfs (cons (selfinters3 lw sp mult) selfs))
        (vl-cmdf "_.move" lw "" "_non" (list 0.0 0.0 0.0) "_non" sp)
        (vl-cmdf "_.move" (caddar selfs) "" "_non" (list 0.0 0.0 0.0) "_non" sp)
        (vl-cmdf "_.scale" lw "" "_non" (list 0.0 0.0 0.0) 1e+6)
        (vl-cmdf "_.scale" (caddar selfs) "" "_non" (list 0.0 0.0 0.0) 1e+6)
      )
      (prompt "\nElapsed time : ") (princ (rtos (- (car (_vl-times)) ti) 2 16)) (prompt " milliseconds...")
    )
    (prompt "\nEmpty sel.set... Better luck next time...")
  )
  (*error* nil (setq selfs (mapcar (function (lambda ( x ) (list (car x) (cadr x)))) selfs)) sp)
)

Regards, M.R.

[john.uhden]

@marko_ribar ,

WOW!

Somewhat more verbose than I had expected, but IT WORKS!

YAY!!!

How about with 4,500 vertices?