凸包的LISP实现

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

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

;;;************************************************************************
;;;一个求点集合的凸包的lisp程序--------------------------------------------
;;;采用的算法为Graham扫描法,具体方法见注释---------------------------------
;;;参考文献&lt;&lt;计算几何-算法及其应用&gt;&gt;(第二版),以及参考了其他网站的一些源代码
;;;用法: 加载运行程序后，选取点，直线段，或多义线(全是直线段组成)即可。----
;;;************************************************************************
(defun C:test1 (/ fil sel t0 ptlist pp 2Pi)
  (setq fil '((0 . "POINT,LINE,POLYLINE,LWPOLYLINE")))
  (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 "点的有效数目太小，请重新输入!")
    (MAKE-POLY PP)
  )
  (gc)
  (princ)
)
;;;==========================
;;;程序主段，可以单独成为函数
;;;==========================
(defun Graham-scan (ptlist / hullpt maxXpt sortPt P Q)
  (if (&lt; (length ptlist) 3)             ;3点以下
    ptlist                              ;是本集合
    (progn
      (setq maxXpt (assoc (apply 'max (mapcar 'car ptlist)) ptlist))    ;最右边的点
      (setq sortPt (sort-by-angle-distance ptlist maxXpt))              ;分类点集
      (setq hullPt (list (cadr sortPt) maxXpt))                         ;开始的两点      
      (foreach n (cddr sortPt)                                          ;从第3点开始
        (setq hullPt (cons n HullPt))                                   ;把Pi加入到凸集
        (setq P (cadr hullPt))                                          ;Pi-1
        (setq Q (caddr hullPt))                                         ;Pi-2
        (while (and q (&gt; (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点
        )
      )
      (reverse 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 (= ang1 ang2)
                 (&lt; (distance pt e1) (distance pt e2))
                 (&lt; ang1 ang2)
               )
             )
           )
  )
)
(defun sort-by-angle (ptlist pt / Ang1 Ang2)
  (vl-sort ptlist
           (function
             (lambda (e1 e2) (&lt; (angle pt e1) (angle pt e2)))
           )
  )
)
(defun sort-XY (ptlist)
  (vl-sort ptlist
           (function
             (lambda (e1 e2)
               (if (equal (cadr e1) (cadr e2) 1e-8)
                 (&gt; (car e1) (car e2))
                 (&lt; (cadr e1) (cadr e2))
               )
             )
           )
  )
)
;;定义三点的行列式,即三点之倍面积
(defun det (p1 p2 p3 / x2 y2)
  (setq x2 (car p2)
        y2 (cadr p2)
  )
  (- (* (- x2 (car p3)) (- y2 (cadr p1)))
     (* (- x2 (car p1)) (- y2 (cadr p3)))
  )
)
;;;============
;;;程序主段结束
;;;============

;;;取点函数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 make-poly (pp / X)
  (entmake                              ;画凸包
    (append
      '((0 . "LWPOLYLINE")
        (100 . "AcDbEntity")
        (100 . "AcDbPolyline")
       )
      (list (cons 90 (length pp)))      ;顶点个数
      (mapcar
        (function (lambda (x) (cons 10 x)))
        pp
      )                                 ;多段线顶点
      (list (cons 70 1))                ;闭合的
      (list (cons 62 1))                ;红色的
    )
  )
)
;;取得多边形顶点
(defun get-LWpolyline-vertexs (entlst / n lst)
  (foreach n entlst
    (if (= (car n) 10)
      (setq lst (cons (cdr n) lst))
    )
  )
  (reverse lst)
)

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

;;;************************************************************************

;;;一个求点集合的凸包的lisp程序--------------------------------------------

;;;采用的算法为Graham扫描法,具体方法见注释---------------------------------

;;;参考文献<<计算几何-算法及其应用>>(第二版),以及参考了其他网站的一些源代码

;;;用法: 加载运行程序后，选取点，直线段，或多义线(全是直线段组成)即可。----

;;;************************************************************************

(defun C:test1 (/ fil sel t0 ptlist pp 2Pi)

(setq fil '((0 . "POINT,LINE,POLYLINE,LWPOLYLINE")))

(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 "点的有效数目太小，请重新输入!")

(MAKE-POLY PP)

)

(gc)

(princ)

)

;;;==========================

;;;程序主段，可以单独成为函数

;;;==========================

(defun Graham-scan (ptlist / hullpt maxXpt sortPt P Q)

(if (< (length ptlist) 3) ;3点以下

ptlist ;是本集合

(progn

(setq maxXpt (assoc (apply 'max (mapcar 'car ptlist)) ptlist)) ;最右边的点

(setq sortPt (sort-by-angle-distance ptlist maxXpt)) ;分类点集

(setq hullPt (list (cadr sortPt) maxXpt)) ;开始的两点

(foreach n (cddr sortPt) ;从第3点开始

(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点

)

(reverse 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 (= ang1 ang2)

(< (distance pt e1) (distance pt e2))

(< ang1 ang2)

)

(defun sort-by-angle (ptlist pt / Ang1 Ang2)

(vl-sort ptlist

(function

(lambda (e1 e2) (< (angle pt e1) (angle pt e2)))

)

(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 / x2 y2)

(setq x2 (car p2)

y2 (cadr p2)

)

(- (* (- x2 (car p3)) (- y2 (cadr p1)))

(* (- x2 (car p1)) (- y2 (cadr p3)))

)

;;;============

;;;程序主段结束

;;;============

;;;取点函数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 make-poly (pp / X)

(entmake ;画凸包

(append

'((0 . "LWPOLYLINE")

(100 . "AcDbEntity")

(100 . "AcDbPolyline")

)

(list (cons 90 (length pp))) ;顶点个数

(mapcar

(function (lambda (x) (cons 10 x)))

) ;多段线顶点

(list (cons 70 1)) ;闭合的

(list (cons 62 1)) ;红色的

)

;;取得多边形顶点

(defun get-LWpolyline-vertexs (entlst / n lst)

(foreach n entlst

(if (= (car n) 10)

(setq lst (cons (cdr n) lst))

)

(reverse lst)

)

高飞鸟的天空

有一次，我们梦见大家都是不相识的。我们醒了，却知道我们原是相亲爱的。

凸包的LISP实现

Leave a comment 取消回复