[编程交流] 更改重复点的层

(defun c:movdup (/ a b dl en enl i pl ss)
  (setq pl nil  dl nil)
  (princ "\nSelect Points: ")
  (if (setq ss (ssget '((0 . "POINT"))))
     (progn
         (repeat (setq i (sslength ss))
      (setq en (ssname ss (setq i (1- i)))
                   pl (cons (cons (cdr (assoc 10 (entget en))) en) pl))              
         )     
         (setq pl (vl-sort pl (function (lambda (a b) (< (caddar a) (caddar b))))) ;; Sort on Z Coordinate     
               pl (vl-sort pl (function (lambda (a b) (< (cadar a) (cadar b)))))   ;; Sort on Y Coordinate     
               pl (vl-sort pl (function (lambda (a b) (< (caar a) (caar b)))))     ;; Sort on X Coordinate     
               dl (vl-remove nil
                     (mapcar '(lambda (a b) (if (equal (cdr (reverse (car a))) (cdr (reverse (car b)))) (cdr a)))
                                pl (append (cdr pl) (list (car pl)))
                     )
                  ) 
         )
       
         ;; dl should now be a list of ename of duplicate points.                ;
          
         (foreach en dl
            (setq enl (entget en))
            (entmod (subst (cons 8 "Lower Duplicate Points") (assoc 8 enl) enl ))
         )
     )
  )
)  

([color=BLUE]defun[/color] c:fixpoints ( [color=BLUE]/[/color] e i l s )
   ([color=BLUE]if[/color] ([color=BLUE]setq[/color] s ([color=BLUE]ssget[/color] [color=MAROON]"_:L"[/color] '((0 . [color=MAROON]"POINT"[/color]))))
       ([color=BLUE]progn[/color]
           ([color=BLUE]repeat[/color] ([color=BLUE]setq[/color] i ([color=BLUE]sslength[/color] s))
               ([color=BLUE]setq[/color] e ([color=BLUE]ssname[/color] s ([color=BLUE]setq[/color] i ([color=BLUE]1-[/color] i)))
                     l ([color=BLUE]cons[/color] ([color=BLUE]cons[/color] ([color=BLUE]assoc[/color] 10 ([color=BLUE]entget[/color] e)) e) l)
               )
           )
           ([color=BLUE]foreach[/color] x
               (LM:groupbyfunction l
                   ([color=BLUE]lambda[/color] ( a b )
                       ([color=BLUE]equal[/color]
                           ([color=BLUE]list[/color] ([color=BLUE]cadar[/color] a) ([color=BLUE]caddar[/color] a))
                           ([color=BLUE]list[/color] ([color=BLUE]cadar[/color] b) ([color=BLUE]caddar[/color] b))
                           1e-8
                       )
                   )
               )
               ([color=BLUE]foreach[/color] x ([color=BLUE]cdr[/color] ([color=BLUE]vl-sort[/color] x '([color=BLUE]lambda[/color] ( a b ) ([color=BLUE]>[/color] ([color=BLUE]last[/color] ([color=BLUE]car[/color] a)) ([color=BLUE]last[/color] ([color=BLUE]car[/color] b))))))
                   ([color=BLUE]entmod[/color] ([color=BLUE]list[/color] ([color=BLUE]cons[/color] -1 ([color=BLUE]cdr[/color] x)) '(8 . [color=MAROON]"Lower Points"[/color])))
               )
           )
       )
   )
   ([color=BLUE]princ[/color])
)
[color=GREEN];; Group By Function  -  Lee Mac[/color]
[color=GREEN];; Groups items considered equal by a given predicate function[/color]
([color=BLUE]defun[/color] LM:groupbyfunction ( lst fun [color=BLUE]/[/color] tmp1 tmp2 x1 )
   ([color=BLUE]if[/color] ([color=BLUE]setq[/color] x1 ([color=BLUE]car[/color] lst))
       ([color=BLUE]progn[/color]
           ([color=BLUE]foreach[/color] x2 ([color=BLUE]cdr[/color] lst)
               ([color=BLUE]if[/color] (fun x1 x2)
                   ([color=BLUE]setq[/color] tmp1 ([color=BLUE]cons[/color] x2 tmp1))
                   ([color=BLUE]setq[/color] tmp2 ([color=BLUE]cons[/color] x2 tmp2))
               )
           )
           ([color=BLUE]cons[/color] ([color=BLUE]cons[/color] x1 ([color=BLUE]reverse[/color] tmp1)) (LM:groupbyfunction ([color=BLUE]reverse[/color] tmp2) fun))
       )
   )
)
([color=BLUE]princ[/color])

$ (c:fixpoints)
    Fixpoints - Elapsed time: 66.2220 secs.
_$ (c:movdup)
Select Points: 
    Movdup - Elapsed time: 0.2970 secs.
_$