点集凸包的autolisp实现（几何方法）

freedom_ice · 发表于 2022-10-30 16:45:35

本帖最后由 freedom_ice 于 2022-10-30 17:22 编辑

问题：给定一系列二维点集，求包围所有点的最小凸多边形。

思路：1.将二维点集按X升序排列，当X值相等时，按Y值升序；
      2.沿着排序后的左下点P0（第一点）和右上点P1（最末点），作分界线line0，将点集分为上部和下部，上部的边界线为上包，下部的边界线为下包；
      3.递归方法求上包。上包的下边线line0，找到上包点集中距离line0最远的点Pmax，得到两条分界线，点P0和Pmax组成line1，点Pmax和P1组成line2，同样方法求line1的上包和line2的上包，两者合并即为line0的上包，递归出口为点集中只有两个点时，即为要求的点，输出即可。
      4.同样方法求下包，上包结果与下包合并即为所求凸包。
      5.输出结果为一段一段的线段，所以会有重复的点，未经去重处理；
      6.供探讨学习，未经完全验证，可能会有不可知的问题。比如对处于凸包边缘上的点未经特殊处理。

( defun c:tt()
( setq pts '( ( 5 4 ) ( 0 0 ) ( 1 1 ) ( 2 2 ) ( 2 3 ) ( 3 1 ) ( 3 0 ) ( 5 1 )) )
( setq pts '( ( 3 0 ) ( 4 1 ) ( 5 4 ) ( 2 2 ) ( 1 2 ) ( 3 4 ) ( 4 2 ) ( 3 2 ) ( 4 3 ) ) )
;( setq pts '( ( 1 1 ) ( 2 1 ) ( 3 2 ) ( 4 4 ) ) )
;( setq pts '( ( 5 4 ) ( 2 2 ) ) )
;( setq pts '( ( 1 1 ) ( 2 4 ) ( 3 4 ) ( 3 5 ) ( 4 4 ) ( 4.5 4.5 ) ( 4 5 ) ( 5 4 ) ( 6 4 ) ( 7 7 ) ) )
;( setq a ( IncreaseXY a ) )
;( setq line '( ( 2 2 ) ( 0 0 ) ) )
;( setq pt '( 1.5 1 ) )
;( princ ( IsPtOnLine pt line ) )
;( UpBoundingPts pts )
;( princ ( UpBoundingPts pts ) )
;( princ "\n" )
;( princ ( DownBoundingPts pts ) )
( princ ( BoundingPts pts ) )
( princ )
)
;;;*****************************************************************************
;;;*****************************************************************************
;;;函数名 : BoundingPts ***************************************************
;;;功能 : 获取点集的凸包 ****************************************************
;;;参数 : pts - 要判断的点集 ************************************************
;;;返回值 : 凸包点集 **********************************************************
( defun BoundingPts ( pts / downpts j len linepts uppts )
( setq pts ( IncreaseXY pts ) )
( setq len ( length pts ) )
( if ( < len 4 )
pts
( progn
( setq linepts ( list ( car pts ) ( last pts ) ) )
( setq uppts linepts )
( setq downpts linepts )
( setq j 1 )
( repeat ( - len 2 )
( if ( = ( IsPtOnLine ( nth j pts ) linepts ) 1 )
( setq uppts ( cons ( nth j pts ) uppts ) )
)
( if ( = ( IsPtOnLine ( nth j pts ) linepts ) -1 )
( setq downpts ( cons ( nth j pts ) downpts ) )
)
( setq j ( 1+ j ) )
)
( append ( UpBoundingPts uppts ) ( DownBoundingPts downpts ) )
)
)
)
;;;*****************************************************************************
;;;*****************************************************************************
;;;*****************************************************************************
;;;*****************************************************************************
;;;*****************************************************************************
;;;函数名 : DownBoundingPts ***************************************************
;;;功能 : 获取点集的下包 ****************************************************
;;;参数 : pts - 要判断的点集 ************************************************
;;;返回值 : 下包点集 **********************************************************
( defun DownBoundingPts( pts / dis i j leftdownpts leftlinepts len linepts rightdownpts rightlinepts targetpt )
( setq pts ( IncreaseXY pts ) )
( setq len ( length pts ) )
( cond ( ( = len 2 ) ( append pts ) )
( ( > len 2 ) ( progn
( setq linepts ( list ( car pts ) ( last pts ) ) )
( setq leftdownpts nil )
( setq rightdownpts nil )
( setq dis 0 )
( setq i 1 )
( repeat ( - len 2 )
( if ( and ( > ( PtDisToLine ( nth i pts ) linepts ) dis )
( = ( IsPtOnLine ( nth i pts ) linepts ) -1 )
)
( setq dis ( PtDisToLine ( nth i pts ) linepts )
targetpt ( nth i pts )
)
)
( setq i ( 1+ i ) )
)
( if ( /= targetpt nil )
( progn
( setq leftlinepts ( list ( car pts ) targetpt ) )
( setq rightlinepts ( list targetpt ( last pts ) ) )
( setq leftdownpts leftlinepts )
( setq rightdownpts rightlinepts )
( setq j 1 )
( repeat ( - len 2 )
( if ( = ( IsPtOnLine ( nth j pts ) leftlinepts ) -1 )
( setq leftdownpts ( cons ( nth j pts ) leftdownpts ) )
)
( if ( = ( IsPtOnLine ( nth j pts ) rightlinepts ) -1 )
( setq rightdownpts ( cons ( nth j pts ) rightdownpts ) )
)
( setq j ( 1+ j ) )
)
( append ( DownBoundingPts leftdownpts )
( DownBoundingPts rightdownpts )
)
)
( append ( DownBoundingPts linepts ) )
)
)
)
)
)
;;;*****************************************************************************
;;;*****************************************************************************
;;;*****************************************************************************
;;;*****************************************************************************
;;;*****************************************************************************
;;;函数名 : UpBoundingPts *****************************************************
;;;功能 : 获取点集的上包 ****************************************************
;;;参数 : pts - 要判断的点集 ************************************************
;;;参数 : linepts - 直线上的两点 ********************************************
;;;返回值 : 上包点集 **********************************************************
( defun UpBoundingPts( pts / a b c dis i j leftlinepts leftuppts len linepts output rightlinepts rightuppts target targetpt )
( setq pts ( IncreaseXY pts ) )
( setq len ( length pts ) )
( cond ( ( = len 2 ) ( append pts ) )
( ( > len 2 ) ( progn
( setq linepts ( list ( car pts ) ( last pts ) ) )
( setq leftuppts nil )
( setq rightuppts nil )
( setq dis 0 )
( setq i 1 )
( repeat ( - len 2 )
( if ( and ( > ( PtDisToLine ( nth i pts ) linepts ) dis )
( = ( IsPtOnLine ( nth i pts ) linepts ) 1 )
)
( setq dis ( PtDisToLine ( nth i pts ) linepts )
targetpt ( nth i pts )
)
)
( setq i ( 1+ i ) )
)
( if ( /= targetpt nil )
( progn
( setq leftlinepts ( list ( car pts ) targetpt ) )
( setq rightlinepts ( list targetpt ( last pts ) ) )
( setq leftuppts leftlinepts )
( setq rightuppts rightlinepts )
( setq j 1 )
( repeat ( - len 2 )
( if ( = ( IsPtOnLine ( nth j pts ) leftlinepts ) 1 )
( setq leftuppts ( cons ( nth j pts ) leftuppts ) )
)
( if ( = ( IsPtOnLine ( nth j pts ) rightlinepts ) 1 )
( setq rightuppts ( cons ( nth j pts ) rightuppts ) )
)
( setq j ( 1+ j ) )
)
( append ( UpBoundingPts leftuppts )
( UpBoundingPts rightuppts )
)
)
( append ( UpBoundingPts linepts ) )
)
)
)
)
)
;;;*****************************************************************************
;;;*****************************************************************************
;;;*****************************************************************************
;;;*****************************************************************************
;;;*****************************************************************************
;;;函数名 : PtDisToLine *******************************************************
;;;功能 : 判断点到直线的距离 ************************************************
;;;参数 : pt - 要判断的点 ***************************************************
;;;参数 : linepts - 直线上的两点 ********************************************
;;;返回值 : 返回距离值 ********************************************************
( defun PtDisToLine( pt linepts / a b c output target )
;;linepts = ( ( x1 y1 ) ( x2 y2 ) )
;;x1 = ( caar linepts )
;;y1 = ( cadar linepts )
;;x2 = ( caadr linepts )
;;y2 = ( cadadr linepts )
( setq A ( - ( cadar linepts ) ( cadadr linepts ) ) )
( setq B ( - ( caadr linepts ) ( caar linepts ) ) )
( setq C ( - ( * ( caar linepts ) ( cadadr linepts ) ) ( * ( caadr linepts ) ( cadar linepts ) ) ) )
( setq target ( + ( * A ( car pt ) )
( * B ( cadr pt ) )
C ) )
( setq target ( abs target ) )
;;点到直线的距离
( setq output ( / target ( expt ( + ( expt A 2 ) ( expt B 2 ) ) 0.5 ) ) )
)
;;;*****************************************************************************
;;;*****************************************************************************
;;;*****************************************************************************
;;;*****************************************************************************
;;;*****************************************************************************
;;;函数名 : IsPtOnLine ********************************************************
;;;功能 : 判断点是否在直线上 ************************************************
;;;参数 : pt - 要判断的点 ***************************************************
;;;参数 : linepts - 直线上的两点 ********************************************
;;;返回值 : 点在直线上方返回1 ************************************************
;;;返回值 : 点在直线上返回0 **************************************************
;;;返回值 : 点在直线下方返回-1 ***********************************************
( defun IsPtOnLine( pt linepts / a b c target )
;;linepts = ( ( x1 y1 ) ( x2 y2 ) )
;;x1 = ( caar linepts )
;;y1 = ( cadar linepts )
;;x2 = ( caadr linepts )
;;y2 = ( cadadr linepts )
( setq A ( - ( cadar linepts ) ( cadadr linepts ) ) )
( setq B ( - ( caadr linepts ) ( caar linepts ) ) )
( setq C ( - ( * ( caar linepts ) ( cadadr linepts ) ) ( * ( caadr linepts ) ( cadar linepts ) ) ) )
( setq target ( + ( * A ( car pt ) )
( * B ( cadr pt ) )
C ) )
( if ( > target 0 )
1
( if ( = target 0 )
0
-1
)
)
)
;;;*****************************************************************************
;;;*****************************************************************************
;;;*****************************************************************************
;;;*****************************************************************************
;;;*****************************************************************************
;;;函数名 : IncreaseXY ********************************************************
;;;功能 : 点表按X升序排列，若X相等，则按Y坐标升序排列************************
;;;参数 : SourceList - 源数据表**********************************************
;;;返回值 : 排序后的数据表*****************************************************
( defun IncreaseXY( SourceList )
( setq SourceList ( vl-sort SourceList
( function ( lambda ( e1 e2 )
( if ( < ( car e1 ) ( car e2 ) )
( < ( car e1 ) ( car e2 ) )
( if ( = ( car e1 ) ( car e2 ) )
( <= ( cadr e1 ) ( cadr e2 ) )
)
)
)
)
)
)
)
;;;*****************************************************************************
;;;*****************************************************************************
;;;*****************************************************************************
( princ )

复制代码

xyp1964 · 发表于 2022-11-3 19:31:28

(defun tb (ptn / mode p0 p1 p2 tmp rr)
"点集逆时针凸包点"
(setq ptn (vl-sort ptn '(lambda (x y) (< (cadr x) (cadr y))))
p0 (car ptn)
ptn (vl-sort (cdr ptn)
'(lambda (x y) (< (angle p0 x) (angle p0 y)))
)
rr (angle p0 (car ptn))
tmp (list p0)
p1 p0
mode t
)
(while mode
(setq ptn (vl-remove-if '(lambda (x) (< (angle p1 x) rr)) ptn)
ptn (vl-sort ptn '(lambda (x y) (< (angle p1 x) (angle p1 y))))
p2 (car ptn)
rr (angle p1 p2)
ptn (vl-remove p2 ptn)
ptn (if (not (member p0 ptn))
(cons p0 ptn)
ptn
)
)
(if (not (equal p2 p0 1e-3))
(setq tmp (cons p2 tmp)
p1 p2
)
(setq mode nil)
)
)
(reverse tmp)
)

(defun tb (ptn / mode p0 p1 p2 tmp rr) 
  "点集逆时针凸包点" 
  (setq        ptn  (vl-sort ptn '(lambda (x y) (< (cadr x) (cadr y)))) 
        p0   (car ptn) 
        ptn  (vl-sort (cdr ptn) 
                      '(lambda (x y) (< (angle p0 x) (angle p0 y))) 
             ) 
        rr   (angle p0 (car ptn)) 
        tmp  (list p0) 
        p1   p0 
        mode t 
  ) 
  (while mode 
    (setq ptn (vl-remove-if '(lambda (x) (< (angle p1 x) rr)) ptn) 
          ptn (vl-sort ptn '(lambda (x y) (< (angle p1 x) (angle p1 y)))) 
          p2  (car ptn) 
          rr  (angle p1 p2) 
          ptn (vl-remove p2 ptn) 
          ptn (if (not (member p0 ptn)) 
                (cons p0 ptn) 
                ptn 
              ) 
    ) 
    (if        (not (equal p2 p0 1e-3)) 
      (setq tmp        (cons p2 tmp) 
            p1        p2 
      ) 
      (setq mode nil) 
    ) 
  ) 
  (reverse tmp) 
)

vitalgg · 发表于 2022-10-30 19:10:58

如果无法播放，请点击此处在新窗口打开

ytianxia · 发表于 2022-11-1 13:32:36

算法有些复杂，简单一些，找到最下面的一个点，然后依次找到所有点中到上一个点角度最靠右的那个点，就可以找到凸包了。
找最靠右的向量以上上个点到上一个点的向量作为标准方向。

freedom_ice · 发表于 2022-11-1 15:25:14

ytianxia 发表于 2022-11-1 13:32
算法有些复杂，简单一些，找到最下面的一个点，然后依次找到所有点中到上一个点角度最靠右的那个点，就可以 ...

这就是凸包的向量算法吧，思路确实更清晰简单。下一步准备实现这个办法。感谢。

guosheyang · 发表于 2022-11-4 08:05:36

xyp1964 发表于 2022-11-3 19:31

牛！院长的代码好精炼！

xj6019 · 发表于 2022-11-4 08:29:08

xyp1964 发表于 2022-11-3 19:31

院长威武！！！！

xj6019 · 发表于 2022-11-4 08:30:21

感谢楼主分享楼主威武！！！！

账号		自动登录	找回密码
密码			注册

[源码] 点集凸包的autolisp实现（几何方法）

本帖子中包含更多资源

评分

评分