获得曲线的最小和最大面积矩形

newer

1. (defun c:min+maxbbrec-2dents ( / *error*  maxn mid pp bb pta bbar geta min-maxbbrec f ss bbb )
   
2. 
   
3.   (defun *error* ( m )
   
4.     (if f (command "_.UCS" "_P"))
   
5.     (if m (prompt m))
   
6.     (princ)
   
7.   )
   
8.   (defun maxn ( l / x r )
   
9.     (if (cadr l)
   
10.       (progn
    
11.         (while (cadr l)
    
12.           (if (null r)
    
13.             (setq x (car l))
    
14.             (setq x r)
    
15.           )
    
16.           (if (> x (cadr l))
    
17.             (setq r x)
    
18.             (setq r (cadr l))
    
19.           )
    
20.           (setq l (cdr l))
    
21.         )
    
22.         r
    
23.       )
    
24.       (car l)
    
25.     )
    
26.   )
    
27. 
    
28.   (defun mid ( p1 p2 )
    
29.     (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) p1 p2)
    
30.   )
    
31. 
    
32.   (defun pp ( p a )
    
33.     (caddr (trans p 0 (polar '(0.0 0.0 0.0) a 1.0)))
    
34.   )
    
35. 
    
36.   (defun bb ( entl a / p1 p2 d bbb bbl ) (vl-load-com)
    
37.     (foreach ent entl
    
38.       (vla-getboundingbox (vlax-ename->vla-object ent) 'p1 'p2)
    
39.       (mapcar 'set (list 'p1 'p2) (mapcar 'vlax-safearray->list (list p1 p2)))
    
40.       (setq d (* 25 (distance p1 p2)))
    
41.       (mapcar 'set (list 'p1 'p2) (mapcar '(lambda ( x s ) (polar x (+ a (* 0.25 pi)) ((eval s) d))) (list (mid p1 p2) (mid p1 p2)) (list '- '+)))
    
42.       (setq bbb (mapcar
    
43.                 '(lambda ( p )
    
44.                    (list
    
45.                      (pp (vlax-curve-getclosestpointtoprojection ent p (polar '(0.0 0.0 0.0) (+ a (* 0.5 pi)) 1.0)) a)
    
46.                      (pp (vlax-curve-getclosestpointtoprojection ent p (polar '(0.0 0.0 0.0) a 1.0)) (+ a (* 0.5 pi)))
    
47.                      0.0
    
48.                    )
    
49.                  ) (list p1 p2)
    
50.                )
    
51.       )
    
52.       (setq bbl (cons bbb bbl))
    
53.     )
    
54.     (setq bbb
    
55.       (list
    
56.         (list
    
57.           (minn (mapcar 'car (mapcar 'car bbl)))
    
58.           (minn (mapcar 'cadr (mapcar 'car bbl)))
    
59.           0.0
    
60.         )
    
61.         (list
    
62.           (maxn (mapcar 'car (mapcar 'cadr bbl)))
    
63.           (maxn (mapcar 'cadr (mapcar 'cadr bbl)))
    
64.           0.0
    
65.         )
    
66.       )
    
67.     )
    
68.     bbb
    
69.   )
    
70. 
    
71.   (defun pta ( pt a )
    
72.     (list
    
73.       (pp pt a)
    
74.       (pp pt (+ (* 0.5 pi) a))
    
75.       (caddr pt)
    
76.     )
    
77.   )
    
78. 
    
79.   (defun bbar ( ptll ptur )
    
80.     (* (- (car ptur) (car ptll)) (- (cadr ptur) (cadr ptll)))
    
81.   )
    
82. 
    
83.   (defun geta ( entl / k a aral bbb armin amin armax amax )
    
84.     (setq k -1)
    
85.     (repeat (fix (* 2.0 pi 1e+3))
    
86.       (setq a (* (setq k (1+ k)) 1e-3))
    
87.       (setq aral (cons (list (bbar (car (setq bbb (bb entl a)))
    
88.                                   (cadr bbb)
    
89.                              )
    
90.                              a
    
91.                        )
    
92.                        aral
    
93.                  )
    
94.       )
    
95.     )
    
96.     (setq armin (minn (mapcar 'car aral)))
    
97.     (setq amin (cadr (assoc armin aral)))
    
98.     (setq armax (maxn (mapcar 'car aral)))
    
99.     (setq amax (cadr (assoc armax aral)))
    
100.     (list (list armin amin) (list armax amax))
     
101.   )
     
102. 
     
103.   (defun min-maxbbrec ( entl / get anmin anmax bbb d )
     
104.     (setq anmin (cadr (car (setq get (geta entl)))))
     
105.     (setq anmax (cadr (cadr get)))
     
106.     (list
     
107.       (list
     
108.         (car (setq bbb (mapcar '(lambda ( p ) (pta p (- anmin))) (bb entl anmin))))
     
109.         (polar (car bbb) anmin (setq d (- (pp (cadr bbb) anmin) (pp (car bbb) anmin))))
     
110.         (cadr bbb)
     
111.         (polar (cadr bbb) anmin (- d))
     
112.         (car (car get))
     
113.       )
     
114.       (list
     
115.         (car (setq bbb (mapcar '(lambda ( p ) (pta p (- anmax))) (bb entl anmax))))
     
116.         (polar (car bbb) anmax (setq d (- (pp (cadr bbb) anmax) (pp (car bbb) anmax))))
     
117.         (cadr bbb)
     
118.         (polar (cadr bbb) anmax (- d))
     
119.         (car (cadr get))
     
120.       )
     
121.     )
     
122.   )
     
123. 
     
124.   ---------------------------------------------------------------
     
125.   (if (eq (getvar 'worlducs) 0)
     
126.     (progn
     
127.       (command "_.UCS" "_W")
     
128.       (setq f t)
     
129.     )
     
130.   )
     
131.   (prompt "\nSelect 2d curve entities that lie in WCS")
     
132.   (setq ss (ssget '((0 . "*POLYLINE,SPLINE,LINE,ARC,CIRCLE,ELLIPSE"))))
     
133.   (while (or (not ss) (or (not (equal (caddr (car (acet-geom-ss-extents-accurate ss))) 0.0 1e-6)) (not (equal (caddr (cadr (acet-geom-ss-extents-accurate ss))) 0.0 1e-6))))
     
134.     (prompt "\nEmpty sel.set or selected curve entities don't lie in WCS or some aren't 2D... Please select 2d curve entities that lie in WCS again...")
     
135.     (setq ss (ssget '((0 . "*POLYLINE,SPLINE,LINE,ARC,CIRCLE,ELLIPSE"))))
     
136.   )
     
137.   (entmake
     
138.     (list
     
139.       '(0 . "LWPOLYLINE")
     
140.       '(100 . "AcDbEntity")
     
141.       '(100 . "AcDbPolyline")
     
142.       '(90 . 4)
     
143.       (cons 70 (if (eq (getvar 'plinegen) 1) 129 1))
     
144.       '(62 . 3)
     
145.       '(38 . 0.0)
     
146.       (cons 10 (car (car (setq bbb (min-maxbbrec (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))))))
     
147.       (cons 10 (cadr (car bbb)))
     
148.       (cons 10 (caddr (car bbb)))
     
149.       (cons 10 (cadddr (car bbb)))
     
150.       '(210 0.0 0.0 1.0)
     
151.     )
     
152.   )
     
153.   (entmake
     
154.     (list
     
155.       '(0 . "LWPOLYLINE")
     
156.       '(100 . "AcDbEntity")
     
157.       '(100 . "AcDbPolyline")
     
158.       '(90 . 4)
     
159.       (cons 70 (if (eq (getvar 'plinegen) 1) 129 1))
     
160.       '(62 . 1)
     
161.       '(38 . 0.0)
     
162.       (cons 10 (car (cadr bbb)))
     
163.       (cons 10 (cadr (cadr bbb)))
     
164.       (cons 10 (caddr (cadr bbb)))
     
165.       (cons 10 (cadddr (cadr bbb)))
     
166.       '(210 0.0 0.0 1.0)
     
167.     )
     
168.   )
     
169.   (prompt "\nGreen rectangle is minimum enclosing and red is maximum enclosing...")
     
170.   (prompt (strcat "\nMinimal area is : " (rtos (last (car bbb)) 2 50) "\tMaximal area is : " (rtos (last (cadr bbb)) 2 50)))
     
171.   (*error* nil)
     
172. )
     

(defun c:min+maxbbrec-2dents ( / *error*  maxn mid pp bb pta bbar geta min-maxbbrec f ss bbb )<br /> <br />   (defun *error* ( m )<br />     (if f (command "_.UCS" "_P"))<br />     (if m (prompt m))<br />     (princ)<br />   )<br />   (defun maxn ( l / x r )<br />     (if (cadr l)<br />       (progn<br />         (while (cadr l)<br />           (if (null r)<br />             (setq x (car l))<br />             (setq x r)<br />           )<br />           (if (> x (cadr l))<br />             (setq r x)<br />             (setq r (cadr l))<br />           )<br />           (setq l (cdr l))<br />         )<br />         r<br />       )<br />       (car l)<br />     )<br />   )<br /> <br />   (defun mid ( p1 p2 )<br />     (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) p1 p2)<br />   )<br /> <br />   (defun pp ( p a )<br />     (caddr (trans p 0 (polar '(0.0 0.0 0.0) a 1.0)))<br />   )<br /> <br />   (defun bb ( entl a / p1 p2 d bbb bbl ) (vl-load-com)<br />     (foreach ent entl<br />       (vla-getboundingbox (vlax-ename->vla-object ent) 'p1 'p2)<br />       (mapcar 'set (list 'p1 'p2) (mapcar 'vlax-safearray->list (list p1 p2)))<br />       (setq d (* 25 (distance p1 p2)))<br />       (mapcar 'set (list 'p1 'p2) (mapcar '(lambda ( x s ) (polar x (+ a (* 0.25 pi)) ((eval s) d))) (list (mid p1 p2) (mid p1 p2)) (list '- '+)))<br />       (setq bbb (mapcar <br />                 '(lambda ( p )<br />                    (list <br />                      (pp (vlax-curve-getclosestpointtoprojection ent p (polar '(0.0 0.0 0.0) (+ a (* 0.5 pi)) 1.0)) a)<br />                      (pp (vlax-curve-getclosestpointtoprojection ent p (polar '(0.0 0.0 0.0) a 1.0)) (+ a (* 0.5 pi)))<br />                      0.0<br />                    )<br />                  ) (list p1 p2)<br />                )<br />       )<br />       (setq bbl (cons bbb bbl))<br />     )<br />     (setq bbb<br />       (list<br />         (list<br />           (minn (mapcar 'car (mapcar 'car bbl)))<br />           (minn (mapcar 'cadr (mapcar 'car bbl)))<br />           0.0<br />         )<br />         (list<br />           (maxn (mapcar 'car (mapcar 'cadr bbl)))<br />           (maxn (mapcar 'cadr (mapcar 'cadr bbl)))<br />           0.0<br />         )<br />       )<br />     )<br />     bbb<br />   )<br /> <br />   (defun pta ( pt a )<br />     (list<br />       (pp pt a)<br />       (pp pt (+ (* 0.5 pi) a))<br />       (caddr pt)<br />     )<br />   )<br /> <br />   (defun bbar ( ptll ptur )<br />     (* (- (car ptur) (car ptll)) (- (cadr ptur) (cadr ptll)))<br />   )<br /> <br />   (defun geta ( entl / k a aral bbb armin amin armax amax )<br />     (setq k -1)<br />     (repeat (fix (* 2.0 pi 1e+3))<br />       (setq a (* (setq k (1+ k)) 1e-3))<br />       (setq aral (cons (list (bbar (car (setq bbb (bb entl a)))<br />                                   (cadr bbb)<br />                              )<br />                              a<br />                        )<br />                        aral<br />                  )<br />       )<br />     )<br />     (setq armin (minn (mapcar 'car aral)))<br />     (setq amin (cadr (assoc armin aral)))<br />     (setq armax (maxn (mapcar 'car aral)))<br />     (setq amax (cadr (assoc armax aral)))<br />     (list (list armin amin) (list armax amax))<br />   )<br /> <br />   (defun min-maxbbrec ( entl / get anmin anmax bbb d )<br />     (setq anmin (cadr (car (setq get (geta entl)))))<br />     (setq anmax (cadr (cadr get)))<br />     (list<br />       (list<br />         (car (setq bbb (mapcar '(lambda ( p ) (pta p (- anmin))) (bb entl anmin))))<br />         (polar (car bbb) anmin (setq d (- (pp (cadr bbb) anmin) (pp (car bbb) anmin))))<br />         (cadr bbb)<br />         (polar (cadr bbb) anmin (- d))<br />         (car (car get))<br />       )<br />       (list<br />         (car (setq bbb (mapcar '(lambda ( p ) (pta p (- anmax))) (bb entl anmax))))<br />         (polar (car bbb) anmax (setq d (- (pp (cadr bbb) anmax) (pp (car bbb) anmax))))<br />         (cadr bbb)<br />         (polar (cadr bbb) anmax (- d))<br />         (car (cadr get))<br />       )<br />     )<br />   )<br /> <br />   ---------------------------------------------------------------<br />   (if (eq (getvar 'worlducs) 0)<br />     (progn<br />       (command "_.UCS" "_W")<br />       (setq f t)<br />     )<br />   )<br />   (prompt "\nSelect 2d curve entities that lie in WCS")<br />   (setq ss (ssget '((0 . "*POLYLINE,SPLINE,LINE,ARC,CIRCLE,ELLIPSE"))))<br />   (while (or (not ss) (or (not (equal (caddr (car (acet-geom-ss-extents-accurate ss))) 0.0 1e-6)) (not (equal (caddr (cadr (acet-geom-ss-extents-accurate ss))) 0.0 1e-6))))<br />     (prompt "\nEmpty sel.set or selected curve entities don't lie in WCS or some aren't 2D... Please select 2d curve entities that lie in WCS again...")<br />     (setq ss (ssget '((0 . "*POLYLINE,SPLINE,LINE,ARC,CIRCLE,ELLIPSE"))))<br />   )<br />   (entmake<br />     (list<br />       '(0 . "LWPOLYLINE")<br />       '(100 . "AcDbEntity")<br />       '(100 . "AcDbPolyline")<br />       '(90 . 4)<br />       (cons 70 (if (eq (getvar 'plinegen) 1) 129 1))<br />       '(62 . 3)<br />       '(38 . 0.0)<br />       (cons 10 (car (car (setq bbb (min-maxbbrec (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))))))<br />       (cons 10 (cadr (car bbb)))<br />       (cons 10 (caddr (car bbb)))<br />       (cons 10 (cadddr (car bbb)))<br />       '(210 0.0 0.0 1.0)<br />     )<br />   )<br />   (entmake<br />     (list<br />       '(0 . "LWPOLYLINE")<br />       '(100 . "AcDbEntity")<br />       '(100 . "AcDbPolyline")<br />       '(90 . 4)<br />       (cons 70 (if (eq (getvar 'plinegen) 1) 129 1))<br />       '(62 . 1)<br />       '(38 . 0.0)<br />       (cons 10 (car (cadr bbb)))<br />       (cons 10 (cadr (cadr bbb)))<br />       (cons 10 (caddr (cadr bbb)))<br />       (cons 10 (cadddr (cadr bbb)))<br />       '(210 0.0 0.0 1.0)<br />     )<br />   )<br />   (prompt "\nGreen rectangle is minimum enclosing and red is maximum enclosing...")<br />   (prompt (strcat "\nMinimal area is : " (rtos (last (car bbb)) 2 50) "\tMaximal area is : " (rtos (last (cadr bbb)) 2 50)))<br />   (*error* nil)<br /> )<br />

minn函数：

游客，如果您要查看本帖隐藏内容请回复

上面是LISP实现，

下面是XDRX API实现代码：

1. (defun c:tt ()
   
2.   (if (setq e (car (xdrx_entsel
   
3.                      "\n拾取曲线<退出>:"
   
4.                      '((0 . "*LINE,ARC,CIRCLE,ELLIPSE"))
   
5.                    )
   
6.               )
   
7.       )
   
8.     (progn
   
9.       (setq pts         (xdrx_getsamplept e 0.001)
   
10.             minA (xdrx_points_minareabox pts)
    
11.             maxA (xdrx_points_maxareabox pts)
    
12.       )
    
13.       (xdrx_polyline_make minA t)
    
14.       (xdrx_setpropertyvalue (entlast) "color" 3)
    
15.       (xdrx_polyline_make maxA t)
    
16.       (xdrx_setpropertyvalue (entlast) "color" 1)
    
17.     )
    
18.   )
    
19.   (princ)
    
20. )
    

(defun c:tt ()<br />   (if (setq e (car (xdrx_entsel<br />                      "\n拾取曲线<退出>:"<br />                      '((0 . "*LINE,ARC,CIRCLE,ELLIPSE"))<br />                    )<br />               )<br />       )<br />     (progn<br />       (setq pts         (xdrx_getsamplept e 0.001)<br />             minA (xdrx_points_minareabox pts)<br />             maxA (xdrx_points_maxareabox pts)<br />       )<br />       (xdrx_polyline_make minA t)<br />       (xdrx_setpropertyvalue (entlast) "color" 3)<br />       (xdrx_polyline_make maxA t)<br />       (xdrx_setpropertyvalue (entlast) "color" 1)<br />     )<br />   )<br />   (princ)<br /> )<br />

效率测试工具

1. (defun _xmin (e)
   
2.   (setq        pts  (xdrx_getsamplept e 0.001)
   
3.         minA (xdrx_points_minareabox pts)
   
4.         maxA (xdrx_points_maxareabox pts)
   
5.   )
   
6. )
   
7. (defun c:tt ()
   
8.   (if (setq e (car (entsel)))
   
9.     (progn
   
10.       (setq ss (ssadd)
    
11.             ss (ssadd e ss)
    
12.       )
    
13.       (xd::quickbench
    
14.         '((setq a(min-maxbbrec
    
15.            (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
    
16.           ))
    
17.           (setq b (_xmin e))
    
18.          )
    
19.       )
    
20.     )
    
21.   )
    
22.   (princ)
    
23. )
    

(defun _xmin (e)<br />   (setq        pts  (xdrx_getsamplept e 0.001)<br />         minA (xdrx_points_minareabox pts)<br />         maxA (xdrx_points_maxareabox pts)<br />   )<br /> )<br /> (defun c:tt ()<br />   (if (setq e (car (entsel)))<br />     (progn<br />       (setq ss (ssadd)<br />             ss (ssadd e ss)<br />       )<br />       (xd::quickbench<br />         '((setq a(min-maxbbrec<br />            (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))<br />           ))<br />           (setq b (_xmin e))<br />          )<br />       )<br />     )<br />   )<br />   (princ)<br /> )<br />

测试结果：

q3_2006

学习方法..

laiz3000

厉害，回复学习一下

yoyoho

回复学习一下，谢谢分享！

原地踏步

最小面积用得更多些。

xinxirong

图片有亮点。256G内存，双cpu，，这服务器要两三万吧？

crtrccrt

一个字很好

newer

xinxirong 发表于 2017-7-15 07:33

DELL T7910 图形工作站
双至强 E5-2643 V4
内存256G
显卡 NVIDIA Quadro M6000 24GB
4X1T PCIe M.2 固态硬盘
3X4T 机械硬盘

上面那个显卡就5万，总共12万多

HLCAD

感谢版主分享程序！！！

kqqt6236

谢谢，回复学习。

819534890

回复学习学习

向嘟嘟

回复学习。

dnbcgrass

回复学习学习！

xinxirong

有没有最大内接矩形？？？

ynhh

来学习亮点
真没见过啊