seems that Evgeniy is trying to spoil other people's friday night :)
(defun make-lwpolyline(l / e)
;;(make-lwpolyline lst)
(setq e (entmakex (append (list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(67 . 0)
'(410 . "Model")
'(8 . "Kant")
'(62 . 3)
'(100 . "AcDbPolyline")
(cons 90 (length l))
'(70 . 1)
) ;_ list
(mapcar (function (lambda (a) (cons 10 a))) l)
) ;_ append
) ;_ entmakex
) ;_ setq
(Princ (strcat "\n length lwpolyline "
(rtos (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)) 2 4)
" mm."
) ;_ strcat
) ;_ Princ
(Princ)
) ;_ defun
(defun rjp-sortpt2pt (pt lst / tmp newlst)
(defun dsort (pt lst / d1 d2)
(vl-sort lst (function (lambda (d1 d2) (< (distance pt d1) (distance pt d2)))))
)
(setq tmp (dsort pt lst))
(repeat (length lst)
(setq tmp (dsort (car tmp) tmp)
newlst (cons (car tmp) newlst)
tmp (vl-remove (car tmp) tmp)
)
)
(reverse newlst)
)
(make-lwpolyline (rjp-sortpt2pt (car lst-a) lst-a))
;;3908.169
(make-lwpolyline (rjp-sortpt2pt (car lst-b) lst-b))
;;3206.567
(defun mkPoly (lst / rslt tmp lst ply)
(setq rslt (list (car lst)))
(while (setq lst (cdr lst))
(setq tmp (car rslt))
(setq rslt
(cons
(car (vl-sort lst
(function
(lambda (a b)
(< (distance tmp a)
(distance tmp b)))))) rslt)))
(setq ply
(entmakex
(append (list (cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 (length rslt))
(cons 70 1))
(mapcar (function (lambda (x) (cons 10 x))) rslt))))
(princ (strcat "\nPolyline Length: " (rtos (vlax-curve-getDistatParam ply
(vlax-curve-getEndParam ply)) 2 4) " mm."))
(princ))
lst-a Polyline Length: 968.1675 mm.
lst-b Polyline Length: 1019.6264 mm.
Hello Ron.
I liked your code!
My code, much more long...
heres mine ... am I even close?
(defun mkPoly (lst / qsort rslt x)
(defun qsort (pt lst)
(vl-sort lst
(function (lambda (a b) (< (distance pt a) (distance pt b))))))
(setq rslt (list (car lst)))
(while (setq x (car (setq lst (qsort (car rslt) (cdr lst)))))
(setq rslt (cons x rslt)))
(make-lwpolyline rslt)
(princ))
i vote for the long code.
i think we have to bruteforce it. thus making factorial of (length lst) iterations.
Got the same result as Ron, but maybe with quicker code ^-^Code: [Select](defun mkPoly (lst / qsort rslt x)
(defun qsort (pt lst)
(vl-sort lst
(function (lambda (a b) (< (distance pt a) (distance pt b))))))
(setq rslt (list (car lst)))
(while (setq x (car (setq lst (qsort (car rslt) (cdr lst)))))
(setq rslt (cons x rslt)))
(make-lwpolyline rslt)
(princ))
Lee, this task is not as simple as it appears. Evgeniy is not up to thowing easy tasks :)
try your function on both list-b and (reverse lst-b)
(defun mkPoly (lst / qsort mPt rslt x)
(defun qsort (pt lst)
(vl-sort lst
(function (lambda (a b) (< (distance pt a) (distance pt b))))))
(setq lst (cons mPt (qsort (setq mPt (apply 'mapcar (cons 'min lst)))
(vl-remove mPt lst))))
(setq rslt (list mPt))
(while (setq x (car (setq lst (qsort (car rslt) (cdr lst)))))
(setq rslt (cons x rslt)))
(make-lwpolyline rslt)
(princ))
(defun mkPoly (lst / x sect lst nlst e nlen end)
(defun SubLst (lst i j / k)
(setq k -1)
(or j (setq j (length lst)))
(vl-remove-if-not
(function
(lambda (x)
(<= i (setq k (1+ k)) (+ i (1- j))))) lst))
(setq x -1)
(while (and (setq sect (SubLst lst (setq x (1+ x)) 4))
(= 4 (length sect)))
(setq nlst (append (if (zerop x) '( ) (SubLst lst 0 x))
(reverse sect)
(if (= (length lst) (+ x 4)) '( ) (SubLst lst (+ x 4) nil))))
(setq e (make-lwpolyline nlst))
(setq nLen (vlax-curve-getDistatParam e (vlax-curve-getEndParam e)))
(entdel e)
(if len
(if (< nlen len)
(setq len nlen lst nlst))
(setq len nlen)))
(setq e (make-lwpolyline lst))
(Princ (strcat "\n length lwpolyline "
(rtos (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)) 2 4)" mm."))
(princ))
(defun mkPoly (lst / on_line qsort lst mPt ePt lLst rLst rslt)
(defun on_line (pt p1 p2)
(or (equal (angle p1 pt) (angle p1 p2) 0.01)
(equal (angle p1 pt) (+ pi (angle p1 p2)) 0.01)))
(defun qsort (pt lst)
(vl-sort lst
(function (lambda (a b) (< (distance pt a) (distance pt b))))))
(setq lst (qsort (setq mPt (apply 'mapcar (cons 'min lst)))
(vl-remove mPt lst)))
(setq ePt
(car
(vl-sort
(vl-sort lst
(function
(lambda (a b)
(< (cadr a) (cadr b)))))
(function
(lambda (c d)
(> (car c) (car d)))))))
(mapcar
(function
(lambda (x)
(if (on_line x mPt ePt)
(setq lLst (cons x lLst))
(setq rlst (cons x rlst))))) lst)
(setq lLst (cons mPt (reverse lLst)) rLst (reverse rLst))
(setq rslt (list (car rlst)))
(while (setq x (car (setq rlst (qsort (car rslt) (cdr rlst)))))
(setq rslt (cons x rslt)))
(make-lwpolyline (append rslt llst))
(princ))
length lwpolyline 3850.0010 mm.
I'm enjoying this task very much :-)
Need one more column of points to make this efficient :-(
Excellent work Lee!
I have specially given odd quantity of points in rows and columns.
Otherwise, the decision will be trivial and discussion will be not about algorithm, and about speed or beauty.
Now, the guru and beginners are equal - the main thing algorithm, instead of knowledge lisp...
(defun mkPoly (lst / on_line qsort lst mPt MaPt ePt lLst rLst rslt bLst)
(defun on_line (pt p1 p2)
(or (equal (angle p1 pt) (angle p1 p2) 0.01)
(equal (angle p1 pt) (+ pi (angle p1 p2)) 0.01)))
(defun qsort (pt lst)
(vl-sort lst
(function (lambda (a b) (< (distance pt a) (distance pt b))))))
(setq lst (qsort (setq mPt (apply 'mapcar (cons 'min lst)))
(vl-remove mPt lst)))
(setq ePt
(car
(vl-sort
(vl-sort lst
(function (lambda (a b) (< (cadr a) (cadr b)))))
(function (lambda (c d) (> (car c) (car d)))))))
(setq MaPt (apply 'mapcar (cons 'max lst)))
(mapcar
(function
(lambda (x)
(cond ( (on_line x mPt ePt)
(setq lLst (cons x lLst)))
( (on_line x ePt MaPt)
(setq bLst (cons x bLst)))
(t (setq rlst (cons x rlst)))))) lst)
(setq lLst (cons mPt (reverse lLst))
bLst (vl-remove ePt (reverse bLst)) rLst (reverse rLst))
(setq rslt (list (car rlst)))
(while (setq x (car (setq rlst (qsort (car rslt) (cdr rlst)))))
(setq rslt (cons x rslt)))
(make-lwpolyline (append rslt llst bLst))
(princ))
length lwpolyline 3826.5970 mm.
(defun mkPoly (lst / av tLst bLst)
(setq av (mapcar
(function
(lambda (x)
(/ (float x) (length lst))))
(apply 'mapcar (cons '+ lst))))
(mapcar
(function
(lambda (x)
(cond ( (>= (cadr x) (cadr av))
(setq tLst (cons x tLst)))
(t (setq bLst (cons x bLst)))))) lst)
(setq tLst (vl-sort tLst (function (lambda (a b) (< (car a) (car b))))))
(setq bLst (vl-sort bLst (function (lambda (a b) (> (car a) (car b))))))
(make-lwpolyline (append tLst bLst)))
length lwpolyline 2897.1142 mm.
(setq lst '((2142.0 1310.52 0.0) (2096.3 1195.7 0.0) (2212.65 1191.2 0.0) (2097.43 1466.42 0.0) (2002.47 1474.35 0.0) (2123.32 1309.75 0.0)))
my bruteforce method gives the route of 821.9093 length
For reception of the best results, I have written two programs - the first for the first list, the second for the second...
VovKa - I am not writing generic functions :wink:aha, that clears the situation
As Elpanov says, he wrote one for each list...
i wonder how many lists does Evgeniy have :)
(defun mkPoly (lst / mklw vlax-list->2D-point SubLst
miP maP tmp lst nlst par ptlst obj)
(vl-load-com)
(defun mklw (l / e)
(entmakex (append (list (cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 (length l))
(cons 70 1))
(mapcar (function (lambda (a) (cons 10 a))) l))))
(defun vlax-list->2D-point (lst)
(if lst
(cons (list (car lst) (cadr lst))
(vlax-list->2D-point (cddr lst)))))
(defun SubLst (lst i j / k)
(setq k -1)
(or j (setq j (length lst)))
(vl-remove-if-not
(function
(lambda (x)
(<= i (setq k (1+ k)) (+ i (1- j))))) lst))
(setq miP (apply 'mapcar (cons 'min lst)))
(setq maP (apply 'mapcar (cons 'max lst)))
(setq obj (vlax-ename->vla-object
(mklw (list miP (list (car miP) (cadr maP)) maP (list (car maP) (cadr miP))))))
(setq lst (vl-sort lst
(function
(lambda (a b) (< (distance (vlax-curve-getClosestPointto obj a) a)
(distance (vlax-curve-getClosestPointto obj b) b))))))
(setq nlst lst)
(while (setq x (car nLst))
(setq nLst (cdr nLst) par (fix (vlax-curve-getParamatPoint obj
(vlax-curve-getClosestPointto obj x))))
(setq ptlst (vlax-list->2D-point (vlax-get obj 'Coordinates)))
(setq ptlst (append (SubLst ptlst 0 (1+ par)) (list x)
(SubLst ptlst (1+ par) nil)))
(vlax-put obj 'Coordinates (apply 'append ptlst)))
(vlax-put obj 'Coordinates (apply 'append
(vl-remove-if-not
(function (lambda (x) (vl-position x lst))) ptlst)))
(princ (strcat "\nPolyline Length: " (rtos (vla-get-Length obj) 2 2) " mm."))
(princ))
Polyline Length: 2760.18 mm.
I tried to emulate your method - only up to Step 4, so not quite as short as you:
(defun mkPoly (lst / mklw vlax-list->2D-point SubLst remove_nth
i x miP maP tmp lst nlst par ptlst obj)
(vl-load-com)
;;(foreach pt lst (command "_.point" "_non" pt))
(defun mklw (l / e)
(entmakex (append (list (cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 (length l))
(cons 70 1))
(mapcar (function (lambda (a) (cons 10 a))) l))))
(defun vlax-list->2D-point (lst)
(if lst
(cons (list (car lst) (cadr lst))
(vlax-list->2D-point (cddr lst)))))
(defun SubLst (lst i j / k)
(setq k -1)
(or j (setq j (length lst)))
(vl-remove-if-not
(function
(lambda (x)
(<= i (setq k (1+ k)) (+ i (1- j))))) lst))
(defun remove_nth (k lst / j)
(setq j -1)
(vl-remove-if
(function
(lambda (x)
(= k (setq j (1+ j))))) lst))
(setq miP (apply 'mapcar (cons 'min lst)))
(setq maP (apply 'mapcar (cons 'max lst)))
(setq obj (vlax-ename->vla-object
(mklw (list miP (list (car miP) (cadr maP)) maP (list (car maP) (cadr miP))))))
(setq lst (vl-sort lst
(function
(lambda (a b) (< (distance (vlax-curve-getClosestPointto obj a) a)
(distance (vlax-curve-getClosestPointto obj b) b))))))
(setq nlst lst)
(while (setq x (car nLst))
(setq nLst (cdr nLst) par (fix (vlax-curve-getParamatPoint obj
(vlax-curve-getClosestPointto obj x))))
(setq ptlst (vlax-list->2D-point (vlax-get obj 'Coordinates)))
(setq ptlst (append (SubLst ptlst 0 (1+ par)) (list x)
(SubLst ptlst (1+ par) nil)))
(vlax-put obj 'Coordinates (apply 'append ptlst)))
(vlax-put obj 'Coordinates (apply 'append
(setq ptlst
(vl-remove-if-not
(function (lambda (x) (vl-position x lst))) ptlst))))
(setq i -1)
(repeat (length ptlst)
(setq x (nth (setq i (1+ i)) ptlst))
(vlax-put obj 'Coordinates (apply 'append (Remove_nth i ptlst)))
(setq par (fix (vlax-curve-getParamatPoint obj
(vlax-curve-getClosestPointto obj x))))
(setq ptlst (vlax-list->2D-point (vlax-get obj 'Coordinates)))
(setq ptlst (append (SubLst ptlst 0 (1+ par)) (list x)
(SubLst ptlst (1+ par) nil)))
(vlax-put obj 'Coordinates (apply 'append ptlst)))
(vlax-put obj 'Coordinates (apply 'append ptlst))
(princ (strcat "\nPolyline Length: " (rtos (vla-get-Length obj) 2 2) " mm."))
(princ))
Polyline Length: 2535.09 mm.
I have updated my routine, but I'm still not as short as yours...
(http://www.theswamp.org/screens/leemac/example2.png)
(defun mkPoly (lst / mklw vlax-list->2D-point SubLst remove_nth
i x miP maP tmp lst nlst par ptlst obj nlst nlen)
(vl-load-com)
(defun mklw (l / e)
(entmakex (append (list (cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 (length l))
(cons 70 1))
(mapcar (function (lambda (a) (cons 10 a))) l))))
(defun vlax-list->2D-point (lst)
(if lst
(cons (list (car lst) (cadr lst))
(vlax-list->2D-point (cddr lst)))))
(defun SubLst (lst i j / k)
(setq k -1)
(or j (setq j (length lst)))
(vl-remove-if-not
(function
(lambda (x)
(<= i (setq k (1+ k)) (+ i (1- j))))) lst))
(defun remove_nth (k lst / j)
(setq j -1)
(vl-remove-if
(function
(lambda (x)
(= k (setq j (1+ j))))) lst))
(setq miP (apply 'mapcar (cons 'min lst)))
(setq maP (apply 'mapcar (cons 'max lst)))
(setq obj (vlax-ename->vla-object
(mklw (list miP (list (car miP) (cadr maP)) maP (list (car maP) (cadr miP))))))
(setq lst (vl-sort lst
(function
(lambda (a b) (< (distance (vlax-curve-getClosestPointto obj a) a)
(distance (vlax-curve-getClosestPointto obj b) b))))))
(setq nlst lst)
(while (setq x (car nLst))
(setq nLst (cdr nLst) par (fix (vlax-curve-getParamatPoint obj
(vlax-curve-getClosestPointto obj x))))
(setq ptlst (vlax-list->2D-point (vlax-get obj 'Coordinates)))
(setq ptlst (append (SubLst ptlst 0 (1+ par)) (list x)
(SubLst ptlst (1+ par) nil)))
(vlax-put obj 'Coordinates (apply 'append ptlst)))
(vlax-put obj 'Coordinates (apply 'append
(setq ptlst
(vl-remove-if-not
(function (lambda (x) (vl-position x lst))) ptlst))))
(setq i -1)
(repeat (length ptlst)
(setq x (nth (setq i (1+ i)) ptlst))
(vlax-put obj 'Coordinates (apply 'append (Remove_nth i ptlst)))
(setq par (fix (vlax-curve-getParamatPoint obj
(vlax-curve-getClosestPointto obj x))))
(setq ptlst (vlax-list->2D-point (vlax-get obj 'Coordinates)))
(setq ptlst (append (SubLst ptlst 0 (1+ par)) (list x)
(SubLst ptlst (1+ par) nil)))
(vlax-put obj 'Coordinates (apply 'append ptlst)))
(setq i -1)
(repeat (- (length ptlst) 1)
(setq x (nth (setq i (1+ i)) ptlst) y (nth (1+ i) ptlst))
(vlax-put obj 'Coordinates (apply 'append ptlst))
(setq len (vla-get-length obj))
(setq nlst (append (SubLst ptlst 0 i) (list y x)
(Sublst ptlst (+ i 2) nil)))
(vlax-put obj 'Coordinates (apply 'append nlst))
(if (< (setq nlen (vla-get-length obj)) len)
(setq ptlst nlst len nlen)))
(vlax-put obj 'Coordinates (apply 'append ptlst))
(princ (strcat "\nPolyline Length: " (rtos (vla-get-Length obj) 2 4) " mm."))
(princ))
Excellent result!
You very quickly understand an essence.
I shall dare to give one more advice.
Functions vlax-curve-* work much more quickly if it to transfer argument ename than object.
Especially strongly, it is appreciable on the contours having a plenty of segments.
Elapsed milliseconds / relative speed for 16384 iteration(s):
(vlax-curve-getEndParam ENT).....1233 / 1.43 <fastest>
(vlax-curve-getEndParam OBJ).....1763 / 1.00 <slowest>
Just had to test it :PCode: [Select]Elapsed milliseconds / relative speed for 16384 iteration(s):
(vlax-curve-getEndParam ENT).....1233 / 1.43 <fastest>
(vlax-curve-getEndParam OBJ).....1763 / 1.00 <slowest>
It is very a pity, I hoped, in a theme will be more participants...
Earlier, themes with the name " (Challenge) *** " were more often also than participants was more.
Prompt me, it was very complex task or it was not interesting?
Probably, I have had time to offend?
Whether themes " (Challenge) *** " with tasks for algorithms are necessary or programming with comparison of quantity of lines and is interesting only to time of performance?
Probably, I have had time to offend?
I think rather that this task is based more on the best Algorithm rather than the fastest programming solution, and hence knowledge of the language.
; error: Exception occurred: 0xC0000005 (Access Violation)
; warning: unwind skipped on unknown exception
Lee, your code crashes when supplied '((20.0 0.0) (80.0 0.0) (100.0 100.0) (0.0 100.0)) as an argumentQuote; error: Exception occurred: 0xC0000005 (Access Violation)
; warning: unwind skipped on unknown exception
Lee, it crashes almost all the time for me. I can't even test your code :(
Lee, it crashes almost all the time for me. I can't even test your code :(
Clean from a code recursion...
; error: Exception occurred: 0xC0000005 (Access Violation)
; warning: unwind skipped on unknown exception
(defun vlax-list->2D-point (lst)
(if lst
(cons (list (car lst) (cadr lst))
(vlax-list->2D-point (cddr lst)))))
(setq miP (apply 'mapcar (cons 'min lst)))
(setq maP (apply 'mapcar (cons 'max lst)))
Evgeniy, as Lee've already guessed it is (vlax-put 'Coordinates ...) that issues the error.
By the way, I am not assured, that my result the shortest!i think it's time to post your code, Evgeniy.
I think so too 8-)
Mine is messy with all the alterations I've made to it :oops:
i think it's time to post your code, Evgeniy.
i've tested Lee's a bit, and sometimes it's mistaken.
so, seeing your code is essential :)
Where your variant? :police:come on, i remember you saying that you're not interested in a bruteforce solution? :)
(defun vk_GetPerimeter (CoordsList)
(apply '+
(mapcar (function (lambda (p1 p2) (distance p1 p2)))
CoordsList
(cons (last CoordsList) CoordsList)
)
)
)
(defun vk_GetPermutations (lst)
(if (cdr lst)
(apply 'append
(mapcar (function (lambda (e1)
(mapcar (function (lambda (e2) (cons e1 e2)))
(vk_GetPermutations (vl-remove e1 lst))
)
)
)
lst
)
)
(list lst)
)
)
(defun mkPoly (lst / mlst mdst dst)
(setq lst (vk_GetPermutations lst)
mlst (car lst)
mdst (vk_GetPerimeter mlst)
)
(foreach chain (cdr lst)
(if (< (setq dst (vk_GetPerimeter chain)) mdst)
(setq mdst dst
mlst chain
)
)
)
mlst
)
as any bruteforce attack it is one hundred percent foolproof and one billion percent slow :)(test lst-b) =>> "Polyline Length: 2521.6043 mm."
(defun test (l / D 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
(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)))
(setq p (vlax-curve-getPointAtParam
ent
(fix (vlax-curve-getParamAtPoint ent (vlax-curve-getClosestPointTo ent (car a))))
) ;_ vlax-curve-getPointAtParam
p (list 10 (car p) (cadr p))
) ;_ setq ;_ setq
(entmod (append (reverse (member p (reverse (entget ent))))
(list (cons 10 (car a)))
(cdr (member p (entget ent)))
) ;_ append
) ;_ entmod
(setq p (vlax-curve-getPointAtParam
ent
(fix (vlax-curve-getParamAtPoint ent (vlax-curve-getClosestPointTo ent (cadr a))))
) ;_ vlax-curve-getPointAtParam
p (list 10 (car p) (cadr p))
) ;_ setq
(entmod (append (reverse (member p (reverse (entget ent))))
(list (cons 10 (cadr a)))
(cdr (member p (entget ent)))
) ;_ append
) ;_ entmod
(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)))
(setq p (vlax-curve-getPointAtParam
ent
(fix (vlax-curve-getParamAtPoint ent (vlax-curve-getClosestPointTo ent (cadr a))))
) ;_ vlax-curve-getPointAtParam
p (list 10 (car p) (cadr p))
) ;_ setq
(entmod (append (reverse (member p (reverse (entget ent))))
(list (cons 10 (cadr a)))
(cdr (member p (entget ent)))
) ;_ append
) ;_ entmod
(setq p (vlax-curve-getPointAtParam
ent
(fix (vlax-curve-getParamAtPoint ent (vlax-curve-getClosestPointTo ent (car a))))
) ;_ vlax-curve-getPointAtParam
p (list 10 (car p) (cadr p))
) ;_ setq
(entmod (append (reverse (member p (reverse (entget ent))))
(list (cons 10 (car a)))
(cdr (member p (entget ent)))
) ;_ append
) ;_ entmod
(if (<= d (setq d1 (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent))))
(entmod e)
(setq d d1
e (entget ent)
) ;_ setq
) ;_ if
) ;_ foreach
(princ (strcat "\nPolyline Length: " (rtos d 2 4) " mm."))
(princ)
)
Nice code - works well for lst-b, but you get a freaky result for lst-a :lol:
I haven't studied your code in depth yet Elpanov, but I shall look at how you changed the points - I think the entmod method is much more reliable than vlax-put...
(test lst-a) =>> "Polyline Length: 3709.0142 mm."
(defun test (l / A B D E LL P PL)
(setq p (car l)
pl (list p)
l (cdr l)
) ;_ setq
(while l
(setq b (car l)
d (distance p (car l))
) ;_ setq
(foreach a l
(if (<= (setq e (distance p a)) d)
(setq b a
d e
) ;_ setq
) ;_ if
) ;_ foreach
(setq pl (cons b pl)
l (vl-remove b l)
p b
b (car l)
) ;_ setq
) ;_ while
(setq e nil
l pl
ll l
) ;_ setq
(while (and (not e) ll)
(setq e t
ll l
) ;_ setq
(while (and e ll)
(setq ll (if (listp (caar ll))
ll
(mapcar (function list) (cons (last ll) ll) ll)
) ;_ if
a (car ll)
pl (vl-remove-if (function (lambda (b) (or (member (car a) b) (member (cadr a) b))))
(cdr ll)
) ;_ vl-remove-if
ll (cdr ll)
) ;_ setq
(while (and pl (setq b (car pl)) (not (inters (car a) (cadr a) (car b) (cadr b))))
(setq pl (cdr pl))
) ;_ while
(if pl
(progn (setq l (append (member (car a) l) (reverse (cdr (member (car a) (reverse l)))))
l (append (list (car a)) (member (car b) (reverse (cdr l))) (member (cadr b) l))
e nil
) ;_ setq
) ;_ progn
) ;_ if
) ;_ while
) ;_ while
(setq e (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))) l)
) ;_ append
) ;_ entmakex
) ;_ setq
(princ (strcat "\nPolyline Length: "
(rtos (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)) 2 4)
" mm."
) ;_ strcat
) ;_ princ
(princ)
)
'((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
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
and i insist that minimum length is 225.88
27.9296) (34.469 8.53055) (97.5564 8.39047) (8.10511 51.1888))
(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)
)
my program searches for results close to best. It not necessarily best result!your last code works much better
;;;------------------------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
)
)
)
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 . :-)
Sorry to ElpanovEvgeniy for taking the wrong result , See following and upload doct .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?
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 . :-)
The gist of my code - show the applicability of the genetic algorithm.'Serious' support !
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 !
I think you misunderstood " 'Serious' support ! " , What I mean is very supportive of your views :-D'Serious' support !
Try your code on regular lattices...
(http://www.theswamp.org/index.php?action=dlattach;topic=30434.0;attach=13699;image)
lst-a.lsp (http://www.theswamp.org/index.php?action=dlattach;topic=30434.0;attach=13685)
Now really genetic algorithm for search of best of possible results in the program
; error: Exception occurred: 0xC0000005 (Access Violation)
; warning: unwind skipped on exception
; error: Exception occurred: 0xC0000005 (Access Violation)
(vl-some '(lambda ( x ) (vl-position (reverse x) ll)) ll)
Daniel, chlh_jd's code is more accurateDoh! crushed
real TSP is considered as 3D problem too with 3D points in 3D space...your right, that adds a whole new dimension!
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...
I need about 10 hours of running... But I'll be back with info as soon as it finishes...
LOL!...
(defun test-lst-a (l / A B BB D E LL P PL AN)
(setq l (vl-sort l (function (lambda (a b) (if (= (car a) (car b)) (< (cadr a) (cadr b)) (< (car a) (car b))))))) ;_ setq
(setq p (car l)
pl (list p)
l (cdr l)
) ;_ setq
(while l
(setq d (distance p (car l))) ;_ setq
(foreach a l
(if (<= (setq e (distance p a)) d)
(if (and an (or (equal (angle p a) an 1e-6) (equal (angle p a) (rem (+ pi an) (+ pi pi)) 1e-6) (if (or (equal an 0.0 1e-6) (equal an (* 2 pi) 1e-6)) (equal (angle p a) (* 2 pi) 1e-6))))
(setq bb a
d e
) ;_ setq
(setq b a
d e
) ;_ setq
) ;_ if
) ;_ if
) ;_ foreach
(cond
((and bb b (<= (distance p bb) (distance p b)))
(setq b bb) ;_ setq
)
((and bb b)
(setq bb b) ;_ setq
)
(bb
(setq b bb) ;_ setq
)
) ;_ cond
(setq pl (cons b pl)
an (angle p b)
l (vl-remove b l)
p b
b nil
bb nil
) ;_ setq
) ;_ while
(setq pl (reverse pl)) ;_ setq
(setq e nil
l pl
ll l
) ;_ setq
(while (and (not e) ll)
(setq e t
ll l
) ;_ setq
(while (and e ll)
(setq ll (if (listp (caar ll))
ll
(mapcar (function list) (cons (last ll) ll) ll)
) ;_ if
a (car ll)
pl (vl-remove-if (function (lambda (b) (or (member (car a) b) (member (cadr a) b))))
(cdr ll)
) ;_ vl-remove-if
ll (cdr ll)
) ;_ setq
(while (and pl (setq b (car pl)) (not (inters (car a) (cadr a) (car b) (cadr b))))
(setq pl (cdr pl))
) ;_ while
(if pl
(progn (setq l (append (member (car a) l) (reverse (cdr (member (car a) (reverse l)))))
l (append (list (car a)) (member (car b) (reverse (cdr l))) (member (cadr b) l)) ;;; (car a) (cadr a) + ... + (car b) (cadr b) + ... ->end ;;; => ;;; (car a) + (reversed (car b)->(cadr a)) + (not reversed (cadr b)->end)
e nil
) ;_ setq
) ;_ progn
) ;_ if
) ;_ while
) ;_ while
(setq e (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))) l)
) ;_ append
) ;_ entmakex
) ;_ setq
(princ (strcat "\nPolyline Length: "
(rtos (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)) 2 4)
" mm."
) ;_ strcat
) ;_ princ
(princ)
)
(test-lst-a (mapcar '(lambda ( x ) (cdr (assoc 10 (entget x)))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "POINT"))))))))
(defun test-lst-a (l / A B BB D E LL P PL AN W H)
(setq l (vl-sort l (function (lambda (a b) (if (= (car a) (car b)) (< (cadr a) (cadr b)) (< (car a) (car b))))))) ;_ setq
(setq w (- (car (last l)) (car (car l))) h (- (cadr (last l)) (cadr (car l)))) ;_ setq
(if (< w h)
(setq an (* 0.5 pi)) ;_ setq
(setq an 0.0) ;_ setq
) ;_ if
(setq p (car l)
pl (list p)
l (cdr l)
) ;_ setq
(while l
(setq d (distance p (car l))) ;_ setq
(foreach a l
(if (<= (setq e (distance p a)) d)
(if (and an (or (equal (angle p a) an 1e-6) (equal (angle p a) (rem (+ pi an) (+ pi pi)) 1e-6) (if (or (equal an 0.0 1e-6) (equal an (* 2 pi) 1e-6)) (equal (angle p a) (* 2 pi) 1e-6))))
(setq bb a
d e
) ;_ setq
(setq b a
d e
) ;_ setq
) ;_ if
) ;_ if
) ;_ foreach
(cond
((and bb b (<= (distance p bb) (distance p b)))
(setq b bb) ;_ setq
)
((and bb b)
(setq bb b) ;_ setq
)
(bb
(setq b bb) ;_ setq
)
) ;_ cond
(setq pl (cons b pl)
l (vl-remove b l)
p b
b nil
bb nil
) ;_ setq
) ;_ while
(setq pl (reverse pl)) ;_ setq
(setq e nil
l pl
ll l
) ;_ setq
(while (and (not e) ll)
(setq e t
ll l
) ;_ setq
(while (and e ll)
(setq ll (if (listp (caar ll))
ll
(mapcar (function list) (cons (last ll) ll) ll)
) ;_ if
a (car ll)
pl (vl-remove-if (function (lambda (b) (or (member (car a) b) (member (cadr a) b))))
(cdr ll)
) ;_ vl-remove-if
ll (cdr ll)
) ;_ setq
(while (and pl (setq b (car pl)) (not (inters (car a) (cadr a) (car b) (cadr b))))
(setq pl (cdr pl))
) ;_ while
(if pl
(progn (setq l (append (member (car a) l) (reverse (cdr (member (car a) (reverse l)))))
l (append (list (car a)) (member (car b) (reverse (cdr l))) (member (cadr b) l)) ;;; (car a) (cadr a) + ... + (car b) (cadr b) + ... ->end ;;; => ;;; (car a) + (reversed (car b)->(cadr a)) + (not reversed (cadr b)->end)
e nil
) ;_ setq
) ;_ progn
) ;_ if
) ;_ while
) ;_ while
(setq e (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))) l)
) ;_ append
) ;_ entmakex
) ;_ setq
(princ (strcat "\nPolyline Length: "
(rtos (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)) 2 4)
" mm."
) ;_ strcat
) ;_ princ
(princ)
)
(test-lst-a (mapcar '(lambda ( x ) (cdr (assoc 10 (entget x)))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "POINT"))))))))
Hi All
Out of the various routines given by various people, which one is the latest / fastest / best ?
Hi AllThe latest is right before your post :-P .. the solutions in here vary based on the length of the list being processed. You'll have to test to see what works for you.
Out of the various routines given by various people, which one is the latest / fastest / best ?
I see there is no comment for my code...because the code is long and rather difficult to read and understand
(setq mid (reverse (cdr (member (cadr ilil) (reverse mid)))))
(setq mid (reverse mid))
i'm pretty sure it could be optimized more
at least some simple things asCode: [Select](setq mid (reverse (cdr (member (cadr ilil) (reverse mid)))))
(setq mid (reverse mid))
(setq mid (cdr (member (cadr ilil) (reverse mid))))
; ----- LISP : Call Stack -----
; [0]...C:TSP-2D-MR-LATEST-NEW
; [1].....DEPTH
; [2].......UNIQUE # 1108 <<--
;
; ----- Error around expression -----
; (EQUAL A B 1.0e-06)
;
; error : out of LISP 'Heap' memory at [gc]
: TSP-2D-MR-LATEST-NEW
Select points, blocks or circles in WCS...
Select entities:
Opposite Corner:
Entities in set: 40
Select entities:
Specify depth number - positive integer - from 0 to 32 <32> :
Specify number of solution attempts per depth iteration - preferable 50 <all> : 100
Specify number of list length processed by (processpt) sub function - preferable 2 <all> : 4
; ----- LISP : Call Stack -----
; [0]...C:TSP-2D-MR-LATEST-NEW
; [1].....DEPTH
; [2].......UNIQUE # 1130 <<--
;
; ----- Error around expression -----
; (CAR L)
;
; error : out of LISP 'Heap' memory at [gc]
: TSP-2D-MR-LATEST-NEW
Select points, blocks or circles in WCS...
Select entities:
Opposite Corner:
Entities in set: 40
Select entities:
Specify depth number - positive integer - from 0 to 32 <32> :
Specify number of solution attempts per depth iteration - preferable 50 <all> : 100
Specify number of list length processed by (processpt) sub function - preferable 2 <all> : 4
; ----- LISP : Call Stack -----
; [0]...C:TSP-2D-MR-LATEST-NEW
; [1].....DEPTH
; [2].......UNIQUE # 897 <<--
;
; ----- Error around expression -----
; (GC)
;
; error : out of LISP 'Heap' memory at [gc]
But this is really nothing in overall performance...this is true
(defun unique3 (l / x ll f1 f2)
(defun f1 (a b) (equal a b 1e-6))
(defun f2 (y) (vl-every 'f1 y (member (car y) x)))
(while (setq x (car l))
(setq ll (cons x ll)
x (append x x)
l (vl-remove-if 'f2 (cdr l))
)
)
ll
)
your algorithm is unchanged but it is written in a more 'optimized' wayI have a problem LISP crashed in BricsCAD with this message :Code: [Select]; ----- LISP : Call Stack -----
<clip>
; [0]...C:TSP-2D-MR-LATEST-NEW
; [1].....DEPTH
; [2].......UNIQUE # 1108 <<--
;
; ----- Error around expression -----
; (EQUAL A B 1.0e-06)
;
; error : out of LISP 'Heap' memory at [gc]
(length(atoms-family 1)) => 5519
:(progn
(_> (gc)
(_> (setq aList (atoms-family 1))
(_> (repeat 11 (setq aList (append aList aList)))
(_> (prompt "\nLength: ") (princ (length aList))
(_> (princ)
(_> )
Length: 11302912
: (progn
(_> (gc)
(_> (setq aList (atoms-family 1))
(_> (repeat 12 (setq aList (append aList aList)))
(_> (prompt "\nLength: ") (princ (length aList))
(_> (princ)
(_> )
; ----- Error around expression -----
; (APPEND ALIST ALIST)
;
; error : out of LISP 'Heap' memory at [gc]
But those are minimal improvements...i don't have bcad
But those are minimal improvements...i don't have bcad
can you benchmark TSP-2D-MR-LATEST-NEW with different versions of unique?
With my (unique) on BricsCAD :
: TSP-2D-MR-LATEST-NEW
Select points, blocks or circles in WCS...
Select entities:
Opposite Corner:
Entities in set: 40
Select entities:
Specify depth number - positive integer - from 0 to 32 <32> :
Specify number of solution attempts per depth iteration - preferable 50 <all> : 100
Specify number of list length processed by (processpt) sub function - preferable 2 <all> : 2
Distance : 19586.78862941693
Elapsed time : 157734 milliseconds...
With your (unique) on BricsCAD :
: TSP-2D-MR-LATEST-NEW
Select points, blocks or circles in WCS...
Select entities:
Opposite Corner:
Entities in set: 40
Select entities:
Specify depth number - positive integer - from 0 to 32 <32> :
Specify number of solution attempts per depth iteration - preferable 50 <all> : 100
Specify number of list length processed by (processpt) sub function - preferable 2 <all> : 2
Distance : 19586.78862941693
Elapsed time : 146703 milliseconds...
: TSP-2D-MR-LATEST-NEW
Select points, blocks or circles in WCS...
Select entities:
Opposite Corner:
Entities in set: 40
Select entities:
Specify depth number - positive integer - from 0 to 32 <32> :
Specify number of solution attempts per depth iteration - preferable 50 <all> : 100
Specify number of list length processed by (processpt) sub function - preferable 2 <all> : 2
Distance : 19586.78862941693
Elapsed time : 261766 milliseconds...
: TSP-2D-MR-LATEST-NEW
Select points, blocks or circles in WCS...
Select entities:
Opposite Corner:
Entities in set: 40
Select entities:
Specify depth number - positive integer - from 0 to 32 <32> :
Specify number of solution attempts per depth iteration - preferable 50 <all> : 100
Specify number of list length processed by (processpt) sub function - preferable 2 <all> : 2
Distance : 19586.78862941693
Elapsed time : 155390 milliseconds...
: TSP-2D-MR-LATEST-NEW
Select points, blocks or circles in WCS...
Select entities:
Opposite Corner:
Entities in set: 40
Select entities:
Specify depth number - positive integer - from 0 to 32 <32> :
Specify number of solution attempts per depth iteration - preferable 50 <all> : 100
Specify number of list length processed by (processpt) sub function - preferable 2 <all> : 2
Distance : 19586.78862941693
Elapsed time : 138094 milliseconds...
So it's faster...i benchmarked both functions - your original-while unique and mine unique3
_$ (length testlst)
500
_$ (length (unique testlst))
237
_$ (length (unique3 testlst))
237
_$ (BenchMark '((unique testlst) (unique3 testlst)))
Benchmarking ....Elapsed milliseconds / relative speed for 2 iteration(s):
(UNIQUE3 TESTLST).....1404 / 2.47 <fastest>
(UNIQUE TESTLST)......3463 / 1 <slowest>
as you can see those small 'technical' changes yield a big speed gainWhat else can you remedy in my routine VovKa?not me but you :)
I have a problem LISP crashed in BricsCAD with this message :Code: [Select]; ----- LISP : Call Stack -----
<clip>
; [0]...C:TSP-2D-MR-LATEST-NEW
; [1].....DEPTH
; [2].......UNIQUE # 1108 <<--
;
; ----- Error around expression -----
; (EQUAL A B 1.0e-06)
;
; error : out of LISP 'Heap' memory at [gc]
Keep in mind that the list with atoms-family is at the limit of the memory (also in AutoCAD) and depends on your starting atoms-family length:Code: [Select](length(atoms-family 1)) => 5519
:(progn
(_> (gc)
(_> (setq aList (atoms-family 1))
(_> (repeat 11 (setq aList (append aList aList)))
(_> (prompt "\nLength: ") (princ (length aList))
(_> (princ)
(_> )
Length: 11302912
: (progn
(_> (gc)
(_> (setq aList (atoms-family 1))
(_> (repeat 12 (setq aList (append aList aList)))
(_> (prompt "\nLength: ") (princ (length aList))
(_> (princ)
(_> )
; ----- Error around expression -----
; (APPEND ALIST ALIST)
;
; error : out of LISP 'Heap' memory at [gc]
(defun con_kpi(/ )
(setq;|a25930|;
kpi 3.14159265358979323846
kHalfPi 1.57079632679489661923
kTwoPi 6.28318530717958647692
kpi_max 3.14159265358979323846264338327950288
con_kpi kpi
con_kpi2 6.2831853071795865
)
It should be just slightly faster, but every improvement is welcomed...I compile your 'program (Greedy) to three-versions.(attached here).
Attachments updated here :
And also I want to post and mention for my triangulation implementation that differs from Delaunay as it creates concave hull instead of convex like Delaunay version... I don't want to place it in triangulation topic as this is far more
To write fast code, it is necessary to solve two problems.
1. Do not use the code extra computing - to come up with an algorithm, from which there is nothing to remove.
2. Add in the code checks to interrupt the bad cycles. Complex calculations can be represented as a tree. Let's say we're looking for the shortest branch. Then when checking another branch if it is already longer than the previous one, so there is no reason to continue the calculation of its length!
So long from me,this might be the longest post here on theswamp :)
Interesting approach by CADaSchtroumpf at autodesk forums by using temporary ellipse entity for sorting points... It should be very fast... I'll see to implement intersections checking... It's not difficult - just use that what I posted for @ahsattarian...
https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/challenge-generate-n-closed-plines-from-n-groups-of-points/m-p/11476934/highlight/true#M437651
Regards, M.R.
@gile
Can you try to convert lastly posted TSP.lsp to some kind of faster routine (TSP.dll)... What can we do when it's so slooow...
Anyway, I programmed it and it works well for me, it's just that it don't quite meet expectation time difference after finish...
Regards, M.R.
(vlce_cheapestpath Strategy Scale points)
Great link Dan !
result from the original test
result from the original test
Evgeniy's is : 3709.0141
http://www.theswamp.org/index.php?topic=30434.msg360448#msg360448
I suggest that you use this one (TSP-chlh-greedy.lsp) : http://www.theswamp.org/index.php?topic=30434.msg612620#msg612620
, as it's very fast, but results are not always the best - there are no bigger permutation parameters like "depth" from TSP-A.lsp...