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

0 Members and 1 Guest are viewing this topic.

ElpanovEvgeniy

  • Water Moccasin
  • Posts: 1540
  • Moscow (Russia)
Re: (Challenge) To draw the shortest lwpolyline
« Reply #90 on: August 10, 2012, 07:07:08 AM »
'Serious' support  !

Try your code on regular lattices...


lst-a.lsp
蝸牛そろそろ登れ富士の山 /Kobayashi Issa/

chlh_jd

  • Guest
Re: (Challenge) To draw the shortest lwpolyline
« Reply #91 on: August 11, 2012, 08:54:36 AM »
'Serious' support  !

Try your code on regular lattices...


lst-a.lsp
I think you misunderstood " 'Serious' support ! " , What I mean is very supportive of your views  :-D
Just like you say , the GA method only provide a relatively feasible results . I'v try so much for lst-a and lst-b in your 1st post  , The code I post would not got the best .
 
Now really genetic algorithm for search of best of possible results in the program


TSP problem using the improved genetic algorithm to solve, may take years for me can not be resolved ,
However , your encouragement is my greatest motivation. :-)

ribarm

  • Water Moccasin
  • Posts: 2122
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #92 on: October 22, 2018, 07:25:30 AM »
Here are couple of brute-force versions for 3D points... Note that all of these are incredibly slower and can operate up to max 9 points for which routines will give results in reasonbly long time... They are based on permutations of points - so main sub function is (permutate) by Reini Urban... I only modified (permutate) in one example for which I thought I'll gain some better results but I was wrong... Pure brute force (permutate) + calculation of min. distances is the fastest - up to 9 points; then slower - up to 8 points; and last one with additional sub - up to 7 points...
So like Evgeniy I don't like big codes and I have hard time to understand big codes, but of course I like when I see that something is good and working better, so thanks to chlh_jd who helped me many times, still I trust these more general codes more, despite they can do it with only few points but correctly getting the result that was expected for TSP no matter what disposition of points are in 3D space...

Up to 9 points :

Code - Auto/Visual Lisp: [Select]
  1. (defun c:TSP-bruteforce-3dpoints ( / unique permutate 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.   ;;; 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.   (setq n (length pl))
  34.   (setq k n)
  35.   (repeat n
  36.     (setq l (cons (setq k (1- k)) l))
  37.   )
  38.   (setq ti (car (_vl-times)))
  39.   (setq ll (permutate l))
  40.   (setq dmin 1e+308)
  41.   (foreach x ll
  42.     (setq x (mapcar '(lambda ( a ) (nth a pl)) x))
  43.     (setq d (apply '+ (mapcar '(lambda ( a b ) (distance a b)) x (append (cdr x) (list (car x))))))
  44.     (if (> dmin d)
  45.       (setq dmin d rtn x)
  46.     )
  47.   )
  48.   (vl-cmdf "_.3DPOLY")
  49.   (foreach p rtn
  50.     (vl-cmdf "_non" (trans p 0 1))
  51.   )
  52.   (vl-cmdf "_C")
  53.   (prompt "\nDistance : ") (princ (rtos dmin 2 50))
  54.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds.")
  55.   (princ)
  56. )
  57.  

Up to 8 points, I tried but its still slower (permutate) sub modified :

Code - Auto/Visual Lisp: [Select]
  1. (defun c:TSP-bruteforce-3dpoints ( / unique 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.   ;;; 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.   ;;; Modified version for exclude reverses sublists by M.R.
  12.   ;;; (permutate-exclude-reverses '(0 1 2)) => ((0 1 2) (0 2 1) (1 0 2))
  13.   ;;;--------------------------------------------------------------------------
  14.   (defun permutate-exclude-reverses ( l / x1 q )
  15.     (cond
  16.       ( (null l) l )
  17.       ( (= (length l) 2) (list l (reverse l)) )
  18.       ( t
  19.         (repeat (length l)
  20.           (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))
  21.             (if (= (length l) n) ;; n - lexical global from routine processing previous steps
  22.               (if (not (vl-position (reverse (setq q (cons (car l) x))) x1)) ;; final recursion - check for reversers and (cons) only unique lists
  23.                 (setq x1 (cons q x1))
  24.               )
  25.               (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))
  26.             )
  27.           )
  28.           (setq l (append (cdr l) (list (car l)))) ;; l = '(0 1 2) - loop1; l = '(1 2 0) - loop2; l = '(2 0 1) - loop3
  29.         )
  30.         (reverse x1)
  31.       )
  32.     )
  33.   )
  34.  
  35.   (setq ss (ssget '((0 . "POINT"))))
  36.   (repeat (setq i (sslength ss))
  37.     (setq pl (cons (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) pl))
  38.   )
  39.   (setq pl (unique pl))
  40.   (setq n (length pl))
  41.   (setq k n)
  42.   (repeat n
  43.     (setq l (cons (setq k (1- k)) l))
  44.   )
  45.   (setq ti (car (_vl-times)))
  46.   (setq ll (permutate-exclude-reverses l))
  47.   (setq dmin 1e+308)
  48.   (foreach x ll
  49.     (setq x (mapcar '(lambda ( a ) (nth a pl)) x))
  50.     (setq d (apply '+ (mapcar '(lambda ( a b ) (distance a b)) x (append (cdr x) (list (car 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 "_C")
  60.   (prompt "\nDistance : ") (princ (rtos dmin 2 50))
  61.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds.")
  62.   (princ)
  63. )
  64.  

Up to 7 points, the worst one :

Code - Auto/Visual Lisp: [Select]
  1. (defun c:TSP-bruteforce-3dpoints ( / unique exclude-reverses permutate 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.   (defun exclude-reverses ( l )
  8.     (while (vl-some '(lambda ( x ) (if (vl-position (reverse x) l) (setq l (vl-remove x l)))) l))
  9.     l
  10.   )
  11.  
  12.   ;;;--------------------------------------------------------------------------
  13.   ;;; Permutate a single list.
  14.   ;;; Recursive solution by Reini Urban
  15.   ;;; (permutate '(0 1 2)) => ((0 1 2) (0 2 1) (1 2 0) (1 0 2) (2 0 1) (2 1 0))
  16.   ;;;--------------------------------------------------------------------------
  17.   (defun permutate ( l / x1 )
  18.     (cond
  19.       ( (null l) l )
  20.       ( (= (length l) 2) (list l (reverse l)) )
  21.       ( t
  22.         (repeat (length l)
  23.           (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))
  24.             (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))
  25.           )
  26.           (setq l (append (cdr l) (list (car l)))) ;; l = '(0 1 2) - loop1; l = '(1 2 0) - loop2; l = '(2 0 1) - loop3
  27.         )
  28.         (reverse x1)
  29.       )
  30.     )
  31.   )
  32.  
  33.   (setq ss (ssget '((0 . "POINT"))))
  34.   (repeat (setq i (sslength ss))
  35.     (setq pl (cons (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) pl))
  36.   )
  37.   (setq pl (unique pl))
  38.   (setq n (length pl))
  39.   (setq k n)
  40.   (repeat n
  41.     (setq l (cons (setq k (1- k)) l))
  42.   )
  43.   (setq ti (car (_vl-times)))
  44.   (setq ll (exclude-reverses (permutate l)))
  45.   (setq dmin 1e+308)
  46.   (foreach x ll
  47.     (setq x (mapcar '(lambda ( a ) (nth a pl)) x))
  48.     (setq d (apply '+ (mapcar '(lambda ( a b ) (distance a b)) x (append (cdr x) (list (car x))))))
  49.     (if (> dmin d)
  50.       (setq dmin d rtn x)
  51.     )
  52.   )
  53.   (vl-cmdf "_.3DPOLY")
  54.   (foreach p rtn
  55.     (vl-cmdf "_non" (trans p 0 1))
  56.   )
  57.   (vl-cmdf "_C")
  58.   (prompt "\nDistance : ") (princ (rtos dmin 2 50))
  59.   (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds.")
  60.   (princ)
  61. )
  62.  

Regards, M.R.
Maybe someone will find it useful after all...
« Last Edit: October 24, 2018, 10:40:32 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2122
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #93 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: 2122
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #94 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: 2122
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #95 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: 2122
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #96 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: 2122
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #97 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: 6934
  • AKA Daniel
Re: (Challenge) To draw the shortest lwpolyline
« Reply #98 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: 2122
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #99 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: 6934
  • AKA Daniel
Re: (Challenge) To draw the shortest lwpolyline
« Reply #100 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: 6934
  • AKA Daniel
Re: (Challenge) To draw the shortest lwpolyline
« Reply #101 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: 6934
  • AKA Daniel
Re: (Challenge) To draw the shortest lwpolyline
« Reply #102 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: 2122
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #103 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: 2122
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #104 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