vl-remove-if的用法？做了个简单是自动标注

taocitc

(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 n  0
   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)
)

有问题自己改吧。

nzl1116

删除相同元素有更好的方法，论坛里就有，递归法

wowan1314

论坛貌似很多！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)))
)

taocitc

wowan1314 发表于 2012-4-7 11:34
论坛貌似很多！xyp1964
(defun erase-equal-lst (lst)
  (setq lst-new '())

谢谢，我试试

cabinsummer

(defun delsame (lst) (if lst (cons (car lst) (delsame (vl-remove (car lst) lst)))))
不用vl-remove-if就可以简单的实现

yshf

命令: (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

yshf 发表于 2012-4-7 21:12
命令: (setq klist '(20 20 50 20 30 50 10 20 20 10)) (20 20 50 20 30 50 10 20 20
10)

差不多就是这个意思，不过我要的结果是只留一个结果，去掉多余的重复的，谢谢啦。我用了3楼的方法很好用。

yshf

(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)

pxt2001

楼主能否公布演示程序？

露草

对这个命令不熟悉