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

飞诗(fsxm) · 发表于 2011-12-30 16:34:48

打个酱油占个位,反正别人不知道,哈哈！

xshrimp · 发表于 2011-12-31 16:30:36

;1.【选择集处理】8分
; 已知一个选择集，要求从选择集中筛选出符合下列描述的对象：
; (1)圆环(由2个半圆组成的封闭多段线)、矩形(由多段线构成的封闭的直角平行四边形)；
; (2)忽略LWEIGHT命令概念的线宽，多段线线宽为0；
; (3)起点、终点重合即可被认为封闭。
(defun iscpl (ent / 42lst entlst entype obj ptlst pw x y)
(setq obj (gps->e2o ent) entlst (entget ent) entype (cdr(assoc 0 entlst)))
(if
(and
(= entype "LWPOLYLINE")
(VLAX-CURVE-ISCLOSED obj)
(not(vl-catch-all-error-p(setq pw(vl-catch-all-apply 'vla-get-ConstantWidth(list obj)))))
(zerop pw)
)
(progn
(setq 42lst (vl-remove-if-not '(lambda(x)(= 42(car x)))entlst))
(cond
((= 2 (length 42lst)) ;圆环
(not(apply 'or (mapcar '(lambda(y)(zerop(cdr y)))42lst)))
)
((or (= 4 (length 42lst)) (= 5 (length 42lst))) ;矩形
(setq ptlst (mapcar 'cdr (vl-remove-if-not '(lambda(x)(= 10(car x)))entlst)))
(and
(apply 'and (mapcar '(lambda(y)(zerop(cdr y)))42lst))
(=
(abs(- (angle(nth 1 ptlst)(nth 2 ptlst))(angle(nth 1 ptlst)(nth 0 ptlst))))
(abs(- (angle(nth 2 ptlst)(nth 3 ptlst))(angle(nth 2 ptlst)(nth 1 ptlst))))
(* 0.5 pi)
)
)
)
(T nil)
)
)
)
)
(defun test (ss / ent lst n)
(repeat (setq n (sslength ss))
(setq ent (ssname ss (setq n (1- n))))
(if (not(iscpl ent))(setq lst (cons ent lst)))
)
(foreach n lst(ssdel n ss))
(sssetfirst nil ss)
ss
)
;|
2.【几何运算】9分
已知一条端点为A和B的直线，将该直线以A端点为基点旋转89度，再以B端点为基点
缩放3.5倍，用几何方法求出直线的2个新端点。禁用polar、command、vl-cmdf函数
|;
(defun test(a b / ang len x+ y+)
(setq len(distance a b)ang(+(angle a b)(*(/ 89 180.0)pi)))
(setq x+(* len(cos ang))y+(* len (sin ang)))
(list
(mapcar '+ a(list x+ y+ 0))
(mapcar '- a(list(* 2 x+)(* 2 y+)0))
)
)
;3.【点集处理】15分
; 已知一个包含若干个三维点的表，若表中相邻两个点之间的距离大于100，则
; 在两点之间添加中点，直到表中相邻两个点之间距离小于或等于100。
; 限用递归法
(defun newptlst(lst / mid pt1 pt2)
(cond ((<(length lst)2)lst)
(T
(setq pt1 (car lst) pt2 (cadr lst))
(if (<= (distance pt1 pt2) 100)
(cons pt1 (newptlst (cdr lst)))
(progn
(setq mid(mapcar '(lambda(x y)(* 0.5(+ x y)))pt1 pt2))
(setq lst(append(list pt1 mid)(cdr lst)))
(newptlst lst)
)
)
)
)
)
;4.【图形对象操作】8分
;??已知一个云线(由REVCLOUD命令绘制的包含若干弧段的多段线)，用VLISP方法
;??将云线翻转(即把弧段的凸度方向调整为反方向)，禁用command、vl-cmdf函数
(defun RevCloud (ent / newlst)
(foreach n (entget ent)
(if (and(=(car n)42)(not(zerop(cdr n))))
(setq newlst (cons(cons 42(-(cdr n)))newlst))
(setq newlst (cons n newlst))
)
)
(entmod (reverse newlst))
)
;5.【非图形对象操作】20分
;? ?在禁用炸开命令的前提下，将将MLINE转换为LINE。
;;;多线样式
(defun Kdub:Mlinestyle-Get (Name / mlsty-DICT MLSty)
(if (setq mlsty-DICT (dictsearch (Namedobjdict) "ACAD_MLINESTYLE"))
(while
(and mlsty-DICT
(not (setq MLSty (if (and (assoc 3 mlsty-DICT) (= (strcase (cdr (assoc 3 mlsty-DICT))) (strcase Name)))
(list (strcase Name) (cdr (cadr (member (assoc 3 mlsty-DICT) mlsty-DICT))))
)
)
)
)
(setq mlsty-DICT (cdr (member (assoc 3 mlsty-DICT) mlsty-DICT)))
)
)
MLSty
)
;; Expects pts to be a list of 2D or 3D points
(defun makePline (spc pts)
(if (= (length (car pts)) 2) ; 2d point list
(setq pts (apply 'append pts))
(setq
pts (apply 'append (mapcar '(lambda (x) (list (car x) (cadr x))) pts))
)
)
(setq
pts (vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbdouble (cons 0 (1- (length pts))))
pts
)
)
)
(vla-addlightweightpolyline spc pts)
)
;;;基本完成了,没有考虑图层,线型.
(defun exmline (ent / dq entlst n obj plst spc)
(setq entlst (entget ent))
(foreach n entlst
(if (member (car n) '(10 11))
(setq plst (cons (cdr n) plst))
)
)
(setq dq (cdr(assoc 70 entlst)) bl (cdr(assoc 40 entlst)))
(setq obj (makePline (vla-get-modelspace(vla-get-ActiveDocument(vlax-get-acad-object))) plst))
(setq mstyle (Kdub:Mlinestyle-Get(vla-get-stylename (gps->e2o ent)) ))
(setq mstylelst (entget (cadr mstyle)))
(setq dis (apply '+ (mapcar '(lambda(x)(if(=(car x)49)(abs(cdr x))0))mstylelst)))
(cond
((= dq 0)
(vla-Offset obj (* -1 dis bl))
)
((= dq 1)
(vla-Offset obj (* 0.5 dis bl))
(vla-Offset obj (* -0.5 dis bl))
(vla-delete obj)
)
((= dq 2)
(vla-Offset obj (* dis bl))
)
)
(entdel ent)
(princ)
)
;6.【曲线计算】10分
; 已知共面且不相交的一直线和一圆弧，求两个对象之间的最小距离。
(vlax-curve-getClosestPointTo obj pt)
;有空再写吧.
;7.【非图形对象操作】10分
;分解图元所在编组(GROUP)，即清除编组定义。禁用command、vl-cmdf函数。
;炸开图中所有组
;同一个物体可能在几个不同的组
(defun explodeGroups(obj / e g lst vla-groups)
(setq vla-groups(vla-get-Groups(vla-get-activedocument(vlax-get-acad-object))))
(vlax-for g vla-groups
(vlax-for e g
(if (equal(vla-get-ObjectID e)(vla-get-ObjectID Obj))
(setq lst (cons g lst))
)
)
)
(foreach g lst
(princ (strcat "\n 对象所在 "(vla-get-Name g)" 组被分解!"))
(vla-delete g)
)
(vlax-release-object vla-groups)
(princ)
)
;8.【实用技巧】20分
; 找出指定fas程序文件中的所有命令(C:开头的函数)。
; 提示：fas可能已加载。测试文件见附件test.fas。
(defun c:Compare( / #newatoms #oldatoms file n ret str x)
(vl-load-com)
(defun atoms(str)
(vl-remove-if-not
(function(lambda(n)(wcmatch n str)))
(atoms-family 1)
)
)
(setq #oldatoms (mapcar '(lambda(x)(list x(eval(read x))))(atoms "C:*")))
(if (setq file (getfiled "选择加载文件" "" "fas;lsp;vlx" 2 ))
(progn
(load file "")
(setq #newatoms(mapcar '(lambda(x)(list x(eval(read x))))(atoms "C:*")))
(setq ret(vl-remove 'nil (mapcar '(lambda(x)(if(equal(assoc(car x)#oldatoms)x)nil (car x)))#newatoms)))
(princ ret)
)
)
(princ)
)

;1.【选择集处理】8分 
;  已知一个选择集，要求从选择集中筛选出符合下列描述的对象： 
;  (1)圆环(由2个半圆组成的封闭多段线)、矩形(由多段线构成的封闭的直角平行四边形)； 
;  (2)忽略LWEIGHT命令概念的线宽，多段线线宽为0； 
;  (3)起点、终点重合即可被认为封闭。 
(defun iscpl (ent / 42lst entlst entype obj ptlst pw x y) 
  (setq obj (gps->e2o ent) entlst (entget ent) entype (cdr(assoc 0 entlst))) 
  (if 
    (and 
      (= entype "LWPOLYLINE") 
      (VLAX-CURVE-ISCLOSED obj) 
      (not(vl-catch-all-error-p(setq pw(vl-catch-all-apply 'vla-get-ConstantWidth(list obj))))) 
      (zerop pw) 
    ) 
    (progn 
      (setq 42lst (vl-remove-if-not '(lambda(x)(= 42(car x)))entlst)) 
      (cond      
        ((= 2 (length 42lst)) ;圆环 
          (not(apply 'or (mapcar '(lambda(y)(zerop(cdr y)))42lst)))                
        ) 
        ((or (= 4 (length 42lst)) (= 5 (length 42lst))) ;矩形 
         (setq ptlst (mapcar 'cdr (vl-remove-if-not '(lambda(x)(= 10(car x)))entlst))) 
         (and 
           (apply 'and (mapcar '(lambda(y)(zerop(cdr y)))42lst)) 
           (= 
             (abs(- (angle(nth 1 ptlst)(nth 2 ptlst))(angle(nth 1 ptlst)(nth 0 ptlst)))) 
             (abs(- (angle(nth 2 ptlst)(nth 3 ptlst))(angle(nth 2 ptlst)(nth 1 ptlst)))) 
             (* 0.5 pi) 
           ) 
         ) 
        ) 
        (T nil) 
      ) 
    ) 
  ) 
) 
(defun test (ss / ent lst n) 
  (repeat (setq n (sslength ss)) 
   (setq ent (ssname ss (setq n (1- n)))) 
   (if (not(iscpl ent))(setq lst (cons ent lst))) 
  ) 
  (foreach n lst(ssdel n ss)) 
  (sssetfirst nil ss) 
  ss 
) 
;| 
2.【几何运算】9分 
  已知一条端点为A和B的直线，将该直线以A端点为基点旋转89度，再以B端点为基点 
  缩放3.5倍，用几何方法求出直线的2个新端点。禁用polar、command、vl-cmdf函数 
|; 
(defun test(a b / ang len x+ y+) 
  (setq len(distance a b)ang(+(angle a b)(*(/ 89 180.0)pi))) 
  (setq x+(* len(cos ang))y+(* len (sin ang))) 
  (list 
    (mapcar '+ a(list x+ y+ 0)) 
    (mapcar '- a(list(* 2 x+)(* 2 y+)0)) 
  ) 
) 
;3.【点集处理】15分 
;   已知一个包含若干个三维点的表，若表中相邻两个点之间的距离大于100，则 
;   在两点之间添加中点，直到表中相邻两个点之间距离小于或等于100。 
;   限用递归法 
(defun newptlst(lst / mid pt1 pt2) 
 (cond ((<(length lst)2)lst) 
       (T 
         (setq pt1 (car lst) pt2 (cadr lst)) 
         (if (<= (distance pt1 pt2) 100) 
            (cons pt1 (newptlst (cdr lst))) 
            (progn 
              (setq mid(mapcar '(lambda(x y)(* 0.5(+ x y)))pt1 pt2)) 
              (setq lst(append(list pt1 mid)(cdr lst))) 
              (newptlst lst) 
            )   
         )       
     ) 
 ) 
) 
;4.【图形对象操作】8分 
;??已知一个云线(由REVCLOUD命令绘制的包含若干弧段的多段线)，用VLISP方法 
;??将云线翻转(即把弧段的凸度方向调整为反方向)，禁用command、vl-cmdf函数 
(defun RevCloud (ent / newlst)          
    (foreach n (entget ent) 
       (if (and(=(car n)42)(not(zerop(cdr n)))) 
         (setq newlst (cons(cons 42(-(cdr n)))newlst)) 
         (setq newlst (cons n newlst)) 
       ) 
     ) 
   (entmod (reverse newlst))    
) 
 
;5.【非图形对象操作】20分 
;? ?在禁用炸开命令的前提下，将将MLINE转换为LINE。 
 
;;;多线样式 
(defun Kdub:Mlinestyle-Get (Name / mlsty-DICT MLSty) 
  (if (setq mlsty-DICT (dictsearch (Namedobjdict) "ACAD_MLINESTYLE")) 
    (while 
      (and mlsty-DICT 
        (not (setq MLSty (if (and (assoc 3 mlsty-DICT) (= (strcase (cdr (assoc 3 mlsty-DICT))) (strcase Name))) 
        (list (strcase Name) (cdr (cadr (member (assoc 3 mlsty-DICT) mlsty-DICT)))) 
        ) 
        ) 
        ) 
      ) 
      (setq mlsty-DICT (cdr (member (assoc 3 mlsty-DICT) mlsty-DICT))) 
    ) 
  ) 
  MLSty 
) 
;;  Expects pts to be a list of 2D or 3D points 
  (defun makePline (spc pts) 
    (if (= (length (car pts)) 2) ; 2d point list 
      (setq pts (apply 'append pts)) 
      (setq 
        pts (apply 'append (mapcar '(lambda (x) (list (car x) (cadr x))) pts)) 
      ) 
    ) 
    (setq 
      pts (vlax-make-variant 
            (vlax-safearray-fill 
              (vlax-make-safearray vlax-vbdouble (cons 0 (1- (length pts)))) 
              pts 
            ) 
          ) 
    ) 
    (vla-addlightweightpolyline spc pts) 
  ) 
;;;基本完成了,没有考虑图层,线型. 
(defun exmline (ent / dq entlst n obj plst spc) 
   (setq entlst (entget ent))   
   (foreach n entlst 
     (if (member (car n) '(10 11)) 
       (setq plst (cons (cdr n) plst)) 
     ) 
   )    
  (setq  dq (cdr(assoc 70 entlst)) bl (cdr(assoc 40 entlst)))    
  (setq  obj (makePline (vla-get-modelspace(vla-get-ActiveDocument(vlax-get-acad-object))) plst))    
  (setq mstyle (Kdub:Mlinestyle-Get(vla-get-stylename (gps->e2o ent)) ))   
  (setq mstylelst (entget (cadr mstyle)))    
  (setq dis (apply '+ (mapcar '(lambda(x)(if(=(car x)49)(abs(cdr x))0))mstylelst))) 
  (cond 
    ((= dq 0) 
      (vla-Offset obj (* -1 dis bl)) 
      ) 
    ((= dq 1)    
      (vla-Offset obj (* 0.5 dis bl)) 
      (vla-Offset obj (* -0.5 dis bl)) 
      (vla-delete obj) 
    ) 
    ((= dq 2) 
      (vla-Offset obj (* dis bl)) 
    ) 
  ) 
  (entdel ent) 
  (princ) 
) 
   
;6.【曲线计算】10分 
;   已知共面且不相交的一直线和一圆弧，求两个对象之间的最小距离。 
 
(vlax-curve-getClosestPointTo obj pt) 
;有空再写吧. 
 
 
;7.【非图形对象操作】10分 
;分解图元所在编组(GROUP)，即清除编组定义。禁用command、vl-cmdf函数。 
;炸开图中所有组   
;同一个物体可能在几个不同的组 
(defun explodeGroups(obj / e g lst vla-groups) 
  (setq vla-groups(vla-get-Groups(vla-get-activedocument(vlax-get-acad-object))))   
  (vlax-for g vla-groups 
    (vlax-for e g 
     (if (equal(vla-get-ObjectID e)(vla-get-ObjectID Obj)) 
      (setq lst (cons g lst)) 
     )    
    )   
   ) 
  (foreach g lst 
    (princ (strcat "\n 对象所在 "(vla-get-Name g)" 组被分解!")) 
    (vla-delete g) 
  )    
  (vlax-release-object vla-groups)   
  (princ) 
) 
    
;8.【实用技巧】20分 
;   找出指定fas程序文件中的所有命令(C:开头的函数)。 
;   提示：fas可能已加载。测试文件见附件test.fas。    
(defun c:Compare( / #newatoms #oldatoms file n ret str x) 
  (vl-load-com)      
  (defun atoms(str) 
    (vl-remove-if-not 
      (function(lambda(n)(wcmatch n str))) 
      (atoms-family 1) 
    ) 
  ) 
  (setq #oldatoms (mapcar '(lambda(x)(list x(eval(read x))))(atoms "C:*")))   
  (if (setq file (getfiled "选择加载文件" "" "fas;lsp;vlx" 2  )) 
    (progn 
      (load file "") 
      (setq #newatoms(mapcar '(lambda(x)(list x(eval(read x))))(atoms "C:*")))   
      (setq ret(vl-remove 'nil (mapcar '(lambda(x)(if(equal(assoc(car x)#oldatoms)x)nil (car x)))#newatoms)))    
      (princ ret) 
    ) 
  ) 
  (princ) 
)

狂刀lxx · 发表于 2012-1-1 00:57:40

怎么都占了沙发？

caoyin · 发表于 2012-1-1 05:01:08

本帖最后由 caoyin 于 2012-1-1 06:42 编辑

先做两题简单的
;;;第1题

(defun TEST-1 (SS / IsCircle IsRectang I EN OBJ LST CW)
;;判断对象是否构成是圆--凸度法
(defun IsCircle (PlObj / BLG LST)
(setq BLG -1)
(vl-catch-all-apply '(lambda ()
(while (setq LST (cons (vla-GetBulge PLOBJ (setq BLG (1+ BLG))) LST)))
))
(and (= (length LST) 2) (apply '= LST) (zerop (apply '- LST)))
)
;;判断对象是否是矩形--对角线法
(defun IsRectang (PLOBJ / N PP P LST)
(setq N (fix (vlax-curve-getEndParam PLOBJ)) PP N)
(while (and PP (setq P (vlax-curve-getPointAtParam PLOBJ PP)))
(if (or (= PP N) (zerop (vla-GetBulge PLOBJ PP)))
(setq LST (cons P LST) PP (1- PP))
(setq PP nil)
)
)
(and PP
(= (length LST) 5)
(equal (distance (car LST) (caddr LST))
(distance (cadr LST) (cadddr LST))
1E-6
)
)
)
(repeat (setq I (sslength SS))
(setq EN (ssname SS (setq I (1- I)))
OBJ (vlax-ename->vla-object EN)
)
(if (and (= (vla-get-objectname OBJ) "AcDbPolyline")
(not (vl-catch-all-error-p
(vl-catch-all-apply
'(lambda () (setq CW (vla-get-ConstantWidth OBJ)))
)))
(zerop CW)
(equal (vlax-curve-getstartPoint OBJ)
(vlax-curve-getendPoint OBJ)
1E-6
)
(or (IsCircle OBJ) (IsRectang OBJ))
)
(setq LST (cons EN LST))
)
)
LST
)

(defun TEST-1 (SS / IsCircle IsRectang I EN OBJ LST CW) 
  ;;判断对象是否构成是圆--凸度法 
  (defun IsCircle (PlObj / BLG LST) 
    (setq BLG -1) 
    (vl-catch-all-apply '(lambda () 
      (while (setq LST (cons (vla-GetBulge PLOBJ (setq BLG (1+ BLG))) LST))) 
    )) 
    (and (= (length LST) 2) (apply '= LST) (zerop (apply '- LST))) 
  ) 
  ;;判断对象是否是矩形--对角线法 
  (defun IsRectang (PLOBJ / N PP P LST) 
    (setq N (fix (vlax-curve-getEndParam PLOBJ)) PP N) 
    (while (and PP (setq P (vlax-curve-getPointAtParam PLOBJ PP))) 
      (if (or (= PP N) (zerop (vla-GetBulge PLOBJ PP))) 
        (setq LST (cons P LST) PP (1- PP)) 
        (setq PP nil) 
      ) 
    ) 
    (and PP 
         (= (length LST) 5) 
         (equal (distance (car LST) (caddr LST)) 
                (distance (cadr LST) (cadddr LST)) 
                1E-6 
         ) 
    ) 
  ) 
  (repeat (setq I (sslength SS)) 
    (setq EN  (ssname SS (setq I (1- I))) 
          OBJ (vlax-ename->vla-object EN) 
    ) 
    (if (and (= (vla-get-objectname OBJ) "AcDbPolyline") 
             (not (vl-catch-all-error-p 
             (vl-catch-all-apply 
               '(lambda () (setq CW (vla-get-ConstantWidth OBJ))) 
             ))) 
             (zerop CW) 
             (equal (vlax-curve-getstartPoint OBJ) 
                    (vlax-curve-getendPoint OBJ) 
                    1E-6 
             ) 
             (or (IsCircle OBJ) (IsRectang OBJ)) 
        ) 
      (setq LST (cons EN LST)) 
    ) 
  ) 
  LST 
)

;;;第4题
;;;(test4 (vlax-ename->vla-object (car(entsel))))

(defun TEST-4 (OBJ / N)
(repeat (setq N (fix (vlax-curve-getEndParam OBJ)))
(setq N (1- N))
(vla-setBulge OBJ N (- (vla-getBulge OBJ N)))
)
)

e2002 · 发表于 2012-1-5 12:38:34

建议文字表述算法,具体代码可以多种实现

nzl1116 · 发表于 2012-1-5 13:08:46

第8题可以讨论下，我的代码如下：

(defun getcommandname (file / acadapp documents
actdoc mnlfile tmpfile tmpf
value str1
)
(vl-load-com)
(setq acadapp (vlax-get-acad-object)
documents (vla-get-documents acadapp)
actdoc (vla-get-activedocument acadapp)
)
(setq mnlfile (findfile "acad.mnl")
tmpfile (strcat (vl-filename-directory mnlfile) "\\tmpfile.lsp")
tmpf (open tmpfile "w")
)
(princ (vl-prin1-to-string
'(defun
findfunc
(file / abcdoc lst1 lst2 lst3)
(vl-load-com)
(setq
abcdoc
(vla-get-activedocument (vlax-get-acad-object))
)
(mapcar
'(lambda (x)
(if (or (wcmatch x "C:*")
(wcmatch x "c:*")
)
(setq lst1 (cons x lst1))
)
)
(atoms-family 1)
)
(load file (princ))
(mapcar
'(lambda (x)
(if (or (wcmatch x "C:*")
(wcmatch x "c:*")
)
(setq lst2 (cons x lst2))
)
)
(atoms-family 1)
)
(mapcar
'(lambda (x)
(if (not (member x lst1))
(setq lst3 (cons x lst3))
)
)
lst2
)
(vl-bb-set 'a lst3)
(vla-close abcdoc)
)
)
tmpf
)
(princ (strcat "\n(findfunc " (vl-prin1-to-string file) " )")
tmpf
)
(close tmpf)
;;;从头到尾依次读取指定文件的每一行，
;;;如果文件存在指定的字符串，就返回这
;;;条字符串，并停止搜索，否则返回nil。
(defun readeveryline (fd string / str)
(if (setq str (read-line fd))
(if (/= string str)
(readeveryline fd string)
str
)
)
)
(setq tmpf (open mnlfile "r")
str1 (strcat "(load " (vl-prin1-to-string tmpfile) " (princ))")
)
(if (readeveryline tmpf str1)
(close tmpf)
(progn (close tmpf)
(setq tmpf (open mnlfile "a"))
(princ (strcat "\n" str1) tmpf)
(close tmpf)
)
)
(vla-add documents "")
(setq value (vl-bb-ref 'a))
(vl-bb-set 'a nil)
(vl-file-delete tmpfile)
value
)

(defun getcommandname (file         /           acadapp   documents 
                       actdoc         mnlfile   tmpfile   tmpf 
                       value     str1 
                      ) 
  (vl-load-com) 
  (setq        acadapp          (vlax-get-acad-object) 
        documents (vla-get-documents acadapp) 
        actdoc          (vla-get-activedocument acadapp) 
  ) 
  (setq        mnlfile        (findfile "acad.mnl") 
        tmpfile        (strcat (vl-filename-directory mnlfile) "\\tmpfile.lsp") 
        tmpf        (open tmpfile "w") 
  ) 
  (princ (vl-prin1-to-string 
           '(defun 
             findfunc 
             (file / abcdoc lst1 lst2 lst3) 
             (vl-load-com) 
             (setq 
              abcdoc 
              (vla-get-activedocument (vlax-get-acad-object)) 
             ) 
             (mapcar 
              '(lambda (x) 
                 (if (or (wcmatch x "C:*") 
                         (wcmatch x "c:*") 
                     ) 
                   (setq lst1 (cons x lst1)) 
                 ) 
               ) 
              (atoms-family 1) 
             ) 
             (load file (princ)) 
             (mapcar 
              '(lambda (x) 
                 (if (or (wcmatch x "C:*") 
                         (wcmatch x "c:*") 
                     ) 
                   (setq lst2 (cons x lst2)) 
                 ) 
               ) 
              (atoms-family 1) 
             ) 
             (mapcar 
              '(lambda (x) 
                 (if (not (member x lst1)) 
                   (setq lst3 (cons x lst3)) 
                 ) 
               ) 
              lst2 
             ) 
             (vl-bb-set 'a lst3) 
             (vla-close abcdoc) 
            ) 
         ) 
         tmpf 
  ) 
  (princ (strcat "\n(findfunc " (vl-prin1-to-string file) " )") 
         tmpf 
  ) 
  (close tmpf) 
  ;;;从头到尾依次读取指定文件的每一行， 
  ;;;如果文件存在指定的字符串，就返回这 
  ;;;条字符串，并停止搜索，否则返回nil。 
  (defun readeveryline (fd string / str) 
    (if        (setq str (read-line fd)) 
      (if (/= string str) 
        (readeveryline fd string) 
        str 
      ) 
    ) 
  ) 
  (setq tmpf (open mnlfile "r") 
        str1 (strcat "(load " (vl-prin1-to-string tmpfile) " (princ))") 
        ) 
  (if (readeveryline tmpf str1) 
    (close tmpf) 
    (progn (close tmpf) 
           (setq tmpf (open mnlfile "a")) 
           (princ (strcat "\n" str1) tmpf) 
           (close tmpf) 
    ) 
  ) 
  (vla-add documents "") 
  (setq value (vl-bb-ref 'a)) 
  (vl-bb-set 'a nil) 
  (vl-file-delete tmpfile) 
  value 
)

只不过有点问题，以前就没发上来
问题是没把新建的文档给关闭

nzl1116 · 发表于 2012-1-5 13:56:41

本帖最后由 nzl1116 于 2012-1-6 09:39 编辑

自己能解决了，在第二文档里激活第一个文档，在第一个文档里再关闭第二个文档
思路：考虑到当前文档有可能已经加载test.fas，于是就新建一个文档，在新建的文档里获取test.fas文件的C:*命令名，然后通过黑板变量来传递返回值。

;;;8.【实用技巧】20分
;;; 找出指定fas程序文件中的所有命令(C:开头的函数)。
;;; 提示：fas可能已加载。测试文件见附件test.fas
;;;-----------------------------------------------------;;;
;;;---------------- getcommandname file ----------------;;;
;;; (getcommandname file) ;;;
;;; 获取指定文件中定义的C:*命令名 ;;;
;;;-----------------------------------------------------;;;
(defun getcommandname (file / acadapp documents
actdoc mnlfile tmpfile tmpf
value str1 abcDoc
)
(vl-load-com)
(setq acadapp (vlax-get-acad-object)
documents (vla-get-documents acadapp)
actdoc (vla-get-activedocument acadapp)
)
;;寻找自动加载的"acad.mnl"文件，并在同目录下创建"tmpfile.lsp"文件
(setq mnlfile (findfile "acad.mnl")
tmpfile (strcat (vl-filename-directory mnlfile) "\\tmpfile.lsp")
tmpf (open tmpfile "w")
)
;;在tmpfile.lsp"文件里写入 findfunc 函数定义
(princ (vl-prin1-to-string
'(defun findfunc (file / lst1 lst2 lst3)
(mapcar
'(lambda (x)
(if (or (wcmatch x "C:*")
(wcmatch x "c:*")
)
(setq lst1 (cons x lst1))
)
)
(atoms-family 1)
)
(load file (princ))
(mapcar
'(lambda (x)
(if (or (wcmatch x "C:*")
(wcmatch x "c:*")
)
(setq lst2 (cons x lst2))
)
)
(atoms-family 1)
)
(mapcar
'(lambda (x)
(if (not (member x lst1))
(setq lst3 (cons x lst3))
)
)
lst2
)
(vl-bb-set 'a lst3)
) ;_ 结束defun
) ;_ 结束 vl-princ1-to-string
tmpf
) ;_ 结束 princ
;;在文件的后面添加两行代码
;;(findfunc file) ;_ 执行自定义函数
;;(vl-load-com) ;_ 在第二个文档的名称空间里加载ActiveX支持[?这一步不知道是否需要]
;;(vla-Activate actDoc) ;_ 激活前一个文档，把控制权交还给它
(princ (strcat "\n(findfunc " (vl-prin1-to-string file) " )")
tmpf
)
(princ "\n(vl-load-com)" tmpf)
(princ "\n(vla-Activate actdoc)" tmpf)
;;关闭"tmpfile.lsp"文件
(close tmpf)
;;从头到尾依次读取指定文件的每一行，
;;如果文件存在指定的字符串，就返回这
;;条字符串，并停止搜索，否则返回nil。
(defun readeveryline (fd string / str)
(if (setq str (read-line fd))
(if (/= string str)
(readeveryline fd string)
str
)
)
)
;;打开"acad.mnl"文件，依次读取每一行
;;寻找是不是存在(load tmpfile (princ))这一行代码
;;若不存在，就在文件里添加
(setq tmpf (open mnlfile "r")
str1 (strcat "(load " (vl-prin1-to-string tmpfile) " (princ))")
)
(if (readeveryline tmpf str1)
(close tmpf)
(progn (close tmpf)
(setq tmpf (open mnlfile "a"))
(princ (strcat "\n" str1) tmpf)
(close tmpf)
)
)
;;新建一个文档，同时，把控制权交给它
(setq abcDoc (vla-add documents ""))
;;第二个文档执行完所有的代码后，自动把控制权交还给第一个文档
;;第一个文档得到控制权后，就关闭第二个文档
(vla-close abcDoc)
;;从黑板读取变量值
(setq value (vl-bb-ref 'a))
;;删除黑板的变量
(vl-bb-set 'a nil)
;;删除文件
(vl-file-delete tmpfile)
value
)

;;;8.【实用技巧】20分                                       
;;;   找出指定fas程序文件中的所有命令(C:开头的函数)。       
;;;   提示：fas可能已加载。测试文件见附件test.fas          
;;;-----------------------------------------------------;;; 
;;;---------------- getcommandname file ----------------;;; 
;;; (getcommandname file)                               ;;; 
;;; 获取指定文件中定义的C:*命令名                       ;;; 
;;;-----------------------------------------------------;;; 
(defun getcommandname (file   /     acadapp   documents 
                                         actdoc   mnlfile   tmpfile   tmpf 
                                        value     str1      abcDoc 
                                         ) 
  (vl-load-com) 
  (setq  acadapp    (vlax-get-acad-object) 
           documents (vla-get-documents acadapp) 
              actdoc    (vla-get-activedocument acadapp) 
  ) 
  ;;寻找自动加载的"acad.mnl"文件，并在同目录下创建"tmpfile.lsp"文件 
  (setq  mnlfile  (findfile "acad.mnl") 
           tmpfile  (strcat (vl-filename-directory mnlfile) "\\tmpfile.lsp") 
           tmpf  (open tmpfile "w") 
  ) 
  ;;在tmpfile.lsp"文件里写入 findfunc 函数定义 
  (princ (vl-prin1-to-string 
              '(defun findfunc (file / lst1 lst2 lst3) 
              (mapcar 
                '(lambda (x) 
                   (if (or (wcmatch x "C:*") 
                           (wcmatch x "c:*") 
                      ) 
                   (setq lst1 (cons x lst1)) 
                 ) 
               ) 
        (atoms-family 1) 
       ) 
       (load file (princ)) 
       (mapcar 
        '(lambda (x) 
     (if (or (wcmatch x "C:*") 
       (wcmatch x "c:*") 
         ) 
       (setq lst2 (cons x lst2)) 
     ) 
         ) 
        (atoms-family 1) 
       ) 
       (mapcar 
        '(lambda (x) 
     (if (not (member x lst1)) 
       (setq lst3 (cons x lst3)) 
     ) 
         ) 
        lst2 
       ) 
       (vl-bb-set 'a lst3) 
      ) ;_ 结束defun 
   ) ;_ 结束 vl-princ1-to-string 
   tmpf 
  ) ;_ 结束 princ 
  ;;在文件的后面添加两行代码 
  ;;(findfunc file) ;_ 执行自定义函数 
  ;;(vl-load-com) ;_ 在第二个文档的名称空间里加载ActiveX支持[?这一步不知道是否需要] 
  ;;(vla-Activate actDoc) ;_ 激活前一个文档，把控制权交还给它 
  (princ (strcat "\n(findfunc " (vl-prin1-to-string file) " )") 
   tmpf 
  ) 
  (princ "\n(vl-load-com)" tmpf) 
  (princ "\n(vla-Activate actdoc)" tmpf) 
  ;;关闭"tmpfile.lsp"文件 
  (close tmpf) 
  ;;从头到尾依次读取指定文件的每一行， 
  ;;如果文件存在指定的字符串，就返回这 
  ;;条字符串，并停止搜索，否则返回nil。 
  (defun readeveryline (fd string / str) 
    (if  (setq str (read-line fd)) 
      (if (/= string str) 
  (readeveryline fd string) 
  str 
      ) 
    ) 
  ) 
  ;;打开"acad.mnl"文件，依次读取每一行 
  ;;寻找是不是存在(load tmpfile (princ))这一行代码 
  ;;若不存在，就在文件里添加 
  (setq  tmpf (open mnlfile "r") 
  str1 (strcat "(load " (vl-prin1-to-string tmpfile) " (princ))") 
  ) 
  (if (readeveryline tmpf str1) 
    (close tmpf) 
    (progn (close tmpf) 
     (setq tmpf (open mnlfile "a")) 
     (princ (strcat "\n" str1) tmpf) 
     (close tmpf) 
    ) 
  ) 
  ;;新建一个文档，同时，把控制权交给它 
  (setq abcDoc (vla-add documents "")) 
  ;;第二个文档执行完所有的代码后，自动把控制权交还给第一个文档 
  ;;第一个文档得到控制权后，就关闭第二个文档 
  (vla-close abcDoc) 
  ;;从黑板读取变量值 
  (setq value (vl-bb-ref 'a)) 
  ;;删除黑板的变量 
  (vl-bb-set 'a nil) 
  ;;删除文件 
  (vl-file-delete tmpfile) 
  value 
)

yjr111 · 发表于 2012-1-5 22:52:25

还是G版强悍啊，这么多源码，研究透了可不得了

highflybir · 发表于 2012-1-6 01:50:34

本帖最后由 highflybir 于 2012-1-6 02:23 编辑

只解答最后一道题目：

(defun c:test(/ FunLst name)
  (setq FunLst nil)
  (foreach name (ATOMS-FAMILY 1)
(if (= "C:" (substr name 1 2))
   (setq funlst (cons (eval (read name)) funlst))
)
  )
  ;;这时候再重新装载程序
  (load "d:\\tddownload\\test.fas") ;目录依据情况而定
  (princ "\ntest.fas含有C:开头函数是:")
  (foreach name (atoms-family 1)
(if (= "C:" (substr name 1 2))
   (if (not (member (eval (read name)) funLst))
      (princ (strcat "\n函数名:" name))
   )
)
  )

  (princ)
)

狂刀lxx · 发表于 2012-1-6 02:24:43

本帖最后由狂刀lxx 于 2012-1-6 11:54 编辑

看了gu_xl的第一题答案，觉得程序写的很长。提出另外一种思路，抛砖引玉。思路是用vlax-curve-getendparam 判断段数，用面积公式判断是否是圆或矩形。

;| by dreamskylxx-2012.1.6适用lwpolyline，polyline
适用外观闭合（不论最后一段是否是通过CL参数来进行闭合）
圆环适用于两端圆环不一定是半圆
排除多段线重合情况（如看似一个完整圆环，但是实际上有≥3段圆弧段组成）
|;
(defun tt1 (ss / AA C D1 D2 E I L1 L2 O PA SS1 SS2)
(setq i -1)
(while (setq e (ssname ss (setq i(1+ i))))
(setq o (vlax-ename->vla-object e))
(if(wcmatch (vla-get-objectname o) "*Polyline")
(setq pa(vlax-curve-getendparam o)))
(cond
((= 2.0 pa)
(setq c(vla-get-length o)
aa(vlax-curve-getarea o))
(if (equal aa (/ (* c c)(* 4. PI)) 1e-6)
;;(and (equal aa (/ (* c c)(* 4. PI)) 1e-6) ;;如果一定要判断是完整的半圆组成
;; (equal c (* 2. (vlax-curve-getdistatparam O 1.)) 1e-6))
(setq ss1 (cons e ss1)))
)
((= 4.0 pa)
(setq d1(vlax-curve-getdistatparam O 1.)
d2(vlax-curve-getdistatparam O 2.)
l1 d1
l2 (- d2 d1)
aa(vlax-curve-getarea o))
(if (equal aa (* l1 l2) 1e-6)
(setq ss2 (cons e ss2)))
)
(T nil)
)
)
(list ss1 ss2)
)
;;;; 以下是测试程序.
(defun c:ttt();;测试矩形多义线
(setq ss(ssget)
fss (tt1 ss))
(SETQ SSS(SSADD))
(MAPCAR '(LAMBDA(X)(SSADD X SSS))(caDr fss))
(sssetfirst NIL SSS)
)
(defun c:ttt2();;测试圆环多义线
(setq ss(ssget)
fss (tt1 ss))
(SETQ SSS(SSADD))
(MAPCAR '(LAMBDA(X)(SSADD X SSS))(car fss))
(sssetfirst NIL SSS)
)

;| by dreamskylxx-2012.1.6适用lwpolyline，polyline 
适用外观闭合（不论最后一段是否是通过CL参数来进行闭合） 
圆环适用于两端圆环不一定是半圆 
排除多段线重合情况（如看似一个完整圆环，但是实际上有≥3段圆弧段组成） 
|; 
(defun tt1 (ss / AA C D1 D2 E I L1 L2 O PA SS1 SS2) 
  (setq i -1) 
  (while (setq e (ssname ss (setq i(1+ i)))) 
    (setq o (vlax-ename->vla-object e)) 
    (if(wcmatch (vla-get-objectname o) "*Polyline") 
      (setq pa(vlax-curve-getendparam o))) 
    (cond 
      ((= 2.0 pa) 
       (setq c(vla-get-length o) 
             aa(vlax-curve-getarea o)) 
       (if (equal aa (/ (* c c)(* 4. PI)) 1e-6) 
         ;;(and (equal aa (/ (* c c)(* 4. PI)) 1e-6)  ;;如果一定要判断是完整的半圆组成 
         ;;     (equal c (* 2. (vlax-curve-getdistatparam O 1.)) 1e-6)) 
         (setq ss1 (cons e ss1))) 
       ) 
      ((= 4.0 pa) 
       (setq d1(vlax-curve-getdistatparam O 1.) 
             d2(vlax-curve-getdistatparam O 2.) 
             l1 d1 
             l2 (- d2 d1) 
             aa(vlax-curve-getarea o)) 
       (if (equal aa (* l1 l2) 1e-6) 
         (setq ss2 (cons e ss2))) 
       ) 
      (T nil) 
    ) 
  ) 
  (list ss1 ss2) 
) 
;;;; 以下是测试程序. 
(defun c:ttt();;测试矩形多义线 
  (setq ss(ssget) 
        fss (tt1 ss)) 
  (SETQ SSS(SSADD)) 
  (MAPCAR '(LAMBDA(X)(SSADD X SSS))(caDr fss)) 
  (sssetfirst NIL SSS) 
  ) 
(defun c:ttt2();;测试圆环多义线 
  (setq ss(ssget) 
        fss (tt1 ss)) 
  (SETQ SSS(SSADD)) 
  (MAPCAR '(LAMBDA(X)(SSADD X SSS))(car fss)) 
  (sssetfirst NIL SSS) 
  )

第2题，其实polar是很好用的，不能用这个函数，难道不能写一个替代函数么？呵呵
思路是不违反题目要求前提下，写一个替代polar功能的函数，从而使程序代码和结构简洁明了。
测试代码同 gu_lx中的c:tt2(gu_lx的我测试了一下，是不是忘了缩放比例了？)

;|2.【几何运算】9分已知一条端点为A和B的直线，将该直线以A端点为基点旋转89度，再以B端点为基点
缩放3.5倍，用几何方法求出直线的2个新端点。禁用polar、command、vl-cmdf函数|;
(defun tt2 (LINE ANG SCALE FLAG / ent pt1 pt2 len an pt2x pt1x) ;;by dreamskylxx-2012.1.6
(setq ent (entget LINE)
pt1 (cdr(assoc 10 ent))
pt2 (cdr(assoc 11 ent))
len (distance pt1 pt2))
(if (not flag)(setq pt pt1 pt1 pt2 pt2 pt));;对调
(setq an (angle pt1 pt2) pt2x(polarx pt1 (+ ang an) len)
pt1x(polarx pt2x (angle pt2x pt1 ) (* len scale))
ent (SUBST (cons 10 pt1x)(assoc 10 ent)ent)
ent (SUBST (cons 11 pt2x)(assoc 11 ent)ent))
(entmod ent)
)
;; 替代polar函数.
(defun polarx (pt an di)
(setq x (* di (cos an))
y (* di (sin an)))
(mapcar '+ (list x y (nth 2 pt)) pt)
)

第3题, 参照gu_xl的思路，用更紧凑和通俗的格式重写一次，比较纯粹。今晚太晚了，明天有空再玩玩

;;///////////第3题//////////////////////////////////////////;;
;|3.【点集处理】15分
已知一个包含若干个三维点的表，若表中相邻两个点之间的距离大于100，则
在两点之间添加中点，直到表中相邻两个点之间距离小于或等于100。
限用递归法。
|;
;(TT3x (list '(0 0 0) '(200 0 0) '(250 0 0) '(450 0 0) '(600 0 0)))
;->((0 0 0) (100.0 0.0 0.0) (200 0 0) (250 0 0) (350.0 0.0 0.0) (450 0 0) (525.0 0.0 0.0) (600 0 0))
(defun tt3x (pts / p1 p2)
(if (cdr pts)
(progn
(setq p1 (car pts)
p2 (cadr pts)
)
(if (<= (distance p1 p2) 100)
(cons p1 (tt3x (cdr pts)))
(tt3x (cons p1 (cons (mapcar '(lambda (a b) (* 0.5 (+ a b))) p1 p2) (cdr pts))))
)
)
(car pts)
)
)

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

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

评分

评分

评分

本帖子中包含更多资源

评分

点评

评分

浏览过的版块