扫描法凸包.lsp

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

;;;************************************************************************
;;;一个求点集合的凸包的lisp程序--------------------------------------------
;;;采用的算法为Graham扫描法,具体方法见注释---------------------------------
;;;参考文献<<计算几何-算法及其应用>>(第二版),以及参考了其他网站的一些源代码
;;;用法: 加载运行程序后，选取点，直线段，或多义线(全是直线段组成)即可。----
;;;************************************************************************
(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))                                     ;构造点集
  (setq t0 (getvar "TDUSRTIMER"))                               ;开始计时
  (setq pp (Graham-scan 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 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))                    ;如果左转
          (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))
)
;;;============
;;;程序主段结束
;;;============

;;;取点函数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
)
;;;取点函数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
)