递归法凸包改进.lsp

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

;;;====================================
;;;程序的主段                          
;;;一个用递归法求凸包的程序            
;;;严格地说这是一个QuickHull的方法     
;;;All Copyrights Reserved             
;;;highflbird         2006-2007 Kunming
;;;====================================

(vl-load-com)

;;点集合排序函数
(defun XYsort (ptlist)
  (vl-sort ptlist
    (function
      (lambda (e1 e2)
	(if (equal (car e1) (car e2) 1e-8)
	  (< (cadr e1) (cadr e2))
	  (< (car  e1) (car  e2))
	)
      )
    )
  )
)
;;;分包函数
(defun divide (ptlist / p1 p2 ptlst1 ptlst2)
  (setq p1 (car ptlist))                                    ;最左端点
  (setq p2 (last ptlist))                                   ;最右端点
  (foreach n ptlist
    (if (> (- (angle p2 p1) (angle p2 n)) 0)                ;如果比P2P1的角度小
      (setq ptlst1 (cons n ptlst1))                         ;是P1P2上的点集
      (setq ptlst2 (cons n ptlst2))                         ;是P1P2下的点集
    ) 
  )	 	   
  (setq ptlst1 (cons p1 (reverse ptlst1)))                  
  (setq ptlst2 (cons p2 ptlst2))
  (list ptlst1 ptlst2)                                      ;把点集分成上下部分
)
;;;上半部分的凸包
(defun Hull1 (ptlist / l p1 p2 p3 ppp pp1 pp2)
  (setq l (length ptlist))
  (if (<= l 3)
    ptlist
    (progn
      (setq p1 (car ptlist))		                    ;左端点
      (setq p2 (last ptlist))		                    ;右端点
      (setq ppp (mapcar (function (lambda (x) (det x p1 p2))) ptlist))
      (setq p3 (nth (- (length ppp) (length (member (apply 'max ppp) ppp))) ptlist))
                                                            ;最大面积点
      (foreach n ptlist
	(cond
	  ( (and (judge p1 p3 n) (judge p3 n p2))
	    (setq pp1 (cons n pp1))
	  )
          ( (and (judge p1 n p3) (judge n p3 p2))
	    (setq pp2 (cons n pp2))                        
	  )
	)
      )
      (setq pp1	(append (cons p1 (reverse pp1)) (list p3))) ;左边
      (setq pp2	(append (cons p3 (reverse pp2)) (list p2))) ;左边
      (setq pp1	(hull1 pp1))                                ;递归左边(recursion)
      (setq pp2	(hull1 pp2))                                ;递归右边(recursion)
      (append pp1 (vl-remove p3 pp2))
    )
  )
)
;;;合并凸包
(defun hull (pts / ptlist ptlst1 ptlst2 uppers lowers hullpt)
  (if (< (length pts) 4)
    pts
    (setq ptlist (XYsort pts)                               ;排序
          ptlist (divide ptlist)                            ;分包
          ptlst1 (car  ptlist)                              ;上面的点集合
          ptlst2 (cadr ptlist)                              ;下面的点集合
          uppers (cdr (hull1 ptlst1))                       ;上凸包
          lowers (cdr (hull1 ptlst2))                       ;下凸包
          hullpt (reverse (append uppers lowers))           ;合并凸包
    )
  )
)
;;;====================================
;;;主段结束                            
;;;====================================
(defun C:test (/ sl ss t0 pp)
  (setq fil '((0 . "POINT")))
  (setq sel (ssget fil))
  (setq ptlist (getpt sel))                                 ;构造点集
  (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 x)) pp)               ;多段线顶点
	(list (cons 70 1))                                  ;闭合的
	(list (cons 62 1))                                  ;红色的
      )
    )
  )
  (gc)
  (princ)
)
;;取点函数
(defun getpt (ss / i listpp a b c) 
  (setq i 0 listpp nil ) 
  (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))  
    ) 
  ) 
  (reverse listpp)
)
;;定义三点的行列式,即三点之倍面积
(defun det (p1 p2 p3 / dx1 dy1 dx2 dy2)
  (setq	dx1 (- (car  p2) (car  p1))
	dy1 (- (cadr p2) (cadr p1))
	dx2 (- (car  p3) (car  p1))
	dy2 (- (cadr p3) (cadr p1))
  )
  (- (* dx1 dy2) (* dx2 dy1))
)
;;定义判别法则
(defun judge (p1 p2 p3)
  (> (det p1 p2 p3) 0)
)