;;;************************************************************************
;;;一個求點集合的凸包的lisp程序--------------------------------------------
;;;采用的算法為Graham掃描法,具體方法見注釋---------------------------------
;;;參考文獻<<計算幾何-算法及其應用>>(第二版),以及參考了其他網(wǎng)站的一些源代碼
;;;用法: 加載運行程序后，選取點，直線段，或多義線(全是直線段組成)即可。----
;;;************************************************************************
(defun C:test1 (/ fil sel t0 ptlist pp 2Pi)
  (setq	fil '( (-4 . "<OR")
	       (0 . "POINT")
	       (0 . "LINE")
	       (0 . "POLYLINE")
	       (0 . "LWPOLYLINE")
	       (-4 . "OR>")
	     )
  )
  (setq sel (ssget fil))                                        ;選擇點集
  (setq ptlist (getpt sel))                                     ;構(gòu)造點集
  (setq t0 (getvar "TDUSRTIMER"))                               ;開始計時
  (setq pp (Graham-scan ptlist))                                ;求凸包
  (princ "\n用時")  
  (princ (* (- (getvar "TDUSRTIMER") t0) 86400))                ;結(jié)束計時
  (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 Graham-scan (ptlist / hullpt revPts 2ndPts minYpt sortPt P Q)
  (if (< (length ptlist) 4)                                     ;3點以下
    ptlist                                                      ;是本集合
    (progn 
      (setq revPts (mapcar 'reverse ptlist))                    ;點表的X和Y交換
      (setq 2ndPts (mapcar 'cadr ptlist))                       ;點表的Y值的表
      (setq minYpt (reverse (assoc (apply 'min 2ndPts) revPts)));最下面的點
      ;;(setq minYpt (car (sort-XY ptlist)))
      (setq sortPt (sort-by-angle-distance ptlist minYpt))      ;分類點集
      (setq hullPt (list (caddr sortPt) (cadr sortPt) minYpt))  ;開始的三點
      (foreach n (cdddr sortPt)                                 ;從第4點開始
        (setq hullPt (cons n HullPt))                           ;把Pi加入到凸集
        (setq P      (cadr  hullPt))                            ;Pi-1
        (setq Q      (caddr hullPt))                            ;Pi-2
        (while (and q (> (det n P Q) -1e-6))                    ;如果左轉(zhuǎn)
          (setq hullPt (cons n (cddr hullPt)))                  ;刪除Pi-1點
          (setq P      (cadr  hullPt))                          ;得到新的Pi-1點
          (setq Q      (caddr hullPt))                          ;得到新的Pi-2點
        )
      )
      hullpt                                                    ;返回凸集
    )
  )
)
;;;以最下面的點為基點，按照角度和距離分類點集
(defun sort-by-angle-distance (ptlist pt / Ang1 Ang2)
  (vl-sort ptlist
    (function
      (lambda (e1 e2)
	(setq ang1 (angle pt e1))      
	(setq ang2 (angle pt e2))
	(if (equal ang1 ang2)
	  (< (distance pt e1) (distance pt e2))
	  (< ang1 ang2)
	)
      )
    )
  )	
)
(defun sort-XY (ptlist)
  (vl-sort ptlist
    (function
      (lambda (e1 e2)
	(if (equal (cadr e1) (cadr e2) 1e-8)
	  (> (car e1) (car e2))
	  (< (cadr e1) (cadr e2))
	)
      )
    )
  )
) 
;;定義三點的行列式,即三點之倍面積
(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))
)
;;;============
;;;程序主段結(jié)束
;;;============

;;;取點函數(shù)1
(defun getpt1 (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
)
;;;取點函數(shù)2
(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 ename (cdr (assoc 0 b)))
      (cond
	( (= ename "LWPOLYLINE")
	  (setq c (get-LWpolyline-vertexs b))
	  (setq listpp (append c listpp))
	)
	( (= ename "LINE")
	  (setq c (cdr (assoc 10 b)))
	  (setq d (cdr (assoc 11 b)))
	  (setq c (list (car c) (cadr c)))
	  (setq d (list (car d) (cadr d)))
	  (setq listpp (cons c listpp))
	  (setq listpp (cons d listpp))
	)
	( (= ename "POINT")
	  (setq c (cdr (assoc 10 b)))
	  (setq c (list (car c) (cadr c)))
	  (setq listpp (cons c listpp))
	)
      )
      (setq i (1+ i))
    )
  )
  listpp
)
;;取得多邊形頂點
(defun get-LWpolyline-vertexs (entlst / n lst)
  (foreach n entlst
    (if (= (car n) 10)
      (setq lst (cons (cdr n) lst))
    )
  )
  lst
)