【活动结束】LISP知识测试问卷--第三期[难度指数[★★★☆]
本帖最后由 caoyin 于 2012-1-5 08:35 编辑本期试题因难度高，参与人数少。现公布答题结果，感谢各位的关注与参与！
====================================================================
早前一段时间，LISP版块出了两期答题活动，反响不错。时维岁末、辞旧迎新之际，特推出试题N期，向大家拜早年！
本期试题提供fsxm、caoyin
本期试题较上两期难度有所增大，属于中级偏高，但这一点别把大家吓倒了，题目都很典型，也很实用
希望新老朋友积极参与！
答题期限至：2012.1.5
-----------------------------------------------------------------------------------------------------------------------------------------
1.【选择集处理】8分
已知一个选择集，要求从选择集中筛选出符合下列描述的对象：
(1)圆环(由2个半圆组成的封闭多段线)、矩形(由多段线构成的封闭的直角平行四边形，补充：四边形可以理解为4条段)；
(2)忽略LWEIGHT命令概念的线宽，多段线线宽为0；
(3)起点、终点重合即可被认为封闭。
2.【几何运算】9分
已知一条端点为A和B的直线，将该直线以A端点为基点旋转89度，再以B端点为基点
缩放3.5倍，用几何方法求出直线的2个新端点。禁用polar、command、vl-cmdf函数
3.【点集处理】15分
已知一个包含若干个点的表，若表中相邻两个点之间的距离大于100，则
在两点之间添加中点，直到表中相邻两个点之间距离小于或等于100。
限用递归法。
4.【图形对象操作】8分
已知一个云线(由REVCLOUD命令绘制的包含若干弧段的多段线)，用VLISP方法
将云线翻转(即把弧段的凸度方向调整为反方向)，禁用command、vl-cmdf函数
5.【非图形对象操作】20分
在禁用炸开命令的前提下，将将MLINE转换为LINE。
6.【曲线计算】10分
已知共面且不相交的一直线和一圆弧，求两个对象之间的最小距离。
7.【非图形对象操作】10分
分解图元所在编组(GROUP)，即清除编组定义。禁用command、vl-cmdf函数。
8.【实用技巧】20分
找出指定fas程序文件中的所有命令(C:开头的函数)。
提示：fas可能已加载。测试文件见附件test.fas。
---------------------------------------------------------------------------------------
谢谢vormittag兄指出问题！
“第2题应该指明旋转平面或旋转轴，否则无穷多解。”
“第6题只价值10分好像少了点。除非加上直线和圆弧共面这一条件”
---------------------------------------------------------------------------------------
这两题的补充条件：
第2、6题，只理解为二维方面的操作和计算。
即，第2题的旋转轴为Z轴，第6题直线和圆弧共面。
---------------------------------------------------------------------------------------
因现在大家看不到代码，先把编译的结果发上来供大家测试！
By Gu_xl
本帖最后由 Gu_xl 于 2012-1-6 23:20 编辑
，第五题有点麻烦，以下是除第5题外的所有程序代码
(princ "\n第一题到第八题运行命令分别是:tt1 ~ tt8")
;|
1.【选择集处理】8分
已知一个选择集，要求从选择集中筛选出符合下列描述的对象：
(1)圆环(由2个半圆组成的封闭多段线)、矩形(由多段线构成的封闭的直角平行四边形)；
(2)忽略LWEIGHT命令概念的线宽，多段线线宽为0；
(3)起点、终点重合即可被认为封闭。
|;
(defun tt1(SS / DXF POLYHASARCP BULGE->ARCCP TANG
PI2 SS1 NN ENT N PARAM OBJ
FLAG CP P1 BULGE P2 EN PTS
CNT K P3 AN
)
;;;取组码
(defun dxf(en i)
(cdr (assoc i (entget en)))
)
;;;多段线是否含圆弧段
(defun PolyHasArcP (EN / ENL FLAG)
(cond ((= "POLYLINE" (dxf en 0))
(while (and (not flag)
(setq en (entnext en))
(= "VERTEX" (dxf en 0))
)
(if (/= 0 (dxf en 42))
(setq flag t)
)
)
flag
)
((= "LWPOLYLINE" (dxf en 0))
(setq enl
(vl-remove-if-not '(lambda (x) (= 42 (car x))) (entget en))
)
(vl-some '(lambda (x) (/= 0 (cdr x))) enl)
)
)
)
;;;(Bulge->ArcData 起点 终点 弓弦比) 根据起点 终点 弓弦比计算圆心坐标
(defun Bulge->ArcCP(p1 p2 bulg / ang cen rad)
(setq ang (* 2.0 (atan bulg))
rad (/ (distance p1 p2) (* 2.0 (sin ang)))
)
(polar p1 (+ (- (/ pi 2.) ang) (angle p1 p2)) rad)
)
;;;TAng 角度相除取余
(defun TAng(ang a / n)
(if (MINUSP ang) (setq ang (+ ang pi pi)))
(setq n (rem ang a))
(if (equal n a 1e-6)
0.0
n)
)
(setq pi2 (* 0.5 pi)) ;_ 90度角
(setq ss1 (ssadd)) ;_ 储存结果
(repeat (setq nn (sslength ss))
(setq ent (ssname ss (setq nn (1- nn))))
(if (WCMATCH (dxf ent 0) "*POLYLINE") ;_ 多段线
(progn
(if (equal (vlax-curve-getStartPoint ent)
(vlax-curve-getEndPoint ent)
1e-6) ;_ 看起来闭合
(progn
(cond ((PolyHasArcP ent) ;_ 多段线含圆弧,则必须所有段必须为弧段，且所有弧共同一个圆心
(if (= "LWPOLYLINE" (dxf ent 0)) ;_ 轻体多段线
(progn
(setq n 0
param (fix (vlax-curve-getEndParam ent))
obj (vlax-ename->vla-object ent)
Flagt
CP nil
)
(while (and (< n param)
Flag
)
(if (setq flag (/= 0.0 (vla-GetBulge obj n))) ;_为弧段
(progn
(setq p1 (vlax-curve-getPointAtParam obj n)
bulge (vla-GetBulge obj n)
p2 (vlax-curve-getPointAtParam
obj
(setq n (1+ n))
)
)
(if (null CP)
(setq CP (Bulge->ArcCP p1 p2 bulge))
(progn
(setq Flag
(equal CP
(Bulge->ArcCP p1 p2 bulge)
1e-6
)
)
)
)
)
;;;判断，若为直线段结束判断
(setq flag nil)
)
)
)
(progn ;_ POLYLINE
(setq en ent
flag t
CP nil
p1 nil p2 nil
)
(while (and flag
(setq en (entnext en))
(= "VERTEX" (dxf en 0))
(= "VERTEX" (dxf (entnext en) 0))
)
(if (= 0 (dxf en 42))
(setq flag nil)
(progn
(setq p1 (dxf en 10)
bulge (dxf en 42)
p2 (gxl-dxf (entnext en) 10)
)
(if (null CP)
(setq CP (Bulge->ArcCP p1 p2 bulge))
(progn
(setq Flag
(equal CP
(Bulge->ArcCP p1 p2 bulge)
1e-6
)
)
)
)
)
)
)
) ;_ progn
)
Flag ;_ 返回判断结果
)
(t ;_ 多段线不含圆弧，该多段线所有折角必须为直角，为180度的忽略，且只能有4个直角
(if (> (setq param(fix (vlax-curve-getEndParam ent))) 3) ;_ 四边形最少4点
(progn
(setq pts nil n 0)
(repeat (1+ param)
(setq pts (cons (vlax-curve-getPointAtParam ent n) pts) n (1+ n))
)
(setq pts (reverse (cdr pts))) ;_ 去除闭合点
(setq Flag t n 0 cnt 0)
(while (and Flag (< n (setq k (length pts))))
(if (< 0n (1- k))
(setq p1 (nth (1- n) pts)
p2 (nth n pts)
p3 (nth (1+ n) pts)
)
(if (= n 0)
(setq p1 (last pts)
p2 (nth n pts)
p3 (nth (1+ n) pts)
)
(setq p1 (nth (1- n) pts)
p2 (nth n pts)
p3 (car pts)
)
)
)
(setq n (1+ n))
(if (equal pi2 (setq an (tang (- (angle p2 p3) (angle p2 p1)) pi)) 1e-6)
(progn
(setq cnt (1+ cnt))
(if (> cnt 4) (setq flag nil))
)
(if (not (equal an 0 1e-6))
(setq flag nil)
)
)
)
(if (and flag (= 4 cnt)) (setq flag t) (setq flag nil))
)
(setq flag nil)
)
flag ;_ 返回判断结果
)
)
(if flag (ssadd ent ss1)) ;_ 满足条件添加到选择集ss1
)
)
)
)
)
(if (> (sslength ss1) 0) ss1)
)
;;;测试1
(defun c:tt1 ()
(setq ss (ssget))
(if ss
(progn
(setq ss (tt1 ss))
(if ss
(progn
(setq n (sslength ss))
(princ (strcat "\n**共选择 " (itoa n) " 个物体**"))
(sssetfirst nil ss)
)
)
)
)
(princ)
)
;|
2.【几何运算】9分
已知一条端点为A和B的直线，将该直线以A端点为基点旋转89度，再以B端点为基点
缩放3.5倍，用几何方法求出直线的2个新端点。禁用polar、command、vl-cmdf函数
|;
;;;参数 line = 直线图元 ang = 旋转角弧度 scale = 缩放比例 Flag = T 直线起点为基点旋转，nil反之
(defun tt2 (LINE ANG SCALE FLAG / DXF PA PB L NOR PA1 PB1 ENL)
;;;取组码
(defun dxf (en i)
(cdr (assoc i (entget en)))
)
(if Flag
(setq PA (dxf line 10)
PB (dxf Line 11)
)
(setq PA (dxf line 11)
PB (dxf Line 10)
)
)
(setq ang (+ ang (angle PA PB)))
(setq l (distance PA PB)) ;_ 直线长
(setq nor (list (cos ang) (sin ang) 0)) ;_ ZAxis
(setq PA1 (trans PA 0 nor)) ;_ A坐标转换到ZAxis
(setq PB1 (trans PB 0 nor)) ;_ B坐标转换到ZAxis
(if (> (caddr PB1) (caddr PA1))
(progn
(setq PB1 (list (car PA1) (cadr PA1) (+ (caddr PA1) l))) ;_ 旋转ang角度后B点在ZAxis轴坐标
(setq PA1 (list (car PA1) (cadr PA1) (- (caddr PA1) (* l (- scale 1))))) ;_ 缩放后A点在ZAxis轴坐标
)
(progn
(setq PB1 (list (car PA1) (cadr PA1) (- (caddr PA1) l))) ;_ 旋转ang角度后B点在ZAxis轴坐标
(setq PA1 (list (car PA1) (cadr PA1) (+ (caddr PA1) (* l (- scale 1))))) ;_ 缩放后A点在ZAxis轴坐标
)
)
(setq PA1 (trans PA1 nor 0)) ;_ 转换到世界坐标系的A点
(setq PB1 (trans PB1 nor 0)) ;_ 转换到世界坐标系的B点
(if Flag
(progn ;_ 更新直线端点坐标
(setq enl (entget line))
(setq enl (subst (cons 10 PA1) (assoc 10 enl) enl))
(setq enl (subst (cons 11 PB1) (assoc 11 enl) enl))
(entmod enl)
)
(progn ;_ 更新直线端点坐标
(setq enl (entget line))
(setq enl (subst (cons 11 PA1) (assoc 11 enl) enl)) ;_ 原先此处有误
(setq enl (subst (cons 10 PB1) (assoc 10 enl) enl)) ;_ 原先此处有误
(entmod enl)
)
)
)
(defun c:tt2(/ D2R LINE P1 FLAG SCALE ANG)
(defun d2r (JD / a)
(setq a (/ (* jd pi) 180.0))
)
(defun dxf (en i)
(cdr (assoc i (entget en)))
)
(setq line (entsel "\n 靠近A基点选择直线:"))
(setq p1 (cadr line)
line (car line)
)
(if (< (distance p1 (dxf line 10)) (distance p1 (dxf line 11)))
(setq flag t)
(setq flag nil)
)
(setq scale (getreal "\n放大倍数<3.5>:"))
(if (null scale) (setq scale 3.5))
(setq ang (GETANGLE"\n 旋转角度<89>:"))
(if (null ang) (setq ang (d2r 89)))
(tt2 line ang scale flag)
(princ)
)
;|
3.【点集处理】15分
已知一个包含若干个三维点的表，若表中相邻两个点之间的距离大于100，则
在两点之间添加中点，直到表中相邻两个点之间距离小于或等于100。
限用递归法。
|;
;(TT3 (list '(0 0 0) '(200 0 0) '(250 0 0) '(450 0 0) '(600 0 0)))
(defun tt3 (pts /midpt go)
(defun midpt (p1 p2)
(mapcar '(lambda (a b) (* 0.5 (+ a b))) p1 p2)
)
(defun go (pt pts)
(if pts
(if (> (distance pt (car pts)) 100)
(go pt (cons (midpt pt (car pts)) pts))
(cons pt (go (car pts) (cdr pts)))
)
(list pt)
)
)
(if (> (length pts) 1)
(go (car pts) (cdr pts))
pts
)
)
;|
4.【图形对象操作】8分
已知一个云线(由REVCLOUD命令绘制的包含若干弧段的多段线)，用VLISP方法
将云线翻转(即把弧段的凸度方向调整为反方向)，禁用command、vl-cmdf函数
|;
(defun c:tt4 (/ ENT OBJ PA N)
(setq ent (car(entsel "\n选择云线: ")))
(if (and ent
(= "LWPOLYLINE" (cdr (assoc 0 (entget ent))))
)
(progn
(setq obj (vlax-ename->vla-object ent)
pa (fix (vlax-curve-getendparam ent))
n 0
)
(repeat pa
(vla-SetBulge obj n (- (vla-GetBulge obj n)))
(setq n (1+ n))
)
)
)
(princ)
)
;|
5.【非图形对象操作】20分
在禁用炸开命令的前提下，将将MLINE转换为LINE。
|;
;|
(defun tt5 (mline)
(setq enl (entget mline))
)
|;
;|
6.【曲线计算】10分
已知共面且不相交的一直线和一圆弧，求两个对象之间的最小距离。
|;
(defun tt6 (ARC LINE / PERTOLINE LST-SPLIT OBJ1OBJ2
PTS D1 P1 P11 D2 P2 P21D3
P3 P31 D4 P4 P41 CP RSTA
ENA PERPTAN D5 RTN DATA MIND
)
;;;(PerToLine pt p1 p2) 计算pt到p1 p2的垂足点
(defun PerToLine (pt p1 p2 / norm)
(setq norm (mapcar '- p2 p1)
p1 (trans p1 0 norm)
pt (trans pt 0 norm)
)
(trans (list (car p1) (cadr p1) (caddr pt)) norm 0)
)
;;;按长度分割表
(defun lst-split (lst len / tmp)
(if lst
(cons
(reverse
(repeat len
(if (car lst)
(setq tmp (cons (car lst) tmp)
lst (cdr lst)
)
)
tmp ;_ 制造返回值
)
)
(lst-split lst len)
)
)
)
(setq obj1 (vlax-ename->vla-object arc)
obj2 (vlax-ename->vla-object line)
)
(if (setq pts (vlax-invoke obj1 'IntersectWith obj2 acExtendNone))
(list (cons 0 (lst-split pts 3))) ;_ 相交，返回距离0及交点
(progn ;_ 不相交
(setq d1 (distance (setq p1 (vlax-curve-getstartpoint line))
(setq p11 (vlax-curve-getclosestpointto arc p1))
)
d2 (distance (setq p2 (vlax-curve-getendpoint line))
(setq p21 (vlax-curve-getclosestpointto arc p2))
)
d3 (distance (setq p3 (vlax-curve-getstartpoint arc))
(setq p31 (vlax-curve-getclosestpointto line p3))
)
d4 (distance (setq p4 (vlax-curve-getendpoint arc))
(setq p41 (vlax-curve-getclosestpointto line p4))
)
cp (cdr (assoc 10 (entget arc)))
r (cdr (assoc 40 (entget arc)))
sta (cdr (assoc 50 (entget arc))) ;_ 圆弧起点角度
ena (cdr (assoc 51 (entget arc))) ;_ 圆弧终点角度
perpt (PerToLine cp p1 p2) ;_ 圆心在直线上的垂足点
)
(if (< ena sta)
(setq ena (+ ena pi pi))
)
(if (equal perpt (vlax-curve-getclosestpointto line perpt) 1e-6)
(progn ;_ 垂足点落在直线段内
(if (or (< sta (setq an (angle cp perpt)) ena)
(< sta (+ an pi pi) ena)
) ;_ 圆心、垂足点方向落在圆弧段内
(progn
(if (> (distance cp perpt) r)
(setq d5 (- (distance cp perpt) r))
)
)
)
)
)
(if d5
(list (list d5 perpt (polar cp an r))) ;_ 返回最小距离和最小距离点
(progn
(setq rtn
(vl-sort (list (list d1 p1 p11)
(list d2 p2 p21)
(list d3 p3 p31)
(list d4 p4 p41)
)
'(lambda (a b) (< (car a) (car b)))
)
)
(setq data (car rtn) rtn (cdr rtn))
(setq mind (car data))
(cons data (vl-remove-if-not '(lambda (X) (equal mind (car x) 1e-6)) rtn))
)
)
)
)
)
(defun c:tt6 (/ ARC LINE RTN DATA)
(while (or
(not (setq arc (car (entsel "\n选择圆弧:"))))
(not (= "ARC" (cdr (assoc 0 (entget arc)))))
)
(princ "\n***选择的不是圆弧***")
)
(while (or
(not (setq line (car (entsel "\n选择直线:"))))
(not (= "LINE" (cdr (assoc 0 (entget line)))))
)
(princ "\n***选择的不是直线***")
)
(setq rtn (tt6 arc line))
(princ
(strcat "圆弧和直线最小距离为: " (rtos (caar rtn) 2 4))
)
(foreach data rtn
(if (and (/= 0 (car data)) (> (length (setq data (cdr data))) 1))
(progn
(entmake
(list '(0 . "line")
'(62 . 1)
(cons 10 (car data))
(cons 11 (cadr data))
)
)
)
(princ "\n***直线和圆弧相交***")
)
)
(princ)
)
;|7.【非图形对象操作】10分
分解图元所在编组(GROUP)，即清除编组定义。禁用command、vl-cmdf函数。
|;
(defun gxl-massoc (key alist)
(mapcar 'cdr (vl-remove-if '(lambda (x) (not (equal key (car x)))) alist))
)
(defun tt7 (ENT / GROUPENAME)
(setq GroupEname nil)
(if ent
(if (listp ent)
(setq GroupEname (GXL-MASSOC 330 ent))
(setq GroupEname (GXL-MASSOC 330 (entget ent)))
)
)
(setq GroupEname (reverse (cdr (reverse GroupEname))))
(if GroupEname
(progn
(princ (strcat "\n***删除 "
(itoa (length GroupEname))
" 个编组***"
)
)
(mapcar 'entdel GroupEname)
)
(princ "\n***该图元无编组***")
)
)
(defun c:tt7 (/ ent)
(while (setq ent (car(entsel "\n选择要删除组的图元:")))
(tt7 ent)
)
(princ)
)
;|
8.【实用技巧】20分
找出指定fas程序文件中的所有命令(C:开头的函数)。
提示：fas可能已加载。测试文件见附件test.fas。
|;
;;;请在未打开VLISP编辑器下运行！
;;;参数 FILENAME = fas。vlx文件名 EXPECTIONFUNS = 例外C:函数表
(defun tt8 (FILENAME EXPECTIONFUNS / FUNCLST1 I SAVEFUNCS FUNCLST2)
(setq funclst1 (vl-remove-if-not '(lambda (X) (= "C:" (substr (strcase x) 1 2))) (atoms-family 1)))
(if expectionfuns ;_ 移除例外C:函数
(mapcar '(lambda (a) (setq funclst1 (vl-remove-if '(lambda (X) (= (strcase a) (strcase x))) funclst1))) expectionfuns)
)
(setq i 0)
(setq saveFuncs (mapcar '(lambda (x) (read (strcat "*fun*" (itoa (setq i (1+ i)))))) funclst1))
(mapcar 'set saveFuncs (mapcar '(lambda (x) (eval (read x))) funclst1))
(mapcar '(lambda (x) (if (= 'sym (type (read x))) (set (read x) nil))) funclst1) ;_ 原C:函数置空
(load filename "已加载该 LISP 应用程序!")
(setq funclst2 (vl-remove-if-not '(lambda (X) (= "C:" (substr (strcase x) 1 2))) (atoms-family 1))) ;_ Fas、Vlx中C:函数
(mapcar '(lambda (x) (if (= 'sym (type (read x))) (set (read x) nil))) funclst2) ;_ C:函数置空
(mapcar 'set (mapcar 'read funclst1) (mapcar 'eval saveFuncs)) ;_ 恢复保存函数
(if expectionfuns ;_ 移除例外C:函数
(mapcar '(lambda (a) (setq funclst2 (vl-remove-if '(lambda (X) (= (strcase a) (strcase x))) funclst2))) expectionfuns)
)
funclst2 ;_ 返回值
)
(defun c:tt8 (/ filename lst)
(setq filename (getfiled "" "" "fas;vlx" 4))
(if filename
(progn
(setq lst (tt8 filename (list "c:tt8")))
(princ lst)
)
)
(princ)
)
;;;云运行结果 '(C:ISOOBJ C:HIDEOBJ C:HIDESWAP C:SHOWALL)
;|另两个局部函数名
EA:SSONOFFFSXM-SETENDXF
|;
第五题真麻烦，花了数个小时才搞定，纯AutoLisp代码，读DXF组码写的：
;|
5.【非图形对象操作】20分
在禁用炸开命令的前提下，将将MLINE转换为LINE。
|;
;;
;; Copyright (c)2011.12.31 Gu_xl
;; 版权所有Gu_xl
;;
;;作者保留本程序的一切权利，但你可以自由拷贝与复制、修改本程序用于非商业目的。
;;作者尽力将本程序做得完善，但不会因本软件的错失而造成的损失承担任何责任。
;;本程序仅提供作为应用上的参考, 而未声明或隐含任何保证; 对于任何特殊用途之适
;;应性, 以及商业销售所隐含作出的保证, 在此一概予以否认。
;;
(vl-load-com)
;;;*************函数 gxl-codestrip.lsp*************
;; | ---------------------------------------------------------------------------
;; | (gxl-CodeStrip entl StripLst) 将entl表 剔除StripLst表中的组码值
;;;(gxl-CodeStrip (entget (car(entsel))) (list 330 -1 5 8 70 100 10))
(defun gxl-CodeStrip( entl StripLst)
(vl-remove-if '(lambda ( a ) (vl-position (car a) StripLst)) entl)
)
;;;***************** 函数 gxl-CodeStrip*****************
;;;*************函数 gxl-listmlstyle.lsp*************
;;;打印多样式数据表
;;;(gxl-listmlstyle "Standard")
(defun gxl-listmlstyle (name / mltable ent flag)
(setq mltable (dictsearch (namedobjdict) "ACAD_MLINESTYLE")
flag t)
(while (and flag mltable)
(setq data (car mltable)
mltable (cdr mltable)
)
(if (= 3 (car data))
(if (= (strcase name) (strcase (cdr data)))
(setq flag nil
ent (cdar mltable)
)
)
)
)
(if ent
(progn
(setq ent (entget ent))
(GXL-CODESTRIP ent (list -1 5 102 330))
)
)
)
;;;***************** 函数 gxl-listmlstyle*****************
;;;*************函数 gxl-listp.lsp*************
;;;(gxl-listp lst) 判断表是否为真正的表,非nil、非点对表
;;;(gxl-listp nil) nil (gxl-listp '(1 . 2)) (gxl-listp '(12))
(defun gxl-listp (lst)
(and (vl-consp lst)
(vl-list-length lst)
)
)
;;;***************** 函数 gxl-listp*****************
;;;*************函数 gxl-dxf.lsp*************
(defun gxl-dxf (ent i)
(if (= (type ent) 'ename)
(setq ent (entget ent '("*")))
)
(cond ((atom i)
(cdr (assoc i ent))
)
((gxl-listp i)
(mapcar '(lambda (x) (cdr (assoc x ent))) i)
)
)
)
;;;***************** 函数 gxl-dxf*****************
;;;*************函数 gxl-midpoint.lsp*************
;;;==================================================================
;;;gxl-MidPoint 表操作函数,计算两点的中点
;;;计算两点的中点
;;;==================================================================
(defun gxl-MidPoint (p1 p2)
(if (and (> (length p1) 2)(> (length p2) 2))
(list (* 0.5 (+ (car p1) (car p2))) (* 0.5 (+ (cadr p1) (cadr p2))) (* 0.5 (+ (caddr p1) (caddr p2))))
(list (* 0.5 (+ (car p1) (car p2))) (* 0.5 (+ (cadr p1) (cadr p2))))
)
)
;;;***************** 函数 gxl-MidPoint*****************
;;;*************函数 gxl-sel-entnextall.lsp*************
;;;gxl-Sel-EntNextAll en 返回 en 之后的所有物体选择集，无则返回 nil,en为nil返回图形全部图元
(defun gxl-Sel-EntNextAll (ent / ss)
(if (not ent)
(progn
(setq ent (entnext))
(if ent
(setq ss (ssadd ent))
(setq ss (ssadd))
)
)
(setq ss (ssadd))
)
(while (setq ent (entnext ent))
(if (not (member (cdr (assoc 0 (entget ent))) '("ATTRIB" "VERTEX" "SEQEND")))
(ssadd ent ss)
)
)
(if (= 0 (sslength ss))
nil
ss
)
)
;;;***************** 函数 gxl-Sel-EntNextAll*****************
;;;(gxl-Sel-Mapcar ss Fun) 遍历选择集对所包含的图元进行指定函数操作,返回操作后的表
(defun gxl-Sel-Mapcar (ss Fun / nn rtn)
(if ss
(repeat (setq nn (sslength ss))
(setq rtn (cons (apply Fun (list (ssname ss (setq nn (1- nn))))) rtn))
)
)
)
;;;*************************************************
;| 参数：mldata 多线样式组码表
(setq mldata '((0 . "MLINESTYLE")
(100 . "AcDbMlineStyle")
(2 . "A0") ;_ 多线样式名
(70 . 1634) ;_ 70 标志（按位编码）：
;_ 1 =填充
;_ 2 = 显示斜接
;_ 16 = 开始矩形结束（直线）封口
;_ 32 = 开始内弧封口
;_ 64 = 开始圆（外弧）封口
;_ 256 = 结束矩形（直线）封口
;_ 512 = 结束内弧封口
;_ 1024 = 结束圆（外弧）封口
(3 . "") ;_ 样式说明（字符串，最多为 255 个字符）
(62 . 0) ;_ 填充颜色（整数，默认值 = 256）
(51 . 1.5708) ;_ 起点角度（实数，默认值为 90 度）
(52 . 1.5708) ;_端点角度（实数，默认值为 90 度
(71 . 2) ;_ 元素数
(49 . 0.5) ;_ 元素偏移（实数，无默认值）。可以存在多个条目；每个元素一个条目
(62 . 256) ;_ 元素颜色（整数，默认值 = 0）。可以存在多个条目；每个元素一个条目
(6 . "权界线共有") ;_ 元素线型（字符串，默认值 = 随层）。可以存在多个条目；每个元素一个条目
(49 . -0.5) ;_ 元素偏移（实数，无默认值）。可以存在多个条目；每个元素一个条目
(62 . 256) ;_ 元素颜色（整数，默认值 = 0）。可以存在多个条目；每个元素一个条目
(6 . "权界线共有") ;_ 元素线型（字符串，默认值 = 随层）。可以存在多个条目；每个元素一个条目
)
)
|;
;;;(gxl-ml2line mline) 多线转直线
;;;(gxl-ml2line (car(entsel)))
(defun gxl-ml2line (MLINE /MAKELINEMAKEARC MLDATA
MLTYPEDATA DXF70 LINETYPES
COLORSDISPLAYJIONS SCALE
ALIGNCLOSEDP LAYER BASEPT
ANG1ANG2 STARTANGNEWPTS
NUMPTS PT P1
P2MP N K
NODEPTSNEXTNODEOLDPTS STPTS
ENDANGENDPTS TMPPT TMPCOLORS
TMPLTYPES LOOP CP EndEntity
)
(defun makeline (p1 p2 Ltype layer color)
(entmake
(list '(0 . "line")
(cons 8 layer)
(cons 62 color)
(cons 6 ltype)
(cons 10 p1)
(cons 11 p2)
)
)
(entlast)
)
(defun makeArc (cp p1 p2 Ltype layer color)
(entmake
(list '(0 . "arc")
(cons 8 layer)
(cons 62 color)
(cons 6 ltype)
(cons 10 cp)
(cons 40 (distance cp p1))
(cons 50 (angle cp p1))
(cons 51 (angle cp p2))
)
)
)
(setq EndEntity (entlast))
(setq mldata (entget mline))
(setq Mltypedata (gxl-listmlstyle (gxl-dxf mline 2))) ;_ 多线样式表
(setq dxf70 (gxl-dxf Mltypedata 70))
(setq LineTypes (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= 6 (car x))) Mltypedata))) ;_ 线型表
(setq Colors (cdr (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= 62 (car x))) Mltypedata)))) ;_颜色表
(setq DisPlayJions (= 2 (logand dxf70 2))) ;_ 2 = 显示斜接
(setq scale (gxl-dxf mline 40) ;_ 比例因子
align (gxl-dxf mline 40) ;_ 对正：0 = 上；1 = 无；2 = 下
closedp(= 2 (logand (gxl-dxf mline 71) 2)) ;_ 是否闭合
layer (gxl-dxf mline 8)
)
(setq mldata (member (assoc 11 mldata) mldata))
(while (= (caar mldata) 11) ;_ 一个线段开始
(setq basept (gxl-dxf mldata 11) ;_ 顶点
ang1 (angle '(0 0 0) (gxl-dxf mldata 12)) ;_ 从该顶点开始的线段的方向角度
ang2 (angle '(0 0 0) (gxl-dxf mldata 13)) ;_ 此顶点处的斜接方向角度
mldata (cdddr mldata)
)
(if (null StartAng)(setq StartAng ang1)) ;_ 储存起点直线方向
(setq NewPts nil)
(while (= 74 (caar mldata)) ;_ 一个顶点开始
(setq Num (cdar mldata) ;_ 元素的参数数目
mldata (cdr mldata)
pts nil ;_ 直线段点清空
)
(setq pt (polar basept ang2 (cdar mldata)) ;_ 斜接方向点
mldata (cdr mldata)
pt (polar pt ang1 (cdar mldata)) ;_ 直线方向点
mldata (cdr mldata)
)
(setq pts (cons pt pts))
(repeat (- num 2) ;_ 含打断点
(setq pts (cons (polar pt ang1 (cdar mldata)) pts)
mldata (cdr mldata)
)
)
(setq mldata (cdr mldata)
pts (reverse pts) ;_ 一条直线段点
NewPts (cons pts NewPts)
)
)
(setq NewPts (reverse NewPts))
(if DisPlayJions ;_ 显示斜接
(progn
(setq p1 (caar NewPts)
p2 (car (last NewPts))
mp (GXL-MIDPOINT p1 p2)
)
(makeline p1 mp (car LineTypes) layer (car colors))
(makelinemp p2 (last LineTypes) layer (last colors))
)
)
(if oldPts
(progn
(setq n 0 k 0)
(repeat (length oldpts)
(setq NodePts(nth n oldpts) ;_ 上一直线结点坐标
nextNode (car (nth n NewPts)) ;_ 本段直线起点
n (1+ n)
)
(setq NodePts (append NodePts (list nextNode)))
(makeline (car NodePts) (cadr NodePts) (nth k LineTypes) layer (nth k colors)) ;_ 划线
(setq NodePts (cddr NodePts))
(while NodePts
(makeline (car NodePts) (cadr NodePts) (nth k LineTypes) layer (nth k colors)) ;_ 划线
(setq NodePts (cddr NodePts))
)
(setq k (1+ k))
)
(setq oldPts NewPts)
)
(setq oldPts NewPts
stpts (mapcar 'car NewPts) ;_ 保存起始结点点
)
)
)
(setq EndAng ang1) ;_ 储存终点直线方向
(setq endpts(mapcar 'car NewPts)) ;_ 保存起始结点
(if closedp
(progn
(apply 'mapcar (list 'makeline stpts endpts LineTypes (mapcar '(lambda(x) layer) stpts) colors)) ;_ 绘制闭合线
)
(progn
(if (not DisPlayJions) ;_ 不显示斜接
(progn
(if (= 16 (logand dxf70 16)) ;_ 16 = 开始矩形结束（直线）封口
(progn
(if (> (length stpts) 1)
(progn
(makeline (car stpts) (last stpts) "BYLAYER" layer 256)
)
)
)
)
(if (= 256 (logand dxf70 256)) ;_ 256 = 结束矩形（直线）封口
(progn
(if (> (length endpts) 1)
(progn
(makeline (car endpts) (last endpts) "BYLAYER" layer 256)
)
)
)
)
)
)
(if (= 64 (logand dxf70 64)) ;_ 64 = 开始圆（外弧）封口
(progn
(setq tmppt stpts tmpcolors colors tmpltypes LineTypes)
(setq p1 (car tmppt) ;_ 弧端点
p2 (last tmppt) ;_ 弧端点
cp (GXL-MIDPOINT p1 p2) ;_ 圆心点
mp (polar cp StartAng (- (distance cp p1))) ;_ 圆弧中点
)
(makeArc cp p1 mp (car tmpltypes) layer (car tmpcolors))
(makeArc cpmp p2 (car tmpltypes) layer (last tmpcolors))
)
)
(if (= 32 (logand dxf70 32)) ;_ 32 = 开始内弧封口
(progn
(setq tmppt stpts tmpcolors colors tmpltypes LineTypes)
(setq tmppt (reverse (cdr (reverse (cdr tmppt)))))
(setq tmpcolors (reverse (cdr (reverse (cdr tmpcolors)))))
(setq tmpltypes (reverse (cdr (reverse (cdr tmpltypes)))))
(while (> (length tmppt) 1)
(setq p1 (car tmppt) ;_ 弧端点
p2 (last tmppt) ;_ 弧端点
cp (GXL-MIDPOINT p1 p2) ;_ 圆心点
mp (polar cp StartAng (- (distance cp p1))) ;_ 圆弧中点
)
(makeArc cp p1 mp (car tmpltypes) layer (car tmpcolors))
(makeArc cpmp p2 (car tmpltypes) layer (last tmpcolors))
(setq tmppt (reverse (cdr (reverse (cdr tmppt)))))
(setq tmpcolors (reverse (cdr (reverse (cdr tmpcolors)))))
(setq tmpltypes (reverse (cdr (reverse (cdr tmpltypes)))))
)
)
)
(if (= 1024 (logand dxf70 1024)) ;_ 1024 = 结束圆（外弧）封口
(progn
(setq tmppt endpts tmpcolors colors tmpltypes LineTypes)
(setq p1 (car tmppt) ;_ 弧端点
p2 (last tmppt) ;_ 弧端点
cp (GXL-MIDPOINT p1 p2) ;_ 圆心点
mp (polar cp EndAng (distance cp p1)) ;_ 圆弧中点
)
(makeArc cpmp p1 (car tmpltypes) layer (car tmpcolors))
(makeArc cpp2 mp(car tmpltypes) layer (last tmpcolors))
)
)
(if (= 512 (logand dxf70 512)) ;_ 512 = 结束内弧封口
(progn
(setq tmppt endpts tmpcolors colors tmpltypes LineTypes)
(setq tmppt (reverse (cdr (reverse (cdr tmppt)))))
(setq tmpcolors (reverse (cdr (reverse (cdr tmpcolors)))))
(setq tmpltypes (reverse (cdr (reverse (cdr tmpltypes)))))
(while (> (length tmppt) 1)
(setq p1 (car tmppt) ;_ 弧端点
p2 (last tmppt) ;_ 弧端点
cp (GXL-MIDPOINT p1 p2) ;_ 圆心点
mp (polar cp EndAng (distance cp p1)) ;_ 圆弧中点
)
(makeArc cpmp p1 (car tmpltypes) layer (car tmpcolors))
(makeArc cpp2 mp(car tmpltypes) layer (last tmpcolors))
(setq tmppt (reverse (cdr (reverse (cdr tmppt)))))
(setq tmpcolors (reverse (cdr (reverse (cdr tmpcolors)))))
(setq tmpltypes (reverse (cdr (reverse (cdr tmpltypes)))))
)
)
)
)
)
(entdel mline) ;_ 删除多线
(GXL-SEL-ENTNEXTALL EndEntity) ;_ 返回选择直线集
)
(defun c:tt5 ()
(princ "\n***多线转直线，请选择多线: ")
(setq ss (ssget ":L" '((0 . "mline"))))
(GXL-SEL-MAPCAR ss 'GXL-ML2LINE)
(princ)
)
这是什么情况好强悍 貌似都不会啊 汗颜啊 好像一题都不会 考试题目难度如何？ 本帖最后由 langjs 于 2011-12-29 20:58 编辑
;;; 测试
(defun c:aa ( / mame p r1 s)
(setq mame (car (entsel "\n选择直线:"))
p (getpoint "\n旋转基点:")
r1 89
s 3.5
)
(uu mame p r1 s)
)
(defun uu (mame p r1 s / ent l new_l new_r newpt_a newpt_b pt_a pt_ax pt_ay pt_b r x1 y1)
(setq ent (entget mame))
(if (equal p (cdr (assoc 10 ent)))
(setq pt_a (cdr (assoc 10 ent))
pt_b (cdr (assoc 11 ent))
)
(if (equal p (cdr (assoc 11 ent)))
(setq pt_a (cdr (assoc 11 ent))
pt_b (cdr (assoc 10 ent))
)
(progn
(princ "\n旋转基点不是直线端点，程序退出")
(exit)
)
)
)
(setq pt_ax (car pt_a)
pt_ay (cadr pt_a)
l (distance pt_a pt_b)
r (* 180 (/ (angle pt_a pt_b) pi))
new_r (* pi (/ (- r (- 90 r1)) 180))
x1 (* l (sin new_r))
y1 (* l (cos new_r))
newpt_b (list (- pt_ax x1) (+ pt_ay y1))
y1 (* l (sin new_r))
new_l (* l (- s 1))
x1 (* new_l (sin new_r))
y1 (* new_l (cos new_r))
newpt_a (list (+ pt_ax x1) (- pt_ay y1))
)
(list newpt_a newpt_b)
)
本帖最后由 qjchen 于 2011-12-30 12:59 编辑
做下第二题
;;已知一条端点为A和B的直线，将该直线以A端点为基点旋转89度，再以B端点为基点
;;缩放3.5倍，用几何方法求出直线的2个新端点。
;;;考试函数 by qjchen
;;; 绕某点旋转的矩阵(2d)
(defun q:matrix:rotateByPoint(p0 theta / a b)
(setq a (car p0) b (cadr p0))
(list (list (cos theta) (- (sin theta)) 0 (+ (* -1 a (cos theta)) (* b (sin theta)) a))
(list (sin theta) (cos theta) 0 (- b (* a (sin theta)) (* b (cos theta))) )
'(0 0 1 0)
'(0 0 0 1))
)
;;; 绕某点缩放的矩阵(2d)
(defun q:matrix:scaleByPoint(p0 k / a b)
(setq a (car p0) b (cadr p0))
(list (list k 0 0 (- a (* k a)))
(list 0 k 0 (- b (* k b)))
(list 0 0 k 0)
(list 0 0 0 1))
)
;;;测试函数by qjchen
(defun c:test ( / endpt lineobj matrixrotate matrixscale mspace startpt) ; / lineObj startPt endPt matList transMat)
(vl-load-com)
(setq mSpace (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object))))
(setq startPt (getpoint "Pick the start point"))
(setq endPt (getpoint startPt "Pick the end point"))
(setq lineObj (vla-addline mSpace (vlax-3d-point startPt) (vlax-3d-point endPt)))
(setq matrixRotate (q:matrix:rotateByPoint startPt (* (/ 89. 180.0) pi ) ))
(vla-transformby lineObj (vlax-tmatrix matrixRotate))
(getstring "\n旋转后的直线...");Erase_BP
(setq matrixScale (q:matrix:scaleByPoint (vlax-get lineObj 'EndPoint) 3.5 ))
(vla-transformby lineObj (vlax-tmatrix matrixScale))
(princ "\n缩放后的直线....")
(princ)
)
还有第六题
;;;6.【曲线计算】10分
;;;已知共面且不相交的一直线和一圆弧，求两个对象之间的最小距离。
;;;测试函数by qjchen
;;;;by qjchen
;;;;分别计算弧和直线的2个端点对对方的最近点，然后计算，过圆心和圆心离直线最近点直线与圆交点的点和直线的最短距离，为所求
(defun c:test ( / alldistlist ang arccenterp arccenterp1 arcendp arcobj arcstartp lendp lobj lstartp mspace pub templine) ; / lineObj startPt endPt matList transMat)
(vl-load-com)
(setq mSpace (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))
LObj (vlax-ename->vla-object (car (entsel "请选择一段直线")))
LstartP (vlax-get LObj 'StartPoint) LendP (vlax-get LObj 'EndPoint) Ang (vlax-get LObj 'Angle)
arcObj (vlax-ename->vla-object (car (entsel "请选择一段圆弧")))
arcstartP (vlax-get arcObj 'StartPoint) arcEndP (vlax-get arcObj 'EndPoint) arcCenterP (vlax-get arcObj 'Center)
arcCenterP1 (vlax-curve-getClosestPointTo LObj arcCenterP nil)
tempLine (vla-addline mSpace (vlax-3d-point arcCenterP) (vlax-3d-point arcCenterP1) )
pub (vlax-invoke tempLine 'IntersectWith arcObj acExtendNone)
)
(vla-delete tempLine)
(setq allList (list (list LstartP (vlax-curve-getClosestPointTo arcObj LstartP nil) )
(list LendP (vlax-curve-getClosestPointTo arcObj LendP nil) )
(list arcstartP (vlax-curve-getClosestPointTo LObj arcstartP nil))
(list arcendP (vlax-curve-getClosestPointTo LObj arcendP nil))
))
(if pub (setq allList (cons (list pub (vlax-curve-getClosestPointTo LObj pub nil)) allList )))
(setq allList (vl-sort allList (function (lambda (e1 e2) (< (distance (car e1) (cadr e1))(distance (car e2) (cadr e2)) ) ))))
(vla-addline mSpace (vlax-3d-point (car (car allList))) (vlax-3d-point (cadr (car allList))))
(princ "\n最短距离是:") (princ (distance (car (car allList))(cadr (car allList))))
(princ)
)
(princ "\nby qjchen")
果断弃考 第三题是禁用递归法，还是只能用递归法 先发第三题的答案(defun ptsState (pt1 pt2)
(if (and pt1 pt2)
(if (> (distance pt1 pt2) 100)
(list pt1
;;计算中点
(mapcar '(lambda (x) (* x 0.5)) (mapcar '+ pt1 pt2))
pt2
)
(list pt1 pt2)
)
(list pt1 pt2)
)
)
(defun fixpts (lst)
(if (equal lst
(setq lst
(reverse (cdr (reverse (apply 'append
(mapcar
'(lambda (x) (cdr x))
(mapcar 'ptsState
(append '(nil) lst)
(append lst '(nil))
)
)
)
)
)
)
)
)
lst
(fixpts lst)
)
)