请高手帮修改一个程序

zedcar

　　　在网上找的一个删除重复图元的ＬＩＳＰ程序　加载使用后发现对重复线段的删除有时候无效　而且线段内部的线段无法删除　就是说如果一条线段长１００一条长５０　使用这个删除不掉！！请高手帮忙修改下！！
　以下是程序原文：（附件内容是程序源文件）
3 R+ X6 Q! l$ v6 e; ^$ j(defun c:ere()
5 H3 x$ L( R. [  (setq m0 (getpoint "\n左下角："))
/ I: s( V7 d; c! F+ I8 m% P! u  (setq m1 (getpoint "\n右上角："))
  (setq x0 (car m0) x1 (car m1) y0 (cadr m0) y1 (cadr m1) m2 m0 x2 x0 y2 y0)
9 `* B" X$ _; ~$ c, V6 ?; \# O  (while (< x2 x1)
; p- o+ E# Q/ _: I8 n, A    (setq y2 y0 m3 m2)
/ b/ t3 M# ?3 Y) b+ i0 v    (while (< y2 y1)
      (setq m4 (polar m3 0.785398 70.72))
      (setq a (ssget "_C" m3 m4))
' J3 N: P, }# O- z7 H) m: V! J      (if (not a)(setq i 0)(setq i (sslength a)))
      (while (> i 1)
4 o& A* n: w+ K& {, d        (setq j (- i 1))
        (setq b (ssname a (setq i (1- i)))) ;(setq b (ssname a 1))
1 `+ S2 Y5 d1 G9 \        (setq c (entget b))
# \/ X; n( v% V) n: W4 ]5 A$ i& R        (setq d (cdr (assoc 0 c)))
        (while (> j 0)
0 f0 G% H% u% u- ^/ `5 G; C! o( I          (setq b1 (ssname a (setq j (1- j))))
          (setq c1 (entget b1))
          (setq d1 (cdr (assoc 0 c1)))
          (if (= d d1)
            (if (= d "LINE")
  T0 |' \( s- ]8 R              (if (and (= (rtos (cadr (assoc 10 c)) 2 4)(rtos (cadr (assoc 10 c1)) 2 4))
                       (= (rtos (caddr (assoc 10 c)) 2 4)(rtos (caddr (assoc 10 c1)) 2 4))
                       (= (rtos (cadr (assoc 11 c)) 2 4)(rtos (cadr (assoc 11 c1)) 2 4))
. p: Q0 ~) Q! M8 u8 R                       (= (rtos (caddr (assoc 11 c)) 2 4)(rtos (caddr (assoc 11 c1)) 2 4))
  [, S) H* c2 O) S- @                  )(command "erase" b1 "")
# e" `* {$ T  K              )
1 q2 R1 l- k) Q  S" n; `5 y              (if (= d "INSERT")
                (if (and (equal (assoc 2 c) (assoc 2 c1))
                         (= (rtos (cadr (assoc 10 c)) 2 4)(rtos (cadr (assoc 10 c1)) 2 4))
                         (= (rtos (caddr (assoc 10 c)) 2 4)(rtos (caddr (assoc 10 c1)) 2 4))
                    )(command "erase" b1 "")
                )
                (if (= d "LWPOLYLINE")
: j' R5 k9 ]( q( R( D                  (progn
/ l: h' K( B9 L. e9 V" N! a; Q* r& O                    (setq e (cddddr c) e1 (cddddr c1) e (cddddr e) e1 (cddddr e1))
                    (while (and e e1)
5 e& I: T( j0 h/ H! p9 A                      (progn
                      (setq f (car e) f1 (car e1) e (cdr e) e1 (cdr e1))
                      (while (and e (/= (car f) 10))(setq f (car e) e (cdr e)))
                      (while (and e1 (/= (car f1) 10))(setq f1 (car e1) e1 (cdr e1)))
                      (if (or (/= (rtos (cadr f) 2 4)(rtos (cadr f1) 2 4))
                              (/= (rtos (caddr f) 2 4)(rtos (caddr f1) 2 4)))(setq e1 nil)
                        (if (not e1) (command "erase" b1 "")(if (not e)
$ J5 G! u/ g; k7 s                           (progn (command "erase" b "")(setq b b1 b1 nil))))
                  ) ) ) )         
                  (if (= d "SPLINE")
                    (progn
                      (setq e (cddddr c) e1 (cddddr c1) e (cddddr e) e1 (cddddr e1))
                      (while (and e e1)
                        (progn
0 ]7 |2 B) [* k+ G+ H3 Q* _                          (setq f (car e) f1 (car e1) e (cdr e) e1 (cdr e1))
                          (while (and e (/= (car f) 10))(setq f (car e) e (cdr e)))
                          (while (and e1 (/= (car f1) 10))(setq f1 (car e1) e1 (cdr e1)))
                          (if (or (/= (rtos (cadr f) 2 4)(rtos (cadr f1) 2 4))(/= (rtos (caddr f) 2 4)(rtos (caddr f1) 2 4)))(setq e1 nil)
% x3 e% }  Q( z, R                            (if (not e1 ) (command "erase" b1 "")(if (not e)(progn (command "erase" b "")(setq b b1 b1 nil))))
2 @8 G3 D* @. V+ `) d                    ) ) ) )         
9 k1 p* S0 e  Z4 n5 s2 _                    (if (= d "TEXT")
                      (if (and (= (rtos (cadr (assoc 10 c)) 2 4)(rtos (cadr (assoc 10 c1)) 2 4))
                               (= (rtos (caddr (assoc 10 c)) 2 4)(rtos (caddr (assoc 10 c1)) 2 4))
  i, E$ l1 S1 G6 [$ [3 C) g                          )(command "erase" b1 "")
4 G( [7 t! M: }* J                      )
( i& \' K+ A, }' m                      (if (= d "CIRCLE")
* E. j: A4 I5 l2 D                        (if (and (= (rtos (cadr (assoc 10 c)) 2 4)(rtos (cadr (assoc 10 c1)) 2 4))
                                 (= (rtos (caddr (assoc 10 c)) 2 4)(rtos (caddr (assoc 10 c1)) 2 4))
                                 (= (rtos (cdr (assoc 40 c)) 2 4)(rtos (cdr (assoc 40 c1)) 2 4))
                            )(command "erase" b1 "")
* p! S' Q' l3 k8 m      ) ) ) ) ) ) ) ) ) )
, L1 E; t( R" o$ b      (setq m3 (polar m3 1.5708 50.0) y2 (+ y2 50.0))
; c2 q/ @7 X( d) v. o8 U    )
    (setq m2 (polar m2 0.0 50.0) x2 (+ x2 50.0))
  )
: d) a" k6 ?/ w# [. F  (princ)
& n) U2 }+ c* N$ ~) z9 K)
% M' ^/ r& ^$ K- Y/ ^) m(princ "\n\"ere\"启动")
1 @) C, }* s8 G( W, C1 p
[ 本帖最后由 zedcar 于 2008-11-26 09:35 编辑 ]

maoyangmy

有没有中间使用变量得说明？做什么用得？

zedcar

原帖由 maoyangmy 于 2008-11-26 11:05 发表 http://www.3dportal.cn/discuz/images/common/back.gif
有没有中间使用变量得说明？做什么用得？

没有　这个程序用来删除多余的图元。程序特点，可以删除完全重合的直线、多段线、光滑曲线（程序中设置了4位小数，当坐标数值四舍五入精确到4位小数时认为重合），删除位置重合的文字，删除位置和半径相同的圆，删除位置和块名相同的块。

ljm68

给你一个思路：
    处理"LINE"时，增加一个判定函数，用于首先判定直线L1的两个端点是否在直线L2上面；若在，再判定直线L1的两个端点是否在直线L2的两个端点以内，则返回直线L1，否则返回直线L2。
    判定直线L1的两个端点是否在直线L2上面：
- q1 e4 ^9 w9 @1 v/ N. V       可以逐点计算直线L1的两个端点到直线L2的距离是否小余你的精度要求，若小余，则判定为该点在直线L2上，否则，该点不在直线L2上。

SunVei

1.    
   5 a3 c4 F! w3 n! X- t
2.     (defun dxg (code ele)
   
3.       (cdr (assoc code (entget ele)))
   3 j6 `1 ?8 U+ m3 J; I% M7 J6 Q. |+ O
4.     )
   7 i+ Y3 [% H$ k$ V) y
5.       
   
6. 
   
7.     (defun vpt (a b c)
   2 W0 q, L$ c3 E3 F
8.        (equal
   
9.          (if (caddr a) a (reverse (cons 0.0 (reverse a))))
   ' j8 f' l, C6 I* A+ T) Y' G# T
10.          (if (caddr b) b (reverse (cons 0.0 (reverse b))))
    
11.          (expt 0.1 c)
    * k7 o8 R6 W. y9 T( y; G! x0 f; x& E
12.        )
    
13.     )
    ( D4 q3 N: W+ S- u
14.    
    # R+ ]3 W0 F3 [+ D# Q0 `
15. ;;; =========== for Test only =========================================
      {0 @  G; D5 `1 \* l
16. ;;; 删除线段内的短线
    5 z0 q) D- u5 e, V. c$ S: o$ }5 T- ^
17. ;; ssen = Line Selection
    & @/ [( q  c& F  C2 A
18. (setq nn (sslength ssen))
    
19. (cond
    
20.   ((< nn 2) nil)                        ; Nothing to do
    1 E' a$ R' F3 G$ ?/ O
21.   (T
    % _4 k$ {" u: o$ t  M9 C
22.    (princ "\nProceeding with Line ....."
    
23.    (while (setq ee (ssname ssen (setq nn (1- nn))))
    
24.      (cond
    
25.        ((null (entget ee)))                ; bypass
    & I/ H  ?6 Y1 b1 e  ~
26.        (T
    1 x' R  E: V3 u- n
27.         (setq p1  (dxg 10 ee)
    
28.               p2  (dxg 11 ee)
    ; c6 w1 B0 m- L$ k; Y/ L
29.               v1  (angle p1 p2)
    . w7 i! ^1 ^- H" H* t; X
30.               e1d (cdddr (cddr (entget ee)))
    
31.               sc  (ssget "f" (list p1 p2) '((0 . "LINE")
    5 I# ^  [+ F+ O/ h8 f8 f% J9 s
32.               sum (if sc (sslength sc))
    ! B1 r) [8 R/ a: B/ t- @; q
33.         )
    
34.         (while (and (entget ee) (> sum 0))
    7 z; \4 u& b; ]' m
35.           (setq e1 (ssname sc (setq sum (1- sum))))
    / b+ d' N4 K( j+ V$ i
36.           (cond
    
37.             ((eq e1 ee) nil)                ; Itself
    
38.             ((equal (cdddr (cdddr (entget e1))) e1d)
    
39.              (entdel e1)
    . o1 K0 x( F8 J0 B. b
40.             )
    
41.             (T
    
42.              (setq p3 (dxg 10 e1)
    9 |' b) I$ m" E2 @
43.                    p4 (dxg 11 e1)
    
44.                    v2 (if (vpt p1 p3 5)
    6 k' l- }2 H. Q  e% J
45.                         (angle p2 p3)
    
46.                         (angle p1 p3)
    # ^/ ^% w' y$ V4 c/ C. |
47.                       )
    
48.              )
    
49.              (if (< (rem (abs (- v1 v2)) pi) 0.0001)
    
50.                (if (< (distance p3 p4) (distance p1 p2))
    + C" K7 F* C9 r7 h
51.                  (entdel e1)
    * X, T0 c- O- i: M9 t) V8 K! Q
52.                  (entdel ee)
    
53.                )
    9 X, C$ S* I. }$ t1 L$ [2 w
54.              )
    # p2 X9 g- w/ O( \$ X! T. m
55.             )
    
56.           )
    $ t7 I7 M7 [, Z( m
57.         )
    
58.        )
      K+ F) [4 ]: O4 x) y- O. P
59.      )
    
60.    )
    / g* i  U" t& _5 `8 V
61.   )
    
62. )
    * e, n! S5 }1 _& e
63. 
    

复制代码

[ 本帖最后由 SunVei 于 2008-12-6 23:24 编辑 ]

cai813

我认为对有利于促进论坛的发展,同时也激励会员多参与.但对于管理人员应该考虑工作需要,不收取流量.