### Author Topic: Check polyline for square/rectangle  (Read 12993 times)

0 Members and 1 Guest are viewing this topic.

#### ribarm

• Water Moccasin
• Posts: 2367
• Marko Ribar, architect
##### Re: Check polyline for square/rectangle
« Reply #30 on: January 10, 2013, 05:36:09 AM »
Yes, Evgeniy...

Code - Auto/Visual Lisp: [Select]
1. (mapcar (function (lambda (a b c d) (/ (+ a d c a b c) 6))) p1 p2 p3 p4)
2.
is the same as
Code - Auto/Visual Lisp: [Select]
1. (mapcar (function (lambda (a b) (/ (+ a b) 2))) p2 p4)
2.

It seems that you deliberately make things more obscured...

Marko Ribar, d.i.a. (graduated engineer of architecture)

#### ElpanovEvgeniy

• Water Moccasin
• Posts: 1542
• Moscow (Russia)
##### Re: Check polyline for square/rectangle
« Reply #31 on: January 10, 2013, 05:59:12 AM »
Yes, Evgeniy...

Code - Auto/Visual Lisp: [Select]
1. (mapcar (function (lambda (a b c d) (/ (+ a d c a b c) 6))) p1 p2 p3 p4)
2.
is the same as
Code - Auto/Visual Lisp: [Select]
1. (mapcar (function (lambda (a b) (/ (+ a b) 2))) p2 p4)
2.

It seems that you deliberately make things more obscured...

Code - Auto/Visual Lisp: [Select]
1. (defun p (a c) (entmakex (list '(0 . "point") (cons 62 c) (cons 10 a))))
2. (defun c:test (/ p1 p2 p3 p4)
3.   (setq e  (car (entsel))
4.         f  1e-6
5.   )
6.   (p (mapcar (function (lambda (a b c d) (/ (+ a d c a b c) 6))) p1 p2 p3 p4) 1)
7.   (p (mapcar (function (lambda (a b) (/ (+ a b) 2))) p2 p4) 2)
8. )
Stay home. Stay safe. Save lives.

#### ribarm

• Water Moccasin
• Posts: 2367
• Marko Ribar, architect
##### Re: Check polyline for square/rectangle
« Reply #32 on: January 10, 2013, 06:46:15 AM »
If you agree, we are testing rectangle-p, not deltoid-p, and for rectangle (+ p1 p3 p1 p3 p2 p4)/6 is the same as (+ p2 p4)/2... And if you check for other 2 points (+ p1 p3)/2, the test should return equality...
Marko Ribar, d.i.a. (graduated engineer of architecture)

#### ElpanovEvgeniy

• Water Moccasin
• Posts: 1542
• Moscow (Russia)
##### Re: Check polyline for square/rectangle
« Reply #33 on: January 10, 2013, 06:54:13 AM »
Now understand ...
Stay home. Stay safe. Save lives.

#### ribarm

• Water Moccasin
• Posts: 2367
• Marko Ribar, architect
##### Re: Check polyline for square/rectangle
« Reply #34 on: January 10, 2013, 07:01:52 AM »
Yes, you're right... You're checking for exactly rectangle, not any kind of romboid... So your code is fine... My apology, now I understand...
Marko Ribar, d.i.a. (graduated engineer of architecture)

#### ElpanovEvgeniy

• Water Moccasin
• Posts: 1542
• Moscow (Russia)
##### Re: Check polyline for square/rectangle
« Reply #35 on: January 10, 2013, 07:15:05 AM »
My code is endless as my thoughts...
Code - Auto/Visual Lisp: [Select]
1. (defun test (e f / l)
2.   (setq l (mapcar (function vlax-curve-getpointatparam) (list e e e e) '(0 1 2 3)))
3.   (vl-every (function (lambda (a b c) (equal (abs (sin (- (angle a b) (angle b c)))) 1 f)))
4.             (cons (last l) l)
5.             l
6.             (cdr l)
7.   )
8. )
Stay home. Stay safe. Save lives.

#### ribarm

• Water Moccasin
• Posts: 2367
• Marko Ribar, architect
##### Re: Check polyline for square/rectangle
« Reply #36 on: January 10, 2013, 07:20:04 AM »
Still, I think that your code I've tested on romboid gives T and should nil, so I modified just a little...

Code - Auto/Visual Lisp: [Select]
1. (defun rectangle-p (e f / p1 p2 p3 p4)
2.    )
3.         (equal (mapcar (function (lambda (a b) (/ (+ a b) 2))) p2 p4)
4.                (mapcar (function (lambda (a b) (/ (+ a b) 2))) p1 p3)
5.                f
6.         )
7.         (equal (distance p1 p3) (distance p2 p4) f)
8.    )
9. )
10.
Marko Ribar, d.i.a. (graduated engineer of architecture)

#### ElpanovEvgeniy

• Water Moccasin
• Posts: 1542
• Moscow (Russia)
##### Re: Check polyline for square/rectangle
« Reply #37 on: January 10, 2013, 07:27:16 AM »
you gave a new idea with triangles...
Code - Auto/Visual Lisp: [Select]
1. (defun test5 (e f / p1 p2 p3 p4)
2.   )
3.   (equal (distance p4 (mapcar (function (lambda (a b c) (/ (+ a b c) 3))) p1 p2 p3))
4.          (distance p3 (mapcar (function (lambda (a b c) (/ (+ a b c) 3))) p1 p2 p4))
5.          f
6.   )
7. )
Stay home. Stay safe. Save lives.

#### owenwengerd

• Bull Frog
• Posts: 441
##### Re: Check polyline for square/rectangle
« Reply #38 on: January 10, 2013, 12:04:06 PM »

#### ribarm

• Water Moccasin
• Posts: 2367
• Marko Ribar, architect
##### Re: Check polyline for square/rectangle
« Reply #39 on: January 10, 2013, 02:20:49 PM »
Works with QuirkyPolylines :

Code - Auto/Visual Lisp: [Select]
1. (defun rectangle-p (e f / dpar stp enp ptn k parpts index ptlst)
2.    (setq dpar (/ (+ (abs (setq enp (vlax-curve-getendparam e))) (abs (setq stp (vlax-curve-getstartparam e)))) (setq ptn (cdr (assoc 90 (entget e))))))
3.    (setq k -1.0)
4.    (repeat ptn
5.       (setq parpts (append parpts (setq parpts (list (+ stp (* (setq k (1+ k)) dpar))))))
6.    )
7.    (setq k -1)
8.    (repeat ptn
9.       (setq index (append index (setq index (list (setq k (1+ k))))))
10.    )
11.    (setq ptlst (mapcar '(lambda (x) (vlax-curve-getpointatparam e x)) parpts))
12.    (and
13.       (eq ptn 4)
14.       (nobulge-p (if (eq (type e) 'ENAME) (vlax-ename->vla-object e) e) index f)
15.       (equal (distance (nth 0 ptlst) (nth 1 ptlst)) (distance (nth 2 ptlst) (nth 3 ptlst)) f)
16.       (equal (distance (nth 1 ptlst) (nth 2 ptlst)) (distance (nth 3 ptlst) (nth 0 ptlst)) f)
17.       (equal (distance (nth 0 ptlst) (nth 2 ptlst)) (distance (nth 1 ptlst) (nth 3 ptlst)) f)
18.    )
19. )
20.
21. (defun nobulge-p (e i f)
22.    (apply 'and (mapcar '(lambda (x) (equal (vla-getbulge e x) 0.0 f)) i))
23. )
24.
« Last Edit: January 10, 2013, 03:58:39 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

#### owenwengerd

• Bull Frog
• Posts: 441
##### Re: Check polyline for square/rectangle
« Reply #40 on: January 10, 2013, 02:33:02 PM »
Much better! There is still room for improvement.
[Hint: vlax-curve-GetDistAtPoint requires no use of parameters at all.]

#### fixo

• Guest
##### Re: Check polyline for square/rectangle
« Reply #41 on: January 10, 2013, 05:08:38 PM »
I've added check on bulged segments
Code: [Select]
`(defun fxRectangle-p (en fuzz / leg obj pts)  (defun _getpt(obj idx)  (vlax-safearray->list(vlax-variant-value (vla-get-coordinate obj  idx))))(and  (setq obj (vlax-ename->vla-object en))  (eq "AcDbPolyline" (vla-get-objectname obj))  (vlax-method-applicable-p obj 'getbulge)  (vlax-property-available-p obj 'coordinate)  (eq (vla-get-closed obj) :vlax-true)  (= 8 (length (setq pts (vlax-get obj 'coordinates))))  (vl-every '(lambda (x) (zerop (vla-getbulge obj x)))     (list 0 1 2 3))  (setq leg (- (vlax-curve-getdistatpoint obj (list (nth 2 pts) (nth 3 pts)))        (vlax-curve-getdistatpoint obj (list (car pts) (cadr pts)))))  (vl-every '(lambda (a b)        (equal (abs (- (vlax-curve-getdistatpoint obj (_getpt obj a))       (vlax-curve-getdistatpoint obj (_getpt obj b))))       leg       fuzz))     (list 0 1 2)     (list 1 2 3))  (equal (/ pi 2) (abs (- (angle (_getpt obj 1)(_getpt obj 2))(angle (_getpt obj 2)(_getpt obj 3))))fuzz)        ))`Looks like it's what I need to use further
« Last Edit: January 11, 2013, 10:31:39 AM by fixo »

#### owenwengerd

• Bull Frog
• Posts: 441
##### Re: Check polyline for square/rectangle
« Reply #42 on: January 10, 2013, 09:30:52 PM »
I like it, fixo. To make it more flexible, you could replace (eq "AcDbPolyline" (vla-get-objectname obj)) with something like this:

Code - Lisp: [Select]
1. (vlax-property-available-p obj 'coordinates)
2. (vlax-method-available-p obj 'getbulge)

Alternatively, you could use (vl-catch-all-apply) to gracefully handle invalid object types without testing at all. The goal would be to allow the code to work for any object type like a polyline, even if it is not actually an AcDbPolyline (or if it is a class derived from AcDbPolyline).

#### fixo

• Guest
##### Re: Check polyline for square/rectangle
« Reply #43 on: January 10, 2013, 11:14:30 PM »
Thanks, Owen
You're right
Kind regards,
Oleg

#### ribarm

• Water Moccasin
• Posts: 2367
• Marko Ribar, architect
##### Re: Check polyline for square/rectangle
« Reply #44 on: January 11, 2013, 01:36:54 AM »
Here is complete code, based on Oleg's one... It doesn't use parameters, and it is applicable for any kind of 2d polyline old heavy, lightweight, quirky,... And no matter how it's oriented in 3d space with any UCS it works well...

Code - Auto/Visual Lisp: [Select]
1. (defun unit ( v )
2.   (mapcar '(lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v))) v)
3. )
4.
5. (defun mxv ( m v )
6.   (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
7. )
8.
9. (defun v^v ( u v )
10.   (list
12.     (- (* (car  v) (caddr u)) (* (car  u) (caddr v)))
13.     (- (* (car  u) (cadr  v)) (* (car  v) (cadr  u)))
14.   )
15. )
16.
17. (defun transptucs ( pt p1 p2 p3 / ux uy uz )
18.   (setq uz (unit (v^v (mapcar '- p2 p1) (mapcar '- p3 p1))))
19.   (setq ux (unit (mapcar '- p2 p1)))
20.   (setq uy (unit (mapcar '- p3 p1)))
21.
22.   (mxv (list ux uy uz) (mapcar '- pt p1))
23. )
24.
25. (defun transptwcs ( pt pt1 pt2 pt3 / pt1n pt2n pt3n )
26.   (setq pt1n (transptucs '(0.0 0.0 0.0) pt1 pt2 pt3))
27.   (setq pt2n (transptucs '(1.0 0.0 0.0) pt1 pt2 pt3))
28.   (setq pt3n (transptucs '(0.0 1.0 0.0) pt1 pt2 pt3))
29.   (transptucs pt pt1n pt2n pt3n)
30. )
31.
32. (defun _getpt (obj idx)
33.   (if (and (vlax-property-available-p obj 'coordinates)
34.            (vlax-method-applicable-p obj 'getbulge)
35.       )
36.     (vlax-safearray->list
37.       (vlax-variant-value (vla-get-coordinate obj idx))
38.     )
39.   )
40. )
41.
42. (defun perp-p ( u v fuzz )
43.    (equal 0.0 (apply '+ (mapcar '* u v)) fuzz)
44. )
45.
46. (defun MR:Rectangle-p (en fuzz / obj pt pts k pts1 pts2 plel plptl uz ux uy ptlst leg)
47.   (and
48.     (setq obj (vlax-ename->vla-object en))
49.     (eq (vla-get-closed obj) :vlax-true)
50.     (or (= 8 (length (setq pts (vlax-get obj 'coordinates)))) (= 12 (length pts)))
51.     (vl-every '(lambda (x) (zerop (vla-getbulge obj x)))
52.               (list 0 1 2 3)
53.     )
54.     (cond
55.       ((and (= 8 (length pts)) (eq (vla-get-objectname obj) "AcDbPolyline"))
56.         (setq k 0.0)
57.         (setq pts1 (vl-remove nil (mapcar '(lambda (x) (if (equal (/ k 2.0) (float (fix (/ (setq k (1+ k)) 2.0))) fuzz) x)) pts)))
58.         (setq k 1.0)
59.         (setq pts2 (vl-remove nil (mapcar '(lambda (x) (if (equal (/ k 2.0) (float (fix (/ (setq k (1+ k)) 2.0))) fuzz) x)) pts)))
60.         (setq plel (vla-get-elevation obj))
61.         (setq plptl (mapcar '(lambda (x y) (list x y plel)) pts1 pts2))
62.       ))
63.       ((and (= 12 (length pts)) (eq (vla-get-objectname obj) "AcDb2dPolyline"))
64.         (setq plel (vla-get-elevation obj))
65.         (repeat 4
66.           (setq pt (list (car pts) (cadr pts) plel))
67.           (setq pts (cdddr pts))
68.           (setq plptl (cons pt plptl))
69.         )
70.         (setq plptl (reverse plptl))
71.       ))
72.       (nil T)
73.     )
74.     (setq uz (vlax-safearray->list (vlax-variant-value (vla-get-normal obj))))
75.     (if (equal uz '(0.0 0.0 1.0) 1e-8) (setq ux '(1.0 0.0 0.0) uy '(0.0 1.0 0.0)))
76.     (if (equal uz '(0.0 0.0 -1.0) 1e-8) (setq ux '(-1.0 0.0 0.0) uy '(0.0 1.0 0.0)))
77.     (if (not (or (equal uz '(0.0 0.0 1.0) 1e-8) (equal uz '(0.0 0.0 -1.0) 1e-8))) (setq ux (unit (v^v '(0.0 0.0 1.0) uz))))
78.     (if (not uy) (setq uy (unit (v^v uz ux))))
79.     (setq ptlst (mapcar '(lambda (p) (transptwcs p '(0.0 0.0 0.0) ux uy)) plptl))
80.     (setq leg
81.            (abs
82.                   obj
83.                   (nth 1 ptlst)
84.                 )
85.                 (vlax-curve-getdistatpoint obj (nth 0 ptlst))
86.              )
87.            )
88.     )
89.       '(lambda (a b)
90.          (equal (abs (- (vlax-curve-getdistatpoint obj (transptwcs (list (car (_getpt obj a)) (cadr (_getpt obj a)) plel) '(0.0 0.0 0.0) ux uy))
91.                         (vlax-curve-getdistatpoint obj (transptwcs (list (car (_getpt obj b)) (cadr (_getpt obj b)) plel) '(0.0 0.0 0.0) ux uy))
92.                      )
93.                 )
94.                 leg
95.                 fuzz
96.          )
97.        )
98.       (list 0 2)
99.       (list 1 3)
100.     )
101.     (perp-p (mapcar '- (transptwcs (list (car (_getpt obj 2)) (cadr (_getpt obj 2)) plel) '(0.0 0.0 0.0) ux uy) (transptwcs (list (car (_getpt obj 1)) (cadr (_getpt obj 1)) plel) '(0.0 0.0 0.0) ux uy))
102.             (mapcar '- (transptwcs (list (car (_getpt obj 3)) (cadr (_getpt obj 3)) plel) '(0.0 0.0 0.0) ux uy) (transptwcs (list (car (_getpt obj 2)) (cadr (_getpt obj 2)) plel) '(0.0 0.0 0.0) ux uy))
103.             fuzz
104.     )
105.   )
106. )
107.
108.

M.R.

BTW. On my comp. (vlax-method-available-p) function doesn't exist... I changed it to (vlax-method-applicable-p)
« Last Edit: September 20, 2013, 04:32:28 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)