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

Autolisp实现凸包算法


写了个凸包算法的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->listL-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

https://atlisp.cn/static/videos/graham-scan.mp4


https://atlisp.cn/static/videos/graham-scan2.mp4

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


这个视频怎么发布的呢
页: [1]
查看完整版本: Autolisp实现凸包算法