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

0 Members and 1 Guest are viewing this topic.

ribarm

  • Water Moccasin
  • Posts: 2226
  • 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...
 :wink:
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

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...
 :wink:

 :-D

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.         p1 (vlax-curve-getpointatparam e 0)
  6.         p2 (vlax-curve-getpointatparam e 1)
  7.         p3 (vlax-curve-getpointatparam e 2)
  8.         p4 (vlax-curve-getpointatparam e 3)
  9.   )
  10.   (p (mapcar (function (lambda (a b c d) (/ (+ a d c a b c) 6))) p1 p2 p3 p4) 1)
  11.   (p (mapcar (function (lambda (a b) (/ (+ a b) 2))) p2 p4) 2)
  12. )
蝸牛そろそろ登れ富士の山 /Kobayashi Issa/

ribarm

  • Water Moccasin
  • Posts: 2226
  • 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)

:)

M.R. on Youtube

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 ...
蝸牛そろそろ登れ富士の山 /Kobayashi Issa/

ribarm

  • Water Moccasin
  • Posts: 2226
  • 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)

:)

M.R. on Youtube

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. )
蝸牛そろそろ登れ富士の山 /Kobayashi Issa/

ribarm

  • Water Moccasin
  • Posts: 2226
  • 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.          p2 (vlax-curve-getpointatparam e 1)
  3.          p3 (vlax-curve-getpointatparam e 2)
  4.          p4 (vlax-curve-getpointatparam e 3)
  5.    )
  6.         (equal (mapcar (function (lambda (a b) (/ (+ a b) 2))) p2 p4)
  7.                (mapcar (function (lambda (a b) (/ (+ a b) 2))) p1 p3)
  8.                f
  9.         )
  10.         (equal (distance p1 p3) (distance p2 p4) f)
  11.    )
  12. )
  13.  
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

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.         p2 (vlax-curve-getpointatparam e 1)
  3.         p3 (vlax-curve-getpointatparam e 2)
  4.         p4 (vlax-curve-getpointatparam e 3)
  5.   )
  6.   (equal (distance p4 (mapcar (function (lambda (a b c) (/ (+ a b c) 3))) p1 p2 p3))
  7.          (distance p3 (mapcar (function (lambda (a b c) (/ (+ a b c) 3))) p1 p2 p4))
  8.          f
  9.   )
  10. )
蝸牛そろそろ登れ富士の山 /Kobayashi Issa/

owenwengerd

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

ribarm

  • Water Moccasin
  • Posts: 2226
  • 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)

:)

M.R. on Youtube

owenwengerd

  • Bull Frog
  • Posts: 439
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: 439
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: 2226
  • 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
  11.     (- (* (cadr u) (caddr v)) (* (cadr v) (caddr u)))
  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.       (progn
  57.         (setq k 0.0)
  58.         (setq pts1 (vl-remove nil (mapcar '(lambda (x) (if (equal (/ k 2.0) (float (fix (/ (setq k (1+ k)) 2.0))) fuzz) x)) pts)))
  59.         (setq k 1.0)
  60.         (setq pts2 (vl-remove nil (mapcar '(lambda (x) (if (equal (/ k 2.0) (float (fix (/ (setq k (1+ k)) 2.0))) fuzz) x)) pts)))
  61.         (setq plel (vla-get-elevation obj))
  62.         (setq plptl (mapcar '(lambda (x y) (list x y plel)) pts1 pts2))
  63.       ))
  64.       ((and (= 12 (length pts)) (eq (vla-get-objectname obj) "AcDb2dPolyline"))
  65.       (progn
  66.         (setq plel (vla-get-elevation obj))
  67.         (repeat 4
  68.           (setq pt (list (car pts) (cadr pts) plel))
  69.           (setq pts (cdddr pts))
  70.           (setq plptl (cons pt plptl))
  71.         )
  72.         (setq plptl (reverse plptl))
  73.       ))
  74.       (nil T)
  75.     )
  76.     (setq uz (vlax-safearray->list (vlax-variant-value (vla-get-normal obj))))
  77.     (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)))
  78.     (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)))
  79.     (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))))
  80.     (if (not uy) (setq uy (unit (v^v uz ux))))
  81.     (setq ptlst (mapcar '(lambda (p) (transptwcs p '(0.0 0.0 0.0) ux uy)) plptl))
  82.     (setq leg
  83.            (abs
  84.              (- (vlax-curve-getdistatpoint
  85.                   obj
  86.                   (nth 1 ptlst)
  87.                 )
  88.                 (vlax-curve-getdistatpoint obj (nth 0 ptlst))
  89.              )
  90.            )
  91.     )
  92.     (vl-every
  93.       '(lambda (a b)
  94.          (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))
  95.                         (vlax-curve-getdistatpoint obj (transptwcs (list (car (_getpt obj b)) (cadr (_getpt obj b)) plel) '(0.0 0.0 0.0) ux uy))
  96.                      )
  97.                 )
  98.                 leg
  99.                 fuzz
  100.          )
  101.        )
  102.       (list 0 2)
  103.       (list 1 3)
  104.     )
  105.     (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))
  106.             (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))
  107.             fuzz
  108.     )
  109.   )
  110. )
  111.  
  112.  

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)

:)

M.R. on Youtube