|
前生所提供的程序，很好用，我已测试过了。不过程序没有分行，在使用前需要编辑一下。下面是我编辑的，贴出来供参考。 ;;;標題: 【解決方案】消除重線的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)
) | 
[复制链接]
发表于 2007-3-18 12:31:00
显身卡