Autolisp实现凸包算法

danier · 发表于 2023-5-16 20:55:33

写了个凸包算法的autolisp实现，采用Graham扫描法，供大家学习参考
有需求自取！

(defun c:tt()
(L-entity-creatnline nil (l-point-convexpolygon (setq pt_lst (mapcar '(lambda(x)(cdr (assoc 10 (entget x)))) (L-sel->list (ssget '((0 . "POINT"))))))))
)
;;;-----------------------------------------------------------;;
;;; 获取点集的凸包
;;;-----------------------------------------------------------;;
;;; L-point-convexpolygon
;;; 输入： pt_lst>>>点集
;;; 输出：多边形点集
;;; 示例：
;;;-----------------------------------------------------------;;
;;;-----------------------------------------------------------;;
(defun L-point-convexpolygon(pt_lst)
(if (> (length pt_lst) 3)
(progn
(setq pt0 (car (setq pt_lst (vl-sort pt_lst '(lambda (p1 p2) (< (cadr p1) (cadr p2)) )))))
(setq pt_lst (vl-sort pt_lst '(lambda (p1 p2) (< (angle '(0 0 0) (L-point-subtract p1 pt0) ) (angle '(0 0 0) (L-point-subtract p2 pt0))))))
(setq i 0)
(setq res (append (list (cadr pt_lst)) (list (car pt_lst)) ))
(setq pt_lst (L-list-getnvalue pt_lst 2 (length pt_lst)))
(while (< i (length pt_lst))
(cond
((> (L-point-positiononline (nth i pt_lst) (nth 1 res) (nth 0 res)) 0)
(setq res (append (list (nth i pt_lst)) res))
)
((< (L-point-positiononline (nth i pt_lst) (nth 1 res) (nth 0 res)) 0)
(setq res (L-list-getnvalue res 1 (length pt_lst)))
(while (< (L-point-positiononline (nth i pt_lst) (nth 1 res) (nth 0 res)) 0)
(setq res (L-list-getnvalue res 1 (length pt_lst)))
)
(setq res (append (list (nth i pt_lst)) res))
)
((= (L-point-positiononline (nth i pt_lst) (nth 1 res) (nth 0 res)) 0)
(setq res (L-list-getnvalue res 1 (length pt_lst)))
(setq res (append (list (nth i pt_lst)) res))
)
)
(setq i (1+ i))
)
(setq res (append (list (nth (- (length pt_lst) 1) pt_lst)) res))
)
(setq res pt_lst)
)
)
;;;-----------------------------------------------------------;;
;;; 判断点在直线左侧、右侧、直线上
;;;-----------------------------------------------------------;;
;;; L-point-positiononline
;;; 输入： pt>>>需要判断的点
;;; pt1>>>直线起点
;;; pt2>>>直线终点
;;; 输出：等于0>在直线上，小于0>在直线右侧，大于0>在直线左侧
;;; 示例：
;;;-----------------------------------------------------------;;
;;;-----------------------------------------------------------;;
(defun L-point-positiononline(pt pt1 pt2)
(- (*(-(car pt1) (car pt))(- (cadr pt2) (cadr pt))) (*(-(car pt2) (car pt))(- (cadr pt1) (cadr pt))))
)
;;;-----------------------------------------------------------;;
;;; 两点加法
;;;-----------------------------------------------------------;;
;;; L-Point-Add、L-Point-subtract
;;; 输入：
;;; 输出：
;;; 示例：
;;;-----------------------------------------------------------;;
;;;-----------------------------------------------------------;;
(defun L-point-subtract(PT1 PT2)
(list (-(car pt1) (car pt2)) (-(cadr pt1) (cadr pt2)) (-(caddr pt1) (caddr pt2)))
)
;;;-----------------------------------------------------------;;
;;; 获取列表指定区间的值
;;;-----------------------------------------------------------;;
;;; L-list-getnvalue
;;; 输入：m>>>起点位置列表第一位为0
;;; n>>>结束位置
;;; 输出：
;;; 示例：
;;;-----------------------------------------------------------;;
(defun L-list-getnvalue (lst m n / res i)
(setq res nil)
(if (and (= (type m) 'INT) (= (type n) 'INT))
(progn
(setq i m)
(while (and (setq l (nth i lst)) (< i (+ n m)))
(setq res (append res (list l)))
(setq i (1+ i))
)
)
)
res
)
;;;-----------------------------------------------------------;;
;;; 创建直线
;;; L-entity-creatline
;;; 输入：
;;; 输出：
;;; 示例：
;;;-----------------------------------------------------------;;
(defun L-entity-creatline (lay pt1 pt2)
(if (null lay)
(entmakex (list (cons 0 "LINE") (cons 8 (getvar 'clayer)) (cons 10 pt1) (cons 11 pt2)))
(entmakex (list (cons 0 "LINE") (cons 8 lay) (cons 10 pt1) (cons 11 pt2)))
)
)
(defun L-entity-creatnline (lay l_lst / i res)
(setq i 0)
(setq res nil)
(if (null lay)
(repeat (- (length l_lst) 1)
(setq res (append res (list (entmakex (list (cons 0 "LINE") (cons 8 (getvar 'clayer)) (cons 10 (nth i l_lst)) (cons 11 (nth (setq i (1+ i)) l_lst)))))))
)
(repeat (- (length l_lst) 1)
(setq res (append res (list (entmakex (list (cons 0 "LINE") (cons 8 lay) (cons 10 (nth i l_lst)) (cons 11 (nth (setq i (1+ i)) l_lst)))))))
)
)
)
;;;-----------------------------------------------------------;;
;;; 列表、选择集互转
;;;-----------------------------------------------------------;;
;;; L-sel->list L-list->sel
;;; 输入：
;;; 输出：
;;; 示例：
;;;-----------------------------------------------------------;;
(defun L-sel->list(sel / res i)
(setq res nil)
(setq i 0)
(if (/= sel nil)
(repeat (sslength sel)
(setq res (append res (list (ssname sel i))))
(setq i (1+ i))
)
)
res
)
(defun L-list->sel (lst / res)
(setq res (ssadd))
(foreach l lst (setq res (ssadd l res)))
)
(princ)

(defun c:tt() 
  (L-entity-creatnline nil (l-point-convexpolygon (setq pt_lst (mapcar '(lambda(x)(cdr (assoc 10 (entget x)))) (L-sel->list (ssget '((0 . "POINT")))))))) 
) 
 
;;;-----------------------------------------------------------;; 
;;; 获取点集的凸包 
;;;-----------------------------------------------------------;; 
;;; L-point-convexpolygon 
;;; 输入： pt_lst>>>点集 
;;; 输出： 多边形点集 
;;; 示例： 
;;;-----------------------------------------------------------;; 
;;;-----------------------------------------------------------;; 
(defun L-point-convexpolygon(pt_lst) 
  (if (> (length pt_lst) 3) 
    (progn 
      (setq pt0 (car (setq pt_lst (vl-sort pt_lst '(lambda (p1 p2) (< (cadr p1) (cadr p2)) ))))) 
      (setq pt_lst (vl-sort pt_lst '(lambda (p1 p2) (< (angle '(0 0 0) (L-point-subtract p1 pt0) ) (angle '(0 0 0) (L-point-subtract p2 pt0)))))) 
      (setq i 0) 
      (setq res (append (list (cadr pt_lst)) (list (car pt_lst)) )) 
      (setq pt_lst (L-list-getnvalue pt_lst 2 (length pt_lst))) 
      (while (
        (cond 
          ((> (L-point-positiononline (nth i pt_lst)  (nth 1 res) (nth 0 res)) 0) 
            (setq res (append (list (nth i pt_lst)) res)) 
          ) 
          ((< (L-point-positiononline (nth i pt_lst)  (nth 1 res) (nth 0 res)) 0) 
            (setq res (L-list-getnvalue res 1 (length pt_lst))) 
            (while  (< (L-point-positiononline (nth i pt_lst)  (nth 1 res) (nth 0 res)) 0) 
                    (setq res (L-list-getnvalue res 1 (length pt_lst))) 
            ) 
            (setq res (append (list (nth i pt_lst)) res)) 
          ) 
          ((= (L-point-positiononline (nth i pt_lst)  (nth 1 res) (nth 0 res)) 0) 
            (setq res (L-list-getnvalue res 1 (length pt_lst))) 
            (setq res (append (list (nth i pt_lst)) res)) 
          ) 
        ) 
        (setq i (1+ i)) 
      ) 
      (setq res (append (list (nth (- (length pt_lst) 1) pt_lst)) res)) 
    ) 
    (setq res pt_lst) 
  ) 
) 
 
;;;-----------------------------------------------------------;; 
;;; 判断点在直线左侧、右侧、直线上 
;;;-----------------------------------------------------------;; 
;;; L-point-positiononline 
;;; 输入： pt>>>需要判断的点 
;;;       pt1>>>直线起点 
;;;       pt2>>>直线终点 
;;; 输出：等于0>在直线上，小于0>在直线右侧，大于0>在直线左侧 
;;; 示例： 
;;;-----------------------------------------------------------;; 
;;;-----------------------------------------------------------;; 
(defun L-point-positiononline(pt pt1 pt2) 
  (- (*(-(car pt1) (car pt))(- (cadr pt2) (cadr pt))) (*(-(car pt2) (car pt))(- (cadr pt1) (cadr pt)))) 
) 
 
;;;-----------------------------------------------------------;; 
;;; 两点加法 
;;;-----------------------------------------------------------;; 
;;; L-Point-Add、L-Point-subtract 
;;; 输入： 
;;; 输出： 
;;; 示例： 
;;;-----------------------------------------------------------;; 
;;;-----------------------------------------------------------;; 
(defun L-point-subtract(PT1 PT2) 
  (list (-(car pt1) (car pt2)) (-(cadr pt1) (cadr pt2)) (-(caddr pt1) (caddr pt2))) 
) 
 
;;;-----------------------------------------------------------;; 
;;; 获取列表指定区间的值 
;;;-----------------------------------------------------------;;                                    
;;; L-list-getnvalue                                        
;;; 输入：m>>>起点位置 列表第一位为0 
;;;       n>>>结束位置 
;;; 输出：                                     
;;; 示例： 
;;;-----------------------------------------------------------;; 
(defun L-list-getnvalue (lst m n / res i) 
  (setq res nil) 
  (if (and (= (type m) 'INT) (= (type n) 'INT)) 
    (progn 
      (setq i m) 
      (while (and (setq l (nth i lst)) (
        (setq res (append res (list l))) 
        (setq i (1+ i)) 
      ) 
    ) 
  ) 
  res 
) 
 
;;;-----------------------------------------------------------;; 
;;; 创建直线                                    
;;; L-entity-creatline                                        
;;; 输入：                                           
;;; 输出： 
;;; 示例： 
;;;-----------------------------------------------------------;; 
(defun L-entity-creatline (lay pt1 pt2) 
  (if (null lay) 
    (entmakex (list (cons 0 "LINE") (cons 8 (getvar 'clayer)) (cons 10 pt1) (cons 11 pt2))) 
    (entmakex (list (cons 0 "LINE") (cons 8 lay) (cons 10 pt1) (cons 11 pt2))) 
  ) 
) 
(defun L-entity-creatnline (lay l_lst / i res) 
  (setq i 0) 
  (setq res nil) 
  (if (null lay) 
    (repeat (- (length l_lst) 1) 
      (setq res (append res (list (entmakex (list (cons 0 "LINE") (cons 8 (getvar 'clayer)) (cons 10 (nth i l_lst)) (cons 11 (nth (setq i (1+ i)) l_lst))))))) 
    ) 
    (repeat (- (length l_lst) 1) 
      (setq res (append res (list (entmakex (list (cons 0 "LINE") (cons 8 lay) (cons 10 (nth i l_lst)) (cons 11 (nth (setq i (1+ i)) l_lst))))))) 
    ) 
  ) 
) 
 
;;;-----------------------------------------------------------;; 
;;; 列表、选择集互转 
;;;-----------------------------------------------------------;; 
;;; L-sel->list  L-list->sel                              
;;; 输入： 
;;; 输出： 
;;; 示例： 
;;;-----------------------------------------------------------;; 
(defun L-sel->list(sel / res i) 
  (setq res nil) 
  (setq i 0) 
  (if (/= sel nil)   
    (repeat (sslength sel) 
      (setq res (append res (list (ssname sel i)))) 
      (setq i (1+ i)) 
    ) 
  ) 
  res 
) 
(defun L-list->sel (lst / res) 
  (setq res (ssadd)) 
  (foreach l lst (setq res (ssadd l res))) 
) 
(princ)

vitalgg · 发表于 2023-5-17 06:39:11

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

hhh454 · 发表于 2023-5-17 10:27:25

感谢分享算法，学习了

crtrccrt · 发表于 2023-5-20 08:44:58

;;; 判断点在直线左侧、右侧、直线上
;;; L-point-positiononline

;注意该子程序理论上不严谨,可能产生错误;

angel066499 · 发表于 2023-5-22 21:13:03

vitalgg 发表于 2023-5-17 06:39

这个视频怎么发布的呢

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

[源码] Autolisp实现凸包算法

本帖子中包含更多资源

评分