LISP TO FIND COMMON ENDPOINTS OF A POLYGON

[Anonymous]

I have many polygons in the drawing, I want to check if the polygon is having a common endpoint, if not then it should be circled. also if any polygon is not a perfect rectangle or square ie all the angles are of 90 degrees. if there is any angle other than 90 degrees it should be marked.

I AM ATTACHING THE IMAGE

2- SHOWS THE ERROR THAT THE LISP IS SUPPOSED TO HANDLE

[marko_ribar]

(defun c:chkrectcommpts ( / unique ss fuzz i lw pl pll pls errpts ) ; only marks non rectangular error points within fuzz distance from common end points

  (defun unique ( l )
    (if l
      (cons (car l) (unique (vl-remove (car l) l)))
    )
  )

  (while
    (or
      (prompt "\nSelect polygonal - 4 vertices LWPOLYLINES for checking common end points...")
      (not (setq ss (ssget '((0 . "LWPOLYLINE") (90 . 4) (-4 . "&=") (70 . 1) (-4 . "<not") (-4 . "<>") (42 . 0.0) (-4 . "not>")))))
    )
    (prompt "\nEmpty sel. set... Retry selecting polygons...")
  )
  (initget 7)
  (setq fuzz (getdist "\nPick or specify fuzz checking distance : "))
  (repeat (setq i (sslength ss))
    (setq lw (ssname ss (setq i (1- i))))
    (setq pl (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (entget lw))))
    (setq pll (append pl pll))
    (setq pls (cons pl pls))
  )
  (setq pll (unique pll))
  (foreach p pll
    (if (vl-some '(lambda ( x ) (equal x p fuzz)) (vl-remove p pll))
      (setq errpts (cons p errpts))
    )
  )
  (setq errpts (vl-remove-if '(lambda ( x ) (vl-every '(lambda ( y ) (zerop (apply '+ (mapcar '* (mapcar '- x (if (cdr (member x y)) (cadr (member x y)) (car y))) (mapcar '- x (if (cdr (member x (reverse y))) (cadr (member x (reverse y))) (last y))))))) (vl-remove-if-not '(lambda ( z ) (vl-position x z)) pls))) errpts)) 
  (foreach p errpts
    (entmake
      (list
        '(0 . "CIRCLE")
        (cons 10 p)
        (cons 40 (* (/ (getvar 'viewsize) (cadr (getvar 'screensize))) 50)) ; radius = 50 pixels of current display
        '(62 . 1) ; red color of circle
      )
    )
  )
  (princ)
)

HTH., M.R.

[dlanorh]

Try this

(defun rh:sammlung_n (o_lst grouping / tmp n_lst)
	(setq n_lst nil)
	(if (= (rem (length o_lst) grouping) 0)
		(while o_lst
			(while (< (length tmp) grouping)
				(setq tmp (cons (car o_lst) tmp)
							o_lst (cdr o_lst)
				);end_setq
			);end_while
			(setq n_lst (cons (reverse tmp) n_lst) 
						tmp nil
			);end_setq
		);end_while
		(princ "\nModulus Error : The passed list length is not exactly divisible by the group size!!")
	);end_if
  (reverse n_lst)
);end_defun rh:sammelung_n

(defun c:badpolys ( / *error* osm c_doc ms fuzz ss c_ss v_lst idx c_v v_ang last_v next_v bv_lst c_rad_lst c_rad n_obj)

	(defun *error* ( msg ) 
    (if osm (setvar 'osmode osm))
		(if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
		(if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")) (princ (strcat "\nAn Error : " msg " occured.")))
		(princ)
	);_end_*error*_defun

  (cond ( (/= (getvar 'dosmode) 0) (setq osm (getvar 'osmode)) (setvar 'osmode 0)))
  
  (setq c_doc (vla-get-activedocument (vlax-get-acad-object))
        ms (vla-get-modelspace c_doc)
        fuzz 1.0e-04
  );end_setq
  
	(prompt "\nSelect Polylines : ")
  (setq ss (ssget '((0 . "LWPOLYLINE"))))
  
  (vlax-for obj (setq c_ss (vla-get-activeselectionset c_doc))
    (setq v_lst (rh:sammlung_n (vlax-get obj 'coordinates) 2)
          idx 0
    );end_setq
    (cond ( (not (< 3 (length v_lst) 6)) (vlax-put-property obj 'color 1))
          ( (and  (< 3 (length v_lst) 6)
                  (or (equal :vlax-true (vlax-curve-isclosed obj))
                      (equal (vlax-curve-getstartpoint obj) (vlax-curve-getendpoint obj) fuzz)
                  );end_or
            );end_and      
            (repeat 4
              (if (= idx 0) (setq last_v (nth (1- (length v_lst)) v_lst)) (setq last_v (nth (1- idx) v_lst)))
              (if (= idx 3) (setq next_v (nth 0 v_lst)) (setq next_v (nth (1+ idx) v_lst)))
              (setq c_v (nth idx v_lst)
                    v_ang (abs (- (angle c_v last_v) (angle c_v next_v)))
              );end_setq
              (cond ( (and  (not (equal v_ang (/ pi 2) 1.0E-10))
                            (not (equal v_ang (* (/ pi 2) 3) 1.0E-10))
                      );end_and
                      (setq bv_lst (cons c_v bv_lst)
                            c_rad_lst (cons (min (distance c_v last_v) (distance c_v next_v)) c_rad_lst)
                      );end_setq
                    )  
              );end_cond
	      (setq idx (1+ idx))
            );end_repeat
          )
          ( (or (equal :vlax-false (vlax-curve-isclosed obj))
                (not (equal (vlax-curve-getstartpoint obj) (vlax-curve-getendpoint obj) fuzz))
            );end_or
            (vlax-put-property obj 'color 3)
          )  
    );end_cond
  );end_for
  (setq ss nil)
  (vla-delete c_ss)
  (cond ( (and bv_lst c_rad_lst)
          (setq c_rad (/ (apply 'min c_rad_lst) 4))
          (foreach pt bv_lst
            (setq n_obj (vla-addcircle ms (vlax-3d-point pt) c_rad))
            (vlax-put-property n_obj 'layer "0")
            (vlax-put-property n_obj 'color 212)
          );end_foreach
        )
  );end_cond
  (if osm (setvar 'osmode osm))
  (princ)
);end_defun
(princ)

It will handle closed polylines and open polylines where the start point and end point are the same.

Any polyline with less than 4 vertices or more than 5 vertices (this covers open polylines with the same start and end point) will be colored red.

Any polyline with 4 or 5 vertices where the start point and end point are not the same or is not closed will be colored green.

Any vertex which is not a right angle will be marked with a magenta circle.

[Anonymous · Accepted solution]

THANK U marko ribar & dlanorh  sir, it solved my problem.