Author Topic: (Challenge) To draw the shortest lwpolyline  (Read 125164 times)

0 Members and 1 Guest are viewing this topic.

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #150 on: July 02, 2020, 11:41:42 AM »
Hi, me again...
After very limited testings, I discovered that there were no differences between original version and my mod. of chlh_jd's sub... I find that using (/ pi 2.0) angle is somewhat more mathematical and theoretical better than using both (/ pi 2.0) and (/ pi 3.0) and therefore I have chosen my mod. better... It's somewhat faster as it don't process last portion I commented and now it's only the question why chlh_jd used both angles in checking... If someone finds differences between those two, please leave the comment... Here is my mod. I am using now :

Code - Auto/Visual Lisp: [Select]
  1. ...
  2.   (defun chlh_jd-process ( lst / l m p p0 p1 q i d0 l0 l1 d1 _pi2 _pi3 )
  3.     (setq _pi2 (/ pi 2.0) _pi3 (/ pi 3.0))
  4.     (setq lst (foo lst))
  5.     (setq l (f2 lst))
  6.     (setq i  0
  7.           l0 lst
  8.           q  (length lst)
  9.           d0 (get-closedpolygon-length lst)
  10.     )
  11.     (foreach a l
  12.       (if (and (< a _pi2) (setq p (nth i lst))) ;;; original version : (and (< a _pi3) (= (setq p (nth i lst)) (nth i l0)))
  13.         (progn
  14.           (if (= i 0)
  15.             (setq p0 (last lst))
  16.             (setq p0 (nth (1- i) lst))
  17.           )
  18.           (if (= i (1- q))
  19.             (setq p1 (car lst))
  20.             (setq p1 (nth (1+ i) lst))
  21.           )
  22.           (setq m (list (list p0 p p1)
  23.                         (list p0 p1 p)
  24.                         (list p1 p p0)
  25.                         (list p1 p0 p)
  26.                         (list p p0 p1)
  27.                         (list p p1 p0)
  28.                   )
  29.           )
  30.           (setq l1
  31.             (car
  32.               (vl-sort (mapcar
  33.                          (function
  34.                            (lambda ( x )
  35.                              (ch-para-lst x i lst)
  36.                            )
  37.                          )
  38.                          m
  39.                        )
  40.                 (function (lambda ( e1 e2 )
  41.                     (< (get-closedpolygon-length e1)
  42.                        (get-closedpolygon-length e2)
  43.                     )
  44.                   )
  45.                 )
  46.               )
  47.             )
  48.           )
  49.           (setq d1 (get-closedpolygon-length l1))
  50.           (if (< d1 d0)
  51.             (setq d0  d1
  52.                   lst l1
  53.             )
  54.           )
  55.         )
  56.       )
  57.       (setq i (1+ i))
  58.     )
  59.     ;;; original version has this portion that is commented between ;| and |;
  60.     ;|
  61.     (setq l (f2 lst))
  62.     (setq i  0
  63.           l0 lst
  64.           d0 (get-closedpolygon-length lst)
  65.     )
  66.     (foreach a l
  67.       (if (and (< a _pi2) (setq p (nth i l0)))
  68.         (progn
  69.           (setq l1 (f1 p (vl-remove p lst)))
  70.           (setq d1 (get-closedpolygon-length l1))
  71.           (if (< d1 d0)
  72.             (setq d0  d1
  73.                   lst l1
  74.             )
  75.           )
  76.         )
  77.       )
  78.       (setq i (1+ i))
  79.     )
  80.     |;
  81.     lst
  82.   )
  83. ...
  84.  
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

JohnK

  • Administrator
  • Seagull
  • Posts: 10605
Re: (Challenge) To draw the shortest lwpolyline
« Reply #151 on: July 02, 2020, 12:04:45 PM »
> slow
I've lost almost all of my lisp abilities but, to me, this seems like an awful lot of anonymous functions and variable declarations.

Also, function names like "foo", "det", "f1", etc. make this code unreadable.

Here are a few quick copy/pastes from the lisp file (not exhaustive or inclusive; just random areas showing excessive annon functions).
Couldn't some of these annon functions be simplified?
Code - Auto/Visual Lisp: [Select]
  1. ...
  2.               (setq lst
  3.                   (vl-sort lst
  4.                       (function
  5.                           (lambda ( a b / c d )
  6.                               (if (or (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8) (and (or (equal c 0.0 1e-8) (equal c (* 2 pi) 1e-8)) (or (equal d 0.0 1e-8) (equal d (* 2 pi) 1e-8))))
  7.                                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
  8.                                   (< c d)
  9.                               )
  10.                           )
  11.                       )
  12.                   )
  13.               )
  14.               (setq lstl (vl-remove-if-not (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
  15.               (setq lst (vl-remove-if (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
  16.               (setq lstl (vl-sort lstl (function (lambda ( a b ) (> (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))))))
  17.               (setq lst (append lst lstl))
  18.  
  19. ...
  20. (defun chulllw2 ( l v / ll ent ls lll lil lial liall )
  21.     (setq ll  (if (= v 1) (LM:ConvexHull-ptsonHull l) (Graham-scan l))
  22.           ent (entmakex (append (list '(0 . "LWPOLYLINE")
  23.                                       '(100 . "AcDbEntity")
  24.                                       '(100 . "AcDbPolyline")
  25.                                       (cons 90 (length l))
  26.                                       (cons 70 (1+ (* 128 (getvar 'plinegen))))
  27.                                       '(38 . 0.0)
  28.                                 )
  29.                                 (mapcar (function (lambda ( a ) (cons 10 a))) ll)
  30.                         )
  31.               )
  32.     )
  33.     (setq ls l)
  34.     (foreach a ll (setq ls (vl-remove a ls)))
  35.     (setq lll ll)
  36.     (while (/= (length lll) (length l))
  37.       (setq lil (mapcar (function list) lll (append (cdr lll) (list (car lll)))))
  38.       (foreach a ls
  39.         (setq lial (mapcar (function (lambda ( x ) (cons (+ (distance (car x) a) (distance (cadr x) a)) (list x a)))) lil))
  40.         (setq liall (cons lial liall))
  41.       )
  42.       (setq liall (vl-sort liall (function (lambda ( a b ) (< (apply (function min) (mapcar (function car) a)) (apply (function min) (mapcar (function car) b)))))))
  43.       (setq lial (car (vl-sort (car liall) (function (lambda ( a b ) (< (car a) (car b)))))))
  44.       (entmod (append (reverse (member (cons 10 (car (cadr lial))) (reverse (entget ent))))
  45.                       (list (cons 10 (caddr lial)))
  46.                       (member (cons 10 (cadr (cadr lial))) (entget ent))
  47.               )
  48.       )
  49.       (setq lll (mapcar (function cdr)
  50.                         (vl-remove-if (function (lambda ( a ) (/= (car a) 10))) (entget ent))
  51.                 )
  52.       )
  53.       (setq ls (vl-remove (caddr lial) ls))
  54.       (setq liall nil)
  55.     )
  56.     ent
  57.   )
  58.  
  59.   (defun car-sort ( lst cmp / f rtn )
  60.  
  61.     (defun f ( x )
  62.       (setq lst (cdr lst))
  63.       (if (apply cmp (list x rtn))
  64.         (setq rtn x)
  65.       )
  66.     )
  67.  
  68.     (setq rtn (car lst))
  69.     (while (vl-some (function f) (cdr lst)))
  70.     rtn
  71.   )
  72.  
  73.   (defun chkinters ( pl / lil k a ilil pre mid suf )
  74.     (setq lil (mapcar (function list) pl (append (cdr pl) (list (car pl)))))
  75.     (setq k -1)
  76.     (while (and (< (setq k (1+ k)) (length lil)) (setq a (nth k lil)))
  77.       (setq ilil (vl-some (function (lambda ( b / ip ) (setq ip (inters (car a) (cadr a) (car b) (cadr b))) (if (and ip (setq ip (mapcar (function +) '(0 0) ip)) (or (and (or (equal ip (car a) 1e-6) (equal ip (cadr a) 1e-6)) (not (equal ip (car b) 1e-6)) (not (equal ip (cadr b) 1e-6))) (and (or (equal ip (car b) 1e-6) (equal ip (cadr b) 1e-6)) (not (equal ip (car a) 1e-6)) (not (equal ip (cadr a) 1e-6))) (and (not (equal ip (car a) 1e-6)) (not (equal ip (cadr a) 1e-6)) (not (equal ip (car b) 1e-6)) (not (equal ip (cadr b) 1e-6))))) (list a b)))) (vl-remove a lil)))
  78.       (if ilil
  79.         (progn
  80.           (setq pre (reverse (cdr (member (car ilil) (reverse lil)))))
  81.           (setq mid (cdr (member (car ilil) lil)))
  82.           (setq mid (cdr (member (cadr ilil) (reverse mid))))
  83.           (setq mid (mapcar (function reverse) mid))
  84.           (setq suf (cdr (member (cadr ilil) lil)))
  85.           (setq lil (append pre (list (list (car (car ilil)) (car (cadr ilil)))) mid (list (list (cadr (car ilil)) (cadr (cadr ilil)))) suf))
  86.           (setq pre nil mid nil suf nil)
  87.           (setq ilil nil k -1)
  88.         )
  89.       )
  90.     )
  91.     (mapcar (function car) lil)
  92.   )
  93.  
  94.   (prompt "\nSelect points, blocks or circles...")
  95.   (if (setq ss (ssget '((0 . "POINT,INSERT,CIRCLE"))))
  96.     (progn
  97.       (repeat (setq i (sslength ss))
  98.         (setq pl (cons (mapcar (function +) '(0 0) (cdr (assoc 10 (entget (ssname ss (setq i (1- i))))))) pl))
  99.       )
  100.       (setq ti (car (_vl-times)))
  101.       (setq l pl)
  102.       (setq lw (greedy pl))
  103.       (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (setq lwx (entget lw)))))
  104.       (setq pll (cons pl pll))
  105.       (generic lwx)
  106.       (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (setq lwx (entget lw)))))
  107.       (entdel lw)
  108.       (setq pl (chkinters pl))
  109.       (setq pll (cons pl pll))
  110.       (generic (entget (chulllw1 l 1)))
  111.       (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget (entlast)))))
  112.       (entdel (entlast))
  113.       (setq pl (chkinters pl))
  114.       (setq pll (cons pl pll))
  115.       (generic (entget (chulllw1 l 2)))
  116.       (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget (entlast)))))
  117.       (entdel (entlast))
  118.       (setq pl (chkinters pl))
  119.       (setq pll (cons pl pll))
  120.       (generic (entget (chulllw2 l 1)))
  121.       (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget (entlast)))))
  122.       (entdel (entlast))
  123.       (setq pl (chkinters pl))
  124.       (setq pll (cons pl pll))
  125.       (generic (entget (chulllw2 l 2)))
  126.       (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget (entlast)))))
  127.       (entdel (entlast))
  128.       (setq pl (chkinters pl))
  129.       (setq pll (cons pl pll))
  130.       (TSP-chlh_jd l 1)
  131.       (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget (entlast)))))
  132.       (entdel (entlast))
  133. ...
  134.  
TheSwamp.org (serving the CAD community since 2003)
Member location map - Add yourself

Donate to TheSwamp.org

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #152 on: July 02, 2020, 12:45:16 PM »
Just to reply from my perspective... I am also not so called lisp genius - it takes lots of practice to change style and way you code... Someone is born with that talent, someone not... MP is one fine example of person that has abilities of lisping made to perfection... I am just simple guy that tries to help in the way God has blessed me... As for the code, yes it can always be better written, but I tried to keep as much as possible exactly the same written material as original authors left us... That's why (foo) (f1) (det)... If you have some better remarks in the way posted routine works - functions it would be perfect to make those things implemented... It's just that TSP is way too complex programming challenge and it simply isn't easy to cobble together all needed components that can make it fast/correct in the way it should be expected... There is even no way to test for correctness of results - it's all wild guessing unless you choose simple task (cca. 10 points at maximum) and use checking by all possibilities for order the points that form closed path... Now, please don't avoid to reply on my previous observation about sub function that is used... Actually I even don't care too much how the code looks, someone can always make cosmetic changes... To me it's much more important how it works and what could be better in that manner... And yes, it looks that there are more material than needed, but in fact every sub is used in the code - there is no unused functions - it all works together and only combined it makes completeness...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #153 on: July 02, 2020, 06:17:40 PM »
I totally discarded checking of angles and let it process all points in list by triplets of points... Also I used (while) as with (foreach) list is not updating during calculations inside sub... I know that this is now slower then it was and perhaps it gives the same results, but in fact it's better coded - more reliable in terms of what it is doing... Also all subs are needed except newly added (ang) and (f2) that are looking for angles, but I leaved them as there are some comments related to them... So nothing is removed only added and commented those things that aren't necessity... In attachment is my mod. version that I use now...

M.R.

[EDIT : I've replaced 2 subs from chlh_jd's codes with newer more obvious versions that are shorter... But still chlh_jd's subs are faster by my testings, so I just added them for comparison reasons and leaved active chlh_jd's and my versions deactivated... There were 3 downloads till now...]
« Last Edit: July 06, 2020, 06:21:00 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #154 on: July 04, 2020, 01:38:14 PM »
From fast routines to implementation of depth permutation parameter...
So your remark (John) is that it is slow...
Well, it can always be slower, lol...

But in fact, I am satisfied now with this depth version... It should yield the same results as previous with depth=3, but if you put a little higher (for ex. 6), IMO it will be very close to exact solution, no matter how long does it take to finish...
I've tested on my tricky example with 11 points and it did correct at about 40 seconds with my PC - this is still faster than doing full permutations... In routine I hard coded - preferable number 3, but maybe it's actually 6, if you have more time...

Regards, M.R.
« Last Edit: July 10, 2020, 02:03:07 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #155 on: July 05, 2020, 01:36:18 AM »
shorthpath.vlx results beaten by TSP.lsp at about 300 sec...
TSP.lsp results beaten by TSP-depth.lsp at about 5.5 hours...

http://www.theswamp.org/index.php?topic=30434.msg591042#msg591042
This results were beaten...

« Last Edit: July 10, 2020, 08:43:31 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #156 on: July 10, 2020, 02:22:58 AM »
I've reattached TSP-depth.lsp as I improved timings... There is little changes, but there are some and I had to give up of some previous calculations to gain more speed... If you find TSP interesting to you too, then recheck your tasks - it passed all mine very well - not exact solutions as previous were, but that one that was different also yield shortest length as in my example there could be multiple solutions with shortest path...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #157 on: August 01, 2020, 11:06:27 AM »
This is how story continues...
While testing TSP-depth.lsp through AutoCAD and BricsCAD, I noticed that on one example in BricsCAD, routine caused lag... So I retested it and it was the same... At first glance I thought it was something with BricsCAD, so I left it there and switched to AutoCAD testings... I wander how anyone haven't noticed this issue and report this bug... So there it was all the time routine had lacks and now I dedicated little of my time to debugg it... Everything was correct except (chulllw2) sub function... Nevertheless as I didn't know where the issue was, I remedy and some other things I found... I figured what is the point not to fix it for both ACAD and BCAD when BCAD is faster and is IMHO the best choice for performing this task - TSP solution, so there it was, I had to debugg it under BCAD... So finally I haven't retested it under BricsCAD - that DWG I posted last, but I believe that it would be way under 4-5 hours... It was my pleasure to have sub functions from master Evgeniy, Lee and chlh_jd and make this version that satisfies my needs and I believe and needs of many others...
Thanks for your attention and suggestions I recieved from many that participated and gave cntributions to this challenging topic...
Regards, M.R.
Attahched - my latest debugged version that should work well for both ACAD and BCAD...
« Last Edit: August 02, 2020, 05:40:24 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #158 on: August 04, 2020, 11:09:19 AM »
Just to inform and post files...
I've beaten my record both in time and result under BricsCAD - previously timings 97 min. With latest revision now time is around 15 min... Result is shown in *.png and *.dwg...
Important note - now preferable depth is 8 (hard coded 3)...
We'll see if someone can beat now this...
Regards, M.R.

[EDIT : TSP-depth-fast.lsp removed as there were no interest for downloading... There were only 2 downloads till now...]
« Last Edit: August 06, 2020, 03:16:22 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #159 on: August 08, 2020, 09:15:37 AM »
This result was improved too...
My latest code produced most right example in white...
Though, because of this, I had to slower my fast version from 10 min with previous example to about 27 min...
All I do with this codes is heuristic attempts to combine best solution results in one single routine... So actually there is no real logic behind this - logic is behind every portion, but general solution don't exist IMHO...
« Last Edit: August 09, 2020, 11:26:32 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #160 on: September 30, 2020, 01:22:45 AM »
Here is the fastest algorithm I know till now... It gives wrong results, but it strives to get as much good as it's possible for the time it draws path... On my slow PC - it took less than 10 min. for 1000 points... Try it and you'll see benefits from it...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:tsp-li ( / *error* makeli mindist-eea-MR car-sort chkinters pea ss ti i pl len loop li li1 li2 lil el s lwl enx lwx )
  2.  
  3.   (defun *error* ( m )
  4.     (if pea
  5.       (setvar 'peditaccept pea)
  6.     )
  7.     (if m
  8.       (prompt m)
  9.     )
  10.     (princ)
  11.   )
  12.  
  13.   (defun makeli ( a b )
  14.     (entmakex (list '(0 . "LINE") (cons 10 a) (cons 11 b)))
  15.   )
  16.  
  17.   (defun mindist-eea-MR ( l / f d q )
  18.    
  19.     (defun f ( p l / di )
  20.       (while l
  21.         (if (equal p (car l) (+ d 1e-8))
  22.           (cond ( (= (setq di (distance p (car l))) d) (setq q (list p (car l))) )
  23.                 ( (< di d)
  24.                   (setq d di
  25.                         q (list p (car l))
  26.                   )
  27.                 )
  28.           )
  29.         )
  30.         (setq l (cdr l))
  31.       )
  32.     )
  33.  
  34.     (setq d (distance (car l) (cadr l)))
  35.     (foreach a l
  36.       (f a (cdr l))
  37.       (setq l (cdr l))
  38.     )
  39.     q
  40.   )
  41.  
  42.   (defun car-sort ( lst cmp / rtn )
  43.     (setq rtn (car lst))
  44.     (foreach itm (cdr lst)
  45.       (if (apply cmp (list itm rtn))
  46.         (setq rtn itm)
  47.       )
  48.     )
  49.     rtn
  50.   )
  51.  
  52.   (defun chkinters ( pl / lil k a ilil pre mid suf )
  53.     (setq lil (mapcar (function list) pl (append (cdr pl) (list (car pl)))))
  54.     (setq k -1)
  55.     (while (and (< (setq k (1+ k)) (length lil)) (setq a (nth k lil)))
  56.       (setq ilil (vl-some (function (lambda ( b / ip ) (setq ip (inters (car a) (cadr a) (car b) (cadr b))) (if (and ip (setq ip (mapcar (function +) '(0 0) ip)) (or (and (or (equal ip (car a) 1e-6) (equal ip (cadr a) 1e-6)) (not (equal ip (car b) 1e-6)) (not (equal ip (cadr b) 1e-6))) (and (or (equal ip (car b) 1e-6) (equal ip (cadr b) 1e-6)) (not (equal ip (car a) 1e-6)) (not (equal ip (cadr a) 1e-6))) (and (not (equal ip (car a) 1e-6)) (not (equal ip (cadr a) 1e-6)) (not (equal ip (car b) 1e-6)) (not (equal ip (cadr b) 1e-6))))) (list a b)))) (vl-remove a lil)))
  57.       (if ilil
  58.         (progn
  59.           (setq pre (reverse (cdr (member (car ilil) (reverse lil)))))
  60.           (setq mid (cdr (member (car ilil) lil)))
  61.           (setq mid (cdr (member (cadr ilil) (reverse mid))))
  62.           (setq mid (mapcar (function reverse) mid))
  63.           (setq suf (cdr (member (cadr ilil) lil)))
  64.           (setq lil (append pre (list (list (car (car ilil)) (car (cadr ilil)))) mid (list (list (cadr (car ilil)) (cadr (cadr ilil)))) suf))
  65.           (setq pre nil mid nil suf nil)
  66.           (setq ilil nil k -1)
  67.         )
  68.       )
  69.     )
  70.     (mapcar (function car) lil)
  71.   )
  72.  
  73.   (vl-cmdf "_.UNDO" "_BE")
  74.   (setq pea (getvar 'peditaccept))
  75.   (setvar 'peditaccept 1)
  76.   (if (setq ss (ssget '((0 . "POINT,CIRCLE,INSERT"))))
  77.     (progn
  78.       (setq ti (car (_vl-times)))
  79.       (repeat (setq i (sslength ss))
  80.         (setq pl (cons (mapcar (function +) '(0 0) (cdr (assoc 10 (entget (ssname ss (setq i (1- i))))))) pl))
  81.       )
  82.       (setq pl (vl-sort pl (function (lambda ( a b ) (if (= (car a) (car b)) (< (cadr a) (cadr b)) (< (car a) (car b)))))))
  83.       (setq len (length pl))
  84.       (setq loop t)
  85.       (while loop
  86.         (if (and (car pl) (null (cadr pl)))
  87.           (setq pl (cons (car pl) (vl-remove (car pl) (vl-remove-if (function (lambda ( x ) (= (length (vl-remove x (apply (function append) lil))) (- (length (apply (function append) lil)) 2)))) (apply (function append) lil)))))
  88.           (setq li (mindist-eea-MR pl))
  89.         )
  90.         (if (not (vl-position li lil))
  91.           (setq lil (cons li lil))
  92.         )
  93.         (if (not (or (equal li pl 1e-6) (equal li (reverse pl) 1e-6)))
  94.           (progn
  95.             (if (vl-position (car li) (cdr (member (car li) (apply (function append) lil))))
  96.               (setq pl (vl-remove (car li) pl))
  97.             )
  98.             (if (vl-position (cadr li) (cdr (member (cadr li) (apply (function append) lil))))
  99.               (setq pl (vl-remove (cadr li) pl))
  100.             )
  101.             (if (and (vl-position (car li) pl) (vl-position (cadr li) pl))
  102.               (setq pl (vl-remove (cadr li) pl))
  103.             )
  104.           )
  105.           (if (/= len (length lil))
  106.             (setq pl (vl-remove-if (function (lambda ( x ) (= (length (vl-remove x (apply (function append) lil))) (- (length (apply (function append) lil)) 2)))) (apply (function append) lil)))
  107.           )
  108.         )
  109.         (setq el (entlast))
  110.         (setq s (ssadd))
  111.         (foreach li lil
  112.           (ssadd (makeli (car li) (cadr li)) s)
  113.         )
  114.         (vl-cmdf "_.PEDIT" "_M" s "" "_J")
  115.         (while (< 0 (getvar 'cmdactive))
  116.           (vl-cmdf "")
  117.         )
  118.         (if (/= (cdr (assoc 90 (entget (entlast)))) len)
  119.           (while (setq el (entnext el))
  120.             (setq lwl (cons el lwl))
  121.           )
  122.           (setq loop nil)
  123.         )
  124.         (if (vl-some (function (lambda ( x ) (= (logand 1 (cdr (assoc 70 (entget x)))) 1))) lwl)
  125.           (progn
  126.             (if (not (vl-position (car li) pl))
  127.               (setq pl (cons (car li) pl))
  128.             )
  129.             (if (not (vl-position (cadr li) pl))
  130.               (setq pl (cons (cadr li) pl))
  131.             )
  132.             (setq pl (vl-remove (if (> (distance (car li) (car-sort (vl-remove (car li) pl) (function (lambda ( a b ) (< (distance (car li) a) (distance (car li) b)))))) (distance (cadr li) (car-sort (vl-remove (cadr li) pl) (function (lambda ( a b ) (< (distance (cadr li) a) (distance (cadr li) b))))))) (car li) (cadr li)) pl))
  133.             (setq lil (cdr lil))
  134.           )
  135.         )
  136.         (if lwl
  137.           (mapcar (function entdel) lwl)
  138.         )
  139.         (setq lwl nil)
  140.       )
  141.       (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (setq enx (entget (entlast))))))
  142.       (setq pl (chkinters pl))
  143.       (setq lwx (append (reverse (cdr (member (assoc 10 enx) (reverse enx)))) (mapcar (function (lambda ( x ) (cons 10 x))) pl) '((210 0.0 0.0 1.0))))
  144.       (entupd (cdr (assoc -1 (entmod (subst (cons 70 (1+ (* 128 (getvar 'plinegen)))) (assoc 70 lwx) lwx)))))
  145.       (prompt "\nDistance : ") (princ (rtos (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pl (append (cdr pl) (list (car pl))))) 2 20))
  146.       (prompt "\nElapsed time : ") (princ (rtos (- (car (_vl-times)) ti) 2 20)) (prompt " milliseconds...")
  147.     )
  148.   )
  149.   (*error* nil)
  150. )
  151.  

HTH. M.R.
« Last Edit: October 03, 2020, 07:11:46 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #161 on: October 01, 2020, 09:27:08 AM »
What is ubeliveable is that I can swear I used the same code I posted above once in ACAD and once in BCAD and as a result I did get 2 different length lwpolylines - paths... So I don't know what's the trick, I even used "all" option for selecting points - everything was done identically... Maybe you'll get third result, who knows??? In attachment are 2 my DWG files...

[EDIT : It seems that now everything is like it's expected - both *.DWG are equal... The problem was sorting points prior routine calculations - so I added this line - look in my previous code...]

Code - Auto/Visual Lisp: [Select]
  1. (setq pl (vl-sort pl (function (lambda ( a b ) (if (= (car a) (car b)) (< (cadr a) (cadr b)) (< (car a) (car b)))))))
  2.  
« Last Edit: October 03, 2020, 07:11:13 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #162 on: October 02, 2020, 09:52:25 AM »
I think there is more logical variant, but it gives worse (untested...) results than previous code...

Code - Auto/Visual Lisp: [Select]
  1. ...
  2.         (if (not (or (equal li pl 1e-6) (equal li (reverse pl) 1e-6)))
  3.           (progn
  4.             (if (vl-position (car li) (cdr (member (car li) (apply (function append) lil))))
  5.               (setq pl (vl-remove (car li) pl))
  6.             )
  7.             (if (vl-position (cadr li) (cdr (member (cadr li) (apply (function append) lil))))
  8.               (setq pl (vl-remove (cadr li) pl))
  9.             )
  10.             (if (and (vl-position (car li) pl) (vl-position (cadr li) pl))
  11.               (progn
  12.                 (setq li1 (list (car li) (car-sort (vl-remove (car li) pl) (function (lambda ( a b ) (< (distance (car li) a) (distance (car li) b)))))))
  13.                 (setq li2 (list (cadr li) (car-sort (vl-remove (cadr li) pl) (function (lambda ( a b ) (< (distance (cadr li) a) (distance (cadr li) b)))))))
  14.                 (cond
  15.                   ( (and (or (not (equal li1 li 1e-6)) (not (equal li1 (reverse li) 1e-6))) (or (not (equal li2 li 1e-6)) (not (equal li2 (reverse li) 1e-6))) (< (distance (car li1) (cadr li1)) (distance (car li2) (cadr li2))))
  16.                     (setq pl (vl-remove (cadr li) pl))
  17.                   )
  18.                   ( (and (or (not (equal li1 li 1e-6)) (not (equal li1 (reverse li) 1e-6))) (or (not (equal li2 li 1e-6)) (not (equal li2 (reverse li) 1e-6))) (> (distance (car li1) (cadr li1)) (distance (car li2) (cadr li2))))
  19.                     (setq pl (vl-remove (car li) pl))
  20.                   )
  21.                   ( (and (or (not (equal li1 li 1e-6)) (not (equal li1 (reverse li) 1e-6))) (or (equal li2 li 1e-6) (equal li2 (reverse li) 1e-6)) (< (distance (car li1) (cadr li1)) (distance (car li2) (cadr li2))))
  22.                     (setq pl (vl-remove (cadr li) pl))
  23.                   )
  24.                   ( (and (or (not (equal li1 li 1e-6)) (not (equal li1 (reverse li) 1e-6))) (or (equal li2 li 1e-6) (equal li2 (reverse li) 1e-6)) (> (distance (car li1) (cadr li1)) (distance (car li2) (cadr li2))))
  25.                     (setq pl (vl-remove (car li) pl))
  26.                   )
  27.                   ( (and (or (equal li1 li 1e-6) (equal li1 (reverse li) 1e-6)) (or (not (equal li2 li 1e-6)) (not (equal li2 (reverse li) 1e-6))) (< (distance (car li1) (cadr li1)) (distance (car li2) (cadr li2))))
  28.                     (setq pl (vl-remove (cadr li) pl))
  29.                   )
  30.                   ( (and (or (equal li1 li 1e-6) (equal li1 (reverse li) 1e-6)) (or (not (equal li2 li 1e-6)) (not (equal li2 (reverse li) 1e-6))) (> (distance (car li1) (cadr li1)) (distance (car li2) (cadr li2))))
  31.                     (setq pl (vl-remove (car li) pl))
  32.                   )
  33.                   ( t
  34.                     (setq li1 (list (car li) (car-sort (vl-remove (car li) (vl-remove (cadr li) pl)) (function (lambda ( a b ) (< (distance (car li) a) (distance (car li) b)))))))
  35.                     (setq li2 (list (cadr li) (car-sort (vl-remove (car li) (vl-remove (cadr li) pl)) (function (lambda ( a b ) (< (distance (cadr li) a) (distance (cadr li) b)))))))
  36.                     (if (< (distance (car li1) (cadr li1)) (distance (car li2) (cadr li2)))
  37.                       (setq pl (vl-remove (cadr li) pl))
  38.                       (setq pl (vl-remove (car li) pl))
  39.                     )
  40.                   )
  41.                 )
  42.               )
  43.             )
  44.           )
  45.           (if (/= len (length lil))
  46.             (setq pl (vl-remove-if (function (lambda ( x ) (= (length (vl-remove x (apply (function append) lil))) (- (length (apply (function append) lil)) 2)))) (apply (function append) lil)))
  47.           )
  48.         )
  49. ...
  50.  
« Last Edit: October 02, 2020, 12:32:20 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #163 on: October 04, 2020, 12:54:56 AM »
Quickest on small amount of points... And as my tests prove, it tends toward smallest area of closed path, although intention was distance... This is my prettiest code I managed - it's short, but very thoughtful and powerful especially in usage of (car-sort) sub...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:tsp-expand ( / mindist-eea-MR car-sort chkinters insbtwli unique ss ti i pl pll lil li lii )
  2.  
  3.   (defun mindist-eea-MR ( l / f d q )
  4.    
  5.     (defun f ( p l / di )
  6.       (while l
  7.         (if (equal p (car l) (+ d 1e-8))
  8.           (cond ( (= (setq di (distance p (car l))) d) (setq q (list p (car l))) )
  9.                 ( (< di d)
  10.                   (setq d di
  11.                         q (list p (car l))
  12.                   )
  13.                 )
  14.           )
  15.         )
  16.         (setq l (cdr l))
  17.       )
  18.     )
  19.  
  20.     (setq d (distance (car l) (cadr l)))
  21.     (foreach a l
  22.       (f a (cdr l))
  23.       (setq l (cdr l))
  24.     )
  25.     q
  26.   )
  27.  
  28.   (defun car-sort ( lst cmp / rtn )
  29.     (setq rtn (car lst))
  30.     (foreach itm (cdr lst)
  31.       (if (apply cmp (list itm rtn))
  32.         (setq rtn itm)
  33.       )
  34.     )
  35.     rtn
  36.   )
  37.  
  38.   (defun chkinters ( pl / lil k a ilil pre mid suf )
  39.     (setq lil (mapcar (function list) pl (append (cdr pl) (list (car pl)))))
  40.     (setq k -1)
  41.     (while (and (< (setq k (1+ k)) (length lil)) (setq a (nth k lil)))
  42.       (setq ilil (vl-some (function (lambda ( b / ip ) (setq ip (inters (car a) (cadr a) (car b) (cadr b))) (if (and ip (setq ip (mapcar (function +) '(0 0) ip)) (or (and (or (equal ip (car a) 1e-6) (equal ip (cadr a) 1e-6)) (not (equal ip (car b) 1e-6)) (not (equal ip (cadr b) 1e-6))) (and (or (equal ip (car b) 1e-6) (equal ip (cadr b) 1e-6)) (not (equal ip (car a) 1e-6)) (not (equal ip (cadr a) 1e-6))) (and (not (equal ip (car a) 1e-6)) (not (equal ip (cadr a) 1e-6)) (not (equal ip (car b) 1e-6)) (not (equal ip (cadr b) 1e-6))))) (list a b)))) (vl-remove a lil)))
  43.       (if ilil
  44.         (progn
  45.           (setq pre (reverse (cdr (member (car ilil) (reverse lil)))))
  46.           (setq mid (cdr (member (car ilil) lil)))
  47.           (setq mid (cdr (member (cadr ilil) (reverse mid))))
  48.           (setq mid (mapcar (function reverse) mid))
  49.           (setq suf (cdr (member (cadr ilil) lil)))
  50.           (setq lil (append pre (list (list (car (car ilil)) (car (cadr ilil)))) mid (list (list (cadr (car ilil)) (cadr (cadr ilil)))) suf))
  51.           (setq pre nil mid nil suf nil)
  52.           (setq ilil nil k -1)
  53.         )
  54.       )
  55.     )
  56.     (mapcar (function car) lil)
  57.   )
  58.  
  59.   (defun insbtwli ( p1 p2 pl )
  60.     (car-sort (vl-remove p1 (vl-remove p2 pl)) (function (lambda ( a b ) (< (+ (distance p1 a) (distance p2 a)) (+ (distance p1 b) (distance p2 b))))))
  61.   )
  62.  
  63.   (defun unique ( l )
  64.     (if l (cons (car l) (unique (vl-remove (car l) l))))
  65.   )
  66.  
  67.   (if (setq ss (ssget '((0 . "POINT,CIRCLE,INSERT"))))
  68.     (progn
  69.       (setq ti (car (_vl-times)))
  70.       (repeat (setq i (sslength ss))
  71.         (setq pl (cons (mapcar (function +) '(0 0) (cdr (assoc 10 (entget (ssname ss (setq i (1- i))))))) pl))
  72.       )
  73.       (setq pll (mindist-eea-MR pl))
  74.       (setq pll (list (car pll) (insbtwli (car pll) (cadr pll) pl) (cadr pll)))
  75.       (setq pl (vl-remove-if (function (lambda ( x ) (vl-position x pll))) pl))
  76.       (while pl
  77.         (setq lil (mapcar (function (lambda ( a b ) (list a b))) pll (append (cdr pll) (list (car pll)))))
  78.         (setq li (car-sort lil (function (lambda ( a b / p1 p2 ) (< (+ (distance (car a) (setq p1 (insbtwli (car a) (cadr a) pl))) (distance (cadr a) p1)) (+ (distance (car b) (setq p2 (insbtwli (car b) (cadr b) pl))) (distance (cadr b) p2)))))))
  79.         (setq lii (list (car li) (insbtwli (car li) (cadr li) pl) (cadr li)))
  80.         (setq lil (subst lii li lil))
  81.         (setq pll (unique (apply (function append) lil)))
  82.         (setq pl (vl-remove-if (function (lambda ( x ) (vl-position x pll))) pl))
  83.       )
  84.       (setq pll (chkinters pll))
  85.       (entmake
  86.         (append
  87.           (list
  88.             '(0 . "LWPOLYLINE")
  89.             '(100 . "AcDbEntity")
  90.             '(100 . "AcDbPolyline")
  91.             (cons 90 (length pll))
  92.             (cons 70 (1+ (* 128 (getvar 'plinegen))))
  93.             '(38 . 0.0)
  94.           )
  95.           (mapcar (function (lambda ( x ) (cons 10 x))) pll)
  96.           '((210 0.0 0.0 1.0))
  97.         )
  98.       )
  99.       (prompt "\nDistance : ") (princ (rtos (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pll (append (cdr pll) (list (car pll))))) 2 20))
  100.       (prompt "\nElapsed time : ") (princ (rtos (- (car (_vl-times)) ti) 2 20)) (prompt " milliseconds...")
  101.     )
  102.   )
  103.   (princ)
  104. )
  105.  

M.R.
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube