【活动结束】LISP知识测试问卷--第三期[难度指数[★★★☆]

狂刀lxx

提供一个地6题的简练解答

1. ;|6.【曲线计算】10分  已知共面且不相交的一直线和一圆弧，求两个对象之间的最小距离。 |;
   
2. (defun tt6 (line arc / A1 A2 CEN D P1 P2 PM) ;; by dreamskylxx 2012.1
   
3.   (setq line (vlax-ename->vla-object line)
   
4.         arc (vlax-ename->vla-object arc))
   
5.   (setq p1 (vlax-get line 'startpoint)
   
6.         p2 (vlax-get line 'endpoint)
   
7.         a1 (vlax-get arc 'startpoint)
   
8.         a2 (vlax-get arc 'endpoint)
   
9.         cen(vlax-get arc 'Center))
   
10.   (if
    
11.     (vlax-invoke line 'IntersectWith arc acExtendNone)
    
12.     0.
    
13.     (progn
    
14.       (setq pm (vlax-curve-getclosestpointto line cen T)
    
15.              d (apply 'min (mapcar '(lambda(x y)(distance(vlax-curve-getclosestpointto x y) y))
    
16.                            (list arc arc line line)
    
17.                            (list p1 p2 a1 a2))))
    
18.      (if (vlax-curve-getdistatpoint line pm)
    
19.        (min d (distance (vlax-curve-getclosestpointto arc pm) pm))
    
20.        d
    
21.        )
    
22.     )
    
23.   )
    
24. )

;|6.【曲线计算】10分  已知共面且不相交的一直线和一圆弧，求两个对象之间的最小距离。 |;<br /> (defun tt6 (line arc / A1 A2 CEN D P1 P2 PM) ;; by dreamskylxx 2012.1<br />   (setq line (vlax-ename->vla-object line)<br />         arc (vlax-ename->vla-object arc))<br />   (setq p1 (vlax-get line 'startpoint)<br />         p2 (vlax-get line 'endpoint)<br />         a1 (vlax-get arc 'startpoint)<br />         a2 (vlax-get arc 'endpoint)<br />         cen(vlax-get arc 'Center))<br />   (if<br />     (vlax-invoke line 'IntersectWith arc acExtendNone)<br />     0.<br />     (progn<br />       (setq pm (vlax-curve-getclosestpointto line cen T)<br />              d (apply 'min (mapcar '(lambda(x y)(distance(vlax-curve-getclosestpointto x y) y))<br />                            (list arc arc line line)<br />                            (list p1 p2 a1 a2))))<br />      (if (vlax-curve-getdistatpoint line pm)<br />        (min d (distance (vlax-curve-getclosestpointto arc pm) pm))<br />        d<br />        )<br />     )<br />   )<br /> )

或者

1. ;; by dreamskylxx 2012.1
   
2. (defun tt6 (line arc / A1 A2 CEN D ENT1 P1 P2 PM)
   
3.   (setq ent1 (entget line)
   
4.         p1 (cdr(assoc 10 ent1))
   
5.         p2 (cdr(assoc 11 ent1))
   
6.         a1 (vlax-curve-getstartpoint arc)
   
7.         a2 (vlax-curve-getendpoint arc)
   
8.         cen(cdr(assoc 10 (entget arc)))
   
9.         pm (vlax-curve-getclosestpointto line cen T)
   
10.         d  (apply 'min (mapcar '(lambda(x y)(distance(vlax-curve-getclosestpointto x y) y))
    
11.                            (list arc arc line line)
    
12.                            (list p1 p2 a1 a2))))
    
13. (if (vlax-curve-getdistatpoint line pm)
    
14.      (min d (distance (vlax-curve-getclosestpointto arc pm) pm))
    
15.       d
    
16. )
    
17. )

;; by dreamskylxx 2012.1<br /> (defun tt6 (line arc / A1 A2 CEN D ENT1 P1 P2 PM) <br />   (setq ent1 (entget line)<br />         p1 (cdr(assoc 10 ent1))<br />         p2 (cdr(assoc 11 ent1))<br />         a1 (vlax-curve-getstartpoint arc)<br />         a2 (vlax-curve-getendpoint arc)<br />         cen(cdr(assoc 10 (entget arc)))<br />         pm (vlax-curve-getclosestpointto line cen T)<br />         d  (apply 'min (mapcar '(lambda(x y)(distance(vlax-curve-getclosestpointto x y) y))<br />                            (list arc arc line line)<br />                            (list p1 p2 a1 a2))))<br /> (if (vlax-curve-getdistatpoint line pm)<br />      (min d (distance (vlax-curve-getclosestpointto arc pm) pm))<br />       d<br /> )<br /> )

1. ;;测试程序
   
2. (defun c:tt6 ()
   
3.    (setq line (car(entsel "\n 选直线:"))
   
4.          arc  (car(entsel "\n 选圆弧:")))
   
5.    (tt6 line arc)
   
6. )

;;测试程序<br /> (defun c:tt6 ()<br />    (setq line (car(entsel "\n 选直线:"))<br />          arc  (car(entsel "\n 选圆弧:")))<br />    (tt6 line arc)<br /> )

第7题组定义，本人以前有个跟组操作相关的函数收集，连接 http://bbs.mjtd.com/thread-86821-1-1.html
在里面找一个改一下就ok了
GU_XL版主，第7题答案缺函数GXL-MASSOC，无法测试

1. ;;测试：(GPDEl (setq ent (car (entsel "\n选择要删除组的图元:"))))
   
2. ;; 删除所选物体的所在组定义（支持多重组定义）
   
3. (defun gpdel (gpe / el lst a gpdf gplst);;by dreamskylxx 2012.1
   
4.   (setq el (entget gpe))
   
5.   (if (setq lst (member '(102 . "{ACAD_REACTORS") el))
   
6.     (while (and (setq lst (cdr lst)) (= 330 (car (setq a (car lst)))))
   
7.       (if (= "GROUP" (cdr (assoc 0 (setq gpdf (entget (cdr a))))))
   
8.         (entdel (cdr(assoc -1 gpdf)))
   
9.       )
   
10.     )
    
11.   )
    
12. )
    

;;测试：(GPDEl (setq ent (car (entsel "\n选择要删除组的图元:"))))<br /> ;; 删除所选物体的所在组定义（支持多重组定义）<br /> (defun gpdel (gpe / el lst a gpdf gplst);;by dreamskylxx 2012.1<br />   (setq el (entget gpe))<br />   (if (setq lst (member '(102 . "{ACAD_REACTORS") el))<br />     (while (and (setq lst (cdr lst)) (= 330 (car (setq a (car lst)))))<br />       (if (= "GROUP" (cdr (assoc 0 (setq gpdf (entget (cdr a))))))<br />         (entdel (cdr(assoc -1 gpdf)))<br />       )<br />     )<br />   )<br /> )<br />

第4题相对容易，也没有什么特别的处理方法，略过。
第8题，gu版的动作比较大，相当于把所有的都卸载，再重新加载。
   我提个想法，能不能 用vl-unload-vlx先卸载指定fas或vlx，收集family再 load加载，收集family，两次进行对比。。。

chlh_jd

做下第六题，并延伸到空间曲线

2. (defun c:test
   
3.        (/ en1 e en2 fuzz l1 l2 lim l0 d0 p0 p)
   
4.   ;;by GSLS(SS) 2012.1.2
   
5.   (defun getlength (e)
   
6.     (vlax-curve-getDistAtPoint
   
7.       e
   
8.       (vlax-curve-getendpoint e)
   
9.     )
   
10.   )
    
11.   (defun f0 (a b / mid rslt)
    
12.     (repeat (/ (length a) b)
    
13.       (setq mid nil)
    
14.       (repeat b
    
15. (setq mid (cons (car a) mid)
    
16.        a   (cdr a)
    
17. )
    
18.       )
    
19.       (setq rslt (cons (reverse mid) rslt))
    
20.     )
    
21.     (if a
    
22.       (reverse (cons a rslt))
    
23.       (reverse rslt)
    
24.     )
    
25.   )
    
26.   (defun f1 (e p)
    
27.     (distance p (vlax-curve-getClosestPointTo e p))
    
28.   )
    
29.   (defun f2 (e1 e2 p lim / l0 d0 p0 l)
    
30.     (setq l0 (vlax-curve-getDistAtPoint e1 p)
    
31.    d0 (f1 e2 p)
    
32.    p0 p
    
33.    l  l0
    
34.     )
    
35.     (repeat 10
    
36.       (setq l (- l lim))
    
37.       (if (and (>= l 0) (setq p (vlax-curve-getpointatdist e1 l)))
    
38. (if (and (setq d (f1 e2 p))
    
39.    (< d d0)
    
40.      )
    
41.    (setq d0 d
    
42.   p0 p
    
43.    )
    
44. )
    
45.       )
    
46.     )
    
47.     (setq l l0)
    
48.     (repeat 10
    
49.       (setq l (+ l lim))
    
50.       (if (and (>= l 0) (setq p (vlax-curve-getpointatdist e1 l)))
    
51. (if (and (setq d (f1 e2 p))
    
52.    (< d d0)
    
53.      )
    
54.    (setq d0 d
    
55.   p0 p
    
56.    )
    
57. )
    
58.       )
    
59.     )
    
60.     p0
    
61.   )
    
62.   (defun f3 (e1 e2 lim / mid)
    
63.     (if (not
    
64.    (minusp
    
65.      (vlax-safearray-get-u-bound
    
66.        (vlax-variant-value
    
67.   (setq mid (vla-IntersectWith
    
68.        (vlax-ename->vla-object e1)
    
69.        (vlax-ename->vla-object e2)
    
70.        lim
    
71.      )
    
72.   )
    
73.        )
    
74.        1
    
75.      )
    
76.    )
    
77. )
    
78.       (list-comp (vlax-safearray->list (vlax-variant-value mid))
    
79.    3
    
80.       )
    
81.     )
    
82.   )
    
83.   (setq en1 (car (ss-Nentsel "\nSelect First Curve :"))
    
84. en2 (car (ss-Nentsel "\nSelect Second Curve :"))
    
85.   )
    
86.   (setq fuzz (getreal "\nType in Accuracy <1e-6> :"))
    
87.   (or fuzz (setq fuzz 1e-6))
    
88.   (if (and en1 en2)
    
89.     (if (f3 en1 en2 0)
    
90.       (princ "\nThe 2 Curves is intersectwithed !")
    
91.       (progn
    
92. (setq l1 (getlength en1)
    
93.        l2 (getlength en2)
    
94. )
    
95. (if (< l2 l1)
    
96.    (setq e   en1
    
97.   en1 en2
    
98.   en2 e
    
99.   l1  l2
    
100.    )
     
101. )
     
102. (setq lim (/ l1 (1+ (fix (/ l1 200.))))
     
103.        l0  0.
     
104.        d0  1e308
     
105. )
     
106. (repeat (fix (/ l1 lim))
     
107.    (setq p (vlax-curve-getpointatdist en1 l0))
     
108.    (setq d (f1 en2 p))
     
109.    (if (< d d0)
     
110.      (setq d0 d
     
111.     p0 p
     
112.      )
     
113.    )
     
114.    (setq l0 (+ l0 lim))
     
115. )
     
116. (setq is_go T)
     
117. (while (and (> lim fuzz) is_go)
     
118.    (setq p (f2 en1 en2 p0 (setq lim (/ lim 10.))))
     
119.    (if (equal p p0 fuzz)
     
120.      (setq is_go nil
     
121.     p0 p
     
122.      )
     
123.      (setq p0 p)
     
124.    )
     
125. )
     
126. (setq p (vlax-curve-getClosestPointTo en2 p0))
     
127. (entmakex (list (cons 0 "LINE")
     
128.    (cons 8 "Defpoints")
     
129.    (cons 10 p0)
     
130.    (cons 11 p)
     
131.    (cons 62 1)
     
132.     )
     
133. )
     
134.       )
     
135.     )
     
136.   )
     
137.   (princ)
     
138. )
     
139. (defun ss-Nentsel (msg / en en1 pt mat ins mat ent)
     
140.   (setq en (Nentsel msg))
     
141.   (if (= (length en) 4)
     
142.     (progn
     
143.       (setq en1 (car en)
     
144.      pt (cadr en)
     
145.      mat (caddr en)
     
146.      ins (last mat)
     
147.      mat (butlast mat)
     
148.      mat (ss-getrcsmatrix mat ins)
     
149.       )
     
150.       (setq ent (entget en1 (list "*")))
     
151.       (setq ent (vl-remove (assoc -1 ent) ent))
     
152.       (setq en1 (entmakex ent))
     
153.       (if en1
     
154. (progn
     
155.    (setq obj (en2obj en1))
     
156.    (vla-TransformBy obj (vlax-tmatrix mat))
     
157.    (setq en1 (obj2en obj))
     
158. )
     
159.       )
     
160.       (list en1 pt T)
     
161.     )
     
162.     (append en (list nil))
     
163.   )
     
164. )
     
165. ;;; BY GSLS(SS)
     
166. ;;; 2010-09-29
     
167. (defun ss-getrcsmatrix (lst org)
     
168.   (append
     
169.     (mapcar (function (lambda (x y)
     
170.    (append x (list y))
     
171.         )
     
172.      )
     
173.      lst
     
174.      org
     
175.     )
     
176.     (list (list 0. 0. 0. 1.))
     
177.   )
     
178. )
     

(defun c:test<br />        (/ en1 e en2 fuzz l1 l2 lim l0 d0 p0 p)<br />   ;;by GSLS(SS) 2012.1.2<br />   (defun getlength (e)<br />     (vlax-curve-getDistAtPoint<br />       e<br />       (vlax-curve-getendpoint e)<br />     )<br />   )<br />   (defun f0 (a b / mid rslt)<br />     (repeat (/ (length a) b)<br />       (setq mid nil)<br />       (repeat b<br /> (setq mid (cons (car a) mid)<br />        a   (cdr a)<br /> )<br />       )<br />       (setq rslt (cons (reverse mid) rslt))<br />     )<br />     (if a<br />       (reverse (cons a rslt))<br />       (reverse rslt)<br />     )<br />   )<br />   (defun f1 (e p)<br />     (distance p (vlax-curve-getClosestPointTo e p))<br />   )<br />   (defun f2 (e1 e2 p lim / l0 d0 p0 l)<br />     (setq l0 (vlax-curve-getDistAtPoint e1 p)<br />    d0 (f1 e2 p)<br />    p0 p<br />    l  l0<br />     )<br />     (repeat 10<br />       (setq l (- l lim))<br />       (if (and (>= l 0) (setq p (vlax-curve-getpointatdist e1 l)))<br /> (if (and (setq d (f1 e2 p))<br />    (< d d0)<br />      )<br />    (setq d0 d<br />   p0 p<br />    )<br /> )<br />       )<br />     )<br />     (setq l l0)<br />     (repeat 10<br />       (setq l (+ l lim))<br />       (if (and (>= l 0) (setq p (vlax-curve-getpointatdist e1 l)))<br /> (if (and (setq d (f1 e2 p))<br />    (< d d0)<br />      )<br />    (setq d0 d<br />   p0 p<br />    )<br /> )<br />       )<br />     )<br />     p0<br />   )<br />   (defun f3 (e1 e2 lim / mid)<br />     (if (not<br />    (minusp<br />      (vlax-safearray-get-u-bound<br />        (vlax-variant-value<br />   (setq mid (vla-IntersectWith<br />        (vlax-ename->vla-object e1)<br />        (vlax-ename->vla-object e2)<br />        lim<br />      )<br />   )<br />        )<br />        1<br />      )<br />    )<br /> )<br />       (list-comp (vlax-safearray->list (vlax-variant-value mid))<br />    3<br />       )<br />     )<br />   )<br />   (setq en1 (car (ss-Nentsel "\nSelect First Curve :"))<br /> en2 (car (ss-Nentsel "\nSelect Second Curve :"))<br />   )<br />   (setq fuzz (getreal "\nType in Accuracy <1e-6> :"))<br />   (or fuzz (setq fuzz 1e-6))<br />   (if (and en1 en2)<br />     (if (f3 en1 en2 0)<br />       (princ "\nThe 2 Curves is intersectwithed !")<br />       (progn<br /> (setq l1 (getlength en1)<br />        l2 (getlength en2)<br /> )<br /> (if (< l2 l1)<br />    (setq e   en1<br />   en1 en2<br />   en2 e<br />   l1  l2<br />    )<br /> )<br /> (setq lim (/ l1 (1+ (fix (/ l1 200.))))<br />        l0  0.<br />        d0  1e308<br /> )<br /> (repeat (fix (/ l1 lim))<br />    (setq p (vlax-curve-getpointatdist en1 l0))<br />    (setq d (f1 en2 p))<br />    (if (< d d0)<br />      (setq d0 d<br />     p0 p<br />      )<br />    )<br />    (setq l0 (+ l0 lim))<br /> )<br /> (setq is_go T)<br /> (while (and (> lim fuzz) is_go)<br />    (setq p (f2 en1 en2 p0 (setq lim (/ lim 10.))))<br />    (if (equal p p0 fuzz)<br />      (setq is_go nil<br />     p0 p<br />      )<br />      (setq p0 p)<br />    )<br /> )<br /> (setq p (vlax-curve-getClosestPointTo en2 p0))<br /> (entmakex (list (cons 0 "LINE")<br />    (cons 8 "Defpoints")<br />    (cons 10 p0)<br />    (cons 11 p)<br />    (cons 62 1)<br />     )<br /> )<br />       )<br />     )<br />   )<br />   (princ)<br /> )<br /> (defun ss-Nentsel (msg / en en1 pt mat ins mat ent)<br />   (setq en (Nentsel msg))<br />   (if (= (length en) 4)<br />     (progn<br />       (setq en1 (car en)<br />      pt (cadr en)<br />      mat (caddr en)<br />      ins (last mat)<br />      mat (butlast mat)<br />      mat (ss-getrcsmatrix mat ins)<br />       )<br />       (setq ent (entget en1 (list "*")))<br />       (setq ent (vl-remove (assoc -1 ent) ent))<br />       (setq en1 (entmakex ent))<br />       (if en1<br /> (progn<br />    (setq obj (en2obj en1))<br />    (vla-TransformBy obj (vlax-tmatrix mat))<br />    (setq en1 (obj2en obj))<br /> )<br />       )<br />       (list en1 pt T)<br />     )<br />     (append en (list nil))<br />   )<br /> )<br /> ;;; BY GSLS(SS)<br /> ;;; 2010-09-29<br /> (defun ss-getrcsmatrix (lst org)<br />   (append<br />     (mapcar (function (lambda (x y)<br />    (append x (list y))<br />         )<br />      )<br />      lst<br />      org<br />     )<br />     (list (list 0. 0. 0. 1.))<br />   )<br /> )<br />

byghbcx

题目2，可以用直角坐标系求出坐标，qjchen的矩阵算法较好；
题目3，GU_xl 的递归算法较好，但题目为什么限用递归，因要求是3D点计算，复杂点；
题目4，直接替换凸度即可，由于REVCLOUD命令画出的直接是lwpolyline线，对polyline线没作计算；
题目5，对MLINE线的起始点、内弧、外弧计算较复杂，没作计算，只对线型、图层、颜色、坐标点进行计算；
题目6，对直线是否无限长，没作规定，所以只能以一般含端点直线加以计算，分了几种情况加以判断。

2. (defun c:tt2()
   
3. (setq ab (car (entsel "\n请选择AB直线:")))
   
4. (setq ab_dxf (entget ab))
   
5. (setq a_cor (cdr (assoc 10 ab_dxf))
   
6.       b_cor (cdr (assoc 11 ab_dxf))
   
7.       len   (distance a_cor b_cor)
   
8.       ang   (angle a_cor b_cor))
   
9. (setq det_x (* len (cos (+ ang (/ (* pi 89.0) 180.0))))
   
10.       det_y (* len (sin (+ ang (/ (* pi 89.0) 180.0))))
    
11. )
    
12. (setq ptb (list (+ det_x (car a_cor) ) (+ det_y (cadr a_cor) ) (caddr a_cor)))
    
13. (setq det_x (- (car a_cor) (car ptb)) det_y (- (cadr a_cor) (cadr ptb)))
    
14. (setq pta (list (+ (* 3.5 det_x) (car ptb)) (+ (* 3.5 det_y) (cadr ptb)) (caddr ptb)))
    
15. (list pta ptb)
    
16. ;(command "line" pta ptb "")
    
17. )
    
18. (defun tt3( lst / lst1 lst2 lst3 d dd ang n)
    
19.   (setq lst1 (reverse (cdr (reverse lst))))
    
20.   (setq lst2 (cdr lst) lst3 nil)  
    
21.   (mapcar '(lambda(x y)
    
22.       (if (> (setq d (distance x y)) 100)
    
23.         (progn
    
24.    (setq dd d n 0)
    
25.    (while (> dd 100)
    
26.      (setq dd (* 0.5 dd))
    
27.      )
    
28.    (repeat (fix (/ d dd))
    
29.      (setq lst3 (cons
    
30.     (mapcar '(lambda (a b) (+ (* (/ n (/ d dd)) a) b))
    
31.     (mapcar '(lambda (a b) (- a b)) y x)
    
32.      x)
    
33.     lst3))
    
34.      (setq n (1+ n))
    
35.      )
    
36.    )
    
37.         (setq lst3 (cons x lst3))
    
38.         )
    
39.       )
    
40.    lst1 lst2)
    
41.   (setq lst3 (reverse (cons (last lst2) lst3)))
    
42.   )
    
43.   ;(tt3 lst)(setq lst (list '(0 0 0) '(199 0 0) '(250 0 0) '(450 600 0) '(1600 1000 1000)))
    
44. (defun c:tt4( / dxfcod);云线反向
    
45. (setq dxfcod (entget (car (entsel "\n请选择REVCLOUD云线:"))))
    
46. (mapcar '(lambda(x) (if (= (car x) 42) (setq dxfcod (subst (cons 42 (- (cdr x))) x dxfcod)))) dxfcod)
    
47. (entmod dxfcod)
    
48. )
    
49. (defun c:tt5();非炸开，重绘MLINE
    
50.   (setq os (getvar 'osmode))
    
51.   (setvar 'osmode 0)
    
52.   (setq en (car (entsel "\n请选择多线:")))
    
53.   (setq dxfcod (entget en))
    
54.   (setq mlst (entget (cdr (assoc 340 dxfcod))))
    
55.   (setvar 'clayer (cdr (assoc 8 dxfcod)))
    
56.   (if (assoc 48 dxfcod) (setvar 'CELTSCALE (cdr (assoc 48 dxfcod))))
    
57.   (setq m (cdr (assoc 73 dxfcod)) n 0)
    
58.   (mapcar '(lambda(x) (if (not (member (car x) '(11 13 41))) (setq dxfcod (vl-remove x dxfcod)))) dxfcod)
    
59.   (repeat m
    
60.     (setq mlst (cdr (member (assoc 49 mlst) mlst)))
    
61.     (setvar 'cecolor
    
62.      (cond
    
63.        ((= (cdr (assoc 62 mlst)) 0) "byblock")
    
64.        ((= (cdr (assoc 62 mlst)) 256) "bylayer")
    
65.        (t (itoa (cdr (assoc 62 mlst))))
    
66.        )
    
67.      )
    
68.     (setvar 'celtype (cdr (assoc 6 mlst)))
    
69.     (setq cod dxfcod)
    
70.     (command "_.line")
    
71.     (while (assoc 11 cod)
    
72.       (setq pt (cdr (assoc 11 cod)))
    
73.       (setq cod (cdr (member (assoc 11 cod) cod)))
    
74.       (setq v (angle '(0 0 0) (cdr (assoc 13 cod))))
    
75.       (repeat n (setq cod (cdr (member (assoc 41 cod) cod))))
    
76.       (setq d (cdr (assoc 41 cod)))
    
77.       (command (polar pt v d))
    
78.       )
    
79.     (command "")
    
80.     (setq n (+ n 2))
    
81.     )
    
82.   (command "_.erase" en "")
    
83.   (setvar 'osmode os)
    
84.   )
    
85. (defun c:tt6( / line arc pt1 pt2 minpt maxpt)
    
86.   (setq line (car (entsel "\n请选择直线:")))
    
87.   (setq arc (car (entsel "\n请选择圆弧:")))
    
88.   (setq pt1 (cdr (assoc 10 (entget line))) pt2 (cdr (assoc 11 (entget line))))
    
89.   (setq ang (angle pt1 pt2))
    
90.   (command "_.rotate" line arc "" pt1 (- (/ (* ang 180.0) pi)))
    
91.   (setq pt2 (cdr (assoc 11 (entget line))))
    
92.   (setq ptc (cdr (assoc 10 (entget arc))) r (cdr (assoc 40 (entget arc))))
    
93.   (setq st (vla-get-startpoint (vlax-ename->vla-object arc)) et (vla-get-endpoint (vlax-ename->vla-object arc)))
    
94.   (setq st (vlax-safearray->list (vlax-variant-value st)) et (vlax-safearray->list (vlax-variant-value et)))
    
95.   (command "_.line" ptc (polar ptc (* 0.5 pi) 100) "")
    
96.   (setq line1 (entlast))
    
97.   (setq pt (vla-intersectwith (vlax-ename->vla-object line1) (vlax-ename->vla-object line) acextendthisentity))
    
98.   (if (safearray-value (vlax-variant-value pt))
    
99.     (progn
    
100.       (vla-getboundingbox (vlax-ename->vla-object arc) 'minpt 'maxpt)
     
101.       (setq minpt (vlax-safearray->list minpt) maxpt (vlax-safearray->list maxpt))
     
102.       (setq min_d (min (abs (- (cadr minpt) (cadr pt1))) (abs (- (cadr maxpt) (cadr pt1)))))
     
103.       )
     
104.     (progn
     
105.       (command "_.line" ptc (setq pt0 (if (> (distance pt1 ptc) (distance pt2 ptc)) pt2 pt1)) "")
     
106.       (setq line2 (entlast))
     
107.       (setq pt# (vla-intersectwith (vlax-ename->vla-object line2) (vlax-ename->vla-object arc) acextendnone))
     
108.       (if (safearray-value (vlax-variant-value pt#))
     
109. (setq min_d (- (distance pt0 ptc) r))
     
110. (setq min_d (min (distance pt0 st) (distance pt0 et)))
     
111. )
     
112.       )
     
113.     )
     
114.   (command "_.rotate" line arc "" pt1 (/ (* ang 180.0) pi))
     
115.   (command "_.erase" line1 line2 "")
     
116.   (princ "\n此直线与圆弧之间的最小距离为:")
     
117.   (princ min_d)
     
118.   (princ)
     
119.   )

(defun c:tt2()<br /> (setq ab (car (entsel "\n请选择AB直线:")))<br /> (setq ab_dxf (entget ab))<br /> (setq a_cor (cdr (assoc 10 ab_dxf))<br />       b_cor (cdr (assoc 11 ab_dxf))<br />       len   (distance a_cor b_cor)<br />       ang   (angle a_cor b_cor))<br /> (setq det_x (* len (cos (+ ang (/ (* pi 89.0) 180.0))))<br />       det_y (* len (sin (+ ang (/ (* pi 89.0) 180.0))))<br /> )<br /> (setq ptb (list (+ det_x (car a_cor) ) (+ det_y (cadr a_cor) ) (caddr a_cor)))<br /> (setq det_x (- (car a_cor) (car ptb)) det_y (- (cadr a_cor) (cadr ptb)))<br /> (setq pta (list (+ (* 3.5 det_x) (car ptb)) (+ (* 3.5 det_y) (cadr ptb)) (caddr ptb)))<br /> (list pta ptb)<br /> ;(command "line" pta ptb "")<br /> )<br /> (defun tt3( lst / lst1 lst2 lst3 d dd ang n)<br />   (setq lst1 (reverse (cdr (reverse lst))))<br />   (setq lst2 (cdr lst) lst3 nil)  <br />   (mapcar '(lambda(x y)<br />       (if (> (setq d (distance x y)) 100)<br />         (progn<br />    (setq dd d n 0)<br />    (while (> dd 100)<br />      (setq dd (* 0.5 dd))<br />      )<br />    (repeat (fix (/ d dd))<br />      (setq lst3 (cons<br />     (mapcar '(lambda (a b) (+ (* (/ n (/ d dd)) a) b))<br />     (mapcar '(lambda (a b) (- a b)) y x)<br />      x)<br />     lst3))<br />      (setq n (1+ n))<br />      )<br />    )<br />         (setq lst3 (cons x lst3))<br />         )<br />       )<br />    lst1 lst2)<br />   (setq lst3 (reverse (cons (last lst2) lst3)))<br />   )<br />   ;(tt3 lst)(setq lst (list '(0 0 0) '(199 0 0) '(250 0 0) '(450 600 0) '(1600 1000 1000)))<br /> (defun c:tt4( / dxfcod);云线反向<br /> (setq dxfcod (entget (car (entsel "\n请选择REVCLOUD云线:"))))<br /> (mapcar '(lambda(x) (if (= (car x) 42) (setq dxfcod (subst (cons 42 (- (cdr x))) x dxfcod)))) dxfcod)<br /> (entmod dxfcod)<br /> )<br /> (defun c:tt5();非炸开，重绘MLINE<br />   (setq os (getvar 'osmode))<br />   (setvar 'osmode 0)<br />   (setq en (car (entsel "\n请选择多线:")))<br />   (setq dxfcod (entget en))<br />   (setq mlst (entget (cdr (assoc 340 dxfcod))))<br />   (setvar 'clayer (cdr (assoc 8 dxfcod)))<br />   (if (assoc 48 dxfcod) (setvar 'CELTSCALE (cdr (assoc 48 dxfcod))))<br />   (setq m (cdr (assoc 73 dxfcod)) n 0)<br />   (mapcar '(lambda(x) (if (not (member (car x) '(11 13 41))) (setq dxfcod (vl-remove x dxfcod)))) dxfcod)<br />   (repeat m<br />     (setq mlst (cdr (member (assoc 49 mlst) mlst)))<br />     (setvar 'cecolor<br />      (cond<br />        ((= (cdr (assoc 62 mlst)) 0) "byblock")<br />        ((= (cdr (assoc 62 mlst)) 256) "bylayer")<br />        (t (itoa (cdr (assoc 62 mlst))))<br />        )<br />      )<br />     (setvar 'celtype (cdr (assoc 6 mlst)))<br />     (setq cod dxfcod)<br />     (command "_.line")<br />     (while (assoc 11 cod)<br />       (setq pt (cdr (assoc 11 cod)))<br />       (setq cod (cdr (member (assoc 11 cod) cod)))<br />       (setq v (angle '(0 0 0) (cdr (assoc 13 cod))))<br />       (repeat n (setq cod (cdr (member (assoc 41 cod) cod))))<br />       (setq d (cdr (assoc 41 cod)))<br />       (command (polar pt v d))<br />       )<br />     (command "")<br />     (setq n (+ n 2))<br />     )<br />   (command "_.erase" en "")<br />   (setvar 'osmode os)<br />   )<br /> (defun c:tt6( / line arc pt1 pt2 minpt maxpt)<br />   (setq line (car (entsel "\n请选择直线:")))<br />   (setq arc (car (entsel "\n请选择圆弧:")))<br />   (setq pt1 (cdr (assoc 10 (entget line))) pt2 (cdr (assoc 11 (entget line))))<br />   (setq ang (angle pt1 pt2))<br />   (command "_.rotate" line arc "" pt1 (- (/ (* ang 180.0) pi)))<br />   (setq pt2 (cdr (assoc 11 (entget line))))<br />   (setq ptc (cdr (assoc 10 (entget arc))) r (cdr (assoc 40 (entget arc))))<br />   (setq st (vla-get-startpoint (vlax-ename->vla-object arc)) et (vla-get-endpoint (vlax-ename->vla-object arc)))<br />   (setq st (vlax-safearray->list (vlax-variant-value st)) et (vlax-safearray->list (vlax-variant-value et)))<br />   (command "_.line" ptc (polar ptc (* 0.5 pi) 100) "")<br />   (setq line1 (entlast))<br />   (setq pt (vla-intersectwith (vlax-ename->vla-object line1) (vlax-ename->vla-object line) acextendthisentity))<br />   (if (safearray-value (vlax-variant-value pt))<br />     (progn<br />       (vla-getboundingbox (vlax-ename->vla-object arc) 'minpt 'maxpt)<br />       (setq minpt (vlax-safearray->list minpt) maxpt (vlax-safearray->list maxpt))<br />       (setq min_d (min (abs (- (cadr minpt) (cadr pt1))) (abs (- (cadr maxpt) (cadr pt1)))))<br />       )<br />     (progn<br />       (command "_.line" ptc (setq pt0 (if (> (distance pt1 ptc) (distance pt2 ptc)) pt2 pt1)) "")<br />       (setq line2 (entlast))<br />       (setq pt# (vla-intersectwith (vlax-ename->vla-object line2) (vlax-ename->vla-object arc) acextendnone))<br />       (if (safearray-value (vlax-variant-value pt#))<br /> (setq min_d (- (distance pt0 ptc) r))<br /> (setq min_d (min (distance pt0 st) (distance pt0 et)))<br /> )<br />       )<br />     )<br />   (command "_.rotate" line arc "" pt1 (/ (* ang 180.0) pi))<br />   (command "_.erase" line1 line2 "")<br />   (princ "\n此直线与圆弧之间的最小距离为:")<br />   (princ min_d)<br />   (princ)<br />   )

byghbcx

题目1，先用选择集过滤，得到四边形，或园环多段线，再判断四边形的三个角为90度，即为符合要求的。

2. (defun c:tt1(ss / per ss1 n en dxfcod pts ss2)
   
3.   (defun per (ap1 ap2 bp1 bp2 / a-> b-> ) ;判断垂直,向量点积为零
   
4.   (setq a-> (mapcar '- ap1 ap2) b-> (mapcar '- bp1 bp2))
   
5.   (if (equal (apply '+ (mapcar '* a-> b->)) 0 0.0001) t nil)
   
6.   )
   
7.   (command "_.convert" "p" "s" ss "")
   
8.   (sssetfirst nil ss)
   
9.   (setq ss1 (ssget ":e" '((0 . "*POLYLINE") (-4 . "<or")
   
10.                           (-4 . "<and") (-4 . "=") (90 . 2) (-4 . "=") (40 . 0) (-4 . "=") (41 . 0) (-4 . "=") (42 . 1.0) (-4 . "=") (70 . 1)
    
11.                           (-4 . "and>")
    
12.                           (-4 . "<and") (-4 . "<or") (-4 . "=") (90 . 4) (-4 . "=") (90 . 5) (-4 . "or>") (-4 . "=") (40 . 0) (-4 . "=") (41 . 0) (-4 . "and>")
    
13.                           (-4 . "or>"))))
    
14.   (setq n 0 ss2 (ssadd))
    
15.   (repeat (sslength ss1)
    
16.     (setq en (ssname ss1 n))
    
17.     (setq dxfcod (entget en) pts nil)
    
18.     (cond ((= (cdr (assoc 90 dxfcod)) 2) (setq ss2 (ssadd en ss2)));园环
    
19.           ((member (cdr (assoc 90 dxfcod)) (list 4 5));四边形多段线
    
20.            (mapcar '(lambda(x) (if (= (car x) 10) (setq pts (cons (cdr x) pts)))) dxfcod)
    
21.            (if (or (= (cdr (assoc 70 dxfcod)) 1) (equal (car pts) (last pts) 0.0001))
    
22.              (if (and (per (car pts) (cadr pts) (car pts) (cadddr pts))
    
23.                       (per (cadr pts) (car pts) (cadr pts) (caddr pts))
    
24.                       (per (caddr pts) (cadr pts) (caddr pts) (cadddr pts))
    
25.                    );三个角为90度
    
26.                (setq ss2 (ssadd en ss2))
    
27.              )
    
28.             )
    
29.            )
    
30.       )
    
31.     (setq n (1+ n))
    
32.     )
    
33.   ss2
    
34.   )

(defun c:tt1(ss / per ss1 n en dxfcod pts ss2)<br />   (defun per (ap1 ap2 bp1 bp2 / a-> b-> ) ;判断垂直,向量点积为零<br />   (setq a-> (mapcar '- ap1 ap2) b-> (mapcar '- bp1 bp2)) <br />   (if (equal (apply '+ (mapcar '* a-> b->)) 0 0.0001) t nil)<br />   )<br />   (command "_.convert" "p" "s" ss "")<br />   (sssetfirst nil ss)<br />   (setq ss1 (ssget ":e" '((0 . "*POLYLINE") (-4 . "<or")<br />                           (-4 . "<and") (-4 . "=") (90 . 2) (-4 . "=") (40 . 0) (-4 . "=") (41 . 0) (-4 . "=") (42 . 1.0) (-4 . "=") (70 . 1)<br />                           (-4 . "and>")<br />                           (-4 . "<and") (-4 . "<or") (-4 . "=") (90 . 4) (-4 . "=") (90 . 5) (-4 . "or>") (-4 . "=") (40 . 0) (-4 . "=") (41 . 0) (-4 . "and>")<br />                           (-4 . "or>"))))<br />   (setq n 0 ss2 (ssadd))<br />   (repeat (sslength ss1)<br />     (setq en (ssname ss1 n))<br />     (setq dxfcod (entget en) pts nil)<br />     (cond ((= (cdr (assoc 90 dxfcod)) 2) (setq ss2 (ssadd en ss2)));园环<br />           ((member (cdr (assoc 90 dxfcod)) (list 4 5));四边形多段线<br />            (mapcar '(lambda(x) (if (= (car x) 10) (setq pts (cons (cdr x) pts)))) dxfcod)<br />            (if (or (= (cdr (assoc 70 dxfcod)) 1) (equal (car pts) (last pts) 0.0001))<br />              (if (and (per (car pts) (cadr pts) (car pts) (cadddr pts))<br />                       (per (cadr pts) (car pts) (cadr pts) (caddr pts))<br />                       (per (caddr pts) (cadr pts) (caddr pts) (cadddr pts))<br />                    );三个角为90度<br />                (setq ss2 (ssadd en ss2))<br />              )<br />             )<br />            )<br />       )<br />     (setq n (1+ n))<br />     )<br />   ss2<br />   )

pzweng

学习了

sfzyr

看得我都沒信心了

YAOSHIWEI

太厉害了

gao051525

好难啊，菜鸟路过

chlh_jd

虽然试卷已经公布答案了，个人觉得第1题对于从事建筑结构设计还是比较有帮助的，如选择封闭圆环多义线经常可以用来选择点钢筋

1. (ssget '((0 . "LWPOLYLINE") (90 . 2) (70 . 1) (42 . 1)))

复制代码

选择矩形目前未发现其妙用，对于轻装多义线发下我的代码：

2. ;;;SS已知选择集分离出封闭圆环和矩形轻装多义线
   
3. (defun test1 (ss / i en ent pts l1 l2)
   
4.   (setq i -1)
   
5.   (while (setq en (ssname ss (setq i (1+ i))))
   
6.     (setq ent (entget en (list "*")))
   
7.     (setq pts (ss-assoc 10 ent))
   
8.     (cond ((or
   
9.              (and (= (dxf 90 ent) 2)
   
10.                   (= (dxf 70 ent) 1)
    
11.                   (apply (function =) (cons 1 (ss-assoc 42 ent)))
    
12.              )
    
13.              (and (= (dxf 90 ent) 3)
    
14.                   (= (dxf 70 ent) 0)
    
15.                   (equal (car pts) (last pts) 1e-6)
    
16.                   (apply (function =) (cons 1 (ss-assoc 42 ent)))
    
17.              )
    
18.            )
    
19.            (setq l1 (cons en l1))
    
20.           )
    
21.           ((or
    
22.              (and (= (dxf 90 ent) 4)
    
23.                   (= (dxf 70 ent) 1)
    
24.                   (apply (function =) (cons 0 (ss-assoc 42 ent)))
    
25.                   (equal (distance (car pts) (caddr pts))
    
26.                          (distance (cadr pts) (last pts))
    
27.                          1e-6
    
28.                   )
    
29.              )
    
30.              (and (= (dxf 90 ent) 5)
    
31.                   (= (dxf 70 ent) 0)
    
32.                   (apply (function =) (cons 0 (ss-assoc 42 ent)))
    
33.                   (equal (car pts) (last pts) 1e-6)
    
34.                   (equal (distance (car pts) (caddr pts))
    
35.                          (distance (cadr pts) (last pts))
    
36.                          1e-6
    
37.                   )
    
38.              )
    
39.            )
    
40.            (setq l2 (cons en l2))
    
41.           )
    
42.     )
    
43.   )
    
44.   (list l1 l2)
    
45. )
    
46. ;;查找组码
    
47. (defun dxf (a b)
    
48.   (cdr (assoc a b))
    
49.   )
    
50. ;;批量查找组码
    
51. (defun ss-assoc        (a lst / b res)
    
52.   (while (setq b (assoc a lst))
    
53.     (setq lst  (cdr (member b lst))
    
54.           res (cons (cdr b) res)
    
55.     ))(reverse res))

;;;SS已知选择集分离出封闭圆环和矩形轻装多义线<br /> (defun test1 (ss / i en ent pts l1 l2)<br />   (setq i -1)<br />   (while (setq en (ssname ss (setq i (1+ i))))<br />     (setq ent (entget en (list "*")))<br />     (setq pts (ss-assoc 10 ent))<br />     (cond ((or<br />              (and (= (dxf 90 ent) 2)<br />                   (= (dxf 70 ent) 1)<br />                   (apply (function =) (cons 1 (ss-assoc 42 ent)))<br />              )<br />              (and (= (dxf 90 ent) 3)<br />                   (= (dxf 70 ent) 0)<br />                   (equal (car pts) (last pts) 1e-6)<br />                   (apply (function =) (cons 1 (ss-assoc 42 ent)))<br />              )<br />            )<br />            (setq l1 (cons en l1))<br />           )<br />           ((or<br />              (and (= (dxf 90 ent) 4)<br />                   (= (dxf 70 ent) 1)<br />                   (apply (function =) (cons 0 (ss-assoc 42 ent)))<br />                   (equal (distance (car pts) (caddr pts))<br />                          (distance (cadr pts) (last pts))<br />                          1e-6<br />                   )<br />              )<br />              (and (= (dxf 90 ent) 5)<br />                   (= (dxf 70 ent) 0)<br />                   (apply (function =) (cons 0 (ss-assoc 42 ent)))<br />                   (equal (car pts) (last pts) 1e-6)<br />                   (equal (distance (car pts) (caddr pts))<br />                          (distance (cadr pts) (last pts))<br />                          1e-6<br />                   )<br />              )<br />            )<br />            (setq l2 (cons en l2))<br />           )<br />     )<br />   )<br />   (list l1 l2)<br /> )<br /> ;;查找组码<br /> (defun dxf (a b)<br />   (cdr (assoc a b))<br />   )<br /> ;;批量查找组码<br /> (defun ss-assoc        (a lst / b res)<br />   (while (setq b (assoc a lst))<br />     (setq lst  (cdr (member b lst))<br />           res (cons (cdr b) res)<br />     ))(reverse res))

野狼谷/〈M〉

好程序，留个脚板印