Topic: Algorithm: 4 point boundary, the area is the smallest.

[ssdd]

Algorithm: 4 point boundary, the area is the smallest.

[ribarm]

Find minimum enclosing triangle by approximation points of reference curve :

Approximation points (I've modified Lee's sub) :

Code: [Select]

(defun c:curve2pts ( / MR:ent->pts c acc pts )

  (vl-load-com)

  ;; Entity to Point List  -  M.R.
  ;; Returns a list of points describing or approximating the supplied entity, else nil if the entity is not supported.
  ;; ent - [ent] Entity name to be described by point list (POINT/LINE/ARC/CIRCLE/LWPOLYLINE/POLYLINE/ELLIPSE/SPLINE)
  ;; acc - [num] Positive number determining the point density for non-linear objects

  (defun MR:ent->pts ( ent acc / der di1 di2 enx inc lst par fds fdm )
      (setq enx (entget ent))
      (cond
          (   (= "POINT" (cdr (assoc 0 enx)))
              (list (cdr (assoc 10 enx)))
          )
          (   (= "LINE" (cdr (assoc 0 enx)))
              (list (cdr (assoc 10 enx)) (cdr (assoc 11 enx)))
          )
          (   (wcmatch (cdr (assoc 0 enx)) "ARC,CIRCLE")
              (setq di1 0.0
                    di2 (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent))
                    inc (/ di2 acc)
                    di2 (- di2 1e-8)
              )
              (while (< di1 di2)
                  (setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
                        di1 (+ di1 inc)
                  )
              )
              (reverse (if (vlax-curve-isclosed ent) lst (cons (vlax-curve-getendpoint ent) lst)))
          )
          (   (and (wcmatch (cdr (assoc 0 enx)) "*POLYLINE") (zerop (logand 80 (cdr (assoc 70 enx)))))
              (setq par 0)
              (repeat (fix (+ 1.0 1e-8 (vlax-curve-getendparam ent)))
                  (cond
                      (   (not (setq der (vlax-curve-getsecondderiv ent par))))
                      (   (equal der '(0.0 0.0 0.0) 1e-8)
                          (if (/= par (vlax-curve-getendparam ent))
                              (setq lst (cons (vlax-curve-getpointatparam ent par) lst))
                          )
                      )
                      (   (not (equal der '(0.0 0.0 0.0) 1e-8))
                          (if (/= par (vlax-curve-getendparam ent))
                              (progn
                                  (setq di1 (vlax-curve-getdistatparam ent par)
                                        di2 (vlax-curve-getdistatparam ent (1+ par))
                                  )
                                  (setq inc (/ (- di2 di1) acc)
                                        di2 (- di2 1e-8)
                                  )
                                  (while (< di1 di2)
                                      (setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
                                            di1 (+ di1 inc)
                                      )
                                  )
                              )
                          )
                      )
                  )
                  (setq par (1+ par))
              )
              (reverse (if (vlax-curve-isclosed ent) lst (cons (vlax-curve-getendpoint ent) lst)))
          )
          (   (= "ELLIPSE" (cdr (assoc 0 enx)))
              (setq di1 (vlax-curve-getdistatparam ent (vlax-curve-getstartparam ent))
                    di2 (vlax-curve-getdistatparam ent (vlax-curve-getendparam   ent))
                    inc (/ (- di2 di1) acc)
                    di2 (- di2 1e-8)
              )
              (while (< di1 di2)
                  (setq fds (cons (distance '(0.0 0.0 0.0) (vlax-curve-getfirstderiv ent (vlax-curve-getparamatdist ent di1))) fds)
                        di1 (+ di1 (distance '(0.0 0.0 0.0) (vlax-curve-getfirstderiv ent (vlax-curve-getparamatdist ent di1))))
                  )
              )
              (setq di1 (vlax-curve-getdistatparam ent (vlax-curve-getstartparam ent)))
              (setq fdm (apply 'max fds))
              (while (< di1 di2)
                  (setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
                        di1 (+ di1 (* (/ (distance '(0.0 0.0 0.0) (vlax-curve-getfirstderiv ent (vlax-curve-getparamatdist ent di1))) fdm) inc))
                  )
              )
              (reverse (if (vlax-curve-isclosed ent) lst (cons (vlax-curve-getendpoint ent) lst)))
          )
          (   (= "SPLINE" (cdr (assoc 0 enx)))
              (setq di1 (vlax-curve-getdistatparam ent (vlax-curve-getstartparam ent))
                    di2 (vlax-curve-getdistatparam ent (vlax-curve-getendparam   ent))
                    inc (/ (- di2 di1) acc)
                    di2 (- di2 1e-8)
              )
              (while (< di1 di2)
                  (setq fds (cons (distance '(0.0 0.0 0.0) (vlax-curve-getfirstderiv ent (vlax-curve-getparamatdist ent di1))) fds)
                        di1 (+ di1 (distance '(0.0 0.0 0.0) (vlax-curve-getfirstderiv ent (vlax-curve-getparamatdist ent di1))))
                  )
              )
              (setq di1 (vlax-curve-getdistatparam ent (vlax-curve-getstartparam ent)))
              (setq fdm (apply 'max fds))
              (while (< di1 di2)
                  (setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
                        di1 (+ di1 (* (/ (distance '(0.0 0.0 0.0) (vlax-curve-getfirstderiv ent (vlax-curve-getparamatdist ent di1))) fdm) inc))
                  )
              )
              (reverse (if (vlax-curve-isclosed ent) lst (cons (vlax-curve-getendpoint ent) lst)))
          )
      )
  )

  (while (or (not (setq c (car (entsel "\nPick curve entity...")))) (if c (vl-catch-all-error-p (vl-catch-all-apply 'vlax-curve-getstartpoint (list c)))))
    (prompt "\nMissed or picked wrong entity type...")
  )
  (initget 6)
  (setq acc (getreal "\nSpecify number of point density <35> : "))
  (if (null acc)
    (setq acc 35.0)
  )
  (setq pts (MR:ent->pts c acc))
  (foreach p pts
    (entmake (list '(0 . "POINT") (cons 10 p)))
  )
  (princ)
)

Minimum and maximum enclosing triangle - convex hull :
http://www.theswamp.org/index.php?topic=50176.msg553387#msg553387

When you find smallest triangle, cut the biggest apex area sub triangle with convex hull edge so the final result is 4 pt shape with smallest area...

[ribarm]

This mod of my posted link worked for me... Very limited testings...

Code - Auto/Visual Lisp: [Select]

1. (defun c:minencquadpol-rndpts ( / *error* car-sort unit mid LM:ConvexHull LM:Clockwise-p MR:triangarea ac ti pdm pds f ss i p pl lil pp1 pp2 pp3 ar trl ll ur qual pp11 pp12 pp21 pp22 pp31 pp32 pp4 tr qua )
2.  
3.   (vl-load-com)
4.  
5.   (defun *error* ( msg )
6.     (if f (vl-cmdf "_.UCS" "_P"))
7.     (if pdm (setvar 'pdmode pdm))
8.     (if pds (setvar 'pdsize pds))
9.     (if msg (prompt msg))
10.     (princ)
11.   )
12.  
13.   (defun car-sort ( l f / removenth r k )
14.  
15.     (defun removenth ( l n / k )
16.       (setq k -1)
17.       (vl-remove-if '(lambda ( x ) (= (setq k (1+ k)) n)) l)
18.     )
19.  
20.     (setq k -1)
21.     (vl-some '(lambda ( a ) (setq k (1+ k)) (if (vl-every '(lambda ( x ) (apply f (list a x))) (removenth l k)) (setq r a))) l)
22.     r
23.   )
24.  
25.   (defun unit ( v / d )
26.     (if (not (equal (setq d (distance '(0.0 0.0 0.0) v)) 0.0 1e-8))
27.       (mapcar '(lambda ( x ) (/ x d)) v)
28.     )
29.   )
30.  
31.   (defun mid ( p1 p2 )
32.     (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) p1 p2)
33.   )
34.  
35.   ;; Convex Hull  -  Lee Mac
36.   ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
37.  
38.   (defun LM:ConvexHull ( lst / ch p0 )
39.       (cond
40.           (   (< (length lst) 4) lst)
41.           (   (setq p0 (car lst))
42.               (foreach p1 (cdr lst)
43.                   (if (or (< (cadr p1) (cadr p0))
44.                           (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0)))
45.                       )
46.                       (setq p0 p1)
47.                   )
48.               )
49.               (setq lst (vl-remove p0 lst))
50.               (setq lst (append (list p0) lst))
51.               (setq lst
52.                   (vl-sort lst
53.                       (function
54.                           (lambda ( a b / c d )
55.                               (if (or (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8) (and (or (equal c 0.0 1e-8) (equal c (* 2 pi) 1e-8)) (or (equal d 0.0 1e-8) (equal d (* 2 pi) 1e-8))))
56.                                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
57.                                   (< c d)
58.                               )
59.                           )
60.                       )
61.                   )
62.               )
63.               (setq ch (list (cadr lst) (car lst)))
64.               (foreach pt (cddr lst)
65.                   (setq ch (cons pt ch))
66.                   (while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt))
67.                       (setq ch (cons pt (cddr ch)))
68.                   )
69.               )
70.               (reverse ch)
71.           )
72.       )
73.   )
74.  
75.   ;; Clockwise-p  -  Lee Mac
76.   ;; Returns T if p1,p2,p3 are clockwise oriented or collinear
77.  
78.   (defun LM:Clockwise-p ( p1 p2 p3 )
79.       (<  (-  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
80.               (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
81.           )
82.           1e-8
83.       )
84.   )
85.  
86.   ;; triangarea - Marko R.
87.   ;; Returns area of triangle defined with p1,p2,p3 in 3d space
88.  
89.   (defun MR:triangarea ( p1 p2 p3 / v12 v13 v1 v21 v23 v2 c cz r ar )
90.     (setq v12 (unit (mapcar '- p2 p1)))
91.     (setq v13 (unit (mapcar '- p3 p1)))
92.     (setq v1 (unit (mid v12 v13)))
93.     (setq v21 (mapcar '- v12))
94.     (setq v23 (unit (mapcar '- p3 p2)))
95.     (setq v2 (unit (mid v21 v23)))
96.     (setq c (inters p1 (mapcar '+ p1 v1) p2 (mapcar '+ p2 v2) nil))
97.     (setq cz (trans c 0 v12))
98.     (setq r (distance (mapcar '+ '(0.0 0.0) (trans p1 0 v12)) cz))
99.     (setq ar (* r 0.5 (+ (distance p1 p2) (distance p2 p3) (distance p3 p1))))
100.     ar
101.   )
102.  
103.   (setq ac (vlax-get-acad-object))
104.   (setq pdm (getvar 'pdmode))
105.   (setvar 'pdmode 0)
106.   (setq pds (getvar 'pdsize))
107.   (setvar 'pdsize -1.5)
108.   (if (eq (getvar 'worlducs) 0)
109.     (progn
110.       (vl-cmdf "_.UCS" "_W")
111.       (setq f t)
112.     )
113.   )
114.   (prompt "\nSelect RND more than 3 points in WCS plane...")
115.   (while (or (not (setq ss (ssget '((0 . "POINT"))))) (not (and (equal (caddr (car (acet-geom-ss-extents-accurate ss))) 0.0 1e-6) (equal (caddr (cadr (acet-geom-ss-extents-accurate ss))) 0.0 1e-6))) (and ss (< (sslength ss) 3)))
116.     (prompt "\nEmpty sel. set or some of selected points don't lie in WCS plane or selected less than 3 points... Please select RND points in WCS plane again...")
117.   )
118.   (setq ti (car (_vl-times)))
119.   (repeat (setq i (sslength ss))
120.     (setq p (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))))
121.     (setq pl (cons p pl))
122.   )
123.   (setq pl (LM:ConvexHull pl))
124.   (setq lil (mapcar '(lambda ( p1 p2 ) (list p1 p2)) pl (cdr (reverse (cons (car pl) (reverse pl))))))
125.   (if (> (length pl) 3)
126.     (foreach l1 lil
127.       (foreach l2 (vl-remove l1 lil)
128.         (foreach l3 (vl-remove l2 (vl-remove l1 lil))
129.           (setq pp1 (inters (car l1) (cadr l1) (car l2) (cadr l2) nil))
130.           (setq pp2 (inters (car l2) (cadr l2) (car l3) (cadr l3) nil))
131.           (setq pp3 (inters (car l3) (cadr l3) (car l1) (cadr l1) nil))
132.           (if (and pp1 pp2 pp3)
133.             (progn
134.               (setq ll (list (apply 'min (mapcar 'car (list pp1 pp2 pp3))) (apply 'min (mapcar 'cadr (list pp1 pp2 pp3)))))
135.               (setq ur (list (apply 'max (mapcar 'car (list pp1 pp2 pp3))) (apply 'max (mapcar 'cadr (list pp1 pp2 pp3)))))
136.               (setq ar (MR:triangarea pp1 pp2 pp3))
137.               (vla-zoomwindow ac (vlax-3d-point ll) (vlax-3d-point ur))
138.               (if (and (ssget "_CP" (list pp1 pp2 pp3) '((0 . "POINT"))) (eq (sslength ss) (sslength (ssget "_CP" (list pp1 pp2 pp3) '((0 . "POINT"))))))
139.                 (setq trl (cons (list ar pp1 pp2 pp3) trl))
140.               )
141.             )
142.           )
143.         )
144.       )
145.     )
146.     (progn
147.       (setq pp1 (car pl) pp2 (cadr pl) pp3 (caddr pl))
148.       (setq trl (cons (list (MR:triangarea pp1 pp2 pp3) pp1 pp2 pp3) trl))
149.     )
150.   )
151.   (if (> (length trl) 1)
152.     (setq tr (car-sort trl '(lambda ( a b ) (<= (car a) (car b)))))
153.     (setq tr (car trl))
154.   )
155.   (setq pp1 (cadr tr) pp2 (caddr tr) pp3 (cadddr tr))
156.   (foreach li lil
157.     (if (and (setq pp11 (inters (car li) (cadr li) pp1 pp2 nil)) (setq pp12 (inters (car li) (cadr li) pp1 pp3 nil)) (not (equal pp11 pp12 1e-8)) (not (equal pp11 pp2 1e-8)) (not (equal pp11 pp3 1e-8)) (not (equal pp12 pp2 1e-8)) (not (equal pp12 pp3 1e-8)))
158.       (progn
159.         (setq ll (list (apply 'min (mapcar 'car (list pp11 pp2 pp3 pp12))) (apply 'min (mapcar 'cadr (list pp11 pp2 pp3 pp12)))))
160.         (setq ur (list (apply 'max (mapcar 'car (list pp11 pp2 pp3 pp12))) (apply 'max (mapcar 'cadr (list pp11 pp2 pp3 pp12)))))
161.         (vla-zoomwindow ac (vlax-3d-point ll) (vlax-3d-point ur))
162.         (if (and (ssget "_CP" (list pp11 pp2 pp3 pp12) '((0 . "POINT"))) (eq (sslength ss) (sslength (ssget "_CP" (list pp11 pp2 pp3 pp12) '((0 . "POINT"))))))
163.           (setq qual (cons (list (+ (MR:triangarea pp11 pp2 pp3) (MR:triangarea pp3 pp11 pp12)) pp11 pp2 pp3 pp12) qual))
164.         )
165.       )
166.     )
167.     (if (and (setq pp31 (inters (car li) (cadr li) pp2 pp3 nil)) (setq pp32 (inters (car li) (cadr li) pp1 pp3 nil)) (not (equal pp31 pp32 1e-8)) (not (equal pp31 pp2 1e-8)) (not (equal pp31 pp1 1e-8)) (not (equal pp32 pp2 1e-8)) (not (equal pp32 pp1 1e-8)))
168.       (progn
169.         (setq ll (list (apply 'min (mapcar 'car (list pp1 pp2 pp31 pp32))) (apply 'min (mapcar 'cadr (list pp1 pp2 pp31 pp32)))))
170.         (setq ur (list (apply 'max (mapcar 'car (list pp1 pp2 pp31 pp32))) (apply 'max (mapcar 'cadr (list pp1 pp2 pp31 pp32)))))
171.         (vla-zoomwindow ac (vlax-3d-point ll) (vlax-3d-point ur))
172.         (if (and (ssget "_CP" (list pp1 pp2 pp31 pp32) '((0 . "POINT"))) (eq (sslength ss) (sslength (ssget "_CP" (list pp1 pp2 pp31 pp32) '((0 . "POINT"))))))
173.           (setq qual (cons (list (+ (MR:triangarea pp1 pp2 pp31) (MR:triangarea pp1 pp31 pp32)) pp1 pp2 pp31 pp32) qual))
174.         )
175.       )
176.     )
177.     (if (and (setq pp21 (inters (car li) (cadr li) pp1 pp2 nil)) (setq pp22 (inters (car li) (cadr li) pp2 pp3 nil)) (not (equal pp21 pp22 1e-8)) (not (equal pp21 pp1 1e-8)) (not (equal pp21 pp3 1e-8)) (not (equal pp22 pp1 1e-8)) (not (equal pp22 pp3 1e-8)))
178.       (progn
179.         (setq ll (list (apply 'min (mapcar 'car (list pp1 pp21 pp22 pp3))) (apply 'min (mapcar 'cadr (list pp1 pp21 pp22 pp3)))))
180.         (setq ur (list (apply 'max (mapcar 'car (list pp1 pp21 pp22 pp3))) (apply 'max (mapcar 'cadr (list pp1 pp21 pp22 pp3)))))
181.         (vla-zoomwindow ac (vlax-3d-point ll) (vlax-3d-point ur))
182.         (if (and (ssget "_CP" (list pp1 pp21 pp22 pp3) '((0 . "POINT"))) (eq (sslength ss) (sslength (ssget "_CP" (list pp1 pp21 pp22 pp3) '((0 . "POINT"))))))
183.           (setq qual (cons (list (+ (MR:triangarea pp1 pp21 pp22) (MR:triangarea pp1 pp22 pp3)) pp1 pp21 pp22 pp3) qual))
184.         )
185.       )
186.     )
187.   )
188.   (if (> (length qual) 1)
189.     (setq qua (car-sort qual '(lambda ( a b ) (<= (car a) (car b)))))
190.     (setq qua (car qual))
191.   )
192.   (setq pp1 (nth 1 qua) pp2 (nth 2 qua) pp3 (nth 3 qua) pp4 (nth 4 qua))
193.   (entmake
194.     (list
195.       '(0 . "LWPOLYLINE")
196.       '(100 . "AcDbEntity")
197.       '(100 . "AcDbPolyline")
198.       '(90 . 4)
199.       (cons 70 (if (eq 1 (getvar 'plinegen)) 129 1))
200.       '(62 . 3)
201.       '(38 . 0.0)
202.       (cons 10 pp1)
203.       (cons 10 pp2)
204.       (cons 10 pp3)
205.       (cons 10 pp4)
206.       '(210 0.0 0.0 1.0)
207.     )
208.   )
209.   (prompt (strcat "\nArea of quad is : " (rtos (caar qual) 2 50)))
210.   (prompt (strcat "\nElapsed time : " (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50) " seconds..."))
211.   (vl-cmdf "_.ZOOM" "_OB" (entlast) "")
212.   (*error* nil)
213. )
214.  

HTH., M.R.

[ssdd]

Thanks Ribarm