凸包的LISP实现

关于凸包的维基解释:在一个实数向量空间V中,对于给定集合X,所有包含X的凸集的交集S被称为X的凸包。

凸包有很多用途,网上流传着很多其他语言的代码,LISP的却很少,下面是我的LISP实现代码:

  1. ;;;************************************************************************
  2. ;;;一个求点集合的凸包的lisp程序--------------------------------------------
  3. ;;;采用的算法为Graham扫描法,具体方法见注释---------------------------------
  4. ;;;参考文献<<计算几何-算法及其应用>>(第二版),以及参考了其他网站的一些源代码
  5. ;;;用法: 加载运行程序后,选取点,直线段,或多义线(全是直线段组成)即可。----
  6. ;;;************************************************************************
  7. (defun C:test1 (/ fil sel t0 ptlist pp 2Pi)
  8.   (setq fil '((0 . "POINT,LINE,POLYLINE,LWPOLYLINE")))
  9.   (setq sel (ssget fil))                ;选择点集
  10.   (setq ptlist (getpt sel))             ;构造点集
  11.   (setq t0 (getvar "TDUSRTIMER"))       ;开始计时
  12.   (setq pp (Graham-scan ptlist))        ;求凸包
  13.   (princ "n用时")
  14.   (princ (* (- (getvar "TDUSRTIMER") t0) 86400)) ;结束计时
  15.   (princ "秒")
  16.   (if (null pp)
  17.     (alert "点的有效数目太小,请重新输入!")
  18.     (MAKE-POLY PP)
  19.   )
  20.   (gc)
  21.   (princ)
  22. )
  23. ;;;==========================
  24. ;;;程序主段,可以单独成为函数
  25. ;;;==========================
  26. (defun Graham-scan (ptlist / hullpt maxXpt sortPt P Q)
  27.   (if (< (length ptlist) 3)             ;3点以下
  28.     ptlist                              ;是本集合
  29.     (progn
  30.       (setq maxXpt (assoc (apply 'max (mapcar 'car ptlist)) ptlist))    ;最右边的点
  31.       (setq sortPt (sort-by-angle-distance ptlist maxXpt))              ;分类点集
  32.       (setq hullPt (list (cadr sortPt) maxXpt))                         ;开始的两点      
  33.       (foreach n (cddr sortPt)                                          ;从第3点开始
  34.         (setq hullPt (cons n HullPt))                                   ;把Pi加入到凸集
  35.         (setq P (cadr hullPt))                                          ;Pi-1
  36.         (setq Q (caddr hullPt))                                         ;Pi-2
  37.         (while (and q (> (det n P Q) -1e-6))                            ;如果左转
  38.           (setq hullPt (cons n (cddr hullPt)))                          ;删除Pi-1点
  39.           (setq P (cadr hullPt))                                        ;得到新的Pi-1点
  40.           (setq Q (caddr hullPt))                                       ;得到新的Pi-2点
  41.         )
  42.       )
  43.       (reverse hullpt)                                                  ;返回凸集
  44.     )
  45.   )
  46. )
  47. ;;;以最下面的点为基点,按照角度和距离分类点集
  48. (defun sort-by-angle-distance (ptlist pt / Ang1 Ang2)
  49.   (vl-sort ptlist
  50.            (function
  51.              (lambda (e1 e2)
  52.                (setq ang1 (angle pt e1))
  53.                (setq ang2 (angle pt e2))
  54.                (if (= ang1 ang2)
  55.                  (< (distance pt e1) (distance pt e2))
  56.                  (< ang1 ang2)
  57.                )
  58.              )
  59.            )
  60.   )
  61. )
  62. (defun sort-by-angle (ptlist pt / Ang1 Ang2)
  63.   (vl-sort ptlist
  64.            (function
  65.              (lambda (e1 e2) (< (angle pt e1) (angle pt e2)))
  66.            )
  67.   )
  68. )
  69. (defun sort-XY (ptlist)
  70.   (vl-sort ptlist
  71.            (function
  72.              (lambda (e1 e2)
  73.                (if (equal (cadr e1) (cadr e2) 1e-8)
  74.                  (> (car e1) (car e2))
  75.                  (< (cadr e1) (cadr e2))
  76.                )
  77.              )
  78.            )
  79.   )
  80. )
  81. ;;定义三点的行列式,即三点之倍面积
  82. (defun det (p1 p2 p3 / x2 y2)
  83.   (setq x2 (car p2)
  84.         y2 (cadr p2)
  85.   )
  86.   (- (* (- x2 (car p3)) (- y2 (cadr p1)))
  87.      (* (- x2 (car p1)) (- y2 (cadr p3)))
  88.   )
  89. )
  90. ;;;============
  91. ;;;程序主段结束
  92. ;;;============
  93.  
  94. ;;;取点函数1
  95. (defun getpt1 (ss / i listpp a b c d)
  96.   (setq i 0)
  97.   (if ss
  98.     (repeat (sslength ss)
  99.       (setq a (ssname ss i))
  100.       (setq b (entget a))
  101.       (setq c (cdr (assoc 10 b)))
  102.       (setq c (list (car c) (cadr c)))
  103.       (setq listpp (cons c listpp))
  104.       (setq i (1+ i))
  105.     )
  106.   )
  107.   listpp
  108. )
  109. ;;;取点函数2
  110. (defun getpt (ss / i listpp a b c d)
  111.   (setq i 0)
  112.   (if ss
  113.     (repeat (sslength ss)
  114.       (setq a (ssname ss i))
  115.       (setq b (entget a))
  116.       (setq ename (cdr (assoc 0 b)))
  117.       (cond
  118.         ((= ename "LWPOLYLINE")
  119.          (setq c (get-LWpolyline-vertexs b))
  120.          (setq listpp (append c listpp))
  121.         )
  122.         ((= ename "LINE")
  123.          (setq c (cdr (assoc 10 b)))
  124.          (setq d (cdr (assoc 11 b)))
  125.          (setq c (list (car c) (cadr c)))
  126.          (setq d (list (car d) (cadr d)))
  127.          (setq listpp (cons c listpp))
  128.          (setq listpp (cons d listpp))
  129.         )
  130.         ((= ename "POINT")
  131.          (setq c (cdr (assoc 10 b)))
  132.          (setq c (list (car c) (cadr c)))
  133.          (setq listpp (cons c listpp))
  134.         )
  135.       )
  136.       (setq i (1+ i))
  137.     )
  138.   )
  139.   listpp
  140. )
  141. (DEFUN make-poly (pp / X)
  142.   (entmake                              ;画凸包
  143.     (append
  144.       '((0 . "LWPOLYLINE")
  145.         (100 . "AcDbEntity")
  146.         (100 . "AcDbPolyline")
  147.        )
  148.       (list (cons 90 (length pp)))      ;顶点个数
  149.       (mapcar
  150.         (function (lambda (x) (cons 10 x)))
  151.         pp
  152.       )                                 ;多段线顶点
  153.       (list (cons 70 1))                ;闭合的
  154.       (list (cons 62 1))                ;红色的
  155.     )
  156.   )
  157. )
  158. ;;取得多边形顶点
  159. (defun get-LWpolyline-vertexs (entlst / n lst)
  160.   (foreach n entlst
  161.     (if (= (car n) 10)
  162.       (setq lst (cons (cdr n) lst))
  163.     )
  164.   )
  165.   (reverse lst)
  166. )

发表回复

您的电子邮箱地址不会被公开。 必填项已用*标注