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

0 Members and 2 Guests are viewing this topic.

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #105 on: November 02, 2018, 01:02:37 PM »
One variant of TSP - start/end point is known...

http://www.theswamp.org/index.php?topic=54636.0
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 #106 on: November 05, 2018, 11:57:33 AM »
Here is my greedy version...

And here are results :

RAND10 :
Distance : 39.57484137324679
Elapsed time : 0.031 seconds.

RAND100 :
Distance : 1948.071162589293
Elapsed time : 1.983999999999999 seconds.

RAND1000 :
Distance : 85218.62326581254
Elapsed time : 990.4059999999999 seconds.

Code - Auto/Visual Lisp: [Select]
  1. (defun c:TSP-MR ( / car-sort nextpt pathbynextshortdst sortpl ss i pl ti rtn d )
  2.  
  3.   ;;; (car-sort '(2 4 1 3 5 1) '<) => nil
  4.   ;;; (car-sort '(2 4 1 3 5 1) '<=) => 1
  5.   (defun car-sort ( l f / removenth r k )
  6.  
  7.     (defun removenth ( l n / k )
  8.       (setq k -1)
  9.       (vl-remove-if (function (lambda ( x ) (= (setq k (1+ k)) n))) l)
  10.     )
  11.  
  12.     (setq k -1)
  13.     (vl-some (function (lambda ( a ) (setq k (1+ k)) (if (vl-every (function (lambda ( x ) (apply f (list a x)))) (removenth l k)) (setq r a)))) l)
  14.     r
  15.   )
  16.  
  17.   (defun nextpt ( p l ) ; p - point ; l - list of points without point p
  18.     (car-sort l (function (lambda ( a b ) (<= (distance a p) (distance b p)))))
  19.   )
  20.  
  21.   (defun pathbynextshortdst ( l / p pl pp ) ; l - list of points to sort by starting point (car l)
  22.     (while (setq p (car l))
  23.       (setq pl (cons p pl))
  24.       (setq l (vl-remove p l))
  25.       (if (car l)
  26.         (setq l (cons (setq pp (nextpt p l)) (vl-remove pp l)))
  27.       )
  28.     )
  29.     (reverse pl)
  30.   )
  31.  
  32.   (defun sortpl ( l / pdl pl1 pl2 d1 d2 ) ; l - list of points to sort by shortest next distances
  33.     (foreach p l
  34.       (setq pdl (cons (cons (distance p (nextpt p (vl-remove p l))) p) pdl))
  35.     )
  36.     (setq pdl (vl-sort pdl (function (lambda ( a b ) (< (car a) (car b))))))
  37.     (setq pl1 (pathbynextshortdst (cons (cdar pdl) (vl-remove (cdar pdl) pl))))
  38.     (setq pl2 (pathbynextshortdst (cons (cdadr pdl) (vl-remove (cdadr pdl) pl))))
  39.     (setq d1 (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pl1 (append (cdr pl1) (list (car pl1))))))
  40.     (setq d2 (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pl2 (append (cdr pl2) (list (car pl2))))))
  41.     (if (< d1 d2)
  42.       (list pl1 d1)
  43.       (list pl2 d2)
  44.     )
  45.   )
  46.  
  47.   (setq ss (ssget '((0 . "POINT"))))
  48.   (repeat (setq i (sslength ss))
  49.     (setq pl (cons (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) pl))
  50.   )
  51.   (setq ti (car (_vl-times)))
  52.   (setq rtn (sortpl pl))
  53.   (setq pl (car rtn))
  54.   (setq d (cadr rtn))
  55.   (vl-cmdf "_.3DPOLY")
  56.   (foreach p pl
  57.     (vl-cmdf "_non" (trans p 0 1))
  58.   )
  59.   (vl-cmdf "_C")
  60.   (prompt "\nDistance : ") (princ (rtos d 2 50))
  61.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds.")
  62.   (princ)
  63. )
  64.  

BTW. How did you do it for 10000 pts? It seems that with LISP it takes forever...
P.S. I attached DWG with 1000 pts...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

It's Alive!

  • Retired
  • Needs a day job
  • Posts: 8659
  • AKA Daniel
Re: (Challenge) To draw the shortest lwpolyline
« Reply #107 on: November 05, 2018, 11:10:45 PM »
>>BTW. How did you do it for 10000 pts?
Length = 84593.961921, time = 6.203176ms
I used a kd-tree,  https://github.com/jlblancoc/nanoflann

Once I start adding stuff, its starts taking more time.

edit: blue is mine, if you want to compare

It's Alive!

  • Retired
  • Needs a day job
  • Posts: 8659
  • AKA Daniel
Re: (Challenge) To draw the shortest lwpolyline
« Reply #108 on: November 06, 2018, 05:06:56 AM »
here is my source, and a build for ac2019

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #109 on: November 07, 2018, 11:44:04 AM »
Another variant of greedy... It was created under impression of @handasa's request - search for path between start/end points... So 2 point lists are finally appended to create main sorted point list... Now it seems just a little faster and code is even shorter...

Results :
RAND10 :
Distance : 43.03222468732679
Elapsed time : 0.031 seconds.

RAND100 :
Distance : 1985.343456459591
Elapsed time : 1.780999999999999 seconds.

RAND1000 :
Distance : 83530.26850483351
Elapsed time : 914.953 seconds.

Code - Auto/Visual Lisp: [Select]
  1. (defun c:TSP-MR ( / car-sort nextpt ss i pl ti pdl pl1 pl2 p1 p2 d1 d2 d )
  2.  
  3.   ;;; (car-sort '(2 4 1 3 5 1) '<) => nil
  4.   ;;; (car-sort '(2 4 1 3 5 1) '<=) => 1
  5.   (defun car-sort ( l f / removenth r k )
  6.  
  7.     (defun removenth ( l n / k )
  8.       (setq k -1)
  9.       (vl-remove-if (function (lambda ( x ) (= (setq k (1+ k)) n))) l)
  10.     )
  11.  
  12.     (setq k -1)
  13.     (vl-some (function (lambda ( a ) (setq k (1+ k)) (if (vl-every (function (lambda ( x ) (apply f (list a x)))) (removenth l k)) (setq r a)))) l)
  14.     r
  15.   )
  16.  
  17.   (defun nextpt ( p l ) ; p - point ; l - list of points without point p
  18.     (car-sort l (function (lambda ( a b ) (<= (distance a p) (distance b p)))))
  19.   )
  20.  
  21.   (setq ss (ssget '((0 . "POINT"))))
  22.   (repeat (setq i (sslength ss))
  23.     (setq pl (cons (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) pl))
  24.   )
  25.   (setq ti (car (_vl-times)))
  26.   (foreach p pl
  27.     (setq pdl (cons (cons (distance p (nextpt p (vl-remove p pl))) p) pdl))
  28.   )
  29.   (setq pdl (vl-sort pdl (function (lambda ( a b ) (< (car a) (car b))))))
  30.   (setq pl1 (cons (cdar pdl) pl1))
  31.   (setq pl2 (cons (cdadr pdl) pl2))
  32.   (setq pl (vl-remove (car pl1) pl) pl (vl-remove (car pl2) pl))
  33.   (while pl
  34.     (setq p1 (nextpt (car pl1) pl))
  35.     (setq p2 (nextpt (car pl2) pl))
  36.     (setq d1 (distance (car pl1) p1))
  37.     (setq d2 (distance (car pl2) p2))
  38.     (if (< d1 d2)
  39.       (setq pl1 (cons p1 pl1) pl (vl-remove p1 pl))
  40.       (setq pl2 (cons p2 pl2) pl (vl-remove p2 pl))
  41.     )
  42.   )
  43.   (setq pl (append (reverse pl1) pl2))
  44.   (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pl (append (cdr pl) (list (car pl))))))
  45.   (vl-cmdf "_.3DPOLY")
  46.   (foreach p pl
  47.     (vl-cmdf "_non" (trans p 0 1))
  48.   )
  49.   (vl-cmdf "_C")
  50.   (prompt "\nDistance : ") (princ (rtos d 2 50))
  51.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds.")
  52.   (princ)
  53. )
  54.  

In attachment is RAND100-MR-2.DWG...
P.S. I didn't looked your version, Daniel, but I think that now my is better for 1000 pts...

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

:)

M.R. on Youtube

It's Alive!

  • Retired
  • Needs a day job
  • Posts: 8659
  • AKA Daniel
Re: (Challenge) To draw the shortest lwpolyline
« Reply #110 on: November 09, 2018, 06:37:20 AM »
new try, times are jumping

rand10 = Length = 38.870136, time in seconds = 0.000913
rand100 = Length = 1888.492776, time in seconds = 0.016582
rand1000 = Length = 82430.569174, time in seconds = 2.645039
rand10000 = Length = 3707449.504854, time in seconds = 3.827995, was 3731327.006039

arx command is 'doit '

edit: changed, the larger the set, the less optimal, otherwise times shoot through the roof lol
« Last Edit: November 09, 2018, 09:21:35 AM by nullptr »

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #111 on: December 06, 2018, 11:06:02 AM »
Back to original task, not to look like I hijacked topic... My version, although too slow, but it's more generic and applicable to both lst-a and lst-b, as also with chlh_jd's DWG, and there is also my test DWG for which my version yields best result from all codes - I don't know, but I can't apply Lee's version correctly - it gives me ConvexHull - don't have time right now, but that's how it turns out on my PC... My version uses Lee's ConvexHull sub that I modified to suit my version better and it's used as starting point, then point list is calculated as concave inward collapsing of ConvexHull... Here is the code and examples used in this topic in attachment...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:TSP-2D-MR ( / LM:ConvexHull-ptsonHull LM:Clockwise-p ss ti i pl pln dmin k plp pld pll d r pp )
  2.  
  3.   ;; Convex Hull  -  Lee Mac
  4.   ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
  5.  
  6.   (defun LM:ConvexHull-ptsonHull ( lst / ch p0 lstl )
  7.       (cond
  8.           (   (< (length lst) 4) lst)
  9.           (   (setq p0 (car lst))
  10.               (foreach p1 (cdr lst)
  11.                   (if (or (< (cadr p1) (cadr p0))
  12.                           (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0)))
  13.                       )
  14.                       (setq p0 p1)
  15.                   )
  16.               )
  17.               (setq lst (vl-remove p0 lst))
  18.               (setq lst (append (list p0) lst))
  19.               (setq lst
  20.                   (vl-sort lst
  21.                       (function
  22.                           (lambda ( a b / c d )
  23.                               (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))))
  24.                                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
  25.                                   (< c d)
  26.                               )
  27.                           )
  28.                       )
  29.                   )
  30.               )
  31.               (setq lstl (vl-remove-if-not (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
  32.               (setq lst (vl-remove-if (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
  33.               (setq lstl (vl-sort lstl (function (lambda ( a b ) (> (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))))))
  34.               (setq lst (append lst lstl))
  35.               (setq ch (list (cadr lst) (car lst)))
  36.               (foreach pt (cddr lst)
  37.                   (setq ch (cons pt ch))
  38.                   (while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt))
  39.                       (setq ch (cons pt (cddr ch)))
  40.                   )
  41.               )
  42.               (reverse ch)
  43.           )
  44.       )
  45.   )
  46.  
  47.   ;; Clockwise-p  -  Lee Mac
  48.   ;; Returns T if p1,p2,p3 are clockwise oriented or [s]collinear[/s]
  49.  
  50.   (defun LM:Clockwise-p ( p1 p2 p3 )
  51.       (<  (-  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
  52.               (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
  53.           )
  54.           0.0
  55.       )
  56.   )
  57.  
  58.   (setq ss (ssget '((0 . "POINT"))))
  59.   (repeat (setq i (sslength ss))
  60.     (setq pl (cons (mapcar '+ '(0 0) (cdr (assoc 10 (entget (ssname ss (setq i (1- i))))))) pl))
  61.   )
  62.   (setq ti (car (_vl-times)))
  63.   (setq pln (LM:ConvexHull-ptsonHull pl))
  64.   (foreach p pln
  65.     (setq pl (vl-remove p pl))
  66.   )
  67.   (while pl
  68.     (setq dmin 1e+99)
  69.     (foreach p pl
  70.       (setq k -1)
  71.       (repeat (length pln)
  72.         (setq k (1+ k))
  73.         (setq plp (reverse (cdr (member (nth k pln) (reverse pln)))))
  74.         (setq pls (member (nth k pln) pln))
  75.         (setq pll (append plp (list p) pls))
  76.         (setq d (apply '+ (mapcar '(lambda ( a b ) (distance a b)) pll (append (cdr pll) (list (car pll))))))
  77.         (if (< d dmin)
  78.           (setq dmin d r pll pp p)
  79.         )
  80.       )
  81.     )
  82.     (setq pln r)
  83.     (setq pl (vl-remove pp pl))
  84.   )
  85.     (append
  86.       (list
  87.         '(0 . "LWPOLYLINE")
  88.         '(100 . "AcDbEntity")
  89.         '(100 . "AcDbPolyline")
  90.         (cons 90 (length pln))
  91.         (cons 70 (1+ (* (getvar 'plinegen) 128)))
  92.         '(38 . 0.0)
  93.       )
  94.       (mapcar '(lambda ( x ) (cons 10 x)) pln)
  95.       (list
  96.         '(210 0.0 0.0 1.0)
  97.         '(62 . 1)
  98.       )
  99.     )
  100.   )
  101.   (prompt "\nDistance : ") (princ (rtos dmin 2 50))
  102.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds...")
  103.   (princ)
  104. )
  105.  

Regards, M.R.
« Last Edit: June 19, 2019, 12:43: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 #112 on: December 06, 2018, 11:07:12 AM »
My testing DWG in attachment...

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

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #114 on: December 08, 2018, 07:07:20 AM »
I've changed a little my version... Forgot to sort initial point list at start and little different "plp" and "pls" variables...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:TSP-2D-MR ( / LM:ConvexHull-ptsonHull LM:Clockwise-p ss ti i pl pln dmin k plp pld pll d r pp )
  2.  
  3.   ;; Convex Hull  -  Lee Mac
  4.   ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
  5.  
  6.   (defun LM:ConvexHull-ptsonHull ( lst / ch p0 lstl )
  7.       (cond
  8.           (   (< (length lst) 4) lst)
  9.           (   (setq p0 (car lst))
  10.               (foreach p1 (cdr lst)
  11.                   (if (or (< (cadr p1) (cadr p0))
  12.                           (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0)))
  13.                       )
  14.                       (setq p0 p1)
  15.                   )
  16.               )
  17.               (setq lst (vl-remove p0 lst))
  18.               (setq lst (append (list p0) lst))
  19.               (setq lst
  20.                   (vl-sort lst
  21.                       (function
  22.                           (lambda ( a b / c d )
  23.                               (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))))
  24.                                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
  25.                                   (< c d)
  26.                               )
  27.                           )
  28.                       )
  29.                   )
  30.               )
  31.               (setq lstl (vl-remove-if-not (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
  32.               (setq lst (vl-remove-if (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
  33.               (setq lstl (vl-sort lstl (function (lambda ( a b ) (> (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))))))
  34.               (setq lst (append lst lstl))
  35.               (setq ch (list (cadr lst) (car lst)))
  36.               (foreach pt (cddr lst)
  37.                   (setq ch (cons pt ch))
  38.                   (while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt))
  39.                       (setq ch (cons pt (cddr ch)))
  40.                   )
  41.               )
  42.               (reverse ch)
  43.           )
  44.       )
  45.   )
  46.  
  47.   ;; Clockwise-p  -  Lee Mac
  48.   ;; Returns T if p1,p2,p3 are clockwise oriented or [s]collinear[/s]
  49.  
  50.   (defun LM:Clockwise-p ( p1 p2 p3 )
  51.       (<  (-  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
  52.               (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
  53.           )
  54.           0.0
  55.       )
  56.   )
  57.  
  58.   (setq ss (ssget '((0 . "POINT"))))
  59.   (repeat (setq i (sslength ss))
  60.     (setq pl (cons (mapcar '+ '(0 0) (cdr (assoc 10 (entget (ssname ss (setq i (1- i))))))) pl))
  61.   )
  62.   (setq ti (car (_vl-times)))
  63.   (setq pl (vl-sort pl '(lambda ( a b ) (if (= (cadr a) (cadr b)) (> (car a) (car b)) (> (cadr a) (cadr b))))))
  64.   (setq pln (LM:ConvexHull-ptsonHull pl))
  65.   (foreach p pln
  66.     (setq pl (vl-remove p pl))
  67.   )
  68.   (while pl
  69.     (setq dmin 1e+99)
  70.     (foreach p pl
  71.       (setq k -1)
  72.       (repeat (length pln)
  73.         (setq k (1+ k))
  74.         (setq plp (reverse (member (nth k pln) (reverse pln))))
  75.         (setq pls (cdr (member (nth k pln) pln)))
  76.         (setq pll (append plp (list p) pls))
  77.         (setq d (apply '+ (mapcar '(lambda ( a b ) (distance a b)) pll (append (cdr pll) (list (car pll))))))
  78.         (if (< d dmin)
  79.           (setq dmin d r pll pp p)
  80.         )
  81.       )
  82.     )
  83.     (setq pln r)
  84.     (setq pl (vl-remove pp pl))
  85.   )
  86.     (append
  87.       (list
  88.         '(0 . "LWPOLYLINE")
  89.         '(100 . "AcDbEntity")
  90.         '(100 . "AcDbPolyline")
  91.         (cons 90 (length pln))
  92.         (cons 70 (1+ (* (getvar 'plinegen) 128)))
  93.         '(38 . 0.0)
  94.       )
  95.       (mapcar '(lambda ( x ) (cons 10 x)) pln)
  96.       (list
  97.         '(210 0.0 0.0 1.0)
  98.         '(62 . 1)
  99.       )
  100.     )
  101.   )
  102.   (prompt "\nDistance : ") (princ (rtos dmin 2 50))
  103.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds...")
  104.   (princ)
  105. )
  106.  

P.S. One would thought that with square grid pattern of points, it's only needed to alter Evgeniy's - lst-a sub function, but no...
Neither this - following path in spiral manner is not good :

Code: [Select]
(defun test-lst-a (l / A B BB D E LL P PL AN)
   (setq l (vl-sort l (function (lambda (a b) (if (= (car a) (car b)) (< (cadr a) (cadr b)) (< (car a) (car b))))))) ;_  setq
   (setq p  (car l)
         pl (list p)
         l  (cdr l)
   ) ;_  setq
   (while l
    (setq d (distance p (car l))) ;_  setq
    (foreach a l
     (if (<= (setq e (distance p a)) d)
      (if (and an (or (equal (angle p a) an 1e-6) (equal (angle p a) (rem (+ pi an) (+ pi pi)) 1e-6) (if (or (equal an 0.0 1e-6) (equal an (* 2 pi) 1e-6)) (equal (angle p a) (* 2 pi) 1e-6))))
       (setq bb a
             d e
       ) ;_  setq
       (setq b a
             d e
       ) ;_  setq
      ) ;_  if
     ) ;_  if
    ) ;_  foreach
    (cond
     ((and bb b (<= (distance p bb) (distance p b)))
      (setq b bb) ;_  setq
     )
     ((and bb b)
      (setq bb b) ;_ setq
     )
     (bb
      (setq b bb) ;_  setq
     )
    ) ;_  cond
    (setq pl (cons b pl)
          an (angle p b)
          l  (vl-remove b l)
          p  b
          b  nil
          bb nil
    ) ;_  setq
   ) ;_  while
   (setq pl (reverse pl)) ;_  setq
   (setq e  nil
         l  pl
         ll l
   ) ;_  setq
   (while (and (not e) ll)
    (setq e  t
          ll l
    ) ;_  setq
    (while (and e ll)
     (setq ll (if (listp (caar ll))
               ll
               (mapcar (function list) (cons (last ll) ll) ll)
              ) ;_  if
           a  (car ll)
           pl (vl-remove-if (function (lambda (b) (or (member (car a) b) (member (cadr a) b))))
                            (cdr ll)
              ) ;_  vl-remove-if
           ll (cdr ll)
     ) ;_  setq
     (while (and pl (setq b (car pl)) (not (inters (car a) (cadr a) (car b) (cadr b))))
      (setq pl (cdr pl))
     ) ;_  while
     (if pl
      (progn (setq l (append (member (car a) l) (reverse (cdr (member (car a) (reverse l)))))
                   l (append (list (car a)) (member (car b) (reverse (cdr l))) (member (cadr b) l)) ;;; (car a) (cadr a) + ... + (car b) (cadr b) + ... ->end ;;; => ;;; (car a) + (reversed (car b)->(cadr a)) + (not reversed (cadr b)->end)
                   e nil
             ) ;_  setq
      ) ;_  progn
     ) ;_  if
    ) ;_  while
   ) ;_  while
   (setq e (entmakex (append (list '(0 . "LWPOLYLINE")
                                   '(100 . "AcDbEntity")
                                   '(8 . "temp")
                                   '(62 . 1)
                                   '(100 . "AcDbPolyline")
                                   (cons 90 (length l))
                                   '(70 . 1)
                             ) ;_  list
                             (mapcar (function (lambda (a) (cons 10 a))) l)
                     ) ;_  append
           ) ;_  entmakex
   ) ;_  setq
   (princ (strcat "\nPolyline Length: "
                  (rtos (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)) 2 4)
                  " mm."
          ) ;_  strcat
   ) ;_  princ
   (princ)
  )
(test-lst-a (mapcar '(lambda ( x ) (cdr (assoc 10 (entget x)))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "POINT"))))))))

Neither is good following path by favoring either X or Y axis, so that path goes like snake like Evgeniy's original lst-a is doing because of rectangular grid pattern :

Code: [Select]
(defun test-lst-a (l / A B BB D E LL P PL AN W H)
   (setq l (vl-sort l (function (lambda (a b) (if (= (car a) (car b)) (< (cadr a) (cadr b)) (< (car a) (car b))))))) ;_  setq
   (setq w (- (car (last l)) (car (car l))) h (- (cadr (last l)) (cadr (car l)))) ;_  setq
   (if (< w h)
    (setq an (* 0.5 pi)) ;_  setq
    (setq an 0.0) ;_  setq
   ) ;_  if
   (setq p  (car l)
         pl (list p)
         l  (cdr l)
   ) ;_  setq
   (while l
    (setq d (distance p (car l))) ;_  setq
    (foreach a l
     (if (<= (setq e (distance p a)) d)
      (if (and an (or (equal (angle p a) an 1e-6) (equal (angle p a) (rem (+ pi an) (+ pi pi)) 1e-6) (if (or (equal an 0.0 1e-6) (equal an (* 2 pi) 1e-6)) (equal (angle p a) (* 2 pi) 1e-6))))
       (setq bb a
             d e
       ) ;_  setq
       (setq b a
             d e
       ) ;_  setq
      ) ;_  if
     ) ;_  if
    ) ;_  foreach
    (cond
     ((and bb b (<= (distance p bb) (distance p b)))
      (setq b bb) ;_  setq
     )
     ((and bb b)
      (setq bb b) ;_ setq
     )
     (bb
      (setq b bb) ;_  setq
     )
    ) ;_  cond
    (setq pl (cons b pl)
          l  (vl-remove b l)
          p  b
          b  nil
          bb nil
    ) ;_  setq
   ) ;_  while
   (setq pl (reverse pl)) ;_  setq
   (setq e  nil
         l  pl
         ll l
   ) ;_  setq
   (while (and (not e) ll)
    (setq e  t
          ll l
    ) ;_  setq
    (while (and e ll)
     (setq ll (if (listp (caar ll))
               ll
               (mapcar (function list) (cons (last ll) ll) ll)
              ) ;_  if
           a  (car ll)
           pl (vl-remove-if (function (lambda (b) (or (member (car a) b) (member (cadr a) b))))
                            (cdr ll)
              ) ;_  vl-remove-if
           ll (cdr ll)
     ) ;_  setq
     (while (and pl (setq b (car pl)) (not (inters (car a) (cadr a) (car b) (cadr b))))
      (setq pl (cdr pl))
     ) ;_  while
     (if pl
      (progn (setq l (append (member (car a) l) (reverse (cdr (member (car a) (reverse l)))))
                   l (append (list (car a)) (member (car b) (reverse (cdr l))) (member (cadr b) l)) ;;; (car a) (cadr a) + ... + (car b) (cadr b) + ... ->end ;;; => ;;; (car a) + (reversed (car b)->(cadr a)) + (not reversed (cadr b)->end)
                   e nil
             ) ;_  setq
      ) ;_  progn
     ) ;_  if
    ) ;_  while
   ) ;_  while
   (setq e (entmakex (append (list '(0 . "LWPOLYLINE")
                                   '(100 . "AcDbEntity")
                                   '(8 . "temp")
                                   '(62 . 1)
                                   '(100 . "AcDbPolyline")
                                   (cons 90 (length l))
                                   '(70 . 1)
                             ) ;_  list
                             (mapcar (function (lambda (a) (cons 10 a))) l)
                     ) ;_  append
           ) ;_  entmakex
   ) ;_  setq
   (princ (strcat "\nPolyline Length: "
                  (rtos (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)) 2 4)
                  " mm."
          ) ;_  strcat
   ) ;_  princ
   (princ)
  )
(test-lst-a (mapcar '(lambda ( x ) (cdr (assoc 10 (entget x)))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "POINT"))))))))

AND FINALLY, SOLUTION THAT IS CORRECT AND FAST FOR SQUARE GRID PATTERN DISPOSITION OF POINTS :

Code - Auto/Visual Lisp: [Select]
  1. (defun test-lst-a (l / A B BB D E LL P PL AN W H F)
  2.    (setq l (vl-sort l (function (lambda (a b) (if (= (car a) (car b)) (< (cadr a) (cadr b)) (< (car a) (car b))))))) ;_  setq
  3.    (setq w (- (car (setq ll (last l))) (car (car l))) h (- (cadr (last l)) (cadr (car l)))) ;_  setq
  4.    (if (< w h)
  5.     (setq an (* 0.5 pi)) ;_  setq
  6.     (setq an 0.0) ;_  setq
  7.    ) ;_  if
  8.    (setq p  (car l)
  9.          pl (list p)
  10.          l  (cdr l)
  11.    ) ;_  setq
  12.    (while l
  13.     (setq d (distance p (car l))) ;_  setq
  14.     (foreach a l
  15.      (if (<= (setq e (distance p a)) d)
  16.       (if (and an (or (equal (angle p a) an 1e-6) (equal (angle p a) (rem (+ pi an) (+ pi pi)) 1e-6) (if (or (equal an 0.0 1e-6) (equal an (* 2 pi) 1e-6)) (equal (angle p a) (* 2 pi) 1e-6))))
  17.        (setq bb a
  18.              d e
  19.        ) ;_  setq
  20.        (setq b a
  21.              d e
  22.        ) ;_  setq
  23.       ) ;_  if
  24.      ) ;_  if
  25.     ) ;_  foreach
  26.     (cond
  27.      ((and bb b (<= (distance p bb) (distance p b)))
  28.       (setq b bb) ;_  setq
  29.      )
  30.      ((and bb b)
  31.       (setq bb b) ;_ setq
  32.      )
  33.      (bb
  34.       (setq b bb) ;_  setq
  35.      )
  36.     ) ;_  cond
  37.     (setq pl (cons b pl)
  38.           l  (vl-remove b l)
  39.           p  b
  40.           b  nil
  41.           bb nil
  42.     ) ;_  setq
  43.     (cond
  44.      ((and (null f) (= an 0.0) (= (car p) (car ll)) (= (distance p ll) d))
  45.       (setq an (* 0.5 pi) f t) ;_  setq
  46.      )
  47.      ((and (null f) (= an (* 0.5 pi)) (= (cadr p) (cadr ll)) (= (distance p ll) d))
  48.       (setq an 0.0 f t) ;_  setq
  49.      )
  50.     ) ;_  cond
  51.    ) ;_  while
  52.    (setq pl (reverse pl)) ;_  setq
  53.    (setq e  nil
  54.          l  pl
  55.          ll l
  56.    ) ;_  setq
  57.    (while (and (not e) ll)
  58.     (setq e  t
  59.           ll l
  60.     ) ;_  setq
  61.     (while (and e ll)
  62.      (setq ll (if (listp (caar ll))
  63.                ll
  64.                (mapcar (function list) (cons (last ll) ll) ll)
  65.               ) ;_  if
  66.            a  (car ll)
  67.            pl (vl-remove-if (function (lambda (b) (or (member (car a) b) (member (cadr a) b))))
  68.                             (cdr ll)
  69.               ) ;_  vl-remove-if
  70.            ll (cdr ll)
  71.      ) ;_  setq
  72.      (while (and pl (setq b (car pl)) (not (inters (car a) (cadr a) (car b) (cadr b))))
  73.       (setq pl (cdr pl))
  74.      ) ;_  while
  75.      (if pl
  76.       (progn (setq l (append (member (car a) l) (reverse (cdr (member (car a) (reverse l)))))
  77.                    l (append (list (car a)) (member (car b) (reverse (cdr l))) (member (cadr b) l)) ;;; (car a) (cadr a) + ... + (car b) (cadr b) + ... ->end ;;; => ;;; (car a) + (reversed (car b)->(cadr a)) + (not reversed (cadr b)->end)
  78.                    e nil
  79.              ) ;_  setq
  80.       ) ;_  progn
  81.      ) ;_  if
  82.     ) ;_  while
  83.    ) ;_  while
  84.    (setq e (entmakex (append (list '(0 . "LWPOLYLINE")
  85.                                    '(100 . "AcDbEntity")
  86.                                    '(8 . "temp")
  87.                                    '(62 . 1)
  88.                                    '(100 . "AcDbPolyline")
  89.                                    (cons 90 (length l))
  90.                                    '(70 . 1)
  91.                              ) ;_  list
  92.                              (mapcar (function (lambda (a) (cons 10 a))) l)
  93.                      ) ;_  append
  94.            ) ;_  entmakex
  95.    ) ;_  setq
  96.    (princ (strcat "\nPolyline Length: "
  97.                   (rtos (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)) 2 4)
  98.                   " mm."
  99.           ) ;_  strcat
  100.    ) ;_  princ
  101.    (princ)
  102.   )
  103. (test-lst-a (mapcar '(lambda ( x ) (cdr (assoc 10 (entget x)))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "POINT"))))))))
  104.  

Regards...
« Last Edit: July 10, 2019, 05:56:46 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 #115 on: December 11, 2018, 09:20:38 AM »
I tried to add checking for intersections using Evgeniy's method... This may and may not produce better (shorter) path, but it's surely better than with crossings... IMO I think when 2D TSP, should yield no crossings no matter what distribution of 2D points... So I agree with Evgeniy - after all he is guru...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:TSP-2D-MR ( / prelst suflst LM:ConvexHull-ptsonHull LM:Clockwise-p ss ti i pl pln dmin k plp pld pll d r pp lil lii1 lii2 lil1 lil2 ip ppl ppll )
  2.  
  3.   (defun prelst ( l n / ll ) ; l - list ; n - 0 based index at which list is split and right-trimmed ; (prelst '(0 1 2 3) 0) => nil ; (prelst '(0 1 2 3) 1) => (0) ; (prelst '(0 1 2 3) 3) => (0 1 2) ; (prelst '(0 1 2 3) 4) => (0 1 2 3) ; (prelst '(0 1 2 3) 5) => (0 1 2 3)
  4.     (if (<= n 0)
  5.       nil
  6.       (if (< n (length l))
  7.         (progn
  8.           (repeat n
  9.             (setq ll (cons (car l) ll))
  10.             (setq l (cdr l))
  11.           )
  12.           (reverse ll)
  13.         )
  14.         l
  15.       )
  16.     )
  17.   )
  18.  
  19.   (defun suflst ( l n ) ; l - list ; n - 0 based index at which list is split and left-trimmed ; (suflst '(0 1 2 3) 0) => (0 1 2 3) ; (suflst '(0 1 2 3) 1) => (1 2 3) ; (suflst '(0 1 2 3) 3) => (3) ; (suflst '(0 1 2 3) 4) => nil ; (suflst '(0 1 2 3) 5) => nil
  20.     (if (<= n 0)
  21.       l
  22.       (if (< n (length l))
  23.         (progn
  24.           (repeat n
  25.             (setq l (cdr l))
  26.           )
  27.           l
  28.         )
  29.         nil
  30.       )
  31.     )
  32.   )
  33.  
  34.   ;; Convex Hull  -  Lee Mac
  35.   ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
  36.  
  37.   (defun LM:ConvexHull-ptsonHull ( lst / ch p0 lstl )
  38.       (cond
  39.           (   (< (length lst) 4) lst)
  40.           (   (setq p0 (car lst))
  41.               (foreach p1 (cdr lst)
  42.                   (if (or (< (cadr p1) (cadr p0))
  43.                           (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0)))
  44.                       )
  45.                       (setq p0 p1)
  46.                   )
  47.               )
  48.               (setq lst (vl-remove p0 lst))
  49.               (setq lst (append (list p0) lst))
  50.               (setq lst
  51.                   (vl-sort lst
  52.                       (function
  53.                           (lambda ( a b / c d )
  54.                               (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))))
  55.                                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
  56.                                   (< c d)
  57.                               )
  58.                           )
  59.                       )
  60.                   )
  61.               )
  62.               (setq lstl (vl-remove-if-not (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
  63.               (setq lst (vl-remove-if (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
  64.               (setq lstl (vl-sort lstl (function (lambda ( a b ) (> (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))))))
  65.               (setq lst (append lst lstl))
  66.               (setq ch (list (cadr lst) (car lst)))
  67.               (foreach pt (cddr lst)
  68.                   (setq ch (cons pt ch))
  69.                   (while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt))
  70.                       (setq ch (cons pt (cddr ch)))
  71.                   )
  72.               )
  73.               (reverse ch)
  74.           )
  75.       )
  76.   )
  77.  
  78.   ;; Clockwise-p  -  Lee Mac
  79.   ;; Returns T if p1,p2,p3 are clockwise oriented or [s]collinear[/s]
  80.  
  81.   (defun LM:Clockwise-p ( p1 p2 p3 )
  82.       (<  (-  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
  83.               (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
  84.           )
  85.           0.0
  86.       )
  87.   )
  88.  
  89.   (setq ss (ssget '((0 . "POINT"))))
  90.   (repeat (setq i (sslength ss))
  91.     (setq pl (cons (mapcar (function +) '(0 0) (cdr (assoc 10 (entget (ssname ss (setq i (1- i))))))) pl))
  92.   )
  93.   (setq ti (car (_vl-times)))
  94.   (setq pln (LM:ConvexHull-ptsonHull pl))
  95.   (foreach p pln
  96.     (setq pl (vl-remove p pl))
  97.   )
  98.   (while pl
  99.     (setq ppl (LM:ConvexHull-ptsonHull pl))
  100.     (if (< (length ppl) 4)
  101.       (setq ppl (vl-sort ppl (function (lambda ( a b ) (< (distance (car pln) a) (distance (car pln) b))))))
  102.     )
  103.     (foreach p ppl
  104.       (setq pl (vl-remove p pl))
  105.     )
  106.     (setq ppll (append ppll (reverse ppl)))
  107.     (setq ppl nil)
  108.   )
  109.   (setq pl ppll)
  110.   (while pl
  111.     (setq dmin 1e+99)
  112.     (foreach p pl
  113.       (setq k -1)
  114.       (repeat (length pln)
  115.         (setq k (1+ k))
  116.         ;|
  117.         (setq plp (prelst pln (1+ k)))
  118.         (setq pls (suflst pln (1+ k)))
  119.         |;
  120.         (setq plp (reverse (member (nth k pln) (reverse pln))))
  121.         (setq pls (cdr (member (nth k pln) pln)))
  122.         (setq pll (append plp (list p) pls))
  123.         (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pll (append (cdr pll) (list (car pll))))))
  124.         (if (< d dmin)
  125.           (setq dmin d r pll pp p)
  126.         )
  127.       )
  128.     )
  129.     (setq pln r)
  130.     (setq pl (vl-remove pp pl))
  131.   )
  132.   (setq lil (mapcar (function (lambda ( a b ) (list a b))) pln (append (cdr pln) (list (car pln)))))
  133.   (while (vl-some (function (lambda ( li1 ) (vl-some (function (lambda ( li2 ) (if (and (setq ip (inters (car li1) (cadr li1) (car li2) (cadr li2))) (not (equal ip (car li1) 1e-8)) (not (equal ip (cadr li1) 1e-8)) (not (equal ip (car li2) 1e-8)) (not (equal ip (cadr li2) 1e-8))) (setq lii1 li1 lii2 li2)))) (vl-remove li1 lil)))) lil)
  134.     (setq lil1 (if (member lii2 (cdr (member lii2 (reverse (cdr (member lii1 (append lil lil))))))) (reverse (cdr (member lii2 (cdr (member lii2 (reverse (cdr (member lii1 (append lil lil))))))))) (reverse (cdr (member lii2 (reverse (cdr (member lii1 (append lil lil)))))))))
  135.     (setq lil2 (if (member lii1 (cdr (member lii1 (reverse (cdr (member lii2 (append lil lil))))))) (cdr (member lii1 (cdr (member lii1 (reverse (cdr (member lii2 (append lil lil)))))))) (cdr (member lii1 (reverse (cdr (member lii2 (append lil lil))))))))
  136.     (setq lil (append lil1 (list (list (cadr (last lil1)) (cadr (car lil2)))) (mapcar 'reverse lil2) (list (list (car (last lil2)) (car (car lil1))))))
  137.   )
  138.   (setq pln (mapcar 'car lil))
  139.   (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pln (append (cdr pln) (list (car pln))))))
  140.     (append
  141.       (list
  142.         '(0 . "LWPOLYLINE")
  143.         '(100 . "AcDbEntity")
  144.         '(100 . "AcDbPolyline")
  145.         (cons 90 (length pln))
  146.         (cons 70 (1+ (* (getvar 'plinegen) 128)))
  147.         '(38 . 0.0)
  148.       )
  149.       (mapcar (function (lambda ( x ) (cons 10 x))) pln)
  150.       (list
  151.         '(210 0.0 0.0 1.0)
  152.         '(62 . 1)
  153.       )
  154.     )
  155.   )
  156.   (prompt "\nDistance : ") (princ (rtos d 2 50))
  157.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds...")
  158.   (princ)
  159. )
  160.  

Regards, M.R.

[EDIT : Forgot to localize "ip" variable...]
[EDIT2 : Tried with subs (prelst) and (suflst), but it seems slower, so I returned to (nth) and (member) variants for "plp" and "pls" variables...]

BTW. My test DWG in now bad, but lst-a of Evgeniy is now little shorter : 3806.343470244899
« Last Edit: June 19, 2019, 12:45:06 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

Grrr1337

  • Swamp Rat
  • Posts: 812
Re: (Challenge) To draw the shortest lwpolyline
« Reply #116 on: December 13, 2018, 06:57:42 PM »
Impressive work, Marko! 8)
(apply ''((a b c)(a b c))
  '(
    (( f L ) (apply 'strcat (f L)))
    (( L ) (if L (cons (chr (car L)) (f (cdr L)))))
    (72 101 108 108 111 32 87 111 114 108 100)
  )
)
vevo.bg

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #117 on: December 15, 2018, 12:14:45 AM »
Thanks Grrr... I've modified it further more, now my test DWG is fine 77.4142... and lst-a by Evgeniy is also good - around 3800 (look in previous post to see exact number)... Only lack now is that it is 2 times slower on already slow routine... But I am satisfied nevertheless...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:TSP-2D-MR ( / LM:ConvexHull-ptsonHull LM:Clockwise-p ss ti i pl pln dmin k plp pld pll d r pp lil lii1 lii2 lil1 lil2 ip ppl ppll )
  2.  
  3.   ;; Convex Hull  -  Lee Mac
  4.   ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
  5.  
  6.   (defun LM:ConvexHull-ptsonHull ( lst / ch p0 lstl )
  7.       (cond
  8.           (   (< (length lst) 4) lst)
  9.           (   (setq p0 (car lst))
  10.               (foreach p1 (cdr lst)
  11.                   (if (or (< (cadr p1) (cadr p0))
  12.                           (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0)))
  13.                       )
  14.                       (setq p0 p1)
  15.                   )
  16.               )
  17.               (setq lst (vl-remove p0 lst))
  18.               (setq lst (append (list p0) lst))
  19.               (setq lst
  20.                   (vl-sort lst
  21.                       (function
  22.                           (lambda ( a b / c d )
  23.                               (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))))
  24.                                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
  25.                                   (< c d)
  26.                               )
  27.                           )
  28.                       )
  29.                   )
  30.               )
  31.               (setq lstl (vl-remove-if-not (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
  32.               (setq lst (vl-remove-if (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
  33.               (setq lstl (vl-sort lstl (function (lambda ( a b ) (> (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))))))
  34.               (setq lst (append lst lstl))
  35.               (setq ch (list (cadr lst) (car lst)))
  36.               (foreach pt (cddr lst)
  37.                   (setq ch (cons pt ch))
  38.                   (while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt))
  39.                       (setq ch (cons pt (cddr ch)))
  40.                   )
  41.               )
  42.               (reverse ch)
  43.           )
  44.       )
  45.   )
  46.  
  47.   ;; Clockwise-p  -  Lee Mac
  48.   ;; Returns T if p1,p2,p3 are clockwise oriented or [s]collinear[/s]
  49.  
  50.   (defun LM:Clockwise-p ( p1 p2 p3 )
  51.       (<  (-  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
  52.               (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
  53.           )
  54.           0.0
  55.       )
  56.   )
  57.  
  58.   (setq ss (ssget '((0 . "POINT"))))
  59.   (repeat (setq i (sslength ss))
  60.     (setq pl (cons (mapcar (function +) '(0 0) (cdr (assoc 10 (entget (ssname ss (setq i (1- i))))))) pl))
  61.   )
  62.   (setq ti (car (_vl-times)))
  63.   (setq pln (LM:ConvexHull-ptsonHull pl))
  64.   (foreach p pln
  65.     (setq pl (vl-remove p pl))
  66.   )
  67.   (while pl
  68.     (setq ppl (LM:ConvexHull-ptsonHull pl))
  69.     (if (< (length ppl) 4)
  70.       (setq ppl (vl-sort ppl (function (lambda ( a b ) (< (distance (car pln) a) (distance (car pln) b))))))
  71.     )
  72.     (foreach p ppl
  73.       (setq pl (vl-remove p pl))
  74.     )
  75.     (setq ppll (append ppll (reverse ppl)))
  76.     (setq ppl nil)
  77.   )
  78.   (setq pl ppll)
  79.   (while pl
  80.     (foreach p pl
  81.       (setq k -1)
  82.       (repeat (length pln)
  83.         (setq k (1+ k))
  84.         (setq plp (reverse (member (nth k pln) (reverse pln))))
  85.         (setq pls (cdr (member (nth k pln) pln)))
  86.         (setq pll (append plp (list p) pls))
  87.         (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pll (append (cdr pll) (list (car pll))))))
  88.         (setq r (cons (list d pll) r))
  89.       )
  90.     )
  91.     (setq r (vl-sort r (function (lambda ( a b ) (< (car a) (car b))))))
  92.     (setq r (vl-remove-if-not (function (lambda ( x ) (equal (caar r) (car x) 1e-8))) r))
  93.     (setq dmin 1e+99)
  94.     (foreach xx (mapcar (function cadr) r)
  95.       (if (vl-remove (vl-some (function (lambda ( x ) (if (vl-position x pl) x))) xx) pl)
  96.         (foreach p (vl-remove (vl-some (function (lambda ( x ) (if (vl-position x pl) x))) xx) pl)
  97.           (setq k -1)
  98.           (repeat (length xx)
  99.             (setq k (1+ k))
  100.             (setq plp (reverse (member (nth k xx) (reverse xx))))
  101.             (setq pls (cdr (member (nth k xx) xx)))
  102.             (setq pll (append plp (list p) pls))
  103.             (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pll (append (cdr pll) (list (car pll))))))
  104.             (if (< d dmin)
  105.               (setq dmin d r pll pp (vl-remove nil (mapcar (function (lambda ( x ) (if (vl-position x pl) x))) pll)))
  106.             )
  107.           )
  108.         )
  109.         (setq r nil pln xx)
  110.       )
  111.     )
  112.     (if r
  113.       (progn
  114.         (setq pln r)
  115.         (foreach x pp
  116.           (setq pl (vl-remove x pl))
  117.         )
  118.         (setq r nil pp nil)
  119.       )
  120.       (setq pl nil)
  121.     )
  122.   )
  123.   (setq lil (mapcar (function (lambda ( a b ) (list a b))) pln (append (cdr pln) (list (car pln)))))
  124.   (while (vl-some (function (lambda ( li1 ) (vl-some (function (lambda ( li2 ) (if (and (setq ip (inters (car li1) (cadr li1) (car li2) (cadr li2))) (not (equal ip (car li1) 1e-8)) (not (equal ip (cadr li1) 1e-8)) (not (equal ip (car li2) 1e-8)) (not (equal ip (cadr li2) 1e-8))) (setq lii1 li1 lii2 li2)))) (vl-remove li1 lil)))) lil)
  125.     (setq lil1 (if (member lii2 (cdr (member lii2 (reverse (cdr (member lii1 (append lil lil))))))) (reverse (cdr (member lii2 (cdr (member lii2 (reverse (cdr (member lii1 (append lil lil))))))))) (reverse (cdr (member lii2 (reverse (cdr (member lii1 (append lil lil)))))))))
  126.     (setq lil2 (if (member lii1 (cdr (member lii1 (reverse (cdr (member lii2 (append lil lil))))))) (cdr (member lii1 (cdr (member lii1 (reverse (cdr (member lii2 (append lil lil)))))))) (cdr (member lii1 (reverse (cdr (member lii2 (append lil lil))))))))
  127.     (setq lil (append lil1 (list (list (cadr (last lil1)) (cadr (car lil2)))) (mapcar (function reverse) lil2) (list (list (car (last lil2)) (car (car lil1))))))
  128.   )
  129.   (setq pln (mapcar (function car) lil))
  130.   (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pln (append (cdr pln) (list (car pln))))))
  131.     (append
  132.       (list
  133.         '(0 . "LWPOLYLINE")
  134.         '(100 . "AcDbEntity")
  135.         '(100 . "AcDbPolyline")
  136.         (cons 90 (length pln))
  137.         (cons 70 (1+ (* (getvar 'plinegen) 128)))
  138.         '(38 . 0.0)
  139.       )
  140.       (mapcar (function (lambda ( x ) (cons 10 x))) pln)
  141.       (list
  142.         '(210 0.0 0.0 1.0)
  143.         '(62 . 1)
  144.       )
  145.     )
  146.   )
  147.   (prompt "\nDistance : ") (princ (rtos d 2 50))
  148.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds...")
  149.   (princ)
  150. )
  151.  

M.R.
Now nullptr and Evgeniy are known for fast algorithms, maybe they can improve it to be faster, but I doubt given the code it is now (nothing much you can't remove not to loose main objective - shortness of TSP 2D)...
« Last Edit: June 19, 2019, 12:45:47 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 #118 on: December 16, 2018, 01:42:42 PM »
Hi, it's me again...
I've speed up my code, but be aware that it may not yield better result... For lst-a (grid like patterns) speed is much better, if you choose shorter fuzz, it will be faster, but distance may be worse... The best for grid like patterns is to choose big fuzz, but it may be so slooow that you maight not even get result... So this is some kind of greedy algorithm improvement, and I think, because of slowness of my version, it was necessity...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:TSP-2D-MR ( / LM:ConvexHull-ptsonHull LM:Clockwise-p unique car-sort ss fuzz ti i pl pln dmin k plp pld pll d dl r rr pp lil lii1 lii2 lil1 lil2 ip ppp pps f )
  2.  
  3.   ;; Convex Hull  -  Lee Mac
  4.   ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
  5.  
  6.   (defun LM:ConvexHull-ptsonHull ( lst / ch p0 lstl )
  7.       (cond
  8.           (   (< (length lst) 4) lst)
  9.           (   (setq p0 (car lst))
  10.               (foreach p1 (cdr lst)
  11.                   (if (or (< (cadr p1) (cadr p0))
  12.                           (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0)))
  13.                       )
  14.                       (setq p0 p1)
  15.                   )
  16.               )
  17.               (setq lst (vl-remove p0 lst))
  18.               (setq lst (append (list p0) lst))
  19.               (setq lst
  20.                   (vl-sort lst
  21.                       (function
  22.                           (lambda ( a b / c d )
  23.                               (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))))
  24.                                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
  25.                                   (< c d)
  26.                               )
  27.                           )
  28.                       )
  29.                   )
  30.               )
  31.               (setq lstl (vl-remove-if-not (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
  32.               (setq lst (vl-remove-if (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
  33.               (setq lstl (vl-sort lstl (function (lambda ( a b ) (> (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))))))
  34.               (setq lst (append lst lstl))
  35.               (setq ch (list (cadr lst) (car lst)))
  36.               (foreach pt (cddr lst)
  37.                   (setq ch (cons pt ch))
  38.                   (while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt))
  39.                       (setq ch (cons pt (cddr ch)))
  40.                   )
  41.               )
  42.               (reverse ch)
  43.           )
  44.       )
  45.   )
  46.  
  47.   ;; Clockwise-p  -  Lee Mac
  48.   ;; Returns T if p1,p2,p3 are clockwise oriented or [s]collinear[/s]
  49.  
  50.   (defun LM:Clockwise-p ( p1 p2 p3 )
  51.       (<  (-  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
  52.               (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
  53.           )
  54.           0.0
  55.       )
  56.   )
  57.  
  58.   (defun unique ( l )
  59.     (if l
  60.       (cons (car l)
  61.         (unique (vl-remove-if (function (lambda ( x ) (equal x (car l) 1e-8))) l))
  62.       )
  63.     )
  64.   )
  65.  
  66.   ;;; (car-sort '(2 4 1 3 5 1) '<) => nil
  67.   ;;; (car-sort '(2 4 1 3 5 1) '<=) => 1
  68.   (defun car-sort ( l f / removenth r k )
  69.  
  70.     (defun removenth ( l n / k )
  71.       (setq k -1)
  72.       (vl-remove-if (function (lambda ( x ) (= (setq k (1+ k)) n))) l)
  73.     )
  74.  
  75.     (setq k -1)
  76.     (vl-some (function (lambda ( a ) (setq k (1+ k)) (if (vl-every (function (lambda ( x ) (apply f (list a x)))) (removenth l k)) (setq r a)))) l)
  77.     r
  78.   )
  79.  
  80.   (setq ss (ssget '((0 . "POINT"))))
  81.   (repeat (setq i (sslength ss))
  82.     (setq pl (cons (mapcar (function +) '(0 0) (cdr (assoc 10 (entget (ssname ss (setq i (1- i))))))) pl))
  83.   )
  84.   (initget 7)
  85.   (setq fuzz (getdist "\nPick or specify radius of point cloud fuzz : "))
  86.   (setq ti (car (_vl-times)))
  87.   (setq pln (LM:ConvexHull-ptsonHull pl))
  88.   (foreach p pln
  89.     (setq pl (vl-remove p pl))
  90.   )
  91.   (setq ppp (vl-remove-if-not (function (lambda ( p ) (< (distance p (car pln)) fuzz))) pl))
  92.   (while pl
  93.     (foreach p (if (null ppp) pl ppp)
  94.       (setq k -1)
  95.       (repeat (length pln)
  96.         (setq k (1+ k))
  97.         (setq plp (reverse (member (nth k pln) (reverse pln))))
  98.         (setq pls (cdr (member (nth k pln) pln)))
  99.         (setq pll (append plp (list p) pls))
  100.         (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pll (append (cdr pll) (list (car pll))))))
  101.         (setq r (cons (list d pll) r))
  102.       )
  103.     )
  104.     ;|
  105.     (setq r (vl-sort r (function (lambda ( a b ) (< (car a) (car b))))))
  106.     (setq dl (unique (mapcar (function car) r)))
  107.     ;(cond
  108.     ;  ( (cadddr dl)
  109.     ;    (setq d (cadddr dl))
  110.     ;  )
  111.     ;  ( (caddr dl)
  112.     ;    (setq d (caddr dl))
  113.     ;  )
  114.     ;  ( (cadr dl)
  115.     ;    (setq d (cadr dl))
  116.     ;  )
  117.     ;  ( t
  118.     ;    (setq d (car dl))
  119.     ;  )
  120.     ;)
  121.     (setq d (last dl))
  122.     (setq r (vl-remove-if-not (function (lambda ( x ) (<= (car x) d))) r))
  123.     |;
  124.     (setq dmin 1e+99)
  125.     (foreach xx (mapcar (function cadr) r)
  126.       (if (vl-remove (vl-some (function (lambda ( x ) (if (vl-position x pl) x))) xx) pl)
  127.         (foreach p (if (null (vl-remove (vl-some (function (lambda ( x ) (if (vl-position x pl) x))) xx) ppp)) (vl-remove (vl-some (function (lambda ( x ) (if (vl-position x pl) x))) xx) pl) (vl-remove (vl-some (function (lambda ( x ) (if (vl-position x pl) x))) xx) ppp))
  128.           (setq k -1)
  129.           (repeat (length xx)
  130.             (setq k (1+ k))
  131.             (setq plp (reverse (member (nth k xx) (reverse xx))))
  132.             (setq pls (cdr (member (nth k xx) xx)))
  133.             (setq pll (append plp (list p) pls))
  134.             (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pll (append (cdr pll) (list (car pll))))))
  135.             (if (< d dmin)
  136.               (setq dmin d r pll pp (vl-remove nil (mapcar (function (lambda ( x ) (if (vl-position x pl) x))) pll)) rr (cons (list d r pp) rr))
  137.             )
  138.           )
  139.         )
  140.         (progn
  141.           (setq k -1)
  142.           (repeat (length xx)
  143.             (setq k (1+ k))
  144.             (setq plp (reverse (member (nth k xx) (reverse xx))))
  145.             (setq pls (cdr (member (nth k xx) xx)))
  146.             (setq pll (append plp (list (car pl)) pls))
  147.             (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pll (append (cdr pll) (list (car pll))))))
  148.             (if (< d dmin)
  149.               (setq dmin d r pll pp (vl-remove nil (mapcar (function (lambda ( x ) (if (vl-position x pl) x))) pll)) rr (cons (list d r pp) rr))
  150.             )
  151.           )
  152.           (setq f t)
  153.         )
  154.       )
  155.     )
  156.     (if f
  157.       (setq pln (cadr (car-sort rr (function (lambda ( a b ) (<= (car a) (car b)))))) r nil)
  158.       (progn
  159.         (setq rr (car-sort rr (function (lambda ( a b ) (<= (car a) (car b))))))
  160.         (setq r (cadr rr) pp (caddr rr) rr nil)
  161.       )
  162.     )
  163.     (if r
  164.       (progn
  165.         (setq pln r ppp nil)
  166.         (foreach x pp
  167.           (setq pl (vl-remove x pl))
  168.         )
  169.         (foreach x pp
  170.           (setq pps (vl-remove-if-not (function (lambda ( p ) (< (distance p x) fuzz))) pl))
  171.           (setq pps (vl-remove-if (function (lambda ( p ) (vl-position p ppp))) pps))
  172.           (setq ppp (append pps ppp))
  173.         )
  174.         (setq r nil pp nil)
  175.       )
  176.       (setq pl nil)
  177.     )
  178.   )
  179.   (setq lil (mapcar (function (lambda ( a b ) (list a b))) pln (append (cdr pln) (list (car pln)))))
  180.   (while (vl-some (function (lambda ( li1 ) (vl-some (function (lambda ( li2 ) (if (and (setq ip (inters (car li1) (cadr li1) (car li2) (cadr li2))) (not (equal ip (car li1) 1e-8)) (not (equal ip (cadr li1) 1e-8)) (not (equal ip (car li2) 1e-8)) (not (equal ip (cadr li2) 1e-8))) (setq lii1 li1 lii2 li2)))) (vl-remove li1 lil)))) lil)
  181.     (setq lil1 (if (member lii2 (cdr (member lii2 (reverse (cdr (member lii1 (append lil lil))))))) (reverse (cdr (member lii2 (cdr (member lii2 (reverse (cdr (member lii1 (append lil lil))))))))) (reverse (cdr (member lii2 (reverse (cdr (member lii1 (append lil lil)))))))))
  182.     (setq lil2 (if (member lii1 (cdr (member lii1 (reverse (cdr (member lii2 (append lil lil))))))) (cdr (member lii1 (cdr (member lii1 (reverse (cdr (member lii2 (append lil lil)))))))) (cdr (member lii1 (reverse (cdr (member lii2 (append lil lil))))))))
  183.     (setq lil (append lil1 (list (list (cadr (last lil1)) (cadr (car lil2)))) (mapcar (function reverse) lil2) (list (list (car (last lil2)) (car (car lil1))))))
  184.   )
  185.   (setq pln (mapcar (function car) lil))
  186.   (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pln (append (cdr pln) (list (car pln))))))
  187.     (append
  188.       (list
  189.         '(0 . "LWPOLYLINE")
  190.         '(100 . "AcDbEntity")
  191.         '(100 . "AcDbPolyline")
  192.         (cons 90 (length pln))
  193.         (cons 70 (1+ (* (getvar 'plinegen) 128)))
  194.         '(38 . 0.0)
  195.       )
  196.       (mapcar (function (lambda ( x ) (cons 10 x))) pln)
  197.       (list
  198.         '(210 0.0 0.0 1.0)
  199.         '(62 . 1)
  200.       )
  201.     )
  202.   )
  203.   (prompt "\nDistance : ") (princ (rtos d 2 50))
  204.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds...")
  205.   (princ)
  206. )
  207.  

Regards, M.R.
« Last Edit: June 19, 2019, 12:46: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 #119 on: January 04, 2019, 04:59:41 AM »
Hi again, my latest revision... I returned back to slow but perhaps more reliable coding... Although its maximum is about 20 points for factor 2, that's also better than brute force... For 3, 4, ... don't even think you'll see the result - its computing large lists and may never finish... So I suggest default 1 and hope that result will be optimal as much as possible, if not then you are practically doomed like with brute force... I'll also input version for start-end in the topic by user @handasa - there is link for it when I compete with @nullptr - Daniel - I post it somewhere in the middle when it was started...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:TSP-2D-MR ( / LM:ConvexHull-ptsonHull LM:Clockwise-p car-sort plstdiff processrs ss ti i pl pln k plp pld pll d r rr ppp lil lii1 lii2 lil1 lil2 ip f kk n )
  2.  
  3.   ;; Convex Hull  -  Lee Mac
  4.   ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
  5.  
  6.   (defun LM:ConvexHull-ptsonHull ( lst / ch p0 lstl )
  7.       (cond
  8.           (   (< (length lst) 4) lst)
  9.           (   (setq p0 (car lst))
  10.               (foreach p1 (cdr lst)
  11.                   (if (or (< (cadr p1) (cadr p0))
  12.                           (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0)))
  13.                       )
  14.                       (setq p0 p1)
  15.                   )
  16.               )
  17.               (setq lst (vl-remove p0 lst))
  18.               (setq lst (append (list p0) lst))
  19.               (setq lst
  20.                   (vl-sort lst
  21.                       (function
  22.                           (lambda ( a b / c d )
  23.                               (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))))
  24.                                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
  25.                                   (< c d)
  26.                               )
  27.                           )
  28.                       )
  29.                   )
  30.               )
  31.               (setq lstl (vl-remove-if-not (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
  32.               (setq lst (vl-remove-if (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
  33.               (setq lstl (vl-sort lstl (function (lambda ( a b ) (> (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))))))
  34.               (setq lst (append lst lstl))
  35.               (setq ch (list (cadr lst) (car lst)))
  36.               (foreach pt (cddr lst)
  37.                   (setq ch (cons pt ch))
  38.                   (while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt))
  39.                       (setq ch (cons pt (cddr ch)))
  40.                   )
  41.               )
  42.               (reverse ch)
  43.           )
  44.       )
  45.   )
  46.  
  47.   ;; Clockwise-p  -  Lee Mac
  48.   ;; Returns T if p1,p2,p3 are clockwise oriented or [s]collinear[/s]
  49.  
  50.   (defun LM:Clockwise-p ( p1 p2 p3 )
  51.       (<  (-  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
  52.               (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
  53.           )
  54.           0.0
  55.       )
  56.   )
  57.  
  58.   ;;; (car-sort '(2 4 1 3 5 1) '<) => nil
  59.   ;;; (car-sort '(2 4 1 3 5 1) '<=) => 1
  60.   (defun car-sort ( l f / removenth r k )
  61.  
  62.     (defun removenth ( l n / k )
  63.       (setq k -1)
  64.       (vl-remove-if (function (lambda ( x ) (= (setq k (1+ k)) n))) l)
  65.     )
  66.  
  67.     (setq k -1)
  68.     (vl-some (function (lambda ( a ) (setq k (1+ k)) (if (vl-every (function (lambda ( x ) (apply f (list a x)))) (removenth l k)) (setq r a)))) l)
  69.     r
  70.   )
  71.  
  72.   (defun plstdiff ( l1 l2 )
  73.     (foreach p l1
  74.       (setq l2 (vl-remove p l2))
  75.     )
  76.     l2
  77.   )
  78.  
  79.   (defun processrs ( r / rr )
  80.     (foreach xx r
  81.       (if (and (null f) (if (equal xx pln) (setq ppp pl) (setq ppp (plstdiff xx pl))))
  82.         (foreach p ppp
  83.           (setq k -1)
  84.           (repeat (length xx)
  85.             (setq k (1+ k))
  86.             (setq plp (reverse (member (nth k xx) (reverse xx))))
  87.             (setq pls (cdr (member (nth k xx) xx)))
  88.             (setq pll (append plp (list p) pls))
  89.             (setq rr (cons pll rr))
  90.           )
  91.         )
  92.         (setq f t)
  93.       )
  94.     )
  95.     (if f
  96.       (progn
  97.         (setq pl nil)
  98.         r
  99.       )
  100.       (if (= kk n)
  101.         (progn
  102.           (setq kk 0)
  103.           (setq rr (mapcar (function (lambda ( x ) (list (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) x (append (cdr x) (list (car x))))) x))) rr))
  104.           (setq rr (list (cadr (car-sort rr (function (lambda ( a b ) (<= (car a) (car b))))))))
  105.         )
  106.         rr
  107.       )
  108.     )
  109.   )
  110.  
  111.   (setq ss (ssget '((0 . "POINT"))))
  112.   (repeat (setq i (sslength ss))
  113.     (setq pl (cons (mapcar (function +) '(0 0) (cdr (assoc 10 (entget (ssname ss (setq i (1- i))))))) pl))
  114.   )
  115.   (initget 6)
  116.   (setq n (getint "\nSpecify speed factor - reliability - [1-fast/2-slow] <1> : "))
  117.   (if (null n)
  118.     (setq n 1)
  119.   )
  120.   (setq ti (car (_vl-times)))
  121.   (setq pln (LM:ConvexHull-ptsonHull pl))
  122.   (foreach p pln
  123.     (setq pl (vl-remove p pl))
  124.   )
  125.   (setq kk 0)
  126.   (while pl
  127.     (setq kk (1+ kk))
  128.     (if (null rr)
  129.       (setq rr (processrs (list pln)))
  130.       (setq rr (processrs rr))
  131.     )
  132.   )
  133.   (setq rr (mapcar (function (lambda ( x ) (list (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) x (append (cdr x) (list (car x))))) x))) rr))
  134.   (setq pln (cadr (car-sort rr (function (lambda ( a b ) (<= (car a) (car b)))))))
  135.   (setq lil (mapcar (function (lambda ( a b ) (list a b))) pln (append (cdr pln) (list (car pln)))))
  136.   (while (vl-some (function (lambda ( li1 ) (vl-some (function (lambda ( li2 ) (if (and (setq ip (inters (car li1) (cadr li1) (car li2) (cadr li2))) (not (equal ip (car li1) 1e-8)) (not (equal ip (cadr li1) 1e-8)) (not (equal ip (car li2) 1e-8)) (not (equal ip (cadr li2) 1e-8))) (setq lii1 li1 lii2 li2)))) (vl-remove li1 lil)))) lil)
  137.     (setq lil1 (if (member lii2 (cdr (member lii2 (reverse (cdr (member lii1 (append lil lil))))))) (reverse (cdr (member lii2 (cdr (member lii2 (reverse (cdr (member lii1 (append lil lil))))))))) (reverse (cdr (member lii2 (reverse (cdr (member lii1 (append lil lil)))))))))
  138.     (setq lil2 (if (member lii1 (cdr (member lii1 (reverse (cdr (member lii2 (append lil lil))))))) (cdr (member lii1 (cdr (member lii1 (reverse (cdr (member lii2 (append lil lil)))))))) (cdr (member lii1 (reverse (cdr (member lii2 (append lil lil))))))))
  139.     (setq lil (append lil1 (list (list (cadr (last lil1)) (cadr (car lil2)))) (mapcar (function reverse) lil2) (list (list (car (last lil2)) (car (car lil1))))))
  140.   )
  141.   (setq pln (mapcar (function car) lil))
  142.   (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pln (append (cdr pln) (list (car pln))))))
  143.     (append
  144.       (list
  145.         '(0 . "LWPOLYLINE")
  146.         '(100 . "AcDbEntity")
  147.         '(100 . "AcDbPolyline")
  148.         (cons 90 (length pln))
  149.         (cons 70 (1+ (* (getvar 'plinegen) 128)))
  150.         '(38 . 0.0)
  151.       )
  152.       (mapcar (function (lambda ( x ) (cons 10 x))) pln)
  153.       (list
  154.         '(210 0.0 0.0 1.0)
  155.         '(62 . 1)
  156.       )
  157.     )
  158.   )
  159.   (prompt "\nDistance : ") (princ (rtos d 2 50))
  160.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds...")
  161.   (princ)
  162. )
  163.  

P.S. If you are lucky enough that your points almost all form shape of ConvexHull then it will be fast and reliable, but if not, then you'll have to wait and only hope for correct result... So this is actually my remark to remove doubts that TSP can be solved, but never give up... chlh_jd's code is fast and superior to my versions, but still not full reliable answer, I mean, so what if it can finish in 1 second, when you don't get correct result, you can get only close to correct...

Regards, happy New Year holidays...
M.R.
« Last Edit: June 19, 2019, 12:47:03 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube