;;;************************************************************************
;;;一個求點集合的凸包的lisp程序--------------------------------------------
;;;------采用的算法為禮品包扎法--------------------------------------------
;;;方法為最右端的點開始處理，將該點作為凸包邊界的第一個點P1，從最初的垂直線
;;;方向繞P1順時針旋轉，直到碰到另一個P2這就是凸包邊界的第二個點P2，依此類推
;;;p2求得p3......直到又重新回到p1，已經考慮了各種退化情況和浮點運算，其算法
;;;時間不超過O(n.h),其中h是凸包的復雜度，時間還是很快的。大家不妨驗證。    
;;;參考文獻<<計算幾何-算法及其應用>>(第二版),以及參考了其他網站的一些源代碼
;;;------------------------------------------------------------------------
;;;其中程序主段是核心算法，其他的附加程序為取得點集，畫凸包邊界線，測試大量
;;;點集函數處理所花費的時間。----------------------------------------------
;;;用法: 加載lisp運行test選取點，直線段，或多義線(全是直線段組成)即可。----
;;;************************************************************************
(defun C:test (/ olderr en errmsg oldmode oce sl ss t0 ptlist pp)
  (setq oldmode (getvar "osmode"))
  (setq oce (getvar "cmdecho"))
  (setvar "cmdecho" 0)
  (command ".ucs" "W")
  ;;也可以用其他方式取得點集----------------
  ;;取點，畫線，并對函數用時計算------------
  (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 (= 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 hull1 (ptlist MaxXpt MinXpt / nextPt hullPt)
  (if ptlist 
    (progn
      (setq nextPt (Max-angle ptlist MaxXpt))
      (setq hullPt (cons nextPt (cons MaxXpt hullPt)))
      (while (not (equal nextPt MinXpt 1e-8))
        (setq nextPt (Max-angle ptlist nextPt))
	(setq hullPt (cons nextPt hullPt))
      )
    )
  )
  hullPt
)
(defun hull (ptlist / maxXp1 minXp1 maxYp2 minYp2 -ptlst hullp1 hullp2)
  (setq maxXp1 (assoc (apply 'max (mapcar 'car ptlist)) ptlist))
  (setq minXp1 (assoc (apply 'min (mapcar 'car ptlist)) ptlist))
  (setq maxYp2 (list (car maxXp1) (- (cadr maxXp1))))
  (setq minYp2 (list (car minXp1) (- (cadr minXp1))))
  (setq -ptlst (Mirror-list-Y ptlist))
  (setq hullp1 (hull1 ptlist maxXp1 minXp1))
  (setq hullp2 (hull1 -ptlst maxYp2 minYp2))
  (setq hullp2 (cdr (reverse (cdr hullp2))))
  (setq hullp2 (Mirror-list-Y hullp2))
  (append hullp1 hullp2)
)
(defun Mirror-list-Y (ptlist)
  (mapcar
    (function
      (lambda (x)
	(list
	  (car x)
	  (- (cadr x))
	)
      )
    )
    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
)
;;求點集中夾角的最大值的點
(defun Max-angle (ptlist pt / ppp)
  (setq ppp
    (mapcar
     '(lambda (x)
	(angle pt x)
      )
      ptlist
    )
  )
  (nth (- (length ppp) (length (member (apply 'max ppp) ppp))) ptlist)
)