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

0 Members and 1 Guest are viewing this topic.

#### VovKa

• Swamp Rat
• Posts: 1210
• Ukraine
##### Re: (Challenge) To draw the shortest lwpolyline
« Reply #75 on: September 30, 2009, 11:19:41 AM »
Evgeniy, i have a list for you
Code: [Select]
`'((34.0417 53.3357) (78.9539 28.539) (45.5878 3.32332) (92.1425 23.3752) (60.589 27.9296) (34.469 8.53055) (97.5564 8.39047) (8.10511 51.1888))`and i insist that minimum length is 225.88

#### ElpanovEvgeniy

• Water Moccasin
• Posts: 1542
• Moscow (Russia)
##### Re: (Challenge) To draw the shortest lwpolyline
« Reply #76 on: September 30, 2009, 11:31:04 AM »
Evgeniy, i have a list for you
Code: [Select]
`'((34.0417 53.3357) (78.9539 28.539) (45.5878 3.32332) (92.1425 23.3752) (60.589 27.9296) (34.469 8.53055) (97.5564 8.39047) (8.10511 51.1888))`and i insist that minimum length is 225.88

For this case, it is enough to execute two times last code of shifts
Generally, the genetic algorithm should work until it is possible to improve result.

#### ElpanovEvgeniy

• Water Moccasin
• Posts: 1542
• Moscow (Russia)
##### Re: (Challenge) To draw the shortest lwpolyline
« Reply #77 on: September 30, 2009, 11:45:17 AM »
Now really genetic algorithm for search of best of possible results in the program
Code: [Select]
`(defun test (l / D D0 D1 E ENT EP LL LS P) (setq ll  (list (apply (function mapcar) (cons (function min) l))                 (apply (function mapcar) (cons (function max) l))           ) ;_  append       ll  (list (car ll) (list (caadr ll) (cadar ll)) (cadr ll) (list (caar ll) (cadadr ll)))       ent (entmakex (append (list '(0 . "LWPOLYLINE")                                   '(100 . "AcDbEntity")                                   '(8 . "temp")                                   '(62 . 1)                                   '(100 . "AcDbPolyline")                                   (cons 90 (length l))                                   '(70 . 1)                             ) ;_  list                             (mapcar (function (lambda (a) (cons 10 a))) ll)                     ) ;_  append           ) ;_  entmakex       l   (mapcar            (function cddr)            (vl-sort             (mapcar (Function (lambda (a / b)                                (cons (distance a (setq b (vlax-curve-getClosestPointTo ent a)))                                      (cons (vlax-curve-getParamAtPoint ent b) a)                                ) ;_  cons                               ) ;_  lambda                     ) ;_  Function                     l             ) ;_  mapcar             (function (lambda (a b)                        (if (equal (car a) (car b) 1)                         (<= (cadr a) (cadr b))                         (< (car a) (car b))                        ) ;_  if                       ) ;_  lambda             ) ;_  function            ) ;_  vl-sort           ) ;_  mapcar       ls  l ) ;_  setq (foreach a ll (setq ls (vl-remove a ls))) (foreach a ls  (setq p (vlax-curve-getParamAtPoint ent (vlax-curve-getClosestPointTo ent a))        p (if (zerop (rem p 1.))           (if (zerop p)            (vlax-curve-getEndParam ent)            (1- p)           ) ;_  if           (fix p)          ) ;_  if        p (vlax-curve-getPointAtParam ent p)        p (list 10 (car p) (cadr p))  ) ;_  setq  (entmod (append (reverse (member p (reverse (entget ent))))                  (list (cons 10 a))                  (cdr (member p (entget ent)))          ) ;_  append  ) ;_  entmod ) ;_  foreach (foreach a l (setq ll (vl-remove a ll))) (entmod (vl-remove-if (function (lambda (a) (member (cdr a) ll))) (entget ent))) (setq l  (mapcar (function cdr)                  (vl-remove-if-not (function (lambda (a) (= (car a) 10))) (entget ent))          ) ;_  mapcar       l  (mapcar (function list) (cons (last l) l) l)       ep (length l) ) ;_  setq (defun f1 (a ent / p)  (setq p (vlax-curve-getPointAtParam           ent           (fix (vlax-curve-getParamAtPoint ent (vlax-curve-getClosestPointTo ent a)))          ) ;_  vlax-curve-getPointAtParam        p (list 10 (car p) (cadr p))  ) ;_  setq ;_  setq  (entmod (append (reverse (member p (reverse (entget ent))))                  (list (cons 10 a))                  (cdr (member p (entget ent)))          ) ;_  append  ) ;_  entmod ) ;_  defun (setq d0 (vlax-curve-getDistAtParam ent ep)) (while  (> d0     (progn      (foreach a l       (setq e (entget ent)             d (vlax-curve-getDistAtParam ent ep)       ) ;_  setq       (entmod (vl-remove (cons 10 (car a)) (vl-remove (cons 10 (cadr a)) e)))       (f1 (car a) ent)       (f1 (cadr a) ent)       (if (<= d (setq d1 (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent))))        (entmod e)        (setq d d1              e (entget ent)        ) ;_  setq       ) ;_  if       (entmod (vl-remove (cons 10 (car a)) (vl-remove (cons 10 (cadr a)) e)))       (f1 (cadr a) ent)       (f1 (car a) ent)       (if (<= d (setq d1 (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent))))        (entmod e)        (setq d d1              e (entget ent)        ) ;_  setq       ) ;_  if      ) ;_  foreach      d     ) ;_  progn  ) ;_  <  (setq d0 d) ) ;_  while (princ (strcat "\nPolyline Length: " (rtos d 2 4) " mm.")) (princ))`

#### ElpanovEvgeniy

• Water Moccasin
• Posts: 1542
• Moscow (Russia)
##### Re: (Challenge) To draw the shortest lwpolyline
« Reply #78 on: September 30, 2009, 11:48:28 AM »
I repeat, my program searches for results close to best. It not necessarily best result!

#### VovKa

• Swamp Rat
• Posts: 1210
• Ukraine
##### Re: (Challenge) To draw the shortest lwpolyline
« Reply #79 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: 1542
• Moscow (Russia)
##### Re: (Challenge) To draw the shortest lwpolyline
« Reply #80 on: September 30, 2009, 12:37:39 PM »

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: 12356
• London, England
##### Re: (Challenge) To draw the shortest lwpolyline
« Reply #81 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

• Swamp Rat
• Posts: 1210
• Ukraine
##### Re: (Challenge) To draw the shortest lwpolyline
« Reply #82 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 #83 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 .
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 #84 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: 1542
• Moscow (Russia)
##### Re: (Challenge) To draw the shortest lwpolyline
« Reply #85 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 .

vertex the top without a point here?

#### chlh_jd

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

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

#### ElpanovEvgeniy

• Water Moccasin
• Posts: 1542
• Moscow (Russia)
##### Re: (Challenge) To draw the shortest lwpolyline
« Reply #87 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: 1542
• Moscow (Russia)
##### Re: (Challenge) To draw the shortest lwpolyline
« Reply #88 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...

#### chlh_jd

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