步进法凸包改进2.lsp

计算几何中的几种lisp语言的算法

;;;************************************************************************
;;;一个求点集合的凸包的lisp程序--------------------------------------------
;;;------采用的算法为礼品包扎法--------------------------------------------
;;;方法为最右端的点开始处理，将该点作为凸包边界的第一个点P1，从最初的垂直线
;;;方向绕P1顺时针旋转，直到碰到另一个P2这就是凸包边界的第二个点P2，依此类推
;;;p2求得p3......直到又重新回到p1，已经考虑了各种退化情况和浮点运算，其算法
;;;时间不超过O(n.h),其中h是凸包的复杂度，时间还是很快的。大家不妨验证。    
;;;参考文献<<计算几何-算法及其应用>>(第二版),以及参考了其他网站的一些源代码
;;;------------------------------------------------------------------------
;;;其中程序主段是核心算法，其他的附加程序为取得点集，画凸包边界线，测试大量
;;;点集函数处理所花费的时间。----------------------------------------------
;;;用法: 加载lisp运行test选取点，直线段，或多义线(全是直线段组成)即可。----
;;;************************************************************************
(defun C:test (/ ss t0 ptlist pp)
  (setq	ss (ssget (list '(0 . "POINT"))))
  (setq ptlist (getpt ss))                      ;取得点集
  (setq t0 (getvar "TDUSRTIMER"))               ;开始计时
  (setq pp (hull ptlist))                       ;求凸包
  (princ "\n用时")                                   
  (princ (* (- (getvar "TDUSRTIMER") t0) 86400));结束计时
  (princ "秒")
  (if (null pp)
    (alert "点的有效数目太小，请重新输入!")
    (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))
      )
    )
  )
  (princ)
)
;;;==========================
;;;程序主段，可以单独成为函数
;;;==========================

;;;右半部的凸包
(defun hull1 (pts MaxPt MinPt / nextPt hullPt)
  (if pts 
    (progn
      (setq nextPt (Max-angle pts MaxPt))                   ;从最上面的点开始
      (setq hullPt (cons nextPt (cons MaxPt hullPt)))       ;顺时针求得第一点
      (while (not (equal nextPt MinPt 1e-8))                ;到最下面的点为止
        (setq nextPt (Max-angle pts nextPt))                ;循环求凸包每一点
	(setq hullPt (cons nextPt hullPt))                  ;把每点加入凸包集
      )
    )
  )
)
;;;左半部的凸包
(defun hull (ptlist /
	     revPts 2ndPts maxXp1 minXp1 maxXp2 minXp2 -ptlst hullp1 hullp2)
  (setq revPts (mapcar 'reverse ptlist))                    ;点表的X和Y交换
  (setq 2ndPts (mapcar 'cadr ptlist))                       ;点表的Y值的表
  (setq maxXp1 (reverse (assoc (apply 'max 2ndPts) revPts)));最上面的点
  (setq minXp1 (reverse (assoc (apply 'min 2ndPts) revPts)));最下面的点
  (setq maxXp2 (list (- (car maxXp1)) (cadr maxXp1)))       ;镜像后最上面的点
  (setq minXp2 (list (- (car minXp1)) (cadr minXp1)))       ;镜像后最下面的点
  (setq -ptlst (Mirror-list-X ptlist))                      ;左半部分以Y轴镜像
  (setq hullp1 (hull1 ptlist maxXp1 minXp1))                ;右半部分的凸包
  (setq hullp2 (hull1 -ptlst maxXp2 minXp2))                ;镜像左半部分的凸包
  (setq hullp2 (cdr (reverse (cdr hullp2))))                
  (setq hullp2 (Mirror-list-X hullp2))                      ;左半部分的凸包
  (append hullp1 hullp2)                                    ;左右相加的凸包
)
;;;镜像左半部分
(defun Mirror-list-X (ptlist)
  (mapcar  (function (lambda (x) (list (- (car x)) (cadr x)))) ptlist)
)
;;;求点集中夹角的最大值的点
(defun Max-angle (ptlist pt / An)
  (setq An (mapcar (function (lambda (x) (angle pt x))) ptlist))
  (nth (- (length An) (length (member (apply 'max An) An))) ptlist)
)
;;;============
;;;程序主段结束
;;;============

;;;依据晓东网站的代码改写而成的取点函数
(defun getpt (ss / i listpp a b c d)
  (setq	i 0)
  (if ss
    (repeat (sslength ss)
      (setq a (ssname ss i))
      (setq b (entget a))
      (setq c (cdr (assoc 10 b)))
      (setq c (list (car c) (cadr c)))
      (setq listpp (cons c listpp))
      (setq i (1+ i))
    )
  )
  listpp
)