Author Topic: Shortest Path between two points on grid and cover all points  (Read 11773 times)

0 Members and 1 Guest are viewing this topic.

handasa

  • Newt
  • Posts: 21
Shortest Path between two points on grid and cover all points
« on: November 01, 2018, 06:29:38 PM »
Greetings Everyone

there are many lisp codes that Find the shortest path between connecting a Grid of points or Shortest path between two points Like TSP and Dijkstra’s Algorithm

the problem appears when i need the this short path to cover all other points to have a Start and End connected together through the entire grid as shown in the picture

Any Help?

Thanks in Advance




Lee Mac

  • Seagull
  • Posts: 12906
  • London, England

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: Shortest Path between two points on grid and cover all points
« Reply #2 on: November 02, 2018, 01:01:02 PM »
To continue that topic :

Maximum 10 points :

Code - Auto/Visual Lisp: [Select]
  1. (defun c:TSP-bruteforce-3dpoints-start-end ( / unique permutate ss i pl sp ep n k l ti ll dmin x d rtn )
  2.  
  3.   (defun unique ( l )
  4.     (if l (cons (car l) (unique (vl-remove-if '(lambda ( x ) (equal x (car l) 1e-6)) l))))
  5.   )
  6.  
  7.   ;;;--------------------------------------------------------------------------
  8.   ;;; Permutate a single list.
  9.   ;;; Recursive solution by Reini Urban
  10.   ;;; (permutate '(0 1 2)) => ((0 1 2) (0 2 1) (1 2 0) (1 0 2) (2 0 1) (2 1 0))
  11.   ;;;--------------------------------------------------------------------------
  12.   (defun permutate ( l / x1 )
  13.     (cond
  14.       ( (null l) l )
  15.       ( (= (length l) 2) (list l (reverse l)) )
  16.       ( t
  17.         (repeat (length l)
  18.           (foreach x (permutate (cdr l)) ;; loop1 = (foreach x '((1 2) (2 1)) [(permutate (cdr '(0 1 2))) = (permutate '(1 2)) = '((1 2) (2 1))] ; loop2 = (foreach x '((2 0) (0 2)) ; loop3 = (foreach x '((0 1) (1 0))
  19.             (setq x1 (cons (cons (car l) x) x1)) ;; loop1 = x1 = '((0 2 1) (0 1 2)) ; loop2 = x1 = '((1 0 2) (1 2 0) (0 2 1) (0 1 2)) ; loop3 = x1 = '((2 1 0) (2 0 1) (1 0 2) (1 2 0) (0 2 1) (0 1 2))
  20.           )
  21.           (setq l (append (cdr l) (list (car l)))) ;; l = '(0 1 2) - loop1; l = '(1 2 0) - loop2; l = '(2 0 1) - loop3
  22.         )
  23.         (reverse x1)
  24.       )
  25.     )
  26.   )
  27.  
  28.   (setq ss (ssget '((0 . "POINT"))))
  29.   (repeat (setq i (sslength ss))
  30.     (setq pl (cons (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) pl))
  31.   )
  32.   (setq pl (unique pl))
  33.   (initget 1)
  34.   (setq sp (trans (getpoint "\nPick or specify start point - must be point in selection previously generated : ") 1 0))
  35.   (initget 1)
  36.   (setq ep (trans (getpoint "\nPick or specify end point - must be point in selection previously generated : ") 1 0))
  37.   (setq pl (vl-remove-if '(lambda ( x ) (equal x sp 1e-6)) pl))
  38.   (setq pl (vl-remove-if '(lambda ( x ) (equal x ep 1e-6)) pl))
  39.   (setq n (length pl))
  40.   (setq k n)
  41.   (repeat n
  42.     (setq l (cons (setq k (1- k)) l))
  43.   )
  44.   (setq ti (car (_vl-times)))
  45.   (setq ll (permutate l))
  46.   (setq dmin 1e+308)
  47.   (foreach x ll
  48.     (setq x (mapcar '(lambda ( a ) (nth a pl)) x))
  49.     (setq x (append (list sp) x (list ep)))
  50.     (setq d (apply '+ (mapcar '(lambda ( a b ) (distance a b)) x (cdr x))))
  51.     (if (> dmin d)
  52.       (setq dmin d rtn x)
  53.     )
  54.   )
  55.   (vl-cmdf "_.3DPOLY")
  56.   (foreach p rtn
  57.     (vl-cmdf "_non" (trans p 0 1))
  58.   )
  59.   (vl-cmdf "")
  60.   (while (< 0 (getvar 'cmdactive))
  61.     (vl-cmdf "")
  62.   )
  63.   (prompt "\nDistance : ") (princ (rtos dmin 2 50))
  64.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds.")
  65.   (princ)
  66. )
  67.  
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

handasa

  • Newt
  • Posts: 21
Re: Shortest Path between two points on grid and cover all points
« Reply #3 on: November 02, 2018, 01:25:14 PM »
To continue that topic :
thanks Marko ... Waiting for points more than 10  :smitten:
« Last Edit: November 02, 2018, 01:29:32 PM by handasa »

ChrisCarlson

  • Guest
Re: Shortest Path between two points on grid and cover all points
« Reply #4 on: November 05, 2018, 08:41:51 AM »
To continue that topic :
thanks Marko ... Waiting for points more than 10  :smitten:

Well there are two real ways to solve this, either algorithmically or brute force.

https://brilliant.org/wiki/traveling-salesperson-problem/

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: Shortest Path between two points on grid and cover all points
« Reply #5 on: November 05, 2018, 11:59:54 AM »
To continue that topic :
thanks Marko ... Waiting for points more than 10  :smitten:

You can always get incorrect but close enough version for more points (greedy... - my version)...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:TSP-MR-start-end ( / car-sort nextpt pathbynextshortdst sortpl ss i pl sp ep ti rtn pl1 pl2 d1 d2 d )
  2.  
  3.   ;;; (car-sort '(2 4 1 3 5 1) '<) => nil
  4.   ;;; (car-sort '(2 4 1 3 5 1) '<=) => 1
  5.   (defun car-sort ( l f / removenth r k )
  6.  
  7.     (defun removenth ( l n / k )
  8.       (setq k -1)
  9.       (vl-remove-if (function (lambda ( x ) (= (setq k (1+ k)) n))) l)
  10.     )
  11.  
  12.     (setq k -1)
  13.     (vl-some (function (lambda ( a ) (setq k (1+ k)) (if (vl-every (function (lambda ( x ) (apply f (list a x)))) (removenth l k)) (setq r a)))) l)
  14.     r
  15.   )
  16.  
  17.   (defun nextpt ( p l ) ; p - point ; l - list of points without point p
  18.     (car-sort l (function (lambda ( a b ) (<= (distance a p) (distance b p)))))
  19.   )
  20.  
  21.   (defun pathbynextshortdst ( l / p pl pp ) ; l - list of points to sort by starting point (car l)
  22.     (while (setq p (car l))
  23.       (setq pl (cons p pl))
  24.       (setq l (vl-remove p l))
  25.       (if (car l)
  26.         (setq l (cons (setq pp (nextpt p l)) (vl-remove pp l)))
  27.       )
  28.     )
  29.     (reverse pl)
  30.   )
  31.  
  32.   (defun sortpl ( l / pdl pl1 pl2 ) ; l - list of points to sort by shortest next distances; return - 2 sorted lists
  33.     (foreach p l
  34.       (setq pdl (cons (cons (distance p (nextpt p (vl-remove p l))) p) pdl))
  35.     )
  36.     (setq pdl (vl-sort pdl (function (lambda ( a b ) (< (car a) (car b))))))
  37.     (setq pl1 (pathbynextshortdst (cons (cdar pdl) (vl-remove (cdar pdl) pl))))
  38.     (setq pl2 (pathbynextshortdst (cons (cdadr pdl) (vl-remove (cdadr pdl) pl))))
  39.     (list pl1 pl2)
  40.   )
  41.  
  42.   (setq ss (ssget '((0 . "POINT"))))
  43.   (repeat (setq i (sslength ss))
  44.     (setq pl (cons (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) pl))
  45.   )
  46.   (initget 1)
  47.   (setq sp (trans (getpoint "\nStart/end point from selection set : ") 1 0))
  48.   (initget 1)
  49.   (setq ep (trans (getpoint "\nEnd/start point from selection set : ") 1 0))
  50.   (setq pl (vl-remove-if (function (lambda ( x ) (equal x sp 1e-6))) pl))
  51.   (setq pl (vl-remove-if (function (lambda ( x ) (equal x ep 1e-6))) pl))
  52.   (setq ti (car (_vl-times)))
  53.   (setq rtn (sortpl pl))
  54.   (setq pl1 (car rtn))
  55.   (setq pl2 (cadr rtn))
  56.   (if (< (+ (distance sp (car pl1)) (distance ep (last pl1))) (+ (distance sp (last pl1)) (distance ep (car pl1))))
  57.     (setq pl1 (append (list sp) pl1 (list ep)))
  58.     (setq pl1 (append (list ep) pl1 (list sp)))
  59.   )
  60.   (if (< (+ (distance sp (car pl2)) (distance ep (last pl2))) (+ (distance sp (last pl2)) (distance ep (car pl2))))
  61.     (setq pl2 (append (list sp) pl2 (list ep)))
  62.     (setq pl2 (append (list ep) pl2 (list sp)))
  63.   )
  64.   (setq d1 (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pl1 (cdr pl1))))
  65.   (setq d2 (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pl2 (cdr pl2))))
  66.   (if (< d1 d2)
  67.     (setq pl pl1 d d1)
  68.     (setq pl pl2 d d2)
  69.   )
  70.   (vl-cmdf "_.3DPOLY")
  71.   (foreach p pl
  72.     (vl-cmdf "_non" (trans p 0 1))
  73.   )
  74.   (vl-cmdf "")
  75.   (while (< 0 (getvar 'cmdactive))
  76.     (vl-cmdf "")
  77.   )
  78.   (prompt "\nDistance : ") (princ (rtos d 2 50))
  79.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds.")
  80.   (princ)
  81. )
  82.  

Cheers...
« Last Edit: November 06, 2018, 09:32:20 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

handasa

  • Newt
  • Posts: 21
Re: Shortest Path between two points on grid and cover all points
« Reply #6 on: November 05, 2018, 06:08:06 PM »
Quote
You can always get incorrect but close enough version for more points (greedy... - my version)...
@Marko
this last version gives  sometimes "strange" and in most case "not optimum" solution
we could use conditional permutation ...
assume lst = x1 x2 x3 x4 x5 x6 with x1 and x6 are the two ends
any list resulted from (permutate lst)
1-must have x1 and x6 as the first and last of it i.e any list such (x4 x1 x2 x3 x5 x6) must be discarded
2-assume the result (x1 x4 x3 x5 x2 x6) each point in this list must be in range of the most nearest 4 points of the next or previous point
i.e
x4 must be in the first 4 items from this
Code: [Select]
(vl-sort lst (function (lambda (e1 e2)(< (distance x1 e1) (distance x1 e2)))))x3 must be in the first 4 items from this 
Code: [Select]
(vl-sort lst (function (lambda (e1 e2)(< (distance x4 e1) (distance x4 e2)))))x5 must be in the first 4 items from this 
Code: [Select]
(vl-sort lst (function (lambda (e1 e2)(< (distance x3 e1) (distance x3 e2))))) ... and so on
i don't know you got what iam trying to say or not ... and excuse me for my bad english


ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: Shortest Path between two points on grid and cover all points
« Reply #7 on: November 05, 2018, 11:52:54 PM »
Quote
You can always get incorrect but close enough version for more points (greedy... - my version)...
@Marko
this last version gives  sometimes "strange" and in most case "not optimum" solution
we could use conditional permutation ...
assume lst = x1 x2 x3 x4 x5 x6 with x1 and x6 are the two ends
any list resulted from (permutate lst)
1-must have x1 and x6 as the first and last of it i.e any list such (x4 x1 x2 x3 x5 x6) must be discarded
2-assume the result (x1 x4 x3 x5 x2 x6) each point in this list must be in range of the most nearest 4 points of the next or previous point
i.e
x4 must be in the first 4 items from this
Code: [Select]
(vl-sort lst (function (lambda (e1 e2)(< (distance x1 e1) (distance x1 e2)))))x3 must be in the first 4 items from this 
Code: [Select]
(vl-sort lst (function (lambda (e1 e2)(< (distance x4 e1) (distance x4 e2)))))x5 must be in the first 4 items from this 
Code: [Select]
(vl-sort lst (function (lambda (e1 e2)(< (distance x3 e1) (distance x3 e2))))) ... and so on
i don't know you got what iam trying to say or not ... and excuse me for my bad english

handasa, if you use function (permutate) - PC will recurse all permutations until finished, so no speed gain if discarding wrong lists (with different start/end points then desired ones)... So you are telling something between real - first algorithm which is correct, but only up to 10 pts and greedy as you described in your array of sorting by shortest distances between each 2 points... Note that greedy is fast, but overall distance could be incorrectly assumed as shortest, so greedy is only good if you want to achieve result that is so called "close" and in the same time process more points than 10... My version of greedy is cecking start/end distances in connection to array generated from inside shortest distance between 2 points of point cloud and when array is generated there can be only 2 possible combinations from which I obtained the best ( start point - start of array & end point - end of array ; start point - end of array & end point - start of array )... With greedy you can't include both start/end points in point cloud unless you are checking all permutations with all possible arrays, but that's the first code...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: Shortest Path between two points on grid and cover all points
« Reply #8 on: November 07, 2018, 11:47:40 AM »
handasa, maybe this version is more appropriate for your task... Now 2 lists - first from start point and second from end point... They are finally gathered into main point list... It may be closer to what you are searching for and code is even shorter... So another greedy :

Code - Auto/Visual Lisp: [Select]
  1. (defun c:TSP-MR-start-end ( / car-sort nextpt ss i pl sp ep ti pl1 pl2 p1 p2 d1 d2 d )
  2.  
  3.   ;;; (car-sort '(2 4 1 3 5 1) '<) => nil
  4.   ;;; (car-sort '(2 4 1 3 5 1) '<=) => 1
  5.   (defun car-sort ( l f / removenth r k )
  6.  
  7.     (defun removenth ( l n / k )
  8.       (setq k -1)
  9.       (vl-remove-if (function (lambda ( x ) (= (setq k (1+ k)) n))) l)
  10.     )
  11.  
  12.     (setq k -1)
  13.     (vl-some (function (lambda ( a ) (setq k (1+ k)) (if (vl-every (function (lambda ( x ) (apply f (list a x)))) (removenth l k)) (setq r a)))) l)
  14.     r
  15.   )
  16.  
  17.   (defun nextpt ( p l ) ; p - point ; l - list of points without point p
  18.     (car-sort l (function (lambda ( a b ) (<= (distance a p) (distance b p)))))
  19.   )
  20.  
  21.   (setq ss (ssget '((0 . "POINT"))))
  22.   (repeat (setq i (sslength ss))
  23.     (setq pl (cons (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) pl))
  24.   )
  25.   (initget 1)
  26.   (setq sp (trans (getpoint "\nStart/end point from selection set : ") 1 0))
  27.   (initget 1)
  28.   (setq ep (trans (getpoint "\nEnd/start point from selection set : ") 1 0))
  29.   (setq ti (car (_vl-times)))
  30.   (setq pl (vl-remove-if (function (lambda ( x ) (equal x sp 1e-6))) pl))
  31.   (setq pl (vl-remove-if (function (lambda ( x ) (equal x ep 1e-6))) pl))
  32.   (setq pl1 (cons sp pl1))
  33.   (setq pl2 (cons ep pl2))
  34.   (while pl
  35.     (setq p1 (nextpt (car pl1) pl))
  36.     (setq p2 (nextpt (car pl2) pl))
  37.     (setq d1 (distance (car pl1) p1))
  38.     (setq d2 (distance (car pl2) p2))
  39.     (if (< d1 d2)
  40.       (setq pl1 (cons p1 pl1) pl (vl-remove p1 pl))
  41.       (setq pl2 (cons p2 pl2) pl (vl-remove p2 pl))
  42.     )
  43.   )
  44.   (setq pl (append (reverse pl1) pl2))
  45.   (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pl (cdr pl))))
  46.   (vl-cmdf "_.3DPOLY")
  47.   (foreach p pl
  48.     (vl-cmdf "_non" (trans p 0 1))
  49.   )
  50.   (vl-cmdf "")
  51.   (while (< 0 (getvar 'cmdactive))
  52.     (vl-cmdf "")
  53.   )
  54.   (prompt "\nDistance : ") (princ (rtos d 2 50))
  55.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds.")
  56.   (princ)
  57. )
  58.  

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

:)

M.R. on Youtube

handasa

  • Newt
  • Posts: 21
Re: Shortest Path between two points on grid and cover all points
« Reply #9 on: November 11, 2018, 03:22:55 PM »
sorry for late reply ... i have issues with my internet connection ...
thanks Marko for Your Effort ..the last version is fast but it may give strange results

BIGAL

  • Swamp Rat
  • Posts: 1396
  • 40 + years of using Autocad
Re: Shortest Path between two points on grid and cover all points
« Reply #10 on: November 12, 2018, 08:50:22 PM »
Maybe a different approach using a seed and direction

1st point and go up U next is R right so the next point would be down then to right the next up and so on. But the ideas is based on a reasonable grid a slight variation on x,y would work by looking for next object within a window.
A man who never made a mistake never made anything

BIGAL

  • Swamp Rat
  • Posts: 1396
  • 40 + years of using Autocad
Re: Shortest Path between two points on grid and cover all points
« Reply #11 on: November 12, 2018, 08:54:19 PM »
Just a quick brain teaser draw a 3x3 grid of dots take a pencil do not lift off paper join all 9 dots in one continuous movement in 4 lines.
A man who never made a mistake never made anything

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: Shortest Path between two points on grid and cover all points
« Reply #12 on: December 15, 2018, 05:43:18 AM »
Hi Handasa,
here are news for you... Until I haven't developed better algorithm to TSP-2D posted on Eveniy's challenge topic, I couldn't write this improvement... So new code for you to test and I think it should yield better result... Checking for intersections are removed as Evgeniy's method is only applicable for closed paths like TSP, also no need for ConvexHull sorting as this problem is different... I haven't visualize too much Evgeniy's method and perhaps it could be coded for checking intersections, but still better anything than nothing... So it is sloow algorithm, but then again faster than all permutations version... Here you are, enjoy...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:TSP-2D-MR-START-END ( / ss ti i pl sp ep pln dmin k plp pld pll d r pp )
  2.   (setq ss (ssget '((0 . "POINT"))))
  3.   (repeat (setq i (sslength ss))
  4.     (setq pl (cons (mapcar (function +) '(0 0) (cdr (assoc 10 (entget (ssname ss (setq i (1- i))))))) pl))
  5.   )
  6.   (initget 1)
  7.   (setq sp (mapcar (function +) '(0 0) (trans (getpoint "\nStart/end point from selection set : ") 1 0)))
  8.   (initget 1)
  9.   (setq ep (mapcar (function +) '(0 0) (trans (getpoint "\nEnd/start point from selection set : ") 1 0)))
  10.   (setq ti (car (_vl-times)))
  11.   (setq pln (list sp ep))
  12.   (setq pl (vl-remove sp pl) pl (vl-remove ep pl))
  13.   (while pl
  14.     (foreach p pl
  15.       (setq k -1)
  16.       (repeat (1- (length pln))
  17.         (setq k (1+ k))
  18.         (setq plp (reverse (member (nth k pln) (reverse pln))))
  19.         (setq pls (cdr (member (nth k pln) pln)))
  20.         (setq pll (append plp (list p) pls))
  21.         (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pll (cdr pll))))
  22.         (setq r (cons (list d pll) r))
  23.       )
  24.     )
  25.     (setq r (vl-sort r (function (lambda ( a b ) (< (car a) (car b))))))
  26.     (setq r (vl-remove-if-not (function (lambda ( x ) (equal (caar r) (car x) 1e-8))) r))
  27.     (setq dmin 1e+99)
  28.     (foreach xx (mapcar (function cadr) r)
  29.       (if (vl-remove (vl-some (function (lambda ( x ) (if (vl-position x pl) x))) xx) pl)
  30.         (foreach p (vl-remove (vl-some (function (lambda ( x ) (if (vl-position x pl) x))) xx) pl)
  31.           (setq k -1)
  32.           (repeat (1- (length xx))
  33.             (setq k (1+ k))
  34.             (setq plp (reverse (member (nth k xx) (reverse xx))))
  35.             (setq pls (cdr (member (nth k xx) xx)))
  36.             (setq pll (append plp (list p) pls))
  37.             (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pll (cdr pll))))
  38.             (if (< d dmin)
  39.               (setq dmin d r pll pp (vl-remove nil (mapcar (function (lambda ( x ) (if (vl-position x pl) x))) pll)))
  40.             )
  41.           )
  42.         )
  43.         (setq r nil pln xx)
  44.       )
  45.     )
  46.     (if r
  47.       (progn
  48.         (setq pln r)
  49.         (foreach x pp
  50.           (setq pl (vl-remove x pl))
  51.         )
  52.         (setq r nil pp nil)
  53.       )
  54.       (setq pl nil)
  55.     )
  56.   )
  57.   (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pln (cdr pln))))
  58.     (append
  59.       (list
  60.         '(0 . "LWPOLYLINE")
  61.         '(100 . "AcDbEntity")
  62.         '(100 . "AcDbPolyline")
  63.         (cons 90 (length pln))
  64.         (cons 70 (* (getvar 'plinegen) 128))
  65.         '(38 . 0.0)
  66.       )
  67.       (mapcar (function (lambda ( x ) (cons 10 x))) pln)
  68.       (list
  69.         '(210 0.0 0.0 1.0)
  70.         '(62 . 1)
  71.       )
  72.     )
  73.   )
  74.   (prompt "\nDistance : ") (princ (rtos d 2 50))
  75.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds...")
  76.   (princ)
  77. )
  78.  

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

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: Shortest Path between two points on grid and cover all points
« Reply #13 on: December 15, 2018, 07:07:27 AM »
Now added checking for intersections... Untested though...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:TSP-2D-MR-START-END ( / ss ti i pl sp ep pln dmin k plp pld pll d r pp lil lii1 lii2 lil1 lil2 lil3 ip )
  2.   (setq ss (ssget '((0 . "POINT"))))
  3.   (repeat (setq i (sslength ss))
  4.     (setq pl (cons (mapcar (function +) '(0 0) (cdr (assoc 10 (entget (ssname ss (setq i (1- i))))))) pl))
  5.   )
  6.   (initget 1)
  7.   (setq sp (mapcar (function +) '(0 0) (trans (getpoint "\nStart/end point from selection set : ") 1 0)))
  8.   (initget 1)
  9.   (setq ep (mapcar (function +) '(0 0) (trans (getpoint "\nEnd/start point from selection set : ") 1 0)))
  10.   (setq ti (car (_vl-times)))
  11.   (setq pln (list sp ep))
  12.   (setq pl (vl-remove sp pl) pl (vl-remove ep pl))
  13.   (while pl
  14.     (foreach p pl
  15.       (setq k -1)
  16.       (repeat (1- (length pln))
  17.         (setq k (1+ k))
  18.         (setq plp (reverse (member (nth k pln) (reverse pln))))
  19.         (setq pls (cdr (member (nth k pln) pln)))
  20.         (setq pll (append plp (list p) pls))
  21.         (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pll (cdr pll))))
  22.         (setq r (cons (list d pll) r))
  23.       )
  24.     )
  25.     (setq r (vl-sort r (function (lambda ( a b ) (< (car a) (car b))))))
  26.     (setq r (vl-remove-if-not (function (lambda ( x ) (equal (caar r) (car x) 1e-8))) r))
  27.     (setq dmin 1e+99)
  28.     (foreach xx (mapcar (function cadr) r)
  29.       (if (vl-remove (vl-some (function (lambda ( x ) (if (vl-position x pl) x))) xx) pl)
  30.         (foreach p (vl-remove (vl-some (function (lambda ( x ) (if (vl-position x pl) x))) xx) pl)
  31.           (setq k -1)
  32.           (repeat (1- (length xx))
  33.             (setq k (1+ k))
  34.             (setq plp (reverse (member (nth k xx) (reverse xx))))
  35.             (setq pls (cdr (member (nth k xx) xx)))
  36.             (setq pll (append plp (list p) pls))
  37.             (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pll (cdr pll))))
  38.             (if (< d dmin)
  39.               (setq dmin d r pll pp (vl-remove nil (mapcar (function (lambda ( x ) (if (vl-position x pl) x))) pll)))
  40.             )
  41.           )
  42.         )
  43.         (setq r nil pln xx)
  44.       )
  45.     )
  46.     (if r
  47.       (progn
  48.         (setq pln r)
  49.         (foreach x pp
  50.           (setq pl (vl-remove x pl))
  51.         )
  52.         (setq r nil pp nil)
  53.       )
  54.       (setq pl nil)
  55.     )
  56.   )
  57.   (setq lil (mapcar (function (lambda ( a b ) (list a b))) pln (cdr pln)))
  58.   (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)
  59.     (if (> (vl-position lii1 lil) (vl-position lii2 lil))
  60.       (mapcar (function set) '(lii1 lii2) (list lii2 lii1))
  61.     )
  62.     (setq lil1 (reverse (cdr (member lii1 (reverse lil)))))
  63.     (setq lil2 (cdr (member lii2 (reverse (cdr (member lii1 lil))))))
  64.     (setq lil3 (cdr (member lii2 lil)))
  65.     (setq lil (append lil1 (list (list (car lii1) (car lii2))) (mapcar (function reverse) lil2) (list (list (cadr lii1) (cadr lii2))) lil3))
  66.   )
  67.   (setq pln (append (mapcar (function car) lil) (list (cadr (last lil)))))
  68.   (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pln (cdr pln))))
  69.     (append
  70.       (list
  71.         '(0 . "LWPOLYLINE")
  72.         '(100 . "AcDbEntity")
  73.         '(100 . "AcDbPolyline")
  74.         (cons 90 (length pln))
  75.         (cons 70 (* (getvar 'plinegen) 128))
  76.         '(38 . 0.0)
  77.       )
  78.       (mapcar (function (lambda ( x ) (cons 10 x))) pln)
  79.       (list
  80.         '(210 0.0 0.0 1.0)
  81.         '(62 . 1)
  82.       )
  83.     )
  84.   )
  85.   (prompt "\nDistance : ") (princ (rtos d 2 50))
  86.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds...")
  87.   (princ)
  88. )
  89.  

[EDIT : Tested and no good... Discard this code and use previous one...]
[EDIT2 : I've fixed it...]

M.R.
« Last Edit: December 15, 2018, 07:58:29 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: Shortest Path between two points on grid and cover all points
« Reply #14 on: December 16, 2018, 01:47:07 PM »
Start-end version of TSP according to my latest improvement in speed... Look at TSP topic of Evgeniy Elpanov for more info (Lee Mac provided link in 1st reply)...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:TSP-2D-MR-START-END ( / unique car-sort ss fuzz ti i pl sp ep pln dmin k plp pld pll d dl r rr pp lil lii1 lii2 lil1 lil2 lil3 ip ppp pps f )
  2.  
  3.   (defun unique ( l )
  4.     (if l
  5.       (cons (car l)
  6.         (unique (vl-remove-if (function (lambda ( x ) (equal x (car l) 1e-8))) l))
  7.       )
  8.     )
  9.   )
  10.  
  11.   ;;; (car-sort '(2 4 1 3 5 1) '<) => nil
  12.   ;;; (car-sort '(2 4 1 3 5 1) '<=) => 1
  13.   (defun car-sort ( l f / removenth r k )
  14.  
  15.     (defun removenth ( l n / k )
  16.       (setq k -1)
  17.       (vl-remove-if (function (lambda ( x ) (= (setq k (1+ k)) n))) l)
  18.     )
  19.  
  20.     (setq k -1)
  21.     (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)
  22.     r
  23.   )
  24.  
  25.   (setq ss (ssget '((0 . "POINT"))))
  26.   (repeat (setq i (sslength ss))
  27.     (setq pl (cons (mapcar (function +) '(0 0) (cdr (assoc 10 (entget (ssname ss (setq i (1- i))))))) pl))
  28.   )
  29.   (initget 1)
  30.   (setq sp (mapcar (function +) '(0 0) (trans (getpoint "\nStart/end point from selection set : ") 1 0)))
  31.   (initget 1)
  32.   (setq ep (mapcar (function +) '(0 0) (trans (getpoint "\nEnd/start point from selection set : ") 1 0)))
  33.   (initget 7)
  34.   (setq fuzz (getdist "\nPick or specify radius of point cloud fuzz : "))
  35.   (setq ti (car (_vl-times)))
  36.   (setq pln (list sp ep))
  37.   (setq pl (vl-remove sp pl) pl (vl-remove ep pl))
  38.   (setq ppp (vl-remove-if-not (function (lambda ( p ) (< (distance p (car pln)) fuzz))) pl))
  39.   (while pl
  40.     (foreach p (if (null ppp) pl ppp)
  41.       (setq k -1)
  42.       (repeat (1- (length pln))
  43.         (setq k (1+ k))
  44.         (setq plp (reverse (member (nth k pln) (reverse pln))))
  45.         (setq pls (cdr (member (nth k pln) pln)))
  46.         (setq pll (append plp (list p) pls))
  47.         (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pll (cdr pll))))
  48.         (setq r (cons (list d pll) r))
  49.       )
  50.     )
  51.     ;|
  52.     (setq r (vl-sort r (function (lambda ( a b ) (< (car a) (car b))))))
  53.     (setq dl (unique (mapcar (function car) r)))
  54.     ;(cond
  55.     ;  ( (cadddr dl)
  56.     ;    (setq d (cadddr dl))
  57.     ;  )
  58.     ;  ( (caddr dl)
  59.     ;    (setq d (caddr dl))
  60.     ;  )
  61.     ;  ( (cadr dl)
  62.     ;    (setq d (cadr dl))
  63.     ;  )
  64.     ;  ( t
  65.     ;    (setq d (car dl))
  66.     ;  )
  67.     ;)
  68.     (setq d (last dl))
  69.     (setq r (vl-remove-if-not (function (lambda ( x ) (<= (car x) d))) r))
  70.     |;
  71.     (setq dmin 1e+99)
  72.     (foreach xx (mapcar (function cadr) r)
  73.       (if (vl-remove (vl-some (function (lambda ( x ) (if (vl-position x pl) x))) xx) pl)
  74.         (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))
  75.           (setq k -1)
  76.           (repeat (1- (length xx))
  77.             (setq k (1+ k))
  78.             (setq plp (reverse (member (nth k xx) (reverse xx))))
  79.             (setq pls (cdr (member (nth k xx) xx)))
  80.             (setq pll (append plp (list p) pls))
  81.             (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pll (cdr pll))))
  82.             (if (< d dmin)
  83.               (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))
  84.             )
  85.           )
  86.         )
  87.         (progn
  88.           (setq k -1)
  89.           (repeat (length xx)
  90.             (setq k (1+ k))
  91.             (setq plp (reverse (member (nth k xx) (reverse xx))))
  92.             (setq pls (cdr (member (nth k xx) xx)))
  93.             (setq pll (append plp (list (car pl)) pls))
  94.             (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pll (cdr pll))))
  95.             (if (< d dmin)
  96.               (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))
  97.             )
  98.           )
  99.           (setq f t)
  100.         )
  101.       )
  102.     )
  103.     (if f
  104.       (setq pln (cadr (car-sort rr (function (lambda ( a b ) (<= (car a) (car b)))))) r nil)
  105.       (progn
  106.         (setq rr (car-sort rr (function (lambda ( a b ) (<= (car a) (car b))))))
  107.         (setq r (cadr rr) pp (caddr rr) rr nil)
  108.       )
  109.     )
  110.     (if r
  111.       (progn
  112.         (setq pln r ppp nil)
  113.         (foreach x pp
  114.           (setq pl (vl-remove x pl))
  115.         )
  116.         (foreach x pp
  117.           (setq pps (vl-remove-if-not (function (lambda ( p ) (< (distance p x) fuzz))) pl))
  118.           (setq pps (vl-remove-if (function (lambda ( p ) (vl-position p ppp))) pps))
  119.           (setq ppp (append pps ppp))
  120.         )
  121.         (setq r nil pp nil)
  122.       )
  123.       (setq pl nil)
  124.     )
  125.   )
  126.   (setq lil (mapcar (function (lambda ( a b ) (list a b))) pln (cdr pln)))
  127.   (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)
  128.     (if (> (vl-position lii1 lil) (vl-position lii2 lil))
  129.       (mapcar (function set) '(lii1 lii2) (list lii2 lii1))
  130.     )
  131.     (setq lil1 (reverse (cdr (member lii1 (reverse lil)))))
  132.     (setq lil2 (cdr (member lii2 (reverse (cdr (member lii1 lil))))))
  133.     (setq lil3 (cdr (member lii2 lil)))
  134.     (setq lil (append lil1 (list (list (car lii1) (car lii2))) (mapcar (function reverse) lil2) (list (list (cadr lii1) (cadr lii2))) lil3))
  135.   )
  136.   (setq pln (append (mapcar (function car) lil) (list (cadr (last lil)))))
  137.   (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pln (cdr pln))))
  138.     (append
  139.       (list
  140.         '(0 . "LWPOLYLINE")
  141.         '(100 . "AcDbEntity")
  142.         '(100 . "AcDbPolyline")
  143.         (cons 90 (length pln))
  144.         (cons 70 (* (getvar 'plinegen) 128))
  145.         '(38 . 0.0)
  146.       )
  147.       (mapcar (function (lambda ( x ) (cons 10 x))) pln)
  148.       (list
  149.         '(210 0.0 0.0 1.0)
  150.         '(62 . 1)
  151.       )
  152.     )
  153.   )
  154.   (prompt "\nDistance : ") (princ (rtos d 2 50))
  155.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds...")
  156.   (princ)
  157. )
  158.  

P.S. Untested though...

Regards, M.R.
« Last Edit: January 03, 2019, 09:55:02 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube