社区 › 源码共享 › 加速>> 批量交点断开!

尘缘一生 发表于 2024-1-22 22:22:01

加速>> 批量交点断开!

本帖最后由 尘缘一生 于 2024-1-23 12:33 编辑

批量交点断开，需要加速的，然而这个缺不好加速理想化，目前三领也没有做到全部抛弃BREAK方式。
从前发过几次改写的，应该说，一次次都有提高。

关于这个问题，代码方面也各不相同，怎么合理的规划是个大事，什么样的实体，采取怎么集成处理
三领在使用过程中，也一直在构思优化，下面贴上三领使用的源码，期待更好的优化下去。
;;交点断开程序----【开始】-----
;三领设计 V3.0 Modify by 尘缘一声QQ:15290049
(defun c:sl-break (/ e_lst ss)
(_undo1)
(setq e_lst (sysvar '("OSMODE" "CMDECHO" "ORTHOMODE" "DRAWORDERCTL")))
(setvar "CMDECHO" 0)
(setvar "OSMODE" 0) ;;捕捉关闭
(setvar "ORTHOMODE" 0) ;;正交关闭
(setvar "DRAWORDERCTL" 0)
(prompt
    (slmsg
      "\n 支持 LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE!"
      "\n や LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE!"
      "\n Support LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE!"
    )
)
(prompt
    (slmsg
      "\n 选择交点断开的实体，ENTER 键继续-->:"
      "\n 匡拒ユ翴耞秨龟砰ENTER 龄膥尿-->:"
      "\n Select the entity whose intersection is broken, and press ENTER to continue-->:"
    )
)
(if (setq ss (sstoslss (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))) ;sstoslss 选择集整理函数,
    (sl_break_with ss t)
)
(mapcar 'eval e_lst)
(_undo2)
(princ)
)
;;实体与其交点处断开----(一级)------
;;nam 实体名 lis 实体上断开点集表(已包含必要的端点)
(defun ssbrkpoint (nam lis / ent lis1 tp namcen objaxis objratio w ly cl lt p0 p1 p2 enlst)
(setq tp (dxf1 nam 0))
(cond
    ((member tp '("LWPOLYLINE" "POLYLINE")) ;整合决定此时已是:共线的
      (setq w (linwind nam) ly (dxf1 nam 8) cl (sl-getcolor nam) lt (sl-linetype nam))
      (if (> w 0.0)
      (while (> (length lis) 1)
          (slch:lwpolyline (list (car lis) (cadr lis)) nil w ly cl nil)
          (vla-put-linetype (en2obj (entlast)) lt)
          (setq lis (cdr lis))
      )
      (while (> (length lis) 1)
          (slch:line (car lis) (cadr lis) ly cl nil)
          (vla-put-linetype (en2obj (entlast)) lt)
          (setq lis (cdr lis))
      )
      )
      (entdel nam)
    )
    ((member tp '("LINE" "ARC"))
      (setq
      lis1 lis
      ent (entget nam)
      ent (vl-remove (assoc -1 ent) ent) ;去除图元名
      ent (vl-remove (assoc 330 ent) ent) ;去除id
      ent (vl-remove (assoc 5 ent) ent) ;去除句柄
      )
      (cond
      ((= tp "LINE")
          (while (> (length lis) 1)
            (setq ent (subst (cons 10 (car lis)) (assoc 10 ent) ent))
            (setq ent (subst (cons 11 (cadr lis)) (assoc 11 ent) ent))
            (entmake ent)
            (setq lis (cdr lis))
          )
      )
      ((= tp "ARC")
          (setq namcen (dxf1 ent 10))
          (while (> (length lis) 1)
            (setq ent (subst (cons 50 (angle namcen (cadr lis))) (assoc 50 ent) ent))
            (setq ent (subst (cons 51 (angle namcen (car lis))) (assoc 51 ent) ent))
            (entmake ent)
            (setq lis (cdr lis))
          )
      )
      )
      (if (> (length lis1) 1) (entdel nam))
    )
    (t
      ;;去除端点(此步重要)
      (setq p1 (vlax-curve-getstartpoint nam) p2 (vlax-curve-getendpoint nam))
      (if (equal (car lis) p1 1e-9)
      (setq lis (cdr lis))
      )
      (if (equal (last lis) p2 1e-9)
      (setq lis (reverse (cdr (reverse lis))))
      )
      ;;以上去除端点
      (vl-catch-all-apply 'sl_break_obj (list nam lis))
    )
)
(princ)
)
;;求交点集函数-------------
;;参数 el (obj1 obj2 obj3)
;;返回 ((obj1 pt1 pt2...交点n) (obj2 pt1 pt2...交点n)....) ;包含实体端点
(defun ssinter (el / el1 obj1 obj2 ipts pts list1 outlst i j)
(setq outlst (mapcar 'list el) i -1)
(while el
    (setq obj1 (car el)
      list1 (nth (setq i (1+ i)) outlst) ;obj1已有的交点列表
      el (cdr el)
      el1 el
      j i
    )
    (while el1
      (setq obj2 (car el1) el1 (cdr el1) j (1+ j))
      (if (and
            (setq ipts (vla-intersectwith obj1 obj2 0))
            (setq ipts (vlax-variant-value ipts))
            (> (vlax-safearray-get-u-bound ipts 1) 0)
          )
      (progn
          (setq ipts (vlax-safearray->list ipts) pts '());obj1,obj2交点临时列表变量
          (while (> (length ipts) 0)
            (setq pts (cons (list (car ipts) (cadr ipts) (caddr ipts)) pts) ipts (cdddr ipts))
          )
          (setq list1 (append list1 pts)) ;存obj1交点表,循环结束后再更新
          (setq outlst (subst (append (nth j outlst) pts) (nth j outlst) outlst));;obj2的交点列表立即更新
      )
      )
    )
    (if (and (cdr list1) (not (vlax-curve-isClosed obj1)))
      (setq list1 (append list1 (list (vlax-curve-getEndPoint obj1)) (list (vlax-curve-getStartPoint obj1))));;当obj1存在交点,且非封闭曲线,添加两端点
    )
    (setq outlst (subst list1 (nth i outlst) outlst));更新obj1交点列表
)
outlst
)
;;点集排序及删除重复点函数---(一级)----
;;参数 ((obj1 pt1 pt2...交点n) (obj2 pt1 pt2...交点n)....)
;;返回 ((nam1 pt1 pt2...) (nam2 pt1 pt2...)....)
(defun InterSort (el / obj1 pts plst outlst item)
(foreach item el
    (setq obj1 (car item) pts (cdr item))
    (if pts
      (progn
      (setq pts (vl-sort pts (function (lambda (p1 p2) (< (vlax-curve-getParamAtPoint obj1 p1) (vlax-curve-getParamAtPoint obj1 p2))))));;交点排序，列表为逆序
      (setq plst (reverse (gps->lst-delsame pts)))
      (if (vlax-curve-isClosed obj1) ;;闭合曲线需再添加首个交点以使新实体完全封闭
          (setq plst (cons (last plst) plst))
      )
      (setq plst (cons (obj2en obj1) plst)
          outlst (cons plst outlst)
      )
      )
    )
)
outlst
)
;;实体与其交点处断开--------(一级)------
;;nam 实体名ptlst 实体上交点表(并未包含端点)
(defun sl_break_obj (nam ptlst / enlst p0 p1 p2 tp maxparam minparam obj)
(setq tp (dxf1 nam 0) enlst (list nam))
(if (= tp "CIRCLE")
    (progn
      (arccirtopl nam) ;转为2点多段线圆
      (setq nam (entlast))
    )
)
(foreach p0 ptlst
    (if enlst
      (if (not (numberp (vl-catch-all-apply 'vlax-curve-getdistatpoint (list nam p0))))
      (foreach obj enlst
          (if (numberp (vl-catch-all-apply 'vlax-curve-getdistatpoint (list obj p0)))
            (setq nam obj)
          )
      )
      )
    )
    (cond
      ((and (= tp "SPLINE") (vlax-curve-isclosed nam))
      (setq
          p1 (vlax-curve-getparamatpoint nam p0)
          p2 (vlax-curve-getpointatparam nam (+ p1 0.000001))
      )
      (command "._break" nam "_non" (trans p0 0 1) "_non" (trans p2 0 1))
      )
      ((and (= tp "ELLIPSE") (vlax-curve-isclosed nam))
      (setq
          p1 (vlax-curve-getparamatpoint nam p0)
          p2 (+ p1 0.000001)
          minparam (min p1 p2)
          maxparam (max p1 p2)
          obj (en2obj nam)
      )
      (vlax-put obj 'startparameter maxparam)
      (vlax-put obj 'endparameter (+ minparam 2pi))
      )
      (t
      (command "._break" nam "_non" (trans p0 0 1) "_non" (trans p0 0 1))
      (if (not (vlax-curve-isclosed nam))
          (setq enlst (cons (entlast) enlst))
      )
      )
    )
)
)
;;选择集交点断开-------(一级)-------
;;支持line arc circle ellipse spline polyline lwpolyline
;self t 自交断nil 自交不断
(defun sl_break_with (ss self / ss1 ss2 nam e lis n tp)
(setq ss1 (ssadd) ss2 (ssadd))
(repeat (setq n (sslength ss))
    (setq nam (ssname ss (setq n (1- n))) tp (dxf1 nam 0))
    (cond
      ((= tp "CIRCLE") ;转为2段多段线处理
      (arccirtopl nam)
      (ssadd (entlast) ss1)
      )
      ((or
         (member tp '("LINE" "ARC"))
         (= (sl:pts-onLine (getpt (ssadd nam))) t)
       )
      (ssadd nam ss2)
      )
      (t
      (ssadd nam ss1)
      )
    )
)
(if (> (sslength ss2) 0)
    (progn
      (setq e (entlast))
      (mapcar '(lambda (x) (ssbrkpoint (car x) (cdr x))) (InterSort (ssinter (ssget->vla-list ss2))))
      (setq ss2 (last_ent e))
    )
)
(if (> (sslength ss1) 0)
    (if (> (sslength ss2) 0)
      (progn
      (setq ss1 (sl:pickset-join ss1 ss2))
      (break_with_include_pl_sl ss1 ss1 self)
      )
      (break_with_include_pl_sl ss1 ss1 self)
    )
)
)
;;对象是否在锁定层上-----(一级)-----
(defun onlockedlayer (nam / entlst)
(setq entlst (tblsearch "LAYER" (dxf1 nam 8)))
(= 4 (logand 4 (dxf1 entlst 70)))
)
;;坐标表--->三维点表------(一级)---
(defun list->3pair (old / new)
(while (setq new (cons (list (car old) (cadr old) (caddr old)) new) old (cdddr old)))
(reverse new)
)
;;选择集交点断开-------(一级)-------
;self t 自交断nil 自交不断
(defun break_with_include_pl_sl (ss2brk ss2brkwith self / intpts lst masterlist obj intobj obj2brk)
(foreach obj (ssget->vla-list ss2brk)
    (if (not (onlockedlayer (obj2en obj)))
      (progn
      (setq lst nil)
      (foreach intobj (ssget->vla-list ss2brkwith)
          (if (and (or self (not (equal obj intobj))) (setq intpts (get_interpts obj intobj 0)))
            (setq lst (append (list->3pair intpts) lst))
          )
      )
      (if lst (setq masterlist (cons (cons (obj2en obj) lst) masterlist)))
      )
    )
)
(if masterlist
    (foreach obj2brk masterlist
      (vl-catch-all-apply 'sl_break_obj (list (car obj2brk) (cdr obj2brk)))
    )
)
)
;;交点断开程序【结束】-------

尘缘一生 发表于 2024-1-23 03:33:53

本帖最后由 尘缘一生 于 2024-1-23 04:08 编辑

再次改写压缩，

;;交点断开程序----【开始】-----
;三领设计 V3.0 Modify by 尘缘一声QQ:15290049
(defun c:sl-break (/ e_lst ss)
(_undo1)
(setq e_lst (sysvar '("OSMODE" "CMDECHO" "ORTHOMODE" "DRAWORDERCTL")))
(setvar "CMDECHO" 0)
(setvar "OSMODE" 0) ;;捕捉关闭
(setvar "ORTHOMODE" 0) ;;正交关闭
(setvar "DRAWORDERCTL" 0)
(prompt
    (slmsg
      "\n 支持 LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE!"
      "\n や LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE!"
      "\n Support LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE!"
    )
)
(prompt
    (slmsg
      "\n 选择交点断开的实体，ENTER 键继续-->:"
      "\n 匡拒ユ翴耞秨龟砰ENTER 龄膥尿-->:"
      "\n Select the entity whose intersection is broken, and press ENTER to continue-->:"
    )
)
(if (setq ss (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
    (sl_break_with ss t)
)
(mapcar 'eval e_lst)
(_undo2)
(princ)
)
;;实体与其交点处断开----(一级)------
;;nam 实体名 lis 实体上断开点集表(已包含必要的端点)
(defun ssbrkpoint (nam lis / ent lis1 tp namcen objaxis objratio w ly cl lt p0 p1 p2 enlst)
(setq tp (dxf1 nam 0))
(if (= tp "CIRCLE") ;转为2段多段线处理
    (progn (arccirtopl nam) (setq nam (entlast)))
)
(cond
    ((and (member tp '("LWPOLYLINE" "POLYLINE")) (= (sl:pts-onLine lis) t) (= (checkarc nam) nil)) ;共线、不带圆弧的
      (setq w (linwind nam) ly (dxf1 nam 8) cl (sl-getcolor nam) lt (sl-linetype nam))
      (if (> w 0.0)
      (while (> (length lis) 1)
          (slch:lwpolyline (list (car lis) (cadr lis)) nil w ly cl nil)
          (vla-put-linetype (en2obj (entlast)) lt)
          (setq lis (cdr lis))
          )
      (while (> (length lis) 1)
          (slch:line (car lis) (cadr lis) ly cl nil)
          (vla-put-linetype (en2obj (entlast)) lt)
          (setq lis (cdr lis))
          )
      )
      (entdel nam)
    )
    ((member tp '("LINE" "ARC")) ;(member tp '("LINE" "ARC" "CIRCLE"))
      (setq
      lis1 lis
      ent (entget nam)
      ent (vl-remove (assoc -1 ent) ent) ;去除图元名
      ent (vl-remove (assoc 330 ent) ent) ;去除id
      ent (vl-remove (assoc 5 ent) ent) ;去除句柄
      )
      (cond
      ((= tp "LINE")
          (while (> (length lis) 1)
            (setq ent (subst (cons 10 (car lis)) (assoc 10 ent) ent))
            (setq ent (subst (cons 11 (cadr lis)) (assoc 11 ent) ent))
            (entmake ent)
            (setq lis (cdr lis))
            )
          )
      ;((= tp "CIRCLE")
      ;(setq objcen (dxf1 ent 10))
      ;(setq ent (subst (cons 0 "ARC") (assoc 0 ent) ent))
      ;(setq ent (append ent (list (cons 100 "AcDbArc") (cons 50 0.0) (cons 51 0.0))))
      ;(while (> (length lis) 1)
      ;    (setq ent (subst (cons 50 (angle objcen (cadr lis))) (assoc 50 ent) ent))
      ;    (setq ent (subst (cons 51 (angle objcen (car lis))) (assoc 51 ent) ent))
      ;    (entmake ent)
      ;    (setq lis (cdr lis))
      ;)
      ;)
      ((= tp "ARC")
          (setq namcen (dxf1 ent 10))
          (while (> (length lis) 1)
            (setq ent (subst (cons 50 (angle namcen (cadr lis))) (assoc 50 ent) ent))
            (setq ent (subst (cons 51 (angle namcen (car lis))) (assoc 51 ent) ent))
            (entmake ent)
            (setq lis (cdr lis))
            )
          )
      )
      (if (> (length lis1) 1) (entdel nam))
    )
    (t
      (setq p1 (vlax-curve-getstartpoint nam) p2 (vlax-curve-getendpoint nam))
      (setq lis (remove_ite_list lis p1));;去除端点
      (setq lis (remove_ite_list lis p2))
      (vl-catch-all-apply 'sl_break_obj (list nam lis))
    )
)
(princ)
)
;;求交点集函数-------------
;;参数 el (obj1 obj2 obj3)
;;返回 ((obj1 pt1 pt2...交点n) (obj2 pt1 pt2...交点n)....) ;包含实体端点
(defun ssinter (el / el1 obj1 obj2 ipts pts list1 outlst i j)
(setq outlst (mapcar 'list el) i -1)
(while el
    (setq obj1 (car el)
      list1 (nth (setq i (1+ i)) outlst) ;obj1已有的交点列表
      el (cdr el)
      el1 el
      j i
    )
    (while el1
      (setq obj2 (car el1) el1 (cdr el1) j (1+ j))
      (if (and
            (setq ipts (vla-intersectwith obj1 obj2 0))
            (setq ipts (vlax-variant-value ipts))
            (> (vlax-safearray-get-u-bound ipts 1) 0)
            )
      (progn
          (setq ipts (vlax-safearray->list ipts) pts '());obj1,obj2交点临时列表变量
          (while (> (length ipts) 0)
            (setq pts (cons (list (car ipts) (cadr ipts) (caddr ipts)) pts) ipts (cdddr ipts))
            )
          (setq list1 (append list1 pts)) ;存obj1交点表,循环结束后再更新
          (setq outlst (subst (append (nth j outlst) pts) (nth j outlst) outlst));;obj2的交点列表立即更新
          )
      )
    )
    (if (and (cdr list1) (not (vlax-curve-isClosed obj1)))
      (setq list1 (append list1 (list (vlax-curve-getEndPoint obj1)) (list (vlax-curve-getStartPoint obj1))));;当obj1存在交点,且非封闭曲线,添加两端点
    )
    (setq outlst (subst list1 (nth i outlst) outlst));更新obj1交点列表
)
outlst
)
;;点集排序及删除重复点函数---(一级)----
;;参数 ((obj1 pt1 pt2...交点n) (obj2 pt1 pt2...交点n)....)
;;返回 ((nam1 pt1 pt2...) (nam2 pt1 pt2...)....)
(defun InterSort (el / obj1 pts plst outlst item)
(foreach item el
    (setq obj1 (car item) pts (cdr item))
    (if pts
      (progn
      (setq pts (vl-sort pts (function (lambda (p1 p2) (< (vlax-curve-getParamAtPoint obj1 p1) (vlax-curve-getParamAtPoint obj1 p2))))));;交点排序，列表为逆序
      (setq plst (reverse (gps->lst-delsame pts)))
      (if (vlax-curve-isClosed obj1) ;;闭合曲线需再添加首个交点以使新实体完全封闭
          (setq plst (cons (last plst) plst))
          )
      (setq plst (cons (obj2en obj1) plst)
          outlst (cons plst outlst)
          )
      )
    )
)
outlst
)
;;实体与其交点处断开--------(一级)------
;;nam 实体名ptlst 实体上交点表(并未包含端点)
(defun sl_break_obj (nam ptlst / enlst p0 p1 p2 tp maxparam minparam obj closif)
(setq tp (dxf1 nam 0) enlst (list nam))
(foreach p0 ptlst
    (if enlst
      (if (not (numberp (vl-catch-all-apply 'vlax-curve-getdistatpoint (list nam p0))))
      (foreach obj enlst
          (if (numberp (vl-catch-all-apply 'vlax-curve-getdistatpoint (list obj p0)))
            (setq nam obj)
            )
          )
      )
    )
    (setq closif (vlax-curve-isclosed nam))
    (cond
      ((and (member tp '("SPLINE" "CIRCLE")) closif)
      (setq
          p1 (vlax-curve-getparamatpoint nam p0)
          p2 (vlax-curve-getpointatparam nam (+ p1 0.000001))
          )
      (command "._break" nam "_non" (trans p0 0 1) "_non" (trans p2 0 1))
      (if (= tp "CIRCLE") (setq tp "ARC"))
      )
      ((and (= tp "ELLIPSE") closif)
      (setq
          p1 (vlax-curve-getparamatpoint nam p0)
          p2 (+ p1 0.000001)
          minparam (min p1 p2)
          maxparam (max p1 p2)
          obj (en2obj nam)
          )
      (vlax-put obj 'startparameter maxparam)
      (vlax-put obj 'endparameter (+ minparam 2pi))
      )
      (t
      (command "._break" nam "_non" (trans p0 0 1) "_non" (trans p0 0 1))
      (if (not closif)
          (setq enlst (cons (entlast) enlst))
          )
      )
    )
)
)
;;对象是否在锁定层上-----(一级)-----
(defun onlockedlayer (nam / entlst)
(setq entlst (tblsearch "LAYER" (dxf1 nam 8)))
(= 4 (logand 4 (dxf1 entlst 70)))
)
;;选择集交点断开-------(一级)-------
;;支持line arc circle ellipse spline polyline lwpolyline
;self t 自交断nil 自交不断
(defun sl_break_with (ss self / obj lis lis1)
(setq lis (ssget->vla-list ss))
(if self
    (foreach obj lis
      (if (not (onlockedlayer (obj2en obj)))
      (setq lis (cons obj lis))
      )
    )
)
(mapcar '(lambda (x) (vl-catch-all-apply 'ssbrkpoint (list (car x) (cdr x)))) (InterSort (ssinter lis)))
)
;;交点断开程序【结束】-------

bai2000 发表于 2024-1-23 15:59:33

看着不错，支持一下，虽然有自定义函数：
(progn (arccirtopl nam) (setq nam (entlast)))
)
(cond
    ((and (member tp '("LWPOLYLINE" "POLYLINE")) (= (sl:pts-onLine lis) t) (= (checkarc nam) nil)) ;共线、不带圆弧的
      (setq w (linwind nam) ly (dxf1 nam 8) cl (sl-getcolor nam) lt (sl-linetype nam))

尘缘一生 发表于 2024-1-24 00:21:47

bai2000 发表于 2024-1-23 15:59
看着不错，支持一下，虽然有自定义函数：
(progn (arccirtopl nam) (setq nam (entlast)))
)


还在修改，思考加速的深挖一下，目前，想合并两部分交点问题，还没有做到。

ghgh0130 发表于 2024-1-24 11:56:26

看着不错，支持一下。。

atone 发表于 2024-2-13 19:39:10

批量交点断开，期待更新

meja 发表于 2024-2-20 11:43:41

这个国外很多大神写过，leemac 和 cab 的最出名

查看完整版本: 加速>> 批量交点断开!