请高手帮修改一个程序

zedcar · 发表于 2008-11-26 09:33:57

马上注册，结识高手，享用更多资源，轻松玩转三维网社区。

您需要登录才可以下载或查看，没有帐号？注册

x

　　　在网上找的一个删除重复图元的ＬＩＳＰ程序　加载使用后发现对重复线段的删除有时候无效　而且线段内部的线段无法删除　就是说如果一条线段长１００一条长５０　使用这个删除不掉！！请高手帮忙修改下！！
　以下是程序原文：（附件内容是程序源文件）
(defun c:ere()
  (setq m0 (getpoint "\n左下角："))
  (setq m1 (getpoint "\n右上角："))
  (setq x0 (car m0) x1 (car m1) y0 (cadr m0) y1 (cadr m1) m2 m0 x2 x0 y2 y0)
  (while (< x2 x1)
(setq y2 y0 m3 m2)
(while (< y2 y1)
   (setq m4 (polar m3 0.785398 70.72))
   (setq a (ssget "_C" m3 m4))
   (if (not a)(setq i 0)(setq i (sslength a)))
   (while (> i 1)
      (setq j (- i 1))
      (setq b (ssname a (setq i (1- i)))) ;(setq b (ssname a 1))
      (setq c (entget b))
      (setq d (cdr (assoc 0 c)))
      (while (> j 0)
      (setq b1 (ssname a (setq j (1- j))))
      (setq c1 (entget b1))
      (setq d1 (cdr (assoc 0 c1)))
      (if (= d d1)
         (if (= d "LINE")
            (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))
                     (= (rtos (caddr (assoc 11 c)) 2 4)(rtos (caddr (assoc 11 c1)) 2 4))
               )(command "erase" b1 "")
            )
            (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")
               (progn
                  (setq e (cddddr c) e1 (cddddr c1) e (cddddr e) e1 (cddddr e1))
                  (while (and e e1)
                  (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)
                        (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
                        (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)(progn (command "erase" b "")(setq b b1 b1 nil))))
                  ) ) ) )
                  (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))
                        )(command "erase" b1 "")
                  )
                  (if (= d "CIRCLE")
                     (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 "")
   ) ) ) ) ) ) ) ) ) )
   (setq m3 (polar m3 1.5708 50.0) y2 (+ y2 50.0))
)
(setq m2 (polar m2 0.0 50.0) x2 (+ x2 50.0))
  )
  (princ)
)
(princ "\n\"ere\"启动")

[ 本帖最后由 zedcar 于 2008-11-26 09:35 编辑 ]

maoyangmy · 发表于 2008-11-26 11:05:42

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

zedcar · 发表于 2008-11-26 12:40:25

原帖由 maoyangmy 于 2008-11-26 11:05 发表 http://www.3dportal.cn/discuz/images/common/back.gif
$ N- P1 d9 Z" {; Y+ ?( d5 c6 M有没有中间使用变量得说明？做什么用得？

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

ljm68 · 发表于 2008-12-6 15:17:15

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

SunVei · 发表于 2008-12-6 22:42:04

6 k( X9 `* }3 h' k. R5 K8 r0 }
(defun dxg (code ele)' U' \! ]$ c* x4 V* O
(cdr (assoc code (entget ele)))
6 x; d7 n1 j, I3 v
)( ~7 _" i* \) U" V2 i0 Y5 t' e
, j, F6 Y: ~. m- m
3 B+ }! ]( z0 H4 u
(defun vpt (a b c)3 d+ r+ Y/ j" e1 A, W, j) c; c
(equal
( Q+ N( H) l7 ]3 F% i- M# }
(if (caddr a) a (reverse (cons 0.0 (reverse a)))). k* Y* ?/ i2 r6 v3 {& P
(if (caddr b) b (reverse (cons 0.0 (reverse b))))1 Q' L+ f# o/ n( S
(expt 0.1 c)8 Y5 G4 X0 H2 k4 r& U- f
): K. Z1 `5 z# N+ F0 h# k
)8 F V9 C' c. g9 r2 u4 [1 g* G! I# o
6 W; }' m0 i" G! Q; K# T7 a
;;; =========== for Test only =========================================
m( g* n" A* N0 @: l
;;; 删除线段内的短线$ O: p( Z2 L& u! X& j2 e
;; ssen = Line Selection
+ t7 u5 e/ p& s- v& s
(setq nn (sslength ssen))6 g$ Z- n* L" j3 A3 V' O
(cond" }- u. @0 T9 `% I- v% O
((< nn 2) nil) ; Nothing to do6 O' p0 z/ f. @! H
(T
8 t S& ^4 O3 p6 I/ M/ y
(princ "\nProceeding with Line ....."
8 p* Z3 T6 O* u! o2 H& y0 ^
(while (setq ee (ssname ssen (setq nn (1- nn)))) 9 M' F# Y6 u8 K+ ~) {) S* N* b
(cond
( ^ |+ u4 ?1 Q
((null (entget ee))) ; bypass7 X! Y: d7 v8 ]4 p! L# y
(T) d: i6 }0 E6 g$ ?; ~/ D
(setq p1 (dxg 10 ee)
' Z; {. W0 O) Y/ a$ P" H
p2 (dxg 11 ee)3 Q9 s' [+ R1 D- I
v1 (angle p1 p2)& [ ?) H- A% G9 s) C$ L
e1d (cdddr (cddr (entget ee)))
& C* F6 J4 }5 V, j( U5 b$ b
sc (ssget "f" (list p1 p2) '((0 . "LINE")0 E. R* w' |7 }+ ?, H1 ?. e# t
sum (if sc (sslength sc)); K4 _5 M2 P# l) C( W, k) h9 J
)
# y8 h1 n( |5 m/ P6 o9 e$ H" g+ @
(while (and (entget ee) (> sum 0))
5 T( h. m! u( ]
(setq e1 (ssname sc (setq sum (1- sum))))
6 y, C( P/ s7 |3 A! V% d1 ]$ C
(cond
5 J& K/ S( t$ U+ N0 K$ |# I, C
((eq e1 ee) nil) ; Itself# Y) i' k9 J7 r: M5 q" P
((equal (cdddr (cdddr (entget e1))) e1d), ], Y8 N8 H+ }2 z; t6 I
(entdel e1)
* ?% p- [7 e0 ~9 T& l6 S+ E' F
)
q4 k ~4 S* U; h, C* B6 f
(T
6 r/ Z5 }- u5 W9 k: }+ d
(setq p3 (dxg 10 e1)9 d( t* h. K' q7 h& ^- \9 P* N$ L
p4 (dxg 11 e1)
5 y* q, d3 p9 a" |9 F( H( a
v2 (if (vpt p1 p3 5)3 ?: [4 @) n, T# W- @& W" O
(angle p2 p3)
& O x; U7 l4 V+ E I% }
(angle p1 p3)
) u- N8 S& {7 K0 _1 {8 _1 Z
)+ t7 o: [/ q" S2 S% a. Z c
)
9 z; n) O K+ |0 r
(if (< (rem (abs (- v1 v2)) pi) 0.0001)
" \+ W. G& |( r$ e" O
(if (< (distance p3 p4) (distance p1 p2))7 ^% ^0 Z1 v* Z* h9 x) y
(entdel e1)
5 o& n; Z y( j$ k
(entdel ee)
$ G3 f8 M9 c4 w% Q; u* H
)
3 Q$ S* B$ u' K) f
)
Z4 S2 J8 s* X* p: \$ N7 M
)
% A5 x, Z& z0 V- k1 U* O
)' w1 d5 [% A7 p& Y
)
2 ^, h! M) h: `: w: T' v- w
)* ~: b" ^ V& n$ `0 K
)) @6 d: H2 ^6 C4 h9 u* b& h/ h3 ]
)
* ?# v# v3 T! q* e Y6 w. E# U
)& M; x, C1 O% I2 C; ^. n4 g
)% }# Q6 E" J" Q2 l
# E% ?/ [, d0 x& h. ]

复制代码

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

cai813 · 发表于 2008-12-7 09:59:37

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

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

通知

[求助] 请高手帮修改一个程序

马上注册，结识高手，享用更多资源，轻松玩转三维网社区。

评分

评分

评分

浏览过的版块