找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 1793|回复: 27

[每日一码] 获得曲线的最小和最大面积矩形

[复制链接]

已领礼包: 40个

财富等级: 招财进宝

发表于 2017-7-14 19:31:32 | 显示全部楼层 |阅读模式

马上注册,结交更多好友,享用更多功能,让你轻松玩转社区。

您需要 登录 才可以下载或查看,没有账号?立即注册

×
本帖最后由 newer 于 2017-7-14 20:17 编辑

  1. (defun c:min+maxbbrec-2dents ( / *error*  maxn mid pp bb pta bbar geta min-maxbbrec f ss bbb )

  2.   (defun *error* ( m )
  3.     (if f (command "_.UCS" "_P"))
  4.     (if m (prompt m))
  5.     (princ)
  6.   )
  7.   (defun maxn ( l / x r )
  8.     (if (cadr l)
  9.       (progn
  10.         (while (cadr l)
  11.           (if (null r)
  12.             (setq x (car l))
  13.             (setq x r)
  14.           )
  15.           (if (> x (cadr l))
  16.             (setq r x)
  17.             (setq r (cadr l))
  18.           )
  19.           (setq l (cdr l))
  20.         )
  21.         r
  22.       )
  23.       (car l)
  24.     )
  25.   )

  26.   (defun mid ( p1 p2 )
  27.     (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) p1 p2)
  28.   )

  29.   (defun pp ( p a )
  30.     (caddr (trans p 0 (polar '(0.0 0.0 0.0) a 1.0)))
  31.   )

  32.   (defun bb ( entl a / p1 p2 d bbb bbl ) (vl-load-com)
  33.     (foreach ent entl
  34.       (vla-getboundingbox (vlax-ename->vla-object ent) 'p1 'p2)
  35.       (mapcar 'set (list 'p1 'p2) (mapcar 'vlax-safearray->list (list p1 p2)))
  36.       (setq d (* 25 (distance p1 p2)))
  37.       (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 '- '+)))
  38.       (setq bbb (mapcar
  39.                 '(lambda ( p )
  40.                    (list
  41.                      (pp (vlax-curve-getclosestpointtoprojection ent p (polar '(0.0 0.0 0.0) (+ a (* 0.5 pi)) 1.0)) a)
  42.                      (pp (vlax-curve-getclosestpointtoprojection ent p (polar '(0.0 0.0 0.0) a 1.0)) (+ a (* 0.5 pi)))
  43.                      0.0
  44.                    )
  45.                  ) (list p1 p2)
  46.                )
  47.       )
  48.       (setq bbl (cons bbb bbl))
  49.     )
  50.     (setq bbb
  51.       (list
  52.         (list
  53.           (minn (mapcar 'car (mapcar 'car bbl)))
  54.           (minn (mapcar 'cadr (mapcar 'car bbl)))
  55.           0.0
  56.         )
  57.         (list
  58.           (maxn (mapcar 'car (mapcar 'cadr bbl)))
  59.           (maxn (mapcar 'cadr (mapcar 'cadr bbl)))
  60.           0.0
  61.         )
  62.       )
  63.     )
  64.     bbb
  65.   )

  66.   (defun pta ( pt a )
  67.     (list
  68.       (pp pt a)
  69.       (pp pt (+ (* 0.5 pi) a))
  70.       (caddr pt)
  71.     )
  72.   )

  73.   (defun bbar ( ptll ptur )
  74.     (* (- (car ptur) (car ptll)) (- (cadr ptur) (cadr ptll)))
  75.   )

  76.   (defun geta ( entl / k a aral bbb armin amin armax amax )
  77.     (setq k -1)
  78.     (repeat (fix (* 2.0 pi 1e+3))
  79.       (setq a (* (setq k (1+ k)) 1e-3))
  80.       (setq aral (cons (list (bbar (car (setq bbb (bb entl a)))
  81.                                   (cadr bbb)
  82.                              )
  83.                              a
  84.                        )
  85.                        aral
  86.                  )
  87.       )
  88.     )
  89.     (setq armin (minn (mapcar 'car aral)))
  90.     (setq amin (cadr (assoc armin aral)))
  91.     (setq armax (maxn (mapcar 'car aral)))
  92.     (setq amax (cadr (assoc armax aral)))
  93.     (list (list armin amin) (list armax amax))
  94.   )

  95.   (defun min-maxbbrec ( entl / get anmin anmax bbb d )
  96.     (setq anmin (cadr (car (setq get (geta entl)))))
  97.     (setq anmax (cadr (cadr get)))
  98.     (list
  99.       (list
  100.         (car (setq bbb (mapcar '(lambda ( p ) (pta p (- anmin))) (bb entl anmin))))
  101.         (polar (car bbb) anmin (setq d (- (pp (cadr bbb) anmin) (pp (car bbb) anmin))))
  102.         (cadr bbb)
  103.         (polar (cadr bbb) anmin (- d))
  104.         (car (car get))
  105.       )
  106.       (list
  107.         (car (setq bbb (mapcar '(lambda ( p ) (pta p (- anmax))) (bb entl anmax))))
  108.         (polar (car bbb) anmax (setq d (- (pp (cadr bbb) anmax) (pp (car bbb) anmax))))
  109.         (cadr bbb)
  110.         (polar (cadr bbb) anmax (- d))
  111.         (car (cadr get))
  112.       )
  113.     )
  114.   )

  115.   ---------------------------------------------------------------
  116.   (if (eq (getvar 'worlducs) 0)
  117.     (progn
  118.       (command "_.UCS" "_W")
  119.       (setq f t)
  120.     )
  121.   )
  122.   (prompt "\nSelect 2d curve entities that lie in WCS")
  123.   (setq ss (ssget '((0 . "*POLYLINE,SPLINE,LINE,ARC,CIRCLE,ELLIPSE"))))
  124.   (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))))
  125.     (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...")
  126.     (setq ss (ssget '((0 . "*POLYLINE,SPLINE,LINE,ARC,CIRCLE,ELLIPSE"))))
  127.   )
  128.   (entmake
  129.     (list
  130.       '(0 . "LWPOLYLINE")
  131.       '(100 . "AcDbEntity")
  132.       '(100 . "AcDbPolyline")
  133.       '(90 . 4)
  134.       (cons 70 (if (eq (getvar 'plinegen) 1) 129 1))
  135.       '(62 . 3)
  136.       '(38 . 0.0)
  137.       (cons 10 (car (car (setq bbb (min-maxbbrec (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))))))
  138.       (cons 10 (cadr (car bbb)))
  139.       (cons 10 (caddr (car bbb)))
  140.       (cons 10 (cadddr (car bbb)))
  141.       '(210 0.0 0.0 1.0)
  142.     )
  143.   )
  144.   (entmake
  145.     (list
  146.       '(0 . "LWPOLYLINE")
  147.       '(100 . "AcDbEntity")
  148.       '(100 . "AcDbPolyline")
  149.       '(90 . 4)
  150.       (cons 70 (if (eq (getvar 'plinegen) 1) 129 1))
  151.       '(62 . 1)
  152.       '(38 . 0.0)
  153.       (cons 10 (car (cadr bbb)))
  154.       (cons 10 (cadr (cadr bbb)))
  155.       (cons 10 (caddr (cadr bbb)))
  156.       (cons 10 (cadddr (cadr bbb)))
  157.       '(210 0.0 0.0 1.0)
  158.     )
  159.   )
  160.   (prompt "\nGreen rectangle is minimum enclosing and red is maximum enclosing...")
  161.   (prompt (strcat "\nMinimal area is : " (rtos (last (car bbb)) 2 50) "\tMaximal area is : " (rtos (last (cadr bbb)) 2 50)))
  162.   (*error* nil)
  163. )


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. )


QQ截图20170714193010.png

效率测试工具

  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. )


测试结果:

QQ截图20170714201225.png


论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!

已领礼包: 2476个

财富等级: 金玉满堂

发表于 2017-7-14 21:06:43 | 显示全部楼层
学习方法..
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复

使用道具 举报

已领礼包: 475个

财富等级: 日进斗金

发表于 2017-7-15 00:32:40 | 显示全部楼层
厉害,回复学习一下
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 8710个

财富等级: 富甲天下

发表于 2017-7-15 07:17:01 | 显示全部楼层
回复学习一下,谢谢分享!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 5188个

财富等级: 富甲天下

发表于 2017-7-15 07:32:46 | 显示全部楼层
最小面积用得更多些。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 5060个

财富等级: 富甲天下

发表于 2017-7-15 07:33:04 来自手机 | 显示全部楼层
本帖最后由 xinxirong 于 2017-7-15 07:40 编辑

图片有亮点。256G内存,双cpu,,这服务器要两三万吧?
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 6个

财富等级: 恭喜发财

发表于 2017-7-15 07:45:49 | 显示全部楼层
一个字很好
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 40个

财富等级: 招财进宝

 楼主| 发表于 2017-7-15 08:10:18 | 显示全部楼层
本帖最后由 newer 于 2017-7-15 08:28 编辑

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

上面那个显卡就5万,总共12万多
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 5578个

财富等级: 富甲天下

发表于 2017-7-15 08:33:11 | 显示全部楼层
感谢版主分享程序!!!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 6056个

财富等级: 富甲天下

发表于 2017-7-17 00:07:19 | 显示全部楼层
谢谢,回复学习。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 2963个

财富等级: 家财万贯

发表于 2017-7-17 15:22:42 | 显示全部楼层
回复学习学习
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 1387个

财富等级: 财源广进

发表于 2017-8-30 20:49:20 | 显示全部楼层
回复学习。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复

使用道具 举报

已领礼包: 3700个

财富等级: 富可敌国

发表于 2017-8-30 21:23:14 | 显示全部楼层
回复学习学习!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 5060个

财富等级: 富甲天下

发表于 2017-8-30 23:04:05 来自手机 | 显示全部楼层
有没有最大内接矩形???
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 6881个

财富等级: 富甲天下

发表于 2017-8-31 08:19:00 | 显示全部楼层
来学习亮点
真没见过啊
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

QQ|申请友链|Archiver|手机版|小黑屋|辽公网安备|晓东CAD家园 ( 辽ICP备15016793号 )

GMT+8, 2024-3-28 19:47 , Processed in 0.477514 second(s), 59 queries , Gzip On.

Powered by Discuz! X3.5

© 2001-2024 Discuz! Team.

快速回复 返回顶部 返回列表