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

0 Members and 1 Guest are viewing this topic.

VovKa

  • Water Moccasin
  • Posts: 1626
  • Ukraine
Re: (Challenge) To draw the shortest lwpolyline
« Reply #75 on: September 30, 2009, 12:30:26 PM »
my program searches for results close to best. It not necessarily best result!
your last code works much better
and of course there are still lists that can not be "perfectly" traced
anyway it's an excellent job, Evgeniy!

ElpanovEvgeniy

  • Water Moccasin
  • Posts: 1569
  • Moscow (Russia)
Re: (Challenge) To draw the shortest lwpolyline
« Reply #76 on: September 30, 2009, 12:37:39 PM »
Let's return to a brute force method

It is necessary for each point, to make the list of 3-5 nearest points,
To apply a brute force method, only to these steams.
It is possible to reduce time very much...

ps. It is necessary to pay attention, on five points, being away from other cloud points. :)

Lee Mac

  • Seagull
  • Posts: 12905
  • London, England
Re: (Challenge) To draw the shortest lwpolyline
« Reply #77 on: September 30, 2009, 12:50:03 PM »
So you mean something like, take a point, and the next nearest four points.

Rearrange these four points through all combinations (4!), and find the shortest path.

Repeat the process for all the points.

Is this what you had in mind?

VovKa

  • Water Moccasin
  • Posts: 1626
  • Ukraine
Re: (Challenge) To draw the shortest lwpolyline
« Reply #78 on: September 30, 2009, 12:55:31 PM »
Evgeniy, as you have seen, my code has absolutely no AI: generate a list of all possible routes, then find the shortest one.
yes, i thought of bruteforcing separate "clouds" and then bruteforce "cloud of clouds" and so on, but that demands lots of thinking and i am not into it :)
« Last Edit: September 30, 2009, 01:03:41 PM by VovKa »

chlh_jd

  • Guest
Re: (Challenge) To draw the shortest lwpolyline
« Reply #79 on: August 09, 2012, 12:06:59 PM »
Hi All , Good topic of discussion .
ElpanovEvgeniy's method is so cool ,Now I rewrite base on his , it seems getting better result and run faster .
Kinds of advice . :-)
Code: [Select]
;;;------------------------TSP------------------------------------------------------------;;;
;;;---------------------------------------------------------------------------------------;;;
(defun c:test (/ foo f2 ptl lst l n i d0 l0 l1 d1)
  ;;by GSLS(SS)
  ;;refer ElpanovEvgeniy's method from  http://www.theswamp.org/index.php?topic=30434.75
  ;;2012-8-10
  (defun foo (l / D D0 D1)
    (setq l0 (mapcar (function list) (cons (last l) l) l)) ;_  setq
 ;_  defun
    (setq d0 (get-closedpolygon-length l))
    (while
      (> d0
(progn
   (foreach a l0
     (setq d (get-closedpolygon-length l))
     (setq l1 (vl-remove (car a) (vl-remove (cadr a) l)))
     (setq l1 (f1 (car a) l1))
     (setq l1 (f1 (cadr a) l1))
     (if (> d
    (setq d1 (get-closedpolygon-length l1))
)
       (setq d d1
     l l1
       ) ;_  setq
     ) ;_  if
     (setq l1 (vl-remove (car a) (vl-remove (cadr a) l)))
     (setq l1 (f1 (cadr a) l1))
     (setq l1 (f1 (car a) l1))
     (if (> d
    (setq d1 (get-closedpolygon-length l1))
)
       (setq d d1
     l l1
       )
     )
   )
   d
) ;_  progn
      ) ;_  <
       (setq d0 d)
    ) ;_  while   
    (setq d (get-closedpolygon-length l))   
    l
  )
  (defun f1 (a l)
    (ins-lst a (get-closest-i l a) l)
  )
  (defun f2 (lst)
    (mapcar (function (lambda (p0 p p1 / a)
(setq a (- (angle p p0) (angle p p1)))
(if (< a (- pi))
  (abs (+ a pi pi))
  (if (> a pi)
    (abs (- a pi pi))
    (abs a)
  )
)
      )
    )
    (cons (last lst) lst)
    lst
    (reverse (cons (car lst) (reverse (cdr lst))))
    )
  )
  (setq ptl (my-getpt)
ptl (mapcar (function (lambda (p) (list (car p) (cadr p)))) ptl)
  )
  (setq t1 (getvar "MilliSecs"))
  (setq lst (Graham-scan ptl))
  (foreach a lst
    (setq ptl (vl-remove a ptl))
  )
  (while (and (> (length ptl) 2) (setq l (Graham-scan ptl)))
    (foreach p l
      (setq ptl (vl-remove p ptl))
      (setq n (get-minadddist-i lst p))
      (setq lst (ins-lst p n lst))
    )
  )
  (if ptl
    (foreach p ptl
      (setq n (get-minadddist-i lst p))
      (setq lst (ins-lst p n lst))
    )
  )
  (setq lst (foo lst))
  (setq l (f2 lst))
  (setq i  0
l0 lst
n  (length lst)
d0 (get-closedpolygon-length lst)
  )
  (foreach a l
    (if (and (< a _pi3) (= (setq p (nth i lst)) (nth i l0)))
      (progn
(if (= i 0)
  (setq p0 (last lst))
  (setq p0 (nth (1- i) lst))
)
(if (= i (1- n))
  (setq p1 (car lst))
  (setq p1 (nth (1+ i) lst))
)
(setq m (list (list p0 p1 p)
      (list p1 p p0)
      (list p1 p0 p)
      (list p p0 p1)
      (list p p1 p0)
)
)
(setq l1
       (car (vl-sort (mapcar (function (lambda (x)
(ch-para-lst x i lst)
       )
     )
     m
     )
     (function (lambda (e1 e2)
(< (get-closedpolygon-length e1)
    (get-closedpolygon-length e2)
)
       )
     )
    )
       )
)
(setq d1 (get-closedpolygon-length l1))
(if (< d1 d0)
  (setq d0  d1
lst l1
  )
)
      )
    )
    (setq i (1+ i))
  )
  (setq l (f2 lst))
  (setq i  0
l0 lst
d0 (get-closedpolygon-length lst)
  )
  (foreach a l
    (if (and (< a _pi2) (setq p (nth i l0)))
      (progn
(setq l1 (f1 p (vl-remove p lst)))
(setq d1 (get-closedpolygon-length l1))
(if (< d1 d0)
  (setq d0  d1
lst l1
  )
)
      )
    )
    (setq i (1+ i))
  )
  (entmake
    (append (list '(0 . "LWPOLYLINE")
  '(100 . "AcDbEntity")
  '(8 . "temp")
  '(62 . 1)
  '(100 . "AcDbPolyline")
  (cons 90 (length lst))
  '(70 . 1)
    )
    (mapcar (function (lambda (p) (cons 10 p))) lst)
    )
  )
  (setq t2 (getvar "MilliSecs"))
  (princ (strcat "\nTSP Length :" (rtos d0 2 0) "."))
  (princ (strcat "\nUse Time :" (rtos (- t2 t1) 2 0) "ms."))
  (princ)
)
;;;Use Funtions
;;;--------------------------------------------------------------
;; Convex hull of pts , Graham scan method
;; by Highflybird
  (defun Graham-scan (ptl / hPs rPs PsY Pt0 sPs P Q)
    (if (< (length ptl) 4) ;3点以下
      ptl ;是本集合
      (progn
(setq rPs (mapcar (function (lambda (x)
      (if (= (length x) 3)
(cdr x) x)))
  (mapcar 'reverse ptl));_点表的X和Y交换
      PsY (mapcar 'cadr ptl) ;_点表的Y值的表
      Pt0 (reverse (assoc (apply 'min PsY) rPs)) ;_最下面的点       
      sPs (sort-ad ptl Pt0) ;_按角度距离排序点集
      hPs (list (caddr sPs) (cadr sPs) Pt0) ;_开始的三点
)
(foreach n (cdddr sPs) ;从第4点开始
  (setq hPs (cons n hPs) ;把Pi加入到凸集
P   (cadr hPs) ;Pi-1
Q   (caddr hPs) ;Pi-2
  )
  (while (and q (> (det n P Q) -1e-6)) ;如果左转
    (setq hPs (cons n (cddr hPs)) ;删除Pi-1点
  P   (cadr hPs) ;得到新的Pi-1点
  Q   (caddr hPs) ;得到新的Pi-2点
    )))
hPs ;返回凸集
      ))
  )
;;;以最下面的点为基点,按照角度和距离分类点集
(defun sort-ad (pl pt)
  (vl-sort pl
   (function (lambda (e1 e2 / an1 an2)
       (setq an1 (angle pt e1)
     an2 (angle pt e2))
       (if (equal an1 an2 1e-6);_这里降低误差,以适应工程需求
(< (distance pt e1) (distance pt e2))
(< an1 an2)
       ))))
)
;;定义三点的行列式,即三点之倍面积
(defun det (p1 p2 p3)
  (- (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1)))
     (* (- (car p3) (car p1)) (- (cadr p2) (cadr p1)))
  ))
;;;
;;;------------------------
(defun my-getpt (/ ss i en l)
  (setq ss (ssget '((0 . "point"))))
  (setq i -1)
  (while (setq en (ssname ss (setq i (1+ i))))
    (setq l (cons (cdr (assoc 10 (entget en))) l))
  )
)
;;;------------------------
;;;
;;(ins-lst 10 5 '(1 2 3 4 5))
;; i 为新插入元素的位置
(defun ins-lst (new i lst / len fst)
  (cond
    ((minusp i)
     lst
    )
    ((> i (setq len (length lst)))
     lst
    )
    ((> i (/ len 2))
     (reverse (ins-lst new (- len i) (reverse lst)))
    )
    (t
     (append
       (progn
(setq fst nil)
(repeat (rem i 4)
   (setq fst (cons (car lst) fst)
lst (cdr lst)
   )
)
(repeat (/ i 4)
   (setq fst (cons (cadddr lst)
   (cons (caddr lst)
(cons
   (cadr lst)
   (cons
     (car lst)
     fst
   )
)
   )
     )
lst (cddddr lst)
   )
)
(reverse fst)
       )
       (list new)
       lst
     )
    )
  )
)
;;;------------------------
;;
;;(ch-para-lst '(7 8 9) 3 '(1 2 3 4 5))
(defun ch-para-lst (para i lst / len fst)
  (setq len (length lst))
  (cond
    ((minusp i)
     lst
    )
    ((> i (1- len))
     lst
    )
    ((= i 0)
     (cons (cadr para)
   (cons (caddr para)
(reverse (cons (car para) (cdr (reverse (cddr lst)))))
   )
     )
    )
    ((= i (1- len))
     (reverse
       (append (cdr (reverse para))
       (cddr (reverse (cons (last para) (cdr lst))))
       )
     )
    )
    ((> i (/ len 2))
     (reverse
       (ch-para-lst (reverse para) (- len i 1) (reverse lst))
     )
    )
    (t
     (append
       (progn
(setq fst nil)
(repeat (rem i 4)
   (setq fst (cons (car lst) fst)
lst (cdr lst)
   )
)
(repeat (/ i 4)
   (setq fst (cons (cadddr lst)
   (cons (caddr lst)
(cons
   (cadr lst)
   (cons
     (car lst)
     fst
   )
)
   )
     )
lst (cddddr lst)
   )
)
(reverse
   (cons (caddr para)
(cons (cadr para) (cons (car para) (cdr fst)))
   )
)
       )
       (cdr lst)
     )
    )
  )
)
;;;------------------------
;;
(defun get-minadddist-i (lst p)
  (car
    (vl-sort-i
      (mapcar (function (lambda (p1 p2)
  (- (+ (distance p p1) (distance p p2))
     (distance p1 p2)
  )
)
      )
      (cons (last lst) lst)
      lst
      )
      '<
    )
  )
)
;;;------------------------
(defun get-closest-i (lst p)
  (car
    (vl-sort-i
      (mapcar
(function
  (lambda (p1 p2 / pt d d1 d2)
    (setq pt (inters p
     (polar p (+ (/ pi 2.) (angle p1 p2)) 1.)
     p1
     p2
     nil
     )
  d  (distance p1 p2)
  d1 (distance p p1)
  d2 (distance p p2)
    )
    (if pt
      (if (equal (+ (distance pt p1) (distance pt p2)) d 1e-8)
(distance p pt)
d2
      )
      1e99
    )
  )
)
(cons (last lst) lst)
lst
      )
      '<
    )
  )
)
;;;------------------------
;;
(defun get-closedpolygon-length (l)
  (apply (function +)
(mapcar (function (lambda (p1 p2)
     (distance p1 p2)
   )
)
(cons (last l) l)
l
)
  )
)
« Last Edit: August 09, 2012, 12:22:38 PM by chlh_jd »

chlh_jd

  • Guest
Re: (Challenge) To draw the shortest lwpolyline
« Reply #80 on: August 09, 2012, 12:40:20 PM »
The codes in up pop use 4 steps complete the Shortest Path Algorithm :
1. Cal Initial feasible path
 1.1 Use Graham Scan algorithm cal  the outermost convex Hull ,
 1.2  Then cal  the remaining internal points convex hull ,
 1.3  Force the collapse of the internal convex hull point , the point join postion is whers increase min distance .
 1.4  repeat 1.2 1.3 until the remaining points less than 3 .
 1.5  Use 1.3 method join remains .
2. Use ElpanovEvgeniy's method Optimize the polyline .
3. Optimize the location of the points which acute angle formed between two adjacent points , this use changing 3p postion .
4. ReOptimize the location of the points which acute angle formed between two adjacent points ,  This use 'getclosestpointto' method .
and so

ElpanovEvgeniy

  • Water Moccasin
  • Posts: 1569
  • Moscow (Russia)
Re: (Challenge) To draw the shortest lwpolyline
« Reply #81 on: August 09, 2012, 12:57:05 PM »
Hi All , Good topic of discussion .
ElpanovEvgeniy's method is so cool ,Now I rewrite base on his , it seems getting better result and run faster .
Kinds of advice . :-)

vertex the top without a point here?

chlh_jd

  • Guest
Re: (Challenge) To draw the shortest lwpolyline
« Reply #82 on: August 10, 2012, 01:14:11 AM »
Hi All , Good topic of discussion .
ElpanovEvgeniy's method is so cool ,Now I rewrite base on his , it seems getting better result and run faster .
Kinds of advice . :-)

vertex the top without a point here?
Sorry to ElpanovEvgeniy for taking the wrong result , See following and upload doct .

ElpanovEvgeniy

  • Water Moccasin
  • Posts: 1569
  • Moscow (Russia)
Re: (Challenge) To draw the shortest lwpolyline
« Reply #83 on: August 10, 2012, 02:14:32 AM »
I am proud that my humble contribution, helping you to reach even greater heights!  :-)

ElpanovEvgeniy

  • Water Moccasin
  • Posts: 1569
  • Moscow (Russia)
Re: (Challenge) To draw the shortest lwpolyline
« Reply #84 on: August 10, 2012, 02:21:43 AM »
The gist of my code - show the applicability of the genetic algorithm.
The code shown here is just a demonstration for the forum. For a real project, I used about a dozen different subroutine optimization. Calling the subroutine was also intellectually ie not a simple iteration...

ps. In fact, writing such programs is difficult - if you are doing to improve, will inevitably begin to optimize for a particular point cloud...

Congratulations on your excellent results!  :-)

chlh_jd

  • Guest
Re: (Challenge) To draw the shortest lwpolyline
« Reply #85 on: August 10, 2012, 06:30:49 AM »
I am proud that my humble contribution, helping you to reach even greater heights!  :-)
First ,I always must thank you a lot . So kindness without saying thanks . :-)
Second , I really envy your proficiency on LISP and algorithms . :lol:
The gist of my code - show the applicability of the genetic algorithm.
The code shown here is just a demonstration for the forum. For a real project, I used about a dozen different subroutine optimization. Calling the subroutine was also intellectually ie not a simple iteration...

ps. In fact, writing such programs is difficult - if you are doing to improve, will inevitably begin to optimize for a particular point cloud...

Congratulations on your excellent results!  :-)
'Serious' support  !

ElpanovEvgeniy

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

Try your code on regular lattices...


lst-a.lsp

chlh_jd

  • Guest
Re: (Challenge) To draw the shortest lwpolyline
« Reply #87 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

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #88 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

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: (Challenge) To draw the shortest lwpolyline
« Reply #89 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