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

0 Members and 1 Guest are viewing this topic.

ribarm

  • Water Moccasin
  • Posts: 2369
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #90 on: October 22, 2018, 06:43:36 PM »
I've tried to optimize up to 8 points to up to 10 points, but something went wrong... I removed sublists that are good; it seems that this tracking method is less reliable... See attached DWG for test... Sorry... M.R.

[EDIT : I fixed wrong formula, but now for 10 points, I get : ]
Code: [Select]
; error: Exception occurred: 0xC0000005 (Access Violation)
; warning: unwind skipped on exception
; error: Exception occurred: 0xC0000005 (Access Violation)

[EDIT : I thought that error was due to recursion of (factorial) sub, but I am wrong again... The same error occur even when iterative version...]

Code - Auto/Visual Lisp: [Select]
  1. (defun c:TSP-bruteforce-3dpoints ( / unique factorial permutate-exclude-reverses ss i pl 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.   (defun factorial ( k )
  9.     (if (> k 1) (setq k (* k (factorial (1- k)))) k)
  10.   )
  11. |;
  12.  
  13.   (defun factorial ( k / kk r )
  14.     (while (> k 0)
  15.       (setq k (1- k))
  16.       (if (null kk)
  17.         (setq kk 1)
  18.         (setq kk (1+ kk))
  19.       )
  20.       (if (null r)
  21.         (setq r 1)
  22.         (setq r (* kk r))
  23.       )
  24.     )
  25.     r
  26.   )
  27.  
  28.   ;;;--------------------------------------------------------------------------
  29.   ;;; Permutate a single list.
  30.   ;;; Recursive solution by Reini Urban
  31.   ;;; (permutate '(0 1 2 3)) => ((0 1 2 3) (0 1 3 2) (0 2 3 1) (0 2 1 3) (0 3 1 2) (0 3 2 1) (1 2 3 0) (1 2 0 3) (1 3 0 2) (1 3 2 0) (1 0 2 3) (1 0 3 2) (2 3 0 1) (2 3 1 0) (2 0 1 3) (2 0 3 1) (2 1 3 0) (2 1 0 3) (3 0 1 2) (3 0 2 1) (3 1 2 0) (3 1 0 2) (3 2 0 1) (3 2 1 0))
  32.   ;;; Modified version for exclude reverses sublists by M.R.
  33.   ;;; (permutate-exclude-reverses '(0 1 2 3)) => ((0 1 2 3) (0 1 3 2) (0 2 3 1) (0 2 1 3) (0 3 1 2) (0 3 2 1) (1 2 3 0) (1 2 0 3) (1 3 0 2) (1 3 2 0) (2 3 0 1) (2 3 1 0))
  34.   ;;;--------------------------------------------------------------------------
  35.   (defun permutate-exclude-reverses ( l / x1 z k kk )
  36.     (cond
  37.       ( (null l) l )
  38.       ( (= (length l) 2) (list l (reverse l)) )
  39.       ( t
  40.         (setq z 1)
  41.         (repeat (length l)
  42.           (foreach x (permutate-exclude-reverses (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))
  43.             (if (= (length l) n) ;; n - lexical global from routine processing previous steps
  44.               (progn
  45.                 (if (null k)
  46.                   (setq k 0)
  47.                   (setq k (1+ k))
  48.                 )
  49.                 (if (null kk)
  50.                   (setq kk 0)
  51.                   (setq kk (1+ kk))
  52.                 )
  53.                 (if (= (factorial (1- n)) kk)
  54.                   (setq z (1+ z) kk 0)
  55.                 )
  56.                 (if (and (<= (* (1- z) (factorial (1- n))) k) (< k (+ (* (1- z) (factorial (1- n))) (- (factorial (1- n)) (* (factorial (1- (1- n))) (1- z))))))
  57.                   (setq x1 (cons (cons (car l) x) x1)) ;; final recursion - check for reversers and (cons) only unique lists
  58.                 )
  59.               )
  60.               (setq x1 (cons (cons (car l) x) x1)) ;; all inner recursions ;; 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))
  61.             )
  62.           )
  63.           (setq l (append (cdr l) (list (car l)))) ;; l = '(0 1 2) - loop1; l = '(1 2 0) - loop2; l = '(2 0 1) - loop3
  64.         )
  65.         (reverse x1)
  66.       )
  67.     )
  68.   )
  69.  
  70.   (setq ss (ssget '((0 . "POINT"))))
  71.   (repeat (setq i (sslength ss))
  72.     (setq pl (cons (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) pl))
  73.   )
  74.   (setq pl (unique pl))
  75.   (setq n (length pl))
  76.   (setq k n)
  77.   (repeat n
  78.     (setq l (cons (setq k (1- k)) l))
  79.   )
  80.   (setq ti (car (_vl-times)))
  81.   (setq ll (permutate-exclude-reverses l))
  82.   (setq dmin 1e+308)
  83.   (foreach x ll
  84.     (setq x (mapcar '(lambda ( a ) (nth a pl)) x))
  85.     (setq d (apply '+ (mapcar '(lambda ( a b ) (distance a b)) x (append (cdr x) (list (car x))))))
  86.     (if (> dmin d)
  87.       (setq dmin d rtn x)
  88.     )
  89.   )
  90.   (vl-cmdf "_.3DPOLY")
  91.   (foreach p rtn
  92.     (vl-cmdf "_non" (trans p 0 1))
  93.   )
  94.   (vl-cmdf "_C")
  95.   (prompt "\nDistance : ") (princ (rtos dmin 2 50))
  96.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds.")
  97.   (princ)
  98. )
  99.  
« Last Edit: October 24, 2018, 10:40:57 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2369
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #91 on: October 23, 2018, 03:09:36 AM »
Something's still wrong... If you set break point at line (setq dmin 1e+308), just when ll is evaluated and you picked 5 points, you can test list ll by :
Code: [Select]
(vl-some '(lambda ( x ) (vl-position (reverse x) ll)) ll)

If everyting's fine this should return nil showing that there are no reversed sub lists, but it returns 59, so 1 good sub list wasn't calculated and instead there is one reversed (nth 59 ll) - (nth 1 ll) are reverses... I am very sorry, but I think I can't track this thing, simply either order of creation of sub lists are wrong, or my estimation that there should be 60 sub lists out of 120 that are reverses is wrong for which I doubt... Simple tests for 3 and 4 points return always half (6/2 = 3) and (24/2 = 12)... So next one would be (120/2 = 60)...

And in my comment there is reverse pair (nth 11 ll) - (nth 1 ll) - look closer they are reverses - read one of them reverse and it should be exactly the same as other one... Wait there are more : (nth 2 ll) and (nth 9 ll) - check it out... And even more (nth 5 ll) and (nth 6 ll)...

When I look closer in my comment, I think that here is an error too there should be (n!/(n - 1)), so (6/2 = 3); (24/3 = 9); so next one is (120/4 = 30), and so on...
« Last Edit: October 23, 2018, 03:36:05 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2369
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #92 on: October 23, 2018, 06:14:09 AM »
I've tried it again, still no good, there are reverse sub lists - you can see it from comment - now it's little different, but not good...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:TSP-bruteforce-3dpoints ( / unique factorial permutate-exclude-reverses ss i pl 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.   (defun factorial ( k )
  9.     (if (> k 1) (setq k (* k (factorial (1- k)))) k)
  10.   )
  11. |;
  12.  
  13.   (defun factorial ( k / kk r )
  14.     (while (> k 0)
  15.       (setq k (1- k))
  16.       (if (null kk)
  17.         (setq kk 1)
  18.         (setq kk (1+ kk))
  19.       )
  20.       (if (null r)
  21.         (setq r 1)
  22.         (setq r (* kk r))
  23.       )
  24.     )
  25.     r
  26.   )
  27.  
  28.   ;;;--------------------------------------------------------------------------
  29.   ;;; Permutate a single list.
  30.   ;;; Recursive solution by Reini Urban
  31.   ;;; (permutate '(0 1 2 3)) => ((0 1 2 3) (0 1 3 2) (0 2 3 1) (0 2 1 3) (0 3 1 2) (0 3 2 1) (1 2 3 0) (1 2 0 3) (1 3 0 2) (1 3 2 0) (1 0 2 3) (1 0 3 2) (2 3 0 1) (2 3 1 0) (2 0 1 3) (2 0 3 1) (2 1 3 0) (2 1 0 3) (3 0 1 2) (3 0 2 1) (3 1 2 0) (3 1 0 2) (3 2 0 1) (3 2 1 0))
  32.   ;;; Modified version for exclude reverses sublists by M.R.
  33.   ;;; (permutate-exclude-reverses '(0 1 2 3)) => ((0 1 2 3) (0 1 3 2) (0 2 3 1) (0 2 1 3) (0 3 1 2) (0 3 2 1) (1 2 3 0) (1 2 0 3) (1 3 2 0) (1 0 2 3) (2 3 0 1) (2 3 1 0))
  34.   ;;;--------------------------------------------------------------------------
  35.   (defun permutate-exclude-reverses ( l / x1 z k kk q qq qqq lll )
  36.     (cond
  37.       ( (null l) l )
  38.       ( (= (length l) 2) (list l (reverse l)) )
  39.       ( t
  40.         (if (= (length l) n)
  41.           (progn
  42.             (setq z 0)
  43.             (setq qqq (1- n))
  44.             (repeat (1- n)
  45.               (if (not (zerop (rem (setq qqq (1+ qqq)) (1- n))))
  46.                 (setq lll (cons t lll))
  47.                 (setq lll (cons nil lll))
  48.               )
  49.             )
  50.             (setq lll (reverse lll))
  51.           )
  52.         )
  53.         (repeat (length l)
  54.           (foreach x (permutate-exclude-reverses (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))
  55.             (if (= (length l) n) ;; n - lexical global from routine processing previous steps ;; final recursion - check for reversers and (cons) only unique lists
  56.               (progn
  57.                 (if (null k)
  58.                   (setq k 1)
  59.                   (setq k (1+ k))
  60.                 )
  61.                 (if (null kk)
  62.                   (setq kk 1)
  63.                 )
  64.                 (if (= (factorial (1- n)) (1- kk))
  65.                   (setq z (1+ z) kk 1 qq nil)
  66.                 )
  67.                 (setq q (- (factorial (1- n)) (* (factorial (1- (1- n))) z)))
  68.                 (if (> z 0)
  69.                   (if (and (nth (rem (1- k) (1- n)) lll) (< (length qq) q))
  70.                     (setq x1 (cons (cons (car l) x) x1) qq (cons t qq))
  71.                   )
  72.                   (setq x1 (cons (cons (car l) x) x1))
  73.                 )
  74.                 (setq kk (1+ kk))
  75.               )
  76.               (setq x1 (cons (cons (car l) x) x1)) ;; all inner recursions ;; 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))
  77.             )
  78.           )
  79.           (setq l (append (cdr l) (list (car l)))) ;; l = '(0 1 2) - loop1; l = '(1 2 0) - loop2; l = '(2 0 1) - loop3
  80.         )
  81.         (reverse x1)
  82.       )
  83.     )
  84.   )
  85.  
  86.   (setq ss (ssget '((0 . "POINT"))))
  87.   (repeat (setq i (sslength ss))
  88.     (setq pl (cons (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) pl))
  89.   )
  90.   (setq pl (unique pl))
  91.   (setq n (length pl))
  92.   (setq k n)
  93.   (repeat n
  94.     (setq l (cons (setq k (1- k)) l))
  95.   )
  96.   (setq ti (car (_vl-times)))
  97.   (setq ll (permutate-exclude-reverses l))
  98.   (setq dmin 1e+308)
  99.   (foreach x ll
  100.     (setq x (mapcar '(lambda ( a ) (nth a pl)) x))
  101.     (setq d (apply '+ (mapcar '(lambda ( a b ) (distance a b)) x (append (cdr x) (list (car x))))))
  102.     (if (> dmin d)
  103.       (setq dmin d rtn x)
  104.     )
  105.   )
  106.   (vl-cmdf "_.3DPOLY")
  107.   (foreach p rtn
  108.     (vl-cmdf "_non" (trans p 0 1))
  109.   )
  110.   (vl-cmdf "_C")
  111.   (prompt "\nDistance : ") (princ (rtos dmin 2 50))
  112.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds.")
  113.   (princ)
  114. )
  115.  
« Last Edit: October 24, 2018, 10:41:21 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2369
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #93 on: October 23, 2018, 10:09:54 AM »
I achieved what I wanted... This is good version, there are no reverse sub lists... The code is little shorter, and it was in front of my eyes all the time, just had to think more over it...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:TSP-bruteforce-3dpoints ( / unique factorial permutate-exclude-reverses ss i pl n k l ti ll dmin x d rtn )
  2.  
  3.   (defun unique ( l )
  4.     (if l (cons (car l) (unique (vl-remove-if (function (lambda ( x ) (equal x (car l) 1e-6))) l))))
  5.   )
  6.  
  7. ;|
  8.   (defun factorial ( k )
  9.     (if (> k 1) (setq k (* k (factorial (1- k)))) k)
  10.   )
  11. |;
  12.  
  13.   (defun factorial ( k / kk r )
  14.     (while (> k 0)
  15.       (setq k (1- k))
  16.       (if (null kk)
  17.         (setq kk 1)
  18.         (setq kk (1+ kk))
  19.       )
  20.       (if (null r)
  21.         (setq r 1)
  22.         (setq r (* kk r))
  23.       )
  24.     )
  25.     r
  26.   )
  27.  
  28.   ;;;--------------------------------------------------------------------------
  29.   ;;; Permutate a single list.
  30.   ;;; Recursive solution by Reini Urban
  31.   ;;; (permutate '(0 1 2 3)) => ((0 1 2 3) (0 1 3 2) (0 2 3 1) (0 2 1 3) (0 3 1 2) (0 3 2 1) (1 2 3 0) (1 2 0 3) (1 3 0 2) (1 3 2 0) (1 0 2 3) (1 0 3 2) (2 3 0 1) (2 3 1 0) (2 0 1 3) (2 0 3 1) (2 1 3 0) (2 1 0 3) (3 0 1 2) (3 0 2 1) (3 1 2 0) (3 1 0 2) (3 2 0 1) (3 2 1 0))
  32.   ;;; Modified version for exclude reverses sublists by M.R.
  33.   ;;; (permutate-exclude-reverses '(0 1 2 3)) => ((0 1 2 3) (0 1 3 2) (0 2 3 1) (0 2 1 3) (0 3 1 2) (0 3 2 1) (1 2 0 3) (1 3 0 2) (1 0 2 3) (1 0 3 2) (2 0 1 3) (2 1 0 3))
  34.   ;;;--------------------------------------------------------------------------
  35.   (defun permutate-exclude-reverses ( l / x1 z zz zp kk q qq g gg )
  36.     (cond
  37.       ( (null l) l )
  38.       ( (= (length l) 2) (list l (reverse l)) )
  39.       ( t
  40.         (if (= (length l) n)
  41.           (setq z 0)
  42.         )
  43.         (repeat (length l)
  44.           (foreach x (permutate-exclude-reverses (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))
  45.             (if (= (length l) n) ;; n - lexical global from routine processing previous steps ;; final recursion - check for reversers and (cons) only unique lists
  46.               (progn
  47.                 (if (null kk)
  48.                   (setq kk 1)
  49.                 )
  50.                 (if (null g)
  51.                   (setq g (factorial (1- n)))
  52.                 )
  53.                 (if (null gg)
  54.                   (setq gg (/ g (1- n)))
  55.                 )
  56.                 (setq zp zz)
  57.                 (if (= g (1- kk))
  58.                   (setq z (1+ z) kk 1 qq nil zz (cons (1- z) zz))
  59.                 )
  60.                 (if (/= (length zp) (length zz))
  61.                   (setq q (- g (* gg z)))
  62.                 )
  63.                 (if (> z 0)
  64.                   (if (and (< (length qq) q) (not (vl-position (last x) zz)))
  65.                     (setq x1 (cons (cons (car l) x) x1) qq (cons t qq))
  66.                   )
  67.                   (setq x1 (cons (cons (car l) x) x1))
  68.                 )
  69.                 (setq kk (1+ kk))
  70.               )
  71.               (setq x1 (cons (cons (car l) x) x1)) ;; all inner recursions ;; 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))
  72.             )
  73.           )
  74.           (setq l (append (cdr l) (list (car l)))) ;; l = '(0 1 2) - loop1; l = '(1 2 0) - loop2; l = '(2 0 1) - loop3
  75.         )
  76.         (reverse x1)
  77.       )
  78.     )
  79.   )
  80.  
  81.   (setq ss (ssget '((0 . "POINT"))))
  82.   (repeat (setq i (sslength ss))
  83.     (setq pl (cons (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) pl))
  84.   )
  85.   (setq pl (unique pl))
  86.   (setq n (length pl))
  87.   (setq k n)
  88.   (repeat n
  89.     (setq l (cons (setq k (1- k)) l))
  90.   )
  91.   (setq ti (car (_vl-times)))
  92.   (setq ll (permutate-exclude-reverses l))
  93.   (setq dmin 1e+308)
  94.   (foreach x ll
  95.     (setq x (mapcar (function (lambda ( a ) (nth a pl))) x))
  96.     (setq d (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) x (append (cdr x) (list (car x))))))
  97.     (if (> dmin d)
  98.       (setq dmin d rtn x)
  99.     )
  100.   )
  101.   (vl-cmdf "_.3DPOLY")
  102.   (foreach p rtn
  103.     (vl-cmdf "_non" (trans p 0 1))
  104.   )
  105.   (vl-cmdf "_C")
  106.   (prompt "\nDistance : ") (princ (rtos dmin 2 50))
  107.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds.")
  108.   (princ)
  109. )
  110.  

P.S. 10 points are still too much for PC, so still up to 9 pts...
Regards, M.R.
« Last Edit: October 24, 2018, 09:23:23 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2369
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #94 on: October 24, 2018, 09:26:34 AM »
Still though I am boggling with this issue : Why is my firstly posted code faster than last one? IMHO it should be opposite... Who can explain it?
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

It's Alive!

  • BricsCAD
  • Needs a day job
  • Posts: 7032
  • AKA Daniel
Re: (Challenge) To draw the shortest lwpolyline
« Reply #95 on: October 26, 2018, 11:02:05 PM »
Straight up Approximate Nearest Neighbor (ANN) algorithm, using nanoflann.
In some cases using Manhattan worked better than Euclidian… 
red=first
yellow = last

ribarm

  • Water Moccasin
  • Posts: 2369
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #96 on: October 27, 2018, 01:50:31 AM »
Daniel, chlh_jd's code is more accurate, and BTW. real TSP is considered as 3D problem too with 3D points in 3D space...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

It's Alive!

  • BricsCAD
  • Needs a day job
  • Posts: 7032
  • AKA Daniel
Re: (Challenge) To draw the shortest lwpolyline
« Reply #97 on: October 27, 2018, 05:04:43 AM »
Daniel, chlh_jd's code is more accurate
Doh! crushed

real TSP is considered as 3D problem too with 3D points in 3D space...
your right, that adds a whole new dimension!

It's Alive!

  • BricsCAD
  • Needs a day job
  • Posts: 7032
  • AKA Daniel
Re: (Challenge) To draw the shortest lwpolyline
« Reply #98 on: October 27, 2018, 05:07:36 AM »
New 3d datasets, used
std::random_device
std::mt19937
std::uniform_real_distribution

10,100,1000 and 10000 points

edit, rand 100000 seems way to big, attached 10000
« Last Edit: October 27, 2018, 10:42:16 PM by nullptr »

It's Alive!

  • BricsCAD
  • Needs a day job
  • Posts: 7032
  • AKA Daniel
Re: (Challenge) To draw the shortest lwpolyline
« Reply #99 on: October 27, 2018, 05:15:59 AM »
just sort by distance (greedy)?  :mrgreen:

rand10 = 44.252606
rand100 = 2049.632063
rand1000 = 84593.961921
rand10000 = 3731327.006039
« Last Edit: October 28, 2018, 11:01:10 AM by nullptr »

ribarm

  • Water Moccasin
  • Posts: 2369
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #100 on: October 27, 2018, 08:05:32 AM »
1. find center point of complete point cloud
2. take closest point to center point as start
3. find path from start point to outer points using shortest distance between 2, 3, 4, 5 points cloud in one direction from inner to outer point of point cloud
4. append path 3. to main path - store last point as start for next loop
5. find next direction for next point cloud from start point (last from previous step) to center point - step 1.
6. loop 3-4 until all points are processed and calculate final path and its length

3rd step is the most important...
This is my vision and its not foolprof, but I think it may give desired in quickest time processed...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2369
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #101 on: October 27, 2018, 02:27:19 PM »
At least it works, but it's terribly wrong in difference of my previous codes that are good but useless for 10 and more points...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:TSP-3dpoints-MR ( / unique ptonline unit v^v rayincone car-sort nextpt ss i pl pll c p cpcloud cpcloudr dist ti )
  2.  
  3.   (defun unique ( l )
  4.     (if l (cons (car l) (unique (vl-remove-if (function (lambda ( x ) (equal x (car l) 1e-6))) l))))
  5.   )
  6. ;|
  7.   (defun ptonline ( p p1 p2 )
  8.     (equal (distance p1 p2) (+ (distance p1 p) (distance p p2)) 1e-8)
  9.   )
  10. |;
  11.   (defun unit ( v / d )
  12.     (if (not (equal (setq d (distance '(0.0 0.0 0.0) v)) 0.0 1e-8))
  13.       (mapcar (function (lambda ( x ) (/ x d))) v)
  14.     )
  15.   )
  16.  
  17.   (defun v^v ( u v )
  18.     (list
  19.       (- (* (cadr u) (caddr v)) (* (caddr u) (cadr v)))
  20.       (- (* (caddr u) (car v)) (* (car u) (caddr v)))
  21.       (- (* (car u) (cadr v)) (* (cadr u) (car v)))
  22.     )
  23.   )
  24.  
  25.   (defun rayincone ( apex paxis ang pray / d h p nv pv p1 p2 )
  26.     (setq d 10.0)
  27.     (setq h (* d (/ (sin ang) (cos ang))))
  28.     (setq p (mapcar (function *) (unit (mapcar (function -) paxis apex)) (list d d d)))
  29.     (setq nv (v^v (mapcar (function -) paxis apex) (mapcar (function -) pray apex)))
  30.     (setq pv (v^v nv (mapcar (function -) paxis apex)))
  31.     (setq p1 (mapcar (function +) p (mapcar (function *) (unit pv) (list h h h))))
  32.     (setq p2 (mapcar (function +) p (mapcar (function *) (unit pv) (list (- h) (- h) (- h)))))
  33.     (if (inters p1 p2 apex (mapcar (function +) apex (mapcar (function *) (unit (mapcar (function -) pray apex)) (list 100.0 100.0 100.0))))
  34.       t
  35.     )
  36.   )
  37.  
  38.   ;;; (car-sort '(2 4 1 3 5 1) '<) => nil
  39.   ;;; (car-sort '(2 4 1 3 5 1) '<=) => 1
  40.   (defun car-sort ( l f / removenth r k )
  41.  
  42.     (defun removenth ( l n / k )
  43.       (setq k -1)
  44.       (vl-remove-if (function (lambda ( x ) (= (setq k (1+ k)) n))) l)
  45.     )
  46.  
  47.     (setq k -1)
  48.     (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)
  49.     r
  50.   )
  51.  
  52.   (defun nextpt ( p ptlst )
  53.     (car-sort (vl-remove p ptlst) (function (lambda ( a b ) (<= (distance p a) (distance p b)))))
  54.   )
  55.  
  56.   (setq ss (ssget '((0 . "POINT"))))
  57.   (setq ti (car (_vl-times)))
  58.   (if ss
  59.     (repeat (setq i (sslength ss))
  60.       (setq pl (cons (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) pl))
  61.     )
  62.   )
  63.   (setq pl (unique pl))
  64.   (setq c (mapcar (function (lambda ( x ) (/ x (length pl)))) (apply (function mapcar) (cons (function +) pl))))
  65.   (setq pl (vl-sort pl (function (lambda ( a b ) (< (distance c a) (distance c b))))))
  66.   (while pl
  67.     (while (and pl (null cpcloud))
  68.       (setq p (car pl))
  69.       (setq cpcloud (vl-sort (vl-remove-if-not (function (lambda ( x ) (rayincone c p (/ pi 6.0) x))) (vl-remove p pl)) (function (lambda ( a b ) (< (distance p a) (distance p b))))))
  70.       (setq pll (cons p pll))
  71.       (setq pl (cdr pl))
  72.     )
  73.     (if (and pl cpcloud)
  74.       (progn
  75.         (setq pp (last cpcloud))
  76.         (while (and (setq p (nextpt p (setq cpcloud (vl-remove p cpcloud)))) (not (equal p pp 1e-6)))
  77.           (setq pll (cons p pll))
  78.           (setq pl (vl-remove p pl))
  79.         )
  80.         (setq cpcloud nil)
  81.       )
  82.     )
  83.     (if (and pl p (equal p pp 1e-6))
  84.       (progn
  85.         (setq pll (cons p pll))
  86.         (setq pl (vl-remove p pl))
  87.         (while (and pl (null cpcloudr))
  88.           (setq cpcloudr (vl-sort (vl-remove-if-not (function (lambda ( x ) (rayincone p c (/ pi 6.0) x))) (vl-remove p pl)) (function (lambda ( a b ) (< (distance p a) (distance p b))))))
  89.           (setq p (car-sort pl (function (lambda ( a b ) (<= (distance p a) (distance p b))))))
  90.           (setq pll (cons p pll))
  91.           (setq pl (vl-remove p pl))
  92.         )
  93.       )
  94.     )
  95.     (if (and pl cpcloudr)
  96.       (progn
  97.         (setq pp (car-sort cpcloudr (function (lambda ( a b ) (<= (distance c a) (distance c b))))))
  98.         (while (and (setq p (nextpt p (setq cpcloudr (vl-remove p cpcloudr)))) (not (equal p pp 1e-6)))
  99.           (setq pll (cons p pll))
  100.           (setq pl (vl-remove p pl))
  101.         )
  102.       )
  103.     )
  104.     (setq cpcloudr nil)
  105.     (if (and pl p (equal p pp 1e-6))
  106.       (progn
  107.         (setq pll (cons p pll))
  108.         (setq pl (vl-remove p pl))
  109.       )
  110.     )
  111.   )
  112.   (setq dist (apply (function +) (mapcar (function (lambda ( a b ) (distance a b))) pll (append (cdr pll) (list (car pll))))))
  113.   (vl-cmdf "_.3DPOLY")
  114.   (foreach p pll
  115.     (vl-cmdf "_non" (trans p 0 1))
  116.   )
  117.   (vl-cmdf "_C")
  118.   (prompt "\nDistance : ") (princ (rtos dist 2 50))
  119.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds.")
  120.   (princ)
  121. )
  122.  
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

It's Alive!

  • BricsCAD
  • Needs a day job
  • Posts: 7032
  • AKA Daniel
Re: (Challenge) To draw the shortest lwpolyline
« Reply #102 on: October 27, 2018, 10:38:15 PM »
At least it works, but it's terribly wrong in difference of my previous codes that are good but useless for 10 and more points...

what is your result for rand10? I tried to run it, but select , copy paste gives me line numbers... lol

ribarm

  • Water Moccasin
  • Posts: 2369
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #103 on: October 28, 2018, 06:07:52 AM »
RAND10 :
Distance : 62.71290278984382
Elapsed time : 0.04699999999999999 seconds.

RAND100 :
Distance : 6679.527823958952
Elapsed time : 0.7189999999999999 seconds.

RAND1000 :
Distance : 631481.0073386774
Elapsed time : 68.10999999999999 seconds.

RAND10000 :
I need about 10 hours of running... But I'll be back with info as soon as it finishes...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

It's Alive!

  • BricsCAD
  • Needs a day job
  • Posts: 7032
  • AKA Daniel
Re: (Challenge) To draw the shortest lwpolyline
« Reply #104 on: October 28, 2018, 06:45:41 AM »
I need about 10 hours of running... But I'll be back with info as soon as it finishes...

LOL! I tried adding 2-opt to mine, had to kill the process , Iím going to skip the bigger sets until I have a better algorithm