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

0 Members and 1 Guest are viewing this topic.

#### ribarm

• Gator
• Posts: 3327
• 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)

#### ribarm

• Gator
• Posts: 3327
• 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))))
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))
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)

#### It's Alive!

• Retired
• Needs a day job
• Posts: 8908
• 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: 8908
• 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: 3327
• 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)

#### It's Alive!

• Retired
• Needs a day job
• Posts: 8908
• 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: 3327
• 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)
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.                           (lambda ( a b / c d )
22.                               (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))))
23.                                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
24.                                   (< c d)
25.                               )
26.                           )
27.                       )
28.                   )
29.               )
30.               (setq lstl (vl-remove-if-not (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
31.               (setq lst (vl-remove-if (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
32.               (setq lstl (vl-sort lstl (function (lambda ( a b ) (> (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))))))
33.               (setq lst (append lst lstl))
34.               (setq ch (list (cadr lst) (car lst)))
35.               (foreach pt (cddr lst)
36.                   (setq ch (cons pt ch))
38.                       (setq ch (cons pt (cddr ch)))
39.                   )
40.               )
41.               (reverse ch)
42.           )
43.       )
44.   )
45.
46.   ;; Clockwise-p  -  Lee Mac
47.   ;; Returns T if p1,p2,p3 are clockwise oriented or [s]collinear[/s]
48.
49.   (defun LM:Clockwise-p ( p1 p2 p3 )
50.       (<  (-  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
51.               (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
52.           )
53.           0.0
54.       )
55.   )
56.
57.   (setq ss (ssget '((0 . "POINT"))))
58.   (repeat (setq i (sslength ss))
59.     (setq pl (cons (mapcar '+ '(0 0) (cdr (assoc 10 (entget (ssname ss (setq i (1- i))))))) pl))
60.   )
61.   (setq ti (car (_vl-times)))
62.   (setq pln (LM:ConvexHull-ptsonHull pl))
63.   (foreach p pln
64.     (setq pl (vl-remove p pl))
65.   )
66.   (while pl
67.     (setq dmin 1e+99)
68.     (foreach p pl
69.       (setq k -1)
70.       (repeat (length pln)
71.         (setq k (1+ k))
72.         (setq plp (reverse (cdr (member (nth k pln) (reverse pln)))))
73.         (setq pls (member (nth k pln) pln))
74.         (setq pll (append plp (list p) pls))
75.         (setq d (apply '+ (mapcar '(lambda ( a b ) (distance a b)) pll (append (cdr pll) (list (car pll))))))
76.         (if (< d dmin)
77.           (setq dmin d r pll pp p)
78.         )
79.       )
80.     )
81.     (setq pln r)
82.     (setq pl (vl-remove pp pl))
83.   )
84.       (list
85.         '(0 . "LWPOLYLINE")
86.         '(100 . "AcDbEntity")
87.         '(100 . "AcDbPolyline")
88.         (cons 90 (length pln))
89.         (cons 70 (1+ (* (getvar 'plinegen) 128)))
90.         '(38 . 0.0)
91.       )
92.       (mapcar '(lambda ( x ) (cons 10 x)) pln)
93.       (list
94.         '(210 0.0 0.0 1.0)
95.         '(62 . 1)
96.       )
97.     )
98.   )
99.   (prompt "\nDistance : ") (princ (rtos dmin 2 50))
100.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds...")
101.   (princ)
102. )
103.

Regards, M.R.
« Last Edit: June 19, 2019, 12:43:46 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

#### ribarm

• Gator
• Posts: 3327
• 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)

#### ribarm

• Gator
• Posts: 3327
• Marko Ribar, architect
##### Re: (Challenge) To draw the shortest lwpolyline
« Reply #113 on: December 07, 2018, 12:37:56 PM »
Marko Ribar, d.i.a. (graduated engineer of architecture)

#### ribarm

• Gator
• Posts: 3327
• 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)
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.                           (lambda ( a b / c d )
22.                               (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))))
23.                                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
24.                                   (< c d)
25.                               )
26.                           )
27.                       )
28.                   )
29.               )
30.               (setq lstl (vl-remove-if-not (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
31.               (setq lst (vl-remove-if (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
32.               (setq lstl (vl-sort lstl (function (lambda ( a b ) (> (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))))))
33.               (setq lst (append lst lstl))
34.               (setq ch (list (cadr lst) (car lst)))
35.               (foreach pt (cddr lst)
36.                   (setq ch (cons pt ch))
38.                       (setq ch (cons pt (cddr ch)))
39.                   )
40.               )
41.               (reverse ch)
42.           )
43.       )
44.   )
45.
46.   ;; Clockwise-p  -  Lee Mac
47.   ;; Returns T if p1,p2,p3 are clockwise oriented or [s]collinear[/s]
48.
49.   (defun LM:Clockwise-p ( p1 p2 p3 )
50.       (<  (-  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
51.               (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
52.           )
53.           0.0
54.       )
55.   )
56.
57.   (setq ss (ssget '((0 . "POINT"))))
58.   (repeat (setq i (sslength ss))
59.     (setq pl (cons (mapcar '+ '(0 0) (cdr (assoc 10 (entget (ssname ss (setq i (1- i))))))) pl))
60.   )
61.   (setq ti (car (_vl-times)))
62.   (setq pl (vl-sort pl '(lambda ( a b ) (if (= (cadr a) (cadr b)) (> (car a) (car b)) (> (cadr a) (cadr b))))))
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 (member (nth k pln) (reverse pln))))
74.         (setq pls (cdr (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.       (list
86.         '(0 . "LWPOLYLINE")
87.         '(100 . "AcDbEntity")
88.         '(100 . "AcDbPolyline")
89.         (cons 90 (length pln))
90.         (cons 70 (1+ (* (getvar 'plinegen) 128)))
91.         '(38 . 0.0)
92.       )
93.       (mapcar '(lambda ( x ) (cons 10 x)) pln)
94.       (list
95.         '(210 0.0 0.0 1.0)
96.         '(62 . 1)
97.       )
98.     )
99.   )
100.   (prompt "\nDistance : ") (princ (rtos dmin 2 50))
101.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds...")
102.   (princ)
103. )
104.

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.                   " mm."
98.           ) ;_  strcat
99.    ) ;_  princ
100.    (princ)
101.   )
102. (test-lst-a (mapcar '(lambda ( x ) (cdr (assoc 10 (entget x)))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "POINT"))))))))
103.

Regards...
« Last Edit: July 10, 2019, 05:56:46 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

#### ribarm

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

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)

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

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)

#### ribarm

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

Regards, M.R.
« Last Edit: June 19, 2019, 12:46:24 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

#### ribarm

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

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)