Author Topic: Find point pairs  (Read 1405 times)

0 Members and 1 Guest are viewing this topic.

Rod

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

d2010

  • Bull Frog
  • Posts: 323
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
  22. %include=vl_load_com
  23.  
:straight: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)
  5. /*c2s: vl_load_com();
  6.        ldm=(type(freepick)==read("PICKSET"))?freepick:
  7.              (type(freepick)==read("ENAME"))?ssadd(freepick,ssadd()):nil,
  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))
  19. %include=vl_load_com
  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.",
  32.        lxor="\nBrownian motion(E.color1set)(F.color2set)(G.color3line)(M.setMaxDist)\n(A.about)(B.aboutBrown)(X.Exit)(0.run)=",
  33.        ldcw="CIRCLERAD";
  34.        vl_load_com();
  35.        for(;jne!="X";)
  36.          {  jne=dfn_getx_readkey("[ABEFGMRX\n]",lxor);
  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.  
  42.              if (jne=="A") alert(readme.txt);
  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. )
  57. %include=vl_load_com
  58. %include=dfn_getx_readkey
  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:
  73.      $rr=foreach(pair,pointpairs,dfn_enamk_line(car(pair),cadr(pair),"",15,""));
  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,
  93.           function(lambda(lst1(lst2), (cdr(cadr(lst1)) <cdr(cadr(lst2))))));
  94. */
  95. nestedlist)
  96. %include=vl_load_com
  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)
  123.            { headerList=car(nestedList);
  124.              pt1=car(headerList),
  125.              ptDistList=cdr(headerList),
  126.              pt2=car(car(ptDistList)),
  127.              pointPairs=cons(lISt(pt1,pt2),pointpairs);
  128.              foreach(headerList,cdr(nestedlist),
  129.                  header=car(headerList),
  130.                  ptDistList=cdr(headerList),
  131.                  ptDistList=vl.remove_if(function(lambda(pair(),equal(car(pair),pt2))),ptDistList),
  132.                  jsr=(ptDistList)?1:0,
  133.                  newlist=(jsr==1)?cons(cons(header,ptDistList),newList): newList,
  134.                 );
  135.               nestedList=vl.sort(newList,function(lambda(lst1(lst2), (cdr(cadr(lst1)) <cdr(cadr(lst2))))));
  136.             };
  137.           $rr=reverse(pointPairs);
  138. */
  139. $rr)
  140. %include=vl_load_com
  141. #endregion
  142. -------------------------//Md5=8065ca613e733550a9efe50a4c585b34
  143. #region
  144. -cad_amain_callend2
  145.    
  146. /*c2s: princ("\nEnd");*/
  147. T)
  148. #endregion
  149. -------------------------//Md5=3d14f4ad8a8831fd926f456420291222
  150. #region
  151. -cad_amain_eof2
  152. (prompt "\nCommand.com: Q2[enter]\n")
  153. %include=coff_linkerarx
  154. #endregion
  155.  
« Last Edit: November 21, 2020, 01:25:45 PM by d2010 »

ronjonp

  • Needs a day job
  • Posts: 7526
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 11 x64 - AutoCAD /C3D 2023

Custom Build PC

Rod

  • Newt
  • Posts: 185
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