;;;====================================
;;;程序的主段                          
;;;一個用遞歸法求凸包的程序            
;;;嚴格地說這是一個QuickHull的方法     
;;;All Copyrights Reserved             
;;;highflbird         2006-2007 Kunming
;;;====================================

(vl-load-com)

;;點集合排序函數(shù)
(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))
	)
      )
    )
  )
)
;;;分包函數(shù)
(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 "點的有效數(shù)目太小，請重新輸入!")
    (entmake                                                ;畫凸包
      (append
       '( (0 . "LWPOLYLINE")
	  (100 . "AcDbEntity")
	  (100 . "AcDbPolyline")
	)
	(list (cons 90 (length pp)))                        ;頂點個數(shù)
	(mapcar '(lambda (x) (cons 10 x)) pp)               ;多段線頂點
	(list (cons 70 1))                                  ;閉合的
	(list (cons 62 1))                                  ;紅色的
      )
    )
  )
  (gc)
  (princ)
)
;;取點函數(shù)
(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)
)