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

0 Members and 2 Guests are viewing this topic.

nullptr

  • BricsCAD
  • Needs a day job
  • Posts: 6821
  • AKA Daniel
Re: (Challenge) To draw the shortest lwpolyline
« Reply #105 on: October 27, 2018, 10:38:15 PM »
At least it works, but it's terribly wrong in difference of my previous codes that are good but useless for 10 and more points...

what is your result for rand10? I tried to run it, but select , copy paste gives me line numbers... lol

ribarm

  • Water Moccasin
  • Posts: 1935
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #106 on: October 28, 2018, 06:07:52 AM »
RAND10 :
Distance : 62.71290278984382
Elapsed time : 0.04699999999999999 seconds.

RAND100 :
Distance : 6679.527823958952
Elapsed time : 0.7189999999999999 seconds.

RAND1000 :
Distance : 631481.0073386774
Elapsed time : 68.10999999999999 seconds.

RAND10000 :
I need about 10 hours of running... But I'll be back with info as soon as it finishes...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

nullptr

  • BricsCAD
  • Needs a day job
  • Posts: 6821
  • AKA Daniel
Re: (Challenge) To draw the shortest lwpolyline
« Reply #107 on: October 28, 2018, 06:45:41 AM »
I need about 10 hours of running... But I'll be back with info as soon as it finishes...

LOL! I tried adding 2-opt to mine, had to kill the process , Iím going to skip the bigger sets until I have a better algorithm

ribarm

  • Water Moccasin
  • Posts: 1935
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #108 on: October 28, 2018, 07:01:22 AM »
LOL!...

But I am pretty sure that my Salesman haven't traveled neither shortest nor longest... So he enjoyed travel the most... LOL!
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 1935
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #109 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

  • Water Moccasin
  • Posts: 1935
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #110 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

nullptr

  • BricsCAD
  • Needs a day job
  • Posts: 6821
  • AKA Daniel
Re: (Challenge) To draw the shortest lwpolyline
« Reply #111 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

nullptr

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

ribarm

  • Water Moccasin
  • Posts: 1935
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #113 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

nullptr

  • BricsCAD
  • Needs a day job
  • Posts: 6821
  • AKA Daniel
Re: (Challenge) To draw the shortest lwpolyline
« Reply #114 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

  • Water Moccasin
  • Posts: 1935
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #115 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 (equal (cadr p1) (cadr p0) 1e-8) (< (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 (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8)
  24.                                  (< (distance p0 a) (distance p0 b))
  25.                                  (< (if (equal c (* 2.0 pi) 1e-8) 0.0 c) (if (equal d (* 2.0 pi) 1e-8) 0.0 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 p0 a) (distance 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.
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 1935
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #116 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

  • Water Moccasin
  • Posts: 1935
  • Marko Ribar, architect
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 1935
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #118 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 (equal (cadr p1) (cadr p0) 1e-8) (< (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 (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8)
  24.                                  (< (distance p0 a) (distance p0 b))
  25.                                  (< (if (equal c (* 2.0 pi) 1e-8) 0.0 c) (if (equal d (* 2.0 pi) 1e-8) 0.0 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 p0 a) (distance 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.  

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

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 1935
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #119 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 (equal (cadr p1) (cadr p0) 1e-8) (< (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 (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8)
  55.                                  (< (distance p0 a) (distance p0 b))
  56.                                  (< (if (equal c (* 2.0 pi) 1e-8) 0.0 c) (if (equal d (* 2.0 pi) 1e-8) 0.0 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 p0 a) (distance 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: December 13, 2018, 01:01:35 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube