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

0 Members and 1 Guest are viewing this topic.

#### ribarm

• Water Moccasin
• Posts: 2321
• Marko Ribar, architect
##### Re: Shortest Path between two points on grid and cover all points
« Reply #15 on: January 04, 2019, 05:03:45 AM »
My latest revision according to newly posted code for 2D TSP topic started by Evgeniy Elpanov...

Code - Auto/Visual Lisp: [Select]
1. (defun c:TSP-2D-MR-START-END ( / car-sort plstdiff processrs ss ti i pl pln k plp pld pll d r rr ppp lil lii1 lii2 lil1 lil2 lil3 ip f kk n )
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 plstdiff ( l1 l2 )
18.     (foreach p l1
19.       (setq l2 (vl-remove p l2))
20.     )
21.     l2
22.   )
23.
24.   (defun processrs ( r / rr )
25.     (foreach xx r
26.       (if (and (null f) (if (equal xx pln) (setq ppp pl) (setq ppp (plstdiff xx pl))))
27.         (foreach p ppp
28.           (setq k -1)
29.           (repeat (1- (length xx))
30.             (setq k (1+ k))
31.             (setq plp (reverse (member (nth k xx) (reverse xx))))
32.             (setq pls (cdr (member (nth k xx) xx)))
33.             (setq pll (append plp (list p) pls))
34.             (setq rr (cons pll rr))
35.           )
36.         )
37.         (setq f t)
38.       )
39.     )
40.     (if f
41.         (setq pl nil)
42.         r
43.       )
44.       (if (= kk n)
45.           (setq kk 0)
46.           (setq rr (mapcar (function (lambda ( x ) (list (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) x (cdr x))) x))) rr))
47.           (setq rr (list (cadr (car-sort rr (function (lambda ( a b ) (<= (car a) (car b))))))))
48.         )
49.         rr
50.       )
51.     )
52.   )
53.
54.   (setq ss (ssget '((0 . "POINT"))))
55.   (repeat (setq i (sslength ss))
56.     (setq pl (cons (mapcar (function +) '(0 0) (cdr (assoc 10 (entget (ssname ss (setq i (1- i))))))) pl))
57.   )
58.   (initget 1)
59.   (setq sp (mapcar (function +) '(0 0) (trans (getpoint "\nStart/end point from selection set : ") 1 0)))
60.   (initget 1)
61.   (setq ep (mapcar (function +) '(0 0) (trans (getpoint "\nEnd/start point from selection set : ") 1 0)))
62.   (initget 6)
63.   (setq n (getint "\nSpecify speed factor - reliability - [1-fast/2-slow] <1> : "))
64.   (if (null n)
65.     (setq n 1)
66.   )
67.   (setq ti (car (_vl-times)))
68.   (setq pln (list sp ep))
69.   (setq pl (vl-remove sp pl) pl (vl-remove ep pl))
70.   (setq kk 0)
71.   (while pl
72.     (setq kk (1+ kk))
73.     (if (null rr)
74.       (setq rr (processrs (list pln)))
75.       (setq rr (processrs rr))
76.     )
77.   )
78.   (setq rr (mapcar (function (lambda ( x ) (list (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) x (cdr x))) x))) rr))
79.   (setq pln (cadr (car-sort rr (function (lambda ( a b ) (<= (car a) (car b)))))))
80.   (setq lil (mapcar (function (lambda ( a b ) (list a b))) pln (cdr pln)))
81.   (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)
82.     (if (> (vl-position lii1 lil) (vl-position lii2 lil))
83.       (mapcar (function set) '(lii1 lii2) (list lii2 lii1))
84.     )
85.     (setq lil1 (reverse (cdr (member lii1 (reverse lil)))))
86.     (setq lil2 (cdr (member lii2 (reverse (cdr (member lii1 lil))))))
87.     (setq lil3 (cdr (member lii2 lil)))
88.     (setq lil (append lil1 (list (list (car lii1) (car lii2))) (mapcar (function reverse) lil2) (list (list (cadr lii1) (cadr lii2))) lil3))
89.   )
90.   (setq pln (append (mapcar (function car) lil) (list (cadr (last lil)))))
91.   (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pln (cdr pln))))
92.       (list
93.         '(0 . "LWPOLYLINE")
94.         '(100 . "AcDbEntity")
95.         '(100 . "AcDbPolyline")
96.         (cons 90 (length pln))
97.         (cons 70 (* (getvar 'plinegen) 128))
98.         '(38 . 0.0)
99.       )
100.       (mapcar (function (lambda ( x ) (cons 10 x))) pln)
101.       (list
102.         '(210 0.0 0.0 1.0)
103.         '(62 . 1)
104.       )
105.     )
106.   )
107.   (prompt "\nDistance : ") (princ (rtos d 2 50))
108.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds...")
109.   (princ)
110. )
111.

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