### Author Topic: Find point pairs  (Read 592 times)

0 Members and 1 Guest are viewing this topic.

#### Rod

• Newt
• Posts: 153
##### Find point pairs
« on: November 18, 2020, 05:52:57 PM »
I'm trying to come up with a way of finding point pairs from two different sets of points. But I'm having trouble even starting.
Can anyone give me some hints.

Given the two sets of points find the yellow lines

Here are the rules I was thinking
All the point pairs that are within some maximum distance
Preferably best match the points, like minimum total distances squared
Possibly also find the point where the answer isn't clear, like multiple options within a small distance

My example a quick sketch to illustrate my idea and doesn't follow an exact rule

Cheers, Rod.
"All models are wrong, some models are useful" - George Box

#### Rod

• Newt
• Posts: 153
##### Re: Find point pairs
« Reply #1 on: November 19, 2020, 05:21:04 PM »
I've come up with something if anyone is interseted but it's optimization is pretty terrible.
Greddy alorithim that resorts lists after each point pair is found to find the next closest point pair

Result images below.

Cheers, Rod.

Code - Auto/Visual Lisp: [Select]
1. (defun getDistList (ptList1 ptList2 maxDist / ptDistList dist)
2.   (setq nestedlist nil)
3.   (foreach pt1 ptList1
4.     (setq ptDistList nil)
5.     (foreach pt2 ptList2
6.       (if (< (setq dist (distance pt1 pt2)) maxDist)
7.         (setq ptDistList (cons (cons pt2 dist) ptDistList))
8.       ) ;_ end of if
9.     ) ;_ end of foreach
10.     (if ptDistList
11.         (setq ptDistList (vl-sort ptDistList (function (lambda (pair1 pair2) (< (cdr pair1) (cdr pair2))))))
12.         (setq nestedlist (cons (cons pt1 ptDistList) nestedlist))
13.       ) ;_ end of progn
14.     ) ;_ end of if
15.  ;_ end of setq
16.   ) ;_ end of foreach
17.   (setq nestedList (vl-sort nestedlist
18.                             (function (lambda (lst1 lst2)
19.                                         (< (cdr (cadr lst1)) (cdr (cadr lst2)))
20.                                       ) ;_ end of vl-sort
21.                             ) ;_ end of setq
22.                    ) ;_ end of foreach
23.   ) ;_ end of setq
24. ) ;_ end of defun
25.
26. (defun getPointPairs (nestedList / newList)
27.   (setq removeList nil)
28.   (setq pointPairs nil)
29.   (while nestedList
30.     (setq newList nil)
31.     (setq headerList (car nestedList))
32.     (setq pt1 (car headerList))
33.     (setq ptDistList (cdr headerList))
34. ;;;      (setq ptList (vl-remove-if (FUNCTION (LAMBDA (pair) (member (car pair) removeList))) ptList))
35.     (setq pt2 (car (car ptDistList)))
36.     (setq pointPairs (cons (list pt1 pt2) pointpairs))
37.     (foreach headerList (cdr nestedlist)
39.       (setq ptDistList (cdr headerList))
40.       (setq ptDistList (vl-remove-if (function (lambda (pair) (equal (car pair) pt2))) ptDistList)
41.       ) ;_ end of setq
42.       (if ptDistList
43.         (setq newList (cons (cons header ptDistList) newList))
44.
45.       ) ;_ end of if
46.     ) ;_ end of foreach
47. ;;;    (setq nestedList newList)
48.     (setq nestedList (vl-sort newList
49.                               (function (lambda (lst1 lst2)
50.                                           (< (cdr (cadr lst1)) (cdr (cadr lst2)))
51.                                         ) ;_ end of vl-sort
52.                               ) ;_ end of setq
53.                      ) ;_ end of vl-sort
54.     ) ;_ end of setq
55.     (setq newList nil)
56.   ) ;_ end of while
57.   (reverse pointPairs)
58. ) ;_ end of defun
59.
60. (defun drawlines (pointpairs)
61.   (foreach pair pointpairs
62.     (command "line" (car pair) (cadr pair) "")
63.   ) ;_ end of foreach
64. ) ;_ end of defun
65.
66. (defun C:test ()
67.   (setq ptList1 (getPointList 1))
68.   (setq ptList2 (getPointList 5))
69.   (setq nestedList (getdistList ptList1 ptList2 2.5))
70.   (setq pointPairs (getPointPairs nestedList))
71.   (drawlines pointpairs)
72.   (princ)
73. ) ;_ end of defun
74.
75. (defun getPointList (colour / ss1 pointList)
76.   (setq ss1 (ssget "x" (list (cons 62 colour) (cons 67 0))))
77.   (setq i 0)
78.   (repeat (sslength ss1)
79.     (setq pointList (cons (cdr (assoc 10 (entget (ssname ss1 i))))
80.                           pointlist
81.                     ) ;_ end of cons
82.     ) ;_ end of setq
83.     (setq i (1+ i))
84.   ) ;_ end of defun
85.   pointList
86. ) ;_ end of defun
87.
88.
« Last Edit: November 19, 2020, 06:18:18 PM by Rod »
"All models are wrong, some models are useful" - George Box

#### d2010

• Newt
• Posts: 159
##### Re: Find point pairs
« Reply #2 on: November 20, 2020, 08:30:48 AM »
You must replace this line   (command "Line" (car pair) (cadr pair) "")
with (dfn_enamk_line (car pair) (cadr pair) "" 15 "")=15 is newcolor
Code: [Select]
`(Defun dfn_enamk_line(p1 p2 la color lt / \$rr nfl)   (if (=  color nil) (setq;|a38748|; color 256)) (setq;|a38776|; la (if (>  la "") la (getvar "CLAYER")) p1 (append (list 10) p1) p2 (append (list 11) p2) nfl (list (cons 0 "LINE") (cons 100 "AcDbEntity") (cons 8 la) (cons 100 "AcDbLine") p1 p2 (cons 62 color))) (if (>  lt "") (setq;|a39068|; nfl (append nfl (list (cons 6 lt))))) (setq;|a39124|; \$rr (entmakex nfl)) (princ) \$rr) ;;{\$E}` :straight:You must add sufix  each functions/names.In my source i use rod_*
rod_getpointlist
rod_getpointpairs
rod_drawlines
rod_getdistlist
rod_epscolor=You exchange the color but dif <> (1,2,5) at (1->11)....
This function not accept 1 to 2, !or  1 to 5.
Code - Text: [Select]
1. ------------------------- //Md5=3261f31be69a089a46ab02c6b03b9483
2. #region
3. rod_epscolor
4. (Defun rod_epscolor(j_newarray kKeyColorList tzxelse / \$rr loopede pde nop cld cec sbb)
5. /*c2s:
6.        \$rr=tzxelse;
7.        princ(j_newarray);
8.        princ(" ");
9.        princ(kKeyColorList);
10.        terpri();
11.        cec=getint("="),
12.        sbb=(acand(numberp(cec),nil==member(cec,kKeyColorList)))?ssget("X",lISt(cons(62,tzxelse),cons(67,0))):nil,
13.        loopde=(sbb&&(sslength(sbb)>0))?dfn_ssg_tolistvla(sbb):car(list(nil,alert(strcat("*error*None  Entity with color=",itoa(tzxelse)))));
14.        if (loopde)
15.          { nop=foreach(pde,car(loopde),vla.put_color(pde,cec));
16.            nop=vla.Regen(con_acdoc,acAllViewports);
17.            \$rr=cec;
18.         };
19. */
20. \$rr)
21. %include=dfn_ssg_tolistvla
23.
Profesorul Dumitru Constantin Dulcan despre InteligentaMateriei.
Code - Text: [Select]
1. -------------------------//Md5=74d2b3a99ef5c512722f8c3d187da36e
2. #region
3. dfn_ssg_tolistvla
4. (defun dfn_ssg_tolistvla(freepick / ldm idx \$rr \$rl nop cpm)
8.        idx=(ldm)?(sslength(ldm)-1):RTCAN,
9.        \$rl=nil,
10.        \$rr=nil;
11.        if (ldm&&idx>0)
12.           for(;idx>=0;idx=idx-1)
13.              cpm=ssname(ldm,idx),
14.              \$rr=cons(cpm,\$rr),
15.              cpm=vlax.ename->vla_object(cpm),
16.              \$rl=(cpm)?cons(cpm,\$rl):\$rl;
17. */
18. (list \$rl \$rr))
20. #endregion
21. ------------------------- //Md5=c8f340319185b5573c5136da0f3b17fa
22. #region
23. pp_brownian_static
24. (defun pp_brownian_static(/ \$rr ptList1 ptList5 maxell ldcw lcmp acb acf acl jne lxor ixor)
25. /*c2s:
26.        jne="A",
27.        maxell=2.5,
28.        ace=1,
29.        acl=2,
30.        acf=5,
31.        ixor="\nDef:Brownian motion, or pedesis is the random motion of particles suspended in a medium.\n--This pattern of motion typically consists of random fluctuations.",
35.        for(;jne!="X";)
37.             if (jne=="M")
38.                 acwhile(maxell<1.0,
39.                      maxell=dfn_getx_real("\nGetRandMax <1..99>-=",getvar(ldcw)),
40.                       lcmp=(maxell>1.0)?setvar(ldcw,maxell):nil);
41.
43.              if (jne=="B") alert(ixor);
44.              if (jne=="E") ace=rod_epscolor("\nAceColor_",list(ace,acf,acl),ace);
45.              if (jne=="F") acf=rod_epscolor("\nAcfColor_",list(acf,ace,acl),acf);
46.              if (jne=="G") acf=rod_epscolor("\nAclColor_",list(acl,ace,acf),acl);
47.              if (jne=="0")
48.                 { ptList1=rod_getpointlist(ace),
49.                   ptList2=rod_getpointlist(acf),
50.                   nestedList=rod_getdistlist(ptList1,ptList2,maxell),
51.                   pointPairs=rod_getpointpairs(nestedList),
52.                   lcmp=(pointPairs && (length(pointPairs)>3))?list(rod_drawlines(pointpairs),terpri()):nil;
53.                };
54.            };
55. */
56. )
59. %include=rod_drawlines
60. %include=rod_getdistlist
61. %include=rod_getpointlist
62. %include=rod_getpointpairs
63. %include=dfn_ssg_tolistvla
64. %include=rod_epscolor
65. %include=dfn_getx_real
66. #endregion
67. ------------------------- //Md5=f6feae3c7907cf8816c95cd822f91cbd
68. #region
69. rod_drawlines
70.
71. (defun rod_drawlines(pointpairs / \$rr pair)
72. /*c2s:
74. */
75. \$rr)
76. %include=dfn_enamk_line
77. #endregion
78. -------------------------//Md5=a2f19d7e9af2fe8631f72d4fd1cae451
79. #region
80. rod_getdistlist
81.
82. (defun rod_getdistlist (ptList1 ptList2 maxDist / ptDistList dist jsr)
83. /*c2s: nestedlist=nil;
84.        foreach(pt1,ptList1,
85.              ptDistList=nil,
86.              foreach(pt2,ptList2,
87.                   dist=distance(pt1,pt2),
88.                   ptDistList=(dist< maxDist)?cons(cons(pt2,dist),ptDistList):ptDistList),
89.             jsr=(ptDistList!=nil)?1:0,
90.             ptDistList=(jsr==1)?vl.sort(ptDistList,function(lambda(pair1(pair2),(cdr(pair1) <cdr(pair2))))):ptDistList,
91.             nestedlist=(jsr==1)?cons(cons(pt1,ptDistList),nestedlist):nestedlist);
92.       nestedList=vl.sort(nestedlist,
94. */
95. nestedlist)
97. #endregion
98. -------------------------//Md5=c05578affa25111a2caf7d1b69925726
99. #region
100. rod_getpointlist
101. (defun rod_getpointlist (colour / \$rr ss1 stb ino)
102. /*c2s: \$rr=nil,
103.        ss1=ssget("X",lISt(cons(62,colour),cons(67,0)));
104.        ino=(ss1==nil)?RTCAN:(sslength(ss1)-1);
105.        if (ino<0) alert("*errorr* I do not found any entity with newcolor\nI'm trying to come up with a way of finding point\n
106. -- pairs from two different sets of points. But I'm\n
107. -- having trouble even starting.
108. -- Can anyone give me some hints.?");
109.        else for(;ino>=0;ino=ino-1)
110.                    stb=ssname(ss1,ino),
111.                \$rr=cons(cdr(assoc(10,entget(stb))),\$rr);
112. */
113. \$rr)
114. #endregion
115. -------------------------//Md5=cebdec731bb8bceef4668583c62ffb64
116. #region
117. rod_getpointpairs
118. (defun rod_getpointpairs (nestedList / newList jsr \$rr)
119. /*c2s: removeList=nil,
120.        pointPairs=nil,
121.        \$rr=nil;
122.        for(pointPairs=nil;nestedList;newList=nil)
126.              pt2=car(car(ptDistList)),
127.              pointPairs=cons(lISt(pt1,pt2),pointpairs);
131.                  ptDistList=vl.remove_if(function(lambda(pair(),equal(car(pair),pt2))),ptDistList),
132.                  jsr=(ptDistList)?1:0,
134.                 );
136.             };
137.           \$rr=reverse(pointPairs);
138. */
139. \$rr)
141. #endregion
142. -------------------------//Md5=8065ca613e733550a9efe50a4c585b34
143. #region
145.
146. /*c2s: princ("\nEnd");*/
147. T)
148. #endregion
150. #region
152. (prompt "\nCommand.com: Q2[enter]\n")
154. #endregion
155.
« Last Edit: November 21, 2020, 01:25:45 PM by d2010 »

#### ronjonp

• Needs a day job
• Posts: 7264
##### Re: Find point pairs
« Reply #3 on: November 20, 2020, 01:00:29 PM »
Here's one .. not going to win any speed competitions but should be faster than your solution.
Code - Auto/Visual Lisp: [Select]
1. (defun c:foo (/ a d p p1 p2 r)
2.   (gc)
3.   (defun _pts (s)
4.     (mapcar (function (lambda (x) (cdr (assoc 10 (entget x)))))
5.             (if s
6.               (mapcar 'cadr (ssnamex s))
7.             )
8.     )
9.   )
10.   (if (and (setq p1 (_pts (ssget "_X" '((0 . "point") (62 . 1)))))
11.            (setq p2 (_pts (ssget "_X" '((0 . "point") (62 . 5)))))
12.            (setq d (getdist "\nEnter max distance: "))
13.       )
14.     (foreach p p1
15.       (setq a (mapcar (function (lambda (x) (list (distance p x) x))) p2))
16.       (setq a (car (vl-sort a (function (lambda (r j) (< (car r) (car j)))))))
17.       (if (<= (car a) d)
18.         (progn (entmakex (list '(0 . "line") (cons 10 p) (cons 11 (cadr a)) '(62 . 1)))
19.                (setq p2 (vl-remove (cadr a) p2))
20.         )
21.       )
22.     )
23.   )
24.   (princ)
25. )
Also take a look at this thread: http://www.theswamp.org/index.php?topic=32874.msg383557#msg383557

More importantly Elpanov's algorithm: http://www.theswamp.org/index.php?topic=32874.msg383634#msg383634
« Last Edit: November 20, 2020, 01:15:15 PM by ronjonp »

Windows 10 x64 - AutoCAD /C3D 2020

Custom Build PC

#### Rod

• Newt
• Posts: 153
##### Re: Find point pairs
« Reply #4 on: November 22, 2020, 04:58:14 PM »
Thanks guys. Seems so easy. I need to study it more.
Cheers, Rod.
"All models are wrong, some models are useful" - George Box