直线，圆弧的圆去虫复,效率很(超)高（目前已知问题全部解决）~~欢迎品鉴和踢馆

易云网络 · 发表于 2015-8-22 18:59:14

本帖最后由易云网络于 2015-9-8 13:37 编辑

;|*********************************************************************************************;
软件作者: 易云网络
当前版本1.03
版本1.03
修改一些BUG，结构上有一些调整，理论要快点
修改时间：2015.09.02
版本1.02
2015.8.27增加去除0长的线，
对排序函数精度降低至1E-5
删除一些无用变量
版本1.01 ；
修改时间：2015.8.25
修改一个BUG增加一个判断有的线是(angle e10 e11)的弧度是2*PI 会出现BUG
;
===============================================================================================;
本软件为开源软件: 以下是开源申明:
-----------------------------------------------------------------------------------------------;
本页面的软件遵照GPL协议开放源代码，您可以自由传播和修改，在遵照下面的约束条件的前提下:
一. 只要你在本开源软件的每一副本上明显和恰当地出版版权声明，保持此许可证的声明和没有担保的声明完
整无损，并和程序一起给每个其他的程序接受者一份许可证的副本，你就可以用任何媒体复制和发布你收到的
原始的程序的源代码。你也可以为转让副本的实际行动收取一定费用，但必须事先得到的同意。
二. 你可以修改本开源软件的一个或几个副本或程序的任何部分，以此形成基于程序的作品。只要你同时满足
下面的所有条件，你就可以按前面第一款的要求复制和发布这一经过修改的程序或作品。
1.你必须在修改的文件中附有明确的说明: 你修改了这一文件及具体的修改日期。
2.你必须使你发布或出版的作品（它包含程序的全部或一部分，或包含由程序的全部或部分衍生的作品）允许
第三方作为整体按许可证条款免费使用。
3.如果修改的程序在运行时以交互方式读取命令，你必须使它在开始进入常规的交互使用方式时打印或显示声
明: 包括适当的版权声明和没有担保的声明（或者你提供担保的声明）；用户可以按此许可证条款重新发布
程序的说明；并告诉用户如何看到这一许可证的副本。（例外的情况: 如果原始程序以交互方式工作，它并
不打印这样的声明，你的基于程序的作品也就不用打印声明。
三. 只要你遵循一、二条款规定，您就可以自由使用并传播本源代码，但必须原封不动地保留原作者信息。
===============================================================================================;
**********************************************************************************************|;
(defun c:lkk(/ 05pi 2pi ang bdata cadata color cx-end-jsq cx-jsq deleteduplicate deleteduplicate1 delss e0 e10 e11 ename ent ent1 lang ldata mat:rot2d matrotate msac msl n on_ent sdata ss tts)
;计时器开始******************函数作者: 哪个版主的，具体是谁忘了，请谅解
(defun cx-jsq () ;计时器开始
(setq time_tmp (getvar "TDUSRTIMER"))
)
;计时器结束*****************函数作者: 哪个版主的，具体是谁忘了，请谅解
(defun cx-end-jsq () ;计时器结束
(setq time_tmp (- (getvar "TDUSRTIMER") time_tmp)
;获得时间，单位小时
time_tmp (* time_tmp 86400)
) ;秒为单位
(prompt (strcat "用时" (rtos time_tmp 2 4) "秒"))
(setq time_tmp nil)
(princ)
)
;; 旋转向量到指定角度
(defun MatRotate (pt rad) (polar '(0 0) (+ (angle '(0 0) pt) rad) (distance '(0 0) pt)))
;圆弧起点包含再另外一个圆弧里面
(defun on_ent(a a1 a2) ;函数作者: 不详
(if (> a2 a1)
(or (equal a a2 1e-6) (equal a a1 1e-6) (> a2 a a1))
(or (equal a a2 1e-6) (equal a a1 1e-6) (< a a2) (> a a1)))
)
(defun color (ent / c62 ent1);函数作者: 易云网络
(setq ent1 (entget ent))
(if (and (setq c62 (cdr (assoc 62 ent1))) (/= 0 c62))
c62
(cdr (assoc 62 (entget (tblobjname "layer" (cdr(assoc 8 ent1))))))
)
)
(defun Deleteduplicate (ldata bdata sdata / a a1 a2 b abc ceshi ent ent1 lang lllzzz nm ssma )
(setq nm 0 )
(if sdata (setq sdata (vl-sort sdata '(lambda(e1 e2)(< (last e1)(last e2))))))
(while (or ldata bdata sdata)
(cond
(ldata
(setq lllzzz ;感谢edata
(vl-sort ldata
'(lambda(e1 e2 / a b)
(if
(equal (setq a (cadar e1)) (setq b (cadar e2)) 1e-5)
(< (caar e1)(caar e2))
(< a b)
)
)
)
ldata nil
)
)
(bdata
(setq lllzzz ;感谢edata
(vl-sort bdata
'(lambda(e1 e2 / a b)
(if
(equal (setq a(caar e1)) (setq b (caar e2)) 1e-5)
(< (cadar e1)(cadar e2))
(< a b)
)
)
)
bdata nil
)
)
(sdata
(setq
ssma '()
ssma (cons (setq a (car sdata)) ssma)
lang (last a)
sdata (cdr sdata)
a (car sdata)
)
(while (equal lang (last a) 1e-7);待定
(setq
sdata (cdr sdata)
ssma (cons a ssma)
a (car sdata)
)
)
(setq lllzzz ;感谢edata
(mapcar 'cdr(vl-sort ssma
'(lambda(e1 e2 / a b)
(if (equal (setq a (cadr(car e1))) (setq b (cadr(car e2))) 1e-5)
(< (caar e1) (caar e2))
(< a b)
)
)
)
)
)
)
)
;(ttbb lllzzz)
(setq
ent (car lllzzz)
a (car ent)
b (cadr ent)
ent (caddr ent)
lllzzz (cdr lllzzz)
ceshi nil
)
(repeat (length lllzzz)
(if (setq ent1 (car lllzzz))
(progn
(setq
a1 (car ent1)
a2 (cadr ent1)
ent1 (caddr ent1)
lllzzz (cdr lllzzz)
)
(if (equal (+ (distance a1 a) (distance a1 b)) (setq abc (distance a b)) 1e-5)
(cond
((equal (+ (distance a2 a) (distance a2 b)) abc 1e-5)
(if (and ceshi (not (car lllzzz)))
(progn
(ssadd ent delss) (ssadd ent1 delss)
(entmake (list '(0 . "LINE") (cons 10 a) (cons 62 (color ent))(cons 11 b)))
)
(progn
(ssadd ent1 delss)
(setq nm (1+ nm))
)
)
)
(t (ssadd ent1 delss)
(setq nm (1+ nm))
(if (car lllzzz)
(setq b a2 ceshi t)
(progn
(ssadd ent delss) (setq ceshi t)
(entmake (list '(0 . "LINE")(cons 10 a)(cons 62 (color ent))(cons 11 a2)))
)
)
)
)
(if ceshi
(progn
(ssadd ent delss)
(entmake (list '(0 . "LINE") (cons 10 a) (cons 62 (color ent))(cons 11 b)))
(setq a a1 b a2 ent ent1 ceshi nil)
)
(setq a a1 b a2 ent ent1)
)
)
)
)
)
)
(prompt (strcat "选到" (itoa msl) "个直线消去" (itoa nm) "个！"))
(setq tts (+ nm tts))
)
(defun Deleteduplicate1 (cadata / a ceshi ceshic e10 ent ent1 ent2 ept1 ept2 er lst lst5051 nm pd spt1 spt2 ssma yht)
(setq nm 0 cadata (vl-sort cadata
'(lambda(e1 e2 / a b)
(if (equal (car e1)(car e2) 1e-5)
(< (cadr e1)(cadr e2))
(if (equal (setq a (cadar e1)) (setq b (cadar e2)) 1e-5)
(< (caar e1) (caar e2))
(< a b)
)
)
)
)
)
(while cadata
(setq
ssma '()
ent (car cadata)
e10 (car ent)
er (cadr ent)
)
(if (= (type(last ent)) 'ENAME)
(progn
(setq
ceshiC t
cadata (cdr cadata)
a (car cadata)
)
(while(and (equal e10 (car a) 1e-7) (equal er (cadr a) 1e-7))
(ssadd (caddr a) delss)
(setq
nm (1+ nm )
cadata (cdr cadata)
a (car cadata)
)
)
)
(progn
(setq
ceshiC nil
ssma (cons ent ssma)
cadata (cdr cadata)
a (car cadata)
)
(while(and (equal e10 (car a) 1e-7) (equal er (cadr a) 1e-7))
(setq cadata (cdr cadata))
(if (= (type (last a)) 'ENAME)
(progn
(if (setq a (car cadata))
(while(and (equal e10 (car a) 1e-7) (equal er (cadr a) 1e-7))
(ssadd (caddr a) delss)
(setq
cadata (cdr cadata)
a (car cadata)
nm (1+ nm)
)
)
)
(setq ceshiC t)
)
(setq ssma (cons a ssma))
)
(setq a (car cadata))
)
)
)
(if ceshiC
(progn
(setq nm (+ (length ssma) nm))
(mapcar '(lambda (x) (ssadd (caddr x) delss)) ssma)
)
(progn
(setq
ssma (vl-sort ssma (function (lambda (e1 e2)(< (car (last e1)) (car (last e2))))))
lst (car ssma)
ent1 (caddr lst)
lst5051 (last lst)
spt1 (rem (car lst5051) 6.283185)
ept1 (rem (cadr lst5051) 6.283185)
yht nil
ceshi nil
)
(while (setq ssma (cdr ssma))
(setq
lst (car ssma)
ent2 (caddr lst)
lst5051 (last lst)
spt2 (rem (car lst5051)6.283185)
ept2 (rem (cadr lst5051)6.283185)
)
(if (on_ent spt2 spt1 ept1)
(cond
((on_ent ept2 spt1 ept1)
(if (<= spt1 ept2 spt2)
(progn
(entmake (list '(0 . "CIRCLE") (cons 62 (color ent1)) (cons 10 (car lst)) (cons 40 (cadr lst))))
(setq nm (+ (length ssma) nm))
(mapcar '(lambda (x) (ssadd (caddr x) delss)) ssma)
(ssadd ent1 delss)
(setq ssma nil)
)
(progn
(setq nm (1+ nm))
(ssadd ent2 delss)
(if (and yht (null (cadr ssma)))
(progn
(ssadd ent1 delss)
(entmake (list '(0 . "arc")
(cons 10 (car lst)) (cons 40 (cadr lst)) (cons 50 spt1) (cons 51 ept1)))
)
)
)
)
)
(t
(ssadd ent2 delss)
(setq nm (1+ nm))
(if (null (cadr ssma))
(progn
;(setq ceshi t)
(ssadd ent1 delss)
(entmake (list '(0 . "arc")
(cons 10 (car lst)) (cons 62 (color ent1)) (cons 40 (cadr lst)) (cons 50 spt1) (cons 51 ept2)))
)
(setq ept1 ept2 yht t)
)
)
)
(if (member ent1 ceshi)
(progn
(ssadd ent1 delss)
(entmake (list '(0 . "arc")
(cons 10 (car LST)) (cons 62 (color ent1)) (cons 40 (cadr LST)) (cons 50 spt1) (cons 51 ept1)))
(if (null (cadr ssma))
(progn
(ssadd ent2 delss)
(entmake (list '(0 . "arc")
(cons 10 (car LST)) (cons 62 (color ent2)) (cons 40 (cadr LST)) (cons 50 spt2) (cons 51 ept2)))
)
(setq
ent1 ent2
spt1 spt2
ept1 ept2
)
)
)
(setq
a (list(car LST)(cadr LST) ent1 (list spt1 ept1))
ceshi (cons ent1 ceshi)
ssma (reverse (cons a (reverse ssma)))
ent1 ent2
spt1 spt2
ept1 ept2)
)
)
)
)
)
)
(prompt (strcat "选到" (itoa msac) "个圆弧与圆消去" (itoa nm) "个！"))
(setq tts (+ nm tts))
)
(setvar "cmdecho" 0)
(prompt "\n请选择直线、圆弧或圆：")
(if (setq ss (ssget '((0 . "line,arc,circle"))))
(progn
(command "_.undo" "_be")
;(prompt "\n正在计算，请稍候...")
(cx-jsq)
(setq
jiaodu 0.000001 ;精度
2pi (* 2 pi)
05pi (/ pi 2)
delss (ssadd)
ldata '()
bdata '()
sdata '()
cadata '()
msl 0
msac 0
tts 0
)
(repeat (setq n (sslength ss))
(setq
ent (entget (ssname ss (setq n (1- n))))
e0 (cdr (assoc 0 ent))
ename (cdr (assoc -1 ent)) ;图元名
e10 (cdr (assoc 10 ent))
)
(cond
((= e0 "LINE")
(setq
msl (1+ msl)
e11 (cdr (assoc 11 ent))
ang (angle e10 e11)
lang (rem ang pi) ; lang (rem (+ 2pi ang) pi)
)
(if (equal e10 e11 1e-6) ;2015.8.27增加去除0长的线
(progn (ssadd ename delss) (setq tts (1+ tts)))
(progn
(if (or (equal ang pi 1e-8) (and (not (equal ang 2pi 1e-8)) (> ang pi)));增加一个判断2015.8.25
(setq ent (list e11 e10 ename lang))
(setq ent (list e10 e11 ename lang))
)
(cond
((equal 05pi lang 1e-8) (setq bdata (cons ent bdata))) ;纵线
((or (equal 0 lang 1e-8) (equal pi lang 1e-8)) (setq ldata (cons ent ldata))) ;横线
(t (setq sdata (cons (cons (MatRotate (car ent) (* -1. lang)) ent) sdata))) ;斜线
)
)
)
)
(t
(setq
msac (1+ msac)
ent1 (list ename (cdr (assoc 40 ent)) e10)
)
(if (= e0 "ARC")
(setq ent1 (cons (list (cdr (assoc 50 ent)) (cdr (assoc 51 ent))) ent1))
)
(setq cadata (cons (reverse ent1) cadata))
)
)
)
(if (> msl 1) (Deleteduplicate ldata bdata sdata))
(if (> msac 1) (Deleteduplicate1 cadata))
(if (> (sslength delss) 0)
(progn
(princ"\n共删除了：<")(princ tts)(princ" >个重复对象")
(command "_.erase" delss "")
(princ"\n")(cx-end-jsq)
)
(prompt "\n没有重复实体！")
)
(command "_.undo" "_e")
)
)
(princ)
)

;|*********************************************************************************************; 
软件作者: 易云网络 
当前版本1.03    
 
版本1.03   
修改一些BUG，结构上有一些调整，理论要快点 
修改时间：2015.09.02 
 
版本1.02 
2015.8.27增加去除0长的线， 
对排序函数精度降低至1E-5 
删除一些无用变量 
 
版本1.01                                                                                               ； 
修改时间：2015.8.25   
修改一个BUG增加一个判断有的线是(angle e10 e11)的弧度是2*PI 会出现BUG 
 
; 
===============================================================================================; 
本软件为开源软件: 以下是开源申明:                                                 
-----------------------------------------------------------------------------------------------; 
本页面的软件遵照GPL协议开放源代码，您可以自由传播和修改，在遵照下面的约束条件的前提下:    
 
一. 只要你在本开源软件的每一副本上明显和恰当地出版版权声明，保持此许可证的声明和没有担保的声明完 
整无损，并和程序一起给每个其他的程序接受者一份许可证的副本，你就可以用任何媒体复制和发布你收到的 
原始的程序的源代码。你也可以为转让副本的实际行动收取一定费用，但必须事先得到的同意。    
 
二. 你可以修改本开源软件的一个或几个副本或程序的任何部分，以此形成基于程序的作品。只要你同时满足 
下面的所有条件，你就可以按前面第一款的要求复制和发布这一经过修改的程序或作品。       
1.你必须在修改的文件中附有明确的说明: 你修改了这一文件及具体的修改日期。       
2.你必须使你发布或出版的作品（它包含程序的全部或一部分，或包含由程序的全部或部分衍生的作品）允许 
第三方作为整体按许可证条款免费使用。                
3.如果修改的程序在运行时以交互方式读取命令，你必须使它在开始进入常规的交互使用方式时打印或显示声 
明: 包括适当的版权声明和没有担保的声明（或者你提供担保的声明）；用户可以按此许可证条款重新发布 
程序的说明；并告诉用户如何看到这一许可证的副本。（例外的情况: 如果原始程序以交互方式工作，它并 
不打印这样的声明，你的基于程序的作品也就不用打印声明。                      
 
三. 只要你遵循一、二条款规定，您就可以自由使用并传播本源代码，但必须原封不动地保留原作者信息。   
===============================================================================================; 
**********************************************************************************************|; 
 
(defun c:lkk(/ 05pi 2pi ang bdata cadata color cx-end-jsq cx-jsq deleteduplicate deleteduplicate1 delss e0 e10 e11 ename ent ent1 lang ldata mat:rot2d matrotate msac msl n on_ent sdata ss tts) 
   
  ;计时器开始******************函数作者: 哪个版主的，具体是谁忘了，请谅解 
  (defun cx-jsq () ;计时器开始 
    (setq time_tmp (getvar "TDUSRTIMER")) 
  ) 
   
  ;计时器结束*****************函数作者: 哪个版主的，具体是谁忘了，请谅解 
  (defun cx-end-jsq () ;计时器结束 
    (setq  time_tmp (- (getvar "TDUSRTIMER") time_tmp) 
      ;获得时间，单位小时 
      time_tmp (* time_tmp 86400) 
    ) ;秒为单位 
    (prompt (strcat "用时" (rtos time_tmp 2 4) "秒")) 
    (setq time_tmp nil) 
    (princ) 
  ) 
   
  ;; 旋转向量到指定角度 
  (defun MatRotate (pt rad) (polar '(0 0) (+ (angle '(0 0) pt) rad) (distance '(0 0) pt))) 
   
   
  ;圆弧起点包含再另外一个圆弧里面 
  (defun on_ent(a a1 a2) ;函数作者: 不详    
    (if (> a2 a1) 
      (or (equal a a2 1e-6) (equal a a1 1e-6) (> a2 a a1)) 
      (or (equal a a2 1e-6) (equal a a1 1e-6) (< a a2) (> a a1))) 
  ) 
   
  (defun color (ent / c62 ent1);函数作者: 易云网络 
    (setq ent1 (entget ent)) 
    (if (and (setq c62 (cdr (assoc  62 ent1))) (/= 0 c62)) 
      c62 
      (cdr (assoc  62 (entget (tblobjname "layer" (cdr(assoc  8 ent1)))))) 
    ) 
  ) 
   
  (defun Deleteduplicate (ldata bdata sdata / a a1 a2 b abc ceshi ent ent1 lang lllzzz nm ssma ) 
    (setq nm 0 ) 
    
    (if sdata  (setq sdata (vl-sort sdata   '(lambda(e1 e2)(< (last e1)(last e2)))))) 
    
    (while (or ldata bdata sdata) 
      (cond 
        (ldata    
          (setq lllzzz                ;感谢edata 
            (vl-sort ldata 
              '(lambda(e1 e2 / a b) 
                 (if 
                   (equal (setq a (cadar e1)) (setq b (cadar e2)) 1e-5) 
                   (< (caar e1)(caar e2)) 
                   (< a b) 
                 ) 
               ) 
            ) 
            ldata nil 
          ) 
        ) 
         
        (bdata    
          (setq lllzzz                ;感谢edata 
            (vl-sort bdata 
              '(lambda(e1 e2 / a b) 
                 (if 
                   (equal (setq a(caar e1))  (setq b (caar e2)) 1e-5) 
                   (< (cadar e1)(cadar e2)) 
                   (< a b) 
                 ) 
               ) 
            ) 
            bdata nil 
          ) 
        ) 
         
        (sdata 
          (setq 
            ssma  '() 
            ssma  (cons (setq a (car sdata)) ssma) 
            lang  (last a) 
            sdata (cdr sdata) 
            a     (car sdata) 
          ) 
          
          (while (equal lang (last a) 1e-7);待定 
            (setq 
              sdata (cdr sdata) 
              ssma  (cons a ssma) 
              a     (car sdata) 
            ) 
          ) 
          
          (setq lllzzz                ;感谢edata 
            (mapcar 'cdr(vl-sort ssma 
                          '(lambda(e1 e2 / a b) 
                             (if  (equal (setq a (cadr(car e1))) (setq b (cadr(car e2))) 1e-5) 
                               (< (caar e1) (caar e2)) 
                               (< a b) 
                             ) 
                           ) 
                        ) 
            ) 
          ) 
        ) 
      ) 
       
       
      ;(ttbb lllzzz) 
       
      (setq 
        ent    (car lllzzz) 
        a      (car ent)    
        b      (cadr ent) 
        ent    (caddr ent) 
        lllzzz (cdr lllzzz) 
        ceshi  nil 
      ) 
       
      (repeat (length lllzzz) 
        (if (setq ent1  (car lllzzz)) 
          (progn 
            (setq 
              a1     (car   ent1) 
              a2     (cadr  ent1) 
              ent1   (caddr ent1) 
              lllzzz (cdr lllzzz) 
            ) 
             
            (if (equal (+ (distance a1 a) (distance a1 b)) (setq abc (distance a b)) 1e-5) 
               
              (cond   
                ((equal (+ (distance a2 a) (distance a2 b)) abc 1e-5) 
                  (if (and ceshi (not (car lllzzz))) 
                    (progn                   
                      (ssadd ent delss) (ssadd ent1 delss) 
                      (entmake (list '(0 . "LINE") (cons 10 a) (cons 62 (color ent))(cons 11 b)))   
                    ) 
                    (progn               
                      (ssadd ent1 delss) 
                      (setq nm (1+ nm)) 
                    ) 
                  ) 
                ) 
                (t (ssadd ent1 delss) 
                  (setq nm (1+ nm)) 
                  (if (car lllzzz) 
                    (setq b a2 ceshi t) 
                    (progn 
                      (ssadd ent delss) (setq ceshi t) 
                      (entmake (list '(0 . "LINE")(cons 10 a)(cons 62 (color ent))(cons 11 a2))) 
                    ) 
                  ) 
                ) 
              ) 
              (if ceshi 
                (progn                   
                  (ssadd ent delss) 
                  (entmake (list '(0 . "LINE") (cons 10 a) (cons 62 (color ent))(cons 11 b)))   
                  (setq a a1 b a2 ent ent1 ceshi nil) 
                ) 
                (setq a a1 b a2 ent ent1) 
              ) 
            ) 
          ) 
        ) 
      ) 
    ) 
    (prompt (strcat "选到" (itoa msl) "个直线消去" (itoa nm) "个！")) 
    (setq tts (+ nm tts)) 
  ) 
   
  (defun Deleteduplicate1 (cadata / a ceshi ceshic e10 ent ent1 ent2 ept1 ept2 er lst lst5051 nm pd spt1 spt2 ssma yht) 
    
    (setq nm 0  cadata  (vl-sort cadata 
                          '(lambda(e1 e2 / a b) 
                             (if (equal (car e1)(car e2) 1e-5) 
                               (< (cadr e1)(cadr e2)) 
                               (if  (equal (setq a (cadar e1)) (setq b (cadar e2)) 1e-5) 
                                 (< (caar e1) (caar e2)) 
                                 (< a b) 
                               ) 
                             ) 
                           ) 
                        ) 
    ) 
    
    (while cadata 
      (setq 
        ssma '() 
        ent   (car cadata) 
        e10   (car ent) 
        er    (cadr ent) 
      ) 
       
      (if (= (type(last ent)) 'ENAME) 
        (progn 
          (setq 
            ceshiC t 
            cadata (cdr cadata) 
            a      (car cadata) 
          ) 
          (while(and (equal e10 (car a) 1e-7) (equal er (cadr a) 1e-7)) 
            (ssadd (caddr a) delss) 
            (setq 
              nm     (1+  nm    ) 
              cadata (cdr cadata) 
              a      (car cadata) 
            ) 
          ) 
        ) 
        (progn 
          (setq 
            ceshiC nil 
            ssma   (cons ent ssma) 
            cadata (cdr cadata) 
            a      (car cadata) 
          ) 
          
          (while(and (equal e10 (car a) 1e-7) (equal er (cadr a) 1e-7)) 
            (setq cadata (cdr cadata)) 
             
            (if (= (type (last a)) 'ENAME) 
              (progn 
                (if (setq a  (car cadata)) 
                  (while(and (equal e10 (car a) 1e-7) (equal er (cadr a) 1e-7)) 
                    (ssadd (caddr a) delss) 
                    (setq 
                      cadata (cdr cadata) 
                      a      (car cadata) 
                      nm     (1+ nm) 
                    ) 
                  ) 
                ) 
                (setq  ceshiC t) 
              ) 
              (setq  ssma  (cons a ssma)) 
            ) 
            (setq a (car cadata)) 
          ) 
        ) 
      ) 
       
      (if ceshiC 
        (progn 
          (setq nm (+ (length ssma) nm)) 
          (mapcar '(lambda (x) (ssadd (caddr x) delss)) ssma) 
        ) 
         
        (progn 
          (setq 
            ssma    (vl-sort  ssma (function (lambda (e1 e2)(< (car (last e1)) (car (last  e2)))))) 
            lst     (car ssma) 
            ent1    (caddr lst) 
            lst5051 (last lst) 
            spt1    (rem (car  lst5051)  6.283185) 
            ept1    (rem (cadr lst5051)  6.283185) 
            yht     nil 
            ceshi   nil 
          ) 
          (while  (setq ssma  (cdr ssma)) 
            (setq 
              lst     (car ssma) 
              ent2    (caddr lst) 
              lst5051 (last lst) 
              spt2    (rem (car  lst5051)6.283185) 
              ept2    (rem (cadr lst5051)6.283185) 
            ) 
             
            (if (on_ent spt2 spt1 ept1) 
              (cond   
                ((on_ent ept2 spt1 ept1) 
                  (if (<= spt1 ept2 spt2) 
                    (progn 
                      (entmake (list '(0 . "CIRCLE") (cons 62 (color ent1)) (cons 10 (car lst)) (cons 40 (cadr lst)))) 
                      (setq nm (+ (length ssma) nm)) 
                      (mapcar '(lambda (x) (ssadd (caddr x) delss)) ssma) 
                      (ssadd ent1 delss) 
                      (setq ssma  nil)   
                    ) 
                    (progn 
                      (setq nm (1+ nm)) 
                      (ssadd ent2 delss) 
                      (if (and yht (null (cadr ssma))) 
                        (progn 
                          (ssadd ent1 delss) 
                          (entmake (list '(0 . "arc") 
                                     (cons 10 (car lst)) (cons 40 (cadr lst)) (cons 50 spt1) (cons 51 ept1))) 
                        ) 
                      ) 
                    ) 
                  ) 
                ) 
                (t 
                  (ssadd ent2 delss) 
                  (setq nm (1+ nm)) 
                  (if (null (cadr ssma)) 
                    (progn 
                      ;(setq ceshi t) 
                      (ssadd ent1 delss) 
                      (entmake (list '(0 . "arc") 
                                 (cons 10 (car lst)) (cons 62 (color ent1)) (cons 40 (cadr lst)) (cons 50 spt1) (cons 51 ept2))) 
                    ) 
 
                    (setq ept1 ept2 yht t) 
                  ) 
                ) 
              ) 
              (if (member ent1 ceshi) 
                (progn 
                  (ssadd ent1 delss) 
                  (entmake (list '(0 . "arc") 
                             (cons 10 (car LST)) (cons 62 (color ent1)) (cons 40 (cadr LST)) (cons 50 spt1) (cons 51 ept1))) 
                  (if (null (cadr ssma)) 
                    (progn 
                      (ssadd ent2 delss) 
                      (entmake (list '(0 . "arc") 
                                 (cons 10 (car LST)) (cons 62 (color ent2)) (cons 40 (cadr LST)) (cons 50 spt2) (cons 51 ept2))) 
                    ) 
                    (setq   
                      ent1 ent2 
                      spt1 spt2   
                      ept1 ept2 
                    ) 
                  ) 
                ) 
                  (setq    
                    a     (list(car LST)(cadr LST) ent1 (list spt1 ept1)) 
                    ceshi (cons ent1 ceshi)   
                    ssma  (reverse (cons a (reverse  ssma))) 
                    ent1 ent2 
                    spt1 spt2   
                    ept1 ept2) 
              ) 
            ) 
          ) 
        ) 
      ) 
    ) 
    (prompt (strcat "选到" (itoa msac) "个圆弧与圆消去" (itoa nm) "个！")) 
    (setq tts (+ nm tts)) 
  ) 
   
   
   
  (setvar "cmdecho" 0) 
  (prompt "\n请选择直线、圆弧或圆：") 
  (if (setq ss (ssget '((0 . "line,arc,circle")))) 
    (progn 
      (command "_.undo" "_be") 
      ;(prompt "\n正在计算，请稍候...") 
      (cx-jsq) 
      (setq   
        jiaodu  0.000001     ;精度 
        2pi     (* 2 pi) 
        05pi    (/ pi 2) 
        delss   (ssadd) 
        ldata   '()   
        bdata   '() 
        sdata   '() 
        cadata  '()    
        msl      0   
        msac     0 
        tts      0 
      ) 
       
      (repeat (setq n (sslength ss)) 
        (setq 
          ent (entget (ssname ss (setq n (1- n)))) 
          e0    (cdr (assoc 0 ent)) 
          ename (cdr (assoc -1 ent)) ;图元名 
          e10   (cdr (assoc 10 ent)) 
        ) 
        (cond 
          ((= e0 "LINE") 
            (setq 
              msl   (1+ msl) 
              e11   (cdr (assoc 11 ent)) 
              ang   (angle e10 e11) 
              lang  (rem ang pi)   ;  lang  (rem (+ 2pi ang) pi) 
            ) 
             
            (if (equal e10 e11 1e-6) ;2015.8.27增加去除0长的线 
              (progn (ssadd ename delss) (setq tts (1+ tts))) 
              (progn 
                (if (or (equal ang pi 1e-8) (and (not (equal ang 2pi 1e-8)) (> ang pi)));增加一个判断2015.8.25 
                  (setq ent  (list  e11 e10 ename lang)) 
                  (setq ent  (list  e10 e11 ename lang)) 
                ) 
                (cond 
                  ((equal 05pi lang 1e-8)  (setq bdata (cons ent bdata)))  ;纵线 
                  ((or (equal 0 lang 1e-8) (equal pi lang 1e-8)) (setq ldata (cons ent ldata)))  ;横线 
                  (t (setq sdata (cons (cons (MatRotate (car ent) (* -1. lang))  ent) sdata)))  ;斜线 
                ) 
              ) 
            ) 
          ) 
          (t 
            (setq 
              msac   (1+ msac) 
              ent1   (list ename  (cdr (assoc 40 ent)) e10) 
            ) 
            (if (= e0 "ARC") 
              (setq ent1  (cons (list (cdr (assoc 50 ent)) (cdr (assoc 51 ent))) ent1)) 
            ) 
            (setq cadata (cons (reverse ent1) cadata)) 
          ) 
        ) 
      ) 
       
       
      (if (> msl  1) (Deleteduplicate ldata bdata sdata)) 
      (if (> msac 1) (Deleteduplicate1 cadata)) 
       
       
      (if (> (sslength  delss) 0) 
        (progn 
          (princ"\n共删除了：<")(princ tts)(princ" >个重复对象") 
          (command "_.erase" delss "") 
          (princ"\n")(cx-end-jsq) 
        ) 
        (prompt "\n没有重复实体！") 
      ) 
      (command "_.undo" "_e") 
    ) 
    
  ) 
   
  (princ) 
)

版本1.02
2015.8.27增加去除0长的线，
对排序函数精度降低至1E-5
删除一些无用变量

版本1.01 ；
修改时间：2015.8.25 18：50
修改一个BUG,增加一个判断.
有的线(angle e10 e11)算出来的的弧度居然是2*PI

文档已经更新：2015.8.24 18:59
已知BUG已经更新

命令: lkk
请选择直线、圆弧或圆：
选择对象: 指定对角点: 找到 23570 个
选择对象:
正在消除合并重复线条，请稍候...
选到5376个直线消去4626个！选到18194个圆弧与圆消去18018个！
共删除了：<22644 >个重复对象用时1.9930秒

LKK附件理论应该还要快一点(只针对测试情况)，（有可能有BUG目前还没发现）所以暂时收币

院长观察的真仔细已经更新了就忙着想算法了，没留意结构
欢迎下载测试图进行测试()

479274135 · 发表于 2018-4-17 10:40:07

厉害收藏了

F4164789 · 发表于 2015-8-22 19:25:07

不错下载用下

edata · 发表于 2015-8-22 20:40:05

效率果然高，不知道和overkill相比较如何，本子上没装ET，暂时无法测试，试过某插件直接卡死，这个算法值得研究，楼主可否介绍下，代码太长，而且不熟悉，介绍下会比较容易理解。
相对的，处理交点打断之类的，也是否高效呢。。

429014673 · 发表于 2015-8-22 20:57:06

支持的类型太少了，应该搞一个支持所有类型的。

xiaotao · 发表于 2015-8-22 21:16:19

刚测试了下，针对 CIRCLE ARC LINE 目前为止这个是速度最快处理得也是最理想的lsp程序！比OVERKILL快多了。

易云网络 · 发表于 2015-8-22 22:22:33

本帖最后由易云网络于 2015-8-22 22:24 编辑

edata 发表于 2015-8-22 20:40
效率果然高，不知道和overkill相比较如何，本子上没装ET，暂时无法测试，试过某插件直接卡死，这个算法值得 ...

c选择集按照
横线，  ldata (list 小  大图元名))
竖线，  bdata  (list 小  大图元名))
斜线 sdata  (list （运用高飞老师的矩阵点变换成横线的点“小”）小大图元名  (angle 小大)))
圆弧和园 cadata (list 圆心 R 图元名（如果是圆弧这里就是50 51组码）))
分别按照表分类
再对表进行排序从小到大
再进行判断基本不用重复计算（速度快就是因为这个）

唯一遗憾的是园和圆弧排序的地方

现在是按照圆心排序的，（缺少再从小到大排序）上次那个奇怪的表排序搞了好几天都没搞定，到现在对排序函数还没掌握好
(while (and (equal e10 (car a) 1e-7) (equal er (cadr a) 1e-7))
因为排序过了所以同心圆和或同心的圆弧的10组码相同，所以可以同时处理圆和圆弧
当搜寻到(last lst)是图元名的时候就可以把循环得到的表（圆心和R相同圆和圆弧）全部删除

这里可能会存在BUG（给您解释的时候发现的，麻烦您把红色的部分补上）
圆心相同但半径顺序不同程序可能会清理不彻底（家里的电脑硬盘坏了，测试不了）

易云网络 · 发表于 2015-8-22 22:23:41

xiaotao 发表于 2015-8-22 21:16
刚测试了下，针对 CIRCLE ARC LINE 目前为止这个是速度最快处理得也是最理想的lsp程序！比OVERKILL快多了。 ...

目前理论发现BUG 谢谢测试

edata · 发表于 2015-8-23 09:45:04

用OVERkill测试了下，发现，overkill速度慢点不说，还有清理不干净的线，圆弧直接kill，剩余最后一条，overkill果然太老了。
至于你说的同心圆BUG，是存在的。
你将排序函数首先按圆心，圆心相同则按半径。
具体怎么融合代码。还得靠你才行，排序的原理就是这样的。

(setq l(list (list "圆心" 10 "ename")(list "圆心" 5 "ename")(list "圆心" 3 "ename")(list "圆心2" 6 "ename")(list "圆心2" 3 "ename")))
(("圆心" 10 "ename") ("圆心" 5 "ename") ("圆心" 3 "ename") ("圆心2" 6 "ename") ("圆心2" 3 "ename"))
_$ (vl-sort l '(lambda(e1 e2)(if (equal (car e1)(car e2) 1e-7)(< (cadr e1)(cadr e2))(< (car e1)(car e2)))))
(("圆心" 3 "ename") ("圆心" 5 "ename") ("圆心" 10 "ename") ("圆心2" 3 "ename") ("圆心2" 6 "ename"))
_$

xyccf · 发表于 2015-8-23 09:49:32

感谢楼主分享感

cable2004 · 发表于 2015-8-23 12:29:28

有效的分类，降低循环的数量级！提高效率！

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

[源码] 直线，圆弧的圆去虫复,效率很(超)高（目前已知问题全部解决）~~欢迎品鉴和踢馆

本帖子中包含更多资源

点评

评分

本帖被以下淘专辑推荐: