LISP - draw center line of a rectangle
It seems to me this can be done much more simply:
(defun C:QLCL ; = Quadrilateral Long-direction Center Line
(/ pap ss n pl dists parA)
(defun pap (i) (vlax-curve-getPointAtParam pl i))
(if (setq ss (ssget '((0 . "LWPOLYLINE") (90 . 4) (-4 . "&=") (70 . 1))))
(repeat (setq n (sslength ss))
(setq
pl (ssname ss (setq n (1- n)))
dists (list (distance (pap 0.5) (pap 2.5)) (distance (pap 1.5) (pap 3.5)))
parA (vl-position (apply 'max dists) dists)
); setq
(command
"_.line" "_non" (pap (+ parA 0.5)) "_non" (pap (+ parA 2.5)) ""
"_.chprop" (entlast) "" "_ltype" "CENTER" ""
); command
); repeat
); if
(prin1)
)It could be made to verify that a given one is actually rectangular, if needed, also I think in a simpler way.
I think this does all those things [again, lightly tested]:
(defun C:QLCLP ; = Quadrilateral Long-direction Center Line or Point
(/ pap ss n pl seglen1 seglen2 dists parA)
(defun pap (i) (vlax-curve-getPointAtParam pl i))
(if (setq ss (ssget '((0 . "LWPOLYLINE") (90 . 4) (-4 . "&=") (70 . 1))))
; 4-sided closed only
(repeat (setq n (sslength ss))
(setq pl (ssname ss (setq n (1- n))))
(if
(and
; all straight-line segments [no bulge factors]:
(= (apply '+ (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 42)) (entget pl)))) 0.0)
; opposite sides equal lengths:
(equal (setq seglen1 (distance (pap 0) (pap 1))) (distance (pap 2) (pap 3)) 1e-6)
(equal (setq seglen2 (distance (pap 1) (pap 2))) (distance (pap 3) (pap 0)) 1e-6)
; right angle corner:
(equal (rem (abs (- (angle (pap 0) (pap 1)) (angle (pap 1) (pap 2)))) pi) (/ pi 2) 1e-6)
); and
(progn ; then
(setq dists (list seglen1 seglen2))
(if (> (/ (apply 'max dists) (apply 'min dists)) 2.35); ratio of sides
(progn; then -- Center Line in longer direction
(setq parA (vl-position (apply 'min dists) dists)); 0 or 1
(command
"_.line" "_non" (pap (+ parA 0.5)) "_non" (pap (+ parA 2.5)) ""
"_.chprop" (entlast) "" "_ltype" "CENTER" ""
); command
); progn
(command "_.point" "_non" (mapcar '/ (mapcar '+ (pap 0) (pap 2)) '(2 2 2))); else
); if [ratio]
); progn
); if [rectangular]
); repeat
); if [any 4-sided closed Polyline(s) selected]
(prin1)
)
@cool.stuff wrote:
.... I tried to change the criterium to be equal or greater than 2.35, by adding "=" after the ">", but is does not work. ....
You don't show your edited version, but I have two thoughts:
Did you perhaps put a space between the > and the = ? There should not be one.
It may be one of those things that will work most of the time but not always right at the cut-off ratio, because of tiny way-down-in-the-decimal-places differences in calculated values, which result from the fact that decimal values are just masking the fact that everything is really done in binary fashion with 1's and 0's. What you think is 2.35 may actually be 2.349999999999613, which would not meet the test. This is why, when comparing real-number values, people often use (equal) with a fuzz factor, instead of (=) which wants absolute true equality. But there's no fuzz factor option in the (>=) and similar functions. Would it work for you to check in comparison with 2.34999 instead of 2.35?
Regards @cool.stuff
Try this code, it should comply with what you request...
;;;___
(defun c:line_M
(/ s lp p0 p1 p2 p3 lx ly v0 v1 v2 v3 dx dy vux vuy px pxc py
pyc x y i j k l u w m
)
(setvar 'pdmode 3)
(setvar 'pdsize 0.1)
(while
(setq s (car (entsel "\nSelect Lwpolyline Rectangle: ")))
(setq
lp (mapcar 'cdr
(vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget s))
)
p0 (car lp)
p1 (cadr lp)
p2 (caddr lp)
p3 (cadddr lp)
lx (distance p0 p1)
ly (distance p1 p2)
v0 (mapcar '- p1 p0)
v1 (mapcar '- p2 p1)
v2 (mapcar '- p3 p2)
v3 (mapcar '- p0 p3)
)
(if (equal (apply '+
(list (* (car v0) (car v1))
(* (cadr v0) (cadr v1))
(* (car v2) (car v3))
(* (cadr v2) (cadr v3))
)
)
0.0
0.0001
)
(progn
(princ "\nThe selected figure is a Rectangle...")
(setq vux (mapcar '(lambda (x) (/ x lx)) (mapcar '- p1 p0))
vuy (mapcar '(lambda (y) (/ y ly)) (mapcar '- p2 p1))
)
(if (>= lx ly)
(progn
(setq
dx (/ lx 2)
dy (/ ly 2)
px (mapcar '+ p0 (mapcar '(lambda (j) (* dy j)) vuy))
pxc (mapcar '+ px (mapcar '(lambda (u) (* dx u)) vux))
)
(if (<= (/ lx ly) 2.35)
(progn
(princ "\nL.maj/L.min<=2.35:")
(entmakex
(list '(0 . "Point")
(cons 10 pxc)
)
)
)
(entmakex
(list
'(0 . "line")
(cons 10 px)
(cons 11 (mapcar '+ px (mapcar '(lambda (k) (* lx k)) vux)))
)
)
)
)
(progn
(setq
dx (/ lx 2)
dy (/ ly 2)
py (mapcar '+ p0 (mapcar '(lambda (l) (* dx l)) vux))
pyc (mapcar '+ py (mapcar '(lambda (w) (* dy w)) vuy))
)
(if (<= (/ ly lx) 2.35)
(progn
(princ "\nL.maj/L.min<=2.35:")
(entmakex
(list '(0 . "Point")
(cons 10 pyc)
)
)
)
(entmakex
(list
'(0 . "line")
(cons 10 py)
(cons 11 (mapcar '+ py (mapcar '(lambda (m) (* ly m)) vuy)))
)
)
)
)
)
)
(progn
(command "_chprop" s "" "c" 1 "")
(princ "\nThe selected shape is not a Rectangle...")
)
)
)
(princ)
)
Carlos Calderon G
>Did you find this post helpful? Feel free to Like this post.
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
That needs more work on its rectangularity test. It accepted these parallelograms [green Polylines, white results]:
as well as things with arc segments:
and self-intersecting ones, with rectangular extents and even with isosceles trapezoidal vertex relationships:
though it did reject isosceles trapezoids that are not self-intersecting.
[And if you need to do multiple rectangles, it requires selecting them one at a time.]
Regards @Kent1Cooper
Thank you very much for your observations, I made a mistake. I made the corrections in my previous post, to verify the perpendicularity and it was tested in your graphs. The multiple selection thing, although it wouldn't be complicated. I didn't do it so I could see the message when I selected it, it wasn't a rectangle.
Carlos Calderon G
>Did you find this post helpful? Feel free to Like this post.
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
@calderg1000 wrote:
.... I made the corrections in my previous post, to verify the perpendicularity ....
That took care of the parallelogram and self-intersecting and trapezoidal issues, but not yet the arc segment(s) issue:
And [I hadn't tried this before] it accepts one that is not closed:
[And I would suggest adding a check on the type of object selected. If I pick a non-rectangular Polyline, it scolds me but asks again, but if I pick something else like a Line, it dies with an error message.]
Regards @cool.stuff
Try this code, I made the necessary edits to it so that it complies with your request and with the additional border conditions that @Kent1Cooper mentioned.
(defun c:line_M
(/ s lp p0 p1 p2 p3 lx ly v0 v1 v2 v3 dx dy vux vuy px pxc py
pyc x y i j k l u w m
)
(setvar 'pdmode 3)
(setvar 'pdsize 0.25)
(setq lsn
(vl-remove-if
'listp
(mapcar
'cadr
(ssnamex (ssget '((0 . "LWPOLYLINE") (-4 . "&=") (70 . 1) (90 . 4)))
)
)
)
)
(foreach i lsn
(progn
(setq
lp (mapcar 'cdr
(vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget i))
)
p0 (car lp)
p1 (cadr lp)
p2 (caddr lp)
p3 (cadddr lp)
lx (distance p0 p1)
ly (distance p1 p2)
v0 (mapcar '- p1 p0)
v1 (mapcar '- p2 p1)
v2 (mapcar '- p3 p2)
v3 (mapcar '- p0 p3)
)
(if
(and
(equal (apply '+
(list (* (car v0) (car v1))
(* (cadr v0) (cadr v1))
(* (car v2) (car v3))
(* (cadr v2) (cadr v3))
)
)
0.0
0.0001
)
(equal
(apply
'+
(mapcar 'cdr
(vl-remove-if-not '(lambda (x) (= (car x) 42)) (entget i))
)
)
0.0
0.0001
)
)
(progn
(princ "\nThe selected figure is a Rectangle...")
(setq vux (mapcar '(lambda (x) (/ x lx)) (mapcar '- p1 p0))
vuy (mapcar '(lambda (y) (/ y ly)) (mapcar '- p2 p1))
)
(if (>= lx ly)
(progn
(setq
dx (/ lx 2)
dy (/ ly 2)
px (mapcar '+ p0 (mapcar '(lambda (j) (* dy j)) vuy))
pxc (mapcar '+ px (mapcar '(lambda (u) (* dx u)) vux))
)
(if (<= (/ lx ly) 2.35)
(progn
(princ "\nL.maj/L.min<=2.35:")
(entmakex
(list '(0 . "Point")
(cons 10 pxc)
)
)
)
(entmakex
(list
'(0 . "line")
(cons 10 px)
(cons 11 (mapcar '+ px (mapcar '(lambda (k) (* lx k)) vux)))
)
)
)
)
(progn
(setq
dx (/ lx 2)
dy (/ ly 2)
py (mapcar '+ p0 (mapcar '(lambda (l) (* dx l)) vux))
pyc (mapcar '+ py (mapcar '(lambda (w) (* dy w)) vuy))
)
(if (<= (/ ly lx) 2.35)
(progn
(princ "\nL.maj/L.min<=2.35:")
(entmakex
(list '(0 . "Point")
(cons 10 pyc)
)
)
)
(entmakex
(list
'(0 . "line")
(cons 10 py)
(cons 11 (mapcar '+ py (mapcar '(lambda (m) (* ly m)) vuy)))
)
)
)
)
)
)
(command "_chprop" i "" "c" 1 "")
)
)
(princ)
)
)
Carlos Calderon G
>Did you find this post helpful? Feel free to Like this post.
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
Regards @, the line of code you show us works for me. As practice for you, show us where you put it and we will see if it is correct.
Carlos Calderon G
>Did you find this post helpful? Feel free to Like this post.
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
Regrads @cool.stuff
This right. But, so that it does not override the line type properties of the previously created line, put the code "_.matchprop" pl (entlast)" before
"_.chprop" (entlast) "" "_ltype" "CENTER" ""
Carlos Calderon G
>Did you find this post helpful? Feel free to Like this post.
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
@calderg1000 is correct that the MATCHPROP command will match the linetype as well, overriding the setting of that to CENTER for the Line result. You could do as suggested, and assign the linetype after MATCHPROPing to get the Layer, or you could just put more than one Property change into the CHPROP command, to match the Layer of the source object, but not its Linetype [or other Properties]:
....
(command
"_.line" "_non" (pap (+ parA 0.5)) "_non" (pap (+ parA 2.5)) ""
"_.chprop" (entlast) ""
"_ltype" "CENTER"
"_layer" (cdr (assoc 8 (entget pl)))
"" ; conclude CHPROP
); command
....You can do the same with the Point result if you like, but MATCHPROP assigning the rectangle's Linetype to the Point won't matter.
