Jump to content

Find points pairs with distance tolerance


ctdlc888

Recommended Posts

Hi lisp masters.I have searched here a lot but could'nt find a lisp which can identify

almost duplicate points,what i found are duplicate finders.Say i need to know which points are closer by less than 5meters(or any number tolerance). We always receive drawings with many GPS XY coordinates with plenty multiple observations/coordinates which should count as one. We need exact counting.

Thanks for help.

Link to comment
Share on other sites

------->Further testing resulted in FAILURE to give accurate count

(defun c:test  (/ seek fuzz cnt i plst)
(vl-load-com)
(defun seek  (pt fz lst / sk lst)
           (setq sk   (ssget "_C"
                             (polar pt (* pi 0.25) (* fz (sqrt 2)))
                             (polar pt (* pi 1.25) (* fz (sqrt 2)))
                             '((0 . "POINT"))))
           (repeat (sslength sk)
                 (setq lst (cons (ssname sk 0) lst))
                 (ssdel (ssname sk 0) sk))
           lst
           )
     (if (and (setq fuzz (getdist "\nEmter Fuzz Value: "))
              (setq plst nil
                    cnt  0
                    ss   (ssget "_X" (list '(0 . "POINT")(cons 410 (getvar 'Ctab))))))
           (progn (vla-zoomextents (vlax-get-acad-object))
                 (repeat (setq i (sslength ss))
                        (setq en (ssname ss (setq i (1- i))))
                        (if (not (member en plst))
                              (setq plst (seek (cdr (assoc 10
                                                           (entget en)))
                                               fuzz
                                               plst)
                                    cnt  (1+ cnt))(entmod (subst (cons 8 "DuplicatePoints")
                                                                 (assoc 8 (entget en)) (entget en))))
                        )
                  (princ (strcat "\n"
                                 (itoa cnt)
                                 " Points Found")))
           )
     (princ)
     )

 

UPDATED to include place duplicates on Layer "DuplicatePoints"

:::::Code Failure: :::::

Edited by pBe
Seek again/Select All points on current tab
Link to comment
Share on other sites

I'd try:

 

[b][color=BLACK]([/color][/b]defun c:findpt [b][color=FUCHSIA]([/color][/b]/ fuzz ss bp ps en pp[b][color=FUCHSIA])[/color][/b] [color=#8b4513]; ts is global[/color]
 [b][color=FUCHSIA]([/color][/b]initget 7[b][color=FUCHSIA])[/color][/b]
 [b][color=FUCHSIA]([/color][/b]setq fuzz [b][color=NAVY]([/color][/b]getdist [color=#2f4f4f]"\nTolerance Distance:   "[/color][b][color=NAVY])[/color][/b][b][color=FUCHSIA])[/color][/b]
 [b][color=FUCHSIA]([/color][/b]and [b][color=NAVY]([/color][/b]princ [color=#2f4f4f]"\nSelect Base Point:   "[/color][b][color=NAVY])[/color][/b]
      [b][color=NAVY]([/color][/b]setq ss [b][color=MAROON]([/color][/b]ssget '[b][color=GREEN]([/color][/b][b][color=BLUE]([/color][/b]0 . [color=#2f4f4f]"POINT"[/color][b][color=BLUE])[/color][/b][b][color=GREEN])[/color][/b][b][color=MAROON])[/color][/b][b][color=NAVY])[/color][/b]
      [b][color=NAVY]([/color][/b]= [b][color=MAROON]([/color][/b]sslength ss[b][color=MAROON])[/color][/b] 1[b][color=NAVY])[/color][/b]
      [b][color=NAVY]([/color][/b]setq bp [b][color=MAROON]([/color][/b]cdr [b][color=GREEN]([/color][/b]assoc 10 [b][color=BLUE]([/color][/b]entget [b][color=RED]([/color][/b]ssname ss 0[b][color=RED])[/color][/b][b][color=BLUE])[/color][/b][b][color=GREEN])[/color][/b][b][color=MAROON])[/color][/b][b][color=NAVY])[/color][/b]
      [b][color=NAVY]([/color][/b]setq ps [b][color=MAROON]([/color][/b]ssget [color=#2f4f4f]"_C"[/color] [b][color=GREEN]([/color][/b]list [b][color=BLUE]([/color][/b]- [b][color=RED]([/color][/b]car bp[b][color=RED])[/color][/b] fuzz[b][color=BLUE])[/color][/b] [b][color=BLUE]([/color][/b]- [b][color=RED]([/color][/b]cadr bp[b][color=RED])[/color][/b] fuzz[b][color=BLUE])[/color][/b][b][color=GREEN])[/color][/b]
                           [b][color=GREEN]([/color][/b]list [b][color=BLUE]([/color][/b]+ [b][color=RED]([/color][/b]car bp[b][color=RED])[/color][/b] fuzz[b][color=BLUE])[/color][/b] [b][color=BLUE]([/color][/b]+ [b][color=RED]([/color][/b]cadr bp[b][color=RED])[/color][/b] fuzz[b][color=BLUE])[/color][/b][b][color=GREEN])[/color][/b]
                          '[b][color=GREEN]([/color][/b][b][color=BLUE]([/color][/b]0 . [color=#2f4f4f]"POINT"[/color][b][color=BLUE])[/color][/b][b][color=GREEN])[/color][/b][b][color=MAROON])[/color][/b][b][color=NAVY])[/color][/b]
      [b][color=NAVY]([/color][/b]setq ts [b][color=MAROON]([/color][/b]ssadd[b][color=MAROON])[/color][/b][b][color=NAVY])[/color][/b]
      [b][color=NAVY]([/color][/b]while [b][color=MAROON]([/color][/b]setq en [b][color=GREEN]([/color][/b]ssname ps 0[b][color=GREEN])[/color][/b][b][color=MAROON])[/color][/b]
             [b][color=MAROON]([/color][/b]setq pp [b][color=GREEN]([/color][/b]cdr [b][color=BLUE]([/color][/b]assoc 10 [b][color=RED]([/color][/b]entget en[b][color=RED])[/color][/b][b][color=BLUE])[/color][/b][b][color=GREEN])[/color][/b][b][color=MAROON])[/color][/b]
             [b][color=MAROON]([/color][/b]and [b][color=GREEN]([/color][/b]not [b][color=BLUE]([/color][/b]equal bp pp[b][color=BLUE])[/color][/b][b][color=GREEN])[/color][/b]
                  [b][color=GREEN]([/color][/b]<= [b][color=BLUE]([/color][/b]distance bp pp[b][color=BLUE])[/color][/b] fuzz[b][color=GREEN])[/color][/b]
                  [b][color=GREEN]([/color][/b]ssadd en ts[b][color=GREEN])[/color][/b][b][color=MAROON])[/color][/b]
             [b][color=MAROON]([/color][/b]ssdel en ps[b][color=MAROON])[/color][/b][b][color=NAVY])[/color][/b]
      [b][color=NAVY]([/color][/b]prin1 [b][color=MAROON]([/color][/b]sslength ts[b][color=MAROON])[/color][/b][b][color=NAVY])[/color][/b][b][color=FUCHSIA])[/color][/b]
 [b][color=FUCHSIA]([/color][/b]prin1[b][color=FUCHSIA])[/color][/b][b][color=BLACK])[/color][/b]

 

 

I don't think that the "W" ssget filter will return correct results. -David

 

Also, please remember that point values are calculated in 3D

Link to comment
Share on other sites

Here is a 'Divide and Conquer' method:

 

(defun c:ptcount ( / a b d e f i s x y )

   (setq f  5.0 ;; Tolerance
         d '(8 . "$DUPLICATE-POINTS$") ;; Duplicate Points Layer
   )
   (if (setq s (ssget "_X" '((0 . "POINT") (410 . "Model"))))
       (progn
           (setq a
               (vl-sort
                   (repeat (setq i (sslength s))
                       (setq e (entget (ssname s (setq i (1- i))))
                             a (cons (cons (cdr (assoc 10 e)) e) a)
                       )
                   )
                  '(lambda ( a b ) (<= (caar a) (caar b)))
               )
           )
           (while (setq x (car a))
               (setq a (cdr a)
                     b a
               )
               (while (and (setq y (car b)) (<= (- (caar y) (caar x)) f))
                   (if (<= (distance (car x) (car y)) f)
                       (progn
                           (entmod (subst d (assoc 8 (cdr y)) (cdr y)))
                           (ssdel (cdr (assoc -1 (cdr y))) s)
                       )
                   )
                   (setq b (cdr b))
               )
           )
           (princ (strcat "\n" (itoa (sslength s)) " Distinct Points to a Tolerance of " (rtos f 2 15)))
       )
   )
   (princ)
)

 

Duplicate points will be placed on a separate layer.

Link to comment
Share on other sites

@LM.Can we have a prompt for input of tolerance and color of the new layer?

if not too much of asking .thanks

Yours WORKED VERY FINE. I just change 'setq f 5' to other number for tolerance

Edited by ctdlc888
Link to comment
Share on other sites

Update Code at post #4 to include placement of duplicates on a separate layer.

 

HTH

 

EDIT:

Scratch that code . Further testing shows using distance function is the way to go. unless i can find a way to force selection within circumference of a given radius.

kudos to Lee and David

 

Second attempt: (similar to Lee's approach)

 

(defun c:Ptnum  (/ cnt ss coll p)
     (vl-load-com)
     (if (and (setq cnt  0
                    coll nil
                    fuzz (getdist "\nEmter Fuzz Value: "))
              (ssget "_X"
                     (list '(0 . "POINT")
                           (cons 410 (getvar 'Ctab)))))
           (progn
                 (vlax-for
                        itm  (setq ss   (vla-get-ActiveSelectionSet
                                              (vla-get-ActiveDocument
                                                    (vlax-get-acad-object))))
                       (setq coll (cons (list
                                              (list (car (setq a (vlax-get itm 'Coordinates)))
                                                    (cadr a))
                                              itm)
                                        coll))
                       )
                 (vla-delete ss)
                 (while (and (setq p (car coll))
                             (/= (length coll) 1))
                       (setq cnt (1+ cnt))
                       (foreach
                              j  coll
                             (if (<= (distance
                                           (car p)
                                           (car j))
                                     fuzz)
                                   (setq coll (vl-remove j coll))
                                   )
                             (setq coll (vl-remove p coll))
                             ))
                 )
           )
     (princ (strcat "\n" (itoa cnt) " Points Found"))
     (princ)
     )

Edited by pBe
Link to comment
Share on other sites

@LM.Can we have a prompt for input of tolerance and color of the new layer?

if not too much of asking .thanks

 

Here is a prompt for tolerance:

 

(defun c:ptcount ( / a b d e f i s x y )

   (setq d '(8 . "$DUPLICATE-POINTS$")) ;; Duplicate Points Layer
   
   (if
       (and
           (setq s (ssget "_X" '((0 . "POINT") (410 . "Model"))))
           (setq f (getdist "\nSpecify Tolerance: "))
       )        
       (progn
           (setq a
               (vl-sort
                   (repeat (setq i (sslength s))
                       (setq e (entget (ssname s (setq i (1- i))))
                             a (cons (cons (cdr (assoc 10 e)) e) a)
                       )
                   )
                  '(lambda ( a b ) (<= (caar a) (caar b)))
               )
           )
           (while (setq x (car a))
               (setq a (cdr a)
                     b a
               )
               (while (and (setq y (car b)) (<= (- (caar y) (caar x)) f))
                   (if (<= (distance (car x) (car y)) f)
                       (progn
                           (entmod (subst d (assoc 8 (cdr y)) (cdr y)))
                           (ssdel (cdr (assoc -1 (cdr y))) s)
                       )
                   )
                   (setq b (cdr b))
               )
           )
           (princ (strcat "\n" (itoa (sslength s)) " Distinct Points to a Tolerance of " (rtos f 2 15)))
       )
   )
   (princ)
)

 

You can change the layer colour easily through the Layer Manager.

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...