获得曲线的最小和最大面积矩形
本帖最后由 newer 于 2017-7-14 20:17 编辑(defun c:min+maxbbrec-2dents ( / *error*maxn mid pp bb pta bbar geta min-maxbbrec f ss bbb )
(defun *error* ( m )
(if f (command "_.UCS" "_P"))
(if m (prompt m))
(princ)
)
(defun maxn ( l / x r )
(if (cadr l)
(progn
(while (cadr l)
(if (null r)
(setq x (car l))
(setq x r)
)
(if (> x (cadr l))
(setq r x)
(setq r (cadr l))
)
(setq l (cdr l))
)
r
)
(car l)
)
)
(defun mid ( p1 p2 )
(mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) p1 p2)
)
(defun pp ( p a )
(caddr (trans p 0 (polar '(0.0 0.0 0.0) a 1.0)))
)
(defun bb ( entl a / p1 p2 d bbb bbl ) (vl-load-com)
(foreach ent entl
(vla-getboundingbox (vlax-ename->vla-object ent) 'p1 'p2)
(mapcar 'set (list 'p1 'p2) (mapcar 'vlax-safearray->list (list p1 p2)))
(setq d (* 25 (distance p1 p2)))
(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 '- '+)))
(setq bbb (mapcar
'(lambda ( p )
(list
(pp (vlax-curve-getclosestpointtoprojection ent p (polar '(0.0 0.0 0.0) (+ a (* 0.5 pi)) 1.0)) a)
(pp (vlax-curve-getclosestpointtoprojection ent p (polar '(0.0 0.0 0.0) a 1.0)) (+ a (* 0.5 pi)))
0.0
)
) (list p1 p2)
)
)
(setq bbl (cons bbb bbl))
)
(setq bbb
(list
(list
(minn (mapcar 'car (mapcar 'car bbl)))
(minn (mapcar 'cadr (mapcar 'car bbl)))
0.0
)
(list
(maxn (mapcar 'car (mapcar 'cadr bbl)))
(maxn (mapcar 'cadr (mapcar 'cadr bbl)))
0.0
)
)
)
bbb
)
(defun pta ( pt a )
(list
(pp pt a)
(pp pt (+ (* 0.5 pi) a))
(caddr pt)
)
)
(defun bbar ( ptll ptur )
(* (- (car ptur) (car ptll)) (- (cadr ptur) (cadr ptll)))
)
(defun geta ( entl / k a aral bbb armin amin armax amax )
(setq k -1)
(repeat (fix (* 2.0 pi 1e+3))
(setq a (* (setq k (1+ k)) 1e-3))
(setq aral (cons (list (bbar (car (setq bbb (bb entl a)))
(cadr bbb)
)
a
)
aral
)
)
)
(setq armin (minn (mapcar 'car aral)))
(setq amin (cadr (assoc armin aral)))
(setq armax (maxn (mapcar 'car aral)))
(setq amax (cadr (assoc armax aral)))
(list (list armin amin) (list armax amax))
)
(defun min-maxbbrec ( entl / get anmin anmax bbb d )
(setq anmin (cadr (car (setq get (geta entl)))))
(setq anmax (cadr (cadr get)))
(list
(list
(car (setq bbb (mapcar '(lambda ( p ) (pta p (- anmin))) (bb entl anmin))))
(polar (car bbb) anmin (setq d (- (pp (cadr bbb) anmin) (pp (car bbb) anmin))))
(cadr bbb)
(polar (cadr bbb) anmin (- d))
(car (car get))
)
(list
(car (setq bbb (mapcar '(lambda ( p ) (pta p (- anmax))) (bb entl anmax))))
(polar (car bbb) anmax (setq d (- (pp (cadr bbb) anmax) (pp (car bbb) anmax))))
(cadr bbb)
(polar (cadr bbb) anmax (- d))
(car (cadr get))
)
)
)
---------------------------------------------------------------
(if (eq (getvar 'worlducs) 0)
(progn
(command "_.UCS" "_W")
(setq f t)
)
)
(prompt "\nSelect 2d curve entities that lie in WCS")
(setq ss (ssget '((0 . "*POLYLINE,SPLINE,LINE,ARC,CIRCLE,ELLIPSE"))))
(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))))
(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...")
(setq ss (ssget '((0 . "*POLYLINE,SPLINE,LINE,ARC,CIRCLE,ELLIPSE"))))
)
(entmake
(list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 4)
(cons 70 (if (eq (getvar 'plinegen) 1) 129 1))
'(62 . 3)
'(38 . 0.0)
(cons 10 (car (car (setq bbb (min-maxbbrec (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))))))
(cons 10 (cadr (car bbb)))
(cons 10 (caddr (car bbb)))
(cons 10 (cadddr (car bbb)))
'(210 0.0 0.0 1.0)
)
)
(entmake
(list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 4)
(cons 70 (if (eq (getvar 'plinegen) 1) 129 1))
'(62 . 1)
'(38 . 0.0)
(cons 10 (car (cadr bbb)))
(cons 10 (cadr (cadr bbb)))
(cons 10 (caddr (cadr bbb)))
(cons 10 (cadddr (cadr bbb)))
'(210 0.0 0.0 1.0)
)
)
(prompt "\nGreen rectangle is minimum enclosing and red is maximum enclosing...")
(prompt (strcat "\nMinimal area is : " (rtos (last (car bbb)) 2 50) "\tMaximal area is : " (rtos (last (cadr bbb)) 2 50)))
(*error* nil)
)
minn函数：
**** Hidden Message *****
上面是LISP实现，
下面是XDRX API实现代码：
(defun c:tt ()
(if (setq e (car (xdrx_entsel
"\n拾取曲线<退出>:"
'((0 . "*LINE,ARC,CIRCLE,ELLIPSE"))
)
)
)
(progn
(setq pts (xdrx_getsamplept e 0.001)
minA (xdrx_points_minareabox pts)
maxA (xdrx_points_maxareabox pts)
)
(xdrx_polyline_make minA t)
(xdrx_setpropertyvalue (entlast) "color" 3)
(xdrx_polyline_make maxA t)
(xdrx_setpropertyvalue (entlast) "color" 1)
)
)
(princ)
)
效率测试工具
(defun _xmin (e)
(setq pts(xdrx_getsamplept e 0.001)
minA (xdrx_points_minareabox pts)
maxA (xdrx_points_maxareabox pts)
)
)
(defun c:tt ()
(if (setq e (car (entsel)))
(progn
(setq ss (ssadd)
ss (ssadd e ss)
)
(xd::quickbench
'((setq a(min-maxbbrec
(vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
))
(setq b (_xmin e))
)
)
)
)
(princ)
)
测试结果：
学习方法..
厉害，回复学习一下 回复学习一下，谢谢分享！
最小面积用得更多些。 本帖最后由 xinxirong 于 2017-7-15 07:40 编辑
图片有亮点。256G内存，双cpu，，这服务器要两三万吧？ 一个字很好 本帖最后由 newer 于 2017-7-15 08:28 编辑
xinxirong 发表于 2017-7-15 07:33
DELL T7910 图形工作站
双至强 E5-2643 V4
内存256G
显卡 NVIDIA Quadro M6000 24GB
4X1T PCIe M.2 固态硬盘
3X4T 机械硬盘
上面那个显卡就5万，总共12万多
感谢版主分享程序！！！ 谢谢，回复学习。 回复学习学习
回复学习。 回复学习学习！ 有没有最大内接矩形？？？ 来学习亮点
真没见过啊