计算交叉连续多段的外轮廓

Sring65 · 发表于昨天 00:39

本帖最后由 Sring65 于 2025-6-13 08:06 编辑

(defun c:getOuterBoundary ()
(setq s (car (entsel)))
(setq pts (getPlinePts s))
(entmakeLWPOLYLINE (getOuterBoundary pts))
(princ)
)
(defun entmakeLWPOLYLINE (pts)
(entmake
(append
(list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(62 . 1)
(cons 90 (length pts)) ; 点的数量
; 闭合标志
(if (equal (caar pts) (car (last pts)) 1e-8)
(cons 70 1)
(cons 70 0)
)
)
(mapcar '(lambda (a) (cons 10 a)) pts)
)
)
)
(defun getPlinePts (ent)
(vl-remove-if
'null
(mapcar
'(lambda (x)
(if (= (car x) 10)
(cdr x)
)
)
(entget ent)
)
)
)
(defun getOuterBoundary (pointList / pts ptxList ptmin tmp p0 p1)
(setq PIx2 (+ pi pi))
(setq tmp (mapcar '1- (apply 'mapcar (cons 'min pointList)))) ;最下点
(setq p0 (last (sortByDistance tmp pointList))) ;最下点近点
(setq pts (getNextIntsitepts tmp p0 pointList))
(setq tmp p0)
(while (and
(setq pts (getNextIntsitepts (car pts) (cadr pts) pointList))
(setq p0 (car pts))
(setq p1 (cadr pts))
(setq ptxList (cons p0 ptxList))
(not (equal p0 tmp 1e-6)) ;回到起点退出循环
)
)
;补起点
(setq ptxList (cons tmp ptxList))
(if (not (equal (last ptxList) (car ptxList) 1e-6))
(setq ptxList (cons (last ptxList) ptxList))
)
ptxList
)
;;;是否包含点
(defun ContainsEqual (lst pts / i e return)
(setq i -1)
(while (setq e (nth (setq i (1+ i)) lst))
(if (equal e pts 1e-6)
(setq return t
i (length lst)
)
)
)
return
)
;;;计算下一点位置
(defun getNextIntsitepts
(p1 p2 pointList / lst ptx ptn minLen tmp y x ptxlst)
(setq ptn p2
minLen (1+ (distance p1 p2))
y (last pointList)
)
(foreach x pointList
(if (and (setq ptx (Inters p1 p2 x y))
(not (equal p1 ptx 1e-6))
) ;计算交点
(progn
(setq tmp (Distance p1 ptx))
(if (equal tmp minLen 1e-6)
;;防止交点重复
(setq lst (cons x lst)
lst (cons y lst)
)
(if (< tmp minLen)
;;;取最近交点
(setq minLen tmp
ptn ptx
lst (list x y p2)
)
)
)
)
(if (checkOnline p1 p2 x y) ;检查是否共线
(setq lst (cons x lst)
lst (cons y lst)
)
)
)
(setq y x)
)
(setq ptxlst (removeEqual ptn (removeEqual p1 lst)))
(cons ptn (sortByAngle p1 ptn (sortByDistance ptn ptxlst)))
;;交点最小角度
)
(defun checkOnline (p1 p2 l1 l2 / ang)
(and
(or (equal (setq ang (getangles p1 p2 l1)) PIx2 1e-8)
(equal ang pi 1e-8)
)
(or (equal (setq ang (getangles p1 p2 l2)) PIx2 1e-8)
(equal ang pi 1e-8)
)
)
)
(defun sortByAngle (pt0 pt1 ptxlst / angb anga ang0)
(vl-sort ptxlst
'(lambda (a b)
(< (getAngles pt0 pt1 a) (getAngles pt0 pt1 b))
)
)
)
(defun sortByDistance (p ptxlst)
(vl-sort ptxlst
'(lambda (a b) (> (distance p a) (distance p b)))
)
)
(defun getAngles (pt1 pt2 pt3 / ang a1 a2)
(if (or (equals pt2 pt1 1e-6) (equals pt2 pt3 1e-6))
(+ pi pi)
(progn
(setq ang (- (Angle pt2 pt3) (Angle pt2 pt1)))
(if (< ang 0)
(setq ang (+ ang pi pi))
)
(if (equal ang 0 1e-6)
(+ pi pi)
ang
)
)
)
)
(defun equals (a b p)
(vl-every '(lambda (x y) (equal x y p)) a b)
)
(defun removeEqual (ptn ptxlst / lst)
(vl-remove-if
'null
(mapcar '(lambda (x)
(if (equal ptn x 1e-6)
nil
x
)
)
ptxlst
)
)
)

(defun c:getOuterBoundary () 
  (setq s (car (entsel))) 
  (setq pts (getPlinePts s)) 
  (entmakeLWPOLYLINE (getOuterBoundary pts)) 
  (princ) 
) 
(defun entmakeLWPOLYLINE (pts) 
  (entmake 
    (append 
      (list 
  '(0 . "LWPOLYLINE") 
  '(100 . "AcDbEntity") 
  '(100 . "AcDbPolyline") 
  '(62 . 1) 
  (cons 90 (length pts))    ; 点的数量 
          ; 闭合标志 
  (if (equal (caar pts) (car (last pts)) 1e-8) 
    (cons 70 1) 
    (cons 70 0) 
  ) 
      ) 
      (mapcar '(lambda (a) (cons 10 a)) pts) 
    ) 
  ) 
) 
(defun getPlinePts (ent) 
  (vl-remove-if 
    'null 
    (mapcar 
      '(lambda (x) 
   (if (= (car x) 10) 
     (cdr x) 
   ) 
       ) 
      (entget ent) 
    ) 
  ) 
) 
(defun getOuterBoundary  (pointList / pts ptxList ptmin tmp p0 p1) 
  (setq PIx2 (+ pi pi)) 
  (setq tmp (mapcar '1- (apply 'mapcar (cons 'min pointList)))) ;最下点 
  (setq p0 (last (sortByDistance tmp pointList))) ;最下点近点 
  (setq pts (getNextIntsitepts tmp p0 pointList)) 
  (setq tmp p0) 
  (while (and 
     (setq pts (getNextIntsitepts (car pts) (cadr pts) pointList)) 
     (setq p0 (car pts)) 
     (setq p1 (cadr pts)) 
     (setq ptxList (cons p0 ptxList)) 
     (not (equal p0 tmp 1e-6))  ;回到起点退出循环 
   ) 
  ) 
          ;补起点 
  (setq ptxList (cons tmp ptxList)) 
  (if (not (equal (last ptxList) (car ptxList) 1e-6)) 
    (setq ptxList (cons (last ptxList) ptxList)) 
  ) 
  ptxList 
) 
;;;是否包含点 
(defun ContainsEqual (lst pts / i e return) 
  (setq i -1) 
  (while (setq e (nth (setq i (1+ i)) lst)) 
    (if  (equal e pts 1e-6) 
      (setq return t 
      i     (length lst) 
      ) 
    ) 
  ) 
  return 
) 
;;;计算下一点位置 
(defun getNextIntsitepts 
       (p1 p2 pointList / lst ptx ptn minLen tmp y x ptxlst) 
  (setq  ptn    p2 
  minLen (1+ (distance p1 p2)) 
  y      (last pointList) 
  ) 
  (foreach x pointList 
    (if  (and (setq ptx (Inters p1 p2 x y)) 
       (not (equal p1 ptx 1e-6)) 
  )        ;计算交点 
      (progn 
  (setq tmp (Distance p1 ptx)) 
  (if (equal tmp minLen 1e-6) 
    ;;防止交点重复 
    (setq  lst (cons x lst) 
    lst (cons y lst) 
    ) 
    (if (< tmp minLen) 
;;;取最近交点 
      (setq minLen tmp 
      ptn   ptx 
      lst   (list x y p2) 
      ) 
    ) 
  ) 
      ) 
      (if (checkOnline p1 p2 x y)  ;检查是否共线 
  (setq lst (cons x lst) 
        lst (cons y lst) 
  ) 
      ) 
    ) 
    (setq y x) 
  ) 
  (setq ptxlst (removeEqual ptn (removeEqual p1 lst))) 
  (cons ptn (sortByAngle p1 ptn (sortByDistance ptn ptxlst))) 
  ;;交点最小角度 
) 
(defun checkOnline (p1 p2 l1 l2 / ang) 
  (and 
    (or  (equal (setq ang (getangles p1 p2 l1)) PIx2 1e-8) 
  (equal ang pi 1e-8) 
    ) 
    (or  (equal (setq ang (getangles p1 p2 l2)) PIx2 1e-8) 
  (equal ang pi 1e-8) 
    ) 
  ) 
) 
(defun sortByAngle (pt0 pt1 ptxlst / angb anga ang0) 
  (vl-sort ptxlst 
     '(lambda (a b) 
        (< (getAngles pt0 pt1 a) (getAngles pt0 pt1 b)) 
      ) 
  ) 
) 
(defun sortByDistance (p ptxlst) 
  (vl-sort ptxlst 
     '(lambda (a b) (> (distance p a) (distance p b))) 
  ) 
) 
(defun getAngles (pt1 pt2 pt3 / ang a1 a2) 
  (if (or (equals pt2 pt1 1e-6) (equals pt2 pt3 1e-6)) 
    (+ pi pi) 
    (progn 
      (setq ang (- (Angle pt2 pt3) (Angle pt2 pt1))) 
      (if (< ang 0) 
  (setq ang (+ ang pi pi)) 
      ) 
      (if (equal ang 0 1e-6) 
  (+ pi pi) 
  ang 
      ) 
    ) 
  ) 
) 
(defun equals (a b p) 
  (vl-every '(lambda (x y) (equal x y p)) a b) 
) 
(defun removeEqual (ptn ptxlst / lst) 
  (vl-remove-if 
    'null 
    (mapcar '(lambda (x) 
         (if (equal ptn x 1e-6) 
     nil 
     x 
         ) 
       ) 
      ptxlst 
    ) 
  ) 
)

crtrccrt · 发表于昨天 06:26

不封闭的多段线，按封闭计算，逻辑有问题。

Sring65 · 发表于昨天 07:41

crtrccrt 发表于 2025-6-13 06:26
不封闭的多段线，按封闭计算，逻辑有问题。

对就是按封闭的算的

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

[源码] 计算交叉连续多段的外轮廓

本帖子中包含更多资源