LISP画最小矩形代码

newer · 发表于 2016-4-12 18:02:31

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

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

×

本帖最后由 newer 于 2016-4-12 18:03 编辑

;;;The procedure for Test
(defun C:aq (/ PP PTLIST SEL T0 n)
(setq sel (ssget (list '(0 . "POINT,LWPOLYLINE,LINE,SPLINE")))) ;select curve or point
(initget 7)
(setq n 2000)
(if sel
(progn
(setq ptlist (getpt sel 2000)) ;construct the set of points
(setq ptlist (Graham-scan ptlist)) ;construct the CCW Hull of this set.
(if (<= (det (car ptlist) (cadr ptlist) (caddr ptlist)) 0.0) ;ensure the hull is CCW.
(setq ptlist (reverse ptlist)) ;if it isn't CCW,then reverse it
)
(setq t0 (getvar "TDUSRTIMER")) ;The start time of this algorithm
(setq pp (car (MinAreaRectangle ptlist))) ;start calculating
(princ "\nIt takes :")
(princ (* (- (getvar "TDUSRTIMER") t0) 86400)) ;The End time
(princ "seconds")
(if pp
(make-poly pp) ;draw rectangle.
)
)
)
(princ)
)
;;;=======================================================
;;;Function : Find the minimum area of encasing rectangle.
;;;Arguments : A CCW HULL
;;;Return: The Four points of Rectangle and its Area
;;;=======================================================
(defun MinAreaRectangle (ptlist / AA AI BB D1
D2 EDGE I I1X I1Y I2X I2Y
IL INF IX IY J1 J2 MINA
MINH MINW NORH NORM PI1 PI2 PTI0
PTI1 PTI2 PTJ1 PTK1 PTM1 PTS1 PTS2
PTS3 PTS4 REC1 REC2 REC3 REC4 RECT
VECH VECL VJ12 VM12
)
(setq INF 1e309)
(setq minA INF) ;Initiating the Minimum area is infinite
(setq pti0 (car ptlist)) ;the first point of Hull.
(setq pts1 (append ptlist (list pti0))) ;add the first point at back of Hull
(setq pts2 (cdr (append ptlist ptlist (list pti0)))) ;Construct a loop for the hull
(setq i 0)
;;Find area of encasing rectangle anchored on each edge.
(repeat (length ptlist)
(setq pi1 (car pts1)
pi2 (cadr pts1)
i1x (car pi1)
i1y (cadr pi1)
i2x (car pi2)
i2y (cadr pi2)
ix (- i2x i1x)
iy (- i2y i1y)
il (distance (list ix iy) '(0.0 0.0))
)
;;寻找最左点
;;Find a vertex on on first perpendicular line of support
(while (> (DOTPR ix iy pts2) 0.0)
(setq pts2 (cdr pts2))
)
;;寻找最上点
;;Find a vertex on second perpendicular line of suppoer
(if (= i 0)
(setq pts3 pts2)
)
(while (> (CROSSPR ix iy pts3) 0.0)
(setq pts3 (cdr pts3))
)
;;寻找最右点
;;Find a vertex on second perpendicular line of suppoer
(if (= i 0)
(setq pts4 pts3)
)
(while (< (DOTPR ix iy pts4) 0.0)
(setq pts4 (cdr pts4))
)
;;得出了每边的矩形
;;Find distances between parallel and perpendicular lines of support
(cond
((equal i1x i2x 1e-4) ;如果边两点的X值相同
(setq d1 (- (caar pts3) i1x) ;那么矩形的高就是最上点与边的X的差值
d2 (- (cadar pts4) (cadar pts2)) ;矩形的宽就是最左和最右的Y的差值
)
)
((equal i1y i2y 1e-4) ;如果边两点的Y值相同
(setq d1 (- (cadar pts3) i1y) ;那么矩形的高就是最上点与边的Y的差值
d2 (- (caar pts4) (caar pts2)) ;矩形的宽就是最左和最右的X的差值
)
)
(T
(setq aa (det pi1 pi2 (car pts3))) ;否则计算边和最上点构成的面积的二倍(det)
(setq d1 (/ aa il)) ;高就是det值除以边长
(setq j1 (car pts2)) ;最右边点
(setq j2 (list (- (car j1) iy) (+ (cadr j1) ix))) ;通过最右边点的垂直边的点
(setq bb (det j1 j2 (car pts4))) ;最右边点，上面的点和最左边的点
(setq d2 (/ bb il)) ;这三点的det除以边长就是宽
)
)
;;计算矩形的面积，必要时更新最小面积
;;Compute area of encasing rectangle anchored on current edge.
;;if the area is smaller than the old Minimum area,then update,and record the width,height and five points.
(setq Ai (abs (* d1 d2))) ;面积就是高和宽的积
(if (< Ai MinA) ;如果面积小于先前的最小面积，则记录：
(setq MinA Ai ;更新最小面积
MinH d1 ;最小面积的高
MinW d2 ;最小面积的宽
pti1 pi1 ;最小面积的边的第一个端点
pti2 pi2 ;最小面积的边的第二个端点
ptj1 (car pts2) ;最右边的点
ptk1 (car pts3) ;最上面的点
ptm1 (car pts4) ;最左边的点
)
)
(setq pts1 (cdr pts1)) ;检测下一条边
(setq i (1+ i)) ;计数器加一
)
;;according to the result ,draw the Minimum Area Rectangle
(setq edge (mapcar '- pti2 pti1)) ;最小面积的边对应的向量
(setq VecL (distance edge '(0.0 0.0))) ;最小面积的边的长度
(setq NorH (abs (/ MinH VecL))) ;这边的法线
(setq Norm (list (- (cadr edge)) (car edge))) ;这边的垂直向量
(setq vj12 (mapcar '+ ptj1 Norm)) ;通过最右点的垂直向量
(setq vm12 (mapcar '+ ptm1 Norm)) ;通过最左点的垂直向量
(setq vecH (mapcar '* (list NorH NorH) Norm))
(setq rec1 (inters pti1 pti2 ptj1 vj12 nil)) ;矩形的第一点
(setq rec4 (inters pti1 pti2 ptm1 vm12 nil)) ;矩形的第四点
(setq rec2 (mapcar '+ rec1 vecH)) ;矩形的第二点
(setq rec3 (mapcar '+ rec4 vecH)) ;矩形的第三点
(setq rect (list Rec1 rec2 rec3 rec4)) ;矩形的点表
(cons rect MinA) ;返回这个矩形的点表和最大距离
)
;;;========================================
;;;求凸壳的直径的程序
;;;参数：逆时针的凸壳 H-------注意逆时针!!!
;;;返回值: 直径的两个端点和直径 Pair . MaxD
;;;========================================
(defun Max-distance (H / D M MAXD P PAIR Q U V W)
(setq Q (cdr (append H H (list (car H))))) ;构造一个首尾循环的凸集,且起始点为凸壳的第二点
(setq MaxD 0.0) ;初始化最小距离为0
(foreach U H ;依次检查凸壳的边
(setq V (car Q)) ;循环集的第一点
(setq W (cadr Q)) ;循环集的第二点
(setq M (mid-pt V W)) ;这两点的中点
(while (> (dot M U V) 0.0) ;如果夹角小于90度（即点积大于0）
(setq Q (cdr Q)) ;循环集推进
(setq V (car Q)) ;取下一点
(setq W (cadr Q)) ;下下一点
(setq M (mid-pt V W)) ;这两点的中点
)
(setq D (distance U V)) ;计算这时的最大距离
(if (> D MaxD) ;如果大于前面的最大距离
(setq MaxD D ;就替换前面的最大距离
Pair (list U V) ;并记录这对点
)
)
)
(cons Pair MaxD) ;返回这对点和最大距离
)
;;;中点函数
(defun mid-pt (p1 p2)
(list
(* (+ (car p1) (car p2)) 0.5)
(* (+ (cadr p1) (cadr p2)) 0.5)
)
)
;;;以某点为基点，按照角度和距离分类点集
(defun sort-by-angle-distance (ptlist pt / )
(vl-sort ptlist
(function
(lambda (e1 e2 / ang1 ang2 )
(setq ang1 (angle pt e1))
(setq ang2 (angle pt e2))
(if (= ang1 ang2)
(< (distance pt e1) (distance pt e2))
(< ang1 ang2)
)
)
)
)
)
;;;点积= x1*x2 + y1*y2
(defun DOTPR (ix iy pts / pt1 pt2)
(setq pt1 (car pts))
(setq pt2 (cadr pts))
(+ (* ix (- (car pt2) (car pt1)))
(* iy (- (cadr pt2) (cadr pt1)))
)
)
;;;叉积= x1*y2 - x2*y1
(defun CROSSPR (ix iy pts / pt1 pt2)
(setq pt1 (car pts))
(setq pt2 (cadr pts))
(- (* ix (- (cadr pt2) (cadr pt1)))
(* iy (- (car pt2) (car pt1)))
)
)
;;;中点函数
(defun mid-pt (p1 p2)
(list
(* (+ (car p1) (car p2)) 0.5)
(* (+ (cadr p1) (cadr p2)) 0.5)
)
)
;;;定义三点的行列式,即三点之倍面积
(defun det (p1 p2 p3 / x2 y2)
(setq x2 (car p2)
y2 (cadr p2)
)
(- (* (- x2 (car p3)) (- y2 (cadr p1)))
(* (- x2 (car p1)) (- y2 (cadr p3)))
)
)
;;;定义向量的点积函数
(defun dot (p1 p2 p3 / x1 y1)
(setq x1 (car p1)
y1 (cadr p1)
)
(+ (* (- (car p2) x1) (- (car p3) x1))
(* (- (cadr p2) y1) (- (cadr p3) y1))
)
)
;;;取点函数2
(defun getpt (ss n / i s a b c d e)
(setq i 0)
(if ss
(repeat (sslength ss)
(setq a (ssname ss i))
(setq b (entget a))
(setq e (cdr (assoc 0 b)))
(cond
((= e "LWPOLYLINE")
(setq c (get-pline-vertexs a n))
(setq s (append c s))
)
((= e "SPLINE")
(setq c (get-spline-vertexs a n))
(setq s (append c s))
)
((= e "LINE")
(setq c (cdr (assoc 10 b)))
(setq d (cdr (assoc 11 b)))
(setq c (list (car c) (cadr c)))
(setq d (list (car d) (cadr d)))
(setq s (cons c s))
(setq s (cons d s))
)
((= e "POINT")
(setq c (cdr (assoc 10 b)))
(setq c (list (car c) (cadr c)))
(setq s (cons c s))
)
)
(setq i (1+ i))
)
)
s
)
;;取得多边形顶点
(defun get-LWpolyline-vertexs (DXF / lst)
(foreach n DXF
(if (= (car n) 10)
(setq lst (cons (cdr n) lst))
)
)
(reverse lst)
)
(defun get-3dpolyline-vertexs ( ent / p )
(if (and (setq ent (entnext ent)) (setq p (cdr (assoc 10 (entget ent)))))
(cons p (get-3dpolyline-vertexs ent))
)
p
)
;;;取得样条曲线的点
(defun get-spline-vertexs (ent n / DIST ENDPAR I LEN OBJ PT PTS SEG)
(setq obj (vlax-ename->vla-object ent))
(setq endpar (vlax-curve-getEndParam obj))
(setq len (vlax-curve-getDistAtParam obj endpar))
(setq seg (/ len n))
(setq dist 0)
(while (< dist len)
(setq pt (vlax-curve-getPointAtDist obj dist))
(setq pts (cons pt pts))
(setq dist (+ seg dist))
)
(if (= (vla-get-closed obj) :vlax-false)
(setq pt (vlax-curve-getEndPoint obj)
pts (cons pt pts)
)
)
(reverse pts)
)
;;;取得含有圆弧的多段线的点
(defun get-pline-vertexs (ent n / BLG DIST ENDPAR I L1 L2 L3 LI OBJ PT PTS VEXNUM)
(setq obj (vlax-ename->vla-object ent))
(setq endpar (vlax-curve-getEndParam obj))
(setq vexNum (fix endPar))
(setq pts nil)
(setq i 0)
(repeat vexNum
(setq pt (vlax-curve-getPointAtParam obj i))
(setq pts (cons pt pts))
(setq blg (vla-getbulge obj i))
(if (/= blg 0.0)
(progn
(setq l1 (vlax-curve-getDistAtParam obj i))
(setq l2 (vlax-curve-getDistAtParam obj (1+ i)))
(setq l3 (- l2 l1))
(setq li (/ l3 n))
(setq dist l1)
(repeat (1- n)
(setq dist (+ dist li))
(setq pt (vlax-curve-getPointAtDist obj dist))
(setq pts (cons pt pts))
)
)
)
(setq i (1+ i))
)
(if (= (vla-get-closed obj) :vlax-false)
(setq pt (vlax-curve-getEndPoint obj)
pts (cons pt pts)
)
)
pts
)
;;;绘制多段线
(defun Make-Poly (pp / x)
(entmake ;画凸包
(append
'((0 . "LWPOLYLINE")
(100 . "AcDbEntity")
(100 . "AcDbPolyline")
)
(list (cons 90 (length pp))) ;顶点个数
(mapcar
(function (lambda (x) (cons 10 x)))
pp
) ;多段线顶点
(list (cons 70 1)) ;闭合的
(list (cons 62 1)) ;红色的
)
)
)

;;;The procedure for Test 
(defun C:aq (/ PP PTLIST SEL T0 n) 
  (setq sel (ssget (list '(0 . "POINT,LWPOLYLINE,LINE,SPLINE"))))         ;select curve or point 
  (initget 7) 
  (setq n 2000) 
  (if sel                                                          
    (progn 
      (setq ptlist (getpt sel 2000))                                        ;construct the set of points 
      (setq ptlist (Graham-scan ptlist))                                ;construct the CCW Hull of this set. 
      (if (<= (det (car ptlist) (cadr ptlist) (caddr ptlist)) 0.0)      ;ensure the hull is CCW. 
        (setq ptlist (reverse ptlist))                                        ;if it isn't CCW,then reverse it 
      )         
      (setq t0 (getvar "TDUSRTIMER"))                                        ;The start time of this algorithm 
      (setq pp (car (MinAreaRectangle ptlist)))                                ;start calculating 
      (princ "\nIt takes :")                                                 
      (princ (* (- (getvar "TDUSRTIMER") t0) 86400))                         ;The End time 
      (princ "seconds") 
      (if pp 
        (make-poly pp)                                                        ;draw rectangle. 
      ) 
    ) 
  ) 
  (princ) 
) 
;;;======================================================= 
;;;Function : Find the minimum area of encasing rectangle. 
;;;Arguments : A CCW HULL                                  
;;;Return: The Four points of Rectangle and its Area       
;;;======================================================= 
(defun MinAreaRectangle        (ptlist             /           AA         AI    BB    D1 
                         D2    EDGE  I           I1X         I1Y   I2X   I2Y 
                         IL    INF   IX           IY         J1    J2    MINA 
                         MINH  MINW  NORH  NORM         PI1   PI2   PTI0 
                         PTI1  PTI2  PTJ1  PTK1         PTM1  PTS1  PTS2 
                         PTS3  PTS4  REC1  REC2         REC3  REC4  RECT 
                         VECH  VECL  VJ12  VM12 
                        ) 
  (setq INF 1e309)                                                         
  (setq minA INF)                                                        ;Initiating the Minimum area is infinite 
  (setq pti0 (car ptlist))                                                ;the first point of Hull. 
  (setq pts1 (append ptlist (list pti0)))                                ;add the first point at back of Hull 
  (setq pts2 (cdr (append ptlist ptlist (list pti0))))                        ;Construct a loop for the hull 
  (setq i 0)                                                                
 
  ;;Find area of encasing rectangle anchored on each edge. 
  (repeat (length ptlist) 
    (setq pi1 (car   pts1)                                                 
          pi2 (cadr  pts1) 
          i1x (car   pi1) 
          i1y (cadr  pi1) 
          i2x (car   pi2) 
          i2y (cadr  pi2) 
          ix  (- i2x i1x) 
          iy  (- i2y i1y) 
          il  (distance (list ix iy) '(0.0 0.0)) 
    ) 
 
    ;;寻找最左点 
    ;;Find a vertex on on first perpendicular line of support 
    (while (> (DOTPR ix iy pts2) 0.0) 
      (setq pts2 (cdr pts2)) 
    ) 
 
    ;;寻找最上点 
    ;;Find a vertex on second perpendicular line of suppoer 
    (if        (= i 0) 
      (setq pts3 pts2) 
    ) 
    (while (> (CROSSPR ix iy pts3) 0.0) 
      (setq pts3 (cdr pts3)) 
    ) 
 
    ;;寻找最右点 
    ;;Find a vertex on second perpendicular line of suppoer 
    (if        (= i 0) 
      (setq pts4 pts3) 
    ) 
    (while (< (DOTPR ix iy pts4) 0.0) 
      (setq pts4 (cdr pts4)) 
    ) 
 
    ;;得出了每边的矩形 
    ;;Find distances between parallel and perpendicular lines of support 
    (cond 
      ((equal i1x i2x 1e-4)                                                ;如果边两点的X值相同 
       (setq d1        (- (caar pts3) i1x)                                        ;那么矩形的高就是最上点与边的X的差值 
             d2        (- (cadar pts4) (cadar pts2))                                ;矩形的宽就是最左和最右的Y的差值 
       ) 
      ) 
      ((equal i1y i2y 1e-4)                                                ;如果边两点的Y值相同 
       (setq d1        (- (cadar pts3) i1y)                                        ;那么矩形的高就是最上点与边的Y的差值 
             d2        (- (caar pts4) (caar pts2))                                ;矩形的宽就是最左和最右的X的差值 
       ) 
      ) 
 
      (T 
       (setq aa (det pi1 pi2 (car pts3)))                                ;否则计算边和最上点构成的面积的二倍(det) 
       (setq d1 (/ aa il))                                                ;高就是det值除以边长 
       (setq j1 (car pts2))                                                ;最右边点 
       (setq j2 (list (- (car j1) iy) (+ (cadr j1) ix)))                ;通过最右边点的垂直边的点 
       (setq bb (det j1 j2 (car pts4)))                                        ;最右边点，上面的点和最左边的点 
       (setq d2 (/ bb il))                                                ;这三点的det除以边长就是宽 
      ) 
    ) 
 
    ;;计算矩形的面积，必要时更新最小面积 
    ;;Compute area of encasing rectangle anchored on current edge. 
    ;;if the area is smaller than the old Minimum area,then update,and record the width,height and five points. 
    (setq Ai (abs (* d1 d2)))                                                ;面积就是高和宽的积 
    (if        (< Ai MinA)                                                     ;如果面积小于先前的最小面积，则记录： 
      (setq MinA Ai                                                        ;更新最小面积 
            MinH d1                                                        ;最小面积的高 
            MinW d2                                                        ;最小面积的宽 
            pti1 pi1                                                        ;最小面积的边的第一个端点 
            pti2 pi2                                                        ;最小面积的边的第二个端点 
            ptj1 (car pts2)                                                ;最右边的点 
            ptk1 (car pts3)                                                ;最上面的点 
            ptm1 (car pts4)                                                ;最左边的点 
      ) 
    ) 
    (setq pts1 (cdr pts1))                                                ;检测下一条边 
    (setq i (1+ i))                                                        ;计数器加一 
  ) 
 
  ;;according to the result ,draw the Minimum Area Rectangle 
  (setq edge (mapcar '- pti2 pti1))                                        ;最小面积的边对应的向量 
  (setq VecL (distance edge '(0.0 0.0)))                                ;最小面积的边的长度 
  (setq NorH (abs (/ MinH VecL)))                                        ;这边的法线 
 
  (setq Norm (list (- (cadr edge)) (car edge)))                                ;这边的垂直向量 
  (setq vj12 (mapcar '+ ptj1 Norm))                                        ;通过最右点的垂直向量 
  (setq vm12 (mapcar '+ ptm1 Norm))                                        ;通过最左点的垂直向量 
  (setq vecH (mapcar '* (list NorH NorH) Norm))                                 
 
  (setq rec1 (inters pti1 pti2 ptj1 vj12 nil))                                ;矩形的第一点 
  (setq rec4 (inters pti1 pti2 ptm1 vm12 nil))                                ;矩形的第四点 
  (setq rec2 (mapcar '+ rec1 vecH))                                        ;矩形的第二点 
  (setq rec3 (mapcar '+ rec4 vecH))                                        ;矩形的第三点 
  (setq rect (list Rec1 rec2 rec3 rec4))                                ;矩形的点表 
  (cons rect MinA)                                                        ;返回这个矩形的点表和最大距离 
) 
 
;;;======================================== 
;;;求凸壳的直径的程序                      
;;;参数：逆时针的凸壳 H-------注意逆时针!!! 
;;;返回值: 直径的两个端点和直径 Pair . MaxD 
;;;======================================== 
(defun Max-distance (H / D M MAXD P PAIR Q U V W) 
  (setq Q (cdr (append H H (list (car H)))))                                ;构造一个首尾循环的凸集,且起始点为凸壳的第二点 
  (setq MaxD 0.0)                                                        ;初始化最小距离为0 
  (foreach U H                                                                ;依次检查凸壳的边 
    (setq V (car Q))                                                        ;循环集的第一点 
    (setq W (cadr Q))                                                        ;循环集的第二点 
    (setq M (mid-pt V W))                                                ;这两点的中点 
    (while (> (dot M U V) 0.0)                                                ;如果夹角小于90度（即点积大于0） 
      (setq Q (cdr Q))                                                        ;循环集推进 
      (setq V (car Q))                                                        ;取下一点 
      (setq W (cadr Q))                                                        ;下下一点 
      (setq M (mid-pt V W))                                                ;这两点的中点 
    ) 
    (setq D (distance U V))                                                ;计算这时的最大距离 
    (if        (> D MaxD)                                                        ;如果大于前面的最大距离 
      (setq MaxD D                                                        ;就替换前面的最大距离 
            Pair (list U V)                                                ;并记录这对点 
      ) 
    ) 
  ) 
  (cons Pair MaxD)                                                        ;返回这对点和最大距离 
) 
 
 
 
;;;中点函数 
(defun mid-pt (p1 p2) 
  (list 
    (* (+ (car p1) (car p2)) 0.5) 
    (* (+ (cadr p1) (cadr p2)) 0.5) 
  ) 
) 
 
;;;以某点为基点，按照角度和距离分类点集 
(defun sort-by-angle-distance (ptlist pt / ) 
  (vl-sort ptlist 
           (function 
             (lambda (e1 e2 / ang1 ang2 ) 
               (setq ang1 (angle pt e1)) 
               (setq ang2 (angle pt e2)) 
               (if (= ang1 ang2) 
                 (< (distance pt e1) (distance pt e2)) 
                 (< ang1 ang2) 
               ) 
             ) 
           ) 
  ) 
) 
 
;;;点积= x1*x2 + y1*y2 
(defun DOTPR (ix iy pts / pt1 pt2) 
  (setq pt1 (car pts)) 
  (setq pt2 (cadr pts)) 
  (+ (* ix (- (car pt2) (car pt1))) 
     (* iy (- (cadr pt2) (cadr pt1))) 
  ) 
) 
 
;;;叉积= x1*y2 - x2*y1 
(defun CROSSPR (ix iy pts / pt1 pt2) 
  (setq pt1 (car pts)) 
  (setq pt2 (cadr pts)) 
  (- (* ix (- (cadr pt2) (cadr pt1))) 
     (* iy (- (car pt2) (car pt1))) 
  ) 
) 
 
;;;中点函数 
(defun mid-pt (p1 p2) 
  (list 
    (* (+ (car p1) (car p2)) 0.5) 
    (* (+ (cadr p1) (cadr p2)) 0.5) 
  ) 
) 
 
;;;定义三点的行列式,即三点之倍面积 
(defun det (p1 p2 p3 / x2 y2) 
  (setq        x2 (car p2) 
        y2 (cadr p2) 
  ) 
  (- (* (- x2 (car p3)) (- y2 (cadr p1))) 
     (* (- x2 (car p1)) (- y2 (cadr p3))) 
  ) 
) 
 
;;;定义向量的点积函数 
(defun dot (p1 p2 p3 / x1 y1) 
  (setq        x1 (car p1) 
        y1 (cadr p1) 
  ) 
  (+ (* (- (car p2) x1) (- (car p3) x1)) 
     (* (- (cadr p2) y1) (- (cadr p3) y1)) 
  ) 
) 
;;;取点函数2 
(defun getpt (ss n / i s a b c d e) 
  (setq i 0) 
  (if ss 
    (repeat (sslength ss) 
      (setq a (ssname ss i)) 
      (setq b (entget a)) 
      (setq e (cdr (assoc 0 b))) 
      (cond 
        ((= e "LWPOLYLINE") 
         (setq c (get-pline-vertexs a n)) 
         (setq s (append c s)) 
        ) 
        ((= e "SPLINE") 
         (setq c (get-spline-vertexs a n)) 
         (setq s (append c s)) 
        ) 
        ((= e "LINE") 
         (setq c (cdr (assoc 10 b))) 
         (setq d (cdr (assoc 11 b))) 
         (setq c (list (car c) (cadr c))) 
         (setq d (list (car d) (cadr d))) 
         (setq s (cons c s)) 
         (setq s (cons d s)) 
        ) 
        ((= e "POINT") 
         (setq c (cdr (assoc 10 b))) 
         (setq c (list (car c) (cadr c))) 
         (setq s (cons c s)) 
        ) 
      ) 
      (setq i (1+ i)) 
    ) 
  ) 
  s 
) 
 
;;取得多边形顶点 
(defun get-LWpolyline-vertexs (DXF / lst) 
  (foreach n DXF 
    (if        (= (car n) 10) 
      (setq lst (cons (cdr n) lst)) 
    ) 
  ) 
  (reverse lst) 
) 
 
(defun get-3dpolyline-vertexs ( ent / p ) 
  (if (and (setq ent (entnext ent)) (setq p (cdr (assoc 10 (entget ent))))) 
    (cons p (get-3dpolyline-vertexs ent)) 
  ) 
  p 
) 
 
;;;取得样条曲线的点 
(defun get-spline-vertexs (ent n / DIST ENDPAR I LEN OBJ PT PTS SEG) 
  (setq obj (vlax-ename->vla-object ent)) 
  (setq endpar  (vlax-curve-getEndParam obj)) 
  (setq len (vlax-curve-getDistAtParam obj endpar)) 
  (setq seg (/ len n)) 
  (setq dist 0) 
  (while (< dist len)    
    (setq pt (vlax-curve-getPointAtDist obj dist)) 
    (setq pts (cons pt pts)) 
    (setq dist (+ seg dist))    
  ) 
  (if (= (vla-get-closed obj) :vlax-false) 
    (setq pt (vlax-curve-getEndPoint obj) 
          pts (cons pt pts) 
    ) 
  ) 
  (reverse pts) 
) 
 
;;;取得含有圆弧的多段线的点 
(defun get-pline-vertexs (ent n / BLG DIST ENDPAR I L1 L2 L3 LI OBJ PT PTS VEXNUM) 
  (setq obj (vlax-ename->vla-object ent)) 
  (setq endpar (vlax-curve-getEndParam obj)) 
  (setq vexNum (fix endPar)) 
  (setq pts nil) 
  (setq i 0) 
  (repeat vexNum 
    (setq pt (vlax-curve-getPointAtParam obj i)) 
    (setq pts (cons pt pts)) 
    (setq blg (vla-getbulge obj i)) 
    (if (/= blg 0.0) 
      (progn 
        (setq l1 (vlax-curve-getDistAtParam obj i)) 
        (setq l2 (vlax-curve-getDistAtParam obj (1+ i))) 
        (setq l3 (- l2 l1)) 
        (setq li (/ l3 n)) 
        (setq dist l1) 
        (repeat (1- n) 
          (setq dist (+ dist li)) 
          (setq pt (vlax-curve-getPointAtDist obj dist)) 
          (setq pts (cons pt pts)) 
        ) 
      ) 
    ) 
    (setq i (1+ i)) 
  ) 
  (if (= (vla-get-closed obj) :vlax-false) 
    (setq pt (vlax-curve-getEndPoint obj) 
          pts (cons pt pts) 
    ) 
  ) 
  pts 
) 
 
;;;绘制多段线 
(defun Make-Poly (pp / x) 
  (entmake                                                                ;画凸包 
    (append 
      '((0 . "LWPOLYLINE") 
        (100 . "AcDbEntity") 
        (100 . "AcDbPolyline") 
       ) 
      (list (cons 90 (length pp)))                                        ;顶点个数 
      (mapcar 
        (function (lambda (x) (cons 10 x))) 
        pp 
      )                                                                        ;多段线顶点 
      (list (cons 70 1))                                                ;闭合的 
      (list (cons 62 1))                                                ;红色的 
    ) 
  ) 
)

Graham扫描法求凸包

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

lijiao · 发表于 2016-4-14 09:43:05

wekjhrpoiquweproijf;PAOSJKCP8uewpirjf'WEKLF/L;A'WE;LKF
'WEK
**ds;lfk'A;SKDF[AOJWEFLMAS;LDFMASDC

aranty · 发表于 2016-5-10 16:17:22

看看先，顶一个

/db_自贡黄明儒_ · 发表于 2016-4-13 08:05:38

(setq INF 1e309)在05下使用不会出错，但编译后使用就有问题了。

HLCAD · 发表于 2016-4-13 08:06:28

感谢版主为我们提供这么好的代码！

zjy2999 · 发表于 2016-4-13 09:21:28

学习！！！！！！！！

zjy2999 · 发表于 2016-4-13 09:25:59

学习！！！！！！！！

Lisphk · 发表于 2016-4-13 09:33:58

/db_自贡黄明儒_ 发表于 2016-4-13 08:05
(setq INF 1e309)在05下使用不会出错，但编译后使用就有问题了。

大师，请明示。

yxianfo · 发表于 2016-4-13 10:06:10

下载试用、学习提高。

守仁格竹GM · 发表于 2016-4-13 11:46:36

学习

守仁格竹GM · 发表于 2016-4-13 11:55:48

经测试对样条曲线而言，比MSteel钢结构工具箱的速度慢，但是比MSteel得到的矩形面积小，顶大师一下

newer · 发表于 2016-4-13 12:12:01

守仁格竹GM 发表于 2016-4-13 11:55
经测试对样条曲线而言，比MSteel钢结构工具箱的速度慢，但是比MSteel得到的矩形面积小，顶大师一下

能贴上来两个工具生成的图形对比吗？

守仁格竹GM · 发表于 2016-4-13 13:53:12

newer 发表于 2016-4-13 12:12
能贴上来两个工具生成的图形对比吗？

。

/db_自贡黄明儒_ · 发表于 2016-4-13 15:08:25

Lisphk 发表于 2016-4-13 09:33
大师，请明示。

已经说得很明白了哇。你是想知道为什么吧？那我告诉你，我也不知道。

守仁格竹GM · 发表于 2016-4-14 13:53:29

本帖最后由守仁格竹GM 于 2016-4-14 14:29 编辑

缺少包括ARC的和椭圆

账号		自动登录	找回密码
密码			立即注册

[每日一码] LISP画最小矩形代码

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