- 积分
- 15319
- 明经币
- 个
- 注册时间
- 2002-2-9
- 在线时间
- 小时
- 威望
-
- 金钱
- 个
- 贡献
-
- 激情
-
|
发表于 2003-8-13 16:19:00
|
显示全部楼层
试试这个,不过只是对付Line线的
;;;标题: 【解决方案】消除重线的LISP程序，使用纯LISP函，
;;;适用于任何AUTOCAD平台。不考虑图层，只要是重线就处理。
;;;________________________________________________________
(defun ww ()
(setq ls (Entsel "\n 请选取一条直线:..."))
(setq ls (car ls))
(setq p1 (trans (cdr (Assoc 10 (entget ls))) 0 1)
p2 (trans (cdr (Assoc 11 (entget ls))) 0 1)
)
(setq ls (angle p1 p2)
ls1 (+ ls (* pi 1.5))
)
(setq p0 (getpoint "\n 请输入一个点!.."))
;;; (setq p0 (trans p0 1 0))
(setq pe (polar p0 ls1 1))
(setq pp (inters p1 p2 p0 pe nil))
(setq #l (distance pp p0))
(princ "\n 距离为:")
(princ #l)
)
;;;________________________________________________________
;;;内容:
;;;清重 LINE
;;;消除重线，不生成任何新的LINE
;;;程序没考虑图层，只要是重线，就处理
;;;内有详细的注释，帮助朋友理解开发思路。
;;;这个程序很复杂，用了很多技巧。希望能对朋友有帮助
;;;命令：c:rdup
(setvar "cmdecho" 0)
;;;子程序 (ran), 将LISP表按关键字排序。参数 'a' 为要排序的LISP表。
;;;例如执行程序: (ran '((3 3.2) (5.4 4.8) (3 3) (-0.4 5.5) (3 3)))
;;;该程序将返回: ((-0.4 5.5) (3 3) (3 3.2) (5.4 4.8))
(defun ran (a / b c d mn mx)
(setq c (mapcar 'car a)
mn (apply 'min c)
mn (1- mn)
)
(while (< mn (setq mx (apply 'max c)))
(setq c (subst mn mx c))
(while (setq d (assoc mx a))
(setq a (subst '(nil) d a)
b (cons d b)
)
)
)
b
)
;;;子程序 (rz), 消去点 'p' 的 Z-坐标。
(defun rz (p) (list (car p) (cadr p)))
;;;子程序 (p-l1), 求点到直线距离程序的前半部分 (求常数'c1','c2'和'c3')。
;;;参数 'p1' 和 'p2' 为直线的两个端点。
(defun p-l1 (p1 p2 / x1 y1 x2 y2)
(setq x1 (car p1)
y1 (cadr p1)
x2 (car p2)
y2 (cadr p2)
c1 (- y2 y1)
c2 (- x1 x2)
c3 (sqrt (+ (* c1 c1) (* c2 c2)))
c1 (/ c1 c3)
c2 (/ c2 c3)
c3 (/ (- (* x2 y1) (* x1 y2)) c3)
)
)
;;;子程序 (p-l2), 求点到直线距离程序的后半部分 (返回距离值)。
;;;参数 'p0' 为点坐标。
(defun p-l2 (p0) (+ (* c1 (car p0)) (* c2 (cadr p0)) c3))
;;;子程序 (rddo1), 合并一条直线上的各线段。
(defun rddo1 (l2 / e el c1 c2 c3 ln1 ll1 ll2 ll3 ll4 lle len len1 p z)
(setq ll (car l2)
p1 (car ll)
p2 (cadr ll)
a1 (angle p1 p2)
p3 (polar p1 (+ pi2 a1) mx)
n (+ n (length l2))
)
;;;分别求出直线上某点到各线段上两个端点的距离, 并与实体名一同存入表 'll1'。
;;;表 'll1' 的格式为 ((距离1 实体名1) (距离2 实体名2) . . .)。
;;;'lle' 为各线段的实体名表, 格式为 (实体名1 实体名2 . . .)
(p-l1 p1 p3)
(foreach ll l2
(setq e (last ll)
ll1 (cons (list (p-l2 (car ll)) e) ll1)
ll1 (cons (list (p-l2 (cadr ll)) e) ll1)
lle (cons e lle)
)
)
;;;'ll2' 为临时实体名表, 格式为 (实体名1 实体名2 . . .)。
;;;'ll4' 为合并完成后的线段表, 格式为 ((首端1 . 末端1) (首端2 . 末端2) . . .)。
(setq ll1 (ran ll1)
ln1 (+ mx (caar ll1))
ll4 nil
)
(foreach ll ll1
(setq ln (car ll)
e (cadr ll)
)
(if ll2
(progn
;;;此时有重叠的线段。
(setq ll3 (member e ll2)
ll2 (if ll3
(append (cdr ll3) (cdr (member e (reverse ll2))))
;;;结束一条重线。
(cons e ll2) ;将新重线的实体名加入 'll2'。
)
)
(if (not ll2)
;;;结束一条线的合并, 将其存入 'll4'。
(setq ll4 (cons (cons (polar p1 a1 ln) p2) ll4)
ln1 ln
)
)
)
(progn
;;;此时没有重叠的线段。
(if (equal ln1 ln mm)
(setq ll4 (cdr ll4)) ;消去前一条线, 使首尾相接的两条线连续。
(setq p2 (polar p1 a1 ln)) ;求出一条新线的起始点。
)
(setq ll2 (cdr ll)) ;将起点实体名加入 'll2'。
)
)
)
(if (> (setq len (length ll4)
len1 (length lle)
)
len
)
(progn
(repeat (- len1 len)
(setq e (car lle)
lle (cdr lle)
)
(entdel e)
)
;;;用表 'll4' 中的线段更新表 'lle' 中的线段。
(foreach ll ll4
(setq e (car lle)
lle (cdr lle)
el (entget e)
p (assoc 10 el)
z (cdddr p)
el (subst (cons 10 (append (car ll) z)) p el)
el (subst (cons 11 (append (cdr ll) z)) (assoc 11 el) el)
)
(entmod el)
)
)
)
(setq n (- n len))
;;;每画 40 根线, 在提示行更新一次报数。
(if (> (- n n2) 40)
(progn
(setq n2 n)
(princ (strcat st2 (itoa n)))
)
)
)
;;;子程序 (rddo), 对一组同角度的线段进行重线合并。
;;;参数 'l0' 为线段表, 其格式为
;;; ((首端1 末端1 实体名1) (首端2 末端2 实体名2) . . .)。
(defun rddo (l0 / e1 a1 p1 p2 p3 c1 c2 c3 ln l1 l2 ll ll1)
(setq ll (car l0)
p1 (car ll)
p2 (cadr ll)
l1 (list (list 0. ll))
)
;;;将 'l0' 中各项, 按距离进行分类存入表 'l1'
;;;'l1' 的格式为 ((距离1 (首端1 末端1 实体名1)
;;; (首端2 末端2 实体名2) . . .) . . .)
(p-l1 p1 p2)
(foreach ll (cdr l0)
;;;变量 'ln' 为该线段与首根直线的距离。
(setq ln (p-l2 (car ll))
l2 l1
)
(while (and (setq ll1 (car l2)) (not (equal ln (car ll1) mm)))
(setq l2 (cdr l2))
)
;;;将距离值近似的线段归入同一个子表内, 否则另开一个新的子表。
(setq l1 (if ll1
(subst (append ll1 (list ll)) ll1 l1)
(cons (list ln ll) l1)
)
)
)
;;;对表 'l1' 中各组同距离 (即在一条直线上) 的线段进行重线合并。
(foreach l2 l1
(setq l2 (cdr l2))
(if (cdr l2)
(rddo1 l2)
) ;一组线多于一根才进行处理。
)
)
;;;主程序 (c:rdup), 合并或去除重线 (处理图内全部 LINE 实体)。
(defun c:rdup (/ osm mm mx pi2 st1 st2 ss1 e1 el1 n n1 n2 a1 p1 p2 l1 ll
ll1)
(gc)
(prompt "\n选取要处理的LINE<全选>:")
(if (not (setq ss1 (ssget '((0 . "LINE")))))
(setq ss1 (ssget "x" '((0 . "LINE"))))
)
;;;变量 'mm' 为距离微量 (在该距离内的线段均视为重合)。
(command "undo" "be")
(setq osm (getvar "osmode")
mx (getvar "viewsize")
mm (* 3e-4 mx)
pi2 (/ pi 2)
st1 "\r搜索到直线数： "
st2 "\r已经去除重线数： "
n 0
n1 0
n2 0
)
(setvar "osmode" 0)
(setvar "highlight" 0)
(princ "\n")
;;;对全体 LINE 实体, 按角度进行分类存入表 'l1'。
;;;'l1' 的格式为 ((角度1 (首端1 末端1 实体名1)
;;; (首端2 末端2 实体名2) . . .) . . .)。
(while (setq e1 (ssname ss1 n))
(setq n (1+ n)
el1 (entget e1)
p1 (rz (cdr (assoc 10 el1)))
p2 (rz (cdr (assoc 11 el1)))
)
(if (equal p1 p2 mm)
(progn;;;线段长度小于 'mm', 认为是超短线, 做擦除处理。
(entdel e1)
(setq n1 (1+ n1))
);;;将角度值近似的线段归入同一个子表内, 否则另开一个新的子表。
(setq ll1 (list (list p1 p2 e1))
a1 (angle p1 p2)
a1 (rtos (if (< a1 pi)
a1
(- a1 pi)
)
2
3
)
ll (assoc a1 l1)
l1 (if ll
(subst (append ll ll1) ll l1)
(cons (cons a1 ll1) l1)
)
)
)
;;;每处理 128 根线, 在提示行更新一次报数。
(if (= 127 (logand 127 n))
(princ (strcat st1 (itoa n)))
)
)
(princ (strcat st1
(itoa n)
(if (zerop n1)
""
(strcat ". 删除超短线 " (itoa n1))
)
".\n"
)
)
(setq n1 (- n n1)
n 0
);;;对表 'l1' 中各组同角度的线段进行重线合并。
(foreach ll l1
(setq ll (cdr ll))
(if (cdr ll)
(rddo ll)
);;;一组线多于一根才进行处理。
)
(princ (strcat st2
(itoa n)
". 还剩 "
(itoa (- n1 n))
" 条线."
)
)
(redraw)
(command "undo" "e")
(setvar "osmode" osm)
(setvar "highlight" 1)
(princ)
) |
|
[复制链接]
置顶卡
变色卡
显身卡
楼主
发表于 2003-8-4 17:20:00
