[原创]：关于平面凸包的一个完整程序(更新到2013年4月9日)

highflybird

这里是我给出的一个关于平面凸包的一个完整的程序。其算法说明在LISP程序中。
希望大家多多指教。

请点击此处下载

查看状态：需购买或无权限

您的用户组是：游客

文件名称:扫描法凸包2.rar 
下载次数:138  文件大小:1.74 KB 
下载权限: 不限 以上  [免费赚D豆]

算法已经更新到2013年4月9日。

highflybird

2. ;;;一个求点集合的凸包的lisp程序--------------------------------------------
   
3. ;;;------采用的算法为礼品包扎法--------------------------------------------
   
4. ;;;方法为最右端的点开始处理，将该点作为凸包边界的第一个点P1，从最初的垂直线
   
5. ;;;方向绕P1顺时针旋转，直到碰到另一个P2这就是凸包边界的第二个点P2，依此类推
   
6. ;;;p2求得p3......直到又重新回到p1，已经考虑了各种退化情况和浮点运算，其算法
   
7. ;;;时间不超过O(n.h),其中h是凸包的复杂度，时间还是很快的。大家不妨验证。   
   
8. ;;;参考文献<<计算几何-算法及其应用>>(第二版),以及参考了晓东网站的一些源代码
   
9. ;;;------------------------------------------------------------------------
   
10. ;;;其中程序主段是核心算法，其他的附加程序为取点，画点，画凸包边界线，可舍弃
    
11. (defun C:tub (/ olderr en errmsg oldmode oce p pfirst p0 p1 pmax1 pmax2 pp)
    
12.   ;;定义错误函数和预处理---------------
    
13.   (setvar "errno" 0)
    
14.   (setq olderr *error*)
    
15.   (defun *error* (msg)
    
16.     (setq en (getvar "errno"))
    
17.     (setq errmsg (strcat "errno=" (itoa en) "\nError:" msg))
    
18.     (alert errmsg)
    
19.     (setq *error* olderr)
    
20.   )
    
21.   (graphscr)
    
22.   (setq oldmode (getvar "osmode"))
    
23.   (setq oce (getvar "cmdecho"))
    
24.   (setvar "cmdecho" 0)
    
25.   ;;定义删除重复点函数-----------------
    
26.   (defun remove-dups (pts / pl p)
    
27.     (while pts
    
28.       (setq p   (car pts)
    
29.             pts (cdr pts)
    
30.             pts (vl-remove-if '(lambda (x) (equal x p 1e-8)) pts)
    
31.             pl (cons p pl)
    
32.       )
    
33.     )
    
34.     (reverse pl)
    
35.   )
    
36.   ;;定义取点函数-----------------------
    
37.   (defun getp (/ m )
    
38.     (setq m (fix (getint "\n请输入点数目:")))
    
39.     (if (< m 3)
    
40.       (progn
    
41.         (alert "你输入的点的数目太小，请重新输入!")
    
42.         (setvar "cmdecho" oce)
    
43.         (princ)
    
44.       )
    
45.       (progn
    
46.         (setq m (1- m))
    
47.         ;;定义0-N的有序整数集函数------
    
48.         (defun listn (a / n x)
    
49.           (setq n 1)
    
50.           (setq x (list 0))
    
51.           (while (<= n a)
    
52.             (setq x (append (list n) x))
    
53.             (setq n (1+ n))
    
54.           )
    
55.           (reverse x)
    
56.         )
    
57.         (setq x (listn m))
    
58.         ;;取得点集---------------------
    
59.         (setq x (mapcar '(lambda (x) (getpoint "\n输入点: ")) x))
    
60.         (setvar "cmdecho" oce)
    
61.         (princ)
    
62.       )
    
63.     )
    
64.   )
    
65.   (getp)
    
66.   (setq x (remove-dups x))
    
67.   ;;定义矢量之叉积,即二阶行列式之值----
    
68.   (defun det2 (p1 p2)
    
69.     (- (* (car p1) (cadr p2)) (* (car p2) (cadr p1)))
    
70.   )
    
71.   ;;定义三点的行列式,即三点之倍面积----
    
72.   (defun det (p1 p2 p3)
    
73.     (+ (det2 p1 p2) (det2 p2 p3) (det2 p3 p1))
    
74.   )
    
75.   (defun sign (x)
    
76.     (cond ((> x 0) -1.0)((< x 0) 1.0)(t 0) )
    
77.   )
    
78.   ;;;定义顺时针方向的夹角为正，反之为负
    
79. 
    
80. 
    
81.   (defun ang (p1 p2 p3 / x)
    
82.     (setq x (abs (- (angle p1 p3) (angle p1 p2))))
    
83.     (if (equal p3 p1 1e-8)
    
84.       (- pi)
    
85.       (if (< (abs (sin x)) 1e-8)
    
86.         (if (equal (- (distance p2 p3) (+ (distance p1 p2) (distance p1 p3))) 0 1e-8)  
    
87.           pi 0
    
88.         )
    
89.         (if (> x pi)
    
90.           (* (- (* 2 pi) x) (sign (det p2 p1 p3)))
    
91.           (* x (sign (det p2 p1 p3)))
    
92.         )
    
93.       )
    
94.     )
    
95.   )
    
96.   ;;***********************************
    
97.   ;;程序主段***************************
    
98.   (defun maxium (pts)
    
99.     (car (vl-sort pts '(lambda (e1 e2) (if (equal (car e1) (car e2) 1e-8)(> (cadr e1) (cadr e2))(> (car e1) (car e2))))))
    
100.     )       
     
101.   ;;计算-------------------------------
     
102.   (setq p0 (maxium x))
     
103.   (setq p1 p0 pfirst p0 p0 (list (car p0) (+ 1.0 (cadr p0)) (caddr p0)))
     
104.   (setq pmax1 p1)
     
105.   (setq p1 (mapcar '(lambda (x) (list (ang p1 p0 x) (distance p1 x) x)) x))
     
106.   (setq pmax2 (caddr (maxium p1)))
     
107.   (setq pp (append (list pmax2 pmax1)))
     
108.   (while (not (equal pfirst pmax2 1e-8))
     
109.     (setq p1 (mapcar '(lambda (x) (list (ang pmax2 pmax1 x) (distance pmax2 x) x)) (mapcar 'caddr p1)))
     
110.     (setq pmax1 pmax2)
     
111.     (setq pmax2 (caddr (maxium p1)))
     
112.     (setq pp (append (list pmax2) pp))
     
113.   )
     
114.   (setq pp (reverse (cdr pp)))
     
115.   ;;画点-------------------------------
     
116.   (setq pdm (getvar "pdmode"))
     
117.   (setq pds (getvar "pdsize"))
     
118.   ;;(setvar "pdmode" 32);这段可加可不加
     
119.   ;;(setvar "pdsize" 0)用来定义点的样式
     
120.   (mapcar '(lambda (pt)
     
121.     (entmake
     
122.       (append
     
123.         '((0 . "Point") (100 . "AcDbEntity") (100 . "AcDbPoint"))
     
124.         (list (cons 10 pt)))
     
125.       )
     
126.     )
     
127.   x)
     
128.   ;;画线-------------------------------
     
129.   (entmake
     
130.     (append
     
131.       '((0 . "lwpolyline") (100 . "AcDbEntity") (100 . "AcDbPolyline"))
     
132.       (list (cons 90 (length pp)))
     
133.       (mapcar '(lambda (x) (cons 10 (list (car x) (cadr x)))) pp)
     
134.       (list (cons 70 1))(list (cons 62 1))
     
135.     )
     
136.   )
     
137.   (setvar "osmode" 0)
     
138.   (setvar "osmode" oldmode)
     
139.   (setvar "cmdecho" oce)
     
140.   pp
     
141. )

;;;一个求点集合的凸包的lisp程序--------------------------------------------<br /> ;;;------采用的算法为礼品包扎法--------------------------------------------<br /> ;;;方法为最右端的点开始处理，将该点作为凸包边界的第一个点P1，从最初的垂直线<br /> ;;;方向绕P1顺时针旋转，直到碰到另一个P2这就是凸包边界的第二个点P2，依此类推<br /> ;;;p2求得p3......直到又重新回到p1，已经考虑了各种退化情况和浮点运算，其算法<br /> ;;;时间不超过O(n.h),其中h是凸包的复杂度，时间还是很快的。大家不妨验证。    <br /> ;;;参考文献<<计算几何-算法及其应用>>(第二版),以及参考了晓东网站的一些源代码<br /> ;;;------------------------------------------------------------------------<br /> ;;;其中程序主段是核心算法，其他的附加程序为取点，画点，画凸包边界线，可舍弃<br /> (defun C:tub (/ olderr en errmsg oldmode oce p pfirst p0 p1 pmax1 pmax2 pp)<br />   ;;定义错误函数和预处理---------------<br />   (setvar "errno" 0)<br />   (setq olderr *error*)<br />   (defun *error* (msg)<br />     (setq en (getvar "errno"))<br />     (setq errmsg (strcat "errno=" (itoa en) "\nError:" msg))<br />     (alert errmsg)<br />     (setq *error* olderr)<br />   )<br />   (graphscr)<br />   (setq oldmode (getvar "osmode"))<br />   (setq oce (getvar "cmdecho"))<br />   (setvar "cmdecho" 0)<br />   ;;定义删除重复点函数-----------------<br />   (defun remove-dups (pts / pl p)<br />     (while pts<br />       (setq p   (car pts)<br />             pts (cdr pts)<br />             pts (vl-remove-if '(lambda (x) (equal x p 1e-8)) pts)<br />             pl (cons p pl)<br />       )<br />     )<br />     (reverse pl)<br />   )<br />   ;;定义取点函数-----------------------<br />   (defun getp (/ m )<br />     (setq m (fix (getint "\n请输入点数目:")))<br />     (if (< m 3)<br />       (progn<br />         (alert "你输入的点的数目太小，请重新输入!")<br />         (setvar "cmdecho" oce)<br />         (princ)<br />       )<br />       (progn<br />         (setq m (1- m))<br />         ;;定义0-N的有序整数集函数------<br />         (defun listn (a / n x)<br />           (setq n 1)<br />           (setq x (list 0))<br />           (while (<= n a)<br />             (setq x (append (list n) x))<br />             (setq n (1+ n))<br />           )<br />           (reverse x)<br />         )<br />         (setq x (listn m))<br />         ;;取得点集---------------------<br />         (setq x (mapcar '(lambda (x) (getpoint "\n输入点: ")) x))<br />         (setvar "cmdecho" oce)<br />         (princ)<br />       )<br />     )<br />   )<br />   (getp)<br />   (setq x (remove-dups x))<br />   ;;定义矢量之叉积,即二阶行列式之值----<br />   (defun det2 (p1 p2)<br />     (- (* (car p1) (cadr p2)) (* (car p2) (cadr p1)))<br />   )<br />   ;;定义三点的行列式,即三点之倍面积----<br />   (defun det (p1 p2 p3)<br />     (+ (det2 p1 p2) (det2 p2 p3) (det2 p3 p1))<br />   )<br />   (defun sign (x)<br />     (cond ((> x 0) -1.0)((< x 0) 1.0)(t 0) )<br />   )<br />   ;;;定义顺时针方向的夹角为正，反之为负<br /> <br /> <br />   (defun ang (p1 p2 p3 / x)<br />     (setq x (abs (- (angle p1 p3) (angle p1 p2))))<br />     (if (equal p3 p1 1e-8)<br />       (- pi)<br />       (if (< (abs (sin x)) 1e-8)<br />         (if (equal (- (distance p2 p3) (+ (distance p1 p2) (distance p1 p3))) 0 1e-8)  <br />           pi 0<br />         )<br />         (if (> x pi)<br />           (* (- (* 2 pi) x) (sign (det p2 p1 p3)))<br />           (* x (sign (det p2 p1 p3)))<br />         )<br />       )<br />     )<br />   )<br />   ;;***********************************<br />   ;;程序主段***************************<br />   (defun maxium (pts)<br />     (car (vl-sort pts '(lambda (e1 e2) (if (equal (car e1) (car e2) 1e-8)(> (cadr e1) (cadr e2))(> (car e1) (car e2))))))<br />     )        <br />   ;;计算-------------------------------<br />   (setq p0 (maxium x))<br />   (setq p1 p0 pfirst p0 p0 (list (car p0) (+ 1.0 (cadr p0)) (caddr p0)))<br />   (setq pmax1 p1)<br />   (setq p1 (mapcar '(lambda (x) (list (ang p1 p0 x) (distance p1 x) x)) x))<br />   (setq pmax2 (caddr (maxium p1)))<br />   (setq pp (append (list pmax2 pmax1)))<br />   (while (not (equal pfirst pmax2 1e-8))<br />     (setq p1 (mapcar '(lambda (x) (list (ang pmax2 pmax1 x) (distance pmax2 x) x)) (mapcar 'caddr p1)))<br />     (setq pmax1 pmax2)<br />     (setq pmax2 (caddr (maxium p1)))<br />     (setq pp (append (list pmax2) pp))<br />   )<br />   (setq pp (reverse (cdr pp)))<br />   ;;画点-------------------------------<br />   (setq pdm (getvar "pdmode"))<br />   (setq pds (getvar "pdsize"))<br />   ;;(setvar "pdmode" 32);这段可加可不加<br />   ;;(setvar "pdsize" 0)用来定义点的样式<br />   (mapcar '(lambda (pt)<br />     (entmake<br />       (append<br />         '((0 . "Point") (100 . "AcDbEntity") (100 . "AcDbPoint"))<br />         (list (cons 10 pt)))<br />       )<br />     ) <br />   x)<br />   ;;画线-------------------------------<br />   (entmake<br />     (append<br />       '((0 . "lwpolyline") (100 . "AcDbEntity") (100 . "AcDbPolyline"))<br />       (list (cons 90 (length pp))) <br />       (mapcar '(lambda (x) (cons 10 (list (car x) (cadr x)))) pp)<br />       (list (cons 70 1))(list (cons 62 1))<br />     )<br />   )<br />   (setvar "osmode" 0)<br />   (setvar "osmode" oldmode)<br />   (setvar "cmdecho" oce)<br />   pp<br /> )

在CAD中运行TUB即可。
图为其演示。

eachy

凸包算法有很多种，楼主的这个算法在 Autolisp 中还不是效率最高的。

Lisp 的运行效率受多个因素影响，上面的程序中 remove-dups 占掉了至少一半的时间，虽然这个函数和求凸包不是直接的关系。

继续努力，还要很大的改进空间。

TUB 测试 16780 个点 约 86s，去掉 remove-dups 速度约减少 一半。

去掉 remove-dups
命令: tub
选择对象: 指定对角点: 找到 18192 个

选择对象:
34.78

命令:

另外一种算法：

命令: tt
选择对象: 指定对角点: 找到 18192 个

选择对象:

Use Time = 18.847

highflybird

多谢斑竹的指教。
我也考虑过了删除重复点这个函数对于求凸包来说无关。
其实这个程序只要有效点（即使重复点全在一个点上）只有一个点也能求出来，只不过那样没有多大意义而已。
这也是我编的第四个lisp程序。
（前三个为求方程的根，马尔法蒂问题求解，四边形内切椭圆问题），深深感知只有在问题中自己编写lisp程序去解决它，才是学习lisp的最好途径。

附上稍微修改后的lisp程序，（改进了如果不是在世界坐标系下这种求法的结果虽然是正确的，但画出来的点和凸边界可能会偏离你点取的位置。）

fsxm

我也写了个凸包程序呵呵！贴上玩玩！
1.纯lisp可于CAD2000以下运行
2.主程序1K
3.处理了各种退化情况如:重合点共线点
4.效率很高,在我机上测试32800个取点&运算用时4.844s

2. 
   
3. ;;主程序
   
4. (defun minpolbox (ptlst            /              minbox:min          nextlist
   
5.                   ang0            ang2      ang_save        next          polbox
   
6.                   pt            startpt
   
7.                  )
   
8.   (defun minbox:min (ptlst)
   
9.     (apply 'mapcar (cons 'min ptlst))
   
10.   )
    
11.   (defun nextlist (ang0 ang2 pt ptlst / ang minang newlst)
    
12.     (foreach p ptlst
    
13.       (setq ang (angle pt p))
    
14.       (if (and (>= ang ang0) (< ang ang2))
    
15.         (setq newlst (cons (cons ang p) newlst))
    
16.       )
    
17.     )
    
18.     (setq minang (apply 'min (mapcar 'car newlst)))
    
19.     (list minang
    
20.           (cdr (assoc minang newlst))
    
21.           (mapcar 'cdr newlst)
    
22.     )
    
23.   )
    
24.   (setq pt (mapcar '- (minbox:min ptlst) '(0 1e-8 0)))
    
25.   (setq        next  (nextlist 0 7 pt ptlst)
    
26.         ang0  (car next)
    
27.         pt    (cadr next)
    
28.         ptlst (last next)
    
29.   )
    
30.   (setq        startpt        pt
    
31.         polbox        (list startpt)
    
32.   )
    
33.   (while ptlst
    
34.     (setq ang2 (angle pt startpt))
    
35.     (if        (= ang2 0)
    
36.       (setq ang2 7)
    
37.     )
    
38.     (setq next        (nextlist ang0 ang2 pt ptlst)
    
39.           ang0        (car next)
    
40.           pt        (cadr next)
    
41.           ptlst        (last next)
    
42.     )
    
43.     (setq polbox   (if (= ang0 ang_save)
    
44.                      (cons pt (cdr polbox))
    
45.                      (cons pt polbox)
    
46.                    )
    
47.           ang_save ang0
    
48.     )
    
49.   )
    
50.   (cdr polbox)
    
51. )
    
52. ;;测试程序
    
53. (defun c:tb (/ en i ptlst ss t0)
    
54.   (setq ss (ssget '((0 . "point"))))
    
55.   (setq t0 (getvar "TDUSRTIMER"))
    
56.   (setq i 0)
    
57.   (while (setq en (ssname ss i))
    
58.     (setq ptlst        (cons (cdr (assoc 10 (entget en)))
    
59.                       ptlst
    
60.                 )
    
61.     )
    
62.     (setq i (1+ i))
    
63.   )
    
64.   (setq ptlst (minpolbox ptlst))
    
65.   (entmake (append
    
66.              (list '(0 . "lwpolyline")
    
67.                    '(100 . "AcDbEntity")
    
68.                    '(100 . "AcDbPolyline")
    
69.                    (cons 90 (length ptlst))
    
70.                    '(70 . 1)
    
71.                    '(62 . 1)
    
72.              )
    
73.              (mapcar '(lambda (a) (cons 10 a)) ptlst)
    
74.            )
    
75.   )
    
76.   (princ "\nminpolbox共用时")
    
77.   (princ (* (- (getvar "TDUSRTIMER") t0) 86400))
    
78.   (princ "s")
    
79.   (princ)
    
80. )
    

<br /> ;;主程序<br /> (defun minpolbox (ptlst            /              minbox:min          nextlist<br />                   ang0            ang2      ang_save        next          polbox<br />                   pt            startpt<br />                  )<br />   (defun minbox:min (ptlst)<br />     (apply 'mapcar (cons 'min ptlst))<br />   )<br />   (defun nextlist (ang0 ang2 pt ptlst / ang minang newlst)<br />     (foreach p ptlst<br />       (setq ang (angle pt p))<br />       (if (and (>= ang ang0) (< ang ang2))<br />         (setq newlst (cons (cons ang p) newlst))<br />       )<br />     )<br />     (setq minang (apply 'min (mapcar 'car newlst)))<br />     (list minang<br />           (cdr (assoc minang newlst))<br />           (mapcar 'cdr newlst)<br />     )<br />   )<br />   (setq pt (mapcar '- (minbox:min ptlst) '(0 1e-8 0)))<br />   (setq        next  (nextlist 0 7 pt ptlst)<br />         ang0  (car next)<br />         pt    (cadr next)<br />         ptlst (last next)<br />   )<br />   (setq        startpt        pt<br />         polbox        (list startpt)<br />   )<br />   (while ptlst<br />     (setq ang2 (angle pt startpt))<br />     (if        (= ang2 0)<br />       (setq ang2 7)<br />     )<br />     (setq next        (nextlist ang0 ang2 pt ptlst)<br />           ang0        (car next)<br />           pt        (cadr next)<br />           ptlst        (last next)<br />     )<br />     (setq polbox   (if (= ang0 ang_save)<br />                      (cons pt (cdr polbox))<br />                      (cons pt polbox)<br />                    )<br />           ang_save ang0<br />     )<br />   )<br />   (cdr polbox)<br /> )<br /> ;;测试程序<br /> (defun c:tb (/ en i ptlst ss t0)<br />   (setq ss (ssget '((0 . "point"))))<br />   (setq t0 (getvar "TDUSRTIMER"))<br />   (setq i 0)<br />   (while (setq en (ssname ss i))<br />     (setq ptlst        (cons (cdr (assoc 10 (entget en)))<br />                       ptlst<br />                 )<br />     )<br />     (setq i (1+ i))<br />   )<br />   (setq ptlst (minpolbox ptlst))<br />   (entmake (append<br />              (list '(0 . "lwpolyline")<br />                    '(100 . "AcDbEntity")<br />                    '(100 . "AcDbPolyline")<br />                    (cons 90 (length ptlst))<br />                    '(70 . 1)<br />                    '(62 . 1)<br />              )<br />              (mapcar '(lambda (a) (cons 10 a)) ptlst)<br />            )<br />   )<br />   (princ "\nminpolbox共用时")<br />   (princ (* (- (getvar "TDUSRTIMER") t0) 86400))<br />   (princ "s")<br />   (princ)<br /> )<br />

highflybird

多谢fsxm的回复，
经验证，果然比我的快多了，一般在10倍左右。佩服！
我的代码还未完全优化，待仔细优化看看。

但我发现了一个fsxm的瑕疵，见下图，我构造出来的凸包是正确的
而fsxm稍微有一处不同，不知道是什么缘故。（同样的取点函数，同样的画线函数，除了求凸包函数不同外，其他地方完全相同）。

eachy

当点数大于一定数量上出现内存溢出错误，在7W 2 3 个点时正常

命令: tub
选择对象: 指定对角点: 找到 129024 个

选择对象:
; 错误: 出现异常: 0xC0000005 (访问冲突)
; 警告: 忽略展开 异常
; 错误: 出现异常: 0xC0000005 (访问冲突)

机器配置 WinXP + SP2  迅驰1.6G + 1G DDR333 内存 AutoCAD 2007 cn SP1

highflybird

抽空改写了这个程序。

版主所说：“当点数大于一定数量上出现内存溢出错误”是正确的，这种解决办法是再加一段分治算法进去，即可（代码叫容易实现，但我没加加进去）就是：把一个可能包含十万个以上的点按照100或者1000分段然后分别对每段求凸包，最后选择所有的凸包，再求凸包。也就是凸包集的凸包是点集的并集的凸包。（有点拗口）
重新改进代码段，使之更简短，更有效，比以前的速度快了不少。
比之fsxm的还是慢些，大概我用的时间比他多5、6倍.但是我的速度跟规模是成线性的，跟fsxm的亦是如此，可见此算法是一个跟n成线性的算法，不是平方级以上的。对此算法而言，时间主要取决于凸包的复杂度，时间不超过O(n.h),也就是说：凸包的边界点所占点集比例越大，时间越多。很可能出现这样一种情况，一个点集虽然比另外一个点集中的点多，但如果这个点集的凸包边界更简单的话，时间反而会少。
以此综述，这种算法不适宜于大量点位于凸包边界上的点集，但对于凸包边界简单的大量点集有效。
[php]
;;;************************************************************************
;;;一个求点集合的凸包的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)
)

[/php]
对此算法基本可以告一段落了，欢迎大家多提建议。
不知道为什么有些代码显示不出来，故贴上LISP附件

ywqq

高手,
谢谢代码
我看能不能看懂

lixiangdfeng

凸包到底是什么？

xinr111

强人,要我画个凸包还没问题,这样就是高手了哦.

maiqi816

好东东呀 非常喜欢