vl-remove-if的用法？做了个简单是自动标注
本帖最后由 taocitc 于 2012-4-13 13:52 编辑(setq klist '(20 20 50 20 30 50 10 20 20 10))
怎么用vl-remove-if或是vl-remove-if-not删掉所有的相同元素？
多谢3楼，我做了个这个，呵呵，方便。
12楼，给你源码呵呵
(print)
(prompt "自动标注V2012.4.8已加载")
(defun c:CC (/)
(vl-load-com)
(setvar "osmode" 0)
(setvar "cmdecho" 0)
;;;坐标计算
(defun zbjs (klist1 jd pt)
(setq n0
nn (- (length klist1) 1)
pt (polar pt jd (nth 0 klist1))
)
(repeat nn
(setq pt1 (polar pt jd (nth (setq n (1+ n)) klist1))
pt pt1
)
(command pt1)
)
)
;;;删除相同元素
(defun erase-equal-lst (lst)
(setq lst-new '())
(while (setq e1 (car lst))
(setq lst-new (cons e1 lst-new)
n (str-len lst e1)
)
(repeat n
(setq lst (vl-remove e1 lst)
)
)
(princ)
)
(setq lst-new (reverse lst-new))
lst-new
)
;;求表中某个元素的个数
(defun str-len (lst item)
(- (length lst) (length (vl-remove item lst)))
)
;;;获取所有顶点
(defun ayGetLWPolyLineVTX (EntName1 / Obj1 vtx vtxlst PtsList i)
(setq Obj1 (vlax-ename->vla-object EntName1))
(setq vtx (vla-get-Coordinates Obj1))
(setq vtxLst (vlax-safearray->list (vlax-variant-value vtx)))
(setq i 0)
(setq PtsList nil)
(repeat (/ (length vtxLst) 2)
(setq
PtsList
(append PtsList
(list (list (nth i vtxLst) (nth (1+ i) vtxLst)))
)
)
(setq i (+ i 2))
) ;end_repeat
(setq PtsList PtsList)
) ;end_defun
;;;---------------------------------------------------------
(setq ss (ssget))
(if (= ss nil)
(prompt "没有选择(⊙０⊙)")
(progn
(setq sslen (sslength ss))
(setq i 0)
(setq a 0) ;设置LWPOLYLINE的位置
(setq xian 0) ;判断有没有LWPOLYLINE
(setq tj 0)
(setq cirtj 0)
(setq cirtj1 0) ;判断是否输出孔距
(while (< i sslen)
(setq sn (ssname ss i))
(setq el (entget sn))
(setq lx (cdr (assoc 0 el))) ;类型
(if (= lx "LWPOLYLINE")
(progn
(setq xian 1)
(setq a i)
)
)
(if (= lx "CIRCLE")
(progn
(setq tp10 (cdr (assoc 10 el)))
(setq tp11 (cdr (assoc 40 el)))
(setq cirtpx '())
(setq cirtpy '())
(setq cirtpx (list (car tp10)))
(setq cirtpy (list (cadr tp10)))
(if (< tp11 22)
(progn
(if (= cirtj 0)
(progn
(setq cirlistx cirtpx)
(setq cirlisty cirtpy)
(setq cirtj 1)
(setq cirtj1 1)
)
)
(if (= cirtj 1)
(progn
(setq cirlistx (append cirtpx cirlistx))
(setq cirlisty (append cirtpy cirlisty))
)
)
)
)
)
(princ)
)
(if (and (= lx "LINE") (= xian 0))
(progn
(setq tp10 (cdr (assoc 10 el)))
(setq tp11 (cdr (assoc 11 el)))
(setq tplistx (list (car tp10) (car tp11)))
(setq tplisty (list (cadr tp10) (cadr tp11)))
(if (= tj 0)
(progn
(setq listx tplistx)
(setq listy tplisty)
(setq tj 1)
)
(progn
(setq listx (append tplistx listx))
(setq listy (append tplisty listy))
)
)
)
)
(setq i (+ 1 i))
(princ)
)
(setq cirlistx (vl-sort cirlistx '<))
(setq cirlisty (vl-sort cirlisty '<))
(setq cirlistx (erase-equal-lst cirlistx))
(setq cirlisty (erase-equal-lst cirlisty))
;;;(print cirlistx)
;;;(print cirlisty)
;;;(print clxlen)
(if (= xian 1)
(progn
(setq dlist (ayGetLWPolyLineVTX (ssname ss a)))
;;; (print dlist)
;;; (print (length dlist))
;;; (setq td1 (nth 0 dlist))
;;; (setq td2 (nth 1 dlist))
;;; (setq td3 (nth 2 dlist))
;;; (setq td4 (nth 3 dlist))
;;; (setq tmpx (list (car td1) (car td2) (car td3) (car td4)))
;;; (setq tmpy (list (cadr td1) (cadr td2) (cadr td3) (cadr td4)))
(setq dlistlen (length dlist))
;;; (print (length dlist))
(setq tmpx '())
(setq tmpy '())
(while (> dlistlen 0)
(setq dlistlen (- dlistlen 1))
(setq tmpx (append (list (car (nth dlistlen dlist))) tmpx))
(setq tmpy (append (list (cadr (nth dlistlen dlist))) tmpy))
(princ)
)
;;; (print tmpx)
;;; (print tmpy)
(setq xmin (car (vl-sort tmpx '<)))
(setq xmax (car (vl-sort tmpx '>)))
(setq ymin (car (vl-sort tmpy '<)))
(setq ymax (car (vl-sort tmpy '>)))
;;; (print xmin)
;;; (print xmax)
;;; (print ymin)
;;; (print ymax)
)
(progn
(setq xmin (car (vl-sort listx '<)))
(setq xmax (car (vl-sort listx '>)))
(setq ymin (car (vl-sort listy '<)))
(setq ymax (car (vl-sort listy '>)))
;;; (print xmin)
;;; (print xmax)
;;; (print ymin)
;;; (print ymax)
)
)
(setq d1 (list xmin ymax))
(setq d2 (list xmin ymin))
(setq d3 (list xmax ymin))
(setq d4 (list xmax ymax))
(setq ccd1 (list (- xmin 35) (- ymax 5)))
(setq ccd2 (list (+ xmin 5) (- ymin 50)))
(setq ccd3 (list (+ xmax 50) (- ymax 5)))
(setq ccd4 (list (- xmax 5) (+ ymax 35)))
(setq cirlistx (append (append (list xmin) cirlistx) (list xmax)))
(setq cirlisty (append (append (list ymin) cirlisty) (list ymax)))
(setq clxlen (length cirlistx))
(setq clylen (length cirlisty))
;;;(print cirlistx)
;;;(print cirlisty)
(setq xcirlist '())
(setq ycirlist '())
(setq tmp 0)
(while (< tmp (- clxlen 1))
(setq xcirlist (append (list (- (nth (+ tmp 1) cirlistx)
(nth tmp cirlistx)
)
)
xcirlist
)
)
(setq tmp (+ tmp 1))
(princ)
)
(setq xcirlist (reverse xcirlist))
;;; (print xcirlist)
(setq tmp 0)
(while (< tmp (- clylen 1))
(setq ycirlist (append (list (- (nth (+ tmp 1) cirlisty)
(nth tmp cirlisty)
)
)
ycirlist
)
)
(setq tmp (+ tmp 1))
(princ)
)
;;;(setq ycirlist (reverse ycirlist))
;;;(print ycirlist)
(if (= cirtj1 1)
(progn
(command "_dimlinear"
d1
(list (+ (nth 0 xcirlist) xmin) ymax)
ccd4
)
(command "_dimcontinue")
(zbjs xcirlist 0 d1)
(command "" "")
(command "_dimlinear"
d4
(list xmax (- ymax (nth 0 ycirlist)))
ccd3
)
(command "_dimcontinue")
(zbjs ycirlist (* pi 1.5) d4)
(command "" "")
)
)
(setq leftbz (entmakex (list '(0 . "DIMENSION")
'(100 . "AcDbEntity")
'(100 . "AcDbDimension")
(cons 10 ccd1)
'(70 . 32)
'(1 . "")
'(3 . "正常标注")
(cons 51 -1.5708)
'(100 . "AcDbAlignedDimension")
(cons 13 d2)
(cons 14 d1)
'(50 . 1.5708)
'(100 . "AcDbRotatedDimension")
)
)
)
;;;(vla-put-VerticalTextPosition
;;; (vlax-ename->vla-object leftbz)
;;; acOutside
;;;)
(entmake (list '(0 . "DIMENSION")
'(100 . "AcDbEntity")
'(100 . "AcDbDimension")
(cons 10 ccd2)
'(70 . 32)
'(1 . "")
'(3 . "正常标注")
'(100 . "AcDbAlignedDimension")
(cons 13 d3)
(cons 14 d2)
'(100 . "AcDbRotatedDimension")
)
)
)
)
(setvar "osmode" 15359)
(setvar "cmdecho" 1)
)
有问题自己改吧。
删除相同元素有更好的方法，论坛里就有，递归法 论坛貌似很多！xyp1964
(defun erase-equal-lst (lst)
(setq lst-new '())
(while (setq e1 (car lst))
(setq lst-new (cons e1 lst-new)
n (str-len lst e1)
)
(repeat n
(setq lst (vl-remove e1 lst)
)
)
)
(setq lst-new (reverse lst-new))
lst-new
)
;;求表中某个元素的个数
(defun str-len (lst item)
(- (length lst) (length (vl-remove item lst)))
) wowan1314 发表于 2012-4-7 11:34 static/image/common/back.gif
论坛貌似很多！xyp1964
(defun erase-equal-lst (lst)
(setq lst-new '())
谢谢，我试试 (defun delsame (lst) (if lst (cons (car lst) (delsame (vl-remove (car lst) lst)))))
不用vl-remove-if就可以简单的实现 命令: (setq klist '(20 20 50 20 30 50 10 20 20 10)) (20 20 50 20 30 50 10 20 20
10)
命令: (vl-remove-if '(lambda(x)(= x 20)) klist)(50 30 50 10 10)
命令: (vl-remove-if-not '(lambda(x)(/= x 20)) klist)(50 30 50 10 10)
本帖最后由 taocitc 于 2012-4-8 10:46 编辑
yshf 发表于 2012-4-7 21:12 static/image/common/back.gif
命令: (setq klist '(20 20 50 20 30 50 10 20 20 10)) (20 20 50 20 30 50 10 20 20
10)
差不多就是这个意思，不过我要的结果是只留一个结果，去掉多余的重复的，谢谢啦。我用了3楼的方法很好用。 (defun del_sys(X / fhz)
(while X
(if (not (member (car x) fhz))
(setq fhz (cons (car x) fhz))
)
(setq X (cdr X))
)
(setq fhz (reverse fhz))
)
(defun c:test()
(setq klist '(20 20 50 20 30 50 10 20 20 10))
(setq jg (del_sys klist))
)
命令: test (20 50 30 10) 楼主能否公布演示程序？ 对这个命令不熟悉
页:
[1]
2