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

0 Members and 1 Guest are viewing this topic.

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #180 on: November 13, 2021, 03:47:46 AM »
Daniel, that post :
http://www.theswamp.org/index.php?topic=30434.msg607043#msg607043
and code in it had some lacks, but it gives concave hull as well good... It was late yesterday, so I've just put what I pulled that day as soon as possible... Lacks were in (_vl-sort) function - solved...; then in start of (trinagulate-MR) sub - triple (foreach) looping missed to find starting smallest triangle - I over programmed - solved...; at some point of routine - main (while) loop of (triangulate-MR), only very adjacent triangle was used for checking if next founded point with edge points (triangle to be created) intersects other triangles - previously was only adjacent triangle - solved...

As far as I can see, I think that there are no lacks now, so you can safely copy+paste it and save as *.lsp...
If you or someone else notice more than me - you know I am just the ordinary swamper... So your feedback would be very appreciated...

P.S. To my very brief observations - that routine strives to find smallest bounded area rather than perimeter if hull was to be created with some meanings (not just connections between points and returning back with the same path making invisible closure), though nowhere was pointed and searched and programmed for this - that's how it returned hull from adjacent triangles... So not original shortest TSP, but rather some different TSP task...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #181 on: November 13, 2021, 10:51:13 AM »
I've added another variant of TSP-triangulate-MMR routine - look at link from previous post...

The only difference from "*-old.lsp" version is that all occurrences of (min) function is replaced with (+) function...
Perhaps, new version will yield more closer results to real TSP task... (but that's just perhaps...)
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #182 on: November 15, 2021, 04:40:42 AM »
More variants...

Recursion - there is tree branching - terribly slow - even for 40 pts...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:TSP-recurse+foo-subs ( / MR:ConvexHull-ptsonHull LM:ConvexHull-ptsonHull LM:Clockwise-p car-sort _vl-sort unique chkinters chkinters-p foo1 foo2 foo3 foo4 processfoos process ss ti i pl plst inpl *return* d ) ;; *return* is processed through recursions - lexical global variable
  2.  
  3.   ;; Convex Hull  -  Lee Mac
  4.   ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
  5.   ;; Mod by M.R.  -  uses (car-sort) and (_vl-sort) subs...
  6.  
  7.   (defun MR:ConvexHull-ptsonHull ( lst / ch p0 lstl )
  8.     (cond
  9.       ( (< (length lst) 4) (_vl-sort lst (function (lambda ( a b ) (if (= (cadr a) (cadr b)) (< (car a) (car b)) (< (cadr a) (cadr b)))))) )
  10.       ( (setq p0 (car lst))
  11.         (foreach p1 (cdr lst)
  12.           (if (or (< (cadr p1) (cadr p0)) (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0))))
  13.             (setq p0 p1)
  14.           )
  15.         )
  16.         (setq lst (vl-remove p0 lst))
  17.         (setq lst (append (list p0) lst))
  18.         (setq lst
  19.           (_vl-sort lst
  20.             (function
  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.           (if (equal pt (last lst))
  37.             (setq ch (cons pt ch))
  38.             (if (or (equal (angle (car ch) pt) (car-sort (mapcar (function (lambda ( x ) (angle (car ch) x))) (member pt lst)) (function <)) 1e-6) (equal (distance pt (cadr ch)) (+ (distance pt (car ch)) (distance (car ch) (cadr ch))) 1e-6))
  39.               (setq ch (cons pt ch))
  40.             )
  41.           )
  42.         )
  43.         (reverse ch)
  44.       )
  45.     )
  46.   )
  47.  
  48.   ;; Convex Hull  -  Lee Mac
  49.   ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
  50.  
  51.   (defun LM:ConvexHull-ptsonHull ( lst / ch p0 lstl )
  52.     (cond
  53.       ( (< (length lst) 4) lst)
  54.       ( (setq p0 (car lst))
  55.         (foreach p1 (cdr lst)
  56.           (if (or (< (cadr p1) (cadr p0)) (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0))))
  57.             (setq p0 p1)
  58.           )
  59.         )
  60.         (setq lst (vl-remove p0 lst))
  61.         (setq lst (append (list p0) lst))
  62.         (setq lst
  63.           (_vl-sort lst
  64.             (function
  65.               (lambda ( a b / c d )
  66.                 (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))))
  67.                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
  68.                   (< c d)
  69.                 )
  70.               )
  71.             )
  72.           )
  73.         )
  74.         (setq lstl (vl-remove-if-not (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
  75.         (setq lst (vl-remove-if (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
  76.         (setq lstl (_vl-sort lstl (function (lambda ( a b ) (> (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))))))
  77.         (setq lst (append lst lstl))
  78.         (setq ch (list (cadr lst) (car lst)))
  79.         (foreach pt (cddr lst)
  80.           (setq ch (cons pt ch))
  81.           (while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt) (not (equal (distance (caddr ch) pt) (+ (distance (caddr ch) (cadr ch)) (distance (cadr ch) pt)) 1e-8)))
  82.             (setq ch (cons pt (cddr ch)))
  83.           )
  84.         )
  85.         (reverse ch)
  86.       )
  87.     )
  88.   )
  89.  
  90.   ;; Clockwise-p  -  Lee Mac
  91.   ;; Returns T if p1,p2,p3 are clockwise oriented or [s]collinear[/s]
  92.  
  93.   (defun LM:Clockwise-p ( p1 p2 p3 )
  94.     (minusp (- (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1))) (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))))
  95.   )
  96.  
  97.   (defun car-sort ( lst cmp / rtn )
  98.     (setq rtn (car lst))
  99.     (foreach itm (cdr lst)
  100.       (if (apply cmp (list itm rtn))
  101.         (setq rtn itm)
  102.       )
  103.     )
  104.     rtn
  105.   )
  106.  
  107.   (defun _vl-sort ( l f / *q* ll ff gg )
  108.     (if (= (type f) 'sym)
  109.       (setq f (eval f))
  110.     )
  111.     (while (setq *q* (car l))
  112.       (setq ll
  113.         (if (null ll)
  114.           (cons *q* ll)
  115.           (cond
  116.             ( (apply f (list (last ll) *q*))
  117.               (append ll (list *q*))
  118.             )
  119.             ( (apply f (list *q* (car ll)))
  120.               (cons *q* ll)
  121.             )
  122.             ( t
  123.               (setq ff nil)
  124.               (setq gg (apply (function append) (append (mapcar (function (lambda ( *xxx* *yyy* ) (if (null ff) (if (apply f (list *q* *yyy*)) (progn (setq ff t) (list *xxx* *q*)) (list *xxx*)) (list *xxx*)))) ll (cdr ll)) (list (list (last ll))))))
  125.               (if (null ff)
  126.                 (append ll (list *q*))
  127.                 gg
  128.               )
  129.             )
  130.           )
  131.         )
  132.       )
  133.       (setq l (cdr l))
  134.     )
  135.     ll
  136.   )
  137.  
  138.   (defun unique ( l / a ll )
  139.     (while (setq a (car l))
  140.       (if (vl-some (function (lambda ( x ) (equal x a 1e-6))) (cdr l))
  141.         (setq ll (cons a ll) l (vl-remove-if (function (lambda ( x ) (equal x a 1e-6))) (cdr l)))
  142.         (setq ll (cons a ll) l (cdr l))
  143.       )
  144.     )
  145.     (reverse ll)
  146.   )
  147.  
  148.   (defun chkinters ( pl / lil k a ilil pre mid suf )
  149.     (setq lil (mapcar (function list) pl (append (cdr pl) (list (car pl)))))
  150.     (setq k -1)
  151.     (while (and (< (setq k (1+ k)) (length lil)) (setq a (nth k lil)))
  152.       (setq ilil (vl-some (function (lambda ( b / ip ) (if (and (setq ip (inters (car a) (cadr a) (car b) (cadr b))) (not (equal ip (car a) 1e-6)) (not (equal ip (cadr a) 1e-6)) (not (equal ip (car b) 1e-6)) (not (equal ip (cadr b) 1e-6))) (list a b)))) (vl-remove a lil)))
  153.       (if ilil
  154.         (progn
  155.           (setq pre (reverse (cdr (member (car ilil) (reverse lil)))))
  156.           (setq mid (cdr (member (car ilil) lil)))
  157.           (setq mid (cdr (member (cadr ilil) (reverse mid))))
  158.           (setq mid (mapcar (function reverse) mid))
  159.           (setq suf (cdr (member (cadr ilil) lil)))
  160.           (setq lil (append pre (list (list (car (car ilil)) (car (cadr ilil)))) mid (list (list (cadr (car ilil)) (cadr (cadr ilil)))) suf))
  161.           (setq pre nil mid nil suf nil)
  162.           (setq ilil nil k -1)
  163.         )
  164.       )
  165.     )
  166.     (mapcar (function car) lil)
  167.   )
  168.  
  169.   (defun chkinters-p ( l / lil )
  170.     (setq lil (mapcar (function list) l (append (cdr l) (list (car l)))))
  171.     (vl-some (function (lambda ( x ) (vl-some (function (lambda ( y ) (inters (car x) (cadr x) (car y) (cadr y)))) (vl-remove (if (= (vl-position x lil) 0) (last lil) (nth (1- (vl-position x lil)) lil)) (vl-remove (if (= (vl-position x lil) (1- (length lil))) (car lil) (nth (1+ (vl-position x lil)) lil)) (vl-remove x lil)))))) lil)
  172.   )
  173.  
  174.   (defun foo1 ( plst / l )
  175.     (setq l plst)
  176.     (while (and (null xxx1) (vl-some (function (lambda ( a b / l1 l2 c ) (setq l1 l c (vl-some (function (lambda ( x ) (if (< (distance a x) (distance a b)) x))) (vl-remove a (vl-remove b l)))) (if c (setq l2 (append (reverse (member a (reverse (vl-remove c l)))) (list c) (if (/= (vl-position a l) (1- (length l))) (member b (vl-remove c l))))) (setq l2 nil)) (if (and l2 (or (< (length (unique l2)) (length l2)) (< (length l2) (length l1)))) (setq xxx1 (list l1 l2 c (list a b)))) (if (and l2 (not (chkinters-p l2)) (> (apply (function +) (mapcar (function distance) l1 (append (cdr l1) (list (car l1))))) (apply (function +) (mapcar (function distance) l2 (append (cdr l2) (list (car l2))))))) (setq l l2) (if l2 (progn (setq l (append (cdr l) (list (car l)))) nil))))) l (append (cdr l) (list (car l))))))
  177.     l
  178.   )
  179.  
  180.   (defun foo2 ( plst / l )
  181.     (setq l plst)
  182.     (while (and (null xxx2) (vl-some (function (lambda ( a b / l1 l2 c d e ) (setq l1 l c (vl-some (function (lambda ( x ) (if (< (- (+ (distance a x) (distance x b)) (distance a b)) (- (+ (distance (setq d (if (= (vl-position x l) 0) (last l) (nth (1- (vl-position x l)) l))) x) (distance x (setq e (if (= (vl-position x l) (1- (length l))) (car l) (nth (1+ (vl-position x l)) l))))) (distance d e))) x))) (vl-remove a (vl-remove b l)))) (if c (setq l2 (append (reverse (member a (reverse (vl-remove c l)))) (list c) (if (/= (vl-position a l) (1- (length l))) (vl-remove c (member b l))))) (setq l2 nil)) (if (and l2 (or (< (length (unique l2)) (length l2)) (< (length l2) (length l1)))) (setq xxx2 (list l1 l2 c d e (list a b)))) (if (and l2 (not (chkinters-p l2)) (> (apply (function +) (mapcar (function distance) l1 (append (cdr l1) (list (car l1))))) (apply (function +) (mapcar (function distance) l2 (append (cdr l2) (list (car l2))))))) (setq l l2) (if l2 (progn (setq l (append (cdr l) (list (car l)))) nil))))) l (append (cdr l) (list (car l))))))
  183.     l
  184.   )
  185.  
  186.   (defun foo3 ( plst / l )
  187.     (setq l plst)
  188.     (while (and (null xxx3) (vl-some (function (lambda ( a b c / l1 l2 ) (setq l1 l l2 (append (cond ( (= (vl-position a l) (- (length l) 2)) (cdr (reverse (member (cdr (reverse l))))) ) ( (= (vl-position a l) (1- (length l))) (cddr l) ) ( t (reverse (member a (reverse l))) )) (list c b) (cdddr (member a l)))) (if (or (< (length (unique l2)) (length l2)) (< (length l2) (length l1))) (setq xxx3 (list l1 l2 (list a b c)))) (if (and (not (chkinters-p l2)) (> (apply (function +) (mapcar (function distance) l1 (append (cdr l1) (list (car l1))))) (apply (function +) (mapcar (function distance) l2 (append (cdr l2) (list (car l2))))))) (setq l l2) (progn (setq l (append (cdr l) (list (car l)))) nil)))) l (append (cdr l) (list (car l))) (append (cddr l) (list (car l) (cadr l))))))
  189.     l
  190.   )
  191.  
  192.   (defun foo4 ( plst / l )
  193.     (setq l plst)
  194.     (while (and (null xxx4) (vl-some (function (lambda ( a b c / l1 l2 edge ) (setq l1 l edge (vl-some (function (lambda ( x ) (if (< (- (+ (distance (car x) b) (distance b (cadr x))) (distance (car x) (cadr x))) (- (+ (distance a b) (distance b c)) (distance a c))) x))) (vl-remove (list a b) (vl-remove (list b c) (mapcar (function list) (append l l) (append (append (cdr l) (list (car l))) (append (cdr l) (list (car l))))))))) (if edge (setq l2 (append (if (= (vl-position (car edge) l) (1- (length l))) (cdr (vl-remove b l)) (reverse (member (car edge) (reverse (vl-remove b l))))) (list b) (if (= (vl-position (car edge) l) (1- (length l))) (list (cadr edge)) (member (cadr edge) (vl-remove b l))))) (setq l2 nil)) (if (and l2 (or (< (length (unique l2)) (length l2)) (< (length l2) (length l1)))) (setq xxx4 (list l1 l2 edge (list a b c)))) (if (and l2 (not (chkinters-p l2)) (> (apply (function +) (mapcar (function distance) l1 (append (cdr l1) (list (car l1))))) (apply (function +) (mapcar (function distance) l2 (append (cdr l2) (list (car l2))))))) (setq l l2) (if l2 (progn (setq l (append (cdr l) (list (car l)))) nil))))) l (append (cdr l) (list (car l))) (append (cddr l) (list (car l) (cadr l))))))
  195.     l
  196.   )
  197.  
  198.   (defun processfoos ( plst / d dd ddd plst1 plst2 plst3 plst4 d1 d2 d3 d4 )
  199.     (if (< (length (unique plst)) (length plst))
  200.       (progn
  201.         (prompt "\nError in reference list for processing (foo) subs - it contains duplicate points... Quitting...")
  202.         (exit)
  203.       )
  204.     )
  205.     (setq d 1e+99 dd 0)
  206.     (while (> d dd)
  207.       (setq plst1 (foo1 plst))
  208.       (if (or (< (length (unique plst1)) (length plst1)) (< (length plst1) (length plst)))
  209.         (progn
  210.           (prompt "\nError in (foo1) - return list has less points than reference one or output list contains duplicate points... Quitting...")
  211.           (exit)
  212.         )
  213.       )
  214.       (if (chkinters-p plst1)
  215.         (setq plst1 (chkinters plst1))
  216.       )
  217.       (setq d1 (apply (function +) (mapcar (function distance) plst1 (append (cdr plst1) (list (car plst1))))))
  218.       (setq plst2 (foo2 plst))
  219.       (if (or (< (length (unique plst2)) (length plst2)) (< (length plst2) (length plst)))
  220.         (progn
  221.           (prompt "\nError in (foo2) - return list has less points than reference one or output list contains duplicate points... Quitting...")
  222.           (exit)
  223.         )
  224.       )
  225.       (if (chkinters-p plst2)
  226.         (setq plst2 (chkinters plst2))
  227.       )
  228.       (setq d2 (apply (function +) (mapcar (function distance) plst2 (append (cdr plst2) (list (car plst2))))))
  229.       (setq plst3 (foo3 plst))
  230.       (if (or (< (length (unique plst3)) (length plst3)) (< (length plst3) (length plst)))
  231.         (progn
  232.           (prompt "\nError in (foo3) - return list has less points than reference one or output list contains duplicate points... Quitting...")
  233.           (exit)
  234.         )
  235.       )
  236.       (if (chkinters-p plst3)
  237.         (setq plst3 (chkinters plst3))
  238.       )
  239.       (setq d3 (apply (function +) (mapcar (function distance) plst3 (append (cdr plst3) (list (car plst3))))))
  240.       (setq plst4 (foo4 plst))
  241.       (if (or (< (length (unique plst4)) (length plst4)) (< (length plst4) (length plst)))
  242.         (progn
  243.           (prompt "\nError in (foo4) - return list has less points than reference one or output list contains duplicate points... Quitting...")
  244.           (exit)
  245.         )
  246.       )
  247.       (if (chkinters-p plst4)
  248.         (setq plst4 (chkinters plst4))
  249.       )
  250.       (setq d4 (apply (function +) (mapcar (function distance) plst4 (append (cdr plst4) (list (car plst4))))))
  251.       (setq dd (min d1 d2 d3 d4))
  252.       (cond
  253.         ( (= dd d1)
  254.           (setq plst plst1)
  255.         )
  256.         ( (= dd d2)
  257.           (setq plst plst2)
  258.         )
  259.         ( (= dd d3)
  260.           (setq plst plst3)
  261.         )
  262.         ( (= dd d4)
  263.           (setq plst plst4)
  264.         )
  265.       )
  266.       (if (equal ddd dd 1e-6)
  267.         (setq d dd)
  268.         (setq ddd dd)
  269.       )
  270.     )
  271.     plst
  272.   )
  273.  
  274.   (defun process ( pl inpl / dd lil li l lll lx ly d r rr ll r1 r2 lst )
  275.     (if inpl
  276.       (progn
  277.         (setq dd 1e+99)
  278.         (foreach p pl
  279.           (foreach pp inpl
  280.             (setq lil (cons (list p pp) lil))
  281.           )
  282.         )
  283.         (setq l pl)
  284.         (foreach li lil
  285.           (if (< (apply (function +) (mapcar (function distance) (setq lx (append (reverse (member (car li) (reverse l))) (list (cadr li)) (cdr (member (car li) l)))) (append (cdr lx) (list (car lx))))) (apply (function +) (mapcar (function distance) (setq ly (append (reverse (cdr (member (car li) (reverse l)))) (list (cadr li)) (member (car li) l))) (append (cdr ly) (list (car ly))))))
  286.             (setq lll lx)
  287.             (setq lll ly)
  288.           )
  289.           (setq d (apply (function +) (mapcar (function distance) lll (append (cdr lll) (list (car lll))))))
  290.           (if (< d dd)
  291.             (setq r lll rr (cadr li) dd d)
  292.           )
  293.         )
  294.         (setq ll (vl-remove rr inpl))
  295.         (setq r1 (list r ll))
  296.         (setq dd 1e+99)
  297.         (setq lil (vl-remove-if-not (function (lambda ( x ) (equal (apply (function distance) (car-sort lil (function (lambda ( a b ) (< (distance (car a) (cadr a)) (distance (car b) (cadr b))))))) (distance (car x) (cadr x)) 1e-6))) lil))
  298.         (setq l pl)
  299.         (foreach li lil
  300.           (if (< (apply (function +) (mapcar (function distance) (setq lx (append (reverse (member (car li) (reverse l))) (list (cadr li)) (cdr (member (car li) l)))) (append (cdr lx) (list (car lx))))) (apply (function +) (mapcar (function distance) (setq ly (append (reverse (cdr (member (car li) (reverse l)))) (list (cadr li)) (member (car li) l))) (append (cdr ly) (list (car ly))))))
  301.             (setq lll lx)
  302.             (setq lll ly)
  303.           )
  304.           (setq d (apply (function +) (mapcar (function distance) lll (append (cdr lll) (list (car lll))))))
  305.           (if (< d dd)
  306.             (setq r lll rr (cadr li) dd d)
  307.           )
  308.         )
  309.         (setq ll (vl-remove rr inpl))
  310.         (setq r2 (list r ll))
  311.         (if (equal r1 r2 1e-6)
  312.           (if (null (cadr r1))
  313.             (if (null *return*)
  314.               (setq *return* (processfoos (car r1)))
  315.               (progn
  316.                 (setq lst (processfoos (car r1)))
  317.                 (setq d (apply (function +) (mapcar (function distance) lst (append (cdr lst) (list (car lst))))))
  318.                 (if (< d (apply (function +) (mapcar (function distance) *return* (append (cdr *return*) (list (car *return*))))))
  319.                   (setq *return* lst)
  320.                 )
  321.               )
  322.             )
  323.             (process (car r1) (cadr r1))
  324.           )
  325.           (foreach x (list r1 r2)
  326.             (if (null (cadr x))
  327.               (if (null *return*)
  328.                 (setq *return* (processfoos (car x)))
  329.                 (progn
  330.                   (setq lst (processfoos (car x)))
  331.                   (setq d (apply (function +) (mapcar (function distance) lst (append (cdr lst) (list (car lst))))))
  332.                   (if (< d (apply (function +) (mapcar (function distance) *return* (append (cdr *return*) (list (car *return*))))))
  333.                     (setq *return* lst)
  334.                   )
  335.                 )
  336.               )
  337.               (process (car x) (cadr x))
  338.             )
  339.           )
  340.         )
  341.       )
  342.     )
  343.   )
  344.  
  345.   (prompt "\nSelect 2D points...")
  346.   (if (setq ss (ssget (list (cons 0 "POINT"))))
  347.     (progn
  348.       (setq ti (car (_vl-times)))
  349.       (repeat (setq i (sslength ss))
  350.         (setq pl (cons (mapcar (function +) (list 0.0 0.0) (cdr (assoc 10 (entget (ssname ss (setq i (1- i))))))) pl))
  351.       )
  352.       (setq plst (MR:ConvexHull-ptsonHull (setq pl (unique pl))))
  353.       (setq inpl (vl-remove-if (function (lambda ( x ) (vl-position x plst))) pl))
  354.       (process plst inpl)
  355.       (entmake
  356.         (append
  357.           (list
  358.             (cons 0 "LWPOLYLINE")
  359.             (cons 100 "AcDbEntity")
  360.             (cons 100 "AcDbPolyline")
  361.             (cons 90 (length *return*))
  362.             (cons 70 (1+ (* 128 (getvar 'plinegen))))
  363.             (cons 38 0.0)
  364.           )
  365.           (mapcar (function (lambda ( p ) (cons 10 p))) *return*)
  366.           (list (list 210 0.0 0.0 1.0))
  367.         )
  368.       )
  369.       (setq d (apply (function +) (mapcar (function distance) *return* (append (cdr *return*) (list (car *return*))))))
  370.       (prompt "\nPath length : ") (princ (rtos d 2 20))
  371.       (prompt "\nElapsed time : ") (princ (rtos (- (car (_vl-times)) ti) 2 20)) (prompt " milliseconds...")
  372.     )
  373.   )
  374.   (princ)
  375. )
  376.  
« Last Edit: November 18, 2021, 11:39:45 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #183 on: November 15, 2021, 04:42:46 AM »
This one is fast, but result is pretty wrong...

Anyway some different approach - using multiple Convex Hulls and then solving from the most inside one to outside...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:TSP-mchulls ( / MR:ConvexHull-ptsonHull LM:ConvexHull-ptsonHull LM:Clockwise-p car-sort _vl-sort unique chkinters process1 process2 process3 ss ti i pl plst inpl chulls lst out r1 r2 r3 r11 r12 r21 r22 r31 r32 d11 d12 d21 d22 d31 d32 r d flag )
  2.  
  3.   ;; Convex Hull  -  Lee Mac
  4.   ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
  5.   ;; Mod by M.R.  -  uses (car-sort) and (_vl-sort) subs...
  6.  
  7.   (defun MR:ConvexHull-ptsonHull ( lst / ch p0 lstl )
  8.     (cond
  9.       ( (< (length lst) 4) (_vl-sort lst (function (lambda ( a b ) (if (= (cadr a) (cadr b)) (< (car a) (car b)) (< (cadr a) (cadr b)))))) )
  10.       ( (setq p0 (car lst))
  11.         (foreach p1 (cdr lst)
  12.           (if (or (< (cadr p1) (cadr p0)) (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0))))
  13.             (setq p0 p1)
  14.           )
  15.         )
  16.         (setq lst (vl-remove p0 lst))
  17.         (setq lst (append (list p0) lst))
  18.         (setq lst
  19.           (_vl-sort lst
  20.             (function
  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 (caddr lst) (cadr lst) (car lst)))
  35.         (foreach pt (cdddr lst)
  36.           (if (equal pt (last lst))
  37.             (setq ch (cons pt ch))
  38.             (if (or (equal (angle (car ch) pt) (car-sort (mapcar (function (lambda ( x ) (angle (car ch) x))) (member pt lst)) (function <)) 1e-6) (equal (distance pt (cadr ch)) (+ (distance pt (car ch)) (distance (car ch) (cadr ch))) 1e-6))
  39.               (setq ch (cons pt ch))
  40.             )
  41.           )
  42.         )
  43.         (reverse ch)
  44.       )
  45.     )
  46.   )
  47.  
  48.   ;; Convex Hull  -  Lee Mac
  49.   ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
  50.  
  51.   (defun LM:ConvexHull-ptsonHull ( lst / ch p0 lstl )
  52.     (cond
  53.       ( (< (length lst) 4) lst)
  54.       ( (setq p0 (car lst))
  55.         (foreach p1 (cdr lst)
  56.           (if (or (< (cadr p1) (cadr p0)) (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0))))
  57.             (setq p0 p1)
  58.           )
  59.         )
  60.         (setq lst (vl-remove p0 lst))
  61.         (setq lst (append (list p0) lst))
  62.         (setq lst
  63.           (_vl-sort lst
  64.             (function
  65.               (lambda ( a b / c d )
  66.                 (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))))
  67.                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
  68.                   (< c d)
  69.                 )
  70.               )
  71.             )
  72.           )
  73.         )
  74.         (setq lstl (vl-remove-if-not (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
  75.         (setq lst (vl-remove-if (function (lambda ( x ) (equal (angle p0 (last lst)) (angle p0 x) 1e-8))) lst))
  76.         (setq lstl (_vl-sort lstl (function (lambda ( a b ) (> (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))))))
  77.         (setq lst (append lst lstl))
  78.         (setq ch (list (cadr lst) (car lst)))
  79.         (foreach pt (cddr lst)
  80.           (setq ch (cons pt ch))
  81.           (while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt) (not (equal (distance (caddr ch) pt) (+ (distance (caddr ch) (cadr ch)) (distance (cadr ch) pt)) 1e-8)))
  82.             (setq ch (cons pt (cddr ch)))
  83.           )
  84.         )
  85.         (reverse ch)
  86.       )
  87.     )
  88.   )
  89.  
  90.   ;; Clockwise-p  -  Lee Mac
  91.   ;; Returns T if p1,p2,p3 are clockwise oriented or [s]collinear[/s]
  92.  
  93.   (defun LM:Clockwise-p ( p1 p2 p3 )
  94.     (minusp (- (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1))) (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))))
  95.   )
  96.  
  97.   (defun car-sort ( lst cmp / rtn )
  98.     (setq rtn (car lst))
  99.     (foreach itm (cdr lst)
  100.       (if (apply cmp (list itm rtn))
  101.         (setq rtn itm)
  102.       )
  103.     )
  104.     rtn
  105.   )
  106.  
  107.   (defun _vl-sort ( l f / *q* ll ff gg )
  108.     (if (= (type f) 'sym)
  109.       (setq f (eval f))
  110.     )
  111.     (while (setq *q* (car l))
  112.       (setq ll
  113.         (if (null ll)
  114.           (cons *q* ll)
  115.           (cond
  116.             ( (apply f (list (last ll) *q*))
  117.               (append ll (list *q*))
  118.             )
  119.             ( (apply f (list *q* (car ll)))
  120.               (cons *q* ll)
  121.             )
  122.             ( t
  123.               (setq ff nil)
  124.               (setq gg (apply (function append) (append (mapcar (function (lambda ( *xxx* *yyy* ) (if (null ff) (if (apply f (list *q* *yyy*)) (progn (setq ff t) (list *xxx* *q*)) (list *xxx*)) (list *xxx*)))) ll (cdr ll)) (list (list (last ll))))))
  125.               (if (null ff)
  126.                 (append ll (list *q*))
  127.                 gg
  128.               )
  129.             )
  130.           )
  131.         )
  132.       )
  133.       (setq l (cdr l))
  134.     )
  135.     ll
  136.   )
  137.  
  138.   (defun unique ( l / a ll )
  139.     (while (setq a (car l))
  140.       (if (vl-some (function (lambda ( x ) (equal x a 1e-6))) (cdr l))
  141.         (setq ll (cons a ll) l (vl-remove-if (function (lambda ( x ) (equal x a 1e-6))) (cdr l)))
  142.         (setq ll (cons a ll) l (cdr l))
  143.       )
  144.     )
  145.     (reverse ll)
  146.   )
  147.  
  148.   (defun chkinters ( pl / lil k a ilil pre mid suf )
  149.     (setq lil (mapcar (function list) pl (append (cdr pl) (list (car pl)))))
  150.     (setq k -1)
  151.     (while (and (< (setq k (1+ k)) (length lil)) (setq a (nth k lil)))
  152.       (setq ilil (vl-some (function (lambda ( b / ip ) (if (and (setq ip (inters (car a) (cadr a) (car b) (cadr b))) (not (equal ip (car a) 1e-6)) (not (equal ip (cadr a) 1e-6)) (not (equal ip (car b) 1e-6)) (not (equal ip (cadr b) 1e-6))) (list a b)))) (vl-remove a lil)))
  153.       (if ilil
  154.         (progn
  155.           (setq pre (reverse (cdr (member (car ilil) (reverse lil)))))
  156.           (setq mid (cdr (member (car ilil) lil)))
  157.           (setq mid (cdr (member (cadr ilil) (reverse mid))))
  158.           (setq mid (mapcar (function reverse) mid))
  159.           (setq suf (cdr (member (cadr ilil) lil)))
  160.           (setq lil (append pre (list (list (car (car ilil)) (car (cadr ilil)))) mid (list (list (cadr (car ilil)) (cadr (cadr ilil)))) suf))
  161.           (setq pre nil mid nil suf nil)
  162.           (setq ilil nil k -1)
  163.         )
  164.       )
  165.     )
  166.     (mapcar (function car) lil)
  167.   )
  168.  
  169.   (defun process1 ( lst out / dd edgs edges edgesn1 edgesn2 lstt1 lstt2 lstt d r dd1 dd2 rr1 rr2 )
  170.     (setq dd 1e+99)
  171.     (foreach pedge (setq edgs (mapcar (function list) lst (append (cdr lst) (list (car lst)))))
  172.       (foreach ppedge (setq edges (mapcar (function list) out (append (cdr out) (list (car out)))))
  173.         (setq edgesn1 (subst pedge ppedge edges))
  174.         (setq edgesn2 (subst (reverse pedge) ppedge edges))
  175.         (setq edgesn1 (apply (function append) (mapcar (function (lambda ( x y ) (if (not (equal (cadr x) (car y) 1e-6)) (list x (list (cadr x) (car y))) (list x)))) edgesn1 (append (cdr edgesn1) (list (car edgesn1))))))
  176.         (setq edgesn2 (apply (function append) (mapcar (function (lambda ( x y ) (if (not (equal (cadr x) (car y) 1e-6)) (list x (list (cadr x) (car y))) (list x)))) edgesn2 (append (cdr edgesn2) (list (car edgesn2))))))
  177.         (if (and (or (cdr (member pedge edgs)) (cdr (member pedge (reverse edgs)))) (or (cdr (member pedge (reverse edgs))) (cdr (member pedge edgs))))
  178.           (progn
  179.             (setq edgesn1 (apply (function append) (mapcar (function (lambda ( x ) (if (equal x pedge 1e-6) (mapcar (function reverse) (append (cdr (member pedge edgs)) (cdr (member pedge (reverse edgs))))) (list x)))) edgesn1)))
  180.             (setq edgesn2 (apply (function append) (mapcar (function (lambda ( x ) (if (equal x (reverse pedge) 1e-6) (append (cdr (member pedge (reverse edgs))) (cdr (member pedge edgs))) (list x)))) edgesn2)))
  181.             (setq lstt1 (mapcar (function car) edgesn1))
  182.             (setq lstt2 (mapcar (function car) edgesn2))
  183.             (if (< (apply (function +) (mapcar (function distance) lstt1 (append (cdr lstt1) (list (car lstt1))))) (apply (function +) (mapcar (function distance) lstt2 (append (cdr lstt2) (list (car lstt2))))))
  184.               (setq lstt lstt1)
  185.               (setq lstt lstt2)
  186.             )
  187.             (if (< (setq d (apply (function +) (mapcar (function distance) lstt (append (cdr lstt) (list (car lstt)))))) dd)
  188.               (setq r lstt dd d)
  189.             )
  190.           )
  191.         )
  192.       )
  193.     )
  194.     (setq dd1 (apply (function +) (mapcar (function distance) r (append (cdr r) (list (car r))))) rr1 (unique r))
  195.     (setq r (reverse r))
  196.     (setq dd2 (apply (function +) (mapcar (function distance) r (append (cdr r) (list (car r))))) rr2 (unique r))
  197.     (if (< dd1 dd2)
  198.       (setq r rr1)
  199.       (setq r rr2)
  200.     )
  201.     r
  202.   )
  203.  
  204.   (defun process2 ( lst out / q qq edgs qqq inpl singles xxx aaa ggg bbb gqqq dd edges edgesn1 edgesn2 lstt1 lstt2 lstt d r lil li dd1 dd2 rr1 rr2 )
  205.     (setq q (MR:ConvexHull-ptsonHull lst))
  206.     (setq qq (mapcar (function list) q (append (cdr q) (list (car q)))))
  207.     (setq qqq (vl-remove-if (function (lambda ( x ) (or (vl-position x qq) (vl-position (reverse x) qq)))) (setq edgs (mapcar (function list) lst (append (cdr lst) (list (car lst)))))))
  208.     (setq inpl (vl-remove-if (function (lambda ( x ) (vl-position x (apply (function append) qqq)))) q))
  209.     (setq singles (vl-remove-if-not (function (lambda ( x ) (= (length (vl-remove-if (function (lambda ( y ) (equal x y 1e-6))) (apply (function append) qqq))) (1- (length (apply (function append) qqq)))))) (apply (function append) qqq)))
  210.     (foreach x singles
  211.       (setq xxx x)
  212.       (if (setq aaa (vl-some (function (lambda ( y ) (if (vl-position x y) y))) qqq))
  213.         (progn
  214.           (setq ggg (cons aaa ggg))
  215.           (while (setq bbb (vl-some (function (lambda ( y ) (if (vl-position (setq xxx (car (vl-remove xxx aaa))) y) y))) (setq qqq (vl-remove aaa qqq))))
  216.             (setq ggg (cons bbb ggg))
  217.             (setq aaa bbb)
  218.           )
  219.           (setq gqqq (cons (reverse ggg) gqqq))
  220.           (setq ggg nil)
  221.         )
  222.       )
  223.     )
  224.     (setq gqqq (reverse gqqq))
  225.     (setq outlst out)
  226.     (if gqqq
  227.       (repeat (length gqqq)
  228.         (setq dd 1e+99)
  229.         (foreach g gqqq
  230.           (foreach ppedge (setq edges (mapcar (function list) outlst (append (cdr outlst) (list (car outlst)))))
  231.             (setq edgesn1 (append (reverse (cdr (member ppedge (reverse edges)))) g (cdr (member ppedge edges))))
  232.             (setq edgesn2 (append (reverse (cdr (member ppedge (reverse edges)))) (reverse (mapcar (function reverse) g)) (cdr (member ppedge edges))))
  233.             (setq edgesn1 (apply (function append) (mapcar (function (lambda ( x y ) (if (not (equal (cadr x) (car y) 1e-6)) (list x (list (cadr x) (car y))) (list x)))) edgesn1 (append (cdr edgesn1) (list (car edgesn1))))))
  234.             (setq edgesn2 (apply (function append) (mapcar (function (lambda ( x y ) (if (not (equal (cadr x) (car y) 1e-6)) (list x (list (cadr x) (car y))) (list x)))) edgesn2 (append (cdr edgesn2) (list (car edgesn2))))))
  235.             (setq lstt1 (mapcar (function car) edgesn1))
  236.             (setq lstt2 (mapcar (function car) edgesn2))
  237.             (if (< (apply (function +) (mapcar (function distance) lstt1 (append (cdr lstt1) (list (car lstt1))))) (apply (function +) (mapcar (function distance) lstt2 (append (cdr lstt2) (list (car lstt2))))))
  238.               (setq lstt lstt1)
  239.               (setq lstt lstt2)
  240.             )
  241.             (if (< (setq d (apply (function +) (mapcar (function distance) lstt (append (cdr lstt) (list (car lstt)))))) dd)
  242.               (setq r lstt dd d)
  243.             )
  244.           )
  245.         )
  246.         (setq outlst r)
  247.         (setq gqqq (vl-remove-if-not (function (lambda ( x ) (vl-some (function (lambda ( y ) (not (vl-position y r)))) (apply (function append) x)))) gqqq))
  248.       )
  249.     )
  250.     (foreach pp inpl
  251.       (if (null lil)
  252.         (setq lil (mapcar (function list) outlst (append (cdr outlst) (list (car outlst)))))
  253.       )
  254.       (setq li (car-sort lil (function (lambda ( a b ) (< (- (+ (distance (car a) pp) (distance pp (cadr a))) (distance (car a) (cadr a))) (- (+ (distance (car b) pp) (distance pp (cadr b))) (distance (car b) (cadr b))))))))
  255.       (setq lil (apply (function append) (mapcar (function (lambda ( x ) (if (equal x li 1e-6) (list (list (car li) pp) (list pp (cadr li))) (list x)))) lil)))
  256.     )
  257.     (if inpl
  258.       (setq r (mapcar (function car) lil))
  259.     )
  260.     (setq dd1 (apply (function +) (mapcar (function distance) r (append (cdr r) (list (car r))))) rr1 (unique r))
  261.     (setq r (reverse r))
  262.     (setq dd2 (apply (function +) (mapcar (function distance) r (append (cdr r) (list (car r))))) rr2 (unique r))
  263.     (if (< dd1 dd2)
  264.       (setq r rr1)
  265.       (setq r rr2)
  266.     )
  267.     r
  268.   )
  269.  
  270.   (defun process3 ( lst out / lil li r dd1 dd2 rr1 rr2 )
  271.     (foreach pp lst
  272.       (if (null lil)
  273.         (setq lil (mapcar (function list) out (append (cdr out) (list (car out)))))
  274.       )
  275.       (setq li (car-sort lil (function (lambda ( a b ) (< (- (+ (distance (car a) pp) (distance pp (cadr a))) (distance (car a) (cadr a))) (- (+ (distance (car b) pp) (distance pp (cadr b))) (distance (car b) (cadr b))))))))
  276.       (setq lil (apply (function append) (mapcar (function (lambda ( x ) (if (equal x li 1e-6) (list (list (car li) pp) (list pp (cadr li))) (list x)))) lil)))
  277.     )
  278.     (setq r (mapcar (function car) lil))
  279.     (setq dd1 (apply (function +) (mapcar (function distance) r (append (cdr r) (list (car r))))) rr1 (unique r))
  280.     (setq r (reverse r))
  281.     (setq dd2 (apply (function +) (mapcar (function distance) r (append (cdr r) (list (car r))))) rr2 (unique r))
  282.     (if (< dd1 dd2)
  283.       (setq r rr1)
  284.       (setq r rr2)
  285.     )
  286.     r
  287.   )
  288.  
  289.   (initget "Yes No")
  290.   (if (= (setq flag (getkword "\nShow previews [Yes/No] <No> : ")) "Yes")
  291.     (setq flag t)
  292.     (setq flag nil)
  293.   )
  294.   (prompt "\nSelect 2D points...")
  295.   (if (setq ss (ssget (list (cons 0 "POINT"))))
  296.     (progn
  297.       (setq ti (car (_vl-times)))
  298.       (repeat (setq i (sslength ss))
  299.         (setq pl (cons (mapcar (function +) (list 0.0 0.0) (cdr (assoc 10 (entget (ssname ss (setq i (1- i))))))) pl))
  300.       )
  301.       (setq plst (MR:ConvexHull-ptsonHull (setq pl (unique pl))))
  302.       (setq inpl (vl-remove-if (function (lambda ( x ) (vl-position x plst))) pl))
  303.       (setq chulls (cons plst chulls))
  304.       (while (and inpl (> (length inpl) 2))
  305.         (setq plst (MR:ConvexHull-ptsonHull inpl))
  306.         (setq inpl (vl-remove-if (function (lambda ( x ) (vl-position x plst))) inpl))
  307.         (setq chulls (cons plst chulls))
  308.       )
  309.       (setq lst (car chulls))
  310.       (if inpl
  311.         (setq lst (process3 inpl lst))
  312.       )
  313.       (if flag
  314.         (progn
  315.           (redraw)
  316.           (mapcar (function (lambda ( a b ) (grdraw a b 2 0))) lst (append (cdr lst) (list (car lst))))
  317.           (getstring "\nENTER TO CONTINUE...")
  318.         )
  319.       )
  320.       (setq chulls (subst lst (car chulls) chulls))
  321.       (if (cadr chulls)
  322.         (while (cadr chulls)
  323.           (setq lst (car chulls) out (cadr chulls) chulls (cdr chulls))
  324.           (setq r1 (chkinters (process1 lst out)))
  325.           (setq r2 (chkinters (process2 lst out)))
  326.           (setq r3 (chkinters (process3 lst out)))
  327.           (setq r11 (unique r1) r12 (unique (reverse r1)) r21 (unique r2) r22 (unique (reverse r2)) r31 (unique r3) r32 (unique (reverse r3)))
  328.           (if r11
  329.             (setq d11 (apply (function +) (mapcar (function distance) r11 (append (cdr r11) (list (car r11))))))
  330.           )
  331.           (if r12
  332.             (setq d12 (apply (function +) (mapcar (function distance) r12 (append (cdr r12) (list (car r12))))))
  333.           )
  334.           (if r21
  335.             (setq d21 (apply (function +) (mapcar (function distance) r21 (append (cdr r21) (list (car r21))))))
  336.           )
  337.           (if r22
  338.             (setq d22 (apply (function +) (mapcar (function distance) r22 (append (cdr r22) (list (car r22))))))
  339.           )
  340.           (if r31
  341.             (setq d31 (apply (function +) (mapcar (function distance) r31 (append (cdr r31) (list (car r31))))))
  342.           )
  343.           (if r32
  344.             (setq d32 (apply (function +) (mapcar (function distance) r32 (append (cdr r32) (list (car r32))))))
  345.           )
  346.           (setq d (min d11 d12 d21 d22 d31 d32))
  347.           (setq r (nth (vl-position d (list d11 d12 d21 d22 d31 d32)) (vl-remove nil (list r11 r12 r21 r22 r31 r32))))
  348.           (if flag
  349.             (progn
  350.               (redraw)
  351.               (mapcar (function (lambda ( a b ) (grdraw a b 2 0))) r (append (cdr r) (list (car r))))
  352.               (getstring "\nENTER TO CONTINUE...")
  353.             )
  354.           )
  355.           (setq chulls (subst r (car chulls) chulls))
  356.         )
  357.         (setq r lst d (apply (function +) (mapcar (function distance) r (append (cdr r) (list (car r))))))
  358.       )
  359.       (entmake
  360.         (append
  361.           (list
  362.             (cons 0 "LWPOLYLINE")
  363.             (cons 100 "AcDbEntity")
  364.             (cons 100 "AcDbPolyline")
  365.             (cons 90 (length r))
  366.             (cons 70 (1+ (* 128 (getvar 'plinegen))))
  367.             (cons 38 0.0)
  368.           )
  369.           (mapcar (function (lambda ( p ) (cons 10 p))) r)
  370.           (list (list 210 0.0 0.0 1.0))
  371.         )
  372.       )
  373.       (redraw)
  374.       (prompt "\nPath length : ") (princ (rtos d 2 20))
  375.       (prompt "\nElapsed time : ") (princ (rtos (- (car (_vl-times)) ti) 2 20)) (prompt " milliseconds...")
  376.     )
  377.   )
  378.   (princ)
  379. )
  380.  
« Last Edit: November 17, 2021, 04:56:36 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

It's Alive!

  • Retired
  • Needs a day job
  • Posts: 8661
  • AKA Daniel
Re: (Challenge) To draw the shortest lwpolyline
« Reply #184 on: November 16, 2021, 05:03:22 PM »
can't even read lisp anymore  :mrgreen:

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #185 on: November 17, 2021, 05:13:14 AM »
I've manged to improve further more - so many changes...
My last version lisp has over 30K and it's quite good - it works relatively fast (under BricsCAD of course, but you can use it also in AutoCAD... - just little slower - ...)
I've mod.-ed Lee's Convex Hull sub as in my testings, my newer version works better...
Also I've broke record on Evgeiny's example : look at DWG, or use my routine : TSP-mchulls+genetic.lsp (the biggest one in ZIP)...
I worked to implement half genetic algorithm - half greedy, so now it should work very well and with grid disposition of points - I've manged for X and Y directions - it gives the same result like Evgeniy's grid example... RND points are also processed very well - it gives the close to best solution in very short time - there is also option for previewing successive partial small TSP solutions from inside Convex Hulls to outside... So, all in all, I think that without permutations this is the best as I can make (for now)...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #186 on: November 18, 2021, 12:02:39 PM »
It turns out that I accidently broke the record of Evgeniy's example...
I had an error in ConvexHull that I mod.-ed and exactly that turned in my testings to break record... So it was pure accident - in my different example, routne didn't worked well and I discovered what was wrong... In Convex Hull I've put 3 starting points directly from Graham scan and I should have coded that 2 starting points are begginning and already 3rd one is needed for checking of angle - (how I imagined my mod.) - that's all that should have been done correctly... But that mistake turned that record was broken - you'll never know with TSP!!!
I've added something new still - permutations - but that won't influence in the most cases on outcome result... (you should avoid to use big number - greater than 8...)
New file is called TSP-all.lsp - (I've corrected my bug in all files - MR:ConvexHull - after all still LM-version is good and it gives the same results like it should)... But who knows - maybe someone won't like to use LM:Clockwise-p sub (only - (vl-sort) and (car-sort) is needed)...

I've left my previous ZIP in previous post for you to see mistake in (MR:ConvexHull) that caused this confusion and DWG with record...
But I've tried differntly - from inside to outside, but we don't know - TSP is difficult task for solving... If you need quick response from PC, then you can always specify 1 as input number of point clouds processing - permutations won't be performed...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #187 on: November 19, 2021, 12:49:35 AM »
Still, I regularily broke the record... I've mod.-ed my latest version and it did broke it - so it's regular (sooner or later...)...
So here is it :
TSP-all.lsp

Regards, M.R.

[EDIT : Added (foo5) and changed (foo) - now it's little slower, but it was necessity... There were 6 downloads till I reattached new TSP-all.lsp]
« Last Edit: November 25, 2021, 03:06:07 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

It's Alive!

  • Retired
  • Needs a day job
  • Posts: 8661
  • AKA Daniel
Re: (Challenge) To draw the shortest lwpolyline
« Reply #188 on: November 19, 2021, 04:51:47 AM »
awesome

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #189 on: November 21, 2021, 03:03:08 AM »
For future develop, I just wanted to point to this qoute by master Evgeniy :

To write fast code, it is necessary to solve two problems.
1. Do not use the code extra computing - to come up with an algorithm, from which there is nothing to remove.
2. Add in the code checks to interrupt the bad cycles. Complex calculations can be represented as a tree. Let's say we're looking for the shortest branch. Then when checking another branch if it is already longer than the previous one, so there is no reason to continue the calculation of its length!

And one more thing - TSP (Travelling Salesman Problem), although not entirely solvable in terms of freedom and resulting solution outcomes, from psyhological aspect of view, I must say that like all other problems - it's solvable in some reasonable limits of observation... We all know that we have short time here on planet... Some brilliant minds have already left us... And that same destiny will happen to all of us...

So, challenge is opened for future developing, but bear in mind that finding correct solutions are not really so important if you strive for exact results - here reasonable approach is very desired - so beside finding correct soutins as much as possible, time of computations is even more important... But all in all, you can live and without TSP, so there are no real reasons for even trying improvements if they are not based on really fundamental logic that were omitted in past...

Good luck and stay healthy and well...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ahsattarian

  • Newt
  • Posts: 112
Re: (Challenge) To draw the shortest lwpolyline
« Reply #190 on: May 23, 2022, 12:02:00 AM »
Have a look at this  :


 https://cadtips.cadalyst.com/linear-objects/tsp-problem?q=linear-objects/tsp-problem 



Code - Auto/Visual Lisp: [Select]
  1. (defun c:tsp ()
  2.   (setq ss (ssget '((0 . "point"))))
  3.   (cond ((< (sslength ss) 2) (exit)))
  4.   (setq li1 nil)
  5.   (setq li2 nil)
  6.   (setq k -1)
  7.   (setq n (sslength ss))
  8.   (repeat n
  9.     (setq k (1+ k))
  10.     (setq s (ssname ss k))
  11.     (setq en (entget s))
  12.     (setq po (cdr (assoc 10 en)))
  13.     (if (< k 3)
  14.       (setq li1 (append (list po) li1))
  15.       (setq li2 (append (list po) li2))
  16.     )
  17.   )
  18.   (foreach po li2
  19.     (setq lii nil)
  20.     (setq k -1)
  21.     (setq n (length li1))
  22.     (repeat n
  23.       (setq k (1+ k))
  24.       (setq po1 (nth k li1))
  25.       (if (/= k (1- (length li1)))
  26.         (setq po2 (nth (1+ k) li1))
  27.         (progn (setq po1 (nth 0 li1)) (setq po2 (nth (1- (length li1)) li1)))
  28.       )
  29.       (setq lii (append (list (list po1 po po2)) lii))
  30.     )
  31.     (setq dili nil)
  32.     (foreach a lii
  33.       (setq po1 (nth 0 a))
  34.       (setq po2 (nth 1 a))
  35.       (setq po3 (nth 2 a))
  36.       (setq d12 (distance po1 po2))
  37.       (setq d23 (distance po2 po3))
  38.       (setq d13 (distance po1 po3))
  39.       (setq di (- (+ d12 d23) d13))
  40.       (setq dili (append (list di) dili))
  41.     )
  42.     (setq dimin (apply 'min dili))
  43.     (setq k 0)
  44.     (while (< k (length dili))
  45.       (cond ((= dimin (nth k dili)) (setq i k) (setq k (length dili))))
  46.       (setq k (1+ k))
  47.     )
  48.     (setq li3 nil)
  49.     (setq ii (1+ i))
  50.     (if (< ii (length li1))
  51.       (progn
  52.         (setq k 0)
  53.         (setq flag 0)
  54.         (while (< k (length li1))
  55.           (if (and (= k ii) (= flag 0))
  56.             (progn (setq li3 (append (list po) li3)) (setq flag 1))
  57.             (progn (setq li3 (append (list (nth k li1)) li3)) (setq k (1+ k)))
  58.           )
  59.         )
  60.       )
  61.       (setq li3 (append (list po) li1))
  62.     )
  63.     (setq li1 li3)
  64.   )
  65.   (command "pline")
  66.   (foreach po li1 (command po))
  67.   (command "close")
  68.   (princ)
  69. )



..

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #191 on: May 23, 2022, 12:30:06 AM »
That's not quite it shoud be - have a look at Evgeniy's green shape...

Further more - considering E.T. possibility of watching - my solution involved physical aspect of overcoming exhaustive computational processings... On the other side, like I stated once - without help of PC (computer i.e.) - how would anyone be able to formulate TSP in terms of - solvable task for playing in spare time...

Here is one another extension - playing for - how E.T. looks to our PLANET - sphere (me, you, we, they, "reminds me on superheroes trying to save all that could be in daylight/midnight redemtion"...)

BTW... Routine not thouroughly tested - it may fail in some cases and BTW. - don't use more than 7-10 points for starting tests...

Code - Auto/Visual Lisp: [Select]
  1.   ;; TSP - TRAVELLING SALESMAN PROBLEM - SPHERE BODY ASPECT ;;
  2.  
  3.   ;; First note : points can not form connections that may result in crossing vecors between 2 and 2 other points if 4 points are non coplanar - they are always in 3D space ;;
  4.   ;; Second note : if middle point of 2 point vector is near center of sphere, then they are in opposition, so for better reasoning, those vectors should be considered lastly - if they are to be considered at all - TSP looks for shortest solution path finding ;;
  5.   ;; Third note : if 4 points are still in plane - 2D space, then they follow the rule that proper array should be in form of forming ringular pathing, also demining possible crossing situations like ordinary 2D TSP relations - from this conclusion comes the rule considering the best approach to path finding is to gather points array such that each middle point of triangle forms angle bigger than 90 degree - obtuse angle - this relation ensures that ringing array is respected more than possible unnecessary sudden orientation jumping in directions not predictable for better TSP overall partial distances summarizing scoring propositions ;;
  6.   ;; Fourth note : if taking RND (random) solution as starting proposition like 2D TSP reasoning, then maybe the best is to start from longest path - oppositions - middles of vectors are all very near center...; what should algorithm do? - well, if biggest vector is disconnected from solution, we have open shape - so, we should look for another disconnection with just a little smaller opposition (distance) - but with points near 2 previously disconnected ones; then this very reminds on crossing situation of 2D TSP - so just reconnect 2 and 2 vectors but now with much better - shorter relations like it should be - TSP path was improved... ;;
  7.   ;; Fifth note : from fourth note we now can see approach and main procedure of algorithm, but what reasoning is better if 2 of biggest oppositions are very unlinearily oriented - approximatively orthogonal from 2D aspecting - following rule of biggest distances, or searching for less bigger and more linearility... of course - more linearility is good visualizing, but still not necessarily with the best judgement approval from aspect of what TSP stands for - the best possible solution : still we can't get and check for final gather resulting score... ;;
  8.   ;; Sixth note : now let's consider that we must/should start from the most worse TSP connection - longest path...; how can we accomplish that (with full of points belonging all to the sphere body) and still preserve that TSP aspect is respected - closed path solution?...; do we have to set all to extreemely unbalanced starting situations so that we can computate on other direction (longest->shortest) ~ || ~ ""(shortest->longest)"" [!!! are we talking here ab TSP !!!] and do assumation that we are doing right thing from the beggining to the end - where is the end??? ;;
  9.   ;; Seventh note : what could be termination treatment for exiting exhaustive computation - the best ballance between remedied 3D partial TSP shapening ;;
  10.   ;; Eight note (FINAL CONCLUSION) : from deduction until now - I can only say that from reasonable standing, if 2 vectors disconnections and 2 reconnections (single pass) can't benefit to better next pass - routine should terminate; should the starting situation be the worst TSP connection - we can debate and have no real clue where would it lead us : to real TSP as singular the best connection with shortest pathing or not...; still we must always have in mind that we just can't check all possible permutations of 2 vectors disconnections and 2 reconnections, so what we should do is consider at what cost we should do disconnections and connections - with 3 points it is very easy - it's always triangle, no matter if smaller and further from center, or bigger with points as oppositions : here we can analyze - small ring - the best, but 2 other situations are the ones that glitch the mind in striving to determine what is better - if in 2D, we can see the center of shpere as center of circumscribed triangle - so what triangle is shorter : the one with the most further center, or the one with the most relatively closest relation between each of vertices - note radius of sphere/circle is const. - it means for all situations 2D and 3D (we can't fall to thoughts that one vertex is closer than other 2 - they are always with distance==radius)...; but what is better from those 2 - one with small connection and 2 oppositioning passing center almost at middles, or the one with like prettiest equal sided triangle with middle angles of 60 degree and center at exact gravity center/centroid of region/area...; if we are to summarize lengths : ~ 4*radius <???> ~ 3*radius*2cos30 : ~ 4*radius { < } 3*(sqrt 3)*radius...; so from triangles aspects in 2D, better is the one with ~ 4*radius, but from 3D perspective - those relations imply possible disconnections and reconnections 2 by 2 vectors and reforming situations more to closer to that one unwanted - all 60 degree angle relation...; still - what can we say overall : if triangles are references structures for reasonation for overall TSP sphere aspect research jurisdiction and we don't want to restructure our algorithm procedure already described, we should look to continue with processing all until we can say that all middle angles of each vertex connection reaches angle the most closer to 180 degree - sphere tangent; i.e. if in last pass smallest angle is above 60 degree (for ex. 135 degree) and in next pass if smallest angle can't reach 135.1 degree, no matter weather we disconnected and reconnected any of 2 vectors of our reference middle vertex with just a little happier middler one, lets say (for ex. 138 degree) and thereby we are spoiling things more (135->133.5)&&(138->139), we can see that we are in negative -1.5 degree + 1 degree = -0.5 degree ;; we must redo action and treminate routine... (and opposite - if sum of middles angles > 0.0 (positive - for ex. +0.5, or even +0.000001 degree), we can continue with processing)... ;;
  11.  

Regards, M.R.

[EDIT : TSP-shortpath-arcs-sphere-pts-2.lsp - just slightly moded. for perhaps little better performance - sadly not fully true :( ]
« Last Edit: June 27, 2022, 07:25:46 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #192 on: May 25, 2022, 04:30:47 AM »
I just want to add something that may occur and may be overlooked while programming...

*** if lines/arcs cross each other - if implementing Evgeniy's method of reassambling path by 2 disconnections and 2 reconnections, please be aware that there are 2 solutions from which only 1 is correct :

vector/arc1 (start1 end1); vector/arc2 (start2 end2)

* you disconnect them both :

* next reconnections :
- 1st : (start1 end2) + (start2 end1)
- 2nd : (start1 start2) + (end1 end2)

*** ONLY 1 of those is correct, as with the other, TSP - single path connections would break into 2 paths that are closed, but they are separated... Correct is only 1 path (single)...

And all in all, my last *.lsp posted was coded in relation to accounting this into postprocessing, but somehow in my testings it didn't actually worked (BricsCAD V21)... And further more with point(s) [ more than 10 ] : CAD(s) have memory issues and routine terminates with error(s) regarding failures not expected for this relatively simple task... Why it can't do on my PC with even 12 pts I can't really understand... With 10 pts - terribly slooow...

Anyway, for reasonable purposes, you can test it on your PC's and perhaps help us all to get better solutions [ TSP - sphere pts aspect ]...
« Last Edit: May 25, 2022, 08:19:40 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #193 on: June 06, 2022, 06:59:24 AM »
I've took some time to mod. Ahsattarian's code...

Regards...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:TSP-ahsattarian ( / AHS:TSP ss ti n pl d )
  2.  
  3.   (defun AHS:TSP ( pl / AHS:mainprocess AHS:subprocess1 AHS:subprocess2 k li1 li2 lii )
  4.  
  5.     (defun AHS:mainprocess ( li1 li2 )
  6.       (foreach po li2
  7.         (setq lii (append lii (AHS:subprocess1 po li1)))
  8.       )
  9.       (setq li1 (AHS:subprocess2 li1 lii))
  10.     )
  11.  
  12.     (defun AHS:subprocess1 ( po li1 / k n po1 po2 lii )
  13.       (setq k 0)
  14.       (repeat (setq n (length li1))
  15.         (setq po1 (nth k li1))
  16.         (if (= k (1- n))
  17.           (setq po2 (nth 0 li1))
  18.           (setq po2 (nth (1+ k) li1))
  19.         )
  20.         (setq lii (append lii (list (list po1 po po2))))
  21.         (setq k (1+ k))
  22.       )
  23.       lii
  24.     )
  25.  
  26.     (defun AHS:subprocess2 ( li1 lii / n dili dimin k i a po li3 )
  27.       (setq n (length li1))
  28.       (setq dili (mapcar (function (lambda ( a ) (- (+ (distance (car a) (cadr a)) (distance (cadr a) (caddr a))) (distance (car a) (caddr a))))) lii))
  29.       (setq dimin (apply (function min) dili))
  30.       (setq k 0)
  31.       (while (and (not i) (< k (length dili)))
  32.         (if (equal dimin (nth k dili) 1e-6)
  33.           (setq i k)
  34.         )
  35.         (setq k (1+ k))
  36.       )
  37.       (setq a (nth i lii) po (cadr a))
  38.       (if (equal (car a) (last li1) 1e-6)
  39.         (setq li1 (cons po li1))
  40.         (progn
  41.           (setq k 0)
  42.           (while (< k n)
  43.             (if (equal (nth k li1) (car a) 1e-6)
  44.               (setq li3 (cons (nth k li1) li3) li3 (cons po li3))
  45.               (setq li3 (cons (nth k li1) li3))
  46.             )
  47.             (setq k (1+ k))
  48.           )
  49.           (setq li1 (reverse li3))
  50.         )
  51.       )
  52.       (if (or (equal (car a) (cadr a) 1e-6) (equal (cadr a) (caddr a) 1e-6) (equal (car a) (caddr a) 1e-6))
  53.         (progn (prompt "\nDuplicate points detected... Quitting...") (exit))
  54.       )
  55.       li1
  56.     )
  57.  
  58.     (setq k 0)
  59.     (foreach po (setq pl (vl-sort pl (function (lambda ( a b ) (if (equal (cadr a) (cadr b) 1e-6) (< (car a) (car b)) (< (cadr a) (cadr b)))))))
  60.       (setq k (1+ k))
  61.       (if (< k 4)
  62.         (setq li1 (append li1 (list po)))
  63.         (setq li2 (append li2 (list po)))
  64.       )
  65.     )
  66.     (if (> k 3)
  67.       (progn
  68.         (while (cadr li2)
  69.           (setq lii nil)
  70.           (setq li1 (AHS:mainprocess li1 li2))
  71.           (setq li2 (vl-remove-if (function (lambda ( p1 ) (vl-some (function (lambda ( p2 ) (equal p1 p2 1e-6))) li1))) pl))
  72.         )
  73.         (setq lii nil)
  74.         (setq lii (AHS:subprocess1 (car li2) li1))
  75.         (setq li1 (AHS:subprocess2 li1 lii))
  76.       )
  77.     )
  78.     li1
  79.   )
  80.  
  81.   (prompt "\n")
  82.   (prompt "\nSelect points...")
  83.   (if (and (setq ss (ssget '((0 . "POINT")))) (> (setq n (sslength ss)) 1))
  84.     (progn
  85.       (setq ti (car (_vl-times)))
  86.       (repeat n
  87.         (setq pl (cons (mapcar (function +) (list 0.0 0.0) (trans (cdr (assoc 10 (entget (ssname ss (setq n (1- n)))))) 0 1)) pl))
  88.       )
  89.       (setq pl (AHS:TSP pl))
  90.       (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pl (append (cdr pl) (list (car pl))))))
  91.       (entmake
  92.         (append
  93.           (list
  94.            '(0 . "LWPOLYLINE")
  95.            '(100 . "AcDbEntity")
  96.            '(100 . "AcDbPolyline")
  97.             (cons 90 (length pl))
  98.             (cons 70 (1+ (* 128 (getvar 'plinegen))))
  99.            '(38 . 0.0)
  100.           )
  101.           (mapcar (function (lambda ( p ) (list 10 (car p) (cadr p)))) pl)
  102.           (list
  103.             (cons 210 (trans (list 0.0 0.0 1.0) 1 0 t))
  104.            '(62 . 3)
  105.           )
  106.         )
  107.       )
  108.       (prompt "\nDistance - path length : ") (princ (rtos d 2 20))
  109.       (prompt "\nElapsed time : ") (princ (rtos (- (car (_vl-times)) ti) 2 20)) (prompt " milliseconds...")
  110.     )
  111.     (prompt "\nNo points selected, or selected/picked just single point...")
  112.   )
  113.   (princ)
  114. )
  115.  
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #194 on: June 06, 2022, 05:32:05 PM »
I don't know weather I posted revised sub functions for checking intersections, but here they are - implemented into Ahsattarian's code...
BTW. In attachmment I'll post revision of TSP-all.lsp ...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:TSP-ahsattarian-chkinters ( / collinear-p chkinters-p chkinters AHS:TSP ss ti n pl d )
  2.  
  3.   (defun collinear-p ( p1 p p2 )
  4.     (equal (distance p1 p2) (+ (distance p1 p) (distance p p2)) 1e-6)
  5.   )
  6.  
  7.   (defun chkinters-p ( pl / r )
  8.     (or lil (setq lil (mapcar (function list) pl (append (cdr pl) (list (car pl))))))
  9.     (setq r (vl-some (function (lambda ( x ) (vl-some (function (lambda ( y ) (and (not (equal (car x) (car y) 1e-6)) (not (equal (car x) (cadr y) 1e-6)) (not (equal (cadr x) (car y) 1e-6)) (not (equal (cadr x) (cadr y) 1e-6)) (or (inters (car x) (cadr x) (car y) (cadr y)) (collinear-p (car x) (car y) (cadr x)) (collinear-p (car x) (cadr y) (cadr x)) (collinear-p (car y) (car x) (cadr y)) (collinear-p (car y) (cadr x) (cadr y)))))) (vl-remove (if (= (vl-position x lil) 0) (last lil) (nth (1- (vl-position x lil)) lil)) (vl-remove (if (= (vl-position x lil) (1- (length lil))) (car lil) (nth (1+ (vl-position x lil)) lil)) (vl-remove x lil)))))) lil))
  10.     (setq lil nil)
  11.     r
  12.   )
  13.  
  14.   (defun chkinters ( pl / processlil done r lill ilil iip )
  15.  
  16.     (defun processlil ( ilil lil / pre mid suf ret )
  17.       (setq pre (reverse (cdr (member (car ilil) (reverse lil)))))
  18.       (setq mid (cdr (member (car ilil) lil)))
  19.       (setq mid (cdr (member (cadr ilil) (reverse mid))))
  20.       (setq mid (mapcar (function reverse) mid))
  21.       (setq suf (cdr (member (cadr ilil) lil)))
  22.       (setq ret (append pre (list (list (car (car ilil)) (car (cadr ilil)))) mid (list (list (cadr (car ilil)) (cadr (cadr ilil)))) suf))
  23.       ret
  24.     )
  25.  
  26.     (or lil (setq lil (mapcar (function list) pl (append (cdr pl) (list (car pl))))))
  27.     (while (not done)
  28.       (setq ilil (vl-some (function (lambda ( a ) (vl-some (function (lambda ( b / ip ) (progn (setq iip (inters (car a) (cadr a) (car b) (cadr b))) (if (and (not (equal (cadr a) (car b) 1e-6)) (not (equal (car a) (cadr b) 1e-6)) (not (or (and (collinear-p (car a) (car b) (cadr a)) (collinear-p (car a) (cadr b) (cadr a))) (and (collinear-p (car b) (car a) (cadr b)) (collinear-p (car b) (cadr a) (cadr b))))) (not (or (and (collinear-p (car a) (car b) (cadr a)) (collinear-p (car b) (cadr a) (cadr b))) (and (collinear-p (car b) (car a) (cadr b)) (collinear-p (car a) (cadr b) (cadr a)))))) (cond ( (collinear-p (car a) (car b) (cadr a)) (setq ip (car b)) ) ( (collinear-p (car a) (cadr b) (cadr a)) (setq ip (cadr b)) ) ( (collinear-p (car b) (car a) (cadr b)) (setq ip (car a)) ) ( (collinear-p (car b) (cadr a) (cadr b)) (setq ip (cadr a)) )) (setq iip nil)) (cond ( iip (list a b iip) ) ( ip (list a b ip) ))))) (vl-remove a lil)))) lil))
  29.       (cond
  30.         ( (and ilil (equal iip (caddr ilil) 1e-6))
  31.           (setq lil (processlil ilil lil))
  32.         )
  33.         ( (and ilil (equal (caar ilil) (caddr ilil) 1e-6))
  34.           (cond
  35.             ( (and (not (equal (caar ilil) (caadr ilil) 1e-6)) (not (equal (caar ilil) (cadadr ilil) 1e-6)))
  36.               (setq lil (processlil ilil lil))
  37.             )
  38.             ( (equal (caar ilil) (caadr ilil) 1e-6)
  39.               (setq lil (processlil ilil lil))
  40.             )
  41.             ( (equal (caar ilil) (cadadr ilil) 1e-6)
  42.               (setq ilil (subst (assoc (cadadr ilil) lil) (cadr ilil) ilil))
  43.               (setq lil (processlil ilil lil))
  44.             )
  45.           )
  46.         )
  47.         ( (and ilil (equal (cadar ilil) (caddr ilil) 1e-6))
  48.           (cond
  49.             ( (and (not (equal (cadar ilil) (caadr ilil) 1e-6)) (not (equal (cadar ilil) (cadadr ilil) 1e-6)))
  50.               (setq ilil (subst (assoc (cadar ilil) lil) (car ilil) ilil))
  51.               (setq lil (processlil ilil lil))
  52.             )
  53.             ( (equal (cadar ilil) (caadr ilil) 1e-6)
  54.               (setq ilil (subst (assoc (cadar ilil) lil) (car ilil) ilil))
  55.               (setq lil (processlil ilil lil))
  56.             )
  57.             ( (equal (cadar ilil) (cadadr ilil) 1e-6)
  58.               (setq ilil (subst (assoc (cadar ilil) lil) (car ilil) ilil))
  59.               (setq ilil (subst (assoc (cadadr ilil) lil) (cadr ilil) ilil))
  60.               (setq lil (processlil ilil lil))
  61.             )
  62.           )
  63.         )
  64.         ( (and ilil (equal (caadr ilil) (caddr ilil) 1e-6))
  65.           (cond
  66.             ( (and (not (equal (caadr ilil) (caar ilil) 1e-6)) (not (equal (caadr ilil) (cadar ilil) 1e-6)))
  67.               (setq lil (processlil ilil lil))
  68.             )
  69.             ( (equal (caadr ilil) (caar ilil) 1e-6)
  70.               (setq lil (processlil ilil lil))
  71.             )
  72.             ( (equal (caadr ilil) (cadar ilil) 1e-6)
  73.               (setq ilil (subst (assoc (caadr ilil) lil) (car ilil) ilil))
  74.               (setq lil (processlil ilil lil))
  75.             )
  76.           )
  77.         )
  78.         ( (and ilil (equal (cadadr ilil) (caddr ilil) 1e-6))
  79.           (cond
  80.             ( (and (not (equal (cadadr ilil) (caar ilil) 1e-6)) (not (equal (cadadr ilil) (cadar ilil) 1e-6)))
  81.               (setq ilil (subst (assoc (cadadr ilil) lil) (cadr ilil) ilil))
  82.               (setq lil (processlil ilil lil))
  83.             )
  84.             ( (equal (cadadr ilil) (caar ilil) 1e-6)
  85.               (setq ilil (subst (assoc (cadadr ilil) lil) (cadr ilil) ilil))
  86.               (setq lil (processlil ilil lil))
  87.             )
  88.             ( (equal (cadadr ilil) (cadar ilil) 1e-6)
  89.               (setq ilil (subst (assoc (cadadr ilil) lil) (cadr ilil) ilil))
  90.               (setq ilil (subst (assoc (cadar ilil) lil) (car ilil) ilil))
  91.               (setq lil (processlil ilil lil))
  92.             )
  93.           )
  94.         )
  95.         ( t (setq done t) )
  96.       )
  97.     )
  98.     (setq r (mapcar (function car) lil))
  99.     (setq lil nil)
  100.     r
  101.   )
  102.  
  103.   (defun AHS:TSP ( pl / AHS:mainprocess AHS:subprocess1 AHS:subprocess2 k li1 li2 lii )
  104.  
  105.     (defun AHS:mainprocess ( li1 li2 )
  106.       (foreach po li2
  107.         (setq lii (append lii (AHS:subprocess1 po li1)))
  108.       )
  109.       (setq li1 (AHS:subprocess2 li1 lii))
  110.     )
  111.  
  112.     (defun AHS:subprocess1 ( po li1 / k n po1 po2 lii )
  113.       (setq k 0)
  114.       (repeat (setq n (length li1))
  115.         (setq po1 (nth k li1))
  116.         (if (= k (1- n))
  117.           (setq po2 (nth 0 li1))
  118.           (setq po2 (nth (1+ k) li1))
  119.         )
  120.         (setq lii (append lii (list (list po1 po po2))))
  121.         (setq k (1+ k))
  122.       )
  123.       lii
  124.     )
  125.  
  126.     (defun AHS:subprocess2 ( li1 lii / n dili dimin k i a po li3 )
  127.       (setq n (length li1))
  128.       (setq dili (mapcar (function (lambda ( a ) (- (+ (distance (car a) (cadr a)) (distance (cadr a) (caddr a))) (distance (car a) (caddr a))))) lii))
  129.       (setq dimin (apply (function min) dili))
  130.       (setq k 0)
  131.       (while (and (not i) (< k (length dili)))
  132.         (if (equal dimin (nth k dili) 1e-6)
  133.           (setq i k)
  134.         )
  135.         (setq k (1+ k))
  136.       )
  137.       (setq a (nth i lii) po (cadr a))
  138.       (if (equal (car a) (last li1) 1e-6)
  139.         (setq li1 (cons po li1))
  140.         (progn
  141.           (setq k 0)
  142.           (while (< k n)
  143.             (if (equal (nth k li1) (car a) 1e-6)
  144.               (setq li3 (cons (nth k li1) li3) li3 (cons po li3))
  145.               (setq li3 (cons (nth k li1) li3))
  146.             )
  147.             (setq k (1+ k))
  148.           )
  149.           (setq li1 (reverse li3))
  150.         )
  151.       )
  152.       (if (or (equal (car a) (cadr a) 1e-6) (equal (cadr a) (caddr a) 1e-6) (equal (car a) (caddr a) 1e-6))
  153.         (progn (prompt "\nDuplicate points detected... Quitting...") (exit))
  154.       )
  155.       li1
  156.     )
  157.  
  158.     (setq k 0)
  159.     (foreach po (setq pl (vl-sort pl (function (lambda ( a b ) (if (equal (cadr a) (cadr b) 1e-6) (< (car a) (car b)) (< (cadr a) (cadr b)))))))
  160.       (setq k (1+ k))
  161.       (if (< k 4)
  162.         (setq li1 (append li1 (list po)))
  163.         (setq li2 (append li2 (list po)))
  164.       )
  165.     )
  166.     (if (> k 3)
  167.       (progn
  168.         (while (cadr li2)
  169.           (setq lii nil)
  170.           (setq li1 (AHS:mainprocess li1 li2))
  171.           (setq li2 (vl-remove-if (function (lambda ( p1 ) (vl-some (function (lambda ( p2 ) (equal p1 p2 1e-6))) li1))) pl))
  172.         )
  173.         (setq lii nil)
  174.         (setq lii (AHS:subprocess1 (car li2) li1))
  175.         (setq li1 (AHS:subprocess2 li1 lii))
  176.       )
  177.     )
  178.     li1
  179.   )
  180.  
  181.   (prompt "\n")
  182.   (prompt "\nSelect points...")
  183.   (if (and (setq ss (ssget '((0 . "POINT")))) (> (setq n (sslength ss)) 1))
  184.     (progn
  185.       (setq ti (car (_vl-times)))
  186.       (repeat n
  187.         (setq pl (cons (mapcar (function +) (list 0.0 0.0) (trans (cdr (assoc 10 (entget (ssname ss (setq n (1- n)))))) 0 1)) pl))
  188.       )
  189.       (setq pl (AHS:TSP pl))
  190.       (if (chkinters-p pl)
  191.         (setq pl (chkinters pl))
  192.       )
  193.       (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pl (append (cdr pl) (list (car pl))))))
  194.       (entmake
  195.         (append
  196.           (list
  197.            '(0 . "LWPOLYLINE")
  198.            '(100 . "AcDbEntity")
  199.            '(100 . "AcDbPolyline")
  200.             (cons 90 (length pl))
  201.             (cons 70 (1+ (* 128 (getvar 'plinegen))))
  202.            '(38 . 0.0)
  203.           )
  204.           (mapcar (function (lambda ( p ) (list 10 (car p) (cadr p)))) pl)
  205.           (list
  206.             (cons 210 (trans (list 0.0 0.0 1.0) 1 0 t))
  207.            '(62 . 3)
  208.           )
  209.         )
  210.       )
  211.       (prompt "\nDistance - path length : ") (princ (rtos d 2 20))
  212.       (prompt "\nElapsed time : ") (princ (rtos (- (car (_vl-times)) ti) 2 20)) (prompt " milliseconds...")
  213.     )
  214.     (prompt "\nNo points selected, or selected/picked just single point...")
  215.   )
  216.   (princ)
  217. )
  218.  

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

:)

M.R. on Youtube