Author Topic: Open loop - Travelling salesman problem  (Read 785 times)

0 Members and 1 Guest are viewing this topic.

Rod

  • Newt
  • Posts: 150
Open loop - Travelling salesman problem
« on: April 16, 2020, 09:38:24 PM »
Does anyone have an algorithim for a linear open travelling salesman problem?

My thinking is to find the two points that are the greatest distance apart and pick one as the start (or let the user pick the start)
Use a greedy algorithim similar to John Uden https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/connect-selected-blocks-with-the-smallest-polyline-length/m-p/8423401/highlight/true#M377556
uncross any crossing sections

The points will be quite linear so I don't think using a closed loop algorithim, then removing the longest segment would work very well.

Cheers, Rod.
« Last Edit: April 17, 2020, 12:56:50 AM by Rod »
"All models are wrong, some models are useful" - George Box

Dlanor

  • Bull Frog
  • Posts: 262
Re: Open loop - Travelling salesman problem
« Reply #1 on: April 17, 2020, 05:17:52 AM »
I mashed together a load of routines to do something similar a couple of weeks ago. I've adjust to handle points. Fill your boots.  :crazy2:

Code - Auto/Visual Lisp: [Select]
  1.  
  2. (defun rh:emLWP (lst cls)
  3.   (entmakex (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length lst)) (cons 70 cls))
  4.                     (mapcar (function (lambda (x) (cons 10 x))) lst)
  5.             );end_append
  6.   );end_entmakex
  7. );end_defun
  8.  
  9. (defun rh:mslen (ent / sp ep obj vlst lst msl)
  10.   (setq sp 0 ep (vlax-curve-getendparam ent) vlst (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget ent))))
  11.   (while (< sp ep) (setq lst (cons (list sp (- (vlax-curve-getdistatparam ent (1+ sp)) (vlax-curve-getdistatparam ent sp))) lst) sp (1+ sp)))
  12.   (setq lst (reverse lst) msl (vl-position (car (vl-sort lst '(lambda (x y) (> (cadr x) (cadr y))))) lst))
  13.   (while (not (minusp msl)) (setq vlst (append (cdr vlst) (list (car vlst))) msl (1- msl)))
  14.   (entdel ent)
  15.   (rh:emLWP (rh:rplk vlst) 0)
  16. );end_defun
  17.  
  18. (defun _gp ( lst / sp cnt d n z )
  19.   (cond (lst
  20.           (setq d (distance (car lst) (cadr lst)) sp (car lst))
  21.           (foreach x (setq z lst) (foreach y (setq z (cdr z)) (if (< d (setq n (distance x y))) (setq d n sp x))))
  22.           (setq lst (mapcar '(lambda (x) (reverse (cdr (reverse x)))) lst))
  23.           (rh:mslen (rh:emLWP lst 1))
  24.         )
  25.   );end_cond
  26. );end_defun
  27.  
  28. (defun rh:kurz4 ( lst / d1 d2 n_lst)
  29.   (cond ( (= (length lst) 4)
  30.           (setq d1 (+ (distance (nth 0 lst) (nth 1 lst)) (distance (nth 1 lst) (nth 2 lst)) (distance (nth 2 lst) (nth 3 lst)))
  31.                 d2 (+ (distance (nth 0 lst) (nth 2 lst)) (distance (nth 2 lst) (nth 1 lst)) (distance (nth 1 lst) (nth 3 lst)))
  32.           );end_setq
  33.           (if (> d2 d1) (setq n_lst lst) (setq n_lst (list (nth 0 lst) (nth 2 lst) (nth 1 lst) (nth 3 lst))))
  34.         )
  35.         ( (alert "List must have four (4) items"))
  36.   );end_cond
  37. );end_defun
  38.  
  39. (defun rh:sub_lst (lst s_i len / cnt s_lst)
  40.   (if (or (not len) (> (+ len s_i) (length lst))) (setq len (- (length lst) s_i)))
  41.   (setq cnt (+ s_i len))
  42.   (repeat len (setq s_lst (cons (nth (setq cnt (1- cnt)) lst) s_lst)))
  43. );end_defun
  44.  
  45. (defun rh:rplk ( lst / idx s_lst rtn a b c)
  46.   (setq idx 0)
  47.   (while (>= (- (length lst) idx) 4)
  48.     (setq s_lst (rh:sub_lst lst idx 4))
  49.     (setq rtn (rh:kurz4 s_lst))
  50.     (cond ( (not (equal rtn s_lst))
  51.             (if (> idx 0) (setq a (rh:sub_lst lst 0 idx)) (setq a nil))
  52.             (setq b (rh:sub_lst lst idx 4)  c (rh:sub_lst lst (+ idx 4) nil) lst (append a rtn c))
  53.           )
  54.     );end_cond
  55.     (setq idx (1+ idx))
  56.   );end_while
  57.   lst
  58. );end_defun
  59.  
  60. (defun c:test ( / ss cnt ent elst lst)
  61.   (setq ss (ssget '((0 . "POINT"))))
  62.   (cond (ss
  63.           (repeat (setq cnt (sslength ss))
  64.             (setq ent (ssname ss (setq cnt (1- cnt)))
  65.                   elst (entget ent)
  66.                   lst (cons (cdr (assoc 10 elst)) lst)
  67.             );end_setq
  68.           );end_repeat
  69.         )
  70.   );end_cond
  71.   (if lst (_gp lst))
  72.   (princ)
  73. );end_defun
  74.  


Lee Mac

  • Seagull
  • Posts: 12411
  • London, England

Rod

  • Newt
  • Posts: 150
Re: Open loop - Travelling salesman problem
« Reply #3 on: April 19, 2020, 06:39:16 PM »
Thanks Dlanor,
That works really well.
I will have to step through your code to see how it works, any chance of a basic explanation?

Thanks Lee,
I have seen that amazing thread and I understand the basics of Evgeniy's method and chlh_jd's expansion of it, really clever!

Cheers, Rod.
"All models are wrong, some models are useful" - George Box

Dlanor

  • Bull Frog
  • Posts: 262
Re: Open loop - Travelling salesman problem
« Reply #4 on: April 19, 2020, 08:27:03 PM »
OK. An explanation.

The (c:..) function : collects the points and passes them to the (_gp..) function.

(_gp..) function : I didn't write this function, and I don't know who did, as it was in a routine I inherited when I took over my current position. This is a greedy path constructor based on distances between points. This passes the constructed list to the (rh:emLWP ...) function, which makes a closed LWPolyline and the polyline is passed to the (rh:mslen .. ) function.

(rh:mslen ..) function : finds the longest segment of the closed polyline and then shuffles the points so that the longest segment is the last. The closed polyline is then deleted and the list is passed to the (rh:rplk .. ) function before an open lwpolyline is made.

(rh:rplk ..) function : This is a check that the shortest route was found. It was originally written to remove small kinks or minor self intersections from polylines with the aid of the (rh:kurz4..) function and the (rh:sub_lst ..) function. This basically steps through the polyline vertices in groups of 4 points i.e. (1 2 3 4) etc with each being sent to (rh:kurz4 ..). If the return from (rh:kurz4 ..) is different from what was sent the return is substituted for the sent in the point list. The first point (car) is saved to a second list and the processed is repeated on the rest of the list (cdr). This is repeated until there are only 3 points remaining in the original list which are then added to the front of the second list in turn.

(rh:kurz4 ..) function : This assumes that the first and last passed points are fixed and tests if (1 2 3 4) is shorter than (1 3 2 4) returning the shortest.

Clear as mud.  :idiot2:  :oops:

Rod

  • Newt
  • Posts: 150
Re: Open loop - Travelling salesman problem
« Reply #5 on: April 19, 2020, 09:17:37 PM »
Really helpful.
Thanks!
"All models are wrong, some models are useful" - George Box

jtm2020hyo

  • Newt
  • Posts: 152
Re: Open loop - Travelling salesman problem
« Reply #6 on: April 21, 2020, 09:37:24 AM »
I mashed together a load of routines to do something similar a couple of weeks ago. I've adjust to handle points. Fill your boots.  :crazy2:

Code - Auto/Visual Lisp: [Select]
  1.  
  2. (defun rh:emLWP (lst cls)
  3.   (entmakex (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length lst)) (cons 70 cls))
  4.                     (mapcar (function (lambda (x) (cons 10 x))) lst)
  5.             );end_append
  6.   );end_entmakex
  7. );end_defun
  8.  
  9. (defun rh:mslen (ent / sp ep obj vlst lst msl)
  10.   (setq sp 0 ep (vlax-curve-getendparam ent) vlst (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget ent))))
  11.   (while (< sp ep) (setq lst (cons (list sp (- (vlax-curve-getdistatparam ent (1+ sp)) (vlax-curve-getdistatparam ent sp))) lst) sp (1+ sp)))
  12.   (setq lst (reverse lst) msl (vl-position (car (vl-sort lst '(lambda (x y) (> (cadr x) (cadr y))))) lst))
  13.   (while (not (minusp msl)) (setq vlst (append (cdr vlst) (list (car vlst))) msl (1- msl)))
  14.   (entdel ent)
  15.   (rh:emLWP (rh:rplk vlst) 0)
  16. );end_defun
  17.  
  18. (defun _gp ( lst / sp cnt d n z )
  19.   (cond (lst
  20.           (setq d (distance (car lst) (cadr lst)) sp (car lst))
  21.           (foreach x (setq z lst) (foreach y (setq z (cdr z)) (if (< d (setq n (distance x y))) (setq d n sp x))))
  22.           (setq lst (mapcar '(lambda (x) (reverse (cdr (reverse x)))) lst))
  23.           (rh:mslen (rh:emLWP lst 1))
  24.         )
  25.   );end_cond
  26. );end_defun
  27.  
  28. (defun rh:kurz4 ( lst / d1 d2 n_lst)
  29.   (cond ( (= (length lst) 4)
  30.           (setq d1 (+ (distance (nth 0 lst) (nth 1 lst)) (distance (nth 1 lst) (nth 2 lst)) (distance (nth 2 lst) (nth 3 lst)))
  31.                 d2 (+ (distance (nth 0 lst) (nth 2 lst)) (distance (nth 2 lst) (nth 1 lst)) (distance (nth 1 lst) (nth 3 lst)))
  32.           );end_setq
  33.           (if (> d2 d1) (setq n_lst lst) (setq n_lst (list (nth 0 lst) (nth 2 lst) (nth 1 lst) (nth 3 lst))))
  34.         )
  35.         ( (alert "List must have four (4) items"))
  36.   );end_cond
  37. );end_defun
  38.  
  39. (defun rh:sub_lst (lst s_i len / cnt s_lst)
  40.   (if (or (not len) (> (+ len s_i) (length lst))) (setq len (- (length lst) s_i)))
  41.   (setq cnt (+ s_i len))
  42.   (repeat len (setq s_lst (cons (nth (setq cnt (1- cnt)) lst) s_lst)))
  43. );end_defun
  44.  
  45. (defun rh:rplk ( lst / idx s_lst rtn a b c)
  46.   (setq idx 0)
  47.   (while (>= (- (length lst) idx) 4)
  48.     (setq s_lst (rh:sub_lst lst idx 4))
  49.     (setq rtn (rh:kurz4 s_lst))
  50.     (cond ( (not (equal rtn s_lst))
  51.             (if (> idx 0) (setq a (rh:sub_lst lst 0 idx)) (setq a nil))
  52.             (setq b (rh:sub_lst lst idx 4)  c (rh:sub_lst lst (+ idx 4) nil) lst (append a rtn c))
  53.           )
  54.     );end_cond
  55.     (setq idx (1+ idx))
  56.   );end_while
  57.   lst
  58. );end_defun
  59.  
  60. (defun c:test ( / ss cnt ent elst lst)
  61.   (setq ss (ssget '((0 . "POINT"))))
  62.   (cond (ss
  63.           (repeat (setq cnt (sslength ss))
  64.             (setq ent (ssname ss (setq cnt (1- cnt)))
  65.                   elst (entget ent)
  66.                   lst (cons (cdr (assoc 10 elst)) lst)
  67.             );end_setq
  68.           );end_repeat
  69.         )
  70.   );end_cond
  71.   (if lst (_gp lst))
  72.   (princ)
  73. );end_defun
  74.  

is possible to add selected polylines option to work as a "bridge" for the salesman in the lisp?

Rod

  • Newt
  • Posts: 150
Re: Open loop - Travelling salesman problem
« Reply #7 on: April 22, 2020, 02:02:25 AM »
Hi jtm2020hyo,

my knowledge of this is pretty weak but from my understanding you could do a deluaney triangulation of the points and force (change) triangulation on your bridges then brute force (try every possible combination) to find a good soultion.
BTW it seems brute force is not practical for more than 10 points unless you somehow reduce the number of combinations (like using triangulation)

This is discussed in the other thread about the travelling salesman problem https://www.theswamp.org/index.php?topic=30434.0

Hope that helps, Rod.
"All models are wrong, some models are useful" - George Box

ahsattarian

  • Mosquito
  • Posts: 18
Re: Open loop - Travelling salesman problem
« Reply #8 on: November 19, 2020, 10:18:58 AM »
It Doesn't Work Properly   !!!

Please see attached photo   !!!!


ribarm

  • Water Moccasin
  • Posts: 2412
  • Marko Ribar, architect
Re: Open loop - Travelling salesman problem
« Reply #9 on: November 19, 2020, 02:03:11 PM »
Use *.VLX or *.des (BricsCAD) posted in this post :
https://www.theswamp.org/index.php?topic=30434.msg601911#msg601911

(For open loop, you'll have to check for largest segment of resulting closed LWPOLYLINE and manually trim it...)
« Last Edit: November 19, 2020, 02:06:53 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ahsattarian

  • Mosquito
  • Posts: 18
Re: Open loop - Travelling salesman problem
« Reply #10 on: November 20, 2020, 06:55:10 AM »
This Works  :





(defun c:tsp ()
  (setq ss (ssget '((0 . "point"))))
  (cond ((< (sslength ss) 2) (exit)))
  (setq li1 nil)
  (setq li2 nil)
  (setq k -1)
  (setq n (sslength ss))
  (repeat n
    (setq k (1+ k))
    (setq s (ssname ss k))
    (setq en (entget s))
    (setq po (cdr (assoc 10 en)))
    (if   (< k 3)
      (setq li1 (append (list po) li1))
      (setq li2 (append (list po) li2))
    )
  )
  (foreach po li2
    (setq lii nil)
    (setq k -1)
    (setq n (length li1))
    (repeat n
      (setq k (1+ k))
      (setq po1 (nth k li1))
      (if (/= k (1- (length li1)))
   (setq po2 (nth (1+ k) li1))
   (progn (setq po1 (nth 0 li1)) (setq po2 (nth (1- (length li1)) li1)))
      )
      (setq lii (append (list (list po1 po po2)) lii))
    )
    (setq dili nil)
    (foreach a lii
      (setq po1 (nth 0 a))
      (setq po2 (nth 1 a))
      (setq po3 (nth 2 a))
      (setq d12 (distance po1 po2))
      (setq d23 (distance po2 po3))
      (setq d13 (distance po1 po3))
      (setq di (- (+ d12 d23) d13))
      (setq dili (append (list di) dili))
    )
    (setq dimin (apply 'min dili))
    (setq k 0)
    (while (< k (length dili))
      (cond ((= dimin (nth k dili)) (setq i k) (setq k (length dili))))
      (setq k (1+ k))
    )
    (setq li3 nil)
    (setq ii (1+ i))
    (if   (< ii (length li1))
      (progn
   (setq k 0)
   (setq flag 0)
   (while (< k (length li1))
     (if (and (= k ii) (= flag 0))
       (progn (setq li3 (append (list po) li3)) (setq flag 1))
       (progn (setq li3 (append (list (nth k li1)) li3)) (setq k (1+ k)))
     )
   )
      )
      (setq li3 (append (list po) li1))
    )
    (setq li1 li3)
  )
  (command "pline")
  (foreach po li1 (command po))
  (command "close")
  (princ)
)