|
多谢tcs19621!另我补充说明：
此程序对于当点数大于一定数量出现内存溢出错误，这种解决办法是再加一段分治算法进去，即可（代码叫容易实现，但我没加加进去）就是：把一个可能包含十万个以上的点按照100或者1000分段然后分别对每段求凸包，最后选择所有的凸包，再求凸包。也就是凸包集的凸包是点集的并集的凸包。（有点拗口）
重新改进代码段，使之更简短，更有效，比以前的速度快了不少。
算法用时跟规模是成线性的，由此可见此算法是一个跟n成线性的算法，不是平方级以上的。对此算法而言，时间主要取决于凸包的复杂度，时间不超过O(n.h),也就是说：凸包的边界点所占点集比例越大，时间越多。很可能出现这样一种情况，一个点集虽然比另外一个点集中的点多，但如果这个点集的凸包边界更简单的话，时间反而会少。
以此综述，这种算法不适宜于大量点位于凸包边界上的点集，但对于凸包边界简单的大量点集有效。
对此算法基本可以告一段落了，欢迎大家多提建议。
;;;************************************************************************
;;;一个求点集合的凸包的lisp程序--------------------------------------------
;;;------采用的算法为礼品包扎法--------------------------------------------
;;;方法为最右端的点开始处理，将该点作为凸包边界的第一个点P1，从最初的垂直线
;;;方向绕P1顺时针旋转，直到碰到另一个P2这就是凸包边界的第二个点P2，依此类推
;;;p2求得p3......直到又重新回到p1，已经考虑了各种退化情况和浮点运算，其算法
;;;时间不超过O(n.h),其中h是凸包的复杂度，时间还是很快的。大家不妨验证。
;;;参考文献<<计算几何-算法及其应用>>(第二版),以及参考了其他网站的一些源代码
;;;------------------------------------------------------------------------
;;;其中程序主段是核心算法，其他的附加程序为取得点集，画凸包边界线，测试大量
;;;点集函数处理所花费的时间。----------------------------------------------
;;;用法: 加载lisp运行test选取点，直线段，或多义线(全是直线段组成)即可。----
;;;************************************************************************
(defun C:test (/ olderr en errmsg oldmode oce sl ss t1 t2 ptlist pp)
;;定义错误函数和预处理--------------------
(setvar "errno" 0)
(setq olderr *error*)
(defun *error* (msg)
(setq en (getvar "errno"))
(setq errmsg (strcat "errno=" (itoa en) "\nError:" msg))
(alert errmsg)
(setq *error* olderr)
)
(graphscr)
(setq oldmode (getvar "osmode"))
(setq oce (getvar "cmdecho"))
(setvar "cmdecho" 0)
(command ".ucs" "W")
;;也可以用其他方式取得点集----------------
;;取点，画线，并对函数用时计算------------
(setq sl ' ((-4 . "<OR" )
(0 . "POINT")
(0 . "LINE")
(0 . "POLYLINE")
(0 . "LWPOLYLINE")
(-4 . "OR>" )))
(setq ss (ssget sl))
(setq ptlist (getpt ss))
(setq t1 (getvar "CDATE"));;计时开始------
(setq pp (hull ptlist))
(setq t2 (getvar "CDATE"));;计时结束------
(princ "\n用时=")
(princ (* (- t2 t1) 1e6))
(princ "秒")
(if (= nil pp)
(progn
(alert "点的有效数目太小，请重新输入!")
(command ".ucs" "p")
(setvar "osmode" oldmode)
(setvar "cmdecho" oce)
(princ)
)
(progn
;;画凸包边界线------------------------
(setvar "osmode" 0)
(entmake
(append
'((0 . "lwpolyline")(100 . "AcDbEntity")(100 . "AcDbPolyline"))
(list (cons 90 (length pp)))
(mapcar '(lambda (x) (cons 10 (list (car x) (cadr x)))) pp)
(list (cons 70 1))(list (cons 62 1))
)
)
(command ".ucs" "P")
(setvar "osmode" oldmode)
(setvar "cmdecho" oce)
(princ)
)
)
)
;;;*****************************************
;;;程序主段，可以单独成为函数---------------
(defun hull (ptlist / pfirst p0 p1 p2 pp)
(cond
((= (length ptlist) 0)
nil
)
((or nil (= (length ptlist) 1) (= (length ptlist) 2))
(progn
(alert "你输入的点为两点或一点!")
ptlist
)
)
(t
(progn
;;定义顺时针方向的夹角为正值，反之为负
(defun ang (p1 p0 p2 / j2 j3 x)
(setq j2 (angle p1 p0))
(setq j3 (angle p1 p2))
(setq x (- j3 j2))
(cond
((equal p1 p2 1e-8) 0)
((> (- x pi) 1e-8) (+ x (* -2 pi)))
((< (+ x pi) 1e-8) (+ x (* 2 pi)))
(t x)
)
)
(defun angmax (ptlist p0 p1)
(nth (car (vl-sort-i (mapcar '(lambda (x) (ang p1 p0 x)) ptlist) '>)) ptlist)
)
;;排序函数----------------------------
(defun maxium (pts)
(car (vl-sort pts '(lambda (e1 e2)(if (equal (car e1) (car e2) 1e-8)(> (cadr e1) (cadr e2))(> (car e1) (car e2))))))
)
;;计算--------------------------------
(setq pfirst (maxium ptlist))
(setq p1 pfirst p0 (list (car pfirst) (+ 1.0 (cadr pfirst)) (caddr pfirst)))
(setq p2 (angmax ptlist p0 p1))
(setq pp (cons p2 (list p1)))
(while (not (equal pfirst p2 1e-8))
(setq p0 p1)
(setq p1 p2)
(setq p2 (angmax ptlist p0 p1))
(setq pp (cons p2 pp))
)
(reverse (cdr pp))
)
)
)
)
;;;程序主段结束-----------------------------
;;;*****************************************
;;依据晓东网站的代码改写而成的取点函数------
(defun getpt (ss / i listpp a b c d)
(setq i 0 listpp nil )
(if ss
(repeat (sslength ss)
(setq a (ssname ss i))
(setq b (entget a))
(setq ename (cdr (assoc 0 b)))
(cond
( (or nil (= ename "POLYLINE") (= ename "LWPOLYLINE"))
(progn
(setq c (GetListOfPline a))
(setq listpp (append c listpp))
)
)
( (= ename "LINE")
(progn
(setq c (cdr (assoc 10 b)))
(setq d (cdr (assoc 11 b)))
(setq listpp (cons c listpp))
(setq listpp (cons d listpp))
)
)
( (= ename "POINT")
(progn
(setq c (cdr (assoc 10 b)))
(setq listpp (cons c listpp))
)
)
)
(setq i (1+ i))
)
)
listpp
)
;;以下代码来自明经通道----------------------
;;Get all nodes of the LWPolyline, Polyline.
(defun GetListOfPline (EntityName / SSE_Pline N newEntityName)
(setq SSE_Pline (entget EntityName))
(setq LastList nil)
(if (= (cdr (assoc 0 SSE_Pline)) "LWPOLYLINE")
(progn
(setq LastList (LIST (LIST 0 0 0)))
(setq N 0)
(while (/= (nth N SSE_Pline) nil)
(if (= (car (nth N SSE_Pline)) 10)
(setq LastList (append LastList
(list (list (cadr (nth N SSE_Pline))
(caddr (nth N SSE_Pline))
0
)
)
)
)
)
(setq N (+ N 1))
)
(setq LastList (cdr LastList))
)
)
(if (= (cdr (ASSOC 0 SSE_Pline)) "POLYLINE")
(PROGN
(setq LastList (list (list 0 0 0)))
(setq newEntityName (entnext EntityName))
(while (= (cdr (assoc 0 (entget newEntityName))) "VERTEX")
(setq
LastList (append
LastList
(list
(list (cadr (assoc 10 (entget newEntityName)))
(caddr (assoc 10 (entget newEntityName)))
0
)
)
)
)
(setq newEntityName (entnext newEntityName))
)
(setq LastList (cdr LastList))
)
)
(setq LastList LastList)
)
| 
[复制链接]
发表于 2006-11-14 19:30
置顶卡
变色卡
显身卡
发表于 2016-10-19 18:40
楼主
发表于 2007-1-12 11:14