Jump to content

Lisp for diagonal lines for selected rectangles


structo

Recommended Posts

Practiced for fun:

(defun C:test ( / SS e i lst )
(if 
	(and
		(princ "\nSelect rectangles to draw their diagonals: ")
		(setq SS (ssget (list (cons 0 "LWPOLYLINE"))))
	)
	(repeat (setq i (sslength SS))
		(setq e (ssname SS (setq i (1- i))))
		(and
			(rectangle-p e 1e-5)
			(not (vl-catch-all-error-p (vl-catch-all-apply 'vla-GetBoundingBox (list (vlax-ename->vla-object e) 'll 'ur))))
			(setq lst (mapcar 'vlax-safearray->list (list ll ur)))
			(apply 'Line lst)
			(apply 'Line
				(mapcar 'append
					(mapcar 'list (reverse (mapcar 'car lst)))
					(mapcar 'cdr lst)
				)
			)
		)
	)
)
(princ)
) (vl-load-com) (princ)

; Lee Mac
(defun Line (p1 p2)
(entmakex 
	(list 
		(cons 0 "LINE")
		(cons 10 p1)
		(cons 11 p2)
	)
)
)

; Marko Ribar I guess?
(defun rectangle-p ( e f / nobulge-p dpar stp enp ptn k parpts index ptlst rtn)
(if (and e (= (cdr (assoc 0 (entget e))) "LWPOLYLINE"))
	(progn
		(defun nobulge-p ( e i f ) (apply 'and (mapcar '(lambda (x) (equal (vla-getbulge e x) 0.0 f)) i)))
		(setq dpar (/ (+ (abs (setq enp (vlax-curve-getendparam e))) (abs (setq stp (vlax-curve-getstartparam e)))) (setq ptn (cdr (assoc 90 (entget e))))))
		(setq k -1.0)
		(repeat ptn (setq parpts (append parpts (setq parpts (list (+ stp (* (setq k (1+ k)) dpar)))))))
		(setq k -1)
		(repeat ptn (setq index (append index (setq index (list (setq k (1+ k)))))))
		(setq ptlst (mapcar '(lambda (x) (vlax-curve-getpointatparam e x)) parpts))
		(setq rtn
			(and
				(eq ptn 4)
				(nobulge-p (if (eq (type e) 'ENAME) (vlax-ename->vla-object e) e) index f)
				(equal (distance (nth 0 ptlst) (nth 1 ptlst)) (distance (nth 2 ptlst) (nth 3 ptlst)) f)
				(equal (distance (nth 1 ptlst) (nth 2 ptlst)) (distance (nth 3 ptlst) (nth 0 ptlst)) f)
				(equal (distance (nth 0 ptlst) (nth 2 ptlst)) (distance (nth 1 ptlst) (nth 3 ptlst)) f)
			)
		)
	)
)
rtn
); defun rectangle-p		

EDIT: Won't work for rectangles with rotation other than 0 90 180 270 360 degrees.

Edited by Grrr
Link to comment
Share on other sites

Another:

(defun c:rdia ( / ent idx pt1 pt2 pt3 pt4 sel )
   (if (setq sel
           (ssget
              '(   (00 . "LWPOLYLINE")
                   (90 . 4)
                   (-4 . "&=")   (70 . 1)
                   (-4 . "<NOT") (-4 . "<>") (42 . 0.0) (-4 . "NOT>")
               )
           )
       )
       (repeat (setq idx (sslength sel))
           (setq ent (ssname sel (setq idx (1- idx))))
           (mapcar
              '(lambda ( a b ) (set b (trans (cdr a) ent 0)))
               (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) (entget ent))
              '(pt1 pt2 pt3 pt4)
           )
           (if (and (equal (distance pt1 pt2) (distance pt3 pt4) 1e-8)
                    (equal (distance pt2 pt3) (distance pt1 pt4) 1e-8)
                    (equal (distance pt1 pt3) (distance pt2 pt4) 1e-8)
               )
               (mapcar '(lambda ( a b ) (entmake (list '(0 . "LINE") (cons 10 a) (cons 11 b))))
                   (list pt1 pt2)
                   (list pt3 pt4)
               )
           )
       )
   )
   (princ)
)
 
Edited by Lee Mac
Link to comment
Share on other sites

Another method, need to just add the ssget for multiples.

 

; pline co-ords example
; By Alan H
(defun getcoords (ent)
 (vlax-safearray->list
   (vlax-variant-value
     (vlax-get-property
   (vlax-ename->vla-object ent)
   "Coordinates"
     )
   )
 )
)

(defun co-ords2xy ()
; convert now to a list of xy as co-ords are x y x y x y if 3d x y z x y z
(setq len (length co-ords))
(setq numb (/ len 2)) ; even and odd check required
(setq I 0)
(repeat numb
(setq xy (list (nth i co-ords)(nth (+ I 1) co-ords) ))
; odd (setq xy (list (nth i co-ords)(nth (+ I 1) co-ords)(nth (+ I 2) co-ords) ))
(setq co-ordsxy (cons xy co-ordsxy))
(setq I (+ I 2))
)
)
; program starts here
(setq co-ords (getcoords (car (entsel "\nplease pick pline"))))
(co-ords2xy) ; list of 2d points making pline

(command "line" (nth 0 co-ordsxy )(nth 2 co-ordsxy ) "")
(command "line" (nth 1 co-ordsxy )(nth 3 co-ordsxy ) "")

Link to comment
Share on other sites

Here is Lee's code corrected with some issues I've found...

 

(defun c:rdia ( / ent idx pt1 pt2 pt3 pt4 sel )
   (if (setq sel
           (ssget
              '(   (00 . "LWPOLYLINE")
                   (90 . 4)
                   (-4 . "&=")   (70 . 1)
                   (-4 . "<NOT") (-4 . "<>") (42 . 0.0) (-4 . "NOT>")
               )
           )
       )
       (repeat (setq idx (sslength sel))
           (setq ent (ssname sel (setq idx (1- idx))))
           (mapcar
              '(lambda ( a b ) (set b (trans [color=red](list (car (cdr a)) (cadr (cdr a)) (cdr (assoc 38 (entget ent))))[/color] ent 0)))
               (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) (entget ent))
              '(pt1 pt2 pt3 pt4)
           )
           (if (and (equal (distance pt1 pt2) (distance pt3 pt4) 1e-
                    (equal (distance pt2 pt3) (distance pt1 pt4) 1e-
                    (equal (distance pt1 pt3) (distance pt2 pt4) 1e-
               )
               (mapcar '(lambda ( a b ) (entmake (list '(0 . "LINE") (cons 10 a) (cons 11 b))))
                   (list pt1 pt2)
                   (list pt3 pt4)
               )
           )
       )
   )
   (princ)
)

Edited by marko_ribar
Link to comment
Share on other sites

That is what i meant by "other" rectangles, may not be closed or rotated at 0/90. not necessarily 4 vertices.....

 

 

An opposite sides are the same length, i.e. they are equal:

An opposite sides are parallel:

An adjacent sides are always perpendicular:

All four angles is right:

The sum all of the angles of a rectangle is equal to 360 degrees:

A diagonals are equal:

The sum of the squares two diagonals is equal to the sum of the squares of the sides:

The each diagonal divides the rectangle into two equal shape, namely a right triangle.

A diagonal of a rectangle in half divides each other:

Intersection point of the diagonals is called the center and also a center of the circumcircle (incenter).

Diagonal of a rectangle is the diameter of the circumcircle.

Around the rectangle can always describe a circle, because the sum of the opposite angles is 180 degrees:

 

That is probably how i'm going to approach this

Link to comment
Share on other sites

Sorry friends,

 

just i saw my drawing. yes there is zero length lines at each corner. these rectangles are taken from one other software output. please ignore those zero length lines to develop diagonal lines by lisp.

 

Thank you all.

Link to comment
Share on other sites

I am

Couple of days before created for me,

 

Lisp experts have given excellent codes

 

 

(defun c:polycross (/ ss vl_naam_lst lst plst asoc )
;; A wrapper for the ssget function to permit the use of a custom selection prompt
;; msg - [str] selection prompt
;; arg - [lst] list of ssget arguments
(defun LM:ssget ( msg arg / sel )
   (princ msg)
   (setvar 'nomutt 1)
   (setq sel (vl-catch-all-apply 'ssget arg))
   (setvar 'nomutt 0)
   (if (not (vl-catch-all-error-p sel)) sel)
)
;;------------=={ SelectionSet -> VLA Objects }==-------------;;
;;                                                            ;;
;;  Converts a SelectionSet to a list of VLA Objects          ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2011 - [url="http://www.lee-mac.com"]www.lee-mac.com[/url]       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  ss - Valid SelectionSet (Pickset)                         ;;
;;------------------------------------------------------------;;
;;  Returns:  List of VLA Objects, else nil                   ;;
;;------------------------------------------------------------;;
(defun LM:ss->vla ( ss / i l )
   (if ss
       (repeat (setq i (sslength ss))
           (setq l (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) l))
       )
   )
)
   
(setq ss (LM:ssget "Select Polyline(s)" '(((-4 . "<AND") (0 . "LWPOLYLINE") (70 . 1) (-4 . "AND>"))))
vl_naam_lst (LM:ss->vla ss))  
 (foreach n vl_naam_lst
(if  (=  (length (setq coords (vlax-safearray->list (vlax-variant-value (vla-get-coordinates n))))) 
   (progn    
  (setq plst (list (list (trans (list (nth 0 coords) (nth 1 coords) 0) 0 1)
(trans (list (nth 4 coords) (nth 5 coords) 0) 0 1))
(list (trans (list (nth 2 coords) (nth 3 coords) 0) 0 1)
  (trans (list (nth 6 coords) (nth 7 coords) 0) 0 1))))
  (foreach lst plst
    (entmakex 
           (append (list (cons 0 "LWPOLYLINE")
                         (cons 100 "AcDbEntity")
                         (cons 100 "AcDbPolyline")
                         (cons 90 (length lst))
                         (cons 70 0))
(vl-remove nil (mapcar (function (lambda (a) (if (setq asoc (assoc a (entget (vlax-vla-object->ename n))))  asoc))) '(8 62 6)))
(mapcar (function (lambda (p) (cons 10 p))) lst)
        ))                
    )
  
  )
 )
)
(PRINC)
 )

Link to comment
Share on other sites

A quick edit.

 

(defun c:rdia ( / ent idx pt1 pt2 pt3 pt4 sel )
   (if (setq sel
           (ssget
              '(   (00 . "LWPOLYLINE")
                  [color="magenta"] ;(90 . 4)[/color]
                   (-4 . "&=")   (70 . 1)
                   (-4 . "<NOT") (-4 . "<>") (42 . 0.0) (-4 . "NOT>")
               )
           )
       )
       (repeat (setq idx (sslength sel))
           (setq ent (ssname sel (setq idx (1- idx))))
           (mapcar
              '(lambda ( a b ) (set b (trans (cdr a) ent 0)))
       
               [color="magenta"](_removeDuplciates[/color] (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) (entget ent))[color="magenta"])[/color]
              '(pt1 pt2 pt3 pt4)
           )
           (if (and (equal (distance pt1 pt2) (distance pt3 pt4) 1e-
                    (equal (distance pt2 pt3) (distance pt1 pt4) 1e-
                    (equal (distance pt1 pt3) (distance pt2 pt4) 1e-
               )
               (mapcar '(lambda ( a b ) (entmake (list '(0 . "LINE") (cons 10 a) (cons 11 b))))
                   (list pt1 pt2)
                   (list pt3 pt4)
               )
           )
       )
   )
   (princ)
)

[color="blue"](defun _removeDuplciates (lst)
 (if (car lst)
   (cons (car lst) (_removeDuplciates (vl-remove (car lst) (cdr lst))))
 )
)[/color]

Link to comment
Share on other sites

Dear friend pBe,

 

now your code is perfect working. thank you for your kind help.

 

Thanking you all for supporting.

 

Thank LM sturcto, Lee did all the coding. :)

 

And that's just one way of dealing with rectangles (zero length segments), pretty sure there will be more issues as we go along.

 

v1 to v2 (angle) v2 to v3 (if (angle same as previous or ZERO length) (igmore)(check if 90deg)).......... (= distance between v1 v3 & v2 v4 )) (do it))

Link to comment
Share on other sites

Another:
([color=BLUE]setq[/color] sel
([color=BLUE]ssget[/color]
	'(   (00 . [color=MAROON]"LWPOLYLINE"[/color])
		(90 . 4)
		(-4 . [color=MAROON]"&="[/color])   (70 . 1)
		(-4 . [color=MAROON]"<NOT"[/color]) (-4 . [color=MAROON]"<>"[/color]) (42 . 0.0) (-4 . [color=MAROON]"NOT>"[/color])
	)
)
)

After this I feel that I have limited thinking. :oops:

 

Anyway I wrote another solution (better than my first).

Will work for "true" rectangles (4 vertices LWPOLYLINES), with any rotation on any UCS, uncluding such with zero bulges (is that the right term?).

(defun C:test ( / SS i e o )
(if (setq SS (ssget (list (cons 0 "LWPOLYLINE")(cons 70 1) (cons 90 4))))
	(repeat (setq i (sslength SS))
		(setq e (ssname SS (setq i (1- i))))
		(setq o (vlax-ename->vla-object e))
		(and
			(Rectangle-p o 1e-
			(mapcar 
				'(lambda (a b) 
					(entmake 
						(list 
							(cons 0 "LINE") 
							(cons 10 (vlax-curve-getPointAtParam o a)) 
							(cons 11 (vlax-curve-getPointAtParam o b))
						)
					)
				)
				'(0 1) '(2 3)
			)
		)
	)
); if SS
(princ)
)


(defun Rectangle-p ( eo fuzz / eo rtn ) ; Grrr
(cond 
	((eq 'ENAME (type eo))
		(setq rtn
			(vl-every '(lambda (x) (member x '((0 . "LWPOLYLINE") (90 . 4) (70 . 1) (42 . 0))))
				(vl-remove-if-not '(lambda (x) (member (car x) '(0 90 70 42))) (entget eo))
			)
		)
		(setq eo (vlax-ename->vla-object eo)); yes go thru the vla check aswell.
	)
	((eq 'VLA-OBJECT (type eo))
		(setq rtn 
			(and
				(= "AcDbPolyline" (vla-get-ObjectName eo))
				(vlax-curve-isClosed eo)
				(= 4 (vlax-curve-getEndParam eo))
				(equal ; opposite sides are equal AB-CD, will accept non-curved arcs/bulges
					(apply '- (mapcar '(lambda (x) (vlax-curve-getDistAtParam eo x)) '(1 0)))
					(apply '- (mapcar '(lambda (x) (vlax-curve-getDistAtParam eo x)) '(3 2)))
					fuzz
				)
				(equal  ; opposite sides are equal BC-AD, will accept non-curved arcs/bulges
					(apply '- (mapcar '(lambda (x) (vlax-curve-getDistAtParam eo x)) '(2 1)))
					(apply '- (mapcar '(lambda (x) (vlax-curve-getDistAtParam eo x)) '(4 3)))
					fuzz
				)
				(equal ; diagonals are eq length (not romboid) dist A C = dist B D
					(apply 'distance (mapcar '(lambda (x) (vlax-curve-getPointAtParam eo x)) '(1 3)))
					(apply 'distance (mapcar '(lambda (x) (vlax-curve-getPointAtParam eo x)) '(2 4)))
					fuzz
				)
			)
		)	
	)
	(T nil)
)
rtn
);| defun Rectangle-p |; (or vlax-get-acad-object (vl-load-com)) (princ)

Although It won't support lookalike LWpolyline rectangles like in the OP's dwg. (sorry)

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...