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

0 Members and 1 Guest are viewing this topic.

Grrr1337

  • Swamp Rat
  • Posts: 660
Re: (Challenge) To draw the shortest lwpolyline
« Reply #120 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)
  )
)

ribarm

  • Water Moccasin
  • Posts: 1954
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #121 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 (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 (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: December 15, 2018, 01:17:38 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 1954
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #122 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 (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.  (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: December 21, 2018, 12:12:24 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 1954
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #123 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 (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.  ;;; (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: January 04, 2019, 09:50:35 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube