List of points to a group of points

[Jonathan Handojo]

Hi all,

 

It's been a while since I'm asking for help, but I hope that you can once again lend your wisdom to my problem. There's probably a solution out there already, but I'm not too sure as to where to find them.

 

Attached in this dwg is a visual representation of what I'm trying to achieve. I don't really need the full program, but there's a specific goal I'm trying to achieve and I'm on my wits' end trying to figure this out.

 

Let's assume that the dwg file itself is a list, and the yellow blocks are all 3D points within that list. What I would like to find out is how to "group" this list of points into a group of points as shown by the red cloud.

 

Here's the criteria:

 

• Any points that are alone and not within close proximity to another point will be left out.
• Visually you will be able to distinguish the group. Each group will clearly be distinct from another in terms of distance. The "maximum" and "minimum" distance between each one is arbitrary.

 

Hopefully there's solutions out there already. Even a small start such as a function that can return this group of points from the full list will be more than beneficial for me and I can take care of the rest.

 

Thanks.

Jonathan Handojo

Test.dwg

[BIGAL]

Just some ideas start with a real big list of points, take point 1 compare pt2 pt3 etc make a new list when under the radial test, you can use read, eval and set to make new lists need to think about that, once a pair is made add to a list the issue is need to look at both start and end point going out unless you have some fixed pattern of point creation. I am not sure but maybe just do a sort of the master list on X&Y, when the radial distance is to large stop looking. 

 

Just thinking what happens if you make a list of dist from 0,0 to point (123.45 entname) then sort .

 

(setq ss (ssget "X" '((0 . "INSERT")(cons 2 "Quick Clip-CXL 20-25mm")(cons 410 (getvar 'ctab)))))
(setq pt0 (list 0.0 0.0))
(repeat (setq x (sslength ss))
(setq ent (ssname ss (setq x (1- x))))
(setq ins (cdr (assoc 10 (entget ent))))
(setq dist (distance pt0 ins))
(setq lst (cons (list dist ent) lst))
)

(setq lst (vl-sort lst '(lambda (x y) (< (car x)(car y)))))

 

 

A quick random look found 3 points, amongst the 538 points.

(72200.3448964234 <Entity name: 66aa0ce0>) (72204.9018861618 <Entity name: 66aa1960>) (72205.1818105296 <Entity name: 66aa12a0>)

The one before is (72186.8862583018  and after (72222.9410583057

 

[marko_ribar]

Like BIGAL stated, I coded for a start... It makes circles at each group...

Here is my code...

 

(defun c:group_blocks ( / *error* unique group_pts_within_fuzz_dist barycent cmd dd ss in ee ex pt al gg ll )

  (defun *error* ( m )
    (while (= 8 (logand 8 (getvar (quote undoctl))))
      (if command-s
        (command-s "_.UNDO" "_E")
        (vl-cmdf "_.UNDO" "_E")
      )
    )
    (if cmd
      (setvar (quote cmdecho) cmd)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (defun unique ( lst )
    (if lst
      (cons (car lst)
        (unique
          (vl-remove-if (function (lambda ( x ) (equal x (car lst) 1e-6)))
            (cdr lst)
          )
        )
      )
    )
  )

  (defun group_pts_within_fuzz_dist ( ptlst dist / a b g gg xx gx )
    (while ptlst
      (setq a (car ptlst) b (vl-some (function (lambda ( x ) (if (and a x (< (distance a x) dist)) x))) (cdr ptlst)))
      (while (and a b)
        (if (not (vl-some (function (lambda ( x ) (equal a x 1e-6))) g))
          (setq g (cons a g))
        )
        (if (not (vl-some (function (lambda ( x ) (equal b x 1e-6))) g))
          (setq g (cons b g))
        )
        (setq a (car ptlst) b (vl-some (function (lambda ( x ) (if (and a x (< (distance a x) dist)) x))) (cdr ptlst)))
        (if (and b (vl-some (function (lambda ( x ) (equal b x 1e-6))) ptlst))
          (setq ptlst (subst b (car ptlst) (vl-remove-if (function (lambda ( x ) (equal b x 1e-6))) ptlst)))
        )
      )
      (if (and b (vl-some (function (lambda ( x ) (equal b x 1e-6))) ptlst))
        (setq ptlst (subst b (car ptlst) (vl-remove-if (function (lambda ( x ) (equal b x 1e-6))) ptlst)))
        (setq ptlst (cdr ptlst))
      )
      (if (and g (> (length g) 1))
        (setq gg (cons (reverse g) gg))
      )
      (setq g nil)
    )
    (setq gg (reverse gg))
    (foreach g gg
      (foreach pt g
        (if (setq xx (vl-some (function (lambda ( x ) (if (vl-some (function (lambda ( y ) (equal y pt dd))) x) x))) (vl-remove-if (function (lambda ( x ) (equal x g 1e-6))) gg)))
          (setq gg (subst (append g xx) xx (vl-remove-if (function (lambda ( x ) (equal x g 1e-6))) gg)))
        )
      )
    )
    (foreach g gg
      (setq gx (vl-sort g (function (lambda ( a b ) (if (equal (cadr a) (cadr b) 1e-6) (< (car a) (car b)) (< (cadr a) (cadr b)))))))
      (setq gg (subst gx g gg))
    )
    gg
  )

  (defun barycent ( ptlst )
    (mapcar (function (lambda ( x ) (/ x (float (length ptlst))))) 
      (mapcar (function (lambda ( x ) (apply (function +) x))) 
        (apply (function mapcar) (cons (function list) ptlst))
      )
    )
  )

  (setq cmd (getvar (quote cmdecho)))
  (setvar (quote cmdecho) 0)
  (while (= 8 (logand 8 (getvar (quote undoctl))))
    (if command-s
      (command-s "_.UNDO" "_E")
      (vl-cmdf "_.UNDO" "_E")
    )
  )
  (if command-s
    (command-s "_.UNDO" "_BE")
    (vl-cmdf "_.UNDO" "_BE")
  )
  (initget 6)
  (setq dd (cond ( (getdist "\nPick or specify fuzz distance (little larger than distance between two adjacent blocks) <67.5> : ") ) ( 67.5 ) ))
  (if (setq ss (ssget "_X" (list (cons 0 "INSERT"))))
    (progn
      (repeat (setq in (sslength ss))
        (setq ex (entget (setq ee (ssname ss (setq in (1- in))))))
        (setq pt (cdr (assoc 10 ex)))
        (setq al (cons (cons pt ee) al))
      )
      (setq gg (group_pts_within_fuzz_dist (unique (mapcar (function car) al)) dd))
      (foreach g gg
        (foreach pt g
          (setq ll (cons (vl-some (function (lambda ( x ) (if (equal pt (car x) 1e-6) x))) al) ll))
        )
        (setq lll (cons ll lll))
        (setq ll nil)
      )
      (foreach ll lll
        (vl-cmdf "_.CIRCLE" "_non" (barycent (unique (mapcar (function car) ll))) 135.0)
      )
      (prompt "\nGroups of blocks within proximity distance : ") (princ (rtos dd 2 15)) (prompt " is stored in variable lll which is global... You can call it with !lll...\nDon't forget to (setq lll nil) variable when finished using it...")
    )
  )
  (*error* nil)
)

 

HTH.

M.R.

Edited May 9 by marko_ribar

[Jonathan Handojo]

Wow, MR, works a treat! That variable gg is exactly what I needed. Thanks a lot for the help.

 

Maybe the reason I was struggling is because I wanted the program to be able to "detect" the distance without prompting the user. But I suppose that might be slightly out of reach.

 

Anyway, thanks again for this Marko.

[exceed]

how about this way

 

when I wrote this link, (install cables into a pipe - merging the polyline offset by the cable radius to calculate the empty space.)

I knew that it is easy to do this by

entmake CIRCLE for each blocks > OFFSET circles  > convert to REGION > merging regions by UNION > Convert back to POLYLINE

and then add routine for delete the ONE SMALL CIRCLE.. in this case.

 

 

 

 

Edited May 10 by exceed

[Jonathan Handojo]

23 minutes ago, exceed said:

how about this way

 

when I wrote this link, (install cables into a pipe - merging the polyline offset by the cable radius to calculate the empty space.)

I knew that it is easy to do this by

entmake CIRCLE for each blocks > OFFSET circles  > convert to REGION > MERGING > Convert back to POLYLINE

and then add routine for delete the ONE SMALL CIRCLE.. in this case.

 

 

 

 

My application isn't about using cables filling into a conduit but using quick channels to support pex piping. As you can probably tell from the name of the block, I'm using quick clips to support the pex itself, but the clips themselves will also need to be supported to the soffit. Since they're exposed, the client wants them looking neat and pleasing to the eye. As such, their solution was to use the quick channels. So, I need to find out how many cuts are required.

 

Though, that must have been a lot of effort that you have put into your code. Well done.

[exceed]

link is just example, not like this?

 

 

 

(defun c:foo ( / acdoc cloud_offset_size ss ssl index ss2 ent obj bbox lll url c_radius c_center c_ent ss3 ss4 ss5 )
  (vla-startundomark (setq acdoc (vla-get-activedocument (vlax-get-acad-object))))
  (setvar 'cmdecho 0)
  (setq cloud_offset_size 70) ;edit this value
  (setq ss (ssget '((0 . "INSERT"))))
  (setq ssl (sslength ss))
  (setq index 0)
  (setq ss2 (ssadd))
  (repeat ssl
    (setq ent (ssname ss index))
    (setq obj (vlax-ename->vla-object ent))    
    (setq bbox (vla-getboundingbox obj 'll 'ur))
    (setq lll (vlax-safearray->list ll)) 
    (setq url (vlax-safearray->list ur)) 
    (setq c_radius (/ (distance lll url) 2))
    (setq c_center (polar lll (angle lll url) c_radius))
    (setq c_ent (entmakex (list (cons 0 "CIRCLE") (cons 10 c_center) (cons 40 (+ cloud_offset_size c_radius)))))
    (command "region" c_ent "")
    (ssadd (entlast) ss2)
    (setq index (+ index 1))
  )
  (command "union" ss2 "")
  (setvar 'cmdecho 1)
  (vla-endundomark acdoc)
  (princ)
)

 

 

I used QSELECT because I didn't have time, but it is possible to add routines for exploding a region or joining with a polyline.

Edited May 10 by exceed

[Jonathan Handojo]

44 minutes ago, exceed said:

link is just example, not like this?

 

 

 

(defun c:foo ( / acdoc cloud_offset_size ss ssl index ss2 ent obj bbox lll url c_radius c_center c_ent ss3 ss4 ss5 )
  (vla-startundomark (setq acdoc (vla-get-activedocument (vlax-get-acad-object))))
  (setvar 'cmdecho 0)
  (setq cloud_offset_size 70) ;edit this value
  (setq ss (ssget '((0 . "INSERT"))))
  (setq ssl (sslength ss))
  (setq index 0)
  (setq ss2 (ssadd))
  (repeat ssl
    (setq ent (ssname ss index))
    (setq obj (vlax-ename->vla-object ent))    
    (setq bbox (vla-getboundingbox obj 'll 'ur))
    (setq lll (vlax-safearray->list ll)) 
    (setq url (vlax-safearray->list ur)) 
    (setq c_radius (/ (distance lll url) 2))
    (setq c_center (polar lll (angle lll url) c_radius))
    (setq c_ent (entmakex (list (cons 0 "CIRCLE") (cons 10 c_center) (cons 40 (+ cloud_offset_size c_radius)))))
    (command "region" c_ent "")
    (ssadd (entlast) ss2)
    (setq index (+ index 1))
  )
  (command "union" ss2 "")
  (setvar 'cmdecho 1)
  (vla-endundomark acdoc)
  (princ)
)

 

 

I used QSELECT because I didn't have time, but it is possible to add routines for exploding a region or joining with a polyline.

I didn't thought of it this way... a rather creative approach. Thanks for that.

[ronjonp]

53 minutes ago, Jonathan Handojo said:

I didn't thought of it this way... a rather creative approach. Thanks for that.

Adaptation from some code 4 years ago

(defun c:foo (/ a d l r s sp)
  ;; RJP » 2024-05-09
  ;; Adapted from https://www.cadtutor.net/forum/topic/69706-routine-for-buffer/#comment-561009
  (setq l "BubbleLicious")
  (setq d 45)
  (cond	((setq s (ssget '((0 . "INSERT"))))
	 (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))
	   (setq r (cons (entmakex (list '(0 . "CIRCLE") (assoc 10 (entget e)) (cons 40 d))) r))
	 )
	 (setq sp (vlax-ename->vla-object (cdr (assoc 330 (entget (car r))))))
	 (setq s (vlax-invoke sp 'addregion (mapcar 'vlax-ename->vla-object r)))
	 (mapcar 'entdel r)
	 (setq a (car s))
	 (entmod (append (entget (vlax-vla-object->ename a)) (list (cons 8 l))))
	 (foreach o (cdr s) (vla-boolean a acunion o))
	)
  )
  (princ)
)

Edited May 10 by ronjonp

[BIGAL]

Wow so simple compared to comparing points.

[marko_ribar]

@ronjonp

Your code is so simple - that's great, but as per request - OP wanted to find groups and left singles ungrouped... Or I am missing something???

So I think that OP can now implement your region way to my sub and it'll be just fine... He'll just have to code for it, but I suppose that is going to be now much easier...

 

Thanks, Ron...

[Danielm103]

Re foo: what about this one... edit, still ronjonp idea is brilliant

Edited May 10 by Danielm103

[Danielm103]

I used a KD-Tree, it suffers from the same issue in that you have to enter a magic number

and if the number is big enough to fit the issue above, the corners fail. I asked my daughter to write a machine leaning

algorithm lol.

[Jonathan Handojo]

Now that you mention it, it's similar to that of the K Mean Clustering. Yea, my logic won't really need to go that far, but what Marko coded up will work just fine for me right now.

[Jonathan Handojo]

52 minutes ago, marko_ribar said:

@ronjonp

Your code is so simple - that's great, but as per request - OP wanted to find groups and left singles ungrouped... Or I am missing something???

So I think that OP can now implement your region way to my sub and it'll be just fine... He'll just have to code for it, but I suppose that is going to be now much easier...

 

Thanks, Ron...

Yeah, you're not wrong, I need the single ones left out.

[ronjonp]

8 hours ago, Jonathan Handojo said:

Yeah, you're not wrong, I need the single ones left out.

Easy enough and this version creates individual regions 

(defun c:foo (/ a ar d l r s sp)
  ;; RJP » 2024-05-09
  ;; Adapted from https://www.cadtutor.net/forum/topic/69706-routine-for-buffer/#comment-561009
  (setq l "BubbleLicious")
  (setq ar (* pi (* (setq d 150.) d)))
  (cond	((setq s (ssget '((0 . "INSERT"))))
	 (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))
	   (setq r (cons (entmakex (list '(0 . "CIRCLE") (assoc 10 (entget e)) (cons 40 d))) r))
	 )
	 (setq sp (vlax-ename->vla-object (cdr (assoc 330 (entget (car r))))))
	 (setq s (vlax-invoke sp 'addregion (mapcar 'vlax-ename->vla-object r)))
	 (mapcar 'entdel r)
	 (entmod (append (entget (vlax-vla-object->ename (setq a (car s)))) (list (cons 8 l))))
	 (foreach o (cdr s) (vla-boolean a acunion o))
	 (setq s (vlax-invoke a 'explode))
	 (vla-delete a)
	 ;; Remove the loner circles 8-)
	 (foreach o s (and (equal ar (vla-get-area o) 1e-4) (vla-delete o)))
	)
  )
  (princ)
)

Edited May 10 by ronjonp

[ronjonp]

8 hours ago, Danielm103 said:

Re foo: what about this one... edit, still ronjonp idea is brilliant

Just up the size of the radius .. here's 150.

[Danielm103]

does 150 break the corners?  Edit: Just something I noticed, my routine doesn’t handle that edge case either  

 

 

Edited May 10 by Danielm103

[ronjonp]

9 minutes ago, Danielm103 said:

does 150 break the corners?

I would call that better grouping if one tolerance is used 

[ronjonp]

@Jonathan Handojo Would this scenario be considered a group?

Edited May 10 by ronjonp